mod_comm.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

!-----
      subroutine mp_recv(src, qsize_r, b_r)
!-----
      implicit none
      integer, intent(in):: src
      integer, intent(in):: qsize_r
      real, intent(inout):: b_r(*)
      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 src
      if ( qsize_r > 0 ) then
#if !defined(USE_MLP)
#if !defined(MPI2)
        nread = nread + 1
        call mpi_wait(rqest(nread), Status, ierror)
#endif
#else
XXXXXXXXXXXXXXXXXXXXXXXXXX  MLP NOT YET IMPLEMENTED XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!$omp parallel do private(i, j, k)
         do k=kfirst,klast
            j = jfirst - 1
            do i=1,im
               b_r(i,k) = g_t2(i,k,j)
            enddo
         enddo
XXXXXXXXXXXXXXXXXXXXXXXXXX  MLP NOT YET IMPLEMENTED XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
#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

!-----
      subroutine mp_send_ua(im, jm, jfirst, jlast, kfirst, klast, p)
!-----
      integer, intent(in):: im, jm, jfirst, jlast, kfirst, klast
      real, intent(in):: p(im,jfirst:jlast,kfirst:klast) 
      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 north
      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 BufferPack3d(p, 1, im, jfirst, jlast, kfirst, klast, &
                             1, im, jlast,  jlast, 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_4d(i,jlast,k,1) = p(i,jlast,k)
            enddo
         enddo
#endif
      endif
      end subroutine mp_send_ua

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

!-----
      subroutine mp_reduce_max(km, cymax)
!-----
      implicit none
      integer k, km, n
      real maxin(km)
      real cymax(km)

#if !defined(USE_MLP)
!$omp parallel do private(k)
      do k=1,km
        maxin(k) = cymax(k)
      enddo
      call mpi_allreduce( maxin, cymax, km, mp_precision, MPI_MAX, &
                          commglobal, ierror )
#else
#include "mlp_ptr.h"
      do k=1,km
         g_t3(k,nowpro) = cymax(k)
      enddo
      call mlp_barrier(gid, gsize)

      do n=1,numpro
         do k=1,km
            cymax(k) = max(g_t3(k,n), cymax(k))
         enddo
      enddo
      call mlp_barrier(gid, gsize) !may not be necessay, test, BW
#endif
      end subroutine mp_reduce_max

!-----
      subroutine mp_minmax(qmin, qmax)
!-----
      implicit none
      real, intent(inout):: qmin, qmax
      real minin, maxin
      integer n

#if !defined(USE_MLP)
      maxin = qmax
      call mpi_allreduce(maxin, qmax, 1, mp_precision, MPI_MAX, &
                         commglobal, ierror)
      minin = qmin
      call mpi_allreduce(minin, qmin, 1, mp_precision, MPI_MIN, &
                         commglobal, ierror)
#else
#include "mlp_ptr.h"
      g_t3(1,nowpro) = qmin
      g_t3(2,nowpro) = qmax
      call mlp_barrier(gid, gsize)

      do n=1,numpro
         qmin = min(g_t3(1,n), qmin)
         qmax = max(g_t3(2,n), qmax)
      enddo
      call mlp_barrier(gid, gsize)
#endif
      end subroutine mp_minmax

!-----
      subroutine mp_sum1d(jm, jfirst, jlast, qin, sum0)
!-----
      implicit none
      integer jm
      integer jfirst, jlast
      real  qin(jfirst:jlast)
! Output:
      real  sum0
! Local:
      integer j, n
      real qout(jm)

#if !defined(USE_MLP)
      call mp_allgather1d(jm, jfirst, jlast, qin, qout)
      sum0 = 0.
      do j=1,jm
        sum0 = sum0 + qout(j)
      enddo
#else
#include "mlp_ptr.h"
! Gather all subdomain vector from all PEs to a global array
      do j=jfirst,jlast
         g_1d(j) = qin(j)
      enddo
      call mlp_barrier(gid, gsize)

! Compute the sum if "Master"
      if ( gid == 0 ) then
            sum0 = 0.
         do j=1,jm
            sum0 = sum0 + g_1d(j)
         enddo
      endif
      call mp_bcst_real(sum0)
#endif
      end subroutine mp_sum1d

!-----
      subroutine mp_bcst_real(val)
!-----
! Send real "val" from Process=id to All other Processes
      real val

#if !defined(USE_MLP)
      call mpi_bcast(val, 1, mp_precision, 0, commglobal, ierror)
#else
#include "mlp_ptr.h"
      if ( gid == 0 ) then
          g_1d(1) = val
      endif

      call mlp_barrier(gid, gsize)

      if ( gid /= 0 ) then
          val = g_1d(1)
      endif
      call mlp_barrier(gid, gsize)   !may not be necessary, BW
#endif
      end subroutine mp_bcst_real


!-----
      subroutine mp_bcst_int(intv)
!-----
! Send integer "intv" from Process=id to All other Processes
      integer intv

#if !defined(USE_MLP)
      call mpi_bcast(intv, 1, MPI_INTEGER, 0, commglobal, ierror)
#else
#include "mlp_ptr.h"

      if ( gid == 0 ) then
          g_1d(1) = intv
      endif

      call mlp_barrier(gid, gsize)

      if ( gid /= 0 ) then
          intv = nint(g_1d(1))
      endif

      call mlp_barrier(gid, gsize)   !may not be necessary, BW
#endif
      end subroutine mp_bcst_int


!-----
      subroutine mp_bcst_r2d(im, jm, jfirst, jlast, qin, id)
!-----
! Send 2D array qin from Process=id to All other Processes
      integer im, jm
      integer id        ! source ID
      integer jfirst, jlast
      real qin(im,jm)
      integer i, j, n 
      integer j1, j2
      integer qsize_s
      integer qsize_r
      integer src, dest
      integer send_tag, recv_tag
#if !defined(USE_MLP)
      integer rqst(numpro), rq_stats(numpro*MPI_STATUS_SIZE)
#if defined(MPI2)
      integer p, tmpsize, mysize
      integer(kind=MPI_ADDRESS_KIND) mydisp
#endif
#endif

#if !defined(USE_MLP)
#if defined(MPI2)
      call MPI_WIN_FENCE(MPI_MODE_NOPRECEDE, buff4dwin, ierror)
#endif
      if (gid == id) then
         do n=1,numpro
           qsize_s = im*jm
           dest = n-1
           tdisp = 0
#if defined(MPI2)
           call BufferPack2d(qin, 1, im, 1, jm, 1, im, 1, jm, buff4d(tdisp+1))
!$omp parallel do private(p,tmpsize,mysize,mydisp)
           do p=1,numcpu
             tmpsize = ceiling(real(qsize_s)/real(numcpu))
             mysize = MIN(tmpsize, MAX(qsize_s-(tmpsize*(p-1)),0))
             mydisp = tdisp + (p-1)*tmpsize
             call MPI_PUT(buff4d(mydisp+1), mysize, mp_precision ,dest, &
                          mydisp, mysize, mp_precision, buff4dwin, ierror)
           enddo
#else
           send_tag = gid
           nsend = nsend + 1
           call mpi_isend(qin, qsize_s, mp_precision, dest, &
                          send_tag, commglobal, rqst(nsend), ierror)
#endif
         enddo
      endif
#if defined(MPI2)
      call MPI_WIN_FENCE(MPI_MODE_NOSTORE + MPI_MODE_NOSUCCEED, &
                         buff4dwin, ierror)
#else
      qsize_r = im*jm
      src = id
      recv_tag = src
      call mpi_recv(buff4d, qsize_r, mp_precision, src, recv_tag, &
                    commglobal, Status, ierror)
#endif
      tdisp = (jfirst-1)*im
      call BufferUnPack2d(qin, 1, im, 1, jm, 1, im, jfirst, jlast, &
                          buff4d(tdisp+1))

#if !defined(MPI2)
      if (nsend /= 0) then
        call mpi_waitall(nsend, rqst, rq_stats, ierror)
        nsend = 0
      endif
#endif

#else
#include "mlp_ptr.h"
      if ( gid == id ) then
!$omp parallel do private(i, j)
          do j=1,jm
             do i=1,im
                g_2d(i,j) = qin(i,j)
             enddo
          enddo
      endif
      call mlp_barrier(gid, gsize)

      if ( gid /= id ) then
!$omp parallel do private(i, j)
          do j=jfirst,jlast
             do i=1,im
                qin(i,j) = g_2d(i,j)
             enddo
          enddo
      endif
      call mlp_barrier(gid, gsize)
#endif
      end subroutine mp_bcst_r2d


!-----
      subroutine mp_gath_r2d(im, jm, jfirst, jlast, qin, id)
!-----
      integer im, jm
      integer id        ! source ID
      integer jfirst, jlast
      real qin(im,jm)

! Local:
      integer i, j, k, iq
      integer j1, j2
      integer n
      integer qsize
      integer src, dest
      integer send_tag, recv_tag
#if !defined(USE_MLP) && defined(MPI2)
      integer p, tmpsize, mysize
      integer(kind=MPI_ADDRESS_KIND) mydisp
#endif
  
#if !defined(USE_MLP)
#if defined(MPI2)
      call MPI_WIN_FENCE(MPI_MODE_NOPRECEDE, buff4dwin, ierror)
#endif
      dest = id
      tdisp = (