scan2.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

! Initialize moisture, mass, energy, and temperature integrals
!
   hw1(1) = 0.
   engy1  = 0.
   engy2a = 0.
   engy2b = 0.
   diffta = 0.
   difftb = 0.
   do m=1,pcnst
      hw2a(m) = 0.
      hw2b(m) = 0.
      hw3a(m) = 0.
      hw3b(m) = 0.
      do n=1,4
         hwxa(m,n) = 0.
         hwxb(m,n) = 0.
      end do
   end do
!
! Sum water and energy integrals over latitudes
!
   do lat=1,plat
      engy1   = engy1   + engy1lat (lat)
      engy2a  = engy2a  + engy2alat(lat)
      engy2b  = engy2b  + engy2blat(lat)
      diffta  = diffta  + difftalat(lat)
      difftb  = difftb  + difftblat(lat)
      hw1(1)  = hw1(1)  + hw1lat(1,lat)
      hw2a(1) = hw2a(1) + hw2al(1,lat)
      hw2b(1) = hw2b(1) + hw2bl(1,lat)
      hw3a(1) = hw3a(1) + hw3al(1,lat)
      hw3b(1) = hw3b(1) + hw3bl(1,lat)
   end do
!
! Compute atmospheric mass fixer coefficient
!
   qmassf     = hw1(1)
   if (adiabatic .or. ideal_phys) then
      fixmas = tmass0/tmassf
   else
      fixmas = (tmass0 + qmassf)/tmassf
   end if
!
! Compute alpha for water ONLY
!
   hw2(1)    = hw2a(1) + fixmas*hw2b(1)
   hw3(1)    = hw3a(1) + fixmas*hw3b(1)
   if(hw3(1) .ne. 0.) then
      alpha(1)  = ( hw1(1) - hw2(1) )/hw3(1)
   else
      alpha(1)  = 1.
   endif
!
! Compute beta for energy
!
   engy2    = engy2a + fixmas*engy2b
   difft    = diffta + fixmas*difftb
   residual = (engy2 - engy1)/ztodt
   if(difft .ne. 0.) then
     beta = -residual*ztodt/(cpair*difft)
   else
     beta = 0.
   endif
!!   write(6,125) residual,beta
!!125 format('      resid, beta      = ',25x,2f25.15)
!
! Compute alpha for non-water constituents
!
   do m = 2,pcnst
      hw1(m) = 0.
      do lat=1,plat
         hw1(m) = hw1(m) + hw1lat(m,lat)
      end do
      do n = 1,4
         do lat=1,plat
            hwxa(m,n) = hwxa(m,n) + hwxal(m,n,lat)
            hwxb(m,n) = hwxb(m,n) + hwxbl(m,n,lat)
         end do
      end do
      hw2a(m) = hwxa(m,1) - alpha(1)*hwxa(m,2)
      hw2b(m) = hwxb(m,1) - alpha(1)*hwxb(m,2)
      hw3a(m) = hwxa(m,3) - alpha(1)*hwxa(m,4)
      hw3b(m) = hwxb(m,3) - alpha(1)*hwxb(m,4)
      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

   do j=beglatex,endlatex
      endi = nlonex(j) + i1 - 1
      q3(i1:endi,:,ixcldw,j,n3m1) = q3(i1:endi,:,ixcldw,j,n3)
   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), v3(i1,1,j,n3m1), t3(i1,1,j,n3m1), &
                          q3(i1,1,1,j,n3), q3(i1,1,1,j,n3m1), ps(1,lat,n3m1), cwava(lat), alpha, &
                          etamid, qfcst(i1,1,1,lat), div(1,1,lat,n3m1), phis(1,lat), omga(1,1,lat), &
                          dpsl(1,lat), dpsm(1,lat), nlon(lat), t3(i1,1,j,n3),beta)
   end do

   call t_stopf ('tfilt_massfix')
!
! Shift time pointers
!
   call shift_time_indices ()

   return
end subroutine scan2

#ifdef SPMD
subroutine realloc5 (hw2al   ,hw2bl   ,hw3al   ,hw3bl   ,tmass    , &
                     hw1lat  ,hwxal   ,hwxbl   ,engy1lat,engy2alat, &
                     engy2blat,difftalat,difftblat      )
!-----------------------------------------------------------------------
!
! Purpose:
! Reallocation routine for slt variables.
!
! Author:  J. Rosinski
!
!-----------------------------------------------------------------------
!
! $Id: scan2.F90,v 1.11 2001/10/19 17:50:35 eaton Exp $
! $Author: eaton $
!
!-----------------------------------------------------------------------

  use precision
  use pmgrid
  use pspect
  use spmd_dyn
  use prognostics
  use mpishorthand
  implicit none
#include <comsta.h>

!---------------------------------Parameters----------------------------------
!
  integer, parameter :: msgtype = 5000      ! message passing id
!
!------------------------------Arguments--------------------------------
!
  real(r8), intent(in)   :: hw2al (pcnst,plat)   ! -
  real(r8), intent(in)   :: hw2bl (pcnst,plat)   !  | lat contributions to components
  real(r8), intent(in)   :: hw3al (pcnst,plat)   !  | of tracer global mass integrals 
  real(r8), intent(in)   :: hw3bl (pcnst,plat)   ! -
  real(r8), intent(in)   :: tmass (plat)         !    global atmospheric mass integral
  real(r8), intent(in)   :: hw1lat(pcnst,plat)   ! -
  real(r8), intent(in)   :: hwxal (pcnst,4,plat) !  | lat contributions to components
  real(r8), intent(in)   :: hwxbl (pcnst,4,plat) !  | of tracer global mass integrals 
!                                                ! -
  real(r8), intent(in)   :: engy1lat (plat)      ! lat contribution to total energy (n)
  real(r8), intent(in)   :: engy2alat(plat)      ! lat contribution to total energy (n+1)
  real(r8), intent(in)   :: engy2blat(plat)      ! lat contribution to total energy (n+1)
  real(r8), intent(in)   :: difftalat(plat)      ! lat contribution to delta-T integral
  real(r8), intent(in)   :: difftblat(plat)      ! lat contribution to delta-T integral
!
!---------------------------Local workspace-----------------------------
!
  integer len
  integer procid                                 ! Processor id
  integer stat(MPI_STATUS_SIZE)
  integer bpos
  integer procj,maxcount
  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 (engy1lat (beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)
        call mpipack (engy2alat(beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)
        call mpipack (engy2blat(beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)
        call mpipack (difftalat(beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)
        call mpipack (difftblat(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,engy1lat (beglat_p) ,numlats_p,mpir8 ,mpicom)
        call mpiunpack (buf2,bsiz,bpos,engy2alat(beglat_p) ,numlats_p,mpir8 ,mpicom)
        call mpiunpack (buf2,bsiz,bpos,engy2blat(beglat_p) ,numlats_p,mpir8 ,mpicom)
        call mpiunpack (buf2,bsiz,bpos,difftalat(beglat_p) ,numlats_p,mpir8 ,mpicom)
        call mpiunpack (buf2,bsiz,bpos,difftblat(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