LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-25 13:53:49 +01:00
Code Issues Releases Wiki Activity
9ebb88cbf3
quantum_package/plugins/dress_zmq/run_dress_slave.irp.f
Anthony Scemama 873035e016 Squashed commit of the following: 
commit 4b9c435dce0f3b3078d573e66fd32b40fca26497
Merge: 74e559c8 093e3fd0
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date:   Tue Sep 4 16:58:51 2018 +0200

    Merge branch 'thesis' of git://github.com/garniron/quantum_package into garniron-thesis

commit 093e3fd021
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Tue Sep 4 16:13:00 2018 +0200

    removed ungodly hack

commit 8529a0f3f6
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Tue Sep 4 14:57:19 2018 +0200

    reduced prints in pt2_stoch

commit 03b8f353bd
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Tue Sep 4 14:41:46 2018 +0200

    teeth building check for pt2_stoch

commit 0d91b9310a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Tue Sep 4 14:35:04 2018 +0200

    timestamp of first pull

commit 34d9fa0165
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Tue Sep 4 14:27:10 2018 +0200

    potential numerical precision bug

commit 9a0f900d8c
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Tue Sep 4 14:09:51 2018 +0200

    tests if teeth can be built

commit dda0dc34df
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Mon Sep 3 17:48:04 2018 +0200

    corrected pt2_find_sample

commit a521f0cb82
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Mon Sep 3 16:08:02 2018 +0200

    tasks get by batches of Nproc

commit 997a5a1265
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Mon Sep 3 14:18:04 2018 +0200

    buffered task_id send

commit 99ea7948e0
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Mon Sep 3 12:29:12 2018 +0200

    unbalanced fragmentation

commit abb3b7e08b
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Sun Sep 2 17:18:44 2018 +0200

    overflow of pt2_J

commit 8df49f394b
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Sun Sep 2 15:58:48 2018 +0200

    removed useless computation of intermediate checkpoints

commit 4ba5b79eb3
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Sun Sep 2 15:50:14 2018 +0200

    dressing only sent for chosen checkpoint

commit a4a6a69459
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Sat Sep 1 17:01:56 2018 +0200

    cumulative dot_F

commit 6a7f04cb79
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Sat Sep 1 16:58:07 2018 +0200

    simpler purge

commit 168ca2f2e2
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Fri Aug 31 21:07:01 2018 +0200

    task list optimized

commit de4a0d0caf
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Fri Aug 31 18:57:03 2018 +0200

    removed print

commit fee31d4e3e
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Fri Aug 31 18:56:23 2018 +0200

    dress fragmentation

commit 02893a419d
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Fri Aug 31 15:52:16 2018 +0200

    bug in blocked search - replaced with thesis version

commit bb6e073cf1
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Thu Aug 30 21:24:45 2018 +0200

    ungodly hack to prevent double providing

commit 0609e8c627
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Thu Aug 30 20:52:05 2018 +0200

    debugging

commit a254fdd7cf
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Thu Aug 30 15:24:07 2018 +0200

    parallel bug

commit 2a6c1941d4
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Thu Aug 30 11:43:11 2018 +0200

    corrected when relative_error=0d0

commit bac039bdf1
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Thu Aug 30 10:58:17 2018 +0200

    relative error 1d-5

commit aae9d203ec
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Thu Aug 30 10:07:02 2018 +0200

    potential fragmentation bug

commit ad69f39f99
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Wed Aug 29 20:54:58 2018 +0200

    dress_zmq re-implemented

commit d78f64732a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Wed Aug 29 11:30:19 2018 +0200

    pt2_stoch re-implemented

commit 4b9b54e19a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Tue Aug 28 10:24:38 2018 +0200

    removed test for phase_mask_bit

commit 3abccca5e3
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date:   Fri Aug 3 23:44:05 2018 +0200

    phasemask_bit
2018-09-04 17:31:45 +02:00

331 lines
11 KiB
Fortran
Raw Blame History

use bitmasks
subroutine run_dress_slave(thread,iproce,energy)
use f77_zmq
use omp_lib
implicit none
double precision, intent(in) :: energy(N_states_diag)
integer, intent(in) :: thread, iproce
integer :: rc, i, subset, i_generator
integer :: worker_id, ctask, ltask
character*(512) :: task(Nproc)
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
double precision,allocatable :: breve_delta_m(:,:,:)
integer :: i_state,m,l,t,p,sum_f
!integer, external :: omp_get_thread_num
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)
integer :: will_send, task_id, purge_task_id, ntask_buf
integer, allocatable :: task_buf(:)
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, getting_task
double precision :: fac
double precision :: ending(1)
integer, external :: zmq_get_dvector
! double precision, external :: omp_get_wtime
double precision :: time, time0
integer :: ntask_tbd, task_tbd(Nproc), i_gen_tbd(Nproc), subset_tbd(Nproc)
if(iproce /= 0) stop "RUN DRESS SLAVE is OMP"
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
delta_det = 0d0
task = CHAR(0)
call omp_init_lock(sending)
call omp_init_lock(getting_task)
do i=0,dress_N_cp+1
call omp_init_lock(lck_sto(i))
end do
do i=0,pt2_N_teeth+1
call omp_init_lock(lck_det(i))
end do
cp_done = 0
cp_sent = 0
will_send = 0
double precision :: hij, sij, tmp
purge_task_id = 0
provide psi_energy
ending(1) = dble(dress_N_cp+1)
ntask_tbd = 0
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(breve_delta_m, task_id) &
!$OMP PRIVATE(tmp,fac,m,l,t,sum_f,n_tasks) &
!$OMP PRIVATE(i,p,will_send, i_generator, subset, iproc) &
!$OMP PRIVATE(zmq_to_qp_run_socket, zmq_socket_push, worker_id) &
!$OMP PRIVATE(task_buf, ntask_buf,time, time0)
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
iproc = omp_get_thread_num()+1
allocate(breve_delta_m(N_states,N_det,2))
allocate(task_buf(pt2_n_tasks_max))
ntask_buf = 0
if(iproc==1) then
call push_dress_results(zmq_socket_push, 0, 0, edI_task, edI_index, breve_delta_m, task_buf, ntask_buf)
end if
do while(cp_done > cp_sent .or. m /= dress_N_cp+1)
call omp_set_lock(getting_task)
if(ntask_tbd == 0) then
ntask_tbd = size(task_tbd)
call get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_tbd, task, ntask_tbd)
!task = task//" 0"
end if
task_id = task_tbd(1)
if(task_id /= 0) then
read (task(1),*) subset, i_generator
do i=1,size(task_tbd)-1
task_tbd(i) = task_tbd(i+1)
task(i) = task(i+1)
end do
m = dress_P(i_generator)
ntask_tbd -= 1
else
m = dress_N_cp + 1
i= zmq_get_dvector(zmq_to_qp_run_socket, worker_id, "ending", ending, 1)
end if
call omp_unset_lock(getting_task)
will_send = 0
!$OMP CRITICAL
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
end if
if(purge_task_id == 0) then
purge_task_id = task_id
task_id = 0
else if(task_id /= 0) then
ntask_buf += 1
task_buf(ntask_buf) = task_id
end if
!$OMP END CRITICAL
if(will_send /= 0 .and. will_send <= int(ending(1))) then
call omp_set_lock(sending)
n_tasks = 0
sum_f = 0
do i=1,N_det_generators
if(dress_P(i) <= will_send) sum_f = sum_f + f(i)
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
end if
end do
call push_dress_results(zmq_socket_push, will_send, sum_f, edI_task, edI_index, breve_delta_m, 0, n_tasks)
call omp_unset_lock(sending)
end if
if(m /= dress_N_cp+1) then
!UPDATE i_generator
breve_delta_m(:,:,:) = 0d0
call generator_start(i_generator, iproc)
time0 = omp_get_wtime()
call alpha_callback(breve_delta_m, i_generator, subset, pt2_F(i_generator), iproc)
time = omp_get_wtime()
!print '(I0.11, I4, A12, F12.3)', i_generator, subset, "GREPMETIME", time-time0
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))
do p=1,dress_N_cp
if(dress_e(i_generator, p) /= 0d0) then
fac = dress_e(i_generator, p)
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
do i=N_det,1,-1
tmp += psi_coef(i, dress_stoch_istate)*breve_delta_m(dress_stoch_istate, i, 1)
end do
!$OMP ATOMIC
edI(i_generator) += tmp
!$OMP ATOMIC
f(i_generator) += 1
!push bidon
if(ntask_buf == size(task_buf)) then
call push_dress_results(zmq_socket_push, 0, 0, edI_task, edI_index, breve_delta_m, task_buf, ntask_buf)
ntask_buf = 0
end if
end if
end do
!$OMP BARRIER
if(ntask_buf /= 0) then
call push_dress_results(zmq_socket_push, 0, 0, edI_task, edI_index, breve_delta_m, task_buf, ntask_buf)
ntask_buf = 0
end if
!$OMP SINGLE
if(purge_task_id /= 0) then
do while(int(ending(1)) == dress_N_cp+1)
call sleep(1)
i= zmq_get_dvector(zmq_to_qp_run_socket, worker_id, "ending", ending, 1)
end do
will_send = int(ending(1))
breve_delta_m = 0d0
do l=will_send, 1,-1
breve_delta_m(:,:,1) += cp(:,:,l,1)
breve_delta_m(:,:,2) += cp(:,:,l,2)
end do
breve_delta_m(:,:,:) = breve_delta_m(:,:,:) / dress_M_m(will_send)
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
sum_f = 0
do i=1,N_det_generators
if(dress_P(i) <= will_send) sum_f = sum_f + f(i)
end do
call push_dress_results(zmq_socket_push, -will_send, sum_f, edI_task, edI_index, breve_delta_m, purge_task_id, 1)
end if
!$OMP END SINGLE
call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
!$OMP END PARALLEL
do i=0,dress_N_cp+1
call omp_destroy_lock(lck_sto(i))
end do
do i=0,pt2_N_teeth+1
call omp_destroy_lock(lck_det(i))
end do
end subroutine
subroutine push_dress_results(zmq_socket_push, m_task, f, edI_task, edI_index, breve_delta_m, task_id, n_tasks)
use f77_zmq
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
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(pt2_n_tasks_max), n_tasks
integer :: rc, i, j, k
rc = f77_zmq_send( zmq_socket_push, m_task, 4, ZMQ_SNDMORE)
if(rc /= 4) stop "push3"
if(m_task > 0) then
rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
if(rc /= 4) stop "push1"
rc = f77_zmq_send( zmq_socket_push, f, 4, ZMQ_SNDMORE)
if(rc /= 4) stop "push4"
rc = f77_zmq_send( zmq_socket_push, edI_task, 8*n_tasks, ZMQ_SNDMORE)
if(rc /= 8*n_tasks) stop "push5"
rc = f77_zmq_send( zmq_socket_push, edI_index, 4*n_tasks, 0)
if(rc /= 4*n_tasks) stop "push6"
else if(m_task == 0) then
rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
if(rc /= 4) stop "push1"
rc = f77_zmq_send( zmq_socket_push, task_id, 4*n_tasks, 0)
if(rc /= 4*n_tasks) stop "push2"
else
rc = f77_zmq_send( zmq_socket_push, f, 4, ZMQ_SNDMORE)
if(rc /= 4) stop "push4"
rc = f77_zmq_send( zmq_socket_push, breve_delta_m, 8*N_det*N_states*2, ZMQ_SNDMORE)
if(rc /= 8*N_det*N_states*2) stop "push6"
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
if(rc /= 4) stop "push6"
end if
! Activate is zmq_socket_pull is a REP
IRP_IF ZMQ_PUSH
IRP_ELSE
character*(2) :: ok
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
IRP_ENDIF
end subroutine
subroutine pull_dress_results(zmq_socket_pull, m_task, f, edI_task, edI_index, breve_delta_m, task_id, n_tasks)
use f77_zmq
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
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(pt2_n_tasks_max), n_tasks
integer :: rc, i, j, k
rc = f77_zmq_recv( zmq_socket_pull, m_task, 4, 0)
if(rc /= 4) stop "pullc"
if(m_task > 0) then
rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0)
if(rc /= 4) stop "pullc"
rc = f77_zmq_recv( zmq_socket_pull, f, 4, 0)
if(rc /= 4) stop "pullc"
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"
else if(m_task==0) then
rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0)
if(rc /= 4) stop "pullc"
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4*n_tasks, 0)
if(rc /= 4*n_tasks) stop "pull4"
else
rc = f77_zmq_recv( zmq_socket_pull, f, 4, 0)
if(rc /= 4) stop "pullc"
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"
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
if(rc /= 4) stop "pull4"
end if
! 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
Reference in New Issue View Git Blame Copy Permalink