SUBROUTINE CALPBL(PBLRI)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .     
! SUBPROGRAM:    CALPBL COMPUTES PBL HEIGHT BASED ON BULK RCH NUMBER
!     
! ABSTRACT:  
!   THIS ROUTINE COMPUTES THE BULK RICHARDSON NUMBER
!   AND PBL HEIGHT ABOVE SURFACE
!   .     
!     
! PROGRAM HISTORY LOG:
!   06-05-04  M TSIDULKO 
!   
! USAGE:    CALL CALPBL(PBLRI)
!   INPUT ARGUMENT LIST:
!
!   OUTPUT ARGUMENT LIST: 
!     PBLRI  - PBL HEIGHT ABOVE GROUND
!     
!   OUTPUT FILES:
!     NONE
!     
!   SUBPROGRAMS CALLED:
!     UTILITIES:
!       NONE
!     LIBRARY:
!       COMMON   - 
!                  CTLBLK
!     
!   ATTRIBUTES:
!     LANGUAGE: FORTRAN
!     MACHINE : 
!$$$  
!
      use vrbls3d, only: pmid, q, t, uh, vh, zmid
      use vrbls2d, only: fis
      use masks, only: vtm
      use params_mod, only: h10e5, capa, d608, h1, g, gi
      use ctlblk_mod, only: lm, im, jsta, jend, spval, jsta_m, jsta_2l, jend_2u, jend_m
      use gridspec_mod, only: gridtype
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      implicit none
!     
!     DECLARE VARIABLES.
!     
      real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: PBLRI

      REAL, ALLOCATABLE :: THV(:,:,:)
      INTEGER IFRSTLEV(IM,jsta_2l:jend_2u),ICALPBL(IM,jsta_2l:jend_2u)   &
             ,LVLP(IM,jsta_2l:jend_2u)
      REAL    RIF(IM,jsta_2l:jend_2u)                                    &
             ,RIBP(IM,jsta_2l:jend_2u),UBOT1(IM,jsta_2l:jend_2u)         &
             ,VBOT1(IM,jsta_2l:jend_2u),ZBOT1(IM,jsta_2l:jend_2u)        &
             ,THVBOT1(IM,jsta_2l:jend_2u)
      integer I,J,L,IE,IW
      real APE,BETTA,RICR,USTARR,WMIN,UHKL,ULKL,VHKL,VLKL,WNDSL,WNDSLP,  &
           UBOT,VBOT,VTOP,UTOP,THVTOP,ZTOP,WDL2,RIB
!     
!*************************************************************************
!     START CALRCHB HERE.
!     
      ALLOCATE ( THV(IM,JSTA_2L:JEND_2U,LM) )

!     INITIALIZE ARRAYS.
!
!$omp  parallel do private(i,j)
        DO J=JSTA,JEND
          DO I=1,IM
            PBLRI(I,J) = SPVAL
          ENDDO
        ENDDO
!
!     COMPUTE VIRTUAL POTENTIAL TEMPERATURE.
!
!$omp  parallel do private(i,j,l,ape)
      DO L=LM,1,-1
        DO J=JSTA,JEND
          DO I=1,IM
            APE        = (H10E5/PMID(I,J,L))**CAPA
            THV(I,J,L) = (Q(I,J,L)*D608+H1)*T(I,J,L)*APE
          ENDDO
        ENDDO
      ENDDO
!
!     COMPUTE BULK RICHARDSON NUMBER AS CODED IN GFS MODEL
!     AND RAOBS FOR VERIFICATION
!
!!$omp  parallel do
!!$omp& private(uhkl,ulkl,vhkl,vlkl,rib,ubot,utop,vbot,vtop,
!!$omp&         betta,ricr,ustarr,wmin,tvhtop,ztop,
!!$omp&         wndsl,wndslp,betta,ricr,ustarr,wmin 
!!$omp&       ,IFRSTLEV
!!$omp&       ,ICALPBL
!!$omp&       ,LVLP
!!$omp&       ,RIF
!!$omp&       ,RIBP
!!$omp&       ,UBOT1
!!$omp&       ,VBOT1
!!$omp&       ,ZBOT1
!!$omp&       ,THVBOT1)

!$omp  parallel do private(i,j)
      DO J=JSTA_M,JEND_M
        DO I=2,IM-1
           IFRSTLEV(I,J) = 0
           LVLP(I,J)     = LM
           ICALPBL(I,J)  = 0
        ENDDO
      ENDDO

      DO L = LM,2,-1

        BETTA  = 100.
        RICR   = 0.25
        USTARR = 0.1
        WMIN   = 0.01
!
        if(GRIDTYPE /= 'A') THEN
          call exch(VTM(1,jsta_2l,L))
          call exch(UH(1,jsta_2l,L))
          call exch(VH(1,jsta_2l,L))  
          call exch(VTM(1,jsta_2l,L-1))
          call exch(UH(1,jsta_2l,L-1))
          call exch(VH(1,jsta_2l,L-1))
        end if  
         
        DO J=JSTA_M,JEND_M
          DO I=2,IM-1
!
            RIF(I,J) = 0.
            IF(IFRSTLEV(I,J) == 0) THEN
              RIBP(I,J) = RIF(I,J)
            ENDIF

            IF(GRIDTYPE == 'A') THEN
              UBOT = UH(I,J,L)
              UTOP = UH(I,J,L-1)
              VBOT = VH(I,J,L)
              VTOP = VH(I,J,L-1)
            ELSE IF(GRIDTYPE == 'E') THEN
              IE = I+MOD(J+1,2) 
              IW = I+MOD(J+1,2)-1
!
!         WE NEED (U,V) WINDS AT A MASS POINT.  FOUR POINT
!         AVERAGE (U,V) WINDS TO MASS POINT.  NORMALIZE FOUR
!         POINT AVERAGE BY THE ACTUAL NUMBER OF (U,V) WINDS
!         USED IN THE AVERAGING.  VTM=1 IF WIND POINT IS
!         ABOVE GROUND.  VTM=0 IF BELOW GROUND.
!
              WNDSL  = VTM(I,J-1,L)+VTM(IW,J,L)+VTM(IE,J,L)+VTM(I,J+1,L)
              WNDSLP = VTM(I,J-1,L-1)+VTM(IW,J,L-1)+                       &
                       VTM(IE,J,L-1)+VTM(I,J+1,L-1)
              IF(WNDSL == 0. .OR. WNDSLP == 0.) cycle
              UBOT = (UH(I,J-1,L)+UH(IW,J,L)+UH(IE,J,L)+UH(I,J+1,L))/WNDSL  
              UTOP = (UH(I,J-1,L-1)+UH(IW,J,L-1)+UH(IE,J,L-1)+             &
                      UH(I,J+1,L-1))/WNDSLP
              VBOT = (VH(I,J-1,L)+VH(IW,J,L)+VH(IE,J,L)+VH(I,J+1,L))/WNDSL  
              VTOP = (VH(I,J-1,L-1)+VH(IW,J,L-1)+VH(IE,J,L-1)+             &
                      VH(I,J+1,L-1))/WNDSLP
            ELSE IF(GRIDTYPE == 'B')THEN
              IE=I 
              IW=I-1
              UBOT = (UH(IW,J-1,L)+UH(IW,J,L)+UH(IE,J-1,L)+UH(I,J,L))*0.25  
              UTOP = (UH(IW,J-1,L-1)+UH(IW,J,L-1)+UH(IE,J-1,L-1)+             &
                      UH(I,J,L-1))*0.25
              VBOT = (VH(IW,J-1,L)+VH(IW,J,L)+VH(IE,J-1,L)+VH(I,J,L))*0.25  
              VTOP = (VH(IW,J-1,L-1)+VH(IW,J,L-1)+VH(IE,J-1,L-1)+             &
                      VH(I,J,L-1))*0.25
            END IF

            IF(IFRSTLEV(I,J) == 0) THEN
              UBOT1(I,J)    = UBOT
              VBOT1(I,J)    = VBOT
              ZBOT1(I,J)    = ZMID(I,J,L)
              THVBOT1(I,J)  = THV(I,J,L)
              IFRSTLEV(I,J) = 1
            ENDIF

            THVTOP = THV(I,J,L-1)
            ZTOP   = ZMID(I,J,L-1)

!     
!         COMPUTE BULK RICHARDSON NUMBER.
!     
!  FOLLOWING VOGELEZANG AND HOLTSLAG (1996):

            WDL2 = (UTOP-UBOT1(I,J))**2 + (VTOP-VBOT1(I,J))**2 + WMIN**2
            RIB  = (G/THVBOT1(I,J))*(THVTOP-THVBOT1(I,J))*                  &
                   (ZTOP-ZBOT1(I,J))/(WDL2+BETTA*(USTARR**2))
!     
!         COMPUTE PBL HEIGHT
!     
! --------------------------------------------------------------------
!  IF BULK RICHARDSON NUMBER (RIB) EXCEEDS THE CRITICAL RICHARDSON
!  NUMBER (RICR), DETERMINE ABL HEIGHT USING LINEAR INTERPOLATION
!  BETWEEN HEIGHTS, AND PREVIOUS (RIBP) AND CURRENT (RIB) BULK
!  RICHARDSON NUMBERS.  L IS BOUNDARY-LAYER TOP LEVEL NUMBER.
! --------------------------------------------------------------------
            IF (RIB.GE.RICR.AND.ICALPBL(I,J).EQ.0) THEN
              PBLRI(I,J) = ZMID(I,J,L)+(ZMID(I,J,L-1)-ZMID(I,J,L))*      &
                           (RICR-RIBP(I,J))/(RIB-RIBP(I,J))
              ICALPBL(I,J) = 1

!-------- Extract surface height -----------------------------------

              PBLRI(I,J) = PBLRI(I,J)-FIS(I,J)*GI

            ENDIF
            
            RIBP(I,J) = RIB
            LVLP(I,J) = L-1
!
 10         CONTINUE
          ENDDO
        ENDDO
      ENDDO
!     
      DEALLOCATE (THV)
!     END OF ROUTINE.
!     
      RETURN
      END