mod_mpi.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

#include <misc.h>
module mod_mpi

 use precision

#if defined (SPMD )
#include "mpif.h"

#if defined (USE_REAL4)
#define mp_precision MPI_REAL
#else
#define mp_precision MPI_DOUBLE_PRECISION
#endif

 integer Status(MPI_STATUS_SIZE)
 integer ierror
 integer sqest(2)              ! MPI_SEND requests
 integer rqest(2)              ! MPI_RECV requests
 integer nsend, nrecv
 Save sqest, rqest
 Save nsend, nrecv

contains

 subroutine mp_isend_q(q, im, jm, km, jfirst, jlast, k1, k2,  &
                       ng, nc, nq, comm_y, yid, qsouth, qnorth)

 implicit none
 integer, intent(in):: im, jm, km, jfirst, jlast, k1, k2
 integer, intent(in):: ng           ! zones to be ghosted
                                    ! nd may not be equal to ng
 integer, intent(in):: nc
 integer, intent(in):: nq
 integer, intent(in):: comm_y
 integer, intent(in):: yid
 real(r8), intent(in):: q(im,jfirst:jlast,k1:k2,nc) 

 real(r8), intent(out):: qsouth(im,ng,k1:k2,nq)
 real(r8), intent(out):: qnorth(im,ng,k1:k2,nq)

 integer dest
 integer qsize
 integer i,j,k,iq
 integer ktot
 integer send_tag

  ktot = k2 - k1 + 1

  nsend = 0

  if ( jfirst > 1 ) then

! Send to South
  nsend = nsend + 1
      do iq=1,nq
!$omp  parallel do private(i, j, k)
        do k=k1,k2
           do j=1,ng
              do i=1,im
                 qsouth(i,j,k,iq) = q(i,jfirst+j-1,k,iq)
              enddo
           enddo
        enddo
      enddo

       dest  = yid - 1     ! southbound
       send_tag = yid
       qsize = im*ng*ktot*nq
       call mpi_isend(qsouth, qsize, mp_precision, dest,   &
                      send_tag, comm_y, sqest(nsend), ierror)
  endif

  if ( jlast < jm ) then
! Send to North
  nsend = nsend + 1
      do iq=1,nq
!$omp  parallel do private(i, j, k)
        do k=k1,k2
          do j=1,ng
             do i=1,im
                qnorth(i,j,k,iq) = q(i,jlast+j-ng,k,iq)
             enddo
          enddo
       enddo
       enddo
       dest  = yid + 1      ! northbound
       send_tag = yid
       qsize = im*ng*ktot*nq
       call mpi_isend(qnorth, qsize, mp_precision, dest,   &
                      send_tag, comm_y, sqest(nsend), ierror)
  endif

 end subroutine mp_isend_q

 subroutine mp_irecv_q(im, jm, km, jfirst, jlast, ng,      &
                      comm_y, yid, k1, k2, nq, qsouth, qnorth)

 implicit none
 integer, intent(in):: im, jm, km, jfirst, jlast
 integer, intent(in):: k1, k2
 integer, intent(in):: ng           ! zones to be ghosted
                                    ! nd may not be equal to ng
 integer, intent(in):: nq
 integer, intent(in):: comm_y
 integer, intent(in):: yid

 real(r8), intent(out):: qsouth(im,ng,k1:k2,nq)
 real(r8), intent(out):: qnorth(im,ng,k1:k2,nq)

 integer src
 integer qsize
 integer i,ktot
 integer recv_tag

    ktot = k2 - k1 + 1
    nrecv = 0

    if ( jfirst > 1 ) then
! Receive from South
    nrecv = nrecv + 1
         src = yid - 1     ! southbound
         recv_tag = src
         qsize = im*ng*ktot*nq
         call mpi_irecv(qsouth, qsize, mp_precision, src,   &
                       recv_tag, comm_y, rqest(nrecv), ierror)
    endif

    if ( jlast < jm ) then
! Receive from North
    nrecv = nrecv + 1
         src = yid + 1      ! northbound
         recv_tag = src
         qsize = im*ng*ktot*nq
         call mpi_irecv(qnorth, qsize, mp_precision, src,   &
                       recv_tag, comm_y, rqest(nrecv), ierror)
    endif

  if ( nsend /= 0 ) then
    do i=1,nsend
       call mpi_wait(sqest(i), Status, ierror)
    enddo
  endif

  if ( nrecv /= 0 ) then
    do i=1,nrecv
       call mpi_wait(rqest(i), Status, ierror)
    enddo
  endif

 end subroutine mp_irecv_q

#endif
end module mod_mpi