realloc6.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

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

subroutine realloc6

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Reallocation routine for spectral prognostics.
! 
! Method: 
! 
! Author: 
! Original version:  J. Rosinski
! Standardized:      J. Rosinski, Oct 1995
!                    J. Truesdale, Feb. 1996
! Reviewed:
! 
!-----------------------------------------------------------------------
!
! $Id: realloc6.F90,v 1.3 2001/10/10 00:05:43 rosinski Exp $
! $Author: rosinski $
!
!----------------------------------------------------------------------------

#ifdef SPMD

   use precision
   use pmgrid
   use pspect
   use comspe
   use spmd_dyn
   use mpishorthand
!----------------------------------------------------------------------------
   implicit none
!---------------------------Local workspace-----------------------------
!
   integer m,k
   integer mstrt,length
   integer mask,procid
   integer length_p,mstrt_p
   integer bpos
   integer mb,me
   integer, parameter :: msgtype = 1001
!
!----------------------------------------------------------------------------
!
! Spectral processors ship their "m" values
!
   if(iam.le.npessp-1) then
      mb = begm(iam)
      me = endm(iam)
      mstrt = 2*nstart(mb)+1
      length = 2*nstart(me)-2*nstart(mb)+2*nlen(me)
   else
      mstrt = 2*psp
      length = 0
   endif
   mask = 1

   do while (mask.lt.ceil2(npes))
      procid = pair(npes,iam,mask)
      if (procid.ge.0) then
         bpos = 0
         call mpipack (length,1,mpiint,buf1,bsiz,bpos,mpicom)
         call mpipack (mstrt,1,mpiint,buf1,bsiz,bpos,mpicom)
         if (length.gt.0) then
            call mpipack (alps(mstrt),length,mpir8,buf1,bsiz,bpos,mpicom)
            do k=1,plev
               call mpipack (t(mstrt,k),length,mpir8,buf1,bsiz,bpos,mpicom)
               call mpipack (d(mstrt,k),length,mpir8,buf1,bsiz,bpos,mpicom)
               call mpipack (vz(mstrt,k),length,mpir8,buf1,bsiz,bpos,mpicom)
            enddo
         endif

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

         bpos = 0
         call mpiunpack (buf2,bsiz,bpos,length_p,1,mpiint,mpicom)
         call mpiunpack (buf2,bsiz,bpos,mstrt_p,1,mpiint,mpicom)
         if (length_p.gt.0) then
            call mpiunpack (buf2,bsiz,bpos,alps(mstrt_p),length_p,mpir8,mpicom)
            do k=1,plev
               call mpiunpack (buf2,bsiz,bpos,t(mstrt_p,k),length_p,mpir8,mpicom)
               call mpiunpack (buf2,bsiz,bpos,d(mstrt_p,k),length_p,mpir8,mpicom)
               call mpiunpack (buf2,bsiz,bpos,vz(mstrt_p,k),length_p,mpir8,mpicom)
            enddo
         endif
      endif

      if (npes.eq.ceil2(npes)) then
         mstrt = min(mstrt,mstrt_p)
         length = length+length_p
         mask = mask*2
      else
         mask = mask+1
      endif
!JR         call barrier(mpicom)
   end do
#endif
   return
end subroutine realloc6