mirror of
https://github.com/LCPQ/quantum_package
synced 2024-12-24 13:23:41 +01:00
Merge branch 'master' of github.com:scemama/quantum_package
This commit is contained in:
commit
71264bb8fe
@ -38,7 +38,8 @@ subroutine run_wf
|
||||
integer, external :: zmq_get_dvector, zmq_get_N_det_generators
|
||||
integer, external :: zmq_get8_dvector
|
||||
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, zmq_get_psi_bilinear
|
||||
integer, external :: zmq_get_psi_notouch
|
||||
integer, external :: zmq_get_N_states_diag
|
||||
|
||||
zmq_context = f77_zmq_ctx_new ()
|
||||
@ -131,8 +132,8 @@ subroutine run_wf
|
||||
! --------
|
||||
|
||||
call wall_time(t0)
|
||||
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
|
||||
if (zmq_get_N_states_diag(zmq_to_qp_run_socket,1) == -1) cycle
|
||||
if (zmq_get_psi_bilinear(zmq_to_qp_run_socket,1) == -1) cycle
|
||||
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states_diag) == -1) cycle
|
||||
|
||||
call wall_time(t1)
|
||||
|
||||
@ -84,6 +84,11 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
|
||||
integer, external :: zmq_get_dvector
|
||||
integer, external :: zmq_get_dmatrix
|
||||
|
||||
PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique
|
||||
PROVIDE psi_bilinear_matrix_transp_values psi_bilinear_matrix_values psi_bilinear_matrix_columns_loc
|
||||
PROVIDE ref_bitmask_energy nproc
|
||||
PROVIDE mpi_initialized
|
||||
|
||||
allocate(u_t(N_st,N_det))
|
||||
allocate (energy(N_st))
|
||||
|
||||
@ -96,11 +101,11 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
|
||||
ni = 8388608
|
||||
nj = int(size(u_t,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
if (zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, 'u_t', u_t, ni, nj, size(u_t,kind=8)) == -1) then
|
||||
print *, irp_here, ': Unable to get u_t'
|
||||
deallocate(u_t,energy)
|
||||
return
|
||||
endif
|
||||
|
||||
do while (zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, 'u_t', u_t, ni, nj, size(u_t,kind=8)) == -1)
|
||||
call sleep(1)
|
||||
print *, irp_here, ': waiting for u_t...'
|
||||
enddo
|
||||
|
||||
if (zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'energy', energy, size(energy)) == -1) then
|
||||
print *, irp_here, ': Unable to get energy'
|
||||
@ -293,17 +298,71 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
|
||||
integer :: ithread
|
||||
double precision, allocatable :: u_t(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
|
||||
PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique
|
||||
PROVIDE psi_bilinear_matrix_transp_values psi_bilinear_matrix_values psi_bilinear_matrix_columns_loc
|
||||
PROVIDE ref_bitmask_energy nproc
|
||||
PROVIDE mpi_initialized
|
||||
|
||||
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'davidson')
|
||||
|
||||
if (zmq_put_N_states_diag(zmq_to_qp_run_socket, 1) == -1) then
|
||||
stop 'Unable to put N_states_diag on ZMQ server'
|
||||
endif
|
||||
if (zmq_put_psi_bilinear(zmq_to_qp_run_socket,1) == -1) then
|
||||
stop 'Unable to put psi on ZMQ server'
|
||||
endif
|
||||
energy = 0.d0
|
||||
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',energy,size(energy)) == -1) then
|
||||
stop 'Unable to put energy on ZMQ server'
|
||||
endif
|
||||
|
||||
|
||||
! Create tasks
|
||||
! ============
|
||||
|
||||
integer :: istep, imin, imax, ishift, ipos
|
||||
integer, external :: add_task_to_taskserver
|
||||
integer, parameter :: tasksize=10000
|
||||
character*(100000) :: task
|
||||
istep=1
|
||||
ishift=0
|
||||
imin=1
|
||||
|
||||
|
||||
ipos=1
|
||||
do imin=1,N_det,10000
|
||||
imax = min(N_det,imin-1+tasksize)
|
||||
do ishift=0,istep-1
|
||||
write(task(ipos:ipos+50),'(4(I11,1X),1X,1A)') imin, imax, ishift, istep, '|'
|
||||
ipos = ipos+50
|
||||
if (ipos > 100000-50) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
stop 'Unable to add task'
|
||||
endif
|
||||
ipos=1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (ipos > 1) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
stop 'Unable to add task'
|
||||
endif
|
||||
ipos=1
|
||||
endif
|
||||
|
||||
integer, external :: zmq_set_running
|
||||
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Failed in zmq_set_running'
|
||||
endif
|
||||
|
||||
|
||||
allocate(u_t(N_st,N_det))
|
||||
do k=1,N_st
|
||||
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||
enddo
|
||||
|
||||
call dtranspose( &
|
||||
u_0, &
|
||||
size(u_0, 1), &
|
||||
@ -311,33 +370,17 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
|
||||
size(u_t, 1), &
|
||||
N_det, N_st)
|
||||
|
||||
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
|
||||
|
||||
ASSERT (N_st == N_states_diag)
|
||||
ASSERT (sze >= N_det)
|
||||
|
||||
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'davidson')
|
||||
|
||||
character*(512) :: task
|
||||
integer :: rc, ni, nj
|
||||
integer*8 :: rc8
|
||||
double precision :: energy(N_st)
|
||||
|
||||
integer, external :: zmq_put_dvector, zmq_put_psi, zmq_put_N_states_diag
|
||||
integer, external :: zmq_put_dvector, zmq_put_psi, zmq_put_N_states_diag, zmq_put_psi_bilinear
|
||||
integer, external :: zmq_put_dmatrix
|
||||
|
||||
energy = 0.d0
|
||||
|
||||
if (zmq_put_N_states_diag(zmq_to_qp_run_socket, 1) == -1) then
|
||||
stop 'Unable to put N_states_diag on ZMQ server'
|
||||
endif
|
||||
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
|
||||
stop 'Unable to put psi on ZMQ server'
|
||||
endif
|
||||
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',energy,size(energy)) == -1) then
|
||||
stop 'Unable to put energy on ZMQ server'
|
||||
endif
|
||||
if (size(u_t) < 8388608) then
|
||||
ni = size(u_t)
|
||||
nj = 1
|
||||
@ -354,50 +397,9 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
|
||||
deallocate(u_t)
|
||||
|
||||
|
||||
! Create tasks
|
||||
! ============
|
||||
|
||||
integer :: istep, imin, imax, ishift
|
||||
double precision :: w, max_workload, N_det_inv
|
||||
integer, external :: add_task_to_taskserver
|
||||
w = 0.d0
|
||||
istep=1
|
||||
ishift=0
|
||||
imin=1
|
||||
N_det_inv = 1.d0/dble(N_det)
|
||||
max_workload = 10000.d0
|
||||
do imax=1,N_det
|
||||
w = w + 1.d0
|
||||
if (w > max_workload) then
|
||||
do ishift=0,istep-1
|
||||
write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|'
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
|
||||
stop 'Unable to add task'
|
||||
endif
|
||||
enddo
|
||||
imin = imax+1
|
||||
w = 0.d0
|
||||
endif
|
||||
enddo
|
||||
if (w > 0.d0) then
|
||||
imax = N_det
|
||||
do ishift=0,istep-1
|
||||
write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|'
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
|
||||
stop 'Unable to add task'
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
|
||||
|
||||
v_0 = 0.d0
|
||||
s_0 = 0.d0
|
||||
|
||||
integer, external :: zmq_set_running
|
||||
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Failed in zmq_set_running'
|
||||
endif
|
||||
|
||||
call omp_set_nested(.True.)
|
||||
!$OMP PARALLEL NUM_THREADS(2) PRIVATE(ithread)
|
||||
ithread = omp_get_thread_num()
|
||||
|
||||
@ -2,7 +2,7 @@ program print_energy
|
||||
implicit none
|
||||
read_wf = .true.
|
||||
touch read_wf
|
||||
provide mo_bielec_integrals_in_map
|
||||
provide mo_bielec_integrals_in_map psi_coef psi_det psi_bilinear_matrix_transp_values
|
||||
double precision :: time1, time0
|
||||
call wall_time(time0)
|
||||
call routine
|
||||
|
||||
@ -519,7 +519,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_
|
||||
do k=1,N_det
|
||||
psi_bilinear_matrix_transp_values (k,l) = psi_bilinear_matrix_values (k,l)
|
||||
enddo
|
||||
!$OMP ENDDO
|
||||
!$OMP ENDDO NOWAIT
|
||||
enddo
|
||||
!$OMP DO
|
||||
do k=1,N_det
|
||||
|
||||
@ -40,6 +40,242 @@ end
|
||||
|
||||
|
||||
|
||||
integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get the wave function from the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
|
||||
integer, external :: zmq_get_N_states
|
||||
integer, external :: zmq_get_N_det
|
||||
integer, external :: zmq_get_psi_det_size
|
||||
integer*8, external :: zmq_get_psi_det
|
||||
integer*8, external :: zmq_get_psi_coef
|
||||
|
||||
zmq_get_psi_notouch = 0
|
||||
|
||||
if (zmq_get_N_states(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_get_psi_notouch = -1
|
||||
return
|
||||
endif
|
||||
if (zmq_get_N_det(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_get_psi_notouch = -1
|
||||
return
|
||||
endif
|
||||
if (zmq_get_psi_det_size(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_get_psi_notouch = -1
|
||||
return
|
||||
endif
|
||||
|
||||
if (size(psi_det,kind=8) /= N_int*2_8*psi_det_size*bit_kind) then
|
||||
deallocate(psi_det)
|
||||
allocate(psi_det(N_int,2,psi_det_size))
|
||||
endif
|
||||
|
||||
if (size(psi_coef,kind=8) /= psi_det_size*N_states) then
|
||||
deallocate(psi_coef)
|
||||
allocate(psi_coef(psi_det_size,N_states))
|
||||
endif
|
||||
|
||||
if (zmq_get_psi_det(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_notouch = -1
|
||||
return
|
||||
endif
|
||||
if (zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_notouch = -1
|
||||
return
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get the wave function from the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer, external :: zmq_get_psi_notouch
|
||||
zmq_get_psi = zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id)
|
||||
SOFT_TOUCH psi_det psi_coef psi_det_size N_det N_states
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
integer function zmq_put_psi_bilinear(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Put the wave function on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
character*(256) :: msg
|
||||
|
||||
|
||||
zmq_put_psi_bilinear = 0
|
||||
|
||||
integer, external :: zmq_put_psi
|
||||
if (zmq_put_psi(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_put_psi_bilinear_matrix_columns
|
||||
if (zmq_put_psi_bilinear_matrix_rows(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_put_psi_bilinear_matrix_rows
|
||||
if (zmq_put_psi_bilinear_matrix_columns(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_put_psi_bilinear_matrix_order
|
||||
if (zmq_put_psi_bilinear_matrix_order(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_put_psi_bilinear_matrix_values
|
||||
if (zmq_put_psi_bilinear_matrix_values(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_put_N_det_alpha_unique
|
||||
if (zmq_put_N_det_alpha_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_put_N_det_beta_unique
|
||||
if (zmq_put_N_det_beta_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_put_psi_det_alpha_unique
|
||||
if (zmq_put_psi_det_alpha_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_put_psi_det_beta_unique
|
||||
if (zmq_put_psi_det_beta_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get the wave function from the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
|
||||
integer, external :: zmq_get_psi_notouch
|
||||
if (zmq_get_psi_notouch(zmq_to_qp_run_socket,1) == -1) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
zmq_get_psi_bilinear= 0
|
||||
|
||||
if (size(psi_bilinear_matrix_values,kind=8) /= N_det*N_states) then
|
||||
deallocate(psi_bilinear_matrix_values)
|
||||
allocate(psi_bilinear_matrix_values(N_det,N_states))
|
||||
endif
|
||||
|
||||
if (size(psi_bilinear_matrix_rows,kind=8) /= N_det) then
|
||||
deallocate(psi_bilinear_matrix_rows)
|
||||
allocate(psi_bilinear_matrix_rows(N_det))
|
||||
endif
|
||||
|
||||
if (size(psi_bilinear_matrix_columns,kind=8) /= N_det) then
|
||||
deallocate(psi_bilinear_matrix_columns)
|
||||
allocate(psi_bilinear_matrix_columns(N_det))
|
||||
endif
|
||||
|
||||
if (size(psi_bilinear_matrix_order,kind=8) /= N_det) then
|
||||
deallocate(psi_bilinear_matrix_order)
|
||||
allocate(psi_bilinear_matrix_order(N_det))
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_get_psi_bilinear_matrix_values
|
||||
if (zmq_get_psi_bilinear_matrix_values(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_get_psi_bilinear_matrix_rows
|
||||
if (zmq_get_psi_bilinear_matrix_rows(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_get_psi_bilinear_matrix_columns
|
||||
if (zmq_get_psi_bilinear_matrix_columns(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_get_psi_bilinear_matrix_order
|
||||
if (zmq_get_psi_bilinear_matrix_order(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
|
||||
integer*8, external :: zmq_get_N_det_alpha_unique
|
||||
if (zmq_get_N_det_alpha_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_get_N_det_beta_unique
|
||||
if (zmq_get_N_det_beta_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_get_psi_det_alpha_unique
|
||||
if (zmq_get_psi_det_alpha_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_get_psi_det_beta_unique
|
||||
if (zmq_get_psi_det_beta_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
SOFT_TOUCH psi_bilinear_matrix_values psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef psi_det_size N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
integer function zmq_put_$X(zmq_to_qp_run_socket,worker_id)
|
||||
@ -136,15 +372,20 @@ SUBST [ X ]
|
||||
|
||||
N_states ;;
|
||||
N_det ;;
|
||||
N_det_alpha_unique ;;
|
||||
N_det_beta_unique ;;
|
||||
psi_det_size ;;
|
||||
|
||||
END_TEMPLATE
|
||||
|
||||
integer*8 function zmq_put_psi_det(zmq_to_qp_run_socket,worker_id)
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
integer*8 function zmq_put_$X(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Put psi_det on the qp_run scheduler
|
||||
! Put $X on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
@ -154,49 +395,22 @@ integer*8 function zmq_put_psi_det(zmq_to_qp_run_socket,worker_id)
|
||||
integer*8 :: zmq_put_i8matrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size(psi_det,kind=8) <= 8388608_8) then
|
||||
ni = size(psi_det,kind=4)
|
||||
if (size($X,kind=8) <= 8388608_8) then
|
||||
ni = size($X,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608_8
|
||||
nj = int(size(psi_det,kind=8)/8388608_8,4) + 1
|
||||
nj = int(size($X,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_put_i8matrix(zmq_to_qp_run_socket, 1, 'psi_det', psi_det, ni, nj, size(psi_det,kind=8))
|
||||
zmq_put_psi_det = rc8
|
||||
rc8 = zmq_put_i8matrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8))
|
||||
zmq_put_$X = rc8
|
||||
end
|
||||
|
||||
integer*8 function zmq_put_psi_coef(zmq_to_qp_run_socket,worker_id)
|
||||
integer*8 function zmq_get_$X(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Put psi_coef on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer*8 :: rc8
|
||||
character*(256) :: msg
|
||||
|
||||
zmq_put_psi_coef = 0
|
||||
|
||||
integer*8 :: zmq_put_dmatrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size(psi_coef,kind=8) <= 8388608_8) then
|
||||
ni = size(psi_coef,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size(psi_coef,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_put_dmatrix(zmq_to_qp_run_socket, 1, 'psi_coef', psi_coef, ni, nj, size(psi_coef,kind=8) )
|
||||
zmq_put_psi_coef = rc8
|
||||
end
|
||||
|
||||
integer*8 function zmq_get_psi_det(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get psi_det on the qp_run scheduler
|
||||
! Get $X on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
@ -206,99 +420,150 @@ integer*8 function zmq_get_psi_det(zmq_to_qp_run_socket,worker_id)
|
||||
integer*8 :: zmq_get_i8matrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size(psi_det,kind=8) <= 8388608_8) then
|
||||
ni = size(psi_det,kind=4)
|
||||
if (size($X,kind=8) <= 8388608_8) then
|
||||
ni = size($X,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size(psi_det,kind=8)/8388608_8,4) + 1
|
||||
nj = int(size($X,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_get_i8matrix(zmq_to_qp_run_socket, 1, 'psi_det', psi_det, ni, nj, size(psi_det,kind=8))
|
||||
zmq_get_psi_det = rc8
|
||||
rc8 = zmq_get_i8matrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8))
|
||||
zmq_get_$X = rc8
|
||||
end
|
||||
|
||||
integer*8 function zmq_get_psi_coef(zmq_to_qp_run_socket,worker_id)
|
||||
SUBST [ X ]
|
||||
|
||||
psi_det ;;
|
||||
psi_det_alpha_unique ;;
|
||||
psi_det_beta_unique ;;
|
||||
|
||||
END_TEMPLATE
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
integer*8 function zmq_put_$X(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! get psi_coef on the qp_run scheduler
|
||||
! Put $X on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer*8 :: rc8
|
||||
character*(256) :: msg
|
||||
|
||||
zmq_get_psi_coef = 0_8
|
||||
integer*8 :: zmq_put_imatrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size($X,kind=8) <= 8388608_8) then
|
||||
ni = size($X,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608_8
|
||||
nj = int(size($X,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_put_imatrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8))
|
||||
zmq_put_$X = rc8
|
||||
end
|
||||
|
||||
integer*8 function zmq_get_$X(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get $X on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer*8 :: rc8
|
||||
character*(256) :: msg
|
||||
|
||||
integer*8 :: zmq_get_imatrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size($X,kind=8) <= 8388608_8) then
|
||||
ni = size($X,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size($X,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_get_imatrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8))
|
||||
zmq_get_$X = rc8
|
||||
end
|
||||
|
||||
SUBST [ X ]
|
||||
|
||||
psi_bilinear_matrix_rows ;;
|
||||
psi_bilinear_matrix_columns ;;
|
||||
psi_bilinear_matrix_order ;;
|
||||
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
integer*8 function zmq_put_$X(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Put $X on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer*8 :: rc8
|
||||
character*(256) :: msg
|
||||
|
||||
zmq_put_$X = 0
|
||||
|
||||
integer*8 :: zmq_put_dmatrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size($X,kind=8) <= 8388608_8) then
|
||||
ni = size($X,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size($X,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_put_dmatrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8) )
|
||||
zmq_put_$X = rc8
|
||||
end
|
||||
|
||||
integer*8 function zmq_get_$X(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! get $X on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer*8 :: rc8
|
||||
character*(256) :: msg
|
||||
|
||||
zmq_get_$X = 0_8
|
||||
|
||||
integer*8 :: zmq_get_dmatrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size(psi_coef,kind=8) <= 8388608_8) then
|
||||
ni = size(psi_coef,kind=4)
|
||||
if (size($X,kind=8) <= 8388608_8) then
|
||||
ni = size($X,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size(psi_coef,kind=8)/8388608_8,4) + 1
|
||||
nj = int(size($X,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_get_dmatrix(zmq_to_qp_run_socket, 1, 'psi_coef', psi_coef, ni, nj, size(psi_coef,kind=8) )
|
||||
zmq_get_psi_coef = rc8
|
||||
rc8 = zmq_get_dmatrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8) )
|
||||
zmq_get_$X = rc8
|
||||
end
|
||||
|
||||
SUBST [ X ]
|
||||
|
||||
psi_coef ;;
|
||||
psi_bilinear_matrix_values ;;
|
||||
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
|
||||
|
||||
integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get the wave function from the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
|
||||
integer, external :: zmq_get_N_states
|
||||
integer, external :: zmq_get_N_det
|
||||
integer, external :: zmq_get_psi_det_size
|
||||
integer*8, external :: zmq_get_psi_det
|
||||
integer*8, external :: zmq_get_psi_coef
|
||||
|
||||
zmq_get_psi = 0
|
||||
|
||||
if (zmq_get_N_states(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_get_psi = -1
|
||||
return
|
||||
endif
|
||||
if (zmq_get_N_det(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_get_psi = -1
|
||||
return
|
||||
endif
|
||||
if (zmq_get_psi_det_size(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_get_psi = -1
|
||||
return
|
||||
endif
|
||||
|
||||
if (size(psi_det,kind=8) /= N_int*2_8*psi_det_size*bit_kind) then
|
||||
deallocate(psi_det)
|
||||
allocate(psi_det(N_int,2,psi_det_size))
|
||||
endif
|
||||
|
||||
if (size(psi_coef,kind=8) /= psi_det_size*N_states) then
|
||||
deallocate(psi_coef)
|
||||
allocate(psi_coef(psi_det_size,N_states))
|
||||
endif
|
||||
|
||||
if (zmq_get_psi_det(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi = -1
|
||||
return
|
||||
endif
|
||||
if (zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi = -1
|
||||
return
|
||||
endif
|
||||
SOFT_TOUCH psi_det psi_coef psi_det_size N_det N_states
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -456,16 +456,16 @@ BEGIN_TEMPLATE
|
||||
iorder(i) = iorder1(1_$int_type+i1-i)
|
||||
enddo
|
||||
endif
|
||||
deallocate(x1,iorder1,stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to deallocate arrays x1, iorder1'
|
||||
stop
|
||||
endif
|
||||
|
||||
if (i2>1_$int_type) then
|
||||
call $Xradix_sort$big(x(i1+1_$int_type),iorder(i1+1_$int_type),i2,-2)
|
||||
endif
|
||||
|
||||
deallocate(x1,iorder1,stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to deallocate arrays x1, iorder1'
|
||||
stop
|
||||
endif
|
||||
return
|
||||
|
||||
else if (iradix == -2) then ! Positive
|
||||
@ -526,13 +526,23 @@ BEGIN_TEMPLATE
|
||||
endif
|
||||
|
||||
|
||||
!$OMP PARALLEL DEFAULT(SHARED) if (isize > 1000000)
|
||||
!$OMP SINGLE
|
||||
if (i3>1_$int_type) then
|
||||
!$OMP TASK FIRSTPRIVATE(iradix_new,i3) SHARED(x,iorder) if(i3 > 1000000)
|
||||
call $Xradix_sort$big(x,iorder,i3,iradix_new-1)
|
||||
!$OMP END TASK
|
||||
endif
|
||||
|
||||
if (isize-i3>1_$int_type) then
|
||||
!$OMP TASK FIRSTPRIVATE(iradix_new,i3) SHARED(x,iorder) if(isize-i3 > 1000000)
|
||||
call $Xradix_sort$big(x(i3+1_$int_type),iorder(i3+1_$int_type),isize-i3,iradix_new-1)
|
||||
!$OMP END TASK
|
||||
endif
|
||||
|
||||
!$OMP TASKWAIT
|
||||
!$OMP END SINGLE
|
||||
!$OMP END PARALLEL
|
||||
|
||||
return
|
||||
endif
|
||||
@ -588,11 +598,16 @@ BEGIN_TEMPLATE
|
||||
|
||||
|
||||
if (i1>1_$int_type) then
|
||||
!$OMP TASK FIRSTPRIVATE(i0,iradix,i1) SHARED(x,iorder) if(i1 >1000000)
|
||||
call $Xradix_sort$big(x(i0+1_$int_type),iorder(i0+1_$int_type),i1,iradix-1)
|
||||
!$OMP END TASK
|
||||
endif
|
||||
if (i0>1) then
|
||||
!$OMP TASK FIRSTPRIVATE(i0,iradix) SHARED(x,iorder) if(i0 >1000000)
|
||||
call $Xradix_sort$big(x,iorder,i0,iradix-1)
|
||||
!$OMP END TASK
|
||||
endif
|
||||
!$OMP TASKWAIT
|
||||
|
||||
end
|
||||
|
||||
|
||||
@ -608,13 +608,13 @@ integer function zmq_get_int(zmq_to_qp_run_socket, worker_id, name, x)
|
||||
include 'mpif.h'
|
||||
call MPI_BCAST (zmq_get_int, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
print *, irp_here//': Unable to broadcast zmq_get_i8matrix'
|
||||
print *, irp_here//': Unable to broadcast zmq_get_int'
|
||||
stop -1
|
||||
endif
|
||||
call MPI_BARRIER(MPI_COMM_WORLD,ierr)
|
||||
call MPI_BCAST (x, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
print *, irp_here//': Unable to broadcast zmq_get_i8matrix'
|
||||
print *, irp_here//': Unable to broadcast zmq_get_int'
|
||||
stop -1
|
||||
endif
|
||||
IRP_ENDIF
|
||||
@ -723,7 +723,7 @@ integer function zmq_get_i8matrix(zmq_to_qp_run_socket, worker_id, name, x, size
|
||||
integer, intent(in) :: size_x1, size_x2
|
||||
integer*8, intent(in) :: sze
|
||||
character*(*), intent(in) :: name
|
||||
double precision, intent(out) :: x(size_x1,size_x2)
|
||||
integer*8, intent(out) :: x(size_x1,size_x2)
|
||||
integer*8 :: rc, ni
|
||||
integer*8 :: j
|
||||
character*(256) :: msg
|
||||
@ -777,7 +777,7 @@ integer function zmq_get_i8matrix(zmq_to_qp_run_socket, worker_id, name, x, size
|
||||
stop -1
|
||||
endif
|
||||
call MPI_BARRIER(MPI_COMM_WORLD,ierr)
|
||||
call broadcast_chunks_double(x, sze)
|
||||
call broadcast_chunks_integer8(x, sze)
|
||||
IRP_ENDIF
|
||||
|
||||
end
|
||||
@ -786,3 +786,124 @@ end
|
||||
|
||||
|
||||
|
||||
integer function zmq_put_imatrix(zmq_to_qp_run_socket, worker_id, name, x, size_x1, size_x2, sze)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! 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
|
||||
character*(*) :: name
|
||||
integer, intent(in) :: size_x1, size_x2
|
||||
integer*8, intent(in) :: sze
|
||||
integer, intent(in) :: x(size_x1, size_x2)
|
||||
integer*8 :: rc, ni
|
||||
integer*8 :: j
|
||||
character*(256) :: msg
|
||||
|
||||
zmq_put_imatrix = 0
|
||||
|
||||
ni = size_x1
|
||||
do j=1,size_x2
|
||||
if (j == size_x2) then
|
||||
ni = sze - (j-1_8)*int(size_x1,8)
|
||||
endif
|
||||
write(msg,'(A,1X,I8,1X,A,I8.8)') 'put_data '//trim(zmq_state), worker_id, trim(name), j
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
|
||||
if (rc /= len(trim(msg))) then
|
||||
zmq_put_imatrix = -1
|
||||
print *, irp_here, 'Failed in put_data', rc, j
|
||||
return
|
||||
endif
|
||||
|
||||
rc = f77_zmq_send8(zmq_to_qp_run_socket,x(1,j),ni*4_8,0)
|
||||
if (rc /= ni*4_8) then
|
||||
print *, irp_here, 'Failed in send ', rc, j
|
||||
zmq_put_imatrix = -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
|
||||
print *, irp_here, 'Failed in recv ', rc, j
|
||||
zmq_put_imatrix = -1
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
|
||||
integer function zmq_get_imatrix(zmq_to_qp_run_socket, worker_id, name, x, size_x1, size_x2, sze)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! 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
|
||||
integer, intent(in) :: size_x1, size_x2
|
||||
integer*8, intent(in) :: sze
|
||||
character*(*), intent(in) :: name
|
||||
integer, intent(out) :: x(size_x1,size_x2)
|
||||
integer*8 :: rc, ni
|
||||
integer*8 :: j
|
||||
character*(256) :: msg
|
||||
|
||||
PROVIDE zmq_state
|
||||
! Success
|
||||
zmq_get_imatrix = 0
|
||||
|
||||
if (mpi_master) then
|
||||
ni = size_x1
|
||||
do j=1, size_x2
|
||||
if (j == size_x2) then
|
||||
ni = sze - (j-1)*size_x1
|
||||
endif
|
||||
write(msg,'(A,1X,I8,1X,A,I8.8)') 'get_data '//trim(zmq_state), worker_id, trim(name),j
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
|
||||
if (rc /= len(trim(msg))) then
|
||||
zmq_get_imatrix = -1
|
||||
print *, irp_here, 'rc /= len(trim(msg))', rc, len(trim(msg))
|
||||
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
|
||||
print *, irp_here, 'msg(1:14) /= get_data_reply', msg(1:14)
|
||||
zmq_get_imatrix = -1
|
||||
go to 10
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv8(zmq_to_qp_run_socket,x(1,j),ni*4_8,0)
|
||||
if (rc /= ni*4_8) then
|
||||
print *, irp_here, 'rc /= ni*8', rc, ni*4_8
|
||||
zmq_get_imatrix = -1
|
||||
go to 10
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
|
||||
10 continue
|
||||
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
integer :: ierr
|
||||
include 'mpif.h'
|
||||
call MPI_BCAST (zmq_get_imatrix, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
print *, irp_here//': Unable to broadcast zmq_get_imatrix'
|
||||
stop -1
|
||||
endif
|
||||
call MPI_BARRIER(MPI_COMM_WORLD,ierr)
|
||||
call broadcast_chunks_integer(x, sze)
|
||||
IRP_ENDIF
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user