scanslt.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

               zb      ,nlon    )
  do m = 1,pcnst
     call sltint (plev    ,pcnst+pnats,jcen    ,q3(1,1,m,beglatex,n3),lam     , &
                  rdphi   ,rdz     ,lbasdy  ,lbasdz  ,xl      , &
                  xr      ,wgt1x   ,wgt2x   ,wgt3x   ,wgt4x   , &
                  hl      ,hr      ,dhl     ,dhr     ,ys      , &
                  yn      ,wgt1y   ,wgt2y   ,wgt3y   ,wgt4y   , &
                  hs      ,hn      ,dhs     ,dhn     ,wgt1z   , &
                  wgt2z   ,wgt3z   ,wgt4z   ,hb      ,ht      , &
                  dhb     ,dht     ,idp     ,jdp     ,kdp     , &
                  kkdp    ,lhrzint ,lvrtint ,limdrh  ,limdrv  , &
                  fdp(1,1,1),nlon  )
!
! Pass q-interpolants into 3-D array
!
     do k = 1,plev
        do i = 1,nlon
           qfcst(i1-1+i,k,m,lat) = fdp(i,k,1)
        end do
        if(m .eq. 1) then
           do i = 1,nlon
              grqlat(i,k) = fdp(i,k,1)
           end do
        endif
     end do
  end do
!
! Accumulate P-interpolants into T equation
!
  do i = 1,nlon
     grpslat(i) = 0.
     pasum  (i) = 0.
     pa     (i) = 0.
  end do
  do k = 1,plev
     do i = 1,nlon
        grtlat(i,k) = tarrsld (i1-1+i,k,jcen)
     end do
  end do
  do k = 1,plev
     do l = 1,k
        do i = 1,nlon
           grtlat(i,k) = grtlat(i,k) + parrsld(i1-1+i,l,jcen)*gamma(l,k)
        end do
     end do
  end do
!
! Accumulate Ps interpolants in 3-D array
!
  do k = 1,plev
     do i = 1,nlon
        grpslat(i) = grpslat(i) + parrsld(i1-1+i,k,jcen)
        pasum  (i) = pasum  (i) + parrsld(i1-1+i,k,jcen)
     end do
  end do
!
! Compute first part of (1/ps)etadot(dp/deta)
!
  do k = 1,plev-1
     do i = 1,nlon
        pa(i) = pa(i) + parrsld(i1-1+i,k,jcen)
        parrsld(i1-1+i,k,jcen) = pa(i)
     end do
!
     if(k.ge.nprlev) then
        do i = 1,nlon
           parrsld(i1-1+i,k,jcen) = parrsld(i1-1+i,k,jcen) - hybi(k+1)*( pasum(i) )
        end do
     end if
  end do
!
! Compute U, V interpolants:  Non-monotonic, 3-D interpolation
!
  limdrh  = .false.
  limdrv  = .true.
  lhrzint = .true.
  lvrtint = .true.
  call sltint (plev    ,1     ,jcen    ,u3(1,1,beglatex,n3m1)  ,lam     , &
               rdphi   ,rdz     ,lbasdy  ,lbasdz  ,xl      , &
               xr      ,wgt1x   ,wgt2x   ,wgt3x   ,wgt4x   , &
               hl      ,hr      ,dhl     ,dhr     ,ys      , &
               yn      ,wgt1y   ,wgt2y   ,wgt3y   ,wgt4y   , &
               hs      ,hn      ,dhs     ,dhn     ,wgt1z   , &
               wgt2z   ,wgt3z   ,wgt4z   ,hb      ,ht      , &
               dhb     ,dht     ,idp     ,jdp     ,kdp     , &
               kkdp    ,lhrzint ,lvrtint ,limdrh  ,limdrv  , &
               fdp(1,1,1),nlon  )
  call sltint (plev    ,1     ,jcen    ,v3(1,1,beglatex,n3m1)  ,lam     , &
               rdphi   ,rdz     ,lbasdy  ,lbasdz  ,xl      , &
               xr      ,wgt1x   ,wgt2x   ,wgt3x   ,wgt4x   , &
               hl      ,hr      ,dhl     ,dhr     ,ys      , &
               yn      ,wgt1y   ,wgt2y   ,wgt3y   ,wgt4y   , &
               hs      ,hn      ,dhs     ,dhn     ,wgt1z   , &
               wgt2z   ,wgt3z   ,wgt4z   ,hb      ,ht      , &
               dhb     ,dht     ,idp     ,jdp     ,kdp     , &
               kkdp    ,lhrzint ,lvrtint ,limdrh  ,limdrv  , &
               fdp(1,1,2),nlon  )
!
! Evaluate last half of grfu and grfv (Nu,Nv)
!
  call nunv1(lam(i1,jcen) ,phi(jcen),lamdp        ,phidp              ,fdp(1,1,1), &
             fdp(1,1,2)   ,coslat   ,grfu(1,1,lat),grfv(1,1,lat)      ,grfulat   , &
             grfvlat      ,nlon)
!
! Compute T interpolants:  Non-monotonic, 3-D interpolation
!
  limdrh  = .false.
  limdrv  = .true.
  lhrzint = .true.
  lvrtint = .true.
  call sltint (plev    ,1     ,jcen      ,t3(1,1,beglatex,n3m1)  ,lam     , &
               rdphi   ,rdz     ,lbasdy  ,lbasdz  ,xl      , &
               xr      ,wgt1x   ,wgt2x   ,wgt3x   ,wgt4x   , &
               hl      ,hr      ,dhl     ,dhr     ,ys      , &
               yn      ,wgt1y   ,wgt2y   ,wgt3y   ,wgt4y   , &
               hs      ,hn      ,dhs     ,dhn     ,wgt1z   , &
               wgt2z   ,wgt3z   ,wgt4z   ,hb      ,ht      , &
               dhb     ,dht     ,idp     ,jdp     ,kdp     , &
               kkdp    ,lhrzint ,lvrtint ,limdrh  ,limdrv  , &
               fdp(1,1,1),nlon  )
!
! Accumulate T interpolants in 3-D array
!
  do k = 1,plev
     do i = 1,nlon
#ifdef HADVTEST
        grtlat(i,k) = fdp(i,k,1)
#else
        grtlat(i,k) = grtlat(i,k) + fdp(i,k,1)
#endif
     end do
  end do
!
! Reset "kdp" to arrival indices everywhere so that we can do true
! horizontal interpolation rather than "vertical non-interpolation"
!
  do k = 1,plev
     do i = 1,nlon
        kdp(i,k) = k
     end do
  end do
!
! Compute Ps and remaining T interpolants:
! Non-monotonic, 2-D interpolation
!
  limdrh  = .false.
  limdrv  = .false.
  lhrzint = .true.
  lvrtint = .false.
  call sltint (plev    ,1       ,jcen    ,lnpssld ,lam     , &
               rdphi   ,rdz     ,lbasdy  ,lbasdz  ,xl      , &
               xr      ,wgt1x   ,wgt2x   ,wgt3x   ,wgt4x   , &
               hl      ,hr      ,dhl     ,dhr     ,ys      , &
               yn      ,wgt1y   ,wgt2y   ,wgt3y   ,wgt4y   , &
               hs      ,hn      ,dhs     ,dhn     ,wgt1z   , &
               wgt2z   ,wgt3z   ,wgt4z   ,hb      ,ht      , &
               dhb     ,dht     ,idp     ,jdp     ,kdp     , &
               kkdp    ,lhrzint ,lvrtint ,limdrh  ,limdrv  , &
               fdp(1,1,1),nlon  )
  call sltint (plev    ,1       ,jcen    ,prhssld ,lam     , &
               rdphi   ,rdz     ,lbasdy  ,lbasdz  ,xl      , &
               xr      ,wgt1x   ,wgt2x   ,wgt3x   ,wgt4x   , &
               hl      ,hr      ,dhl     ,dhr     ,ys      , &
               yn      ,wgt1y   ,wgt2y   ,wgt3y   ,wgt4y   , &
               hs      ,hn      ,dhs     ,dhn     ,wgt1z   , &
               wgt2z   ,wgt3z   ,wgt4z   ,hb      ,ht      , &
               dhb     ,dht     ,idp     ,jdp     ,kdp     , &
               kkdp    ,lhrzint ,lvrtint ,limdrh  ,limdrv  , &
               fdp(1,1,2), nlon )
  do i = 1,nlon
     pdsum(i) = 0.
     pd   (i) = 0.
     pdsm1(i) = 0.
     pd1  (i) = 0.
  end do
!
! Accumulate P-interpolants into T equation
!
#if ( ! defined HADVTEST )
  do k = nprlev,plev
     tmp1 = cappa*t0(k)*hypi(plevp)/hypm(k)
     do i = 1,nlon
        grtlat(i,k) = grtlat(i,k) - fdp(i,k,1)*tmp1*hybm(k) 
     end do
  end do
  do k = nprlev,plev
     do l = nprlev,k
        do i = 1,nlon
           grtlat(i,k) = grtlat(i,k) + fdp(i,l,1)*hybd(l)*gamma(l,k)
        end do
     end do
  end do
  do k = 1,plev
     do l = 1,k
        do i = 1,nlon
           grtlat(i,k) = grtlat(i,k) + fdp(i,l,2)*gamma(l,k)
        end do
     end do
  end do
#endif
!
! Accumulate Ps interpolants in 3-D array
!
  do k = 1,plev
     do i = 1,nlon
        grpslat(i) = grpslat(i) + fdp(i,k,2)
        pdsum(i) = pdsum(i) + fdp(i,k,2)
     end do
  end do
  do k = nprlev,plev
     do i = 1,nlon
        grpslat(i) = grpslat(i) + fdp(i,k,1)*hybd(k)
        pdsm1(i) = pdsm1(i) + fdp(i,k,1)*hybd(k)
     end do
  end do
!
! Compute remainder of (1/ps)etadot(dp/deta)
!
  do k = 1,plev-1
     do i = 1,nlon
        pd (i) = pd (i) + fdp(i,k,2)
        parrsld(i1-1+i,k,jcen) = parrsld(i1-1+i,k,jcen) + pd (i)
     end do
!
     if(k.ge.nprlev) then
        do i=1,nlon
           pd1(i) = pd1(i) + fdp(i,k,1)*hybd(k)
           parrsld(i1-1+i,k,jcen) = parrsld(i1-1+i,k,jcen) + pd1(i) - &
                hybi(k+1)*(pdsum(i) + pdsm1(i))
        end do
     end if
     do i = 1,nlon
        parrsld(i1-1+i,k,jcen) = parrsld(i1-1+i,k,jcen)*dtr
     end do
  end do
!
! Begin FFT
!
! fu,fv,T,q,vort,Ps: note contiguity assumptions
!
  inc   = 1
  isign = -1
  ntr   = 4*plev + 1
  call fft991(xnlin   ,work    ,trig(1,irow),ifax(1,irow),inc     , &
              plond   ,nlon    ,ntr         ,isign       )
!
  if (lat.gt.plat/2) then
!
! First of latitude pair (N. hemisphere), save Fourier coefficients
!
     do i = 1,2*nmmax(irow)
        grlps2(i,irow) = grpslat(i)
     end do
     do k = 1,plev
        do i = 1,2*nmmax(irow)
#if ( defined PVP )
           grfu2(i,k,irow) = grfulat(i,k)
           grfv2(i,k,irow) = grfvlat(i,k)
           grt2 (i,k,irow) = grtlat (i,k)
           grq2 (i,k,irow) = grqlat (i,k)
#else
           grfu2(k,i,irow) = grfulat(i,k)
           grfv2(k,i,irow) = grfvlat(i,k)
           grt2 (k,i,irow) = grtlat (i,k)
           grq2 (k,i,irow) = grqlat (i,k)
#endif
        end do
     end do
  else
!
! Second of latitude pair (S. hemisphere), save Fourier coefficients
!
     do i = 1,2*nmmax(irow)
        grlps1(i,irow) = grpslat(i)
     end do
     do k = 1,plev
        do i = 1,2*nmmax(irow)
#if ( defined PVP )
           grfu1(i,k,irow) = grfulat(i,k)
           grfv1(i,k,irow) = grfvlat(i,k)
           grt1 (i,k,irow) = grtlat (i,k)
           grq1 (i,k,irow) = grqlat (i,k)
#else
           grfu1(k,i,irow) = grfulat(i,k)
           grfv1(k,i,irow) = grfvlat(i,k)
           grt1 (k,i,irow) = grtlat (i,k)
           grq1 (k,i,irow) = grqlat (i,k)
#endif
        end do
     end do
  end if
!
  return
end subroutine scanslt