From 3aeff1b2b17413aa025a6b68ec1df10740df79d7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 27 Nov 2017 00:09:25 +0100 Subject: [PATCH] Fixed MPI parallelism --- plugins/Full_CI_ZMQ/pt2_slave.irp.f | 3 ++- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 3 ++- .../selection_davidson_slave.irp.f | 12 +++++++---- plugins/Full_CI_ZMQ/selection_slave.irp.f | 6 ++++-- plugins/Full_CI_ZMQ/zmq_selection.irp.f | 3 ++- plugins/Selectors_full/zmq.irp.f | 17 +++------------ src/Davidson/davidson_parallel.irp.f | 21 ++----------------- src/Determinants/H_apply_zmq.template.f | 3 ++- 8 files changed, 25 insertions(+), 43 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_slave.irp.f b/plugins/Full_CI_ZMQ/pt2_slave.irp.f index 0aacbce7..da9e201f 100644 --- a/plugins/Full_CI_ZMQ/pt2_slave.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_slave.irp.f @@ -47,7 +47,8 @@ subroutine run_wf ! --------- print *, 'PT2' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call zmq_get_psi(zmq_to_qp_run_socket,1) + call zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) 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 diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index b2a15249..6950129e 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -61,7 +61,8 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error) print *, '========== ================= ================= =================' call new_parallel_job(zmq_to_qp_run_socket,'pt2') - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call zmq_put_psi(zmq_to_qp_run_socket,1) + call zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) call create_selection_buffer(1, 1*2, b) Ncomb=size(comb) diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 6d84afab..17a54688 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -54,7 +54,8 @@ subroutine run_wf print *, 'Selection' if (mpi_master) then - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call zmq_get_psi(zmq_to_qp_run_socket,1) + call zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) endif call mpi_bcast_psi(energy,N_states) @@ -77,11 +78,13 @@ subroutine run_wf print *, 'Davidson' if (mpi_master) then - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call zmq_get_psi(zmq_to_qp_run_socket,1) + call zmq_get_N_states_diag(zmq_to_qp_run_socket,1) + call zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states_diag) endif double precision :: t0, t1 call wall_time(t0) - call mpi_bcast_psi(energy,N_states) + call mpi_bcast_psi(energy,N_states_diag) call wall_time(t1) call write_double(6,(t1-t0),'Broadcast time') @@ -104,7 +107,8 @@ subroutine run_wf print *, 'PT2' if (mpi_master) then - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call zmq_get_psi(zmq_to_qp_run_socket,1) + call zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) endif call mpi_bcast_psi(energy,N_states) diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index ebfcbaf2..a3277c22 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -51,7 +51,8 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call zmq_get_psi(zmq_to_qp_run_socket,1) + call zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -65,7 +66,8 @@ subroutine run_wf ! --- print *, 'PT2' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call zmq_get_psi(zmq_to_qp_run_socket,1) + call zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) logical :: lstop lstop = .False. diff --git a/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f index 1a029e5a..ee3c9c31 100644 --- a/plugins/Full_CI_ZMQ/zmq_selection.irp.f +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -24,7 +24,8 @@ subroutine ZMQ_selection(N_in, pt2) PROVIDE psi_bilinear_matrix_transp_order call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call zmq_put_psi(zmq_to_qp_run_socket,1) + call zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) call create_selection_buffer(N, N*2, b) endif diff --git a/plugins/Selectors_full/zmq.irp.f b/plugins/Selectors_full/zmq.irp.f index 6f19b7f4..eae7e7fd 100644 --- a/plugins/Selectors_full/zmq.irp.f +++ b/plugins/Selectors_full/zmq.irp.f @@ -1,4 +1,4 @@ -subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) +subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id) use f77_zmq implicit none BEGIN_DOC @@ -6,10 +6,6 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer, intent(in) :: worker_id - integer, intent(in) :: size_energy - double precision, intent(out) :: energy(size_energy) - integer :: rc - integer*8 :: rc8 character*(256) :: msg call zmq_put_N_states(zmq_to_qp_run_socket, worker_id) @@ -19,7 +15,6 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) call zmq_put_psi_coef(zmq_to_qp_run_socket, worker_id) call zmq_put_N_det_generators(zmq_to_qp_run_socket, worker_id) call zmq_put_N_det_selectors(zmq_to_qp_run_socket, worker_id) - call zmq_put_dvector(zmq_to_qp_run_socket, worker_id, 'energy', energy, size_energy) end @@ -208,7 +203,7 @@ end !--------------------------------------------------------------------------- -subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) +subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id) use f77_zmq implicit none BEGIN_DOC @@ -216,10 +211,6 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer, intent(in) :: worker_id - integer, intent(in) :: size_energy - double precision, intent(out) :: energy(size_energy) - integer :: rc - integer*8 :: rc8 character*(64) :: msg call zmq_get_N_states(zmq_to_qp_run_socket, worker_id) @@ -237,8 +228,6 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) call zmq_get_N_det_selectors(zmq_to_qp_run_socket, worker_id) TOUCH N_det_selectors - call zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'energy', energy, size_energy) - end @@ -271,7 +260,7 @@ subroutine zmq_get_psi_det(zmq_to_qp_run_socket, worker_id) rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,int(N_int*2_8*N_det*bit_kind,8),0) if (rc8 /= N_int*2_8*N_det*bit_kind) then - print *, irp_here, ': Error getting psi_det' + print *, irp_here, ': Error getting psi_det', rc8, N_int*2_8*N_det*bit_kind stop 'error' endif diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index a1c1a37e..29a04596 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -90,24 +90,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, integer :: ierr call broadcast_chunks_double(u_t,size(u_t)) - - call MPI_BCAST (N_st, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - print *, irp_here//': Unable to broadcast N_st' - stop -1 - endif - - if (.not.mpi_master) then - allocate (energy(N_st)) - endif - - call MPI_BCAST (energy, N_st, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - print *, irp_here//': Unable to broadcast energy' - stop -1 - endif - IRP_ENDIF ! Run tasks @@ -312,9 +295,9 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) energy = 0.d0 call zmq_put_N_states_diag(zmq_to_qp_run_socket, 1) - call zmq_put_psi_det(zmq_to_qp_run_socket, 1) + call zmq_put_psi(zmq_to_qp_run_socket,1) + call zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',energy,size(energy)) call zmq_put_dvector(zmq_to_qp_run_socket, 1, 'u_t', u_t, size(u_t)) - call zmq_put_dvector(zmq_to_qp_run_socket, 1, 'energy', energy, size(energy)) deallocate(u_t) diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index ddedc5a2..87347c75 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -33,7 +33,8 @@ subroutine $subroutine($params_main) call new_parallel_job(zmq_to_qp_run_socket,'$subroutine') zmq_socket_pair = new_zmq_pair_socket(.True.) - call zmq_put_psi(zmq_to_qp_run_socket,1,energy,size(energy)) + call zmq_put_psi(zmq_to_qp_run_socket,1) + call zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',energy,size(energy)) do i_generator=1,N_det_generators $skip