shifted-bk selection iterates

plugins/dress_zmq/dress_slave.irp.f

@@ -56,7 +56,6 @@ subroutine run_wf
 !       call dress_slave_tcp(i+1, energy)
       call dress_slave_tcp(0, energy)
       !!$OMP END PARALLEL
-      print *,  'dress done'
     endif
 
   end do

plugins/dress_zmq/dress_stoch_routines.irp.f

@@ -122,14 +122,6 @@ subroutine ZMQ_dress(E, dress, delta_out, delta_s2_out, relative_error)
         block(block_i) = dress_jobs(i)
       end if
     end do
-    print *, "ACTUAL TASK NUM", ntas
-    !stop
-
-    !if (ipos > 1) then
-    !  if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
-    !    stop 'Unable to add task to task server'
-    !  endif
-    !endif
     if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
       print *,  irp_here, ': Failed in zmq_set_running'
     endif
@@ -196,7 +188,7 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
   double precision, save :: time0 = -1.d0
   double precision :: time
   double precision, external :: omp_get_wtime
-  integer :: cur_cp
+  integer :: cur_cp, last_cp
   integer :: delta_loc_cur, is, N_buf(3)
   integer, allocatable :: int_buf(:), agreg_for_cp(:)
   double precision, allocatable :: double_buf(:)
@@ -222,8 +214,6 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
       call wall_time(time0)
   endif
   logical :: loop, floop
-  integer :: finalcp
-  finalcp = N_cp*2
 
   floop = .true.
   loop = .true.
@@ -232,29 +222,23 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
     call pull_dress_results(zmq_socket_pull, ind, cur_cp, delta_loc, int_buf, double_buf, det_buf, N_buf, task_id, dress_mwen)
     if(floop) then
       call wall_time(time)
-      print *, "FIRST PULL", time-time0
       time0 = time
       floop = .false.
     end if
     if(cur_cp == -1 .and. ind == N_det_generators) then
       call wall_time(time)
-      print *, "FINISHED_CPL", N_cp-1, time-time0
     end if
     
     
     if(cur_cp == -1) then
-      !print *, "TASK DEL", task_id
       call dress_pulled(ind, int_buf, double_buf, det_buf, N_buf) 
       if (zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,1,more) == -1) then
-        print *, "TASK ID", task_id
         stop 'Unable to delete tasks'
       endif
-      !if(more == 0) stop 'loop = .false.' !!!!!!!!!!!!!!!!
+      if(more == 0)  loop = .false. !stop 'loop = .false.' !!!!!!!!!!!!!!!!
       dress_detail(:, ind) = dress_mwen(:)
     else if(cur_cp > 0) then
-      
       if(ind == 0) cycle
-      
       !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
       do i=1,N_det
         cp(:,i,cur_cp,1) += delta_loc(:,i,1)
@@ -273,8 +257,7 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
 
       call wall_time(time)
       
-      print *, "FINISHED_CP", cur_cp, time-time0
+      last_cp = cur_cp
-
       double precision :: su, su2, eqt, avg, E0, val
       integer, external :: zmq_abort
 
@@ -296,7 +279,7 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
       end if
 
       print '(2X, F16.7, 2X, G16.3, 2X, F16.4, A20)', avg+E(istate)+E0, eqt, time-time0, ''
-      if ((dabs(eqt) < relative_error .and. cps_N(cur_cp) >= 30) .or. cur_cp == N_cp) then
+      if ((dabs(eqt) < relative_error .and. cps_N(cur_cp) >= 30) .or. cur_cp == cur_cp-2) then
         ! Termination
         print *, "TERMINATE"
         if (zmq_abort(zmq_to_qp_run_socket) == -1) then
@@ -305,18 +288,14 @@ subroutine dress_collector(zmq_socket_pull, E, relative_error, delta, delta_s2,
             print *, irp_here, ': Error in sending abort signal (2)'
           endif
         endif                 
-        exit pullLoop
       endif
     end if
   end do pullLoop
-  print *, "exited"
 
+  delta(:,:) = cp(:,:,last_cp,1)
+  delta_s2(:,:) = cp(:,:,last_cp,2)
   
-  delta(:,:) = cp(:,:,cur_cp,1)
+  dress(istate) = E(istate)+E0+avg
-  delta_s2(:,:) = cp(:,:,cur_cp,2)
-  
-
-  dress(istate) = E(istate)+E0
   call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
 end subroutine
 
@@ -405,13 +384,11 @@ END_PROVIDER
   
   integer :: fragsize
   fragsize = N_det_generators / ((N_cps_max-1+1)*(N_cps_max-1+2)/2)
-  print *, "FRAGSIZE", fragsize
 
   do i=1,N_cps_max
     cp_limit(i) = fragsize * i * (i+1) / 2
   end do
   cp_limit(N_cps_max) = N_det*2
-  print *, "CP_LIMIT", cp_limit
 
   N_dress_jobs = first_det_of_comb - 1
   do i=1, N_dress_jobs
@@ -420,7 +397,7 @@ END_PROVIDER
   end do
   
   l=first_det_of_comb
-  call random_seed(put=(/321,654,65,321,65/))
+  call random_seed(put=(/321,654,65,321,65,321,654,65,321,65321,654,65,321,65321,654,65,321,65321,654,65,321,65/))
   call RANDOM_NUMBER(comb)
   lfiller = 1
   nfiller = 1
@@ -432,7 +409,6 @@ END_PROVIDER
     
     !if(N_dress_jobs / gen_per_cp > (cur_cp-1) .or. N_dress_jobs == N_det_generators) then
     if(N_dress_jobs > cp_limit(cur_cp) .or. N_dress_jobs == N_det_generators) then
-      print *, "END CUR_CP", cur_cp, N_dress_jobs
       first_cp(cur_cp+1) = N_dress_jobs
       done_cp_at(N_dress_jobs) = cur_cp
       cps_N(cur_cp) = dfloat(i)

plugins/dress_zmq/dressing.irp.f

@@ -100,7 +100,7 @@ BEGIN_PROVIDER [ double precision, delta_ij_tmp, (N_states,N_det_delta_ij,2) ]
 !  else
 !    errr = 1d-4
 !  end if
-  relative_error = 0d0! 1.d-5
+  relative_error = 1.d-5
 
   call write_double(6,relative_error,"Convergence of the stochastic algorithm")
 

plugins/dress_zmq/dressing_vector.irp.f

@@ -9,6 +9,7 @@
  integer :: i,ii,k,j, l
  double precision :: f, tmp
  double precision, external :: u_dot_v
+ logical, external :: detEq
 
  dressing_column_h(:,:) = 0.d0
  dressing_column_s(:,:) = 0.d0
@@ -17,6 +18,7 @@
    do j = 1, n_det
      dressing_column_h(j,k) = delta_ij(k,j,1) 
      dressing_column_s(j,k) = delta_ij(k,j,2)
+!     print *, j, delta_ij(k,j,:)
    enddo
 !   tmp = u_dot_v(dressing_column_h(1,k), psi_coef(1,k), N_det) &
 !     - dressing_column_h(l,k) * psi_coef(l,k)
@@ -25,6 +27,5 @@
 !     - dressing_column_s(l,k) * psi_coef(l,k)
 !   dressing_column_s(l,k) -= tmp * f
  enddo
-
 END_PROVIDER
 

plugins/dress_zmq/run_dress_slave.irp.f

@@ -81,8 +81,10 @@ subroutine run_dress_slave(thread,iproce,energy)
   done_for = 0
 
   double precision :: hij, sij
-  call i_h_j_s2(psi_det(1,1,1),psi_det(1,1,2),N_int,hij, sij)
+  !call i_h_j_s2(psi_det(1,1,1),psi_det(1,1,2),N_int,hij, sij)
-  print *, E0_denominator(1) 
+  
+  hij = E0_denominator(1)  !PROVIDE BEFORE OMP PARALLEL
+
   !$OMP PARALLEL DEFAULT(SHARED) &
   !$OMP PRIVATE(int_buf, double_buf, det_buf, delta_ij_loc, task, task_id) &
   !$OMP PRIVATE(lastSendable, toothMwen, fracted, fac) &
@@ -93,7 +95,6 @@ subroutine run_dress_slave(thread,iproce,energy)
   zmq_socket_push      = new_zmq_push_socket(thread)
   call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
   if(worker_id == -1) then
-    print *, "WORKER -1"
     call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
     call end_zmq_push_socket(zmq_socket_push,thread)
     stop "WORKER -1"
@@ -106,53 +107,13 @@ subroutine run_dress_slave(thread,iproce,energy)
   allocate(det_buf(N_int, 2, N_dress_det_buffer)) 
   allocate(delta_ij_loc(N_states,N_det,2)) 
   do
-    !!1$OMP CRITICAL (SENDAGE)
     call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
-    !!1$OMP END CRITICAL (SENDAGE)
     task = task//"  0"
-    if(task_id == 0) then
+    if(task_id == 0) exit
-      print *, "DONEDONE"
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      exit   !! LAST MESSAGE ???
+    if(task_id /= 0) then
-    end if
       read (task,*) subset, i_generator
 
-    
-    if(done_cp_at_det(i_generator) < lastCp(iproc)) stop 'loop = .false.'
-    !$OMP CRITICAL
-    send = .false.
-    lastSendable = N_cp*2
-    do i=1,Nproc
-      lastSendable = min(lastCp(i), lastSendable)
-    end do
-    lastSendable -= 1
-    if(lastSendable > lastSent) then
-      lastSent = lastSendable
-      send = .true.
-    end if
-    !$OMP END CRITICAL
-     
-    if(send) then
-      !!1$OMP CRITICAL
-      N_buf = (/0,1,0/)
-  
-      delta_ij_loc = 0d0
-      cur_cp = lastSent
-      if(cur_cp < 1) stop "cur_cp < 1"
-      do i=1,cur_cp
-        delta_ij_loc(:,:,:) += cp(:,:,i,:)
-      end do
-
-      delta_ij_loc(:,:,:) = delta_ij_loc(:,:,:) / cps_N(cur_cp)
-      do i=cp_first_tooth(cur_cp)-1,0,-1
-        delta_ij_loc(:,:,:) = delta_ij_loc(:,:,:) +delta_det(:,:,i,:)
-      end do
-      !!1$OMP END CRITICAL
-      !!1$OMP CRITICAL (SENDAGE)
-      call push_dress_results(zmq_socket_push, done_for(cur_cp), cur_cp, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, -1)
-      !!1$OMP END CRITICAL (SENDAGE)
-    end if
-
-
       !$OMP ATOMIC
       done_for(done_cp_at_det(i_generator)) += 1
 
@@ -161,7 +122,6 @@ subroutine run_dress_slave(thread,iproce,energy)
       call alpha_callback(delta_ij_loc, i_generator, subset, iproc)
       call generator_done(i_generator, int_buf, double_buf, det_buf, N_buf, iproc)
      
-    !!1$OMP CRITICAL
       do i=1,N_cp
         fac = cps(i_generator, i) * dress_weight_inv(i_generator) * comb_step
         if(fac == 0d0) cycle
@@ -190,17 +150,45 @@ subroutine run_dress_slave(thread,iproce,energy)
         delta_det(:,:,toothMwen  , 2) += delta_ij_loc(:,:,2)
         call omp_unset_lock(lck_det(toothMwen))
       end if
-    !!!&$OMP END CRITICAL
-
-    !!1$OMP CRITICAL (SENDAGE)
       call push_dress_results(zmq_socket_push, i_generator, -1, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, task_id)
       call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
-    !!1$OMP END CRITICAL (SENDAGE)
       lastCp(iproc) = done_cp_at_det(i_generator) 
+    end if
+
+    !$OMP CRITICAL
+    send = .false.
+    lastSendable = N_cp*2
+    do i=1,Nproc
+      lastSendable = min(lastCp(i), lastSendable)
+    end do
+    lastSendable -= 1
+    if(lastSendable > lastSent .or. (lastSendable == N_cp-1 .and. lastSent /= N_cp-1)) then
+      lastSent = lastSendable
+      cur_cp = lastSent
+      send = .true.
+    end if
+    !$OMP END CRITICAL
+    
+    if(send) then
+      N_buf = (/0,1,0/)
+
+      delta_ij_loc = 0d0
+      if(cur_cp < 1) stop "cur_cp < 1"
+      do i=1,cur_cp
+        delta_ij_loc(:,:,:) += cp(:,:,i,:)
       end do
 
-  call sleep(10) 
+      delta_ij_loc(:,:,:) = delta_ij_loc(:,:,:) / cps_N(cur_cp)
-  call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
+      do i=cp_first_tooth(cur_cp)-1,0,-1
+        delta_ij_loc(:,:,:) = delta_ij_loc(:,:,:) +delta_det(:,:,i,:)
+      end do
+      call push_dress_results(zmq_socket_push, done_for(cur_cp), cur_cp, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, -1)
+    end if
+
+    if(task_id == 0) exit
+  end do
+  
+  call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id)
   call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
   call end_zmq_push_socket(zmq_socket_push,thread)
   !$OMP END PARALLEL
@@ -211,7 +199,6 @@ subroutine run_dress_slave(thread,iproce,energy)
   do i=0,comb_teeth+1
     call omp_destroy_lock(lck_det(i))
   end do
-  stop
 end subroutine
 
 
@@ -221,6 +208,7 @@ subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf,
   use f77_zmq
   implicit none
   
+  integer, parameter :: sendt = 4
   integer(ZMQ_PTR), intent(in)   :: zmq_socket_push
   double precision, intent(inout)   :: delta_loc(N_states, N_det, 2)
   real(kind=4), allocatable   :: delta_loc4(:,:,:)
@@ -232,7 +220,7 @@ subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf,
   integer, intent(in) :: ind, cur_cp, task_id
   integer :: rc, i, j, k, l
   double precision :: contrib(N_states)
-  real(4), allocatable :: r4buf(:,:,:)
+  real(sendt), allocatable :: r4buf(:,:,:)
   
     rc = f77_zmq_send( zmq_socket_push, ind, 4, ZMQ_SNDMORE)
   if(rc /= 4) stop "push"
@@ -246,16 +234,16 @@ subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf,
     do i=1,2
     do j=1,N_det
     do k=1,N_states
-       r4buf(k,j,i) = real(delta_loc(k,j,i), 4)
+       r4buf(k,j,i) = real(delta_loc(k,j,i), sendt)
     end do
     end do
     end do
 
-    rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,1), 4*N_states*N_det, ZMQ_SNDMORE)
+    rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,1), sendt*N_states*N_det, ZMQ_SNDMORE)
-    if(rc /= 4*N_states*N_det) stop "push"
+    if(rc /= sendt*N_states*N_det) stop "push"
 
-    rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,2), 4*N_states*N_det, ZMQ_SNDMORE)
+    rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,2), sendt*N_states*N_det, ZMQ_SNDMORE)
-    if(rc /= 4*N_states*N_det) stop "push"
+    if(rc /= sendt*N_states*N_det) stop "push"
   else
     contrib = 0d0
     do i=1,N_det
@@ -266,7 +254,7 @@ subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf,
     if(rc /= 8*N_states) stop "push"
     
     N_buf = N_bufi
-    N_buf = (/0,1,0/)
+    !N_buf = (/0,1,0/)
 
     rc = f77_zmq_send( zmq_socket_push, N_buf, 4*3, ZMQ_SNDMORE)
     if(rc /= 4*3) stop "push5" 
@@ -313,6 +301,7 @@ END_PROVIDER
 subroutine pull_dress_results(zmq_socket_pull, ind, cur_cp, delta_loc, int_buf, double_buf, det_buf, N_buf, task_id, contrib)
   use f77_zmq
   implicit none
+  integer, parameter :: sendt = 4
   integer(ZMQ_PTR), intent(in)   :: zmq_socket_pull
   integer, intent(out) :: cur_cp
   double precision, intent(inout) :: delta_loc(N_states, N_det, 2)
@@ -335,11 +324,11 @@ subroutine pull_dress_results(zmq_socket_pull, ind, cur_cp, delta_loc, int_buf,
 
   if(cur_cp /= -1) then
     
-    rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,1), N_states*4*N_det, 0)
+    rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,1), N_states*sendt*N_det, 0)
-    if(rc /= 4*N_states*N_det) stop "pullc"
+    if(rc /= sendt*N_states*N_det) stop "pullc"
   
-    rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,2), N_states*4*N_det, 0)
+    rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,2), N_states*sendt*N_det, 0)
-    if(rc /= 4*N_states*N_det) stop "pulld"
+    if(rc /= sendt*N_states*N_det) stop "pulld"
     
     do i=1,2
     !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(j,k)

plugins/shiftedbk/selection_buffer.irp.f

@@ -8,7 +8,6 @@ subroutine create_selection_buffer(N, siz_, res)
 
   integer :: siz
   siz = max(siz_,1)
- 
   allocate(res%det(N_int, 2, siz), res%val(siz))
 
   res%val(:) = 0d0
@@ -18,19 +17,6 @@ subroutine create_selection_buffer(N, siz_, res)
   res%cur = 0
 end subroutine
 
-subroutine reset_selection_buffer(res)
-  use selection_types
-  implicit none
-
-  type(selection_buffer), intent(out) :: res
-
-  res%val(:) = 0d0
-  res%det(:,:,:) = 0_8
-  res%mini = 0d0
-  res%cur = 0
-end subroutine
-
-
 subroutine delete_selection_buffer(b)
   use selection_types
   implicit none
@@ -53,7 +39,7 @@ subroutine add_to_selection_buffer(b, det, val)
   double precision, intent(in) :: val
   integer :: i
 
-  if(b%N > 0 .and. val < b%mini) then
+  if(b%N > 0 .and. val <= b%mini) then
     b%cur += 1
     b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2)
     b%val(b%cur) = val

plugins/shiftedbk/selection_types.f90

@@ -0,0 +1,9 @@
+module selection_types
+  type selection_buffer
+    integer :: N, cur
+    integer(8)      , pointer :: det(:,:,:)
+    double precision, pointer :: val(:)
+    double precision          :: mini
+  endtype
+end module
+

plugins/shiftedbk/shifted_bk_routines.irp.f

@@ -33,7 +33,6 @@ END_PROVIDER
  END_PROVIDER
 
 
-<<<<<<< HEAD
  BEGIN_PROVIDER [ integer, N_dress_int_buffer ]
 &BEGIN_PROVIDER [ integer, N_dress_double_buffer ]
 &BEGIN_PROVIDER [ integer, N_dress_det_buffer ]
@@ -197,14 +196,15 @@ subroutine undress_with_alpha(old_generators, old_det_gen, alpha, n_alpha)
     c_alpha(:,1) += c_alpha(:,i)
   end do
   
-  delta_ij_tmp(:,:,:) -= delta_ij_loc(:,:,:,1)
+  delta_ij_tmp(:,:,1) -= delta_ij_loc(:,:,1,1)
+  delta_ij_tmp(:,:,2) -= delta_ij_loc(:,:,2,1) 
   
-  
+  !print *, "SUM ALPHA2  PRE", global_sum_alpha2
-  print *, "SUM ALPHA2  PRE", global_sum_alpha2
   !global_sum_alpha2(:) -= c_alpha(:,1)
-  print *, "SUM ALPHA2 POST", c_alpha(:,1)
+  print *, "SUM C_ALPHA^2 ", global_sum_alpha2(:)
+  print *, "*** DRESSINS DIVIDED BY 1+SUM C_ALPHA^2 ***"
   do i=1,N_states
- !   delta_ij_tmp(i,:,:) = delta_ij_tmp(i,:,:) / (1d0 + global_sum_alpha2(i))
+    delta_ij_tmp(i,:,:) = delta_ij_tmp(i,:,:) / (1d0 + global_sum_alpha2(i))
   end do
   global_sum_alpha2 = 0d0 
 end subroutine
@@ -257,6 +257,10 @@ subroutine dress_with_alpha_(Nstates,Ndet,Nint,delta_ij_loc,minilist, det_minili
     do l_sd=1,n_minilist
       hdress = c_alpha(i) * a_h_i(l_sd, iproc)
       sdress = c_alpha(i) * a_s2_i(l_sd, iproc)
+      !if(c_alpha(i) * a_s2_i(l_sd, iproc) > 1d-1) then
+      !  call debug_det(det_minilist(1,1,l_sd), N_int)
+      !  call debug_det(alpha,N_int)
+      !end if
       delta_ij_loc(i, minilist(l_sd), 1) += hdress
       delta_ij_loc(i, minilist(l_sd), 2) += sdress
     end do