mirror of
https://github.com/LCPQ/quantum_package
synced 2024-07-23 11:17:33 +02:00
Parallel bugs fixed
This commit is contained in:
parent
54986d9d8f
commit
ace711ae14
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
enddo
|
||||
|
||||
!$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
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
enddo
|
||||
!$OMP BARRIER
|
||||
|
||||
do istate=1,N_st
|
||||
do i=n,1,-1
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user