determineDonors.F90

Go to the documentation of this file.

!       This subroutine takes a list of all local fringes, sorts it,
!       then communicates the required fringes back to their donor
!       procs, and flags all required cells as donors. This routine
!       does double duty: If the flag useWall is set, it flags the
!       donor cells as wallDonors, otherwise it flags the cells as
!       regular donors. We do this since the communication structure
!       for these two operations are identical
 
subroutine determinedonors(level, sps, fringeList, nFringe, useWall)
 
    use constants
    use block, only: fringetype, flowdoms
    use communication, only: adflow_comm_world, myid, nproc, recvrequests, sendrequests
    use utils, only: echk, setpointers
    use oversetdata, only: clusters, ndomtotal, nclusters
    use oversetutilities, only: qsortfringetype, setisdonor, setiswalldonor, &
                                computefringeprocarray, unwindindex
    implicit none
 
    ! Input Params
    integer(kind=intType), intent(in) :: level, sps, nFringe
    type(fringetype), intent(inout), dimension(nFringe) :: fringeList
    logical, intent(in) :: useWall
 
    ! Working
    integer(kind=intType), dimension(:), allocatable :: fringeProc, cumFringeProc
    integer(kind=intType), dimension(:), allocatable :: tmpInt
    integer(kind=intType), dimension(:), allocatable :: recvSizes
    integer(kind=intType), dimension(:), allocatable :: intSendBuf, intRecvBuf
    integer(kind=intType) :: i, j, k, ii, jj, kk, iii, jjj, kkk, nn, index
    integer(kind=intType) :: il, jl, kl, dIndex
    integer(kind=intType) :: iStart, iEnd, iProc, iSize, nFringeProc
    integer(kind=intType) :: sendCount, recvCount, ierr, totalRecvSize
    integer mpiStatus(MPI_STATUS_SIZE)
 
    ! First sort the fringes such that they are grouped by destination
    ! procesor.
    call qsortfringetype(fringelist, nfringe, sortbydonor)
 
    !-----------------------------------------------------------------
    ! Step 15: Now can scan through the fringeList which is guaranteed
    ! to be sorted by processor. We scan though the (sorted) list
    ! sequentally, detecting where the processor splits are. Then we
    ! fire that off to the processor that needs it, again using the
    ! dynamic sparse data exchange. For the section that is
    ! on-processor, we can do that donor flagging overlapped with the
    ! communication.
    ! -----------------------------------------------------------------
 
    allocate (fringeproc(nproc), cumfringeproc(1:nproc + 1))
    call computefringeprocarray(fringelist, nfringe, &
                                fringeproc, cumfringeproc, nfringeproc)
 
    ! nFringeProc is the total number of donor processors from
    ! fringeList fringeProc(1:nProcFringe) are the donor processors
    ! for the fringes cumFringeProc(1:nFringeProc) are the cumulative
    ! offset from in the localFringe Array. Note that we have
    ! over-estimated their size as nProc.
 
    allocate (tmpint(0:nproc - 1), recvsizes(0:nproc - 1))
    tmpint = 0
    do j = 1, nfringeproc
        iproc = fringeproc(j)
        if (iproc /= myid) then
            tmpint(iproc) = (cumfringeproc(j + 1) - cumfringeproc(j)) * 2
        end if
    end do
 
    ! Sum how much data we must receive from each processor.
    call mpi_alltoall(tmpint, 1, adflow_integer, recvsizes, 1, adflow_integer, &
                      adflow_comm_world, ierr)
    call echk(ierr, __file__, __line__)
 
    ! We will need to send 2 integers to the donor processor:
    ! donorBlock, dIndex
 
    ! Allocate space for the sending and receiving buffers
    totalrecvsize = sum(recvsizes)
    allocate (intsendbuf(2 * nfringe), intrecvbuf(totalrecvsize))
 
    ! Pack the full buffer with donorBlock, dI, dJ, and dK
    do j = 1, nfringe
        intsendbuf(2 * j - 1) = fringelist(j)%donorBlock
        intsendbuf(2 * j) = fringelist(j)%dIndex
    end do
 
    ! Send the donors back to their own processors.
    sendcount = 0
    do j = 1, nfringeproc
 
        iproc = fringeproc(j)
        istart = (cumfringeproc(j) - 1) * 2 + 1
        isize = (cumfringeproc(j + 1) - cumfringeproc(j)) * 2
 
        if (iproc /= myid) then
            sendcount = sendcount + 1
            call mpi_isend(intsendbuf(istart), isize, adflow_integer, iproc, myid, &
                           adflow_comm_world, sendrequests(sendcount), ierr)
            call echk(ierr, __file__, __line__)
        end if
    end do
 
    ! Non-blocking receives
    recvcount = 0
    ii = 1
    do iproc = 0, nproc - 1
 
        if (recvsizes(iproc) > 0) then
            recvcount = recvcount + 1
            call mpi_irecv(intrecvbuf(ii), recvsizes(iproc), adflow_integer, &
                           iproc, iproc, adflow_comm_world, recvrequests(recvcount), ierr)
            call echk(ierr, __file__, __line__)
 
            ii = ii + recvsizes(iproc)
        end if
    end do
 
    ! Local Work to do while we wait for data to send/recv
    do j = 1, nfringeproc
 
        iproc = fringeproc(j)
        istart = cumfringeproc(j)
        iend = cumfringeproc(j + 1) - 1
 
        if (iproc == myid) then
            do i = istart, iend
                nn = fringelist(i)%donorBlock
                il = flowdoms(nn, level, sps)%il
                jl = flowdoms(nn, level, sps)%jl
                kl = flowdoms(nn, level, sps)%kl
                dindex = fringelist(i)%dIndex
                call unwindindex(dindex, il, jl, kl, iii, jjj, kkk)
 
                ! For the wall donors, we just flag the 1 cell that was
                ! identified in the fringe search based on the octant.
                if (usewall) then
                    call setiswalldonor(flowdoms(nn, level, sps)%status(iii, jjj, kkk), .true.)
                else
                    do kk = 0, 1
                        do jj = 0, 1
                            do ii = 0, 1
                                call setisdonor( &
                                    flowdoms(nn, level, sps)%status(iii + ii, jjj + jj, kkk + kk), .true.)
                            end do
                        end do
                    end do
                end if
            end do
        end if
    end do
 
    ! Complete all the sends/receives. We could do overlapping here
    ! like the frist comm for the fringes/blocks.
    do i = 1, recvcount
        call mpi_waitany(recvcount, recvrequests, index, mpistatus, ierr)
        call echk(ierr, __file__, __line__)
    end do
 
    do i = 1, sendcount
        call mpi_waitany(sendcount, sendrequests, index, mpistatus, ierr)
        call echk(ierr, __file__, __line__)
    end do
 
    ! Loop over the full receive buffer that should now be full.
    do j = 1, totalrecvsize / 2
 
        nn = intrecvbuf(2 * j - 1)
        il = flowdoms(nn, level, sps)%il
        jl = flowdoms(nn, level, sps)%jl
        kl = flowdoms(nn, level, sps)%kl
 
        dindex = intrecvbuf(2 * j)
        call unwindindex(dindex, il, jl, kl, iii, jjj, kkk)
 
        if (usewall) Then
            call setiswalldonor(flowdoms(nn, level, sps)%status(iii, jjj, kkk), .true.)
        else
            do kk = 0, 1
                do jj = 0, 1
                    do ii = 0, 1
                        call setisdonor(flowdoms(nn, level, sps)%status(iii + ii, jjj + jj, kkk + kk), .true.)
                    end do
                end do
            end do
        end if
    end do
    ! Finished with the buffers and allocatable arrays
    deallocate (intsendbuf, intrecvbuf, fringeproc, cumfringeproc, tmpint, recvsizes)
 
end subroutine determinedonors