scan2.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

      hw2 (m) = hw2a(m) + fixmas*hw2b(m)
      hw3 (m) = hw3a(m) + fixmas*hw3b(m)
      if(hw3(m) .ne. 0.) then
         alpha(m)  = ( hw1(m) - hw2(m) )/hw3(m)
      else
         alpha(m)  = 1.
      end if
   end do

   call t_stopf ('scan2_single')

   call t_startf ('tfilt_massfix')

!$OMP PARALLEL DO PRIVATE (LAT,J)

   do lat=beglat,endlat
      j = j1 - 1 + lat
      call tfilt_massfix (ztodt,       lat, u3(i1,1,j,n3m1),u3(i1,1,j,n3), &
                          v3(i1,1,j,n3m1), v3(i1,1,j,n3), t3(i1,1,j,n3m1), t3(i1,1,j,n3), &
                             q3(i1,1,1,j,n3m1), &
                          q3(i1,1,1,j,n3), ps(1,lat,n3m1), ps(1,lat,n3), alpha, &
                          etamid, qfcst(i1,1,1,lat), vort(1,1,lat,n3), div(1,1,lat,n3), &
                             vort(1,1,lat,n3m2), &
                          div(1,1,lat,n3m2), qminus(i1,1,1,j), ps(1,lat,n3m2), &
                             u3(i1,1,j,n3m2), &
                          v3(i1,1,j,n3m2), t3(i1,1,j,n3m2), q3(i1,1,1,j,n3m2), vort(1,1,lat,n3m1), &
                             div(1,1,lat,n3m1), &
                          omga(1,1,lat), dpsl(1,lat), dpsm(1,lat), nlon(lat))
                          
   end do
   call t_stopf ('tfilt_massfix')
!
! Shift time pointers
!
   call shift_time_indices ()

   return
end subroutine scan2

#ifdef SPMD
subroutine exchange (grdpss, grzs, grds, gruhs, grvhs, &
                     grths, grpss, grus, grvs, grts, &
                     grpls, grpms, &
                     grdpsa, grza, grda, gruha, grvha, &
                     grtha, grpsa, grua, grva, grta, &
                     grpla, grpma)
!-----------------------------------------------------------------------
   use precision
   use pmgrid
   use mpishorthand
   use spmd_dyn, only: cut, npes
!-----------------------------------------------------------------------
   implicit none
!------------------------------Parameters-------------------------------
   integer msgid
   parameter (msgid = 4000)
!-----------------------------------------------------------------------
! Arguments
!                                
! Symmetric fourier coefficient arrays for all variables transformed 
! from spherical harmonics (see subroutine grcalc)
!                                
   real(r8) grdpss(plond,begirow:endirow)      ! sum(n) of K(4)*(n(n+1)/a**2)**2*2dt*lnps(n,m)*P(n,m)
   real(r8) grzs(plond,plev,begirow:endirow)   ! sum(n) of z(n,m)*P(n,m) 
   real(r8) grds(plond,plev,begirow:endirow)   ! sum(n) of d(n,m)*P(n,m)
   real(r8) gruhs(plond,plev,begirow:endirow)  ! sum(n) of K(2i)*z(n,m)*H(n,m)*a/(n(n+1))
   real(r8) grvhs(plond,plev,begirow:endirow)  ! sum(n) of K(2i)*d(n,m)*H(n,m)*a/(n(n+1))
   real(r8) grths(plond,plev,begirow:endirow)  ! sum(n) of K(2i)*t(n,m)*P(n,m)
   real(r8) grpss(plond,begirow:endirow)       ! sum(n) of lnps(n,m)*P(n,m)
   real(r8) grus(plond,plev,begirow:endirow)   ! sum(n) of z(n,m)*H(n,m)*a/(n(n+1))
   real(r8) grvs(plond,plev,begirow:endirow)   ! sum(n) of d(n,m)*H(n,m)*a/(n(n+1))
   real(r8) grts(plond,plev,begirow:endirow)   ! sum(n) of t(n,m)*P(n,m)
   real(r8) grpls(plond,begirow:endirow)       ! sum(n) of lnps(n,m)*P(n,m)*m/a
   real(r8) grpms(plond,begirow:endirow)       ! sum(n) of lnps(n,m)*H(n,m)
!
! Antisymmetric fourier coefficient arrays for all variables transformed
! from spherical harmonics (see grcalc)
!
   real(r8) grdpsa(plond,begirow:endirow)      ! sum(n) of K(4)*(n(n+1)/a**2)**2*2dt*lnps(n,m)*P(n,m)
   real(r8) grza(plond,plev,begirow:endirow)   ! sum(n) of z(n,m)*P(n,m)
   real(r8) grda(plond,plev,begirow:endirow)   ! sum(n) of d(n,m)*P(n,m)
   real(r8) gruha(plond,plev,begirow:endirow)  ! sum(n)K(2i)*z(n,m)*H(n,m)*a/(n(n+1))
   real(r8) grvha(plond,plev,begirow:endirow)  ! sum(n)K(2i)*d(n,m)*H(n,m)*a/(n(n+1))
   real(r8) grtha(plond,plev,begirow:endirow)  ! sum(n) of K(2i)*t(n,m)*P(n,m)
   real(r8) grpsa(plond,begirow:endirow)       ! sum(n) of lnps(n,m)*P(n,m)
   real(r8) grua(plond,plev,begirow:endirow)   ! sum(n) of z(n,m)*H(n,m)*a/(n(n+1))
   real(r8) grva(plond,plev,begirow:endirow)   ! sum(n) of d(n,m)*H(n,m)*a/(n(n+1))
   real(r8) grta(plond,plev,begirow:endirow)   ! sum(n) of t(n,m)*P(n,m)
   real(r8) grpla(plond,begirow:endirow)       ! sum(n) of lnps(n,m)*P(n,m)*m/a
   real(r8) grpma(plond,begirow:endirow)       ! sum(n) of lnps(n,m)*H(n,m)
!
! Local workspace
!
   integer procid

   procid = npes - iam - 1

   if (cut(2,iam) > plat/2) then

      call mpisendrecv (grdpss, plond*numlats, mpir8, procid, msgid, &
                        grdpsa, plond*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grzs, plndlv*numlats, mpir8, procid, msgid, &
                        grza, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grds, plndlv*numlats, mpir8, procid, msgid, &
                        grda, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (gruhs, plndlv*numlats, mpir8, procid, msgid, &
                        gruha, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grvhs, plndlv*numlats, mpir8, procid, msgid, &
                        grvha, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grths, plndlv*numlats, mpir8, procid, msgid, &
                        grtha, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grpss, plond*numlats, mpir8, procid, msgid, &
                        grpsa, plond*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grus, plndlv*numlats, mpir8, procid, msgid, &
                        grua, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grvs, plndlv*numlats, mpir8, procid, msgid, &
                        grva, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grts, plndlv*numlats, mpir8, procid, msgid, &
                        grta, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grpls, plond*numlats, mpir8, procid, msgid, &
                        grpla, plond*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grpms, plond*numlats, mpir8, procid, msgid, &
                        grpma, plond*numlats, mpir8, procid, msgid, mpicom)

   else

      call mpisendrecv (grdpsa, plond*numlats, mpir8, procid, msgid, &
                        grdpss, plond*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grza, plndlv*numlats, mpir8, procid, msgid, &
                        grzs, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grda, plndlv*numlats, mpir8, procid, msgid, &
                        grds, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (gruha, plndlv*numlats, mpir8, procid, msgid, &
                        gruhs, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grvha, plndlv*numlats, mpir8, procid, msgid, &
                        grvhs, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grtha, plndlv*numlats, mpir8, procid, msgid, &
                        grths, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grpsa, plond*numlats, mpir8, procid, msgid, &
                        grpss, plond*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grua, plndlv*numlats, mpir8, procid, msgid, &
                        grus, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grva, plndlv*numlats, mpir8, procid, msgid, &
                        grvs, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grta, plndlv*numlats, mpir8, procid, msgid, &
                        grts, plndlv*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grpla, plond*numlats, mpir8, procid, msgid, &
                        grpls, plond*numlats, mpir8, procid, msgid, mpicom)
      call mpisendrecv (grpma, plond*numlats, mpir8, procid, msgid, &
                        grpms, plond*numlats, mpir8, procid, msgid, mpicom)

   end if
   return
end subroutine exchange

subroutine realloc5 (hw2al   ,hw2bl   ,hw3al   ,hw3bl   ,tmass   , &
                     hw1lat  ,hwxal   ,hwxbl   )
!-----------------------------------------------------------------------
!
! Reallocation routine for slt variables.
!
!---------------------------Code history--------------------------------
!
! Original version:  J. Rosinski
! Standardized:      J. Rosinski, Oct 1995
!                    J. Truesdale, Feb. 1996
! Reviewed:
!
!
! $Id: scan2.F90,v 1.10 2001/10/19 17:50:32 eaton Exp $
! $Author: eaton $
!
!-----------------------------------------------------------------------
   use precision
   use pmgrid
   use pspect
   use spmd_dyn
   use prognostics
   use mpishorthand
!-----------------------------------------------------------------------
   implicit none
!---------------------------------Parameters----------------------------------
   integer nelempl           ! number of elements per lat in the buffer
   integer msgtype
   parameter (nelempl=5*pcnst + 1)
   parameter (msgtype = 5000)
!---------------------------------Commons-------------------------------------
#include <comsta.h>
!-----------------------------------------------------------------------
!
! Input arguments
!
   real(r8), intent(in) :: hw2al(pcnst,plat)
   real(r8), intent(in) :: hw2bl(pcnst,plat)
   real(r8), intent(in) :: hw3al(pcnst,plat)
   real(r8), intent(in) :: hw3bl(pcnst,plat)
   real(r8), intent(in) :: tmass (plat)
   real(r8), intent(in) :: hw1lat(pcnst,plat)
   real(r8), intent(in) :: hwxal(pcnst,4,plat)
   real(r8), intent(in) :: hwxbl(pcnst,4,plat)
!
!---------------------------Local workspace-----------------------------
!
   integer len
   integer procid              ! Processor id
   integer bpos
   integer procj
   integer len_p,beglat_p,numlats_p
!
! gather global data
!
   len = numlats*pcnst
   do procj=1,ceil2(npes)-1
      procid = pair(npes,procj,iam)
      if (procid.ge.0) then
         bpos = 0
         call mpipack (len,1,mpiint,buf1,bsiz,bpos,mpicom)
         call mpipack (beglat,1,mpiint,buf1,bsiz,bpos,mpicom)
         call mpipack (numlats,1,mpiint,buf1,bsiz,bpos,mpicom)

         call mpipack (tmass(beglat),numlats,mpir8,buf1,bsiz,bpos,mpicom)

         call mpipack (hw1lat(1,beglat),len,mpir8,buf1,bsiz,bpos,mpicom)
         call mpipack (hw2al(1,beglat),len,mpir8,buf1,bsiz,bpos,mpicom)
         call mpipack (hw2bl(1,beglat),len,mpir8,buf1,bsiz,bpos,mpicom)
         call mpipack (hw3al(1,beglat),len,mpir8,buf1,bsiz,bpos,mpicom)
         call mpipack (hw3bl(1,beglat),len,mpir8,buf1,bsiz,bpos,mpicom)

         call mpipack (hwxal(1,1,beglat),len*4,mpir8,buf1,bsiz,bpos,mpicom)
         call mpipack (hwxbl(1,1,beglat),len*4,mpir8,buf1,bsiz,bpos,mpicom)

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

         bpos = 0
         call mpiunpack (buf2,bsiz,bpos,len_p,1,mpiint,mpicom)
         call mpiunpack (buf2,bsiz,bpos,beglat_p,1,mpiint,mpicom)
         call mpiunpack (buf2,bsiz,bpos,numlats_p,1,mpiint,mpicom)

         call mpiunpack (buf2,bsiz,bpos,tmass(beglat_p),numlats_p,mpir8,mpicom)

         call mpiunpack (buf2,bsiz,bpos,hw1lat(1,beglat_p),len_p,mpir8,mpicom)
         call mpiunpack (buf2,bsiz,bpos,hw2al(1,beglat_p),len_p,mpir8,mpicom)
         call mpiunpack (buf2,bsiz,bpos,hw2bl(1,beglat_p),len_p,mpir8,mpicom)
         call mpiunpack (buf2,bsiz,bpos,hw3al(1,beglat_p),len_p,mpir8,mpicom)
         call mpiunpack (buf2,bsiz,bpos,hw3bl(1,beglat_p),len_p,mpir8,mpicom)

         call mpiunpack (buf2,bsiz,bpos,hwxal(1,1,beglat_p),len_p*4,mpir8,mpicom)
         call mpiunpack (buf2,bsiz,bpos,hwxbl(1,1,beglat_p),len_p*4,mpir8,mpicom)
      end if
!JR         call mpibarrier(mpicom)
   end do

   return
end subroutine realloc5
#endif