pkez.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: pkez --- Calculate solution to hydrostatic equation
!
! !INTERFACE:
!****6***0*********0*********0*********0*********0*********0**********72
      subroutine pkez(nx, im, km, jfirst, jlast, kfirst, klast,    &
                      ifirst, ilast, pe, pk, akap, ks, peln, pkz, eta)
!****6***0*********0*********0*********0*********0*********0**********72
!
! !USES:
      use precision

      implicit none

!
! This routine may be called assuming either yz or xy decompositions.
! For xy decomposition, the effective "nx" is 1.
!

! !INPUT PARAMETERS:
      integer nx                          ! SMP decomposition in x
      integer im, km                      ! Dimensions
      integer jfirst, jlast               ! Latitude strip
      integer kfirst, klast               ! Vertical strip
      integer ifirst, ilast               ! Longitude strip
      real (r8)  pe(ifirst:ilast, kfirst:klast+1, jfirst:jlast)    ! Edge pressure
      integer ks
      logical eta     ! Is on ETA coordinate?
                      ! True:  input pe    ; output pk, pkz, peln
                      ! False: input pe, pk; output     pkz, peln
      real (r8) akap

! !INPUT/OUTPUT PARAMETERS:
      real (r8)  pk(ifirst:ilast,jfirst:jlast,kfirst:klast+1)

! !OUTPUT PARAMETERS
      real (r8) pkz(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real (r8) peln(ifirst:ilast, kfirst:klast+1, jfirst:jlast)   ! log pressure (pe) at layer edges

! !DESCRIPTION:
!
!
! !CALLED FROM:
!     te_map and fvccm3
!
! !REVISION HISTORY:
!
!     WS  99.05.19 : Removed fvcore.h
!     WS  99.07.27 : Limited region to jfirst:jlast
!     WS  99.10.22 : Deleted cp as argument (was not used)
!     WS  99.11.05 : Documentation; pruning of arguments
!     SJL 00.01.02 : SMP decomposition in i
!     AAM 00.08.10 : Add kfirst:klast
!     AAM 01.06.27 : Add ifirst:ilast
!
!EOP
!---------------------------------------------------------------------
!BOC

! Local
      real (r8) pk2(ifirst:ilast, kfirst:klast+1)
      real (r8) pek
      real (r8) lnp
      integer i, j, k, itot, nxu
      integer ixj, jp, it, i1, i2

      itot = ilast - ifirst + 1
! Use smaller block sizes only if operating on full i domain
      nxu = 1
      if (itot .eq. im) nxu = nx

      it = itot / nxu
      jp = nxu * ( jlast - jfirst + 1 )

!$omp  parallel do        &
!$omp  default(shared)    &
!$omp  private(ixj, i1, i2, i, j, k, pek, lnp, pk2)

! WS 99.07.27 : Limited region to jfirst:jlast

      do 1000 ixj=1,jp

         j  = jfirst + (ixj-1) / nxu
         i1 = ifirst + it * mod(ixj-1, nxu)
         i2 = i1 + it - 1

        if ( eta ) then

! <<<<<<<<<<< Eta cordinate Coordinate  >>>>>>>>>>>>>>>>>>>
          if (kfirst .eq. 1) then
            pek =     pe(i1,1,j)**akap
            lnp = log(pe(i1,1,j))

            do i=i1,i2
               pk2(i,1)   = pek
              peln(i,1,j) = lnp
            enddo
          endif

          if(ks .ne. 0) then
            do k=max(2,kfirst), min(ks+1,klast+1)
              pek = pe(i1,k,j)**akap
              lnp = log(pe(i1,k,j))
              do i=i1,i2
                 pk2(i,k)   = pek
                peln(i,k,j) =  lnp
              enddo
            enddo

            do k=kfirst, min(ks,klast)
              pek = (       pk2(i1,k+1)   - pk2(i1,k))   /     &
                    (akap*(peln(i1,k+1,j) - peln(i1,k,j)) )
              do i=i1,i2
                 pkz(i,j,k) = pek
              enddo
            enddo
          endif

          do k=max(ks+2,kfirst), klast+1
#if !defined( VECTOR_MATH )
            do i=i1,i2
               pk2(i,k) = pe(i,k,j)**akap
            enddo
#else
            call vlog(pk2(i1,k), pe(i1,k,j), it)
            do i=i1,i2
               pk2(i,k) = akap * pk2(i,k)
            enddo
            call vexp(pk2(i1,k), pk2(i1,k), it)
#endif
          enddo

          do k=max(ks+2,kfirst), klast+1
            do i=i1,i2
               peln(i,k,j) =  log(pe(i,k,j))
            enddo
          enddo

          do k=max(ks+1,kfirst), klast
            do i=i1,i2
               pkz(i,j,k) = (pk2(i,k+1) - pk2(i,k)) /         &
                            (akap*(peln(i,k+1,j) - peln(i,k,j)) )
            enddo
          enddo

          do k=kfirst, klast+1
            do i=i1,i2
               pk(i,j,k) = pk2(i,k)
            enddo
          enddo

        else

! <<<<<<<<<<< General Coordinate  >>>>>>>>>>>>>>>>>>>

          if (kfirst .eq. 1) then
            pek =     pk(i1,j,1)
            lnp = log(pe(i1,1,j))

            do i=i1,i2
               pk2(i,1) = pek
               peln(i,1,j) = lnp
            enddo
          endif

          do k=max(2,kfirst), klast+1
             do i=i1,i2
                peln(i,k,j) =  log(pe(i,k,j))
                pk2(i,k) =  pk(i,j,k)
             enddo
          enddo

          do k=kfirst, klast
             do i=i1,i2
                pkz(i,j,k) = (       pk2(i,k+1) - pk2(i,k) )  /    &
                             (akap*(peln(i,k+1,j) - peln(i,k,j)) )
             enddo
          enddo

        endif
1000  continue

      return
!EOC
      end
!-----------------------------------------------------------------------