scan2.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

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

subroutine scan2 (ztodt, cwava, etamid)

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Second gaussian latitude scan, converts from spectral coefficients to 
! grid point values, from poles to equator, with read/calculate/write cycle.
! 
! Method: 
! The latitude pair loop in this routine is multitasked.
!
! The grid point values of ps, t, u, v, z (vorticity), and d (divergence)
! are calculated and stored for each latitude from the spectral coefficients.
! In addition, the pressure-surface corrections to the horizontal diffusion
! are applied and the global integrals of the constituent fields are 
! computed for the mass fixer.
!
! Author: 
! Original version:  CCM1
!
!-----------------------------------------------------------------------
!
! $Id: scan2.F90,v 1.11 2001/10/19 17:50:35 eaton Exp $
! $Author: eaton $
!
!-----------------------------------------------------------------------

   use precision
   use pmgrid
   use comslt
   use prognostics
   use rgrid
   use mpishorthand
   use physconst, only: cpair
   use tracers,   only: ixcldw
!-----------------------------------------------------------------------
   implicit none
!------------------------------Commons----------------------------------
#include <comqfl.h>
!-----------------------------------------------------------------------
#include <comctl.h>
!-----------------------------------------------------------------------
!
! Input arguments
!
   real(r8), intent(in) :: ztodt                ! twice the timestep unless nstep = 0
   real(r8), intent(in) :: cwava(plat)          ! weight applied to global integrals
   real(r8), intent(in) :: etamid(plev)         ! vertical coords at midpoints 
!
!---------------------------Local workspace-----------------------------
!
   real(r8) engy1         ! component of global energy integral (for time step n)
   real(r8) engy2         ! component of global energy integral (for time step n+1)
   real(r8) engy2a        ! component of global energy integral (for time step n+1)
   real(r8) engy2b        ! component of global energy integral (for time step n+1)
   real(r8) difft         ! component of global delta-temp integral ( (n+1) - n )
   real(r8) diffta        ! component of global delta-temp integral ( (n+1) - n )
   real(r8) difftb        ! component of global delta-temp integral ( (n+1) - n )
   real(r8) hw2a(pcnst)   ! component of constituent global mass integral (mass weighting is 
                          ! based upon the "A" portion of the hybrid grid)
   real(r8) hw2b(pcnst)   ! component of constituent global mass integral (mass weighting is 
                          ! based upon the "B" portion of the hybrid grid)
   real(r8) hw3a(pcnst)   ! component of constituent global mass integral (mass weighting is 
                          ! based upon the "A" portion of the hybrid grid)
   real(r8) hw3b(pcnst)   ! component of constituent global mass integral (mass weighting is 
                          ! based upon the "B" portion of the hybrid grid)
   real(r8) hwxa(pcnst,4)
   real(r8) hwxb(pcnst,4)
   real(r8) engy2alat(plat)     ! lat contribution to total energy integral
   real(r8) engy2blat(plat)     ! lat contribution to total energy integral
   real(r8) difftalat(plat)     ! lat contribution to delta-temperature integral
   real(r8) difftblat(plat)     ! lat contribution to delta-temperature integral
   real(r8) hw2al(pcnst,plat)   ! |------------------------------------
   real(r8) hw2bl(pcnst,plat)   ! |
   real(r8) hw3al(pcnst,plat)   ! | latitudinal contributions to the
   real(r8) hw3bl(pcnst,plat)   ! | components of global mass integrals
   real(r8) hwxal(pcnst,4,plat) ! |
   real(r8) hwxbl(pcnst,4,plat) ! |-----------------------------------
!                                
! 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) grpss(plond,begirow:endirow)       ! sum(n) of lnps(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)

   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) 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) grqs(plond,plev,begirow:endirow)
   real(r8) grtms(plond,plev,begirow:endirow)
   real(r8) grtls(plond,plev,begirow:endirow)
   real(r8) grqms(plond,plev,begirow:endirow)
   real(r8) grqls(plond,plev,begirow:endirow)
!
! 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) grpsa(plond,begirow:endirow)       ! sum(n) of lnps(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)
   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) 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) grqa(plond,plev,begirow:endirow)
   real(r8) grtma(plond,plev,begirow:endirow)
   real(r8) grtla(plond,plev,begirow:endirow)
   real(r8) grqma(plond,plev,begirow:endirow)
   real(r8) grqla(plond,plev,begirow:endirow)
   real(r8) residual                           ! residual energy integral
   real(r8) beta                               ! energy fixer coefficient

   integer m,n, irow                           ! indices
   integer lat,j                               ! latitude indices
   integer endi                                ! index
!
!-----------------------------------------------------------------------
!
   call t_startf ('grcalc')

#if ( defined SPMD )

!$OMP PARALLEL DO PRIVATE (J)

   do j=begirow,endirow
      call grcalcs (j, ztodt, grts(1,1,j), grqs(1,1,j), grths(1,1,j), &
                    grds(1,1,j), grus(1,1,j), gruhs(1,1,j), grvs(1,1,j), grvhs(1,1,j), &
                    grpss(1,j), grdpss(1,j), grpms(1,j), grpls(1,j), grtms(1,1,j), &
                    grtls(1,1,j), grqms(1,1,j), grqls(1,1,j))

      call grcalca (j, ztodt, grta(1,1,j), grqa(1,1,j), grtha(1,1,j), &
                    grda(1,1,j), grua(1,1,j), gruha(1,1,j), grva(1,1,j), grvha(1,1,j), &
                    grpsa(1,j), grdpsa(1,j), grpma(1,j), grpla(1,j), grtma(1,1,j), &
                    grtla(1,1,j), grqma(1,1,j), grqla(1,1,j))
   end do

#else

!$OMP PARALLEL DO PRIVATE (LAT, J)

   do lat=beglat,endlat
      if (lat > plat/2) then
         j = plat - lat + 1
         call grcalcs (j, ztodt, grts(1,1,j), grqs(1,1,j), grths(1,1,j), &
                       grds(1,1,j), grus(1,1,j), gruhs(1,1,j), grvs(1,1,j), grvhs(1,1,j), &
                       grpss(1,j), grdpss(1,j), grpms(1,j), grpls(1,j), grtms(1,1,j), &
                       grtls(1,1,j), grqms(1,1,j), grqls(1,1,j))

      else
         j = lat
         call grcalca (j, ztodt, grta(1,1,j), grqa(1,1,j), grtha(1,1,j), &
                       grda(1,1,j), grua(1,1,j), gruha(1,1,j), grva(1,1,j), grvha(1,1,j), &
                       grpsa(1,j), grdpsa(1,j), grpma(1,j), grpla(1,j), grtma(1,1,j), &
                       grtla(1,1,j), grqma(1,1,j), grqla(1,1,j))
      end if
   end do

#endif

   call t_stopf ('grcalc')

!#if ( defined SPMD )
!   call t_startf ('exchange')
!   call 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)
!   call t_stopf ('exchange')
!#endif

   call t_startf('spegrd')

!$OMP PARALLEL DO PRIVATE (LAT, J, IROW)

   do lat=beglat,endlat
      j = j1 - 1 + lat
      irow = lat
      if (lat > plat/2) irow = plat - lat + 1
      call spegrd (ztodt, lat, cwava(lat), qfcst(i1,1,1,lat), q3(i1,1,1,j,n3), &
                   etamid, ps(1,lat,n3m1), u3(i1,1,j,n3m1), v3(i1,1,j,n3m1), t3(i1,1,j,n3m1), &
                   div(1,1,lat,n3m1), hw2al(1,lat), hw2bl(1,lat), hw3al(1,lat), hw3bl(1,lat), &
                   hwxal(1,1,lat), hwxbl(1,1,lat), grts(1,1,irow), grqs(1,1,irow), grths(1,1,irow), &
                   grds(1,1,irow), grus(1,1,irow), gruhs(1,1,irow), grvs(1,1,irow), grvhs(1,1,irow), &
                   grpss(1,irow), grdpss(1,irow), grpms(1,irow), grpls(1,irow), grtms(1,1,irow), &
                   grtls(1,1,irow), grqms(1,1,irow), grqls(1,1,irow), grta(1,1,irow), grqa(1,1,irow), &
                   grtha(1,1,irow), grda(1,1,irow), grua(1,1,irow), gruha(1,1,irow), grva(1,1,irow), &
                   grvha(1,1,irow), grpsa(1,irow), grdpsa(1,irow), grpma(1,irow), grpla(1,irow), &
                   grtma(1,1,irow), grtla(1,1,irow), grqma(1,1,irow), grqla(1,1,irow), dps(1,lat), &
                   dpsl(1,lat), dpsm(1,lat), tl(1,1,lat), tm(1,1,lat), ql(1,1,lat), &
                   qm(1,1,lat), t3(i1,1,j,n3) ,engy2alat(lat), engy2blat(lat), &
                   difftalat(lat), difftblat(lat), phis(1,lat), nlon(lat) )
   end do

   call t_stopf('spegrd')

#ifdef SPMD
#ifdef TIMING_BARRIERS
   call t_startf ('sync_realloc5')
   call mpibarrier (mpicom)
   call t_stopf ('sync_realloc5')
#endif
   call t_startf('realloc5')
   call realloc5 (hw2al   ,hw2bl   ,hw3al   ,hw3bl   ,tmass    , &
                  hw1lat  ,hwxal   ,hwxbl   ,engy1lat,engy2alat, &
                  engy2blat, difftalat, difftblat)
   call t_stopf('realloc5')
#endif

!
! Accumulate and normalize global integrals for mass fixer (dry mass of
! atmosphere is held constant).
!
   call t_startf ('scan2_single')
   tmassf = 0.
   do lat=1,plat
      tmassf = tmassf + tmass(lat)
   end do
   tmassf = tmassf*.5
!