mod_comm.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

      endif
      if (ncall_r == ncall_s) then
#if !defined(MPI2)
        call mpi_waitall(nsend, sqest, Stats, ierror)
        nrecv = 0
        nread = 0
        nsend = 0
#endif
        ncall_s = 0
        ncall_r = 0
      endif
#else
#include "mlp_ptr.h"
!$omp parallel do private(i,j,k)
      do k=kfirst,klast
         if ( jfirst > 1 ) then
! Recv from south
            do j=jfirst-ng_s,jfirst-1
               do i=1,im
                  q(i,j,k) = g_4d(i,j,k,iq)
               enddo
            enddo
         endif

         if ( jlast < jm ) then
! Recv from north
            do j=jlast+1,jlast+ng_n
               do i=1,im
                  q(i,j,k) = g_4d(i,j,k,iq)
               enddo
            enddo
         endif
      enddo
#endif
      end subroutine mp_recv3d_ns

!-----
      subroutine mp_send2_n(im, jm, jfirst, jlast, kfirst, klast, &
                            ng_s, ng_n, q1, q2)
!-----
      implicit none
      integer, intent(in):: im, jm, jfirst, jlast
      integer, intent(in):: kfirst, klast  ! careful: might be klast+1 outside
      integer, intent(in):: ng_s
      integer, intent(in):: ng_n
      real, intent(in):: q1(im,jfirst-ng_s:jlast+ng_n,kfirst:klast) 
      real, intent(in):: q2(im,jfirst-ng_s:jlast+ng_n,kfirst:klast) 
      integer i, k
      integer src, dest
      integer qsize
      integer recv_tag, send_tag
      integer displ
#if !defined(USE_MLP) && defined(MPI2)
      integer p, tmpsize, mysize
      integer(kind=MPI_ADDRESS_KIND) mydisp
#endif

#if defined(USE_MLP)
#include "mlp_ptr.h"
#endif

#if !defined(USE_MLP)
      ncall_s = ncall_s + 1
#if defined(MPI2)
      if (ncall_s == 1) then
        call MPI_WIN_FENCE(MPI_MODE_NOPRECEDE, buffwin, ierror)
      endif
#else
! Start receive from south
      if ( jfirst > 1 ) then
         src = gid - 1
         recv_tag = src
         qsize = im*2*(klast-kfirst+1)
         nrecv = nrecv + 1
         tdisp = igonorth*idimsize + (ncall_s-1)*idimsize*nbuf
         call mpi_irecv(buff_r(tdisp+1), qsize, mp_precision, src, &
                        recv_tag, commglobal, rqest(nrecv), ierror)
      endif
#endif
#endif

! Send data to north
      if ( jlast < jm ) then
#if !defined(USE_MLP)
        dest = gid + 1
        qsize = im*(klast-kfirst+1)*2
        tdisp = igonorth*idimsize + (ncall_s-1)*idimsize*nbuf
        call BufferPack3d(q1, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                              1, im, jlast,       jlast,      kfirst, klast, &
                              buff_s(tdisp+1))
        displ = im*(klast-kfirst+1)
        call BufferPack3d(q2, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                              1, im, jlast,       jlast,      kfirst, klast, &
                              buff_s(displ+tdisp+1))
#if defined(MPI2)
!$omp parallel do private(p,tmpsize,mysize,mydisp)
        do p=1,numcpu
          tmpsize = ceiling(real(qsize)/real(numcpu))
          mysize = MIN(tmpsize, MAX(qsize-(tmpsize*(p-1)),0))
          mydisp = tdisp + (p-1)*tmpsize
          call MPI_PUT(buff_s(mydisp+1), mysize, mp_precision, dest, &
                       mydisp, mysize, mp_precision, buffwin, ierror)
        enddo
#else
        send_tag = gid
        nsend = nsend + 1
        call mpi_isend(buff_s(tdisp+1), qsize, mp_precision, dest, &
                       send_tag, commglobal, sqest(nsend), ierror)
#endif

#else
!$omp parallel do private(i, k)
         do k=kfirst,klast
            do i=1,im
               g_t1(i,jlast,k,1) = q1(i,jlast,k)
               g_t1(i,jlast,k,2) = q2(i,jlast,k)
            enddo
         enddo
#endif
      endif
      end subroutine mp_send2_n

!-----
      subroutine mp_send2_s(im, jm, jfirst, jlast, kfirst, klast, &
                            ng_s, ng_n, q1, q2)
!-----
      implicit none
      integer, intent(in):: im, jm, jfirst, jlast
      integer, intent(in):: kfirst, klast   !careful: klast might be klast+1
      integer, intent(in):: ng_s
      integer, intent(in):: ng_n
      real, intent(in):: q1(im,jfirst-ng_s:jlast+ng_n,kfirst:klast) 
      real, intent(in):: q2(im,jfirst-ng_s:jlast+ng_n,kfirst:klast) 

! Local:
      integer i, k
      integer src, dest
      integer qsize
      integer recv_tag, send_tag
      integer displ
#if !defined(USE_MLP) && defined(MPI2)
      integer p, tmpsize, mysize
      integer(kind=MPI_ADDRESS_KIND) mydisp
#endif

#if defined(USE_MLP)
#include "mlp_ptr.h"
#endif

#if !defined(USE_MLP)
      ncall_s = ncall_s + 1
#if defined(MPI2)
      if (ncall_s == 1) then
        call MPI_WIN_FENCE(MPI_MODE_NOPRECEDE, buffwin, ierror)
      endif
#else
! Start recv from north
      if ( jlast < jm ) then
         src = gid + 1
         recv_tag = src
         qsize = im*2*(klast-kfirst+1)
         nrecv = nrecv + 1
         tdisp = igosouth*idimsize + (ncall_s-1)*idimsize*nbuf
         call mpi_irecv(buff_r(tdisp+1), qsize, mp_precision, src, &
                        recv_tag, commglobal, rqest(nrecv), ierror)
      endif
#endif
#endif

! Send data to south
      if ( jfirst > 1 ) then
#if !defined(USE_MLP)
        dest = gid - 1
        qsize = im*(klast-kfirst+1)*2
        tdisp = igosouth*idimsize + (ncall_s-1)*idimsize*nbuf
        call BufferPack3d(q1, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                              1, im, jfirst,      jfirst,     kfirst, klast, &
                              buff_s(tdisp+1))
        displ = im*(klast-kfirst+1)
        call BufferPack3d(q2, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                              1, im, jfirst,      jfirst,     kfirst, klast, &
                              buff_s(displ+tdisp+1))
#if defined(MPI2)
!$omp parallel do private(p,tmpsize,mysize,mydisp)
        do p=1,numcpu
          tmpsize = ceiling(real(qsize)/real(numcpu))
          mysize = MIN(tmpsize, MAX(qsize-(tmpsize*(p-1)),0))
          mydisp = tdisp + (p-1)*tmpsize
          call MPI_PUT(buff_s(mydisp+1), mysize, mp_precision, dest, &
                       mydisp, mysize, mp_precision, buffwin, ierror)
        enddo
#else
        send_tag = gid
        nsend  = nsend + 1
        call mpi_isend(buff_s(tdisp+1), qsize, mp_precision, dest, &
                       send_tag, commglobal, sqest(nsend), ierror)
#endif

#else
!$omp parallel do private(i, k)
         do k=kfirst,klast
            do i=1,im
               g_t1(i,jfirst,k,1) = q1(i,jfirst,k)
               g_t1(i,jfirst,k,2) = q2(i,jfirst,k)
            enddo
         enddo
#endif
      endif
      end subroutine mp_send2_s

!-----
      subroutine mp_recv2_s(im, jm, jfirst, jlast, kfirst, klast, &
                            ng_s, ng_n, q1, q2)
!-----
      implicit none
      integer, intent(in):: im, jm, jfirst, jlast
      integer, intent(in):: kfirst, klast     ! careful: klast might be klast+1
      integer, intent(in):: ng_s
      integer, intent(in):: ng_n
      real, intent(inout):: q1(im,jfirst-ng_s:jlast+ng_n,kfirst:klast) 
      real, intent(inout):: q2(im,jfirst-ng_s:jlast+ng_n,kfirst:klast) 

! Local:
      integer i,j, k, n
      integer displ

#if defined(USE_MLP)
#include "mlp_ptr.h"
#endif

#if !defined(USE_MLP)
      ncall_r = ncall_r + 1
#if defined(MPI2)
      if (ncall_r == 1) then
        call MPI_WIN_FENCE(MPI_MODE_NOSTORE + MPI_MODE_NOSUCCEED, &
                           buffwin, ierror)
      endif
#endif
#endif

! Recv data from south
      if ( jfirst > 1 ) then
        j = jfirst - 1
#if !defined(USE_MLP)
#if !defined(MPI2)
        nread = nread + 1
        call mpi_wait(rqest(nread), Status, ierror)
#endif
        tdisp = igonorth*idimsize + (ncall_r-1)*idimsize*nbuf
        call BufferUnPack3d(q1, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                                1, im, j,           j,          kfirst, klast, &
                                buff_r(tdisp+1))
        displ = im*(klast-kfirst+1)
        call BufferUnPack3d(q2, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                                1, im, j,           j,          kfirst, klast, &
                                buff_r(displ+tdisp+1))
#else
!$omp parallel do private(i, k)
         do k=kfirst,klast
            do i=1,im
               q1(i,j,k) = g_t1(i,j,k,1) 
               q2(i,j,k) = g_t1(i,j,k,2) 
            enddo
         enddo
#endif
      endif

#if !defined(USE_MLP)
      if (ncall_r == ncall_s) then
#if !defined(MPI2)
        call mpi_waitall(nsend, sqest, Stats, ierror)
        nrecv = 0
        nread = 0
        nsend = 0
#endif
        ncall_s = 0
        ncall_r = 0
      endif
#endif
      end subroutine mp_recv2_s

!-----
      subroutine mp_recv2_n(im, jm, jfirst, jlast, kfirst, klast, &
                            ng_s, ng_n, q1, q2)
!-----
      implicit none
      integer, intent(in):: im, jm, jfirst, jlast
      integer, intent(in):: kfirst, klast     !careful: klast might be klast+1
      integer, intent(in):: ng_s
      integer, intent(in):: ng_n
      real, intent(inout):: q1(im,jfirst-ng_s:jlast+ng_n,kfirst:klast) 
      real, intent(inout):: q2(im,jfirst-ng_s:jlast+ng_n,kfirst:klast) 

! Local:
      integer i,j, k, n
      integer displ

#if defined(USE_MLP)
#include "mlp_ptr.h"
#endif

#if !defined(USE_MLP)
      ncall_r = ncall_r + 1
#if defined(MPI2)
      if (ncall_r == 1) then
        call MPI_WIN_FENCE(MPI_MODE_NOSTORE + MPI_MODE_NOSUCCEED, &
                           buffwin, ierror)
      endif
#endif
#endif

! Recv data from north
      if ( jlast < jm ) then
        j = jlast + 1
#if !defined(USE_MLP)
#if !defined(MPI2)
        nread = nread + 1
        call mpi_wait(rqest(nread), Status, ierror)
#endif
        tdisp = igosouth*idimsize + (ncall_r-1)*idimsize*nbuf
        call BufferUnPack3d(q1, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                                1, im, j,           j,          kfirst, klast, &
                                buff_r(tdisp+1))
        displ = im*(klast-kfirst+1)
        call BufferUnPack3d(q2, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                                1, im, j,           j,          kfirst, klast, &
                                buff_r(displ+tdisp+1))
#else
!$omp parallel do private(i, k)
         do k=kfirst,klast
            do i=1,im
               q1(i,j,k) = g_t1(i,j,k,1) 
               q2(i,j,k) = g_t1(i,j,k,2) 
            enddo
         enddo
#endif
      endif

#if !defined(USE_MLP)
      if (ncall_r == ncall_s) then
#if !defined(MPI2)
        call mpi_waitall(nsend, sqest, Stats, ierror)
        nrecv = 0
        nread = 0
        nsend = 0
#endif
        ncall_s = 0
        ncall_r = 0
      endif
#endif
      end subroutine mp_recv2_n

!-----
      subroutine mp_send_s(im, jm, jfirst, jlast, kfirst, klast, &
                           nd_s, nd_n, q)
!-----
      implicit none
      integer, intent(in):: im, jm, jfirst, jlast
      integer, intent(in):: kfirst, klast
      integer, intent(in):: nd_s, nd_n
      real, intent(in):: q(im,jfirst-nd_s:jlast+nd_n,kfirst:klast) 

! Local:
      integer i, k
      integer src, dest
      integer qsize
      integer recv_tag, send_tag
#if !defined(USE_MLP) && defined(MPI2)
      integer p, tmpsize, mysize
      integer(kind=MPI_ADDRESS_KIND) mydisp
#endif

#if defined(USE_MLP)
#include "mlp_ptr.h"
#endif

#if !defined(USE_MLP)
      ncall_s = ncall_s + 1
#if defined(MPI2)
      if (ncall_s == 1) then
        call MPI_WIN_FENCE(MPI_MODE_NOPRECEDE, buffwin, ierror)
      endif
#else
! Start receive from north
      if ( jlast < jm ) then
         src = gid + 1
         recv_tag = src
         qsize = im*(klast-kfirst+1)
         nrecv = nrecv + 1
         tdisp = igosouth*idimsize + (ncall_s-1)*idimsize*nbuf
         call mpi_irecv(buff_r(tdisp+1), qsize, mp_precision, src, &
                        recv_tag, commglobal, rqest(nrecv), ierror)
      endif
#endif
#endif

! Send data to south
      if ( jfirst > 1 ) then
#if !defined(USE_MLP)
        dest = gid - 1
        qsize = im*(klast-kfirst+1)
        tdisp = igosouth*idimsize + (ncall_s-1)*idimsize*nbuf
        call BufferPack3d(q, 1, im, jfirst-nd_s, jlast+nd_n, kfirst, klast, &
                             1, im, jfirst,      jfirst,     kfirst, klast, &
                             buff_s(tdisp+1))
#if defined(MPI2)
!$omp parallel do private(p,tmpsize,mysize,mydisp)
        do p=1,numcpu
          tmpsize = ceiling(real(qsize)/real(numcpu))
          mysize = MIN(tmpsize, MAX(qsize-(tmpsize*(p-1)),0))
          mydisp = tdisp + (p-1)*tmpsize
          call MPI_PUT(buff_s(mydisp+1), mysize, mp_precision, dest, &
                       mydisp, mysize, mp_precision, buffwin, ierror)
        enddo
#else
         send_tag = gid
         nsend = nsend + 1
         call mpi_isend(buff_s(tdisp+1), qsize, mp_precision, dest, &
                        send_tag, commglobal, sqest(nsend), ierror)
#endif

#else
!$omp parallel do private(i, k)
         do k=kfirst,klast
            do i=1,im
               g_4d(i,jfirst,k,1) = q(i,jfirst,k)
            enddo
         enddo
#endif
      endif
      end subroutine mp_send_s

!-----
      subroutine mp_recv_n(im, jm, jfirst, jlast, kfirst, klast, nd_s, nd_n, q)
!-----
      implicit none
      integer, intent(in):: im, jm, jfirst, jlast
      integer, intent(in):: kfirst, klast
      integer, intent(in):: nd_s, nd_n
      real, intent(inout):: q(im,jfirst-nd_s:jlast+nd_n,kfirst:klast) 

! Local:
      integer i, j, k, n

#if defined(USE_MLP)
#include "mlp_ptr.h"
#endif

#if !defined(USE_MLP)
      ncall_r = ncall_r + 1
#if defined(MPI2)
      if (ncall_r == 1) then
        call MPI_WIN_FENCE(MPI_MODE_NOSTORE + MPI_MODE_NOSUCCEED, &
                           buffwin, ierror)
      endif
#endif
#endif