realloc4.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

#include <misc.h> 
#include <params.h>

subroutine realloc4(grlps1  ,grt1    ,grz1    ,grd1    ,grfu1   , &
                    grfv1   ,grut1   ,grvt1   ,grrh1   ,grlps2  , &
                    grt2    ,grz2    ,grd2    ,grfu2   ,grfv2   , &
                    grut2   ,grvt2   ,grrh2   )

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Reallocation routine for the Fourier coefficients
! 
! Method: 
! 
! Author: 
! Original version:  J. Rosinski
! Standardized:      J. Rosinski, Oct 1995
!                    J. Truesdale, Feb. 1996
! Reviewed:
! 
!-----------------------------------------------------------------------
!
! $Id: realloc4.F90,v 1.3 2001/02/15 02:23:21 rosinski Exp $
! $Author: rosinski $
!
!-----------------------------------------------------------------------

#ifdef SPMD

   use precision
   use pmgrid
   use pspect
   use comspe
   use spmd_dyn
   use mpishorthand
!-----------------------------------------------------------------------
   implicit none
!-----------------------------------------------------------------------
#include <comsta.h>
!------------------------------Parameters-------------------------------
!
  integer, parameter :: msgtype  = 1000
!---------------------------Input arguments--------------------------
!
   real(r8), intent(in) :: grlps1(2*pmmax,plat/2)      ! ----------------------------
   real(r8), intent(in) :: grt1(plev,2*pmmax,plat/2)   ! |
   real(r8), intent(in) :: grz1(plev,2*pmmax,plat/2)   ! |
   real(r8), intent(in) :: grd1(plev,2*pmmax,plat/2)   ! |
   real(r8), intent(in) :: grfu1(plev,2*pmmax,plat/2)  ! |
   real(r8), intent(in) :: grfv1(plev,2*pmmax,plat/2)  ! |
   real(r8), intent(in) :: grut1(plev,2*pmmax,plat/2)  ! |
   real(r8), intent(in) :: grvt1(plev,2*pmmax,plat/2)  ! |
   real(r8), intent(in) :: grrh1(plev,2*pmmax,plat/2)  ! |- see linems and quad for
   real(r8), intent(in) :: grlps2(2*pmmax,plat/2)      ! |  definitions: these variables are
   real(r8), intent(in) :: grt2(plev,2*pmmax,plat/2)   ! |  declared here for data scoping
   real(r8), intent(in) :: grz2(plev,2*pmmax,plat/2)   ! |
   real(r8), intent(in) :: grd2(plev,2*pmmax,plat/2)   ! |
   real(r8), intent(in) :: grfu2(plev,2*pmmax,plat/2)  ! |
   real(r8), intent(in) :: grfv2(plev,2*pmmax,plat/2)  ! |
   real(r8), intent(in) :: grut2(plev,2*pmmax,plat/2)  ! |
   real(r8), intent(in) :: grvt2(plev,2*pmmax,plat/2)  ! |
   real(r8), intent(in) :: grrh2(plev,2*pmmax,plat/2)  ! ----------------------------
!
!---------------------------Local workspace-----------------------------
!
   integer procid,length,j,mstrt,j_p
   integer length_p,mstrt_p
   integer bpos
   integer procj
   integer begirow_p,endirow_p
   integer num
!     
!     Send gr..1 "m" values to processor(s) owning that wavenumber
!     
   length_p = 2*numm(iam)
   mstrt_p = 2*begm(iam)-1

   do procj=1,ceil2(npes)-1
      procid = pair(npes,procj,iam)
      length = 2*numm(procid)
      mstrt = 2*begm(procid)-1

      if (length > 0 .and. length_p > 0 .and. procid >= 0) then
         bpos = 0
         call mpipack (begirow,1,mpiint,buf1,bsiz,bpos,mpicom)
         call mpipack (endirow,1,mpiint,buf1,bsiz,bpos,mpicom)

         do j=begirow,endirow
            call mpipack (grlps1(mstrt,j),length,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grlps2(mstrt,j),length,mpir8,buf1,bsiz,bpos,mpicom)

            num = length*plev
            call mpipack (grt1(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grz1(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grd1(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grfu1(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grfv1(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grut1(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grvt1(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grrh1(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grt2(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grz2(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grd2(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grfu2(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grfv2(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grut2(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grvt2(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
            call mpipack (grrh2(1,mstrt,j),num,mpir8,buf1,bsiz,bpos,mpicom)
         end do

         call mpisendrecv (buf1,bpos,mpi_packed,procid,msgtype, &
                           buf2,bsiz,mpi_packed,procid,msgtype,mpicom)

         bpos = 0
         call mpiunpack (buf2,bsiz,bpos,begirow_p,1,mpiint,mpicom)
         call mpiunpack (buf2,bsiz,bpos,endirow_p,1,mpiint,mpicom)
         do j_p=begirow_p,endirow_p
            call mpiunpack (buf2,bsiz,bpos,grlps1(mstrt_p,j_p),length_p,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grlps2(mstrt_p,j_p),length_p,mpir8,mpicom)

            num = length_p*plev
            call mpiunpack (buf2,bsiz,bpos,grt1(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grz1(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grd1(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grfu1(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grfv1(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grut1(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grvt1(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grrh1(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grt2(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grz2(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grd2(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grfu2(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grfv2(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grut2(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grvt2(1,mstrt_p,j_p),num,mpir8,mpicom)
            call mpiunpack (buf2,bsiz,bpos,grrh2(1,mstrt_p,j_p),num,mpir8,mpicom)
         end do
      end if
!JR        call barrier (mpicom)
   end do

#endif
   return
end subroutine realloc4