fixed custom buffers

plugins/dress_zmq/dress_general.irp.f

@@ -45,7 +45,7 @@ subroutine run_dressing(N_st,energy)
       do i=1,N_st
         if(.true.) call write_double(6,ci_energy_dressed(i),"Energy")
       enddo
-      call diagonalize_ci_dressed
+      if(.true.) call diagonalize_ci_dressed
       E_new = dress_e0_denominator(1) !sum(ci_energy_dressed(1:N_states))
 
       delta_E = (E_new - E_old)/dble(N_states)

plugins/dress_zmq/dress_slave.irp.f

@@ -6,6 +6,10 @@ subroutine dress_slave
   read_wf = .False.
   distributed_davidson = .False.
   SOFT_TOUCH read_wf distributed_davidson
+  
+  threshold_selectors = 1.d0
+  threshold_generators = 1d0 
+ 
   call provide_everything
   call switch_qp_run_to_master
   call run_wf
@@ -67,6 +71,6 @@ subroutine dress_slave_tcp(i,energy)
   integer, intent(in)            :: i
   logical :: lstop
   lstop = .False.
-  call run_dress_slave(0,i,energy,lstop)
+  call run_dress_slave(0,i,energy)
 end
 

plugins/dress_zmq/dress_stoch_routines.irp.f

@@ -211,7 +211,7 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
   felem = N_det+1
   pullLoop : do while (loop)
     call pull_dress_results(zmq_socket_pull, ind, delta_loc(1,1,1,delta_loc_cur), int_buf, double_buf, det_buf, N_buf, task_id, felem_loc)
-    call dress_pulled(int_buf, double_buf, det_buf, N_buf) 
+    call dress_pulled(ind, int_buf, double_buf, det_buf, N_buf) 
     felem = min(felem_loc, felem)
     dress_mwen(:) = 0d0
  

plugins/dress_zmq/dress_zmq_routines.irp.f

@@ -2,6 +2,8 @@ subroutine dress_zmq()
   implicit none
   double precision, allocatable  :: energy(:)
   allocate (energy(N_states))
+  threshold_selectors = 1.d0
+  threshold_generators = 1d0 
 
   read_wf = .True.
   SOFT_TOUCH read_wf

plugins/dress_zmq/dressing.irp.f

@@ -93,8 +93,8 @@ BEGIN_PROVIDER [ double precision, delta_ij_tmp, (N_states,N_det_delta_ij,2) ]
   delta_ij_tmp = 0d0
 
   E_CI_before(:) = dress_E0_denominator(:) + nuclear_repulsion
-  threshold_selectors = 1.d0
+  !threshold_selectors = 1.d0
-  threshold_generators = 1d0 
+  !:threshold_generators = 1d0 
 !  if(errr /= 0d0) then
 !    errr = errr / 2d0 
 !  else

plugins/dress_zmq/run_dress_slave.irp.f

@@ -36,6 +36,15 @@ subroutine run_dress_slave(thread,iproc,energy)
   integer :: h,p,n,i_state
   logical :: ok
 
+  integer, allocatable :: int_buf(:)
+  double precision, allocatable :: double_buf(:)
+  integer(bit_kind), allocatable :: det_buf(:,:,:)
+  integer :: N_buf(3)
+
+
+  allocate(int_buf(N_dress_int_buffer)) 
+  allocate(double_buf(N_dress_double_buffer)) 
+  allocate(det_buf(N_int, 2, N_dress_det_buffer)) 
   allocate(delta_ij_loc(N_states,N_det,2)) 
   
   zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
@@ -55,10 +64,11 @@ subroutine run_dress_slave(thread,iproc,energy)
     if(task_id /= 0) then
       read (task,*) subset, i_generator
       delta_ij_loc = 0d0
+      call generator_start(i_generator, iproc)
       call alpha_callback(delta_ij_loc, i_generator, subset, iproc)
-      call generator_done(i_generator)
+      call generator_done(i_generator, int_buf, double_buf, det_buf, N_buf, iproc)
       call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
-      call push_dress_results(zmq_socket_push, i_generator, delta_ij_loc, task_id)
+      call push_dress_results(zmq_socket_push, i_generator, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, task_id)
     else
       exit
     end if
@@ -69,23 +79,28 @@ subroutine run_dress_slave(thread,iproc,energy)
 end subroutine
 
 
- BEGIN_PROVIDER [ integer, dress_int_buffer, (N_dress_int_buffer) ]
+! BEGIN_PROVIDER [ integer, dress_int_buffer, (N_dress_int_buffer) ]
-&BEGIN_PROVIDER [ double precision, dress_double_buffer, (N_dress_double_buffer) ]
+!&BEGIN_PROVIDER [ double precision, dress_double_buffer, (N_dress_double_buffer) ]
-&BEGIN_PROVIDER [ integer(bit_kind), dress_det_buffer, (N_int, 2, N_dress_det_buffer) ]
+!&BEGIN_PROVIDER [ integer(bit_kind), dress_det_buffer, (N_int, 2, N_dress_det_buffer) ]
-  implicit none
+!  implicit none
-  
+!  
-  dress_int_buffer = 0
+!  dress_int_buffer = 0
-  dress_double_buffer = 0d0
+!  dress_double_buffer = 0d0
-  dress_det_buffer = 0_bit_kind
+ ! dress_det_buffer = 0_bit_kind
-END_PROVIDER
+!END_PROVIDER
 
 
-subroutine push_dress_results(zmq_socket_push, ind, delta_loc, task_id)
+!subroutine pull_dress_results(zmq_socket_pull, ind, delta_loc, int_buf, double_buf, det_buf, N_buf, task_id, felem)
+subroutine push_dress_results(zmq_socket_push, ind, delta_loc, int_buf, double_buf, det_buf, N_buf, task_id)
   use f77_zmq
   implicit none
 
   integer(ZMQ_PTR), intent(in)   :: zmq_socket_push
   double precision, intent(in)   :: delta_loc(N_states, N_det, 2)
+  double precision, intent(in) :: double_buf(*)
+  integer, intent(in) :: int_buf(*)
+  integer(bit_kind), intent(in) :: det_buf(N_int, 2, *)
+  integer, intent(in) :: N_buf(3)
   integer, intent(in) :: ind, task_id
   integer :: rc, i, j, felem
 
@@ -115,28 +130,31 @@ subroutine push_dress_results(zmq_socket_push, ind, delta_loc, task_id)
  
  
 
-  rc = f77_zmq_send( zmq_socket_push, N_dress_int_buffer, 4, ZMQ_SNDMORE)
+  rc = f77_zmq_send( zmq_socket_push, N_buf, 4*3, ZMQ_SNDMORE)
-  if(rc /= 4) stop "push" 
+  if(rc /= 4*3) stop "push5" 
   
-  rc = f77_zmq_send( zmq_socket_push, dress_int_buffer, 4*N_dress_int_buffer, ZMQ_SNDMORE)
+  if(N_buf(1) > N_dress_int_buffer) stop "run_dress_slave N_buf bad size?"
-  if(rc /= 4*N_dress_int_buffer) stop "push"
+  if(N_buf(2) > N_dress_double_buffer) stop "run_dress_slave N_buf bad size?"
+  if(N_buf(3) > N_dress_det_buffer) stop "run_dress_slave N_buf bad size?"
 
-  rc = f77_zmq_send( zmq_socket_push, N_dress_double_buffer, 4, ZMQ_SNDMORE)
-  if(rc /= 4) stop "push" 
-  
-  rc = f77_zmq_send( zmq_socket_push, dress_double_buffer, 8*N_dress_double_buffer, ZMQ_SNDMORE)
-  if(rc /= 8*N_dress_double_buffer) stop "push"
- 
 
-  rc = f77_zmq_send( zmq_socket_push, N_dress_det_buffer, 4, ZMQ_SNDMORE)
+  if(N_buf(1) > 0) then
-  if(rc /= 4) stop "push" 
+    rc = f77_zmq_send( zmq_socket_push, int_buf, 4*N_buf(1), ZMQ_SNDMORE)
+    if(rc /= 4*N_buf(1)) stop "push6"
+  end if
   
-  rc = f77_zmq_send( zmq_socket_push, dress_det_buffer, 2*N_int*bit_kind*N_dress_det_buffer, ZMQ_SNDMORE)
+  if(N_buf(2) > 0) then
-  if(rc /= 2*N_int*bit_kind*N_dress_det_buffer) stop "push"
+    rc = f77_zmq_send( zmq_socket_push, double_buf, 8*N_buf(2), ZMQ_SNDMORE)
- 
+    if(rc /= 8*N_buf(2)) stop "push8"
+  end if
+
+  if(N_buf(3) > 0) then
+    rc = f77_zmq_send( zmq_socket_push, det_buf, 2*N_int*bit_kind*N_buf(3), ZMQ_SNDMORE)
+    if(rc /= 2*N_int*bit_kind*N_buf(3)) stop "push10"
+  end if
 
   rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
-  if(rc /= 4) stop "push"
+  if(rc /= 4) stop "push11"
 
 ! Activate is zmq_socket_push is a REQ
 IRP_IF ZMQ_PUSH
@@ -164,49 +182,44 @@ subroutine pull_dress_results(zmq_socket_pull, ind, delta_loc, int_buf, double_b
 
 
   rc = f77_zmq_recv( zmq_socket_pull, ind, 4, 0)
-  if(rc /= 4) stop "pull"
+  if(rc /= 4) stop "pulla"
   
   rc = f77_zmq_recv( zmq_socket_pull, felem, 4, 0)
-  if(rc /= 4) stop "pull"
+  if(rc /= 4) stop "pullb"
   
   delta_loc(:,:felem,:) = 0d0
 
   rc = f77_zmq_recv( zmq_socket_pull, delta_loc(1,felem,1), N_states*8*(N_det+1-felem), 0)
-  if(rc /= 8*N_states*(N_det+1-felem)) stop "pull"
+  if(rc /= 8*N_states*(N_det+1-felem)) stop "pullc"
   
   rc = f77_zmq_recv( zmq_socket_pull, delta_loc(1,felem,2), N_states*8*(N_det+1-felem), 0)
-  if(rc /= 8*N_states*(N_det+1-felem)) stop "pull"
+  if(rc /= 8*N_states*(N_det+1-felem)) stop "pulld"
 
 
-  rc = f77_zmq_recv( zmq_socket_pull, N_buf(1), 4, 0)
+  rc = f77_zmq_recv( zmq_socket_pull, N_buf, 4*3, 0)
-  if(rc /= 4) stop "pull" 
+  if(rc /= 4*3) stop "pull" 
   if(N_buf(1) > N_dress_int_buffer) stop "run_dress_slave N_buf bad size?"
-
-  
-  rc = f77_zmq_recv( zmq_socket_pull, int_buf, 4*N_buf(1), 0)
-  if(rc /= 4*N_buf(1)) stop "pull1"
-
-
-  rc = f77_zmq_recv( zmq_socket_pull, N_buf(2), 4, 0)
-  if(rc /= 4) stop "pull" 
   if(N_buf(2) > N_dress_double_buffer) stop "run_dress_slave N_buf bad size?"
-  
-  rc = f77_zmq_recv( zmq_socket_pull, double_buf, 8*N_buf(2), 0)
-  if(rc /= 8*N_buf(2)) stop "pull2"
-  
-
-
-
-  rc = f77_zmq_recv( zmq_socket_pull, N_buf(3), 4, 0)
-  if(rc /= 4) stop "pull" 
   if(N_buf(3) > N_dress_det_buffer) stop "run_dress_slave N_buf bad size?"
+
   
-  rc = f77_zmq_recv( zmq_socket_pull, det_buf, 2*N_int*bit_kind*N_buf(3), 0)
+  if(N_buf(1) > 0) then
-  if(rc /= 2*N_int*bit_kind*N_buf(3)) stop "pull3"
+    rc = f77_zmq_recv( zmq_socket_pull, int_buf, 4*N_buf(1), 0)
- 
+    if(rc /= 4*N_buf(1)) stop "pull1"
+  end if
+  
+  if(N_buf(2) > 0) then
+    rc = f77_zmq_recv( zmq_socket_pull, double_buf, 8*N_buf(2), 0)
+    if(rc /= 8*N_buf(2)) stop "pull2"
+  end if
+  
+  if(N_buf(3) > 0) then
+    rc = f77_zmq_recv( zmq_socket_pull, det_buf, 2*N_int*bit_kind*N_buf(3), 0)
+    if(rc /= 2*N_int*bit_kind*N_buf(3)) stop "pull3"
+  end if
 
   rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
-  if(rc /= 4) stop "pull"
+  if(rc /= 4) stop "pull4"
 
 ! Activate is zmq_socket_pull is a REP
 IRP_IF ZMQ_PUSH

plugins/shiftedbk/shifted_bk.irp.f

@@ -11,7 +11,7 @@ program shifted_bk
   PROVIDE psi_bilinear_matrix_transp_order
 
 
-  call diagonalize_CI()
+  !call diagonalize_CI()
   call dress_zmq()
 end
 

plugins/shiftedbk/shifted_bk_routines.irp.f

@@ -1,30 +1,21 @@
 use selection_types
 
-
- BEGIN_PROVIDER [ integer, N_dress_int_buffer ]
-&BEGIN_PROVIDER [ integer, N_dress_double_buffer ]
-&BEGIN_PROVIDER [ integer, N_dress_det_buffer ]
-  implicit none
-  N_dress_int_buffer = 1
-  N_dress_double_buffer = 1
-  N_dress_det_buffer = 1
-END_PROVIDER
-
-
  BEGIN_PROVIDER [ double precision, fock_diag_tmp_, (2,mo_tot_num+1,Nproc) ]
-&BEGIN_PROVIDER [ integer, current_generator_, (Nproc) ]
+&BEGIN_PROVIDER [ integer, n_det_add ]
 &BEGIN_PROVIDER [ double precision, a_h_i, (N_det, Nproc) ]
 &BEGIN_PROVIDER [ double precision, a_s2_i, (N_det, Nproc) ]
 &BEGIN_PROVIDER [ type(selection_buffer), sb, (Nproc) ]
+&BEGIN_PROVIDER [ type(selection_buffer), global_sb ]
+&BEGIN_PROVIDER [ type(selection_buffer), mini_sb ]
 &BEGIN_PROVIDER [ double precision, N_det_increase_factor ]
   implicit none
   integer :: i
-  integer :: n_det_add
   
   N_det_increase_factor = 1d0
 
-  current_generator_(:) = 0
   n_det_add = max(1, int(float(N_det) * N_det_increase_factor))
+  call create_selection_buffer(n_det_add, n_det_add*2, global_sb)
+  call create_selection_buffer(n_det_add, n_det_add*2, mini_sb)
   do i=1,Nproc
     call create_selection_buffer(n_det_add, n_det_add*2, sb(i))
   end do
@@ -32,46 +23,82 @@ END_PROVIDER
   a_s2_i = 0d0
  END_PROVIDER
 
-subroutine generator_done(i_gen)
+
+ BEGIN_PROVIDER [ integer, N_dress_int_buffer ]
+&BEGIN_PROVIDER [ integer, N_dress_double_buffer ]
+&BEGIN_PROVIDER [ integer, N_dress_det_buffer ]
   implicit none
-  integer, intent(in) :: i_gen
+  N_dress_int_buffer = 1
+  N_dress_double_buffer = n_det_add
+  N_dress_det_buffer = n_det_add
+END_PROVIDER
+
+
+subroutine generator_done(i_gen, int_buf, double_buf, det_buf, N_buf, iproc)
+  implicit none
+  integer, intent(in) :: i_gen, iproc
+  integer, intent(out) :: int_buf(N_dress_int_buffer), N_buf(3)
+  double precision, intent(out) :: double_buf(N_dress_double_buffer)
+  integer(bit_kind), intent(out) :: det_buf(N_int, 2, N_dress_det_buffer)
+  integer :: i
   
-  !dress_int_buffer = ...
+    call sort_selection_buffer(sb(iproc))
+    det_buf(:,:,:sb(iproc)%cur) = sb(iproc)%det(:,:,:sb(iproc)%cur)
+    double_buf(:sb(iproc)%cur) = sb(iproc)%val(:sb(iproc)%cur)
+    if(sb(iproc)%cur > 0) then
+      !$OMP CRITICAL
+      call merge_selection_buffers(sb(iproc), mini_sb)
+      call sort_selection_buffer(mini_sb)
+      do i=1,Nproc
+        sb(i)%mini = min(sb(i)%mini, mini_sb%mini)
+      end do
+      !$OMP END CRITICAL
+    end if
+    N_buf(1) = 1
+    N_buf(2) = sb(iproc)%cur
+    N_buf(3) = sb(iproc)%cur
+    sb(iproc)%cur = 0
 end subroutine
 
 
-subroutine dress_pulled(int_buf, double_buf, det_buf, N_buf)
+subroutine generator_start(i_gen, iproc)
+  implicit none
+  integer, intent(in) :: i_gen, iproc
+  integer :: i
+  
+  call build_fock_tmp(fock_diag_tmp_(1,1,iproc),psi_det_generators(1,1,i_gen),N_int)
+end subroutine
+
+
+subroutine dress_pulled(ind, int_buf, double_buf, det_buf, N_buf)
   use bitmasks
   implicit none
   
-  integer, intent(in) :: N_buf(3)
+  integer, intent(in) :: ind, N_buf(3)
   integer, intent(in) :: int_buf(*)
   double precision, intent(in) :: double_buf(*)
   integer(bit_kind), intent(in) :: det_buf(N_int,2,*)
-
+  integer :: i
+  
+  do i=1,N_buf(2)
+    call add_to_selection_buffer(global_sb, det_buf(1,1,i), double_buf(i))
+  end do
 end subroutine
 
 
 subroutine delta_ij_done()
   use bitmasks
   implicit none
-  integer :: i, n_det_add, old_det_gen
+  integer :: i, old_det_gen
   integer(bit_kind), allocatable :: old_generators(:,:,:)
   
   allocate(old_generators(N_int, 2, N_det_generators))
   old_generators(:,:,:) = psi_det_generators(:,:,:N_det_generators)
   old_det_gen = N_det_generators
  
-  call sort_selection_buffer(sb(1))
 
-  do i=2,Nproc
+  call sort_selection_buffer(global_sb)
-    call sort_selection_buffer(sb(i))
+  call fill_H_apply_buffer_no_selection(global_sb%cur,global_sb%det,N_int,0) 
-    call merge_selection_buffers(sb(i), sb(1))
-  end do
-  
-  call sort_selection_buffer(sb(1))
-  
-  call fill_H_apply_buffer_no_selection(sb(1)%cur,sb(1)%det,N_int,0) 
   call copy_H_apply_buffer_to_wf()
 
   if (s2_eig.or.(N_states > 1) ) then
@@ -226,17 +253,13 @@ subroutine dress_with_alpha_buffer(Nstates,Ndet,Nint,delta_ij_loc, i_gen, minili
 
 
   
-  if(current_generator_(iproc) /= i_gen) then
-    current_generator_(iproc) = i_gen
-    call build_fock_tmp(fock_diag_tmp_(1,1,iproc),psi_det_generators(1,1,i_gen),N_int)
-  end if
-
   haa = diag_H_mat_elem_fock(psi_det_generators(1,1,i_gen),alpha,fock_diag_tmp_(1,1,iproc),N_int)
   
   call dress_with_alpha_(Nstates, Ndet, Nint, delta_ij_loc, minilist, det_minilist, n_minilist, alpha, haa, contrib, iproc)
-  
+ 
-  call add_to_selection_buffer(sb(iproc), alpha, contrib)
+  if(contrib < sb(iproc)%mini) then
-
+    call add_to_selection_buffer(sb(iproc), alpha, contrib)
+  end if
 end subroutine
 
 

plugins/shiftedbk/shifted_bk_slave.irp.f

@@ -10,7 +10,7 @@ program shifted_bk
   PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
   PROVIDE psi_bilinear_matrix_transp_order
 
-  call diagonalize_CI()
+  !call diagonalize_CI()
   call dress_slave()
 end