#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   returnend subroutine realloc6