subroutine init_comm_fix_conserve(idimmin,idimmax,nwfluxin)
use mod_global_parameters
use mod_comm_lib, only: mpistop
integer, intent(in) :: idimmin,idimmax,nwfluxin
integer :: iigrid, igrid, idims, iside, i1,i2,i3, nxCo1,nxCo2,nxCo3
integer :: ic1,ic2,ic3, inc1,inc2,inc3, ipe_neighbor
integer :: recvsize, sendsize
integer :: recvsize_cc, sendsize_cc
! MPI tag out of bounds safeguard
! JESSENEW
nwflux_fc = nwfluxin
if (.not.allocated(pflux(1,1)%flux)) call mpistop(&
"init_comm_fix_conserve: pflux%flux is not allocated yet")
nxCo_fc(1,1)=1
nxCo_fc(2,1)=size(pflux(1,1)%flux,2)/2
nxCo_fc(3,1)=size(pflux(1,1)%flux,3)/2
nxCo_fc(1,2)=size(pflux(1,2)%flux,1)/2
nxCo_fc(2,2)=1
nxCo_fc(3,2)=size(pflux(1,2)%flux,3)/2
nxCo_fc(1,3)=size(pflux(1,3)%flux,1)/2
nxCo_fc(2,3)=size(pflux(1,3)%flux,2)/2
nxCo_fc(3,3)=1
if (nxCo_fc(2,1)/=(ixMhi2-ixMlo2+1)/2 .or. nxCo_fc(3,1)/=(ixMhi3-ixMlo3+&
1)/2 .or. nxCo_fc(1,2)/=(ixMhi1-ixMlo1+1)/2 .or. nxCo_fc(3,&
2)/=(ixMhi3-ixMlo3+1)/2 .or. nxCo_fc(1,3)/=(ixMhi1-ixMlo1+1)/2 .or. &
nxCo_fc(2,3)/=(ixMhi2-ixMlo2+1)/2) call mpistop(&
"init_comm_fix_conserve: pflux%flux shape disagrees with the mesh")
if (nwfluxin > size(pflux(1,1)%flux,4)) call mpistop(&
"init_comm_fix_conserve: nwfluxin exceeds the pflux%flux w extent")
nsend = 0
nrecv = 0
recvsize = 0
sendsize = 0
if(stagger_grid) then
! Special communication for diagonal 'coarse corners'
nsend_ct=0
nrecv_ct=0
recvsize_cc=0
sendsize_cc=0
end if
do idims= idimmin,idimmax
select case (idims)
case (1)
nrecv=nrecv+nrecv_fc(1)
nsend=nsend+nsend_fc(1)
isize(1)=nxCo_fc(1,1)*nxCo_fc(2,1)*nxCo_fc(3,1)*(nwfluxin)
recvsize=recvsize+nrecv_fc(1)*isize(1)
sendsize=sendsize+nsend_fc(1)*isize(1)
if(stagger_grid) then
! This does not consider the 'coarse corner' case
nxCo1=1;nxCo2=ixGhi2/2-nghostcells+1;nxCo3=ixGhi3/2-nghostcells+1;
isize_stg(1)=nxCo1*nxCo2*nxCo3*(3-1)
! the whole size is used (cell centered and staggered)
isize(1)=isize(1)+isize_stg(1)
recvsize=recvsize+nrecv_fc(1)*isize_stg(1)
sendsize=sendsize+nsend_fc(1)*isize_stg(1)
! Coarse corner case
nrecv_ct=nrecv_ct+nrecv_cc(1)
nsend_ct=nsend_ct+nsend_cc(1)
recvsize_cc=recvsize_cc+nrecv_cc(1)*isize_stg(1)
sendsize_cc=sendsize_cc+nsend_cc(1)*isize_stg(1)
end if
case (2)
nrecv=nrecv+nrecv_fc(2)
nsend=nsend+nsend_fc(2)
isize(2)=nxCo_fc(1,2)*nxCo_fc(2,2)*nxCo_fc(3,2)*(nwfluxin)
recvsize=recvsize+nrecv_fc(2)*isize(2)
sendsize=sendsize+nsend_fc(2)*isize(2)
if(stagger_grid) then
! This does not consider the 'coarse corner' case
nxCo1=ixGhi1/2-nghostcells+1;nxCo2=1;nxCo3=ixGhi3/2-nghostcells+1;
isize_stg(2)=nxCo1*nxCo2*nxCo3*(3-1)
! the whole size is used (cell centered and staggered)
isize(2)=isize(2)+isize_stg(2)
recvsize=recvsize+nrecv_fc(2)*isize_stg(2)
sendsize=sendsize+nsend_fc(2)*isize_stg(2)
! Coarse corner case
nrecv_ct=nrecv_ct+nrecv_cc(2)
nsend_ct=nsend_ct+nsend_cc(2)
recvsize_cc=recvsize_cc+nrecv_cc(2)*isize_stg(2)
sendsize_cc=sendsize_cc+nsend_cc(2)*isize_stg(2)
end if
case (3)
nrecv=nrecv+nrecv_fc(3)
nsend=nsend+nsend_fc(3)
isize(3)=nxCo_fc(1,3)*nxCo_fc(2,3)*nxCo_fc(3,3)*(nwfluxin)
recvsize=recvsize+nrecv_fc(3)*isize(3)
sendsize=sendsize+nsend_fc(3)*isize(3)
if(stagger_grid) then
! This does not consider the 'coarse corner' case
nxCo1=ixGhi1/2-nghostcells+1;nxCo2=ixGhi2/2-nghostcells+1;nxCo3=1;
isize_stg(3)=nxCo1*nxCo2*nxCo3*(3-1)
! the whole size is used (cell centered and staggered)
isize(3)=isize(3)+isize_stg(3)
recvsize=recvsize+nrecv_fc(3)*isize_stg(3)
sendsize=sendsize+nsend_fc(3)*isize_stg(3)
! Coarse corner case
nrecv_ct=nrecv_ct+nrecv_cc(3)
nsend_ct=nsend_ct+nsend_cc(3)
recvsize_cc=recvsize_cc+nrecv_cc(3)*isize_stg(3)
sendsize_cc=sendsize_cc+nsend_cc(3)*isize_stg(3)
end if
end select
end do
fc_recvsize = recvsize
fc_sendsize = sendsize
! Grow the buffers to fit, never shrink. init_comm_fix_conserve runs
! every timestep and the number of coarse-fine interfaces oscillates as
! the mesh moves, so reallocating whenever the size merely *differs* meant
! a device free and malloc on most steps: measured on four ranks in
! tests/hd/spherical/blast_amr.par, 164 of 216 calls on the busiest rank.
! Those are synchronising on CUDA. Holding the high-water mark costs
! almost nothing here - it was 4640 doubles, 37 kB, in that same run.
!
! Everything downstream is sized by recvsize / sendsize rather than by
! size(buffer), so a buffer larger than the exchange is harmless; the two
! host/device transfers are sliced for exactly this reason.
if (allocated(recvbuffer)) then
if (recvsize > size(recvbuffer)) then
deallocate(recvbuffer)
allocate(recvbuffer(recvsize))
end if
else
allocate(recvbuffer(max(recvsize,1)))
end if
! Key -> offset table for the incoming chunks, read by fix_conserve.
! Allocated once: max_blocks is fixed, and so therefore is the key range.
if (.not.allocated(ibuf_offset)) then
allocate(ibuf_offset(4**3*max_blocks))
ibuf_offset = -1
end if
if (allocated(sendbuffer)) then
if (sendsize > size(sendbuffer)) then
deallocate(sendbuffer)
allocate(sendbuffer(sendsize))
end if
else
allocate(sendbuffer(max(sendsize,1)))
end if
! Per-chunk working set, sized by nsend / nrecv, and grown on the same
! never-shrink rule as the buffers above - it churned in lockstep with
! them, and three of these carry a device copy. Only 1:nsend / 1:nrecv is
! ever read, so a longer array is harmless. npe bounds the peer lists
! trivially.
if (allocated(snd_ibuf)) then
if (max(nsend,1) > size(snd_ibuf)) then
deallocate(snd_igrid, snd_ibuf, snd_key, snd_dest, snd_dims, snd_group)
end if
end if
if (.not.allocated(snd_ibuf)) then
allocate(snd_igrid(max(nsend,1)), snd_ibuf(max(nsend,1)),&
snd_key(max(nsend,1)), snd_dest(max(nsend,1)),&
snd_dims(max(nsend,1)), snd_group(max(nsend,1),2,3))
end if
if (allocated(rcv_key)) then
if (max(nrecv,1) > size(rcv_key)) deallocate(rcv_key, rcv_src,&
rcv_dims, rcv_off)
end if
if (.not.allocated(rcv_key)) then
allocate(rcv_key(max(nrecv,1)), rcv_src(max(nrecv,1)),&
rcv_dims(max(nrecv,1)), rcv_off(max(nrecv,1)))
end if
if (.not.allocated(send_pe)) then
allocate(send_pe(npe), send_pe_off(npe), send_pe_len(npe))
allocate(recv_pe(npe), recv_pe_off(npe), recv_pe_len(npe))
end if
! Only 1:n_recv_pe / 1:n_send_pe of these is ever posted or waited on, and
! that is bounded by the chunk count, so growing without shrinking is safe.
if (allocated(fc_recvreq)) then
if (nrecv > size(fc_recvreq)) then
deallocate(fc_recvreq, fc_recvstat)
allocate(fc_recvstat(MPI_STATUS_SIZE,max(nrecv,1)),&
fc_recvreq(max(nrecv,1)))
end if
else
allocate(fc_recvstat(MPI_STATUS_SIZE,max(nrecv,1)),&
fc_recvreq(max(nrecv,1)))
end if
if (allocated(fc_sendreq)) then
if (nsend > size(fc_sendreq)) then
deallocate(fc_sendreq, fc_sendstat)
allocate(fc_sendstat(MPI_STATUS_SIZE,max(nsend,1)),&
fc_sendreq(max(nsend,1)))
end if
else
allocate(fc_sendstat(MPI_STATUS_SIZE,max(nsend,1)),&
fc_sendreq(max(nsend,1)))
end if
if(stagger_grid) then
if (allocated(recvbuffer_cc)) then
if (recvsize_cc /= size(recvbuffer_cc)) then
deallocate(recvbuffer_cc)
allocate(recvbuffer_cc(recvsize_cc))
end if
else
allocate(recvbuffer_cc(recvsize_cc))
end if
if (allocated(cc_recvreq)) then
if (nrecv_ct /= size(cc_recvreq)) then
deallocate(cc_recvreq, cc_recvstat)
allocate(cc_recvstat(MPI_STATUS_SIZE,nrecv_ct),&
cc_recvreq(nrecv_ct))
end if
else
allocate(cc_recvstat(MPI_STATUS_SIZE,nrecv_ct), cc_recvreq(nrecv_ct))
end if
if (allocated(sendbuffer_cc)) then
if (sendsize_cc /= size(sendbuffer_cc)) then
deallocate(sendbuffer_cc)
allocate(sendbuffer_cc(sendsize_cc))
end if
else
allocate(sendbuffer_cc(sendsize_cc))
end if
if (allocated(cc_sendreq)) then
if (nsend_ct /= size(cc_sendreq)) then
deallocate(cc_sendreq, cc_sendstat)
allocate(cc_sendstat(MPI_STATUS_SIZE,nsend_ct),&
cc_sendreq(nsend_ct))
end if
else
allocate(cc_sendstat(MPI_STATUS_SIZE,nsend_ct), cc_sendreq(nsend_ct))
end if
end if
call build_message_layout(idimmin,idimmax)
end subroutine init_comm_fix_conserve