!-----      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#elseXXXXXXXXXXXXXXXXXXXXXXXXXX  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         enddoXXXXXXXXXXXXXXXXXXXXXXXXXX  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 = (