diff --git a/src/cipsi/energy.irp.f b/src/cipsi/energy.irp.f index b7ba42bb..0ae5ad79 100644 --- a/src/cipsi/energy.irp.f +++ b/src/cipsi/energy.irp.f @@ -11,9 +11,15 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] BEGIN_DOC ! E0 in the denominator of the PT2 END_DOC + integer :: i,j if (initialize_pt2_E0_denominator) then if (h0_type == "EN") then pt2_E0_denominator(1:N_states) = psi_energy(1:N_states) + else if (h0_type == "HF") then + do i=1,N_states + j = maxloc(abs(psi_coef(:,i)),1) + pt2_E0_denominator(i) = psi_det_hii(j) + enddo else if (h0_type == "Barycentric") then pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) else if (h0_type == "Variance") then @@ -24,7 +30,9 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] print *, h0_type, ' not implemented' stop endif - call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') + do i=1,N_states + call write_double(6,pt2_E0_denominator(i)+nuclear_repulsion, 'PT2 Energy denominator') + enddo else pt2_E0_denominator = -huge(1.d0) endif diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index d93d977a..83924bb6 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -248,8 +248,8 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in) + 64.d0*pt2_n_tasks_max & ! task + 3.d0*pt2_n_tasks_max*N_states & ! pt2, variance, norm + 1.d0*pt2_n_tasks_max & ! i_generator, subset - + 2.d0*(N_int*2.d0*N_in + N_in) & ! selection buffers - + 1.d0*(N_int*2.d0*N_in + N_in) & ! sort/merge selection buffers + + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer + + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer + 2.0d0*(ii) & ! preinteresting, interesting, ! prefullinteresting, fullinteresting + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist @@ -350,7 +350,8 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc double precision, allocatable :: nI(:,:), nI_task(:,:), T3(:) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - integer, external :: zmq_delete_tasks + integer, external :: zmq_delete_tasks_async_send + integer, external :: zmq_delete_tasks_async_recv integer, external :: zmq_abort integer, external :: pt2_find_sample_lr @@ -364,7 +365,7 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc integer, allocatable :: f(:) logical, allocatable :: d(:) - logical :: do_exit, stop_now + logical :: do_exit, stop_now, sending logical, external :: qp_stop type(selection_buffer) :: b2 @@ -372,6 +373,8 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc double precision :: rss double precision, external :: memory_of_double, memory_of_int + sending =.False. + rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2) rss += memory_of_double(N_states*N_det_generators)*3.d0 rss += memory_of_double(N_states*pt2_n_tasks_max)*3.d0 @@ -422,6 +425,7 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc stop_now = .false. do while (n <= N_det_generators) if(f(pt2_J(n)) == 0) then +!print *, 'f(pt2_J(n)) == 0' d(pt2_J(n)) = .true. do while(d(U+1)) U += 1 @@ -447,6 +451,7 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc ! Add Stochastic part c = pt2_R(n) if(c > 0) then +!print *, 'c>0' x = 0d0 x2 = 0d0 x3 = 0d0 @@ -500,7 +505,7 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc exit else call pull_pt2_results(zmq_socket_pull, index, eI_task, vI_task, nI_task, task_id, n_tasks, b2) - if (zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,n_tasks,more) == -1) then + if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then stop 'Unable to delete tasks' endif do i=1,n_tasks @@ -511,12 +516,19 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc end do do i=1, b2%cur call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i)) + ! We assume the pulled buffer is sorted if (b2%val(i) > b%mini) exit end do + if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then + stop 'Unable to delete tasks' + endif end if end do +!print *, 'deleting b2' call delete_selection_buffer(b2) +!print *, 'sorting b' call sort_selection_buffer(b) +!print *, 'done' call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) end subroutine diff --git a/src/cipsi/run_pt2_slave.irp.f b/src/cipsi/run_pt2_slave.irp.f index 04c28e1b..b4df2def 100644 --- a/src/cipsi/run_pt2_slave.irp.f +++ b/src/cipsi/run_pt2_slave.irp.f @@ -1,4 +1,3 @@ - subroutine run_pt2_slave(thread,iproc,energy) use f77_zmq use selection_types @@ -18,7 +17,7 @@ subroutine run_pt2_slave(thread,iproc,energy) integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push - type(selection_buffer) :: b, b2 + type(selection_buffer) :: b logical :: done, buffer_ready double precision,allocatable :: pt2(:,:), variance(:,:), norm(:,:) @@ -27,6 +26,9 @@ subroutine run_pt2_slave(thread,iproc,energy) double precision :: rss double precision, external :: memory_of_double, memory_of_int + integer :: bsize ! Size of selection buffers + logical :: sending + rss = memory_of_int(pt2_n_tasks_max)*67.d0 rss += memory_of_double(pt2_n_tasks_max)*(N_states*3) call check_mem(rss,irp_here) @@ -50,6 +52,7 @@ subroutine run_pt2_slave(thread,iproc,energy) buffer_ready = .False. n_tasks = 1 + sending = .False. done = .False. n_tasks = 1 do while (.not.done) @@ -72,8 +75,8 @@ subroutine run_pt2_slave(thread,iproc,energy) enddo if (b%N == 0) then ! Only first time - call create_selection_buffer(N, N*2, b) - call create_selection_buffer(N, N*2, b2) + bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2) + call create_selection_buffer(bsize, bsize*2, b) buffer_ready = .True. else ASSERT (N == b%N) @@ -100,14 +103,14 @@ subroutine run_pt2_slave(thread,iproc,energy) done = .true. endif call sort_selection_buffer(b) - call merge_selection_buffers(b,b2) - call push_pt2_results(zmq_socket_push, i_generator, pt2, variance, norm, b, task_id, n_tasks) - b%mini = b2%mini + call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending) + call push_pt2_results_async_send(zmq_socket_push, i_generator, pt2, variance, norm, b, task_id, n_tasks,sending) b%cur=0 - ! Try to adjust n_tasks around nproc/8 seconds per job - n_tasks = min(2*n_tasks,int( dble(n_tasks * nproc/8) / (time1 - time0 + 1.d0))) + ! Try to adjust n_tasks around nproc/2 seconds per job + n_tasks = min(2*n_tasks,int( dble(n_tasks * nproc/2) / (time1 - time0 + 1.d0))) end do + call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending) integer, external :: disconnect_from_taskserver do i=1,300 @@ -120,7 +123,6 @@ subroutine run_pt2_slave(thread,iproc,energy) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) if (buffer_ready) then call delete_selection_buffer(b) - call delete_selection_buffer(b2) endif end subroutine @@ -226,6 +228,129 @@ IRP_ENDIF end subroutine +subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2, variance, norm, b, task_id, n_tasks, sending) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(in) :: pt2(N_states,n_tasks) + double precision, intent(in) :: variance(N_states,n_tasks) + double precision, intent(in) :: norm(N_states,n_tasks) + integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks) + type(selection_buffer), intent(inout) :: b + logical, intent(inout) :: sending + integer :: rc + + if (sending) then + print *, irp_here, ': sending is true' + stop -1 + endif + sending = .True. + + rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE) + if (rc == -1) then + return + else if(rc /= 4) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, index, 4*n_tasks, ZMQ_SNDMORE) + if (rc == -1) then + return + else if(rc /= 4*n_tasks) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states*n_tasks, ZMQ_SNDMORE) + if (rc == -1) then + return + else if(rc /= 8*N_states*n_tasks) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, variance, 8*N_states*n_tasks, ZMQ_SNDMORE) + if (rc == -1) then + return + else if(rc /= 8*N_states*n_tasks) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, norm, 8*N_states*n_tasks, ZMQ_SNDMORE) + if (rc == -1) then + return + else if(rc /= 8*N_states*n_tasks) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, task_id, n_tasks*4, ZMQ_SNDMORE) + if (rc == -1) then + return + else if(rc /= 4*n_tasks) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) + if (rc == -1) then + return + else if(rc /= 4) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, b%val, 8*b%cur, ZMQ_SNDMORE) + if (rc == -1) then + return + else if(rc /= 8*b%cur) then + stop 'push' + endif + + + rc = f77_zmq_send( zmq_socket_push, b%det, bit_kind*N_int*2*b%cur, 0) + if (rc == -1) then + return + else if(rc /= N_int*2*8*b%cur) then + stop 'push' + endif + +end subroutine + +subroutine push_pt2_results_async_recv(zmq_socket_push,mini,sending) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(out) :: mini + logical, intent(inout) :: sending + integer :: rc + + if (.not.sending) return + +! Activate is zmq_socket_push is a REQ +IRP_IF ZMQ_PUSH +IRP_ELSE + character*(2) :: ok + rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) + if (rc == -1) then + return + else if ((rc /= 2).and.(ok(1:2) /= 'ok')) then + print *, irp_here//': error in receiving ok' + stop -1 + endif + rc = f77_zmq_recv( zmq_socket_push, mini, 8, 0) +IRP_ENDIF + sending = .False. +end subroutine + + + subroutine pull_pt2_results(zmq_socket_pull, index, pt2, variance, norm, task_id, n_tasks, b) use f77_zmq use selection_types @@ -315,7 +440,7 @@ subroutine pull_pt2_results(zmq_socket_pull, index, pt2, variance, norm, task_id ! Activate is zmq_socket_pull is a REP IRP_IF ZMQ_PUSH IRP_ELSE - rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) + rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, ZMQ_SNDMORE) if (rc == -1) then n_tasks = 1 task_id(1) = 0 @@ -323,6 +448,7 @@ IRP_ELSE print *, irp_here//': error in sending ok' stop -1 endif + rc = f77_zmq_send( zmq_socket_pull, b%mini, 8, 0) IRP_ENDIF end subroutine diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f index 04bb99ef..480ef12b 100644 --- a/src/cipsi/run_selection_slave.irp.f +++ b/src/cipsi/run_selection_slave.irp.f @@ -55,12 +55,13 @@ subroutine run_selection_slave(thread,iproc,energy) if (done) then ctask = ctask - 1 else - integer :: i_generator, N, subset + integer :: i_generator, N, subset, bsize read(task,*) subset, i_generator, N if(buf%N == 0) then ! Only first time - call create_selection_buffer(N, N*2, buf) - call create_selection_buffer(N, N*2, buf2) + bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2) + call create_selection_buffer(bsize, bsize*2, buf) +! call create_selection_buffer(N, N*2, buf2) buffer_ready = .True. else ASSERT (N == buf%N) @@ -83,9 +84,9 @@ subroutine run_selection_slave(thread,iproc,energy) end do if(ctask > 0) then call sort_selection_buffer(buf) - call merge_selection_buffers(buf,buf2) +! call merge_selection_buffers(buf,buf2) call push_selection_results(zmq_socket_push, pt2, variance, norm, buf, task_id(1), ctask) - buf%mini = buf2%mini +! buf%mini = buf2%mini pt2(:) = 0d0 variance(:) = 0d0 norm(:) = 0d0 @@ -108,7 +109,7 @@ subroutine run_selection_slave(thread,iproc,energy) call end_zmq_push_socket(zmq_socket_push,thread) if (buffer_ready) then call delete_selection_buffer(buf) - call delete_selection_buffer(buf2) +! call delete_selection_buffer(buf2) endif end subroutine diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index 86b5536f..69540afc 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -153,9 +153,6 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d logical :: monoAdo, monoBdo integer :: maskInd - double precision :: rss - double precision, external :: memory_of_double, memory_of_int - PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns @@ -231,7 +228,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d deallocate(exc_degree) nmax=k-1 - + allocate(iorder(nmax)) do i=1,nmax iorder(i) = i @@ -241,8 +238,8 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d allocate(preinteresting(0:32), prefullinteresting(0:32), & interesting(0:32), fullinteresting(0:32)) - preinteresting(0) = 0 - prefullinteresting(0) = 0 + preinteresting(:) = 0 + prefullinteresting(:) = 0 do i=1,N_int negMask(i,1) = not(psi_det_generators(i,1,i_generator)) @@ -645,13 +642,11 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere negMask(i,2) = not(mask(i,2)) end do - do i=1, N_sel ! interesting(0) - !i = interesting(ii) + do i=1, N_sel if (interesting(i) < 0) then stop 'prefetch interesting(i) and det(i)' endif - mobMask(1,1) = iand(negMask(1,1), det(1,1,i)) mobMask(1,2) = iand(negMask(1,2), det(1,2,i)) nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) @@ -682,10 +677,10 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere end if end if - call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) - if (interesting(i) >= i_gen) then + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + perMask(1,1) = iand(mask(1,1), not(det(1,1,i))) perMask(1,2) = iand(mask(1,2), not(det(1,2,i))) do j=2,N_int @@ -704,9 +699,14 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere else call get_d0(det(1,1,i), phasemask, bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) end if - else - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) + else if(nt == 4) then + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + call past_d2(banned, p, sp) + else if(nt == 3) then + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + call past_d1(bannedOrb, p) end if end do diff --git a/src/cipsi/selection_buffer.irp.f b/src/cipsi/selection_buffer.irp.f index ce7f2d8b..91fdcd3a 100644 --- a/src/cipsi/selection_buffer.irp.f +++ b/src/cipsi/selection_buffer.irp.f @@ -2,6 +2,10 @@ subroutine create_selection_buffer(N, siz_, res) use selection_types implicit none + BEGIN_DOC +! Allocates the memory for a selection buffer. +! The arrays have dimension siz_ and the maximum number of elements is N + END_DOC integer, intent(in) :: N, siz_ type(selection_buffer), intent(out) :: res diff --git a/src/cipsi/slave_cipsi.irp.f b/src/cipsi/slave_cipsi.irp.f index 66560720..0de07e67 100644 --- a/src/cipsi/slave_cipsi.irp.f +++ b/src/cipsi/slave_cipsi.irp.f @@ -251,8 +251,8 @@ subroutine run_slave_main + 64.d0*pt2_n_tasks_max & ! task + 3.d0*pt2_n_tasks_max*N_states & ! pt2, variance, norm + 1.d0*pt2_n_tasks_max & ! i_generator, subset - + 2.d0*(N_int*2.d0*N_det+ N_det) & ! selection buffers - + 1.d0*(N_int*2.d0*N_det+ N_det) & ! sort/merge selection buffers + + 2.d0*(N_int*2.d0*ii+ ii) & ! selection buffer + + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer + 2.0d0*(ii) & ! preinteresting, interesting, ! prefullinteresting, fullinteresting + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist diff --git a/src/cipsi/stochastic_cipsi.irp.f b/src/cipsi/stochastic_cipsi.irp.f index 9841a429..791656ce 100644 --- a/src/cipsi/stochastic_cipsi.irp.f +++ b/src/cipsi/stochastic_cipsi.irp.f @@ -10,7 +10,7 @@ subroutine run_stochastic_cipsi double precision :: rss double precision, external :: memory_of_double - PROVIDE H_apply_buffer_allocated + PROVIDE H_apply_buffer_allocated N_generators_bitmask threshold_generators = 1.d0 SOFT_TOUCH threshold_generators diff --git a/src/davidson/davidson_parallel.irp.f b/src/davidson/davidson_parallel.irp.f index b4cb3c7d..c615fae7 100644 --- a/src/davidson/davidson_parallel.irp.f +++ b/src/davidson/davidson_parallel.irp.f @@ -139,6 +139,8 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, ! Run tasks ! --------- + logical :: sending + sending=.False. allocate(v_t(N_st,N_det), s_t(N_st,N_det)) do @@ -158,9 +160,11 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then print *, irp_here, 'Unable to send task_done' endif - call davidson_push_results(zmq_socket_push, v_t, s_t, imin, imax, task_id) + call davidson_push_results_async_recv(zmq_socket_push, sending) + call davidson_push_results_async_send(zmq_socket_push, v_t, s_t, imin, imax, task_id, sending) end do deallocate(u_t,v_t, s_t) + call davidson_push_results_async_recv(zmq_socket_push, sending) end subroutine @@ -210,6 +214,73 @@ IRP_ENDIF end subroutine +subroutine davidson_push_results_async_send(zmq_socket_push, v_t, s_t, imin, imax, task_id,sending) + use f77_zmq + implicit none + BEGIN_DOC +! Push the results of $H | U \rangle$ from a worker to the master. + END_DOC + + integer(ZMQ_PTR) ,intent(in) :: zmq_socket_push + integer ,intent(in) :: task_id, imin, imax + double precision ,intent(in) :: v_t(N_states_diag,N_det) + double precision ,intent(in) :: s_t(N_states_diag,N_det) + logical ,intent(inout) :: sending + integer :: rc, sz + integer*8 :: rc8 + + if (sending) then + print *, irp_here, ': sending=true' + stop -1 + endif + sending = .True. + + sz = (imax-imin+1)*N_states_diag + + rc = f77_zmq_send( zmq_socket_push, task_id, 4, ZMQ_SNDMORE) + if(rc /= 4) stop 'davidson_push_results failed to push task_id' + + rc = f77_zmq_send( zmq_socket_push, imin, 4, ZMQ_SNDMORE) + if(rc /= 4) stop 'davidson_push_results failed to push imin' + + rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE) + if(rc /= 4) stop 'davidson_push_results failed to push imax' + + rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz, ZMQ_SNDMORE) + if(rc8 /= 8_8*sz) stop 'davidson_push_results failed to push vt' + + rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz, 0) + if(rc8 /= 8_8*sz) stop 'davidson_push_results failed to push st' + +end subroutine + +subroutine davidson_push_results_async_recv(zmq_socket_push,sending) + use f77_zmq + implicit none + BEGIN_DOC +! Push the results of $H | U \rangle$ from a worker to the master. + END_DOC + + integer(ZMQ_PTR) ,intent(in) :: zmq_socket_push + logical ,intent(inout) :: sending + + integer :: rc + + if (.not.sending) return +! Activate is zmq_socket_push is a REQ +IRP_IF ZMQ_PUSH +IRP_ELSE + character*(2) :: ok + rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) + if ((rc /= 2).and.(ok(1:2)/='ok')) then + print *, irp_here, ': f77_zmq_recv( zmq_socket_push, ok, 2, 0)' + stop -1 + endif +IRP_ENDIF + sending = .False. + +end subroutine + subroutine davidson_pull_results(zmq_socket_pull, v_t, s_t, imin, imax, task_id) @@ -275,22 +346,28 @@ subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull, v0, s0, sze integer :: more, task_id, imin, imax double precision, allocatable :: v_t(:,:), s_t(:,:) + logical :: sending integer :: i,j + integer, external :: zmq_delete_task_async_send + integer, external :: zmq_delete_task_async_recv allocate(v_t(N_st,N_det), s_t(N_st,N_det)) v0 = 0.d0 s0 = 0.d0 more = 1 + sending = .False. do while (more == 1) call davidson_pull_results(zmq_socket_pull, v_t, s_t, imin, imax, task_id) + if (zmq_delete_task_async_send(zmq_to_qp_run_socket,task_id,sending) == -1) then + stop 'Unable to delete task' + endif do j=1,N_st do i=imin,imax v0(i,j) = v0(i,j) + v_t(j,i) s0(i,j) = s0(i,j) + s_t(j,i) enddo enddo - integer, external :: zmq_delete_task - if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) == -1) then + if (zmq_delete_task_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then stop 'Unable to delete task' endif end do diff --git a/src/perturbation/h0_type.irp.f b/src/perturbation/h0_type.irp.f index 17a47ce6..7dd58c2c 100644 --- a/src/perturbation/h0_type.irp.f +++ b/src/perturbation/h0_type.irp.f @@ -8,5 +8,6 @@ BEGIN_PROVIDER [ character*32,h0_type ] else h0_type = 'EN' endif +! h0_type = 'HF' END_PROVIDER diff --git a/src/zmq/utils.irp.f b/src/zmq/utils.irp.f index 939c7b3a..4c838302 100644 --- a/src/zmq/utils.irp.f +++ b/src/zmq/utils.irp.f @@ -246,7 +246,7 @@ IRP_ENDIF ! stop 'Unable to set ZMQ_RCVBUF on pull socket' ! endif - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,8,4) + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,50,4) if (rc /= 0) then stop 'Unable to set ZMQ_RCVHWM on pull socket' endif @@ -1085,6 +1085,62 @@ integer function zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,mo endif end +integer function zmq_delete_task_async_send(zmq_to_qp_run_socket,task_id,sending) + use f77_zmq + implicit none + BEGIN_DOC +! When a task is done, it has to be removed from the list of tasks on the qp_run +! queue. This guarantees that the results have been received in the pull. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: task_id + logical, intent(inout) :: sending + integer :: rc + character*(512) :: message + + if (sending) then + print *, irp_here, ': sending=true' + stop -1 + endif + zmq_delete_task_async_send = 0 + + write(message,*) 'del_task ', zmq_state, task_id + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(message),len(trim(message)),0) + if (rc /= len(trim(message))) then + zmq_delete_task_async_send = -1 + return + endif + sending = .True. + +end + +integer function zmq_delete_task_async_recv(zmq_to_qp_run_socket,more,sending) + use f77_zmq + implicit none + BEGIN_DOC +! When a task is done, it has to be removed from the list of tasks on the qp_run +! queue. This guarantees that the results have been received in the pull. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(out) :: more + logical, intent(inout) :: sending + integer :: rc + character*(512) :: message + character*(64) :: reply + if (.not.sending) return + sending = .False. + reply = '' + rc = f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0) + if (reply(16:19) == 'more') then + more = 1 + else if (reply(16:19) == 'done') then + more = 0 + else + zmq_delete_task_async_recv = -1 + return + endif +end + integer function zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,n_tasks,more) use f77_zmq implicit none @@ -1128,7 +1184,7 @@ integer function zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,n endif end -integer function zmq_delete_tasks_async_send(zmq_to_qp_run_socket,zmq_socket_pull,task_id,n_tasks,more) +integer function zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) use f77_zmq implicit none BEGIN_DOC @@ -1136,13 +1192,17 @@ integer function zmq_delete_tasks_async_send(zmq_to_qp_run_socket,zmq_socket_pul ! queue. This guarantees that the results have been received in the pull. END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_socket_pull integer, intent(in) :: n_tasks, task_id(n_tasks) - integer, intent(in) :: more + logical, intent(inout) :: sending integer :: rc, k character*(64) :: fmt, reply character(LEN=:), allocatable :: message + if (sending) then + print *, irp_here, ': sending is true' + stop -1 + endif + sending = .True. zmq_delete_tasks_async_send = 0 allocate(character(LEN=64+n_tasks*12) :: message) @@ -1162,7 +1222,7 @@ integer function zmq_delete_tasks_async_send(zmq_to_qp_run_socket,zmq_socket_pul end -integer function zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,zmq_socket_pull,task_id,n_tasks,more) +integer function zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) use f77_zmq implicit none BEGIN_DOC @@ -1170,12 +1230,12 @@ integer function zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,zmq_socket_pul ! queue. This guarantees that the results have been received in the pull. END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_socket_pull - integer, intent(in) :: n_tasks, task_id(n_tasks) integer, intent(out) :: more + logical, intent(inout) :: sending integer :: rc character*(64) :: reply + if (.not.sending) return zmq_delete_tasks_async_recv = 0 reply = '' @@ -1188,6 +1248,7 @@ integer function zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,zmq_socket_pul else zmq_delete_tasks_async_recv = -1 endif + sending = .False. end