10
0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-24 13:23:41 +01:00

Fixed MPI

This commit is contained in:
Anthony Scemama 2018-09-09 12:20:33 +02:00
parent 4098b05202
commit f8bda54c75
16 changed files with 141 additions and 18 deletions

View File

@ -77,6 +77,7 @@ subroutine run_pt2_slave(thread,iproc,energy)
! Try to adjust n_tasks around 1 second per job ! Try to adjust n_tasks around 1 second per job
n_tasks = min(n_tasks,int( 1.d0*dble(n_tasks) / (time1 - time0 + 1.d-9)))+1 n_tasks = min(n_tasks,int( 1.d0*dble(n_tasks) / (time1 - time0 + 1.d-9)))+1
! n_tasks = n_tasks+1
end do end do
integer, external :: disconnect_from_taskserver integer, external :: disconnect_from_taskserver

View File

@ -13,9 +13,10 @@ program selection_slave
end end
subroutine provide_everything 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 n_states_diag 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 N_states_diag
PROVIDE pt2_e0_denominator mo_tot_num N_int ci_energy mpi_master zmq_state zmq_context PROVIDE pt2_e0_denominator mo_tot_num N_int ci_energy mpi_master zmq_state zmq_context
PROVIDE psi_det psi_coef PROVIDE psi_det psi_coef threshold_generators threshold_selectors state_average_weight
PROVIDE N_det_selectors pt2_stoch_istate N_det
end end
subroutine run_wf subroutine run_wf
@ -39,8 +40,6 @@ subroutine run_wf
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
call provide_everything
zmq_context = f77_zmq_ctx_new () zmq_context = f77_zmq_ctx_new ()
states(1) = 'selection' states(1) = 'selection'
states(2) = 'davidson' states(2) = 'davidson'
@ -49,6 +48,10 @@ subroutine run_wf
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
PROVIDE psi_det psi_coef threshold_generators threshold_selectors state_average_weight mpi_master
PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
PROVIDE N_det_generators N_states N_states_diag
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
do do
if (mpi_master) then if (mpi_master) then
@ -62,6 +65,10 @@ subroutine run_wf
print *, trim(zmq_state) print *, trim(zmq_state)
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
call MPI_BCAST (zmq_state, 128, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST (zmq_state, 128, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then

View File

@ -1,4 +1,4 @@
program fci_zmq program target_pt2_ratio
implicit none implicit none
integer :: i,j,k integer :: i,j,k
logical, external :: detEq logical, external :: detEq

View File

@ -1,4 +1,4 @@
program fci_zmq program target_pt2
implicit none implicit none
integer :: i,j,k integer :: i,j,k
logical, external :: detEq logical, external :: detEq

View File

@ -72,6 +72,10 @@ integer function zmq_get_$X(zmq_to_qp_run_socket, worker_id)
10 continue 10 continue
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr

View File

@ -32,6 +32,10 @@ BEGIN_PROVIDER [ %(type)s, %(name)s %(size)s ]
stop 1 stop 1
endif endif
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr

View File

@ -127,6 +127,10 @@ BEGIN_PROVIDER [ integer, N_generators_bitmask ]
ASSERT (N_generators_bitmask > 0) ASSERT (N_generators_bitmask > 0)
call write_int(6,N_generators_bitmask,'N_generators_bitmask') call write_int(6,N_generators_bitmask,'N_generators_bitmask')
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -170,6 +174,10 @@ BEGIN_PROVIDER [ integer, N_generators_bitmask_restart ]
ASSERT (N_generators_bitmask_restart > 0) ASSERT (N_generators_bitmask_restart > 0)
call write_int(6,N_generators_bitmask_restart,'N_generators_bitmask_restart') call write_int(6,N_generators_bitmask_restart,'N_generators_bitmask_restart')
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -244,6 +252,10 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_gen
enddo enddo
enddo enddo
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -313,6 +325,10 @@ if (mpi_master) then
enddo enddo
enddo enddo
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -354,6 +370,10 @@ BEGIN_PROVIDER [ integer, N_cas_bitmask ]
call write_int(6,N_cas_bitmask,'N_cas_bitmask') call write_int(6,N_cas_bitmask,'N_cas_bitmask')
endif endif
ASSERT (N_cas_bitmask > 0) ASSERT (N_cas_bitmask > 0)
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -407,6 +427,10 @@ BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ]
enddo enddo
write(*,*) 'Read CAS bitmask' write(*,*) 'Read CAS bitmask'
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr

View File

@ -26,6 +26,10 @@ subroutine broadcast_chunks_bit_kind(A, LDA)
BEGIN_DOC BEGIN_DOC
! Broadcast with chunks of ~2GB ! Broadcast with chunks of ~2GB
END_DOC END_DOC
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: i, sze, ierr integer :: i, sze, ierr

View File

@ -13,7 +13,6 @@ end
subroutine davidson_slave_tcp(i) subroutine davidson_slave_tcp(i)
implicit none implicit none
integer, intent(in) :: i integer, intent(in) :: i
call davidson_run_slave(0,i) call davidson_run_slave(0,i)
end end
@ -36,6 +35,10 @@ subroutine davidson_run_slave(thread,iproc)
integer, external :: connect_to_taskserver integer, external :: connect_to_taskserver
include 'mpif.h'
integer ierr
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then 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) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
endif endif
@ -86,11 +89,13 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
allocate (energy(N_st)) allocate (energy(N_st))
if (zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'u_t', u_t, size(u_t)) == -1) then if (zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'u_t', u_t, size(u_t)) == -1) then
print *, irp_here, ': Unable to get u_t'
deallocate(u_t,energy) deallocate(u_t,energy)
return return
endif endif
if (zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'energy', energy, size(energy)) == -1) then if (zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'energy', energy, size(energy)) == -1) then
print *, irp_here, ': Unable to get energy'
deallocate(u_t,energy) deallocate(u_t,energy)
return return
endif endif
@ -467,10 +472,13 @@ integer function zmq_get_N_states_diag(zmq_to_qp_run_socket, worker_id)
if (rc /= 4) go to 10 if (rc /= 4) go to 10
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST (zmq_get_N_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST (zmq_get_N_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
print *, irp_here//': Unable to broadcast N_states' print *, irp_here//': Unable to broadcast N_states'
@ -484,6 +492,7 @@ integer function zmq_get_N_states_diag(zmq_to_qp_run_socket, worker_id)
endif endif
endif endif
IRP_ENDIF IRP_ENDIF
TOUCH N_states_diag
return return

View File

@ -17,6 +17,10 @@ BEGIN_PROVIDER [ integer, n_states_diag ]
endif endif
n_states_diag = max(N_states, N_states_diag) n_states_diag = max(N_states, N_states_diag)
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr

View File

@ -45,6 +45,10 @@ BEGIN_PROVIDER [ integer, N_det ]
endif endif
call write_int(6,N_det,'Number of determinants') call write_int(6,N_det,'Number of determinants')
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -89,6 +93,10 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
psi_det_size = max(psi_det_size,100000) psi_det_size = max(psi_det_size,100000)
call write_int(6,psi_det_size,'Dimension of the psi arrays') call write_int(6,psi_det_size,'Dimension of the psi arrays')
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -154,6 +162,10 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ]
enddo enddo
endif endif
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -212,6 +224,10 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ]
endif endif
endif endif
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr

View File

@ -112,6 +112,10 @@ integer function zmq_get_$X(zmq_to_qp_run_socket, worker_id)
endif endif
10 continue 10 continue
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -297,6 +301,10 @@ integer function zmq_get_psi_det(zmq_to_qp_run_socket, worker_id)
endif endif
10 continue 10 continue
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -346,6 +354,10 @@ integer function zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id)
10 continue 10 continue
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr

View File

@ -9,6 +9,10 @@ BEGIN_PROVIDER [ integer, mo_tot_num ]
if (mpi_master) then if (mpi_master) then
call ezfio_has_mo_basis_mo_tot_num(has) call ezfio_has_mo_basis_mo_tot_num(has)
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -71,6 +75,10 @@ BEGIN_PROVIDER [ double precision, mo_coef, (ao_num,mo_tot_num) ]
! Coefs ! Coefs
call ezfio_has_mo_basis_mo_coef(exists) call ezfio_has_mo_basis_mo_coef(exists)
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -136,6 +144,10 @@ BEGIN_PROVIDER [ character*(64), mo_label ]
endif endif
write(*,*) '* mo_label ', trim(mo_label) write(*,*) '* mo_label ', trim(mo_label)
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -198,6 +210,10 @@ BEGIN_PROVIDER [ double precision, mo_occ, (mo_tot_num) ]
endif endif
write(*,*) 'Read mo_occ' write(*,*) 'Read mo_occ'
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr

View File

@ -70,6 +70,10 @@ subroutine broadcast_chunks_$double(A, LDA)
BEGIN_DOC BEGIN_DOC
! Broadcast with chunks of ~2GB ! Broadcast with chunks of ~2GB
END_DOC END_DOC
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: i, sze, ierr integer :: i, sze, ierr
@ -80,6 +84,7 @@ subroutine broadcast_chunks_$double(A, LDA)
print *, irp_here//': Unable to broadcast chunks $double ', i print *, irp_here//': Unable to broadcast chunks $double ', i
stop -1 stop -1
endif endif
call MPI_BARRIER(MPI_COMM_WORLD,ierr)
enddo enddo
IRP_ENDIF IRP_ENDIF
end end

View File

@ -54,6 +54,10 @@ BEGIN_PROVIDER [ double precision, nucl_coord, (nucl_num,3) ]
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -159,6 +163,10 @@ BEGIN_PROVIDER [ double precision, nuclear_repulsion ]
endif endif
print*, 'Read nuclear_repulsion' print*, 'Read nuclear_repulsion'
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
@ -228,6 +236,10 @@ END_PROVIDER
close(10) close(10)
endif endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr

View File

@ -60,17 +60,20 @@ integer function zmq_get_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then if (rc /= len(trim(msg))) then
zmq_get_dvector = -1 zmq_get_dvector = -1
print *, irp_here, 'rc /= len(trim(msg))', rc, len(trim(msg))
go to 10 go to 10
endif endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:14) /= 'get_data_reply') then if (msg(1:14) /= 'get_data_reply') then
print *, irp_here, 'msg(1:14) /= get_data_reply', msg(1:14)
zmq_get_dvector = -1 zmq_get_dvector = -1
go to 10 go to 10
endif endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,x,size_x*8,0) rc = f77_zmq_recv(zmq_to_qp_run_socket,x,size_x*8,0)
if (rc /= size_x*8) then if (rc /= size_x*8) then
print *, irp_here, 'rc /= size_x*8', rc, size_x*8
zmq_get_dvector = -1 zmq_get_dvector = -1
go to 10 go to 10
endif endif
@ -78,6 +81,10 @@ integer function zmq_get_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_
10 continue 10 continue
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
integer :: ierr integer :: ierr
include 'mpif.h' include 'mpif.h'
@ -86,11 +93,8 @@ 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_BARRIER(MPI_COMM_WORLD,ierr)
if (ierr /= MPI_SUCCESS) then call broadcast_chunks_double(x, size_x)
print *, irp_here//': Unable to broadcast dvector'
stop -1
endif
IRP_ENDIF IRP_ENDIF
end end
@ -177,6 +181,10 @@ integer function zmq_get_ivector(zmq_to_qp_run_socket, worker_id, name, x, size_
10 continue 10 continue
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI IRP_IF MPI
integer :: ierr integer :: ierr
include 'mpif.h' include 'mpif.h'
@ -185,11 +193,8 @@ integer function zmq_get_ivector(zmq_to_qp_run_socket, worker_id, name, x, size_
print *, irp_here//': Unable to broadcast zmq_get_ivector' print *, irp_here//': Unable to broadcast zmq_get_ivector'
stop -1 stop -1
endif endif
call MPI_BCAST (x, size_x, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BARRIER(MPI_COMM_WORLD,ierr)
if (ierr /= MPI_SUCCESS) then call broadcast_chunks_integer(x, size_x)
print *, irp_here//': Unable to broadcast ivector'
stop -1
endif
IRP_ENDIF IRP_ENDIF
end end