diff --git a/src/Bitmask/mpi.irp.f b/src/Bitmask/mpi.irp.f index 11d6777a..be10f07a 100644 --- a/src/Bitmask/mpi.irp.f +++ b/src/Bitmask/mpi.irp.f @@ -21,7 +21,7 @@ END_PROVIDER subroutine broadcast_chunks_bit_kind(A, LDA) use bitmasks implicit none - integer, intent(in) :: LDA + integer*8, intent(in) :: LDA integer(bit_kind), intent(inout) :: A(LDA) BEGIN_DOC ! Broadcast with chunks of ~2GB diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 59393ce4..5aa7a84a 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -13,6 +13,24 @@ end subroutine davidson_slave_tcp(i) implicit none integer, intent(in) :: i + integer :: nproc_target + double precision :: r1 + if (qp_max_mem > 0) then + nproc_target = nproc + r1 = 8.d0*(3.d0*dble(N_det*N_states_diag) & + + nproc_target*(4.d0*N_det_alpha_unique+2.d0*N_states_diag*N_det))/(1024.d0**3) + do while (r1 > qp_max_mem) + nproc_target = nproc_target - 1 + r1 = 8.d0*(3.d0*dble(N_det*N_states_diag) & + + nproc_target*(4.d0*N_det_alpha_unique+2.d0*N_states_diag*N_det))/(1024.d0**3) + if (nproc_target == 0) then + nproc_target = 1 + exit + endif + enddo + call omp_set_num_threads(nproc_target) + call write_int(6,nproc_target,'Number of threads for diagonalization') + endif call davidson_run_slave(0,i) end @@ -75,7 +93,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, ! Get wave function (u_t) ! ----------------------- - integer :: rc + integer :: rc, ni, nj integer*8 :: rc8 integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read @@ -87,9 +105,16 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, allocate(u_t(N_st,N_det)) allocate (energy(N_st)) - ! Warning : dimensions are permuted for performance considerations, It is OK - ! since we get the full matrix - if (zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, 'u_t', u_t, size(u_t,2), size(u_t,1) ) == -1) then + ! Warning : dimensions are modified for efficiency, It is OK since we get the + ! full matrix + if (size(u_t,kind=8) < 8388608_8) then + ni = size(u_t) + nj = 1 + else + ni = 8388608 + nj = size(u_t,kind=8)/8388608_8 + 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 @@ -105,7 +130,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, include 'mpif.h' integer :: ierr - call broadcast_chunks_double(u_t,size(u_t)) + call broadcast_chunks_double(u_t,size(u_t,kind=8)) IRP_ENDIF @@ -311,7 +336,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'davidson') character*(512) :: task - integer :: rc + integer :: rc, ni, nj integer*8 :: rc8 double precision :: energy(N_st) @@ -329,9 +354,16 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) 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 - ! Warning : dimensions are permuted for performance considerations, It is OK - ! since we get the full matrix - if (zmq_put_dmatrix(zmq_to_qp_run_socket, 1, 'u_t', u_t, size(u_t,2),size(u_t,1) ) == -1) then + if (size(u_t) < 8388608) then + ni = size(u_t) + nj = 1 + else + ni = 8388608 + nj = size(u_t)/8388608 + 1 + endif + ! Warning : dimensions are modified for efficiency, It is OK since we get the + ! full matrix + if (zmq_put_dmatrix(zmq_to_qp_run_socket, 1, 'u_t', u_t, ni, nj, size(u_t,kind=8)) == -1) then stop 'Unable to put u_t on ZMQ server' endif diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 1e58e262..e7ade63b 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -76,7 +76,7 @@ BEGIN_PROVIDER [integer, max_degree_exc] enddo END_PROVIDER -BEGIN_PROVIDER [ integer, psi_det_size ] +BEGIN_PROVIDER [ integer*8, psi_det_size ] implicit none BEGIN_DOC ! Size of the psi_det/psi_coef arrays @@ -88,9 +88,9 @@ BEGIN_PROVIDER [ integer, psi_det_size ] if (exists) then call ezfio_get_determinants_n_det(psi_det_size) else - psi_det_size = 1 + psi_det_size = 1_8 endif - psi_det_size = max(psi_det_size,100000) + psi_det_size = max(psi_det_size,100000_8) call write_int(6,psi_det_size,'Dimension of the psi arrays') endif IRP_IF MPI_DEBUG @@ -100,7 +100,7 @@ BEGIN_PROVIDER [ integer, psi_det_size ] IRP_IF MPI include 'mpif.h' integer :: ierr - call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST( psi_det_size, 1, MPI_INTEGER8, 0, MPI_COMM_WORLD, ierr) if (ierr /= MPI_SUCCESS) then stop 'Unable to read psi_det_size with MPI' endif diff --git a/src/Determinants/zmq.irp.f b/src/Determinants/zmq.irp.f index 5751f5a2..0686be59 100644 --- a/src/Determinants/zmq.irp.f +++ b/src/Determinants/zmq.irp.f @@ -140,7 +140,7 @@ psi_det_size ;; END_TEMPLATE -integer function zmq_put_psi_det(zmq_to_qp_run_socket,worker_id) +integer*8 function zmq_put_psi_det(zmq_to_qp_run_socket,worker_id) use f77_zmq implicit none BEGIN_DOC @@ -148,34 +148,24 @@ integer function zmq_put_psi_det(zmq_to_qp_run_socket,worker_id) END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer, intent(in) :: worker_id - integer :: rc integer*8 :: rc8 character*(256) :: msg - zmq_put_psi_det = 0 + integer*8 :: zmq_put_i8matrix + integer :: ni, nj - write(msg,'(A,1X,I8,1X,A200)') 'put_data '//trim(zmq_state), worker_id, 'psi_det' - rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) - if (rc /= len(trim(msg))) then - zmq_put_psi_det = -1 - return - endif - - rc8 = f77_zmq_send8(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 *, 'rc=', rc8 - zmq_put_psi_det = -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 - zmq_put_psi_det = -1 - return + if (size(psi_det,kind=8) <= 8388608_8) then + ni = size(psi_det,kind=4) + nj = 1 + else + ni = 8388608_8 + nj = int(size(psi_det,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 end -integer function zmq_put_psi_coef(zmq_to_qp_run_socket,worker_id) +integer*8 function zmq_put_psi_coef(zmq_to_qp_run_socket,worker_id) use f77_zmq implicit none BEGIN_DOC @@ -183,32 +173,75 @@ integer function zmq_put_psi_coef(zmq_to_qp_run_socket,worker_id) END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer, intent(in) :: worker_id - integer :: rc integer*8 :: rc8 character*(256) :: msg zmq_put_psi_coef = 0 - write(msg,'(A,1X,I8,1X,A200)') 'put_data '//trim(zmq_state), worker_id, 'psi_coef' - rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) - if (rc /= len(trim(msg))) then - zmq_put_psi_coef = -1 - return - endif + integer*8 :: zmq_put_dmatrix + integer :: ni, nj - rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size,8)*int(N_states,8)*8_8,0) - if (rc8 /= psi_det_size*N_states*8_8) then - print *, 'rc=', rc8 - zmq_put_psi_coef = -1 - return + 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 - rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) - if (msg(1:rc) /= 'put_data_reply ok') then - zmq_put_psi_coef = -1 - return +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 + 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_i8matrix + integer :: ni, nj + + if (size(psi_det,kind=8) <= 8388608_8) then + ni = size(psi_det,kind=4) + nj = 1 + else + ni = 8388608 + nj = int(size(psi_det,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 +end +integer*8 function zmq_get_psi_coef(zmq_to_qp_run_socket,worker_id) + use f77_zmq + implicit none + BEGIN_DOC +! get 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_get_psi_coef = 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) + nj = 1 + else + ni = 8388608 + nj = int(size(psi_coef,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 end !--------------------------------------------------------------------------- @@ -226,8 +259,8 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id) integer, external :: zmq_get_N_states integer, external :: zmq_get_N_det integer, external :: zmq_get_psi_det_size - integer, external :: zmq_get_psi_det - integer, external :: zmq_get_psi_coef + integer*8, external :: zmq_get_psi_det + integer*8, external :: zmq_get_psi_coef zmq_get_psi = 0 @@ -244,21 +277,21 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id) return endif - if (size(psi_det) /= N_int*2_8*psi_det_size*bit_kind) then + 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) /= psi_det_size*N_states) then + 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) then + 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) then + if (zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id) == -1_8) then zmq_get_psi = -1 return endif @@ -267,109 +300,5 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id) end -integer function zmq_get_psi_det(zmq_to_qp_run_socket, worker_id) - use f77_zmq - implicit none - BEGIN_DOC -! Get psi_det from the qp_run scheduler - END_DOC - integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer, intent(in) :: worker_id - integer :: rc - integer*8 :: rc8 - character*(256) :: msg - - PROVIDE zmq_state - zmq_get_psi_det = 0 - if (mpi_master) then - write(msg,'(A,1X,I8,1X,A200)') 'get_data '//trim(zmq_state), worker_id, 'psi_det' - rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) - if (rc /= len(trim(msg))) then - zmq_get_psi_det = -1 - 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 - zmq_get_psi_det = -1 - go to 10 - endif - - 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 - zmq_get_psi_det = -1 - go to 10 - endif - endif - - 10 continue - IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST (zmq_get_psi_det, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to broadcast zmq_get_psi_det' - endif - call broadcast_chunks_bit_kind(psi_det,size(psi_det)) - IRP_ENDIF - -end - -integer function zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id) - use f77_zmq - implicit none - BEGIN_DOC -! Get psi_coef from the qp_run scheduler - END_DOC - integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer, intent(in) :: worker_id - integer :: rc - integer*8 :: rc8 - character*(256) :: msg - - PROVIDE zmq_state psi_det_size - zmq_get_psi_coef = 0 - if (mpi_master) then - write(msg,'(A,1X,I8,1X,A200)') 'get_data '//trim(zmq_state), worker_id, 'psi_coef' - rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) - if (rc /= len(trim(msg))) then - zmq_get_psi_coef = -1 - 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 - zmq_get_psi_coef = -1 - go to 10 - endif - - rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size*N_states*8_8,8),0) - if (rc8 /= psi_det_size*N_states*8_8) then - zmq_get_psi_coef = -1 - go to 10 - endif - endif - - 10 continue - - IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST (zmq_get_psi_coef, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to broadcast zmq_get_psi_coef' - endif - call broadcast_chunks_double(psi_coef,size(psi_coef)) - IRP_ENDIF - -end diff --git a/src/MPI/mpi.irp.f b/src/MPI/mpi.irp.f index 41694c8f..3517754a 100644 --- a/src/MPI/mpi.irp.f +++ b/src/MPI/mpi.irp.f @@ -65,7 +65,7 @@ BEGIN_TEMPLATE subroutine broadcast_chunks_$double(A, LDA) implicit none - integer, intent(in) :: LDA + integer*8, intent(in) :: LDA $type, intent(inout) :: A(LDA) BEGIN_DOC ! Broadcast with chunks of ~2GB diff --git a/src/ZMQ/put_get.irp.f b/src/ZMQ/put_get.irp.f index ed81efd9..70969f52 100644 --- a/src/ZMQ/put_get.irp.f +++ b/src/ZMQ/put_get.irp.f @@ -93,7 +93,7 @@ integer function zmq_get_dvector(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, size_x) + call broadcast_chunks_double(x, int(size_x,8)) IRP_ENDIF end @@ -192,7 +192,7 @@ integer function zmq_get_ivector(zmq_to_qp_run_socket, worker_id, name, x, size_ stop -1 endif call MPI_BARRIER(MPI_COMM_WORLD,ierr) - call broadcast_chunks_integer(x, size_x) + call broadcast_chunks_integer(x, int(size_x,8)) IRP_ENDIF end @@ -273,9 +273,9 @@ integer function zmq_get8_dvector(zmq_to_qp_run_socket, worker_id, name, x, size go to 10 endif - rc = f77_zmq_recv8(zmq_to_qp_run_socket,x,size_x*8,0) + rc = f77_zmq_recv8(zmq_to_qp_run_socket,x,size_x*8_8,0) if (rc /= size_x*8) then - print *, irp_here, 'rc /= size_x*8', rc, size_x*8 + print *, irp_here, 'rc /= size_x*8', rc, size_x*8_8 zmq_get8_dvector = -1 go to 10 endif @@ -303,7 +303,7 @@ end -integer function zmq_put_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_x1, size_x2) +integer function zmq_put_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_x1, size_x2, sze) use f77_zmq implicit none BEGIN_DOC @@ -313,14 +313,19 @@ integer function zmq_put_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_ integer, intent(in) :: worker_id character*(*) :: name integer, intent(in) :: size_x1, size_x2 + integer*8, intent(in) :: sze double precision, intent(in) :: x(size_x1, size_x2) - integer*8 :: rc + integer*8 :: rc, ni integer :: j character*(256) :: msg zmq_put_dmatrix = 0 + ni = size_x1 do j=1,size_x2 + if (j == size_x2) then + ni = int(sze - int(j-1,8)*int(size_x1,8),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 @@ -329,8 +334,8 @@ integer function zmq_put_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_ return endif - rc = f77_zmq_send8(zmq_to_qp_run_socket,x(1,j),size_x1*8_8,0) - if (rc /= size_x1*8_8) then + rc = f77_zmq_send8(zmq_to_qp_run_socket,x(1,j),ni*8_8,0) + if (rc /= ni*8_8) then print *, 'Failed in send ', rc, j zmq_put_dmatrix = -1 return @@ -347,7 +352,7 @@ integer function zmq_put_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_ end -integer function zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_x1, size_x2) +integer function zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_x1, size_x2, sze) use f77_zmq implicit none BEGIN_DOC @@ -356,10 +361,11 @@ integer function zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_ 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 double precision, intent(out) :: x(size_x1,size_x2) - integer*8 :: rc - integer :: j + integer*8 :: rc, ni + integer*8 :: j character*(256) :: msg PROVIDE zmq_state @@ -367,7 +373,11 @@ integer function zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_ zmq_get_dmatrix = 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 @@ -383,9 +393,9 @@ integer function zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_ go to 10 endif - rc = f77_zmq_recv8(zmq_to_qp_run_socket,x(1,j),size_x1*8,0) - if (rc /= size_x1*8) then - print *, irp_here, 'rc /= size_x1*8', rc, size_x1*8 + rc = f77_zmq_recv8(zmq_to_qp_run_socket,x(1,j),ni*8_8,0) + if (rc /= ni*8_8) then + print *, irp_here, 'rc /= size_x1*8', rc, ni*8_8 zmq_get_dmatrix = -1 go to 10 endif @@ -407,7 +417,7 @@ integer function zmq_get_dmatrix(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, int(size_x1,8)*int(size_x2,8)) + call broadcast_chunks_double(x, sze) IRP_ENDIF end @@ -437,8 +447,8 @@ integer function zmq_put8_ivector(zmq_to_qp_run_socket, worker_id, name, x, size return endif - rc = f77_zmq_send8(zmq_to_qp_run_socket,x,size_x*4,0) - if (rc /= size_x*4) then + rc = f77_zmq_send8(zmq_to_qp_run_socket,x,size_x*4_8,0) + if (rc /= size_x*4_8) then zmq_put8_ivector = -1 return endif @@ -478,13 +488,13 @@ integer function zmq_get8_ivector(zmq_to_qp_run_socket, worker_id, name, x, size go to 10 endif - rc = f77_zmq_recv8(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 zmq_get8_ivector = -1 go to 10 endif - rc = f77_zmq_recv(zmq_to_qp_run_socket,x,size_x*4,0) + rc = f77_zmq_recv8(zmq_to_qp_run_socket,x,size_x*4_8,0) if (rc /= size_x*4) then zmq_get8_ivector = -1 go to 10 @@ -591,3 +601,127 @@ integer function zmq_get_int(zmq_to_qp_run_socket, worker_id, name, x) end + +integer function zmq_put_i8matrix(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*8, intent(in) :: x(size_x1, size_x2) + integer*8 :: rc, ni + integer*8 :: j + character*(256) :: msg + + zmq_put_i8matrix = 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_i8matrix = -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*8_8,0) + if (rc /= ni*8_8) then + print *, irp_here, 'Failed in send ', rc, j + zmq_put_i8matrix = -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_i8matrix = -1 + return + endif + enddo + +end + + +integer function zmq_get_i8matrix(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 + double precision, intent(out) :: x(size_x1,size_x2) + integer*8 :: rc, ni + integer*8 :: j + character*(256) :: msg + + PROVIDE zmq_state + ! Success + zmq_get_i8matrix = 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_i8matrix = -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_i8matrix = -1 + go to 10 + endif + + rc = f77_zmq_recv8(zmq_to_qp_run_socket,x(1,j),ni*8_8,0) + if (rc /= ni*8_8) then + print *, irp_here, 'rc /= ni*8', rc, ni*8_8 + zmq_get_i8matrix = -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_i8matrix, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here//': Unable to broadcast zmq_get_i8matrix' + stop -1 + endif + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + call broadcast_chunks_double(x, sze) + IRP_ENDIF + +end + + + + +