WETFRZLVL.f

Go to the documentation of this file.

 
 
      SUBROUTINE wetfrzlvl(TWET,ZWET)
 
!     
!     
      use vrbls3d, only: pint, zint, t
      use vrbls2d, only:  fis, thz0, ths
      use masks, only: lmh, sm
      use params_mod, only: gi, p1000, capa, tfrz, d0065, d50
      use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval, &
                            ista, iend, ista_2l, iend_2u 
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      implicit none
!
!     DECLARE VARIABLES.
!     
      REAL,intent(in) :: TWET(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)
      REAL,intent(out) :: ZWET(ista:iend,jsta:jend)
!     
      integer I,J,LLMH,L
      real HTSFC,THSFC,PSFC,TSFC,DELZ,DELT,ZL,ZU
!*********************************************************************
!     START FRZLVL.
!
!     LOOP OVER HORIZONTAL GRID.
!     
!!$omp  parallel do
!!$omp& private(delt,delz,htsfc,l,llmh
!!$omp&         tsfc,zl,zu)
      DO j=jsta,jend
      DO i=ista,iend
         IF(fis(i,j)==spval)THEN
           zwet(i,j)=spval
           cycle
         ENDIF
         htsfc     = fis(i,j)*gi
         llmh      = nint(lmh(i,j))
         zwet(i,j) = htsfc
!     
!        CHECK IF FREEZING LEVEL IS AT THE GROUND.
!        IF YES, ESTIMATE UNDERGROUND FREEZING LEVEL USING 6.5C/KM LAPSE RATE
!        AND ASSUME RH TO BE EQUAL TO RH AT SFC
!     
         thsfc = (sm(i,j)*thz0(i,j)+(1.-sm(i,j))*ths(i,j))
         psfc  = pint(i,j,llmh+1)
         tsfc  = thsfc*(psfc/p1000)**capa
 
         IF (tsfc<=tfrz) THEN
!            ZWET(I,J) = HTSFC
            zwet(i,j) = htsfc+(tsfc-tfrz)/d0065
            cycle   
         ENDIF
!     
!        OTHERWISE, LOCATE THE FREEZING LEVEL ALOFT.
!
         loopl:DO l = llmh,1,-1
            IF (twet(i,j,l)<=tfrz) THEN
               IF (l<llmh-1) THEN
                  delz = d50*(zint(i,j,l)-zint(i,j,l+2))
                  zl   = d50*(zint(i,j,l+1)+zint(i,j,l+2))
                  delt = twet(i,j,l)-twet(i,j,l+1)
                  zwet(i,j) = zl + (tfrz-twet(i,j,l+1))/delt*delz
               ELSE
                  zu      = d50*(zint(i,j,l)+zint(i,j,l+1))
                  zl      = htsfc
                  delz    = zu-zl
                  tsfc    = sm(i,j)*thz0(i,j)+(1.-sm(i,j))*ths(i,j)    &
                   *(pint(i,j,nint(lmh(i,j))+1)/p1000)**capa
                  delt    = t(i,j,l)-tsfc
          IF(delt /= 0.)THEN  
                   zwet(i,j) = zl + (tfrz-tsfc)/delt*delz
          ELSE
           zwet(i,j) = htsfc+(tsfc-twet(i,j,l))/d0065
          END IF  
                  IF (zwet(i,j) > zu) THEN
                    zwet(i,j)=zu
                  ENDIF
                   IF ((-1*zwet(i,j)) > zu) THEN
                    zwet(i,j)=zu
                  endif
               ENDIF
               EXIT loopl 
            ENDIF
         ENDDO loopl
 
      ENDDO !end I
      ENDDO !end J
!     
!     END OF ROUTINE.
!     
      RETURN
      END