c_redist_36_mpi_copy_nonblock Subroutine

private subroutine c_redist_36_mpi_copy_nonblock(r, from_here, to_here, ntgrid)

Uses

FIXME : Add documentation

Arguments

Type IntentOptional 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

Contents


Source Code

  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