From ace711ae143900cc173d66162c373891ae2c58b1 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 5 Jun 2018 17:51:10 +0200 Subject: [PATCH] Parallel bugs fixed --- ocaml/TaskServer.ml | 2 +- plugins/Full_CI_ZMQ/pt2_slave.irp.f | 82 -------------- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 18 ++- plugins/Full_CI_ZMQ/run_pt2_slave.irp.f | 8 +- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 107 +++++++++++++++++- plugins/Full_CI_ZMQ/selection.irp.f | 28 ++--- .../selection_davidson_slave.irp.f | 21 +++- plugins/Full_CI_ZMQ/zmq_selection.irp.f | 6 + src/Determinants/s2.irp.f | 9 +- src/Integrals_Bielec/map_integrals.irp.f | 2 +- src/ZMQ/put_get.irp.f | 105 ++++++++++++++++- src/ZMQ/utils.irp.f | 14 +-- 12 files changed, 283 insertions(+), 119 deletions(-) delete mode 100644 plugins/Full_CI_ZMQ/pt2_slave.irp.f diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 42524d2d..44a46f52 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -625,7 +625,7 @@ let get_data msg program_state rep_socket = let value = match StringHashtbl.find program_state.data key with | Some value -> value - | None -> "" + | None -> "\0" in Message.GetDataReply (Message.GetDataReply_msg.create ~value) |> Message.to_string_list diff --git a/plugins/Full_CI_ZMQ/pt2_slave.irp.f b/plugins/Full_CI_ZMQ/pt2_slave.irp.f deleted file mode 100644 index 2764b169..00000000 --- a/plugins/Full_CI_ZMQ/pt2_slave.irp.f +++ /dev/null @@ -1,82 +0,0 @@ -program pt2_slave - implicit none - BEGIN_DOC -! Helper program to compute the PT2 in distributed mode. - END_DOC - - read_wf = .False. - distributed_davidson = .False. - SOFT_TOUCH read_wf distributed_davidson - call provide_everything - call switch_qp_run_to_master - call run_wf -end - -subroutine provide_everything - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context -end - -subroutine run_wf - use f77_zmq - implicit none - - integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) - character*(64) :: states(1) - integer :: rc, i - - integer, external :: zmq_get_dvector - integer, external :: zmq_get_psi - - call provide_everything - - zmq_context = f77_zmq_ctx_new () - states(1) = 'pt2' - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - - do - - call wait_for_states(states,zmq_state,1) - - if(trim(zmq_state) == 'Stopped') then - - exit - - else if (trim(zmq_state) == 'pt2') then - - ! Selection - ! --------- - - print *, 'PT2' - if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle - if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle - - 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 - PROVIDE psi_bilinear_matrix_transp_order - psi_energy(1:N_states) = energy(1:N_states) - TOUCH psi_energy - - !$OMP PARALLEL PRIVATE(i) - i = omp_get_thread_num() - call pt2_slave_tcp(i, energy) - !$OMP END PARALLEL - print *, 'PT2 done' - - endif - - end do -end - -subroutine pt2_slave_tcp(i,energy) - implicit none - double precision, intent(in) :: energy(N_states_diag) - integer, intent(in) :: i - logical :: lstop - lstop = .False. - call run_pt2_slave(0,i,energy,lstop) -end - diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 96c4db69..c20c409d 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -37,10 +37,9 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error) state_average_weight_save(:) = state_average_weight(:) do pt2_stoch_istate=1,N_states - SOFT_TOUCH pt2_stoch_istate state_average_weight(:) = 0.d0 state_average_weight(pt2_stoch_istate) = 1.d0 - TOUCH state_average_weight + TOUCH state_average_weight pt2_stoch_istate allocate(pt2_detail(N_states,N_det_generators+1), comb(N_det_generators), computed(N_det_generators), tbc(0:size_tbc)) sumabove = 0d0 @@ -71,6 +70,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error) integer, external :: zmq_put_N_det_generators integer, external :: zmq_put_N_det_selectors integer, external :: zmq_put_dvector + integer, external :: zmq_put_ivector if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then stop 'Unable to put psi on ZMQ server' endif @@ -83,6 +83,20 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error) if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then stop 'Unable to put energy on ZMQ server' endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',pt2_e0_denominator,size(state_average_weight)) == -1) then + stop 'Unable to put state_average_weight on ZMQ server' + endif + if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then + stop 'Unable to put pt2_stoch_istate on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_selectors',threshold_selectors,1) == -1) then + stop 'Unable to put threshold_selectors on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',threshold_generators,1) == -1) then + stop 'Unable to put threshold_generators on ZMQ server' + endif + + call create_selection_buffer(1, 1*2, b) integer :: ipos diff --git a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f index 88c8aacb..dbd9dd48 100644 --- a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f @@ -25,6 +25,12 @@ subroutine run_pt2_slave(thread,iproc,energy) integer :: n_tasks, k, n_tasks_max integer, allocatable :: i_generator(:), subset(:) +!if (mpi_master) then +! do i=1,N_det_generators +! print '(I6,X,100(I10,X))' ,i, psi_det_generators(:,:,i) +! enddo +!endif + n_tasks_max = N_det_generators/100+1 allocate(task_id(n_tasks_max), task(n_tasks_max)) allocate(pt2(N_states,n_tasks_max), i_generator(n_tasks_max), subset(n_tasks_max)) @@ -77,8 +83,8 @@ subroutine run_pt2_slave(thread,iproc,energy) continue endif - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_push_socket(zmq_socket_push,thread) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call delete_selection_buffer(buf) end subroutine diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 3f0e6865..4aa3594c 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -1,5 +1,110 @@ - subroutine run_selection_slave(thread,iproc,energy) + call run_selection_slave_new(thread,iproc,energy) +end + +subroutine run_selection_slave_new(thread,iproc,energy) + use f77_zmq + use selection_types + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i, N + logical :: buffer_ready + + integer :: worker_id, ltask + character*(512), allocatable :: task(:) + integer, allocatable :: task_id(:) + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + type(selection_buffer) :: buf, buf2 + logical :: done + + double precision,allocatable :: pt2(:,:) + integer :: n_tasks, k, n_tasks_max + integer, allocatable :: i_generator(:), subset(:) + + 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 + PROVIDE psi_bilinear_matrix_transp_order + + buffer_ready = .False. + n_tasks_max = N_det_generators/100+1 + allocate(task_id(n_tasks_max), task(n_tasks_max)) + allocate(pt2(N_states,n_tasks_max), i_generator(n_tasks_max), subset(n_tasks_max)) + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + integer, external :: connect_to_taskserver + if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + return + endif + + zmq_socket_push = new_zmq_push_socket(thread) + + buf%N = 0 + n_tasks = 0 + call create_selection_buffer(0, 0, buf) + done = .False. + do while (.not.done) + + n_tasks = min(n_tasks+1,n_tasks_max) + + integer, external :: get_tasks_from_taskserver + if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then + exit + endif + done = task_id(n_tasks) == 0 + if (done) n_tasks = n_tasks-1 + if (n_tasks == 0) exit + + do k=1,n_tasks + read (task(k),*) subset(k), i_generator(k), N + enddo + + if(buf%N == 0) then + ! Only first time + call create_selection_buffer(N, N*2, buf) + call create_selection_buffer(N, N*2, buf2) + buffer_ready = .True. + endif + + do k=1,n_tasks + pt2(:,k) = 0.d0 + buf%cur = 0 + call select_connected(i_generator(k),energy,pt2(1,k),buf,subset(k)) + enddo + integer, external :: tasks_done_to_taskserver + if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then + done = .true. + endif + call sort_selection_buffer(buf) + call merge_selection_buffers(buf,buf2) + call push_selection_results(zmq_socket_push, pt2, buf, task_id, n_tasks) + buf%mini = buf2%mini + pt2(:,:) = 0d0 + buf%cur = 0 + end do + + integer, external :: disconnect_from_taskserver + if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then + continue + endif + + call end_zmq_push_socket(zmq_socket_push,thread) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call delete_selection_buffer(buf) + +end + +subroutine run_selection_slave_old(thread,iproc,energy) use f77_zmq use selection_types implicit none diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 516c4567..82276406 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -137,7 +137,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) puti = p(j, sp) if(bannedOrb(puti)) cycle pmob = p(turn2(j), sp) - hij = mo_bielec_integral(pfix, pmob, hfix, hmob) + hij = mo_bielec_integral(pmob, pfix, hmob, hfix) hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) vect(:, puti) += hij * coefs end do @@ -193,13 +193,13 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) do i=1,hole-1 if(lbanned(i)) cycle - hij = (mo_bielec_integral(p1, p2, i, hole) - mo_bielec_integral(p2, p1, i, hole)) + hij = (mo_bielec_integral(i, hole, p1, p2) - mo_bielec_integral(i, hole, p2, p1)) hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) vect(1:N_states,i) += hij * coefs(1:N_states) end do do i=hole+1,mo_tot_num if(lbanned(i)) cycle - hij = (mo_bielec_integral(p1, p2, hole, i) - mo_bielec_integral(p2, p1, hole, i)) + hij = (mo_bielec_integral(hole, i, p1, p2) - mo_bielec_integral(hole, i, p2, p1)) hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) vect(1:N_states,i) += hij * coefs(1:N_states) end do @@ -211,7 +211,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) p2 = p(1, sh) do i=1,mo_tot_num if(lbanned(i)) cycle - hij = mo_bielec_integral(p1, p2, i, hole) + hij = mo_bielec_integral(i, hole, p1, p2) hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) vect(1:N_states,i) += hij * coefs(1:N_states) end do @@ -910,12 +910,12 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) tmp_row = 0d0 do putj=1, hfix-1 if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (mo_bielec_integral(p1, p2, putj, hfix)-mo_bielec_integral(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + hij = (mo_bielec_integral(putj, hfix, p1, p2)-mo_bielec_integral(putj,hfix,p2,p1)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) tmp_row(1:N_states,putj) += hij * coefs(1:N_states) end do do putj=hfix+1, mo_tot_num if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (mo_bielec_integral(p1, p2, hfix, putj)-mo_bielec_integral(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + hij = (mo_bielec_integral(hfix,putj,p1, p2)-mo_bielec_integral(hfix,putj,p2,p1)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) tmp_row(1:N_states,putj) += hij * coefs(1:N_states) end do @@ -935,13 +935,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) !p1 fixed putj = p1 if(.not. banned(putj,puti,bant)) then - hij = mo_bielec_integral(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + hij = mo_bielec_integral(puti,hfix,pfix,p2) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) tmp_row(:,puti) += hij * coefs(:) end if putj = p2 if(.not. banned(putj,puti,bant)) then - hij = mo_bielec_integral(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + hij = mo_bielec_integral(puti,hfix,pfix,p1) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) tmp_row2(:,puti) += hij * coefs(:) end if end do @@ -963,12 +963,12 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) tmp_row = 0d0 do putj=1,hfix-1 if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (mo_bielec_integral(p1, p2, putj, hfix)-mo_bielec_integral(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + hij = (mo_bielec_integral(putj, hfix, p1, p2)-mo_bielec_integral(putj,hfix,p2,p1)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) tmp_row(:,putj) += hij * coefs(:) end do do putj=hfix+1,mo_tot_num if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (mo_bielec_integral(p1, p2, hfix, putj)-mo_bielec_integral(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + hij = (mo_bielec_integral(putj, hfix, p2, p1)-mo_bielec_integral(putj,hfix,p1,p2)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) tmp_row(:,putj) += hij * coefs(:) end do @@ -986,13 +986,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) if(lbanned(puti,ma)) cycle putj = p2 if(.not. banned(puti,putj,1)) then - hij = mo_bielec_integral(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + hij = mo_bielec_integral(puti,hfix, p1,pfix) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) tmp_row(:,puti) += hij * coefs(:) end if putj = p1 if(.not. banned(puti,putj,1)) then - hij = mo_bielec_integral(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + hij = mo_bielec_integral(puti, hfix, p2, pfix) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) tmp_row2(:,puti) += hij * coefs(:) end if end do @@ -1064,7 +1064,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) call i_h_j(gen, det, N_int, hij) else phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - hij = mo_bielec_integral(p1, p2, h1, h2) * phase + hij = mo_bielec_integral(p2, p1, h2, h1) * phase end if mat(:, p1, p2) += coefs(:) * hij end do @@ -1081,7 +1081,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) call i_h_j(gen, det, N_int, hij) else - hij = (mo_bielec_integral(p1, p2, puti, putj) - mo_bielec_integral(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + hij = (mo_bielec_integral(putj, puti, p2, p1) - mo_bielec_integral(putj, puti, p1, p2))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) end if mat(:, puti, putj) += coefs(:) * hij end do diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 2b6df181..67acc567 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -34,6 +34,7 @@ subroutine run_wf double precision :: t0, t1 integer, external :: zmq_get_dvector, zmq_get_N_det_generators + integer, external :: zmq_get_ivector integer, external :: zmq_get_psi, zmq_get_N_det_selectors integer, external :: zmq_get_N_states_diag @@ -65,8 +66,10 @@ subroutine run_wf if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_generators',threshold_generators,1) == -1) cycle + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_selectors',threshold_selectors,1) == -1) cycle psi_energy(1:N_states) = energy(1:N_states) - TOUCH psi_energy + TOUCH psi_energy threshold_selectors threshold_generators call wall_time(t1) call write_double(6,(t1-t0),'Broadcast time') @@ -105,10 +108,20 @@ subroutine run_wf call wall_time(t0) if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) cycle + if (zmq_get_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) cycle if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_generators',threshold_generators,1) == -1) cycle + if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_selectors',threshold_selectors,1) == -1) cycle psi_energy(1:N_states) = energy(1:N_states) - TOUCH psi_energy + TOUCH psi_energy state_average_weight pt2_stoch_istate threshold_selectors threshold_generators + print *, 'N_det', N_det + print *, 'N_det_generators', N_det_generators + print *, 'N_det_selectors', N_det_selectors + print *, 'psi_energy', psi_energy + print *, 'pt2_stoch_istate', pt2_stoch_istate + print *, 'state_average_weight', state_average_weight call wall_time(t1) call write_double(6,(t1-t0),'Broadcast time') @@ -117,9 +130,11 @@ subroutine run_wf lstop = .False. !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() - call run_pt2_slave(0,i,energy,lstop) + call run_pt2_slave(0,i,pt2_e0_denominator) !$OMP END PARALLEL print *, 'PT2 done' +exit + FREE state_average_weight endif diff --git a/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f index 77a1457f..03d9cb04 100644 --- a/plugins/Full_CI_ZMQ/zmq_selection.irp.f +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -41,6 +41,12 @@ subroutine ZMQ_selection(N_in, pt2) if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then stop 'Unable to put energy on ZMQ server' endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_selectors',threshold_selectors,1) == -1) then + stop 'Unable to put threshold_selectors on ZMQ server' + endif + if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',threshold_generators,1) == -1) then + stop 'Unable to put threshold_generators on ZMQ server' + endif call create_selection_buffer(N, N*2, b) endif diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index 1df4721e..273b8352 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -189,8 +189,8 @@ subroutine S2_u_0_nstates(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8) allocate(vt(sze_8,N_st)) vt = 0.d0 - !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,1) + !$OMP DO do sh2=sh,shortcut(0,1) exa = 0 do ni=1,Nint @@ -227,11 +227,11 @@ subroutine S2_u_0_nstates(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8) enddo enddo enddo + !$OMP END DO NOWAIT enddo - !$OMP END DO NOWAIT - !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,2) + !$OMP DO do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) do j=shortcut(sh,2),i-1 @@ -249,8 +249,9 @@ subroutine S2_u_0_nstates(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8) end if end do end do + !$OMP END DO NOWAIT enddo - !$OMP END DO NOWAIT + !$OMP BARRIER do istate=1,N_st do i=n,1,-1 diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 85a2f954..47743efe 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -421,8 +421,8 @@ double precision function mo_bielec_integral(i,j,k,l) integer, intent(in) :: i,j,k,l double precision :: get_mo_bielec_integral PROVIDE mo_bielec_integrals_in_map mo_integrals_cache - !DIR$ FORCEINLINE PROVIDE mo_bielec_integrals_in_map + !DIR$ FORCEINLINE mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) return end diff --git a/src/ZMQ/put_get.irp.f b/src/ZMQ/put_get.irp.f index 40d2e881..ff58fad2 100644 --- a/src/ZMQ/put_get.irp.f +++ b/src/ZMQ/put_get.irp.f @@ -2,7 +2,7 @@ integer function zmq_put_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_ use f77_zmq implicit none BEGIN_DOC -! Put the X vector on the qp_run scheduler +! Put a float vector on the qp_run scheduler END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer, intent(in) :: worker_id @@ -40,7 +40,7 @@ integer function zmq_get_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_ use f77_zmq implicit none BEGIN_DOC -! Get psi_coef from the qp_run scheduler +! Get a float vector from the qp_run scheduler END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer, intent(in) :: worker_id @@ -86,7 +86,7 @@ integer function zmq_get_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_ print *, irp_here//': Unable to broadcast zmq_get_dvector' stop -1 endif - call MPI_BCAST (x, size_x, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST (x, size_x, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) if (ierr /= MPI_SUCCESS) then print *, irp_here//': Unable to broadcast dvector' stop -1 @@ -97,3 +97,102 @@ end +integer function zmq_put_ivector(zmq_to_qp_run_socket, worker_id, name, x, size_x) + use f77_zmq + implicit none + BEGIN_DOC +! Put a vector of integers on the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + character*(*) :: name + integer, intent(in) :: size_x + integer, intent(out) :: x(size_x) + integer :: rc + character*(256) :: msg + + zmq_put_ivector = 0 + + write(msg,'(A,1X,I8,1X,A200)') 'put_data '//trim(zmq_state), worker_id, name + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) + if (rc /= len(trim(msg))) then + zmq_put_ivector = -1 + return + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,x,size_x*4,0) + if (rc /= size_x*4) then + zmq_put_ivector = -1 + return + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:rc) /= 'put_data_reply ok') then + zmq_put_ivector = -1 + return + endif + +end + + +integer function zmq_get_ivector(zmq_to_qp_run_socket, worker_id, name, x, size_x) + use f77_zmq + implicit none + BEGIN_DOC +! Get a vector of integers from the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer, intent(in) :: size_x + character*(*), intent(in) :: name + integer, intent(out) :: x(size_x) + integer :: rc + integer*8 :: rc8 + character*(256) :: msg + + PROVIDE zmq_state + ! Success + zmq_get_ivector = 0 + + if (mpi_master) then + write(msg,'(A,1X,I8,1X,A200)') 'get_data '//trim(zmq_state), worker_id, name + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) + if (rc /= len(trim(msg))) then + zmq_get_ivector = -1 + go to 10 + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:14) /= 'get_data_reply') then + zmq_get_ivector = -1 + go to 10 + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,x,size_x*4,0) + if (rc /= size_x*4) then + zmq_get_ivector = -1 + go to 10 + endif + endif + + 10 continue + + IRP_IF MPI + integer :: ierr + include 'mpif.h' + call MPI_BCAST (zmq_get_ivector, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here//': Unable to broadcast zmq_get_ivector' + stop -1 + endif + call MPI_BCAST (x, size_x, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here//': Unable to broadcast ivector' + stop -1 + endif + IRP_ENDIF + +end + + + diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 86c4a3ee..f8f7c71b 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -148,12 +148,12 @@ function new_zmq_to_qp_run_socket() stop 'Unable to create zmq req socket' endif - rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 60000, 4) + rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 300000, 4) if (rc /= 0) then stop 'Unable to set send timeout in new_zmq_to_qp_run_socket' endif - rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 60000, 4) + rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 300000, 4) if (rc /= 0) then stop 'Unable to set recv timeout in new_zmq_to_qp_run_socket' endif @@ -250,7 +250,7 @@ IRP_ENDIF stop 'Unable to create zmq pull socket' endif - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_LINGER,60000,4) + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_LINGER,300000,4) if (rc /= 0) then stop 'Unable to set ZMQ_LINGER on pull socket' endif @@ -332,7 +332,7 @@ IRP_ENDIF stop 'Unable to create zmq push socket' endif - rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_LINGER,60000,4) + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_LINGER,300000,4) if (rc /= 0) then stop 'Unable to set ZMQ_LINGER on push socket' endif @@ -352,7 +352,7 @@ IRP_ENDIF stop 'Unable to set ZMQ_IMMEDIATE on push socket' endif - rc = f77_zmq_setsockopt(new_zmq_push_socket, ZMQ_SNDTIMEO, 60000, 4) + rc = f77_zmq_setsockopt(new_zmq_push_socket, ZMQ_SNDTIMEO, 300000, 4) if (rc /= 0) then stop 'Unable to set send timout in new_zmq_push_socket' endif @@ -488,7 +488,7 @@ subroutine end_zmq_push_socket(zmq_socket_push,thread) integer :: rc character*(8), external :: zmq_port - rc = f77_zmq_setsockopt(zmq_socket_push,ZMQ_LINGER,60000,4) + rc = f77_zmq_setsockopt(zmq_socket_push,ZMQ_LINGER,300000,4) if (rc /= 0) then stop 'Unable to set ZMQ_LINGER on push socket' endif @@ -1019,7 +1019,7 @@ subroutine end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) character*(8), external :: zmq_port integer :: rc - rc = f77_zmq_setsockopt(zmq_to_qp_run_socket,ZMQ_LINGER,60000,4) + rc = f77_zmq_setsockopt(zmq_to_qp_run_socket,ZMQ_LINGER,300000,4) if (rc /= 0) then stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket' endif