TRPAUS.f

Go to the documentation of this file.

      SUBROUTINE trpaus(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)

!     
!     
!     INCLUDE ETA GRID DIMENSIONS.  SET/DERIVE PARAMETERS.
!
       use vrbls3d,    only: pint, t, zint, uh, vh
       use masks,      only: lmh
       use params_mod, only: d50
       use ctlblk_mod, only: jsta, jend, spval, im, jm, lm
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
       implicit none
!
!     PARAMTER CRTLAP SPECIFIES THE CRITICAL LAPSE RATE
!     (IN K/M) IDENTIFYING THE TROPOPAUSE.  WE START 
!     LOOKING FOR THE TROPOPAUSE ABOVE PRESSURE LEVEL
!     PSTART (IN PASALS).
      real,PARAMETER :: crtlap=0.002e0, pstart=5.0e4
!     
!     DECLARE VARIABLES.
!     
      REAL,dimension(IM,JM),intent(out) :: ptrop,ttrop,ztrop,utrop,  &
           vtrop,shtrop
      REAL tlapse(lm),dz2(lm),delt2(lm),tlapse2(lm)
!
      integer i,j,ll,llmh,l
      real pm,delt,dz,rsqdif
!     
!*****************************************************************************
!     START TRPAUS HERE.
!     
!     LOOP OVER THE HORIZONTAL GRID.
!    
      DO j=jsta,jend
      DO i=1,im
         ptrop(i,j)  = spval
         ttrop(i,j)  = spval
         ztrop(i,j)  = spval
         utrop(i,j)  = spval
         vtrop(i,j)  = spval
         shtrop(i,j) = spval
      ENDDO
      ENDDO
!
!!$omp  parallel do
!!$omp& private(delt,delt2,dz,dz2,ie,iw,l,llmh,pm,rsqdif,
!!$omp&         tlapse,tlapse2,u0,u0l,uh,uh0,ul,
!!$omp&         v0,v0l,vh,vh0)
       DO j=jsta,jend
       loopi:DO i=1,im
!     
!        COMPUTE THE TEMPERATURE LAPSE RATE (-DT/DZ) BETWEEN ETA 
!        LAYERS MOVING UP FROM THE GROUND.  THE FIRST ETA LAYER
!        ABOVE PRESSURE "PSTART" IN WHICH THE LAPSE RATE IS LESS
!        THAN THE CRITCAL LAPSE RATE IS LABELED THE TROPOPAUSE.
!
        llmh=nint(lmh(i,j))
!
        loopl: DO l=llmh-1,2,-1
        pm     = pint(i,j,l)
        delt   = t(i,j,l-1)-t(i,j,l)
        dz     = d50*(zint(i,j,l-1)-zint(i,j,l+1))
        tlapse(l) = -delt/dz
!
        IF ((tlapse(l)<crtlap).AND.(pm<pstart)) THEN 
          IF (l == 2 .AND. tlapse(l) < crtlap) goto 15
          dz2(l+1) = 0.
!
          DO 17 ll=l,3,-1
          dz2(ll) = 0.
          delt2(ll) = 0.
          tlapse2(ll) = 0.
          dz2(ll) = (2./3.)*(zint(i,j,ll-2)-zint(i,j,l+1))
          IF ((dz2(ll) > 2000.) .AND.                    &
              (dz2(ll+1) > 2000.)) go to 15
          delt2(ll) = t(i,j,ll-2)-t(i,j,l)
          tlapse2(ll) = -delt2(ll)/dz2(ll)
!
          IF (tlapse2(ll) > crtlap) THEN
            cycle loopl
          ENDIF
!
   17     CONTINUE 
        ELSE
          cycle loopl
        ENDIF 
!
   15   ptrop(i,j)  = d50*(pint(i,j,l)+pint(i,j,l+1))
        ttrop(i,j)  = t(i,j,l)
        ztrop(i,j)= 0.5*(zint(i,j,l)+zint(i,j,l+1))
!
        utrop(i,j) = uh(i,j,l)
        vtrop(i,j) = vh(i,j,l)
        dz        = zint(i,j,l)-zint(i,j,l+1)
        rsqdif    = sqrt(((uh(i,j,l-1)-uh(i,j,l+1))*0.5)**2  &
     &                  +((vh(i,j,l-1)-vh(i,j,l+1))*0.5)**2)
        shtrop(i,j) = rsqdif/dz
        cycle loopi

        ENDDO loopl

!X         WRITE(88,*)'REACHED TOP FOR K,P,TLAPSE:  ',K,PM,TLAPSE

        dz       = d50*(zint(i,j,2)-zint(i,j,3))
        ptrop(i,j) = d50*(pint(i,j,2)+pint(i,j,3))
        ttrop(i,j) = t(i,j,2)
        ztrop(i,j)= d50*(zint(i,j,2)+zint(i,j,3))
        utrop(i,j) = uh(i,j,2)
        vtrop(i,j) = vh(i,j,2)
        rsqdif    = sqrt(((uh(i,j,1)-uh(i,j,3))*0.5)**2    &
     &                  +((vh(i,j,1)-vh(i,j,3))*0.5)**2)
        shtrop(i,j) = rsqdif/dz

!X        WRITE(82,1010)I,J,L,PTROP(I,J)*D01,TTROP(I,J),
!X     X       UTROP(I,J),VTROP(I,J),SHTROP(I,J)
!     
      ENDDO loopi !end I
      ENDDO !end J

!     
!     END OF ROUTINE.
!     
      RETURN
      END