2018-03-30 18:16:00 +02:00
|
|
|
use bitmasks
|
|
|
|
|
2017-12-15 16:21:04 +01:00
|
|
|
|
2018-05-01 13:16:10 +02:00
|
|
|
subroutine run_dress_slave(thread,iproce,energy)
|
2017-12-15 16:21:04 +01:00
|
|
|
use f77_zmq
|
2018-05-01 17:43:46 +02:00
|
|
|
use omp_lib
|
2017-12-15 16:21:04 +01:00
|
|
|
implicit none
|
|
|
|
|
|
|
|
double precision, intent(in) :: energy(N_states_diag)
|
2018-05-01 13:16:10 +02:00
|
|
|
integer, intent(in) :: thread, iproce
|
|
|
|
integer :: rc, i, subset, i_generator
|
2017-12-15 16:21:04 +01:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
integer :: worker_id, ctask, ltask
|
2018-04-27 12:41:39 +02:00
|
|
|
character*(5120) :: task
|
2017-12-15 16:21:04 +01:00
|
|
|
|
|
|
|
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
|
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
double precision,allocatable :: breve_delta_m(:,:,:)
|
|
|
|
integer :: i_state,m,l,t,p,sum_f
|
2018-05-01 17:43:46 +02:00
|
|
|
!integer, external :: omp_get_thread_num
|
2018-08-29 20:54:58 +02:00
|
|
|
double precision, allocatable :: delta_det(:,:,:,:), cp(:,:,:,:), edI(:)
|
|
|
|
double precision, allocatable :: edI_task(:)
|
|
|
|
integer, allocatable :: edI_index(:), edI_taskID(:)
|
|
|
|
integer :: n_tasks
|
|
|
|
|
|
|
|
integer :: iproc
|
|
|
|
integer, allocatable :: f(:)
|
|
|
|
integer :: cp_sent, cp_done
|
|
|
|
integer :: cp_max(Nproc)
|
2018-09-01 16:58:07 +02:00
|
|
|
integer :: will_send, task_id, purge_task_id
|
2018-08-29 20:54:58 +02:00
|
|
|
integer(kind=OMP_LOCK_KIND) :: lck_det(0:pt2_N_teeth+1)
|
|
|
|
integer(kind=OMP_LOCK_KIND) :: lck_sto(0:dress_N_cp+1), sending
|
2018-05-01 13:16:10 +02:00
|
|
|
double precision :: fac
|
2018-08-29 20:54:58 +02:00
|
|
|
|
2018-05-01 13:16:10 +02:00
|
|
|
if(iproce /= 0) stop "RUN DRESS SLAVE is OMP"
|
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
allocate(delta_det(N_states, N_det, 0:pt2_N_teeth+1, 2))
|
|
|
|
allocate(cp(N_states, N_det, dress_N_cp, 2))
|
|
|
|
allocate(edI(N_det_generators), f(N_det_generators))
|
|
|
|
allocate(edI_index(N_det_generators), edI_task(N_det_generators))
|
|
|
|
edI = 0d0
|
|
|
|
f = 0
|
2018-08-30 15:24:07 +02:00
|
|
|
delta_det = 0d0
|
2018-05-01 13:16:10 +02:00
|
|
|
cp = 0d0
|
|
|
|
|
2018-04-27 12:41:39 +02:00
|
|
|
task(:) = CHAR(0)
|
2017-12-15 16:21:04 +01:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
call omp_init_lock(sending)
|
|
|
|
do i=0,dress_N_cp+1
|
2018-05-01 17:43:46 +02:00
|
|
|
call omp_init_lock(lck_sto(i))
|
|
|
|
end do
|
2018-08-29 20:54:58 +02:00
|
|
|
do i=0,pt2_N_teeth+1
|
2018-05-01 17:43:46 +02:00
|
|
|
call omp_init_lock(lck_det(i))
|
|
|
|
end do
|
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
cp_done = 0
|
|
|
|
cp_sent = 0
|
|
|
|
will_send = 0
|
2018-05-01 13:16:10 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
double precision :: hij, sij, tmp
|
2018-08-30 20:52:05 +02:00
|
|
|
logical :: purge
|
|
|
|
purge_task_id = 0
|
2018-05-14 13:00:04 +02:00
|
|
|
hij = E0_denominator(1) !PROVIDE BEFORE OMP PARALLEL
|
|
|
|
|
2018-05-01 15:08:41 +02:00
|
|
|
!$OMP PARALLEL DEFAULT(SHARED) &
|
2018-08-29 20:54:58 +02:00
|
|
|
!$OMP PRIVATE(breve_delta_m, task, task_id) &
|
2018-08-30 15:24:07 +02:00
|
|
|
!$OMP PRIVATE(tmp,fac,m,l,t,sum_f,n_tasks) &
|
|
|
|
!$OMP PRIVATE(i,p,will_send, i_generator, subset, iproc) &
|
2018-05-01 17:43:46 +02:00
|
|
|
!$OMP PRIVATE(zmq_to_qp_run_socket, zmq_socket_push, worker_id)
|
|
|
|
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
|
|
|
zmq_socket_push = new_zmq_push_socket(thread)
|
|
|
|
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
|
|
|
|
if(worker_id == -1) then
|
|
|
|
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
|
|
|
call end_zmq_push_socket(zmq_socket_push,thread)
|
|
|
|
stop "WORKER -1"
|
|
|
|
end if
|
|
|
|
|
2018-05-01 15:08:41 +02:00
|
|
|
iproc = omp_get_thread_num()+1
|
2018-08-29 20:54:58 +02:00
|
|
|
allocate(breve_delta_m(N_states,N_det,2))
|
|
|
|
|
|
|
|
|
2018-08-30 20:52:05 +02:00
|
|
|
do while(cp_done > cp_sent .or. m /= dress_N_cp+1)
|
2018-05-01 15:08:41 +02:00
|
|
|
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
|
|
|
|
task = task//" 0"
|
2018-05-14 13:00:04 +02:00
|
|
|
if(task_id /= 0) then
|
|
|
|
read (task,*) subset, i_generator
|
2018-08-29 20:54:58 +02:00
|
|
|
m = dress_P(i_generator)
|
|
|
|
else
|
|
|
|
m = dress_N_cp + 1
|
2018-05-01 15:08:41 +02:00
|
|
|
end if
|
2018-08-29 20:54:58 +02:00
|
|
|
|
|
|
|
will_send = 0
|
|
|
|
|
2018-05-01 15:08:41 +02:00
|
|
|
!$OMP CRITICAL
|
2018-08-29 20:54:58 +02:00
|
|
|
cp_max(iproc) = m
|
|
|
|
cp_done = minval(cp_max)-1
|
|
|
|
if(cp_done > cp_sent) then
|
|
|
|
will_send = cp_sent + 1
|
|
|
|
cp_sent = will_send
|
2018-05-01 15:08:41 +02:00
|
|
|
end if
|
2018-09-01 16:58:07 +02:00
|
|
|
if(purge_task_id == 0) then
|
|
|
|
purge_task_id = task_id
|
2018-08-30 20:52:05 +02:00
|
|
|
task_id = 0
|
|
|
|
end if
|
2018-05-01 15:08:41 +02:00
|
|
|
!$OMP END CRITICAL
|
2018-05-14 13:00:04 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
if(will_send /= 0) then
|
|
|
|
breve_delta_m = 0d0
|
|
|
|
|
2018-08-30 20:52:05 +02:00
|
|
|
do l=will_send, 1,-1
|
2018-08-29 20:54:58 +02:00
|
|
|
breve_delta_m(:,:,1) += cp(:,:,l,1)
|
|
|
|
breve_delta_m(:,:,2) += cp(:,:,l,2)
|
2018-05-01 13:16:10 +02:00
|
|
|
end do
|
|
|
|
|
2018-08-30 15:24:07 +02:00
|
|
|
breve_delta_m(:,:,:) = breve_delta_m(:,:,:) / dress_M_m(will_send)
|
2018-08-29 20:54:58 +02:00
|
|
|
|
|
|
|
do t=dress_dot_t(will_send)-1,0,-1
|
|
|
|
breve_delta_m(:,:,1) = breve_delta_m(:,:,1) + delta_det(:,:,t,1)
|
|
|
|
breve_delta_m(:,:,2) = breve_delta_m(:,:,2) + delta_det(:,:,t,2)
|
|
|
|
end do
|
|
|
|
|
|
|
|
call omp_set_lock(sending)
|
|
|
|
n_tasks = 0
|
|
|
|
sum_f = 0
|
|
|
|
do i=1,N_det_generators
|
|
|
|
if(dress_P(i) == will_send .and. f(i) /= 0) then
|
|
|
|
n_tasks += 1
|
|
|
|
edI_task(n_tasks) = edI(i)
|
|
|
|
edI_index(n_tasks) = i
|
|
|
|
sum_f += f(i)
|
|
|
|
end if
|
2018-05-01 13:16:10 +02:00
|
|
|
end do
|
2018-09-01 16:58:07 +02:00
|
|
|
call push_dress_results(zmq_socket_push, will_send, sum_f, edI_task, edI_index, breve_delta_m, 0, n_tasks)
|
2018-08-30 21:24:45 +02:00
|
|
|
!call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,purge_task_id(will_send))
|
2018-08-29 20:54:58 +02:00
|
|
|
call omp_unset_lock(sending)
|
2017-12-15 16:21:04 +01:00
|
|
|
end if
|
2018-08-29 20:54:58 +02:00
|
|
|
|
|
|
|
if(m /= dress_N_cp+1) then
|
|
|
|
!UPDATE i_generator
|
|
|
|
|
|
|
|
breve_delta_m(:,:,:) = 0d0
|
|
|
|
call generator_start(i_generator, iproc)
|
|
|
|
|
|
|
|
call alpha_callback(breve_delta_m, i_generator, subset, pt2_F(i_generator)*0 + 1, iproc)
|
|
|
|
|
|
|
|
t = dress_T(i_generator)
|
|
|
|
|
|
|
|
call omp_set_lock(lck_det(t))
|
|
|
|
delta_det(:,:,t, 1) += breve_delta_m(:,:,1)
|
|
|
|
delta_det(:,:,t, 2) += breve_delta_m(:,:,2)
|
|
|
|
call omp_unset_lock(lck_det(t))
|
|
|
|
|
2018-08-30 15:24:07 +02:00
|
|
|
do p=1,dress_N_cp
|
|
|
|
if(dress_e(i_generator, p) /= 0d0) then
|
|
|
|
fac = dress_e(i_generator, p)
|
2018-08-29 20:54:58 +02:00
|
|
|
call omp_set_lock(lck_sto(p))
|
|
|
|
cp(:,:,p,1) += breve_delta_m(:,:,1) * fac
|
|
|
|
cp(:,:,p,2) += breve_delta_m(:,:,2) * fac
|
|
|
|
call omp_unset_lock(lck_sto(p))
|
|
|
|
end if
|
|
|
|
end do
|
|
|
|
|
|
|
|
tmp = 0d0
|
2018-08-30 15:24:07 +02:00
|
|
|
do i=N_det,1,-1
|
2018-08-29 20:54:58 +02:00
|
|
|
tmp += psi_coef(i, dress_stoch_istate)*breve_delta_m(dress_stoch_istate, i, 1)
|
|
|
|
end do
|
|
|
|
!$OMP ATOMIC
|
2018-08-30 15:24:07 +02:00
|
|
|
edI(i_generator) += tmp
|
2018-08-29 20:54:58 +02:00
|
|
|
!$OMP ATOMIC
|
|
|
|
f(i_generator) += 1
|
|
|
|
!push bidon
|
2018-08-30 20:52:05 +02:00
|
|
|
if(task_id /= 0) then
|
2018-08-30 21:24:45 +02:00
|
|
|
!call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
|
2018-08-30 20:52:05 +02:00
|
|
|
call push_dress_results(zmq_socket_push, 0, 0, edI_task, edI_index, breve_delta_m, task_id, 1)
|
|
|
|
end if
|
2018-08-29 20:54:58 +02:00
|
|
|
end if
|
2017-12-15 16:21:04 +01:00
|
|
|
end do
|
2018-08-30 20:52:05 +02:00
|
|
|
!$OMP BARRIER
|
|
|
|
!$OMP SINGLE
|
2018-09-01 16:58:07 +02:00
|
|
|
!do m=1,dress_N_cp
|
|
|
|
if(purge_task_id /= 0) then
|
2018-08-30 21:24:45 +02:00
|
|
|
!call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,purge_task_id(m))
|
2018-09-01 16:58:07 +02:00
|
|
|
call push_dress_results(zmq_socket_push, 0, 0, edI_task, edI_index, breve_delta_m, purge_task_id, 1)
|
2018-08-30 20:52:05 +02:00
|
|
|
end if
|
2018-09-01 16:58:07 +02:00
|
|
|
!end do
|
2018-08-30 20:52:05 +02:00
|
|
|
!$OMP END SINGLE
|
|
|
|
|
2018-05-14 13:00:04 +02:00
|
|
|
call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id)
|
2017-12-15 16:21:04 +01:00
|
|
|
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
|
|
|
call end_zmq_push_socket(zmq_socket_push,thread)
|
2018-05-01 17:43:46 +02:00
|
|
|
!$OMP END PARALLEL
|
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
do i=0,dress_N_cp+1
|
2018-05-01 17:43:46 +02:00
|
|
|
call omp_destroy_lock(lck_sto(i))
|
|
|
|
end do
|
2018-08-29 20:54:58 +02:00
|
|
|
do i=0,pt2_N_teeth+1
|
2018-05-01 17:43:46 +02:00
|
|
|
call omp_destroy_lock(lck_det(i))
|
2018-05-02 14:32:41 +02:00
|
|
|
end do
|
2017-12-15 16:21:04 +01:00
|
|
|
end subroutine
|
|
|
|
|
|
|
|
|
2018-03-30 18:16:00 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
subroutine push_dress_results(zmq_socket_push, m_task, f, edI_task, edI_index, breve_delta_m, task_id, n_tasks)
|
2017-12-15 16:21:04 +01:00
|
|
|
use f77_zmq
|
|
|
|
implicit none
|
|
|
|
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
|
2018-08-29 20:54:58 +02:00
|
|
|
integer, intent(in) :: m_task, f, edI_index(n_tasks)
|
|
|
|
double precision, intent(in) :: breve_delta_m(N_states, N_det, 2), edI_task(n_tasks)
|
|
|
|
integer, intent(in) :: task_id, n_tasks
|
|
|
|
integer :: rc, i, j, k
|
|
|
|
rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
|
|
|
|
if(rc /= 4) stop "push1"
|
2018-04-30 13:25:58 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_send( zmq_socket_push, task_id, 4, ZMQ_SNDMORE)
|
|
|
|
if(rc /= 4) stop "push2"
|
2018-05-01 13:16:10 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_send( zmq_socket_push, m_task, 4, ZMQ_SNDMORE)
|
|
|
|
if(rc /= 4) stop "push3"
|
2018-04-29 17:09:46 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_send( zmq_socket_push, f, 4, ZMQ_SNDMORE)
|
|
|
|
if(rc /= 4) stop "push4"
|
2018-08-30 20:52:05 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_send( zmq_socket_push, edI_task, 8*n_tasks, ZMQ_SNDMORE)
|
|
|
|
if(rc /= 8*n_tasks) stop "push5"
|
2018-04-04 11:32:27 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_send( zmq_socket_push, edI_index, 4*n_tasks, ZMQ_SNDMORE)
|
|
|
|
if(rc /= 4*n_tasks) stop "push6"
|
2018-08-30 20:52:05 +02:00
|
|
|
|
|
|
|
if(m_task /= 0) then
|
|
|
|
rc = f77_zmq_send( zmq_socket_push, breve_delta_m, 8*N_det*N_states*2, 0)
|
|
|
|
if(rc /= 8*N_det*N_states*2) stop "push6"
|
|
|
|
else
|
|
|
|
rc = f77_zmq_send( zmq_socket_push, breve_delta_m, 8, 0)
|
|
|
|
if(rc /= 8) stop "push6"
|
|
|
|
end if
|
2018-08-29 20:54:58 +02:00
|
|
|
! Activate is zmq_socket_pull is a REP
|
2017-12-15 16:21:04 +01:00
|
|
|
IRP_IF ZMQ_PUSH
|
|
|
|
IRP_ELSE
|
|
|
|
character*(2) :: ok
|
|
|
|
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
|
|
|
|
IRP_ENDIF
|
|
|
|
end subroutine
|
|
|
|
|
|
|
|
|
2018-05-02 14:32:41 +02:00
|
|
|
|
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
subroutine pull_dress_results(zmq_socket_pull, m_task, f, edI_task, edI_index, breve_delta_m, task_id, n_tasks)
|
2017-12-15 16:21:04 +01:00
|
|
|
use f77_zmq
|
|
|
|
implicit none
|
|
|
|
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
|
2018-08-29 20:54:58 +02:00
|
|
|
integer, intent(out) :: m_task, f, edI_index(N_det_generators)
|
|
|
|
double precision, intent(out) :: breve_delta_m(N_states, N_det, 2), edI_task(N_det_generators)
|
|
|
|
integer, intent(out) :: task_id, n_tasks
|
2018-05-01 13:16:10 +02:00
|
|
|
integer :: rc, i, j, k
|
2018-04-30 09:33:25 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0)
|
|
|
|
if(rc /= 4) stop "pullc"
|
2018-05-02 14:32:41 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
|
|
|
|
if(rc /= 4) stop "pull4"
|
2018-05-02 14:32:41 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_recv( zmq_socket_pull, m_task, 4, 0)
|
|
|
|
if(rc /= 4) stop "pullc"
|
2018-03-30 18:16:00 +02:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_recv( zmq_socket_pull, f, 4, 0)
|
|
|
|
if(rc /= 4) stop "pullc"
|
2017-12-15 16:21:04 +01:00
|
|
|
|
2018-08-29 20:54:58 +02:00
|
|
|
rc = f77_zmq_recv( zmq_socket_pull, edI_task, 8*n_tasks, 0)
|
|
|
|
if(rc /= 8*n_tasks) stop "pullc"
|
|
|
|
|
|
|
|
rc = f77_zmq_recv( zmq_socket_pull, edI_index, 4*n_tasks, 0)
|
|
|
|
if(rc /= 4*n_tasks) stop "pullc"
|
2018-08-30 20:52:05 +02:00
|
|
|
if(m_task /= 0) then
|
|
|
|
rc = f77_zmq_recv( zmq_socket_pull, breve_delta_m, 8*N_det*N_states*2, 0)
|
|
|
|
if(rc /= 8*N_det*N_states*2) stop "pullc"
|
|
|
|
else
|
|
|
|
rc = f77_zmq_recv( zmq_socket_pull, breve_delta_m, 8, 0)
|
|
|
|
if(rc /= 8) stop "pullc"
|
|
|
|
end if
|
2017-12-15 16:21:04 +01:00
|
|
|
! Activate is zmq_socket_pull is a REP
|
|
|
|
IRP_IF ZMQ_PUSH
|
|
|
|
IRP_ELSE
|
|
|
|
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
|
|
|
|
IRP_ENDIF
|
|
|
|
|
|
|
|
end subroutine
|
|
|
|
|
|
|
|
|
|
|
|
|