CALUPDHEL.f

Go to the documentation of this file.

 
!--------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------
      SUBROUTINE calupdhel(UPDHEL)
 
!     
!
!      use vrbls2d, only:
      use vrbls3d,      only: wh, uh, vh, zint, zmid
      use masks,        only: lmh, dx, dy
      use params_mod,   only: d00
      use ctlblk_mod,   only: lm, jsta_2l, jend_2u, jsta_m, jend_m,   &
                              global, spval, im, jm, &
                              ista_2l, iend_2u, ista_m, iend_m
      use gridspec_mod, only: gridtype
      use upp_math,     only: dvdxdudy, ddvdx, ddudy
 
      implicit none
 
!     DECLARE VARIABLES.
!     
!      LOGICAL RUN,FIRST,RESTRT,SIGMA,OLDRD,STRD
      REAL, PARAMETER:: HLOWER=2000., hupper=5000.
      REAL ZMIDLOC
      real :: r2dx, r2dy, dz, dcdx, dudy, dvdx
      REAL :: HTSFC(ista_2l:iend_2u,jsta_2l:jend_2u),UPDHEL(ista_2l:iend_2u,jsta_2l:jend_2u)
      integer :: l, j, i 
      INTEGER, dimension(jm) :: IHE,IHW
!        INTEGER DXVAL,DYVAL,CENLAT,CENLON,TRUELAT1,TRUELAT2
!        INTEGER LATSTART,LONSTART,LATLAST,LONLAST 
!     
!***************************************************************************
!     START CALUPDHEL HERE.
!     
!      write(6,*) 'min/max WH(:,:,20):: ', minval(WH(:,:,20)), &
!                                          maxval(WH(:,:,20))
 
      DO l=1,lm
        CALL exch(uh(ista_2l,jsta_2l,l))
      END DO 
      IF (gridtype == 'B')THEN
        DO l=1,lm
          CALL exch(vh(ista_2l,jsta_2l,l))
        END DO
      END IF
!$omp parallel do private(i,j)
      DO j=jsta_2l,jend_2u
        DO i=ista_2l,iend_2u
          updhel(i,j) = d00
        ENDDO
      ENDDO
 
      DO j=jsta_2l,jend_2u
        ihw(j) = -mod(j,2)
        ihe(j) = ihw(j)+1
      ENDDO
 
!     Integrate (w * relative vorticity * dz) over the 2 km to
!     5 km AGL depth.
 
!   initial try without horizontal averaging
 
!$omp parallel do private(i,j)
      DO j=jsta_m,jend_m
        DO i=ista_m,iend_m
          htsfc(i,j) = zint(i,j,nint(lmh(i,j))+1)
        ENDDO
      ENDDO
 
      DO j=jsta_m,jend_m
        DO i=ista_m,iend_m
 
          IF (htsfc(i,j) < spval) THEN
 
          r2dx   = 1./(2.*dx(i,j))
          r2dy   = 1./(2.*dy(i,j))
 
          l_loop: DO l=1,lm
            zmidloc = zmid(i,j,l)
            IF (global) then ! will put in global algorithm later
              updhel(i,j) = spval
              EXIT l_loop
            END IF 
 
            IF ( (zmidloc - htsfc(i,j)) >= hlower  .AND.  &
                 (zmidloc - htsfc(i,j)) <= hupper ) THEN
              dz=(zint(i,j,l)-zint(i,j,l+1))
 
              IF (wh(i,j,l) < 0) THEN
 
!          ANY DOWNWARD MOTION IN 2-5 km LAYER KILLS COMPUTATION AND
!          SETS RESULTANT UPDRAFT HELICTY TO ZERO
 
                updhel(i,j) = 0.
                EXIT l_loop
 
              ENDIF
 
              CALL dvdxdudy(uh(:,:,l),vh(:,:,l))
              dvdx   = ddvdx(i,j)
              dudy   = ddudy(i,j)
 
              updhel(i,j)=updhel(i,j)+(dvdx-dudy)*wh(i,j,l)*dz
 
              IF (updhel(i,j) < -9e10 .OR. updhel(i,j) > 9e10) THEN
                 updhel(i,j) = spval
              ENDIF
 
            ENDIF
          ENDDO l_loop
 
          ELSE
            updhel(i,j) = spval
          ENDIF
 
        ENDDO
      ENDDO
 
!
!      print*,'jsta_m, jend_m in calupdhel= ',jsta_m,jend_m
!     
!     END OF ROUTINE.
!     
      RETURN
      END