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