dryairm.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

#include <misc.h>
!-----------------------------------------------------------------------
!BOP
! !ROUTINE: dryairm --- Check dry air mass; set to a predefined value if
!                       nlres is false (initialization run)
!
! !INTERFACE:

subroutine dryairm( im,    jm,    km,   jfirst,   jlast,     &
                    ng,    kfirst,klast,                     &
                    moun,  ptop,  ps,   q,       nc,         &
                    nq,    delp,  pe,   nlres )

! !USES:
      use precision
      use pmgrid, only: myid_z, npr_z, strip3zaty

#if defined( SPMD )
#define CPP_PRT_PREFIX  if( gid == 0 )
  use spmd_dyn, only: comm_z
  use parutilitiesmodule, only : gid, parcollective, pargatherreal, sumop
#else
#define CPP_PRT_PREFIX
#endif

 implicit   none

 integer, intent(in):: im, jm, km     ! Dimensions
 integer, intent(in):: jfirst, jlast  ! Latitude strip
 integer, intent(in):: ng             ! Ghost latitudes
 integer, intent(in):: kfirst, klast  ! Vertical strip
 integer, intent(in):: nc             ! Total number of tracers         
 integer, intent(in):: nq             ! Number of advective tracers         
 logical, intent(in):: nlres
 logical, intent(in):: moun
 real(r8), intent(in) :: ptop

 real(r8), intent(inout) :: q(im,jfirst-ng:jlast+ng,kfirst:klast,nc) 
 real(r8), intent(inout) :: ps(im,jfirst:jlast)          ! surface pressure
 real(r8), intent(inout) :: delp(im,jfirst:jlast,kfirst:klast)     ! pressure thickness
 real(r8), intent(inout) :: pe(im,kfirst:klast+1,jfirst:jlast)     ! edge pressure

! !DESCRIPTION:
!  Perform adjustment of the total dry-air-mass while preserving total
!  tracer mass
!  Developer: S.-J. Lin, Aug 2000
!
! !REVISION HISTORY:
!   AAM   01.06.27       Assure agreement thru roundoff for 2D decomp.
!
!EOP
!---------------------------------------------------------------------
!BOC

! Use work arrays psdk/psdkg to assure identical answers through roundoff
!    for different z decompositions

      real(r8), allocatable :: psdk(:,:,:)     ! local work array
      real(r8), allocatable :: psdkg(:,:,:)    ! global work array
      real(r8)    psd(im,jfirst:jlast)    ! dry surface pressure
      real(r8)   drym                     ! global mean dry air mass in pascals

#if defined ( NAVY10 )
      parameter (drym = 98222.)           ! For US NAVY 10-min terrain
#else
      parameter (drym = 98288.)           ! For USGS terrain
#endif

      integer  i, j, k, ic
      real(r8) psm0, psm1
      real(r8) psdry
      real(r8) dpd

! Check global maximum/minimum

    call gmean ( im,   jm,    jfirst,    jlast,   ps(1,jfirst), psm0 )

    allocate (psdk(im,jfirst:jlast,kfirst:klast))
    allocate (psdkg(im,jfirst:jlast,km))

!$omp  parallel do private(i,j,k)
    do k=kfirst,klast
       do j=jfirst,jlast
          do i=1,im
             psdk(i,j,k) = 0.
          enddo
       enddo
    enddo
!$omp  parallel do private(i,j,k)
    do k=1,km
       do j=jfirst,jlast
          do i=1,im
             psdkg(i,j,k) = 0.
          enddo
       enddo
    enddo

    if (kfirst .eq. 1) then

!$omp  parallel do private(i,j)

       do j=jfirst,jlast
          do i=1,im
             psdk(i,j,1) = ptop
          enddo
       enddo

    endif

    if( nq .ne. 0 ) then

!$omp  parallel do private(i,j,k)

       do j=jfirst,jlast
          do k=kfirst,klast
             do i=1,im
                psdk(i,j,k) = psdk(i,j,k) + (1.-q(i,j,k,1))*(pe(i,k+1,j)-pe(i,k,j))
             enddo
          enddo
       enddo

    else

!$omp  parallel do private(i,j,k)

       do j=jfirst,jlast
          do k=kfirst,klast
             do i=1,im
                psdk(i,j,k) = psdk(i,j,k) +  pe(i,k+1,j) - pe(i,k,j)
             enddo
          enddo
       enddo

    endif

    if (npr_z .gt. 1) then
#if defined (SPMD)
       call pargatherreal(comm_z, 0, psdk, strip3zaty, psdkg)
#endif
    else
!$omp  parallel do private(i,j,k)
       do k=kfirst,klast
          do j=jfirst,jlast
             do i=1,im
                psdkg(i,j,k) = psdk(i,j,k)
             enddo
          enddo
       enddo
    endif

!$omp  parallel do private(i,j)
    do j=jfirst,jlast
       do i=1,im
          psd(i,j) = 0.
       enddo
    enddo

    if (myid_z .eq. 0) then

!$omp  parallel do private(i,j,k)

       do j=jfirst,jlast
          do k=1,km
             do i=1,im
                psd(i,j) = psd(i,j) + psdkg(i,j,k)
             enddo
          enddo
       enddo

    endif

#if defined (SPMD)
    if (npr_z .gt. 1) then
       call parcollective(comm_z, sumop, im, jlast-jfirst+1, psd)
    endif
#endif

    call gmean( im,  jm,  jfirst,  jlast,  psd(1,jfirst), psdry )
 
 CPP_PRT_PREFIX write(6,*) 'Total Mass=', 0.01*psm0, '(mb), Dry Mass=', 0.01*psdry, '(mb)'
 CPP_PRT_PREFIX write(6,*) 'Total Precipitable Water =', (psm0-psdry)/9.80616, '(kg/m**2)'

    deallocate (psdk)
    deallocate (psdkg)

    if( nlres ) return

    if(moun) then
       dpd = drym - psdry
    else
       dpd = 1000.*100. - psdry
    endif
 CPP_PRT_PREFIX write(6,*) 'dry mass to be added =', 0.01*dpd

    if (klast .eq. km) then

!$omp  parallel do private(i, j, ic)

       do j=jfirst,jlast

          do ic=1,nq
             do i=1,im
                q(i,j,km,ic) =  q(i,j,km,ic)*delp(i,j,km)/(delp(i,j,km)+dpd)
             enddo
          enddo

! Adjust the lowest Lagrangian layer
          do i=1,im
             delp(i,j,km) = delp(i,j,km) + dpd
             pe(i,km+1,j) = pe(i,km,j) + delp(i,j,km)
             ps(i,j) = pe(i,km+1,j)
          enddo
       enddo
    endif

    if (npr_z .gt. 1) then

       if (myid_z .ne. npr_z-1) then
!$omp  parallel do private(i,j)
          do j=jfirst,jlast
             do i=1,im
                ps(i,j) = 0.
             enddo
          enddo
       endif

#if defined (SPMD)
       call parcollective(comm_z, sumop, im, jlast-jfirst+1, ps)
#endif

    endif

    call gmean(im, jm, jfirst, jlast, ps(1,jfirst), psm1)

 CPP_PRT_PREFIX write(6,*) 'Total moist surface pressure after adjustment (mb) = ',0.01*psm1 

 return

!EOC
end subroutine dryairm
!---------------------------------------------------------------------