Merge pull request #50 from QuantumPackage/bugfix

Fix bug with deterministic PT2

src/cipsi/run_pt2_slave.irp.f

@@ -148,7 +148,7 @@ subroutine run_pt2_slave_small(thread,iproc,energy)
   integer, external :: disconnect_from_taskserver
   do i=1,300
     if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) /= -2) exit
-    call sleep(1)
+    call usleep(500)
     print *,  'Retry disconnect...'
   end do
 

src/cipsi/run_selection_slave.irp.f

@@ -74,7 +74,7 @@ subroutine run_selection_slave(thread,iproc,energy)
     if(done .or. ctask == size(task_id)) then
       do i=1, ctask
          if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
-           call sleep(1)
+           call usleep(100)
           if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
             ctask = 0
             done = .true.
@@ -85,6 +85,7 @@ subroutine run_selection_slave(thread,iproc,energy)
       if(ctask > 0) then
         call sort_selection_buffer(buf)
 !        call merge_selection_buffers(buf,buf2)
+print *, task_id(1), pt2(1), buf%cur, ctask
         call push_selection_results(zmq_socket_push, pt2, variance, norm, buf, task_id(1), ctask)
 !        buf%mini = buf2%mini
         pt2(:) = 0d0
@@ -132,23 +133,24 @@ subroutine push_selection_results(zmq_socket_push, pt2, variance, norm, b, task_
     print *,  'f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)'
   endif
 
+
+  rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE)
+  if(rc /= 8*N_states) then
+    print *,  'f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE)'
+  endif
+
+  rc = f77_zmq_send( zmq_socket_push, variance, 8*N_states, ZMQ_SNDMORE)
+  if(rc /= 8*N_states) then
+    print *,  'f77_zmq_send( zmq_socket_push, variance, 8*N_states, ZMQ_SNDMORE)'
+  endif
+
+  rc = f77_zmq_send( zmq_socket_push, norm, 8*N_states, ZMQ_SNDMORE)
+  if(rc /= 8*N_states) then
+    print *,  'f77_zmq_send( zmq_socket_push, norm, 8*N_states, ZMQ_SNDMORE)'
+  endif
+
   if (b%cur > 0) then
 
-      rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE)
-      if(rc /= 8*N_states) then
-        print *,  'f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE)'
-      endif
-
-      rc = f77_zmq_send( zmq_socket_push, variance, 8*N_states, ZMQ_SNDMORE)
-      if(rc /= 8*N_states) then
-        print *,  'f77_zmq_send( zmq_socket_push, variance, 8*N_states, ZMQ_SNDMORE)'
-      endif
-
-      rc = f77_zmq_send( zmq_socket_push, norm, 8*N_states, ZMQ_SNDMORE)
-      if(rc /= 8*N_states) then
-        print *,  'f77_zmq_send( zmq_socket_push, norm, 8*N_states, ZMQ_SNDMORE)'
-      endif
-
       rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
       if(rc /= 8*b%cur) then
         print *,  'f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)'
@@ -203,22 +205,26 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, variance, norm, val, det
     print *,  'f77_zmq_recv( zmq_socket_pull, N, 4, 0)'
   endif
 
+  pt2(:) = 0.d0
+  variance(:) = 0.d0
+  norm(:) = 0.d0
+
+  rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0)
+  if(rc /= 8*N_states) then
+    print *,  'f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0)'
+  endif
+
+  rc = f77_zmq_recv( zmq_socket_pull, variance, N_states*8, 0)
+  if(rc /= 8*N_states) then
+    print *,  'f77_zmq_recv( zmq_socket_pull, variance, N_states*8, 0)'
+  endif
+
+  rc = f77_zmq_recv( zmq_socket_pull, norm, N_states*8, 0)
+  if(rc /= 8*N_states) then
+    print *,  'f77_zmq_recv( zmq_socket_pull, norm, N_states*8, 0)'
+  endif
+
   if (N>0) then
-      rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0)
-      if(rc /= 8*N_states) then
-        print *,  'f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0)'
-      endif
-
-      rc = f77_zmq_recv( zmq_socket_pull, variance, N_states*8, 0)
-      if(rc /= 8*N_states) then
-        print *,  'f77_zmq_recv( zmq_socket_pull, variance, N_states*8, 0)'
-      endif
-
-      rc = f77_zmq_recv( zmq_socket_pull, norm, N_states*8, 0)
-      if(rc /= 8*N_states) then
-        print *,  'f77_zmq_recv( zmq_socket_pull, norm, N_states*8, 0)'
-      endif
-
       rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
       if(rc /= 8*N) then
         print *,  'f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)'
@@ -228,10 +234,6 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, variance, norm, val, det
       if(rc /= bit_kind*N_int*2*N) then
         print *,  'f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)'
       endif
-  else
-      pt2(:) = 0.d0
-      variance(:) = 0.d0
-      norm(:) = 0.d0
   endif
 
   rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0)

src/cipsi/slave_cipsi.irp.f

@@ -63,7 +63,7 @@ subroutine run_slave_main
     if (mpi_master) then
       call wait_for_states(states,zmq_state,size(states))
       if (zmq_state(1:64) == old_state(1:64)) then
-        call sleep(1)
+        call usleep(200)
         cycle
       else
         old_state(1:64) = zmq_state(1:64)

src/ezfio_files/ezfio.irp.f

@@ -39,6 +39,8 @@ BEGIN_PROVIDER [ character*(128), ezfio_filename ]
   write(command,*) 'echo 15 > /proc//'//trim(adjustl(pidc))//'/oom_adj'
   call system(command)
 
+  PROVIDE file_lock
+
 END_PROVIDER
 
 BEGIN_PROVIDER [ character*(128), ezfio_work_dir ]

src/fci/pt2.irp.f

@@ -43,8 +43,13 @@ subroutine run
   E_CI_before(:) = psi_energy(:) + nuclear_repulsion
   relative_error=PT2_relative_error
 
-  call ZMQ_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
+  if (do_pt2) then
-     norm,0) ! Stochastic PT2
+    call ZMQ_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
+      norm,0) ! Stochastic PT2
+  else
+    call ZMQ_selection(0, pt2, variance, norm)
+  endif
+
   do k=1,N_states
     rpt2(k) = pt2(k)/(1.d0 + norm(k))
   enddo

src/utils/c_functions.f90

@@ -0,0 +1,19 @@
+module c_functions
+  use iso_c_binding
+
+  interface
+    subroutine usleep_c(us) bind (C,name="usleep")
+      use iso_c_binding
+      integer(c_int), value :: us
+    end subroutine usleep_c
+  end interface
+
+end module
+
+subroutine usleep(us)
+  use c_functions
+  use iso_c_binding
+  implicit none
+  integer, intent(in) :: us
+  call usleep_c(int(us,c_int))
+end

src/utils/memory.irp.f

@@ -15,6 +15,7 @@ BEGIN_PROVIDER [ integer, qp_max_mem ]
 END_PROVIDER
 
 subroutine resident_memory(value)
+  use c_functions
   implicit none
   BEGIN_DOC
 ! Returns the current used memory in gigabytes used by the current process.
@@ -25,6 +26,8 @@ subroutine resident_memory(value)
   double precision, intent(out) :: value
 
   call omp_set_lock(file_lock)
+  call usleep(10)
+
   value = 0.d0
   iunit = getUnitAndOpen('/proc/self/status','r')
   do

src/zmq/utils.irp.f

@@ -275,7 +275,6 @@ IRP_ENDIF
     rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address)
     if (rc /= 0) then
       icount = icount-1
-!      call sleep(3)
       zmq_socket_pull_tcp_address    = 'tcp://*:'//zmq_port(2+icount*100)//' '
       zmq_socket_push_tcp_address    = trim(qp_run_address)//':'//zmq_port(2+icount*100)//' '
     else