mod_comm.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

! 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(q, 1, im, jfirst-nd_s, jlast+nd_n, kfirst, klast, &
                               1, im, j,           j,          kfirst, klast, &
                               buff_r(tdisp+1))
#else
!$omp parallel do private(i, k)
         do k=kfirst,klast
            do i=1,im
               q(i,j,k) = g_4d(i,j,k,1) 
            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_recv_n

!-----
      subroutine mp_send2_ns(im, jm, jfirst, jlast, kfirst, klast, nd, 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):: nd
      real, intent(in):: q1(im,jfirst-nd:jlast+nd,kfirst:klast) 
      real, intent(in):: q2(im,jfirst-nd:jlast+nd,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)
      ncall_s = ncall_s + 1
#if defined(MPI2)
      if (ncall_s == 1) then
        call MPI_WIN_FENCE(MPI_MODE_NOPRECEDE, buffwin, ierror)
      endif
#endif

! Send to south
      if ( jfirst > 1 ) then
#if !defined(MPI2)
! Start recv to north
        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
        dest = gid - 1
        qsize = im*(klast-kfirst+1)*2
        tdisp = igosouth*idimsize + (ncall_s-1)*idimsize*nbuf
        call BufferPack3d(q1, 1, im, jfirst-nd, jlast+nd, kfirst, klast, &
                              1, im, jfirst,    jfirst,   kfirst, klast, &
                              buff_s(tdisp+1))
        displ = im*(klast-kfirst+1)
        call BufferPack3d(q2, 1, im, jfirst-nd, jlast+nd, 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
      endif

! Send to north
      if ( jlast < jm ) then
#if !defined(MPI2)
! Start recv to south
        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
        dest = gid + 1
        qsize = im*(klast-kfirst+1)*2
        tdisp = igonorth*idimsize + (ncall_s-1)*idimsize*nbuf
        call BufferPack3d(q1, 1, im, jfirst-nd, jlast+nd, kfirst, klast, &
                              1, im, jlast,     jlast,    kfirst, klast, &
                              buff_s(tdisp+1))
        displ = im*(klast-kfirst+1)
        call BufferPack3d(q2, 1, im, jfirst-nd, jlast+nd, 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
      endif

#else
#include "mlp_ptr.h"
!$omp parallel do private(i, k)
      do k=kfirst,klast
! Send to south
      if ( jfirst > 1 ) then
           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
      endif

! Send to north
      if ( jlast < jm ) then
           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
      endif
      enddo
#endif
      end subroutine mp_send2_ns

!-----
      subroutine mp_recv2_ns(im, jm, jfirst, jlast, kfirst, klast, nd, 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):: nd
      real, intent(inout):: q1(im,jfirst-nd:jlast+nd,kfirst:klast) 
      real, intent(inout):: q2(im,jfirst-nd:jlast+nd,kfirst:klast) 

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

#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
! Recv from south
      if ( jfirst > 1 ) then
#if !defined(MPI2)
        nread = nread + 1
        call mpi_wait(rqest(nread), Status, ierror)
#endif
        j = jfirst - 1
        tdisp = igonorth*idimsize + (ncall_r-1)*idimsize*nbuf
        call BufferUnPack3d(q1, 1, im, jfirst-nd, jlast+nd, kfirst, klast, &
                                1, im, j,         j,        kfirst, klast, &
                                buff_r(tdisp+1))
        displ = im*(klast-kfirst+1)
        call BufferUnPack3d(q2, 1, im, jfirst-nd, jlast+nd, kfirst, klast, &
                                1, im, j,         j,        kfirst, klast, &
                                buff_r(displ+tdisp+1))
      endif
! Recv from north
      if ( jlast < jm ) then
#if !defined(MPI2)
        nread = nread + 1
        call mpi_wait(rqest(nread), Status, ierror)
#endif
        j = jlast + 1
        tdisp = igosouth*idimsize + (ncall_r-1)*idimsize*nbuf
        call BufferUnPack3d(q1, 1, im, jfirst-nd, jlast+nd, kfirst, klast, &
                                1, im, j,         j,        kfirst, klast, &
                                buff_r(tdisp+1))
        displ = im*(klast-kfirst+1)
        call BufferUnPack3d(q2, 1, im, jfirst-nd, jlast+nd, kfirst, klast, &
                                1, im, j,         j,        kfirst, klast, &
                                buff_r(displ+tdisp+1))
      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
! Recv data from south
      if ( jfirst > 1 ) then
            j = jfirst - 1
            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
      endif

! Recv data from north
      if ( jlast < jm ) then
            j = jlast + 1
            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
      endif
      enddo
#endif
      end subroutine mp_recv2_ns

      subroutine mp_send_pe(im, jm, jfirst, jlast, kfirst, klast, p)
!-----
      implicit none
      integer, intent(in):: im, jm, jfirst, jlast, kfirst, klast
      real, intent(in):: p(im,kfirst:klast,jfirst:jlast) 
      integer i, k
      integer src, dest
      integer qsize
      integer recv_tag, send_tag
#if !defined(USE_MLP) && defined(MPI2)
      integer n, 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
#endif
#endif

#if !defined(USE_MLP) && !defined(MPI2)
! Start recv from south
      if ( jfirst > 1 ) then
         src = gid - 1
         recv_tag = src
         qsize = im*(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
! Send data to North
      if ( jlast < jm ) then
#if !defined(USE_MLP)
        dest = gid + 1
        qsize = im*(klast-kfirst+1)
        tdisp = igonorth*idimsize + (ncall_s-1)*idimsize*nbuf
        call BufferPack2d(p(1,1,jlast), 1, im, kfirst, klast, &
                                        1, im, kfirst, klast, &
                                        buff_s(tdisp+1))
#if defined(MPI2)
!$omp parallel do private(n,tmpsize,mysize,mydisp)
        do n=1,numcpu
          tmpsize = ceiling(real(qsize)/real(numcpu))
          mysize = MIN(tmpsize, MAX(qsize-(tmpsize*(n-1)),0))
          mydisp = tdisp + (n-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_t2(i,k,jlast) = p(i,k,jlast)
            enddo
         enddo
#endif
      endif
      end subroutine mp_send_pe

!-----
      subroutine mp_recv_pe(im, jm, jfirst, jlast, kfirst, klast, pesouth)
!-----
      implicit none
      integer, intent(in):: im, jm, jfirst, jlast, kfirst, klast
      real, intent(inout):: pesouth(im,kfirst:klast) 
      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

! Recv from south
      if ( jfirst > 1 ) then
#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 BufferUnPack2d(pesouth, 1, im, kfirst, klast, &
                                     1, im, kfirst, klast, &
                                     buff_r(tdisp+1))
#else
!$omp parallel do private(i, j, k)
         do k=kfirst,klast
            j = jfirst - 1
            do i=1,im
               pesouth(i,k) = g_t2(i,k,j)
            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_recv_pe

      subroutine mp_send(dest, src, qsize_s, qsize_r, b_s, b_r)
!-----
      implicit none
      integer, intent(in) :: qsize_s
      integer, intent(in) :: qsize_r
      integer, intent(in) :: dest
      integer, intent(in) :: src
      real, intent(in):: b_s(*) 
      real, intent(in):: b_r(*) 
      integer i, k
      integer recv_tag, send_tag
#if !defined(USE_MLP) && defined(MPI2)
      integer n, 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
#endif
#endif

#if !defined(USE_MLP) && !defined(MPI2)
! Start recv from src
      if ( qsize_r > 0 ) then
         recv_tag = src
         nrecv = nrecv + 1
         call mpi_irecv(b_r, qsize_r, mp_precision, src, &
                        recv_tag, commglobal, rqest(nrecv), ierror)
      endif
#endif
! Send data to dest
      if ( qsize_s > 0 ) then
#if !defined(USE_MLP)
#if defined(MPI2)
!$omp parallel do private(n,tmpsize,mysize,mydisp)
        do n=1,numcpu
          tmpsize = ceiling(real(qsize_s)/real(numcpu))
          mysize = MIN(tmpsize, MAX(qsize-(tmpsize*(n-1)),0))
          mydisp = (n-1)*tmpsize
          call MPI_PUT(b_s(mydisp+1), mysize, mp_precision, dest, &
                       mydisp, mysize, mp_precision, buffwin, ierror)
        enddo
#else
        send_tag = gid
        nsend = nsend + 1
        call mpi_isend(b_s, qsize_s, mp_precision, dest, &
                       send_tag, commglobal, sqest(nsend), ierror)
#endif

#else
XXXXXXXXXXXXXXXXXXXXXXXXXX  MLP NOT YET IMPLEMENTED XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!$omp parallel do private(i, k)
         do k=kfirst,klast
            do i=1,im
               g_t2(i,k,jlast) = p(i,k,jlast)
            enddo
         enddo
XXXXXXXXXXXXXXXXXXXXXXXXXX  MLP NOT YET IMPLEMENTED XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
#endif
      endif
      end subroutine mp_send