mod_comm.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

               endif
               p2 = p2 + 1
               p1 = p1 - 1
        enddo
      endif

! Safety check:
      lats = 0
      do p = 1, numpro
         lats = lats + ydist(p)
      enddo

      if ( lats .ne. jm ) then
         print *, "Decomp: big trouble sum(ydist) = ", lats, "!=", jm
      endif
 
      jfirst = 1
      jlast  = ydist(1)
      yfirst(1) = jfirst
      ylast(1) = jlast
      kfirst = 1
      klast = km
      zfirst(1) = kfirst
      zlast(1) = klast

      do p = 1,numpro-1
         yfirst(p+1) = ylast(p) + 1
         ylast(p+1) = ylast(p) + ydist(p+1) 
         if( p == myid ) then
            jfirst = yfirst(p+1)
            jlast  = ylast (p+1)
         endif
         zfirst(p+1) = kfirst
         zlast(p+1) = klast
      enddo

      deallocate (ydist)
      end subroutine y_decomp


!-----
      subroutine set_decomp(nprocs, jm, km, ydist, zdist)
      integer nprocs
      integer jm, km
      integer ydist(nprocs)
      integer zdist(nprocs)   ! Currently not used

!
! Set the decomposition if it is defined external to mod_comm
!
      integer lats, p

! Safety check:
      lats = 0
      do p = 1, nprocs
         lats = lats + ydist(p)
      enddo

      if ( lats .ne. jm ) then
         print *, "Decomp: big trouble sum(ydist) = ", lats, "!=", jm
      endif

      yfirst(1) = 1
      ylast(1) = ydist(1)
      zfirst(1) = 1
      zlast(1) = km

      do p = 1,nprocs-1
         yfirst(p+1) = ylast(p) + 1
         ylast(p+1) = ylast(p) + ydist(p+1)
         zfirst(p+1) = 1
         zlast(p+1) = km
      enddo

      end subroutine set_decomp

!-----
      subroutine mp_send4d_ns(im, jm, jfirst, jlast, kfirst, klast, &
                              nq, ng_s, ng_n, q)
!-----
      implicit none
      integer im, jm
      integer jfirst, jlast
      integer kfirst, klast
      integer nq
      integer ng_s      ! southern zones to ghost 
      integer ng_n      ! noruthern zones to ghost 
      real q(im,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq)
! Local:
      integer iq        ! Counter
      integer i, j, 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)
      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)
        src = gid - 1
        recv_tag = src
        qsize = im*ng_s*(klast-kfirst+1)*nq
        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*ng_n*(klast-kfirst+1)*nq
        tdisp = igosouth*idimsize + (ncall_s-1)*idimsize*nbuf
        call BufferPack4d(q, 1, im, jfirst-ng_s, jlast+ng_n, &
                             kfirst, klast, 1, nq, &
                             1, im, jfirst, jfirst+ng_n-1, &
                             kfirst, klast, 1 , nq, &
                             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
      endif
! Send to north
      if ( jlast < jm ) then
#if !defined(MPI2)
        src = gid + 1
        recv_tag = src
        qsize = im*ng_n*(klast-kfirst+1)*nq
        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*ng_s*(klast-kfirst+1)*nq
        tdisp = igonorth*idimsize + (ncall_s-1)*idimsize*nbuf
        call BufferPack4d(q, 1, im, jfirst-ng_s, jlast+ng_n, &
                             kfirst, klast, 1, nq, &
                             1, im, jlast-ng_s+1, jlast, &
                             kfirst, klast, 1, nq, &
                             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
      endif
#else
#include "mlp_ptr.h"
      do iq=1,nq
!$omp parallel do private(i,j,k)
      do k=kfirst,klast
         if ( jfirst > 1 ) then
! Send to south
            do j=jfirst,jfirst+ng_n-1
               do i=1,im
                  g_4d(i,j,k,iq) = q(i,j,k,iq)
               enddo
            enddo
         endif
         if ( jlast < jm ) then
! Send to north
            do j=jlast-ng_s+1,jlast
               do i=1,im
                  g_4d(i,j,k,iq) = q(i,j,k,iq)
               enddo
            enddo
         endif
      enddo
      enddo
#endif
      end subroutine mp_send4d_ns
 
!-----
      subroutine mp_recv4d_ns(im, jm, jfirst, jlast, kfirst, klast, &
                              nq, ng_s, ng_n, q)
!-----
      implicit none
      integer im, jm
      integer jfirst, jlast
      integer kfirst, klast
      integer nq
      integer ng_s      ! southern zones to ghost 
      integer ng_n      ! noruthern zones to ghost 
      real q(im,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq)
! Local:
      integer iq        ! Counter
      integer i, j, k

#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
        tdisp = igonorth*idimsize + (ncall_r-1)*idimsize*nbuf
        call BufferUnPack4d(q, 1, im, jfirst-ng_s, jlast+ng_n, &
                               kfirst, klast, 1, nq, &
                               1, im, jfirst-ng_s, jfirst-1, &
                               kfirst, klast, 1, nq, &
                               buff_r(tdisp+1))
      endif
! Recv from north
      if ( jlast < jm ) then
#if !defined(MPI2)
        nread = nread + 1
        call mpi_wait(rqest(nread), Status, ierror)
#endif
        tdisp = igosouth*idimsize + (ncall_r-1)*idimsize*nbuf
        call BufferUnPack4d(q, 1, im, jfirst-ng_s, jlast+ng_n, &
                               kfirst, klast, 1, nq, &
                               1, im, jlast+1, jlast+ng_n, &
                               kfirst, klast, 1, nq, &
                               buff_r(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"
      do iq=1,nq

!$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,iq) = 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,iq) = g_4d(i,j,k,iq)
               enddo
            enddo
         endif
      enddo
      enddo
#endif
      end subroutine mp_recv4d_ns

!-----
      subroutine mp_send3d_ns(im, jm, jfirst, jlast, kfirst, klast, & 
                              ng_s, ng_n, q, iq)
!-----
      implicit none
      integer im, jm
      integer jfirst, jlast
      integer kfirst, klast
      integer ng_s      ! southern zones to ghost 
      integer ng_n      ! noruthern zones to ghost 
      real q(im,jfirst-ng_s:jlast+ng_n,kfirst:klast)
      integer iq
! Local:
      integer i,j,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)
      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)
        src = gid - 1
        recv_tag = src
        qsize = im*ng_s*(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*ng_n*(klast-kfirst+1)
        tdisp = igosouth*idimsize + (ncall_s-1)*idimsize*nbuf 
        call BufferPack3d(q, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                             1, im, jfirst, jfirst+ng_n-1, 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
      endif
! Send to north
      if ( jlast < jm ) then
#if !defined(MPI2)
        src = gid + 1
        recv_tag = src
        qsize = im*ng_n*(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*ng_s*(klast-kfirst+1)
        tdisp = igonorth*idimsize + (ncall_s-1)*idimsize*nbuf 
        call BufferPack3d(q, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                             1, im, jlast-ng_s+1, jlast, 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
      endif
#else
#include "mlp_ptr.h"
!$omp parallel do private(i,j,k)
      do k=kfirst,klast
         if ( jfirst > 1 ) then
! Send to south
            do j=jfirst,jfirst+ng_n-1
               do i=1,im
                  g_4d(i,j,k,iq) = q(i,j,k)
               enddo
            enddo
         endif
         if ( jlast < jm ) then
! Send to north
            do j=jlast-ng_s+1,jlast
               do i=1,im
                  g_4d(i,j,k,iq) = q(i,j,k)
               enddo
            enddo
         endif
      enddo
#endif
      end subroutine mp_send3d_ns
 
!-----
      subroutine mp_recv3d_ns(im, jm, jfirst, jlast, kfirst, klast, &
                              ng_s, ng_n, q, iq)
!-----
      implicit none
      integer im, jm
      integer jfirst, jlast
      integer kfirst, klast
      integer ng_s      ! southern zones to ghost 
      integer ng_n      ! noruthern zones to ghost 
      integer iq        ! Counter
      real q(im,jfirst-ng_s:jlast+ng_n,kfirst:klast)

! Local:
      integer i,j,k
      integer src
      integer recv_tag

#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
        tdisp = igonorth*idimsize + (ncall_r-1)*idimsize*nbuf
        call BufferUnPack3d(q, 1, im, jfirst-ng_s, jlast+ng_n, kfirst, klast, &
                               1, im, jfirst-ng_s, jfirst-1,   kfirst, klast, &
                               buff_r(tdisp+1))
      endif
! Recv from north
      if ( jlast < jm ) then
#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-ng_s, jlast+ng_n, kfirst, klast, &
                               1, im, jlast+1,     jlast+ng_n, kfirst, klast, &
                               buff_r(tdisp+1))