CALTHTE.f

Go to the documentation of this file.

!--------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------
      SUBROUTINE calthte(P1D,T1D,Q1D,THTE)

!
!     
      use params_mod, only: d00, eps, oneps, d01, h1m12, p1000, h1
      use ctlblk_mod, only: jsta, jend, im, spval, ista, iend
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      implicit none
!
      real,PARAMETER :: kg2g=1.e3
      real,PARAMETER :: d35=3.5,d4805=4.805,h2840=2840.,h55=55.
      real,PARAMETER :: d2845=0.2845,d00028=0.00028,d3376=3.376
      real,PARAMETER :: d00254=0.00254,d00081=0.00081,d81=0.81
      real,PARAMETER :: d28=0.28,h2675=2675.
!
!     DECLARE VARIABLES.
!     
      REAL,dimension(ista:iend,jsta:jend),intent(in)    :: p1d,t1d,q1d
      REAL,dimension(ista:iend,jsta:jend),intent(inout) :: thte

      integer i,j
      real p,t,q,evp,rmx,ckapa,rkapa,arg,denom,tlcl,plcl,fac,   &
           eterm,thetae
!     
!***************************************************************
!     START CALTHTE.
!     
!     ZERO THETA-E ARRAY
!$omp parallel do private(i,j)
      DO j=jsta,jend
        DO i=ista,iend
          thte(i,j) = d00
        ENDDO
      ENDDO
!     
!     COMPUTE THETA-E.
!
!      DO J=JSTA_M,JEND_M
!      DO I=ISTA_M,IEND_M
!$omp parallel do private(i,j,p,t,q,evp,rmx,ckapa,rkapa,arg,denom,tlcl,plcl,fac,eterm,thetae)
      DO j=jsta,jend
        DO i=ista,iend
          IF(p1d(i,j)<spval.and.t1d(i,j)<spval.and.q1d(i,j)<spval)THEN
          p        = p1d(i,j)
          t        = t1d(i,j)
          q        = q1d(i,j)
          evp      = p*q/(eps+oneps*q)
          rmx      = eps*evp/(p-evp)
          ckapa    = d2845*(1.-d28*rmx)
          rkapa    = 1./ckapa
          arg      = max(h1m12, evp*d01)
          denom    = d35*log(t) - log(evp*d01) - d4805
          tlcl     = h2840/denom + h55
          plcl     = p*(tlcl/t)**rkapa
          fac      = (p1000/p)**ckapa
          eterm    = (d3376/tlcl-d00254)*(rmx*kg2g*(h1+d81*rmx))
          thetae   = t*fac*exp(eterm)
          thte(i,j)= thetae
          ENDIF
        ENDDO
      ENDDO
!     
!     END OF ROUTINE.
!
      RETURN
      END