LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-25 05:43:47 +01:00
Code Issues Releases Wiki Activity

Parallel bugs fixed

Browse Source
This commit is contained in:
Anthony Scemama 2018-06-05 17:51:10 +02:00
parent 54986d9d8f
commit ace711ae14
12 changed files with 283 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
ocaml/TaskServer.ml
View File

@ -625,7 +625,7 @@ let get_data msg program_state rep_socket =
let value = let value =
match StringHashtbl.find program_state.data key with match StringHashtbl.find program_state.data key with
| Some value -> value | Some value -> value
| None -> "" | None -> "\0"
in in
Message.GetDataReply (Message.GetDataReply_msg.create ~value) Message.GetDataReply (Message.GetDataReply_msg.create ~value)
|> Message.to_string_list |> Message.to_string_list

82
plugins/Full_CI_ZMQ/pt2_slave.irp.f
View File

@ -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

18
plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f
View File

@ -37,10 +37,9 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error)
state_average_weight_save(:) = state_average_weight(:) state_average_weight_save(:) = state_average_weight(:)
do pt2_stoch_istate=1,N_states do pt2_stoch_istate=1,N_states
SOFT_TOUCH pt2_stoch_istate
state_average_weight(:) = 0.d0 state_average_weight(:) = 0.d0
state_average_weight(pt2_stoch_istate) = 1.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)) allocate(pt2_detail(N_states,N_det_generators+1), comb(N_det_generators), computed(N_det_generators), tbc(0:size_tbc))
sumabove = 0d0 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_generators
integer, external :: zmq_put_N_det_selectors integer, external :: zmq_put_N_det_selectors
integer, external :: zmq_put_dvector integer, external :: zmq_put_dvector
integer, external :: zmq_put_ivector
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
stop 'Unable to put psi on ZMQ server' stop 'Unable to put psi on ZMQ server'
endif 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 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' stop 'Unable to put energy on ZMQ server'
endif 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) call create_selection_buffer(1, 1*2, b)
integer :: ipos integer :: ipos

8
plugins/Full_CI_ZMQ/run_pt2_slave.irp.f
View File

@ -25,6 +25,12 @@ subroutine run_pt2_slave(thread,iproc,energy)
integer :: n_tasks, k, n_tasks_max integer :: n_tasks, k, n_tasks_max
integer, allocatable :: i_generator(:), subset(:) 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 n_tasks_max = N_det_generators/100+1
allocate(task_id(n_tasks_max), task(n_tasks_max)) 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)) 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 continue
endif 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_push_socket(zmq_socket_push,thread)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call delete_selection_buffer(buf) call delete_selection_buffer(buf)
end subroutine end subroutine

107
plugins/Full_CI_ZMQ/run_selection_slave.irp.f
View File

@ -1,5 +1,110 @@
subroutine run_selection_slave(thread,iproc,energy) 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 f77_zmq
use selection_types use selection_types
implicit none implicit none

28
plugins/Full_CI_ZMQ/selection.irp.f
View File

@ -137,7 +137,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
puti = p(j, sp) puti = p(j, sp)
if(bannedOrb(puti)) cycle if(bannedOrb(puti)) cycle
pmob = p(turn2(j), sp) 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) hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix)
vect(:, puti) += hij * coefs vect(:, puti) += hij * coefs
end do end do
@ -193,13 +193,13 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
do i=1,hole-1 do i=1,hole-1
if(lbanned(i)) cycle 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) hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2)
vect(1:N_states,i) += hij * coefs(1:N_states) vect(1:N_states,i) += hij * coefs(1:N_states)
end do end do
do i=hole+1,mo_tot_num do i=hole+1,mo_tot_num
if(lbanned(i)) cycle 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) hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2)
vect(1:N_states,i) += hij * coefs(1:N_states) vect(1:N_states,i) += hij * coefs(1:N_states)
end do end do
@ -211,7 +211,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
p2 = p(1, sh) p2 = p(1, sh)
do i=1,mo_tot_num do i=1,mo_tot_num
if(lbanned(i)) cycle 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) hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2)
vect(1:N_states,i) += hij * coefs(1:N_states) vect(1:N_states,i) += hij * coefs(1:N_states)
end do end do
@ -910,12 +910,12 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
tmp_row = 0d0 tmp_row = 0d0
do putj=1, hfix-1 do putj=1, hfix-1
if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle 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) tmp_row(1:N_states,putj) += hij * coefs(1:N_states)
end do end do
do putj=hfix+1, mo_tot_num do putj=hfix+1, mo_tot_num
if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle 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) tmp_row(1:N_states,putj) += hij * coefs(1:N_states)
end do end do
@ -935,13 +935,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
!p1 fixed !p1 fixed
putj = p1 putj = p1
if(.not. banned(putj,puti,bant)) then 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(:) tmp_row(:,puti) += hij * coefs(:)
end if end if
putj = p2 putj = p2
if(.not. banned(putj,puti,bant)) then 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(:) tmp_row2(:,puti) += hij * coefs(:)
end if end if
end do end do
@ -963,12 +963,12 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
tmp_row = 0d0 tmp_row = 0d0
do putj=1,hfix-1 do putj=1,hfix-1
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle 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(:) tmp_row(:,putj) += hij * coefs(:)
end do end do
do putj=hfix+1,mo_tot_num do putj=hfix+1,mo_tot_num
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle 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(:) tmp_row(:,putj) += hij * coefs(:)
end do end do
@ -986,13 +986,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
if(lbanned(puti,ma)) cycle if(lbanned(puti,ma)) cycle
putj = p2 putj = p2
if(.not. banned(puti,putj,1)) then 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(:) tmp_row(:,puti) += hij * coefs(:)
end if end if
putj = p1 putj = p1
if(.not. banned(puti,putj,1)) then 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(:) tmp_row2(:,puti) += hij * coefs(:)
end if end if
end do 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) call i_h_j(gen, det, N_int, hij)
else else
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) 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 end if
mat(:, p1, p2) += coefs(:) * hij mat(:, p1, p2) += coefs(:) * hij
end do 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 apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
call i_h_j(gen, det, N_int, hij) call i_h_j(gen, det, N_int, hij)
else 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 end if
mat(:, puti, putj) += coefs(:) * hij mat(:, puti, putj) += coefs(:) * hij
end do end do

21
plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f
View File

@ -34,6 +34,7 @@ subroutine run_wf
double precision :: t0, t1 double precision :: t0, t1
integer, external :: zmq_get_dvector, zmq_get_N_det_generators 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_psi, zmq_get_N_det_selectors
integer, external :: zmq_get_N_states_diag 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_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_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,'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) psi_energy(1:N_states) = energy(1:N_states)
TOUCH psi_energy TOUCH psi_energy threshold_selectors threshold_generators
call wall_time(t1) call wall_time(t1)
call write_double(6,(t1-t0),'Broadcast time') call write_double(6,(t1-t0),'Broadcast time')
@ -105,10 +108,20 @@ subroutine run_wf
call wall_time(t0) call wall_time(t0)
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle 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,'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_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_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) 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 wall_time(t1)
call write_double(6,(t1-t0),'Broadcast time') call write_double(6,(t1-t0),'Broadcast time')
@ -117,9 +130,11 @@ subroutine run_wf
lstop = .False. lstop = .False.
!$OMP PARALLEL PRIVATE(i) !$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num() 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 !$OMP END PARALLEL
print *, 'PT2 done' print *, 'PT2 done'
exit
FREE state_average_weight
endif endif

6
plugins/Full_CI_ZMQ/zmq_selection.irp.f
View File

@ -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 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' stop 'Unable to put energy on ZMQ server'
endif 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) call create_selection_buffer(N, N*2, b)
endif endif

9
src/Determinants/s2.irp.f
View File

@ -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)) allocate(vt(sze_8,N_st))
vt = 0.d0 vt = 0.d0
!$OMP DO SCHEDULE(dynamic)
do sh=1,shortcut(0,1) do sh=1,shortcut(0,1)
!$OMP DO
do sh2=sh,shortcut(0,1) do sh2=sh,shortcut(0,1)
exa = 0 exa = 0
do ni=1,Nint 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
enddo enddo
!$OMP END DO NOWAIT
enddo enddo
!$OMP END DO NOWAIT
!$OMP DO SCHEDULE(dynamic)
do sh=1,shortcut(0,2) do sh=1,shortcut(0,2)
!$OMP DO
do i=shortcut(sh,2),shortcut(sh+1,2)-1 do i=shortcut(sh,2),shortcut(sh+1,2)-1
org_i = sort_idx(i,2) org_i = sort_idx(i,2)
do j=shortcut(sh,2),i-1 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 if
end do end do
end do end do
!$OMP END DO NOWAIT
enddo enddo
!$OMP END DO NOWAIT !$OMP BARRIER
do istate=1,N_st do istate=1,N_st
do i=n,1,-1 do i=n,1,-1

2
src/Integrals_Bielec/map_integrals.irp.f
View File

@ -421,8 +421,8 @@ double precision function mo_bielec_integral(i,j,k,l)
integer, intent(in) :: i,j,k,l integer, intent(in) :: i,j,k,l
double precision :: get_mo_bielec_integral double precision :: get_mo_bielec_integral
PROVIDE mo_bielec_integrals_in_map mo_integrals_cache PROVIDE mo_bielec_integrals_in_map mo_integrals_cache
!DIR$ FORCEINLINE
PROVIDE mo_bielec_integrals_in_map PROVIDE mo_bielec_integrals_in_map
!DIR$ FORCEINLINE
mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
return return
end end

105
src/ZMQ/put_get.irp.f
View File

@ -2,7 +2,7 @@ integer function zmq_put_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_
use f77_zmq use f77_zmq
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Put the X vector on the qp_run scheduler ! Put a float vector on the qp_run scheduler
END_DOC END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id 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 use f77_zmq
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Get psi_coef from the qp_run scheduler ! Get a float vector from the qp_run scheduler
END_DOC END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id 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' print *, irp_here//': Unable to broadcast zmq_get_dvector'
stop -1 stop -1
endif 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 if (ierr /= MPI_SUCCESS) then
print *, irp_here//': Unable to broadcast dvector' print *, irp_here//': Unable to broadcast dvector'
stop -1 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

14
src/ZMQ/utils.irp.f
View File

@ -148,12 +148,12 @@ function new_zmq_to_qp_run_socket()
stop 'Unable to create zmq req socket' stop 'Unable to create zmq req socket'
endif 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 if (rc /= 0) then
stop 'Unable to set send timeout in new_zmq_to_qp_run_socket' stop 'Unable to set send timeout in new_zmq_to_qp_run_socket'
endif 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 if (rc /= 0) then
stop 'Unable to set recv timeout in new_zmq_to_qp_run_socket' stop 'Unable to set recv timeout in new_zmq_to_qp_run_socket'
endif endif
@ -250,7 +250,7 @@ IRP_ENDIF
stop 'Unable to create zmq pull socket' stop 'Unable to create zmq pull socket'
endif 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 if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on pull socket' stop 'Unable to set ZMQ_LINGER on pull socket'
endif endif
@ -332,7 +332,7 @@ IRP_ENDIF
stop 'Unable to create zmq push socket' stop 'Unable to create zmq push socket'
endif 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 if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on push socket' stop 'Unable to set ZMQ_LINGER on push socket'
endif endif
@ -352,7 +352,7 @@ IRP_ENDIF
stop 'Unable to set ZMQ_IMMEDIATE on push socket' stop 'Unable to set ZMQ_IMMEDIATE on push socket'
endif 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 if (rc /= 0) then
stop 'Unable to set send timout in new_zmq_push_socket' stop 'Unable to set send timout in new_zmq_push_socket'
endif endif
@ -488,7 +488,7 @@ subroutine end_zmq_push_socket(zmq_socket_push,thread)
integer :: rc integer :: rc
character*(8), external :: zmq_port 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 if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on push socket' stop 'Unable to set ZMQ_LINGER on push socket'
endif endif
@ -1019,7 +1019,7 @@ subroutine end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
character*(8), external :: zmq_port character*(8), external :: zmq_port
integer :: rc 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 if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket' stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket'
endif endif