FIXME : Add documentation
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(redist_type), | intent(inout) | :: | r | |||
complex, | intent(in), | dimension (r%from_low(1):, r%from_low(2):, r%from_low(3):) | :: | from_here | ||
complex, | intent(inout), | dimension (r%to_low(1):, r%to_low(2):, r%to_low(3):, r%to_low(4):, r%to_low(5):, r%to_low(6):) | :: | to_here | ||
integer, | intent(in) | :: | ntgrid |
subroutine c_redist_36_mpi_copy_nonblock(r, from_here, to_here, ntgrid)
use mp, only: iproc, nproc, nbsend, nbrecv, waitany, waitall, initialise_requests
implicit none
integer, intent(in) :: ntgrid
type (redist_type), intent (in out) :: r
complex, dimension (r%from_low(1):, &
r%from_low(2):, &
r%from_low(3):), intent (in) :: from_here
complex, dimension (r%to_low(1):, &
r%to_low(2):, &
r%to_low(3):, &
r%to_low(4):, &
r%to_low(5):, &
r%to_low(6):), intent (in out) :: to_here
integer :: i, ip, nsend, nrecv, count, ipfrom
!AJ Added as the r%complex_buf is not designed for sending contigous blocks, rather to pack individual elements
!AJ into the buffer. As each element in my redist object is actually (2*ntgrid+1)*2 (sigma) then I need a bigger
!AJ send and receive buffer.
complex, dimension(:,:,:,:), allocatable :: recv_buff, send_buff
integer, dimension(:), allocatable :: recv_hand, send_hand, recv_lookup
nrecv = r%nrecv
nsend = r%nsend
if(nrecv>0) then
allocate(recv_buff(-ntgrid:ntgrid,1:2,size(r%complex_buff),nrecv))
allocate(recv_hand(nrecv))
allocate(recv_lookup(nrecv))
call initialise_requests(recv_hand)
count = 0
do ip=0,nproc-1
if(r%to(ip)%nn>0.and.ip.ne.iproc) then
count = count + 1
recv_lookup(count) = ip
call nbrecv(recv_buff(:,:,1:r%to(ip)%nn,count),ip,ip,recv_hand(count))
end if
end do
end if
if(nsend>0) then
allocate(send_buff(-ntgrid:ntgrid,1:2,size(r%complex_buff),nsend))
allocate(send_hand(nsend))
call initialise_requests(send_hand)
count = 0
do ip=0,nproc-1
if(r%from(ip)%nn>0.and.ip.ne.iproc) then
count = count + 1
do i = 1, r%from(ip)%nn
send_buff(:,:,i,count) = from_here(:,:,r%from(ip)%m(i))
end do
call nbsend (send_buff(:,:,1:r%from(ip)%nn,count),ip,iproc,send_hand(count))
end if
end do
end if
if(nrecv>0) then
do ip = 1,nrecv
call waitany(nrecv, recv_hand, count)
ipfrom = recv_lookup(count)
do i = 1, r%to(ipfrom)%nn
to_here(:,:,r%to(ipfrom)%m(i), &
r%to(ipfrom)%n(i), &
r%to(ipfrom)%o(i), &
r%to(ipfrom)%p(i)) &
= recv_buff(:,:,i,count)
end do
end do
deallocate(recv_buff)
deallocate(recv_hand)
deallocate(recv_lookup)
end if
if(nsend>0) then
call waitall(nsend, send_hand)
deallocate(send_buff)
deallocate(send_hand)
end if
end subroutine c_redist_36_mpi_copy_nonblock