LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-25 05:43:47 +01:00
Code Issues Releases Wiki Activity

size(kind=8)

Browse Source
This commit is contained in:
Anthony Scemama 2018-09-21 10:43:30 +02:00
parent b529bf4f96
commit 1139d31fbb
6 changed files with 277 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Bitmask/mpi.irp.f
View File

@ -21,7 +21,7 @@ END_PROVIDER
subroutine broadcast_chunks_bit_kind(A, LDA) subroutine broadcast_chunks_bit_kind(A, LDA)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: LDA integer*8, intent(in) :: LDA
integer(bit_kind), intent(inout) :: A(LDA) integer(bit_kind), intent(inout) :: A(LDA)
BEGIN_DOC BEGIN_DOC
! Broadcast with chunks of ~2GB ! Broadcast with chunks of ~2GB

50
src/Davidson/davidson_parallel.irp.f
View File

@ -13,6 +13,24 @@ end
subroutine davidson_slave_tcp(i) subroutine davidson_slave_tcp(i)
implicit none implicit none
integer, intent(in) :: i 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) call davidson_run_slave(0,i)
end 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) ! Get wave function (u_t)
! ----------------------- ! -----------------------
integer :: rc integer :: rc, ni, nj
integer*8 :: rc8 integer*8 :: rc8
integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_states_read, N_det_read, psi_det_size_read
integer :: N_det_selectors_read, N_det_generators_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(u_t(N_st,N_det))
allocate (energy(N_st)) allocate (energy(N_st))
! Warning : dimensions are permuted for performance considerations, It is OK ! Warning : dimensions are modified for efficiency, It is OK since we get the
! since we get the full matrix ! 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 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' print *, irp_here, ': Unable to get u_t'
deallocate(u_t,energy) deallocate(u_t,energy)
return return
@ -105,7 +130,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call broadcast_chunks_double(u_t,size(u_t)) call broadcast_chunks_double(u_t,size(u_t,kind=8))
IRP_ENDIF 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') call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'davidson')
character*(512) :: task character*(512) :: task
integer :: rc integer :: rc, ni, nj
integer*8 :: rc8 integer*8 :: rc8
double precision :: energy(N_st) 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 if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',energy,size(energy)) == -1) then
stop 'Unable to put energy on ZMQ server' stop 'Unable to put energy on ZMQ server'
endif endif
! Warning : dimensions are permuted for performance considerations, It is OK if (size(u_t) < 8388608) then
! since we get the full matrix ni = size(u_t)
if (zmq_put_dmatrix(zmq_to_qp_run_socket, 1, 'u_t', u_t, size(u_t,2),size(u_t,1) ) == -1) then 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' stop 'Unable to put u_t on ZMQ server'
endif endif

8
src/Determinants/determinants.irp.f
View File

@ -76,7 +76,7 @@ BEGIN_PROVIDER [integer, max_degree_exc]
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, psi_det_size ] BEGIN_PROVIDER [ integer*8, psi_det_size ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Size of the psi_det/psi_coef arrays ! Size of the psi_det/psi_coef arrays
@ -88,9 +88,9 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
if (exists) then if (exists) then
call ezfio_get_determinants_n_det(psi_det_size) call ezfio_get_determinants_n_det(psi_det_size)
else else
psi_det_size = 1 psi_det_size = 1_8
endif 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') call write_int(6,psi_det_size,'Dimension of the psi arrays')
endif endif
IRP_IF MPI_DEBUG IRP_IF MPI_DEBUG
@ -100,7 +100,7 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr 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 if (ierr /= MPI_SUCCESS) then
stop 'Unable to read psi_det_size with MPI' stop 'Unable to read psi_det_size with MPI'
endif endif

225
src/Determinants/zmq.irp.f
View File

@ -140,7 +140,7 @@ psi_det_size ;;
END_TEMPLATE 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 use f77_zmq
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -148,34 +148,24 @@ integer function zmq_put_psi_det(zmq_to_qp_run_socket,worker_id)
END_DOC END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id integer, intent(in) :: worker_id
integer :: rc
integer*8 :: rc8 integer*8 :: rc8
character*(256) :: msg 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' if (size(psi_det,kind=8) <= 8388608_8) then
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) ni = size(psi_det,kind=4)
if (rc /= len(trim(msg))) then nj = 1
zmq_put_psi_det = -1 else
return ni = 8388608_8
endif nj = int(size(psi_det,kind=8)/8388608_8,4) + 1
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
endif 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 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 use f77_zmq
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -183,32 +173,75 @@ integer function zmq_put_psi_coef(zmq_to_qp_run_socket,worker_id)
END_DOC END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id integer, intent(in) :: worker_id
integer :: rc
integer*8 :: rc8 integer*8 :: rc8
character*(256) :: msg character*(256) :: msg
zmq_put_psi_coef = 0 zmq_put_psi_coef = 0
write(msg,'(A,1X,I8,1X,A200)') 'put_data '//trim(zmq_state), worker_id, 'psi_coef' integer*8 :: zmq_put_dmatrix
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) integer :: ni, nj
if (rc /= len(trim(msg))) then
zmq_put_psi_coef = -1
return
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size,8)*int(N_states,8)*8_8,0) if (size(psi_coef,kind=8) <= 8388608_8) then
if (rc8 /= psi_det_size*N_states*8_8) then ni = size(psi_coef,kind=4)
print *, 'rc=', rc8 nj = 1
zmq_put_psi_coef = -1 else
return ni = 8388608
nj = int(size(psi_coef,kind=8)/8388608_8,4) + 1
endif 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) integer*8 function zmq_get_psi_det(zmq_to_qp_run_socket,worker_id)
if (msg(1:rc) /= 'put_data_reply ok') then use f77_zmq
zmq_put_psi_coef = -1 implicit none
return 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 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 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_states
integer, external :: zmq_get_N_det integer, external :: zmq_get_N_det
integer, external :: zmq_get_psi_det_size integer, external :: zmq_get_psi_det_size
integer, external :: zmq_get_psi_det integer*8, external :: zmq_get_psi_det
integer, external :: zmq_get_psi_coef integer*8, external :: zmq_get_psi_coef
zmq_get_psi = 0 zmq_get_psi = 0
@ -244,21 +277,21 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id)
return return
endif 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) deallocate(psi_det)
allocate(psi_det(N_int,2,psi_det_size)) allocate(psi_det(N_int,2,psi_det_size))
endif 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) deallocate(psi_coef)
allocate(psi_coef(psi_det_size,N_states)) allocate(psi_coef(psi_det_size,N_states))
endif 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 zmq_get_psi = -1
return return
endif 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 zmq_get_psi = -1
return return
endif endif
@ -267,109 +300,5 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id)
end 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

2
src/MPI/mpi.irp.f
View File

@ -65,7 +65,7 @@ BEGIN_TEMPLATE
subroutine broadcast_chunks_$double(A, LDA) subroutine broadcast_chunks_$double(A, LDA)
implicit none implicit none
integer, intent(in) :: LDA integer*8, intent(in) :: LDA
$type, intent(inout) :: A(LDA) $type, intent(inout) :: A(LDA)
BEGIN_DOC BEGIN_DOC
! Broadcast with chunks of ~2GB ! Broadcast with chunks of ~2GB

172
src/ZMQ/put_get.irp.f
View File

@ -93,7 +93,7 @@ integer function zmq_get_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_
stop -1 stop -1
endif endif
call MPI_BARRIER(MPI_COMM_WORLD,ierr) 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 IRP_ENDIF
end end
@ -192,7 +192,7 @@ integer function zmq_get_ivector(zmq_to_qp_run_socket, worker_id, name, x, size_
stop -1 stop -1
endif endif
call MPI_BARRIER(MPI_COMM_WORLD,ierr) 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 IRP_ENDIF
end end
@ -273,9 +273,9 @@ integer function zmq_get8_dvector(zmq_to_qp_run_socket, worker_id, name, x, size
go to 10 go to 10
endif 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 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 zmq_get8_dvector = -1
go to 10 go to 10
endif 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 use f77_zmq
implicit none implicit none
BEGIN_DOC 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 integer, intent(in) :: worker_id
character*(*) :: name character*(*) :: name
integer, intent(in) :: size_x1, size_x2 integer, intent(in) :: size_x1, size_x2
integer*8, intent(in) :: sze
double precision, intent(in) :: x(size_x1, size_x2) double precision, intent(in) :: x(size_x1, size_x2)
integer*8 :: rc integer*8 :: rc, ni
integer :: j integer :: j
character*(256) :: msg character*(256) :: msg
zmq_put_dmatrix = 0 zmq_put_dmatrix = 0
ni = size_x1
do j=1,size_x2 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 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) rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then 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 return
endif endif
rc = f77_zmq_send8(zmq_to_qp_run_socket,x(1,j),size_x1*8_8,0) rc = f77_zmq_send8(zmq_to_qp_run_socket,x(1,j),ni*8_8,0)
if (rc /= size_x1*8_8) then if (rc /= ni*8_8) then
print *, 'Failed in send ', rc, j print *, 'Failed in send ', rc, j
zmq_put_dmatrix = -1 zmq_put_dmatrix = -1
return return
@ -347,7 +352,7 @@ integer function zmq_put_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_
end 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 use f77_zmq
implicit none implicit none
BEGIN_DOC 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(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id integer, intent(in) :: worker_id
integer, intent(in) :: size_x1, size_x2 integer, intent(in) :: size_x1, size_x2
integer*8, intent(in) :: sze
character*(*), intent(in) :: name character*(*), intent(in) :: name
double precision, intent(out) :: x(size_x1,size_x2) double precision, intent(out) :: x(size_x1,size_x2)
integer*8 :: rc integer*8 :: rc, ni
integer :: j integer*8 :: j
character*(256) :: msg character*(256) :: msg
PROVIDE zmq_state 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 zmq_get_dmatrix = 0
if (mpi_master) then if (mpi_master) then
ni = size_x1
do j=1, size_x2 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 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) 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
@ -383,9 +393,9 @@ integer function zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_
go to 10 go to 10
endif endif
rc = f77_zmq_recv8(zmq_to_qp_run_socket,x(1,j),size_x1*8,0) rc = f77_zmq_recv8(zmq_to_qp_run_socket,x(1,j),ni*8_8,0)
if (rc /= size_x1*8) then if (rc /= ni*8_8) then
print *, irp_here, 'rc /= size_x1*8', rc, size_x1*8 print *, irp_here, 'rc /= size_x1*8', rc, ni*8_8
zmq_get_dmatrix = -1 zmq_get_dmatrix = -1
go to 10 go to 10
endif endif
@ -407,7 +417,7 @@ integer function zmq_get_dmatrix(zmq_to_qp_run_socket, worker_id, name, x, size_
stop -1 stop -1
endif endif
call MPI_BARRIER(MPI_COMM_WORLD,ierr) 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 IRP_ENDIF
end end
@ -437,8 +447,8 @@ integer function zmq_put8_ivector(zmq_to_qp_run_socket, worker_id, name, x, size
return return
endif endif
rc = f77_zmq_send8(zmq_to_qp_run_socket,x,size_x*4,0) rc = f77_zmq_send8(zmq_to_qp_run_socket,x,size_x*4_8,0)
if (rc /= size_x*4) then if (rc /= size_x*4_8) then
zmq_put8_ivector = -1 zmq_put8_ivector = -1
return return
endif endif
@ -478,13 +488,13 @@ integer function zmq_get8_ivector(zmq_to_qp_run_socket, worker_id, name, x, size
go to 10 go to 10
endif 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 if (msg(1:14) /= 'get_data_reply') then
zmq_get8_ivector = -1 zmq_get8_ivector = -1
go to 10 go to 10
endif 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 if (rc /= size_x*4) then
zmq_get8_ivector = -1 zmq_get8_ivector = -1
go to 10 go to 10
@ -591,3 +601,127 @@ integer function zmq_get_int(zmq_to_qp_run_socket, worker_id, name, x)
end 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