SUBROUTINE SUJBVCOORD (KNUMB,KSTGLO,PTT0,PQT0,PSPT0)

!**** *SUJBVCOORD*  - ROUTINE FOR CALCULATING PRESSURE ON Jb VERTICAL
!****                 LEVELS.

!     PURPOSE.
!     --------

!        CALCULATE PRESSURE ON Jb VERTICAL LEVELS.

!**   INTERFACE.
!     ----------

!        *CALL* *SUJBVCOORD (..)*

!        INPUT:
!           *PTT0*    - FIRST GUESS TEMPERATURE
!           *PTT0*    - FIRST GUESS SPECIFIC HUMIDITY
!           *PSPT0*   - FIRST GUESS SURFACE PRESSURE

!        IMPLICIT OUTPUT:
!                      INDICES LOCATING MODEL LEVLES IN THE Jb VERTICAL GRID
!                      AND VICE VERSA ARE WRITTEN TO GPBUF_JBVCOORD.

!     METHOD.
!     -------

!     EXTERNALS.
!     ----------

!     REFERENCE.
!     ----------

!        ECMWF Research Department documentation of the IFS

!     AUTHOR.
!     -------

!        M. Fisher    *ECMWF*

!     MODIFICATIONS.
!     --------------
!        00/10/26 M. Fisher : Boundary layer top is a coordinate surface
!        R. El Khatib : 01-08-07 Pruning options
!        Modified 04-02-06: Y. Seity : new arguments to GPRCP
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!        M.Hamrud  15-Jan-2006  Revised GPRCP
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMDIM   , ONLY : NFLEVG, NPROMA
USE YOMCST   , ONLY : RKAPPA, RG
USE YOMGEM   , ONLY : VBH, VAH, VC, VDELB
USE YOMFCEB  , ONLY : GPBUF_JBVCOORD, BLTOP
USE YOMLUN   , ONLY : NULERR

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KNUMB 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSTGLO 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTT0(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQT0(NPROMA,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSPT0(NPROMA) 

!     ------------------------------------------------------------------

REAL(KIND=JPRB)                :: ZP_JBVCOORD (NPROMA,NFLEVG), &
 & ZP_MODEL(NPROMA,NFLEVG), &
 & ZLEVEL(NPROMA,NFLEVG),ZBUF(NPROMA,NFLEVG,2)  

REAL(KIND=JPRB) :: ZPRSH  (NPROMA,0:NFLEVG), ZDELP0(NPROMA,0:NFLEVG+1), &
 & ZRDELP0(NPROMA,NFLEVG  ), ZLNPR0(NPROMA,NFLEVG    ), &
 & ZALPH0 (NPROMA,NFLEVG  ), ZRTGR0(NPROMA,NFLEVG    ), &
 & ZRPRE0 (NPROMA,NFLEVG  ), ZRPP0 (NPROMA,NFLEVG    ), &
 & ZR0    (NPROMA,NFLEVG  ), &
 & ZPHI0 (NPROMA,0:NFLEVG  ), &
 & ZPHIF0 (NPROMA,NFLEVG  )   

REAL(KIND=JPRB) :: ZAH(0:NFLEVG),ZBH(0:NFLEVG),ZCH(0:NFLEVG),ZDH(0:NFLEVG)
REAL(KIND=JPRB) :: ZA(NFLEVG),ZB(NFLEVG),ZC(NFLEVG),ZD(NFLEVG),ZVA(NFLEVG),ZVB(NFLEVG)
REAL(KIND=JPRB) :: ZP1(NPROMA),ZP2(NPROMA),ZP3(NPROMA)
REAL(KIND=JPRB) :: ZF1(NPROMA),ZF2(NPROMA),ZF3(NPROMA)
REAL(KIND=JPRB) :: ZALPHA(NPROMA),ZPBLTOP(NPROMA), ZT_OF_P(NPROMA)

INTEGER(KIND=JPIM) :: IABOVE(NPROMA),IBRAC1(NPROMA),IBRAC2(NPROMA)

INTEGER(KIND=JPIM) :: IEND, IENDC, IST, ISTC, JLEV, JROF, ITER, J, IBLLEV

INTEGER(KIND=JPIM), PARAMETER :: JPMAXIT=30
REAL(KIND=JPRB) ,   PARAMETER :: PPTOL=1E-6_JPRB
REAL(KIND=JPRB) ,   PARAMETER :: PPMAXBLH=4500.0_JPRB


REAL(KIND=JPRB) :: ZTEST
REAL(KIND=JPRB) :: ZHOOK_HANDLE
 
!     ------------------------------------------------------------------

#include "abor1.intfb.h"
#include "gpgeo.intfb.h"
#include "gppreh.intfb.h"
#include "gprcp.intfb.h"
#include "gpxyb.intfb.h"
#include "sc2wrg.intfb.h"
#include "get_jbvcoord_coeffs.intfb.h"

!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('SUJBVCOORD',0,ZHOOK_HANDLE)

!     ------------------------------------------------------------------

!      Calculate coefficients for full levels from half-level coefficients

CALL GET_JBVCOORD_COEFFS (ZAH,ZBH,ZCH,ZDH,IBLLEV)

ZVA(:) = 0.5_JPRB * (VAH(0:NFLEVG-1) + VAH(1:NFLEVG))
ZVB(:) = 0.5_JPRB * (VBH(0:NFLEVG-1) + VBH(1:NFLEVG))
ZA(:)  = 0.5_JPRB * (ZAH(0:NFLEVG-1) + ZAH(1:NFLEVG))
ZB(:)  = 0.5_JPRB * (ZBH(0:NFLEVG-1) + ZBH(1:NFLEVG))
ZC(:)  = 0.5_JPRB * (ZCH(0:NFLEVG-1) + ZCH(1:NFLEVG))
ZD(:)  = 0.5_JPRB * (ZDH(0:NFLEVG-1) + ZDH(1:NFLEVG))

!      Find out which gridpoints to process.

IST   = 1
IEND  = KNUMB
ISTC  = 1
IENDC = KNUMB

!      Calculate surface pressure and pressure on model half-levels

ZPRSH(IST:IEND,NFLEVG)= EXP(PSPT0(IST:IEND))

CALL GPPREH (NPROMA,IST,IEND,NFLEVG,VAH,VBH,ZPRSH)

!      Calculate geopotential (minus orography)

CALL GPXYB (NPROMA,IST,IEND,NFLEVG,VDELB,VC, &
 & ZPRSH,ZDELP0(1,1),ZRDELP0,ZLNPR0,ZALPH0,ZRTGR0, &
 & ZRPRE0,ZRPP0)  

CALL GPRCP(NPROMA,IST,IEND,NFLEVG,PQ=PQT0,PR=ZR0)

ZPHI0(IST:IEND,NFLEVG) = 0.0_JPRB
CALL GPGEO(NPROMA,IST,IEND,NFLEVG,ZPHI0,ZPHIF0,PTT0,ZR0,ZLNPR0,ZALPH0)

!      Limit the boundary layer height to below PPMAXBLH

DO JROF=IST,IEND
  BLTOP(KSTGLO-1+JROF)=MIN(PPMAXBLH,BLTOP(KSTGLO-1+JROF))
ENDDO

!      Convert boundary layer height to pressure

IBRAC1(IST:IEND) = NFLEVG
DO JLEV=NFLEVG-1,0,-1
  DO JROF=IST,IEND
    IF (BLTOP(KSTGLO-1+JROF)*RG > ZPHI0(JROF,JLEV)) IBRAC1(JROF) = JLEV
  ENDDO
ENDDO

IF (MINVAL(IBRAC1(IST:IEND))<1) &
 & CALL ABOR1 ('SUJBVCOORD: BOUNDARY LAYER TOP IS ABOVE TOP OF MODEL')  

DO JROF=IST,IEND
  ZTEST = (BLTOP(KSTGLO-1+JROF)*RG    - ZPHI0(JROF,IBRAC1(JROF))) &
   & /(ZPHI0(JROF,IBRAC1(JROF)-1) - ZPHI0(JROF,IBRAC1(JROF)))  
  ZPBLTOP(JROF) = ZPRSH(JROF,IBRAC1(JROF)) &
   & *(( ZPRSH(JROF,IBRAC1(JROF))/ZPRSH(JROF,IBRAC1(JROF)-1) )**ZTEST)  
ENDDO

!      Limit the boundary layer top to above the half-level NFLEVG-1.

ZPBLTOP(IST:IEND) = MIN(ZPRSH(IST:IEND,NFLEVG-1),ZPBLTOP(IST:IEND))

!      Calculate pressure on model full-levels

DO JLEV=1,NFLEVG
  ZP_MODEL(IST:IEND,JLEV) = ZVA(JLEV) + ZVB(JLEV)*ZPRSH(IST:IEND,NFLEVG)
ENDDO

!      The top and bottom Jb vertical levels are coincident with
!      the top and bottom model levels

ZP_JBVCOORD(IST:IEND,1)      = ZP_MODEL(IST:IEND,1)
ZP_JBVCOORD(IST:IEND,NFLEVG) = ZP_MODEL(IST:IEND,NFLEVG)

!      Levels above the boundary layer have to be located by root finding
!      for the function:
!             f(p) = p*(ZD(JLEV)+ZC(JLEV)*( T(p)**(-1./RKAPPA) ) )
!                   - ZA(JLEV) - ZB(JLEV)*ZPRSH(JROF,NFLEVG)
!      The root-finding algorithm is bisection (because it vectorizes)

LEVEL_LOOP: DO JLEV=2,IBLLEV

!      Initial brackets and function values at the brackets

  IBRAC1(IST:IEND) = 1
  ZP1(IST:IEND) = ZP_JBVCOORD(IST:IEND,1)
  ZF1(:) = LEVEL_FUNCTION (ZP1(:),JLEV,PTT0(:,1))

  IBRAC2(IST:IEND) = NFLEVG
  ZP2(IST:IEND) = ZP_JBVCOORD(IST:IEND,NFLEVG)
  ZF2(:) = LEVEL_FUNCTION (ZP2(:),JLEV,PTT0(:,NFLEVG))

!      Initial trial point

  ZP3(IST:IEND) = SQRT(ZP1(IST:IEND)*ZP2(IST:IEND))

  ITER=0
  BISECTION: DO

!      Function value at initial trial point

    IABOVE(IST:IEND) = 0

    DO J=MINVAL(IBRAC1(IST:IEND)),MAXVAL(IBRAC2(IST:IEND))-1
      DO JROF=IST,IEND
        ZTEST = (ZP3(JROF)-ZP_MODEL(JROF,J)) &
         & /(ZP_MODEL(JROF,J+1)-ZP_MODEL(JROF,J))  
        IF (ZTEST <= 1.0_JPRB .AND. ZTEST >= 0.0_JPRB ) THEN
          ZALPHA(JROF) = ZTEST
          IABOVE(JROF) = J
        ENDIF
      ENDDO
    ENDDO

    IF (ANY(IABOVE(IST:IEND) == 0)) CALL ABOR1 ('INTERPOLATION FAILED')

    DO JROF=IST,IEND
      ZT_OF_P(JROF) = ZALPHA(JROF)*PTT0(JROF,IABOVE(JROF)+1)  &
       & +(1.0_JPRB -ZALPHA(JROF))*PTT0(JROF,IABOVE(JROF))  
    ENDDO

    ZF3(:) = LEVEL_FUNCTION (ZP3(:),JLEV,ZT_OF_P(:))

!      Move the lower brackets

    WHERE (ZF1(IST:IEND)*ZF3(IST:IEND) <= 0.0_JPRB )
      ZP2(IST:IEND) = ZP3(IST:IEND)
      ZF2(IST:IEND) = ZF3(IST:IEND)
      IBRAC2(IST:IEND) = IABOVE(IST:IEND) +1
    ENDWHERE

!      Move the upper brackets

    WHERE (ZF2(IST:IEND)*ZF3(IST:IEND) <= 0.0_JPRB )
      ZP1(IST:IEND) = ZP3(IST:IEND)
      ZF1(IST:IEND) = ZF3(IST:IEND)
      IBRAC1(IST:IEND) = IABOVE(IST:IEND)
    ENDWHERE

!      New trial point

    ZP3(IST:IEND) = SQRT(ZP1(IST:IEND)*ZP2(IST:IEND))

    IF ( MAXVAL((ZP2(IST:IEND)-ZP1(IST:IEND))/ZP3(IST:IEND)) < PPTOL ) &
     & EXIT BISECTION  

    IF ( MAXVAL(ZF1(IST:IEND)*ZF2(IST:IEND)) > 0.0_JPRB ) THEN
      CALL ABOR1 ('SUJBVCOORD: BRACKETS DON''T BRACKET')
    ENDIF

    IF (ITER > JPMAXIT) THEN
      WRITE(NULERR,*)'TOO MANY ITERATIONS: ITER=',ITER,' JLEV=',JLEV
      CALL ABOR1 ('TOO MANY ITERATIONS IN SUJBVCOORD')
    ENDIF
    ITER = ITER+1
  ENDDO BISECTION

  ZP_JBVCOORD(IST:IEND,JLEV) = ZP3(IST:IEND)
ENDDO LEVEL_LOOP

!       In the boundary layer, levels are evenly spaced in log(p)

DO JLEV=IBLLEV+1,NFLEVG-1
  ZP_JBVCOORD(IST:IEND,JLEV) = ZPBLTOP(IST:IEND)                   &
   & *( (ZP_JBVCOORD(IST:IEND,NFLEVG)/ZPBLTOP(IST:IEND)) &
   & **( (REAL(JLEV-IBLLEV  ,JPRB)-0.5_JPRB)           &
   & /(REAL(NFLEVG-IBLLEV,JPRB)-0.5_JPRB)) )  

ENDDO

!       Check that ZP_JBVCOORD increases with level number.

DO JROF=IST,IEND
  IF (MAXVAL( ZP_JBVCOORD(JROF,1:NFLEVG-1) &
     & -ZP_JBVCOORD(JROF,2:NFLEVG  ))>0.0_JPRB) then  

    WRITE (NULERR,*) 'ERROR: Jb vertical levels are not monotonic'
    WRITE (NULERR,*) 'Example profile at jrof=',jrof,' jlev=',jlev, &
     & ' surface pressure=',ZPRSH(jrof,NFLEVG), &
     & ' BL top  pressure=',ZPBLTOP(jrof), &
     & ' pressure profile=',ZP_JBVCOORD(jrof,:)  

    CALL ABOR1 ('ERROR: Jb vertical levels are not monotonic')
  ENDIF
ENDDO

!       We now have pressures on model levels in ZP_MODEL, and pressures on
!       Jb vertical levels in ZP_JBVCOORD.
!       Calculate in ZBUF(:,:,1) where each model level lies with respect to
!       the Jb vertical grid. Calculate in ZBUF(:,:,2) where each Jb vertical
!       level lies with respect to the model grid.

DO JLEV=1,NFLEVG
  ZLEVEL(IST:IEND,JLEV) = REAL(JLEV,JPRB)
ENDDO

ZBUF(IST:IEND,     1,1) = 1.0_JPRB
ZBUF(IST:IEND,NFLEVG,1) = REAL(NFLEVG,JPRB)
ZBUF(IST:IEND,     1,2) = 1.0_JPRB
ZBUF(IST:IEND,NFLEVG,2) = REAL(NFLEVG,JPRB)

DO JLEV=2,NFLEVG-1
  ZBUF(:,JLEV,1) = T_INTERP (ZP_MODEL(:,JLEV),ZP_JBVCOORD,ZLEVEL)
  ZBUF(:,JLEV,2) = T_INTERP (ZP_JBVCOORD(:,JLEV),ZP_MODEL,ZLEVEL)
ENDDO

!       Write fractional model level to the buffer

CALL SC2WRG (GPBUF_JBVCOORD,KSTGLO,ISTC,IENDC,ZBUF)

IF (LHOOK) CALL DR_HOOK('SUJBVCOORD',1,ZHOOK_HANDLE)

CONTAINS
FUNCTION LEVEL_FUNCTION (P_ZP,KLEV,P_ZT)
REAL(KIND=JPRB), DIMENSION(NPROMA) :: LEVEL_FUNCTION

!   This function defines the Jb vertical coordinates by
!   having a single root at the pressure on Jb-level JLEV.

REAL(KIND=JPRB),INTENT(IN)    :: P_ZP(NPROMA), P_ZT(NPROMA)
INTEGER(KIND=JPIM),INTENT(IN) :: KLEV
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('SUJBVCOORD:LEVEL_FUNCTION',0,ZHOOK_HANDLE)
LEVEL_FUNCTION(IST:IEND) = &
 & P_ZP(IST:IEND)*( ZD(KLEV) + ZC(KLEV)*(P_ZT**(-1./RKAPPA)) ) &
 & -ZA(KLEV) -ZB(KLEV)*ZPBLTOP(IST:IEND)  

IF (LHOOK) CALL DR_HOOK('SUJBVCOORD:LEVEL_FUNCTION',1,ZHOOK_HANDLE)
END FUNCTION LEVEL_FUNCTION

FUNCTION T_INTERP (P_ZP,P_ZP_MODEL,P_ZT)
REAL(KIND=JPRB), DIMENSION(NPROMA) :: T_INTERP

REAL(KIND=JPRB),    INTENT(IN) :: P_ZP(NPROMA), P_ZP_MODEL(NPROMA,NFLEVG), &
 & P_ZT(NPROMA,NFLEVG)  
INTEGER(KIND=JPIM) :: IUP, JJROF
REAL(KIND=JPRB)    :: ZALPH, ZTEST
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('SUJBVCOORD:T_INTERP',0,ZHOOK_HANDLE)
DO JJROF=IST,IEND
  IUP = 0
  ZTEST  = 0.0_JPRB
  DO J=1,NFLEVG-1
    ZTEST = (P_ZP(JJROF)-P_ZP_MODEL(JJROF,J)) &
     & /(P_ZP_MODEL(JJROF,J+1)-P_ZP_MODEL(JJROF,J))  
    IF (ZTEST <= 1.0_JPRB .AND. ZTEST >= 0.0_JPRB ) THEN
      ZALPH = ZTEST
      IUP   = J
    ENDIF
  ENDDO
  IF (IUP == 0) THEN
    WRITE (NULERR,*) 'VERTICAL INTERPOLATION FAILED: P_ZP=',P_ZP(JJROF),&
     & ' P_ZP_MODEL=',P_ZP_MODEL(JJROF,:)  
    CALL ABOR1 ('INTERPOLATION FAILED')
  ENDIF

  T_INTERP(JJROF) = ZALPH*P_ZT(JJROF,IUP+1) + (1.0_JPRB -ZALPH)*P_ZT(JJROF,IUP)
ENDDO

IF (MINVAL(T_INTERP(IST:IEND)) < 0.0_JPRB ) THEN
  call abor1 ('SUJBVCOORD: negative T_INTERP')
ENDIF
IF (LHOOK) CALL DR_HOOK('SUJBVCOORD:T_INTERP',1,ZHOOK_HANDLE)
END FUNCTION T_INTERP

END SUBROUTINE SUJBVCOORD
