SUBROUTINE LWBTL &
 & ( KIDIA, KFDIA, KLON  , KLEV  , KMODE,&
 & PGA   , PGB   , PGASUR, PGBSUR, PGATOP, PGBTOP, &
 & PDT05 , PTAVE5, PTL5  ,&
 & PB5   , PBINT5, PBSUR5, PBTOP5, PDBSL5,&
 & PDT0  , PTAVE , PTL   ,&
 & PB    , PBINT , PBSUR , PBTOP , PDBSL &
 & )

!**** *LWBTL*   - COMPUTES BLACK-BODY FUNCTIONS FOR LONGWAVE CALCULATIONS
!                      (tangent linear)

!     PURPOSE.
!     --------
!           COMPUTES PLANCK FUNCTIONS

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

!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===
!  Trajectory  Perturbation  Description                         Dimension
!  PDT05       PDT0          SURFACE TEMPERATURE DISCONTINUITY   (KLON)
!  PTAVE5      PTAVE         TEMPERATURE                         (KLON,KLEV)
!  PTL5        PTL           HALF LEVEL TEMPERATURE              (KLON,KLEV+1)

!     ==== OUTPUTS ===
!  Trajectory  Perturbation  Description                         Dimension
!  PB5         PB            SPECTRAL HALF-LEVEL PLANCK
!                            FUNCTIONS                       (KLON,NSIL,KLEV+1)
!  PBINT5      PBINT         HALF-LEVEL PLANCK FUNCTIONS          (KLON,KLEV+1)
!  PBSUR5      PBSUR         SPECTRAL SURFACE PLANCK FUNCTION     (KLON,NSIL)
!  PBTOP5      PBTOP         SPECTRAL T.O.A. PLANCK FUNCTION      (KLON,NSIL)
!  PDBSL5      PDBSL         SUB-LAYER PLANCK FUNCTION GRADIENT   (KLON,KLEV*2)
!  PGA         ---           PADE APPROXIMANTS               (KLON,NIPD,2,KLEV)
!  PGB         ---           PADE APPROXIMANTS               (KLON,NIPD,2,KLEV)
!  PGASUR      ---           SURFACE PADE APPROXIMANTS            (KLON,NIPD,2)
!  PGBSUR      ---           SURFACE PADE APPROXIMANTS            (KLON,NIPD,2)
!  PGATOP      ---           T.O.A. PADE APPROXIMANTS             (KLON,NIPD,2)
!  PGBTOP      ---           T.O.A. PADE APPROXIMANTS             (KLON,NIPD,2)

!        IMPLICIT ARGUMENTS :   NONE
!        --------------------

!     METHOD.
!     -------

!          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
!     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION

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

!          NONE

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

!        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "

!     AUTHOR.
!     -------
!        M. Janiskova  *ECMWF*       27-Jan-2006

!     MODIFICATIONS.
!     --------------

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

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOELW    , ONLY : MXIXT    ,NSIL     ,NIPD     ,PDGA     ,&
 & PDGB     ,TINTP    ,TSTAND   ,TSTP     ,XP  

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMODE
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGA(KLON,NIPD,2,KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGB(KLON,NIPD,2,KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGASUR(KLON,NIPD,2) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGBSUR(KLON,NIPD,2) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGATOP(KLON,NIPD,2) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGBTOP(KLON,NIPD,2) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDT05(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAVE5(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTL5(KLON,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PB5(KLON,NSIL,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBINT5(KLON,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBSUR5(KLON,NSIL) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBTOP5(KLON,NSIL) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDBSL5(KLON,NSIL,KLEV*2) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDT0(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAVE(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTL(KLON,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PB(KLON,NSIL,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBINT(KLON,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBSUR(KLON,NSIL) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBTOP(KLON,NSIL) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDBSL(KLON,NSIL,KLEV*2)

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

!*       0.1   ARGUMENTS
!              ---------

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

!              ------------
INTEGER(KIND=JPIM) :: INDB(KLON)   , INDS(KLON)
REAL(KIND=JPRB) :: ZBLAY(KLON,KLEV), ZBLEV(KLON,KLEV+1)
REAL(KIND=JPRB) :: ZTI(KLON)       , ZTI2(KLON)  
REAL(KIND=JPRB) :: ZBLAY5(KLON,KLEV), ZBLEV5(KLON,KLEV+1)
REAL(KIND=JPRB) :: ZTI5(KLON)       , ZTI25(KLON)

INTEGER(KIND=JPIM) :: ILEV2, INDSU, INDT, INDTO, INDTP, INUE, INUS,&
 & IXTOX, IXTX, JF, JG, JK, JK1, JK2, JL, JNU  

REAL(KIND=JPRB) :: ZDST15, ZDSTO15, ZDSTOX5, ZDSTX5
REAL(KIND=JPRB) :: ZITSTAND, ZITSTP
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

ZITSTAND = 1.0_JPRB/TSTAND
ZITSTP = 1.0_JPRB/TSTP

!*         1.0     PLANCK FUNCTIONS AND GRADIENTS
!                  ------------------------------

ILEV2=2*KLEV
INUS=1
INUE=NSIL
IF (KMODE == 2) THEN
  INUS=3
  INUE=4
ENDIF

DO JK = 1 , KLEV+1
  DO JL = KIDIA,KFDIA
    PBINT (JL,JK) = 0.0_JPRB
    PBINT5(JL,JK) = 0.0_JPRB
  ENDDO
ENDDO

DO JNU=1,NSIL
  DO JL=KIDIA,KFDIA
    PBSUR (JL,JNU) = 0.0_JPRB
    PBSUR5(JL,JNU) = 0.0_JPRB
    PBTOP (JL,JNU) = 0.0_JPRB
    PBTOP5(JL,JNU) = 0.0_JPRB
  ENDDO
  DO JK=1,KLEV
    DO JL=KIDIA,KFDIA
      PB (JL,JNU,JK) = 0.0_JPRB
      PB5(JL,JNU,JK) = 0.0_JPRB
    ENDDO
  ENDDO
  DO JK=1,ILEV2
    DO JL=KIDIA,KFDIA
      PDBSL (JL,JNU,JK) = 0.0_JPRB
      PDBSL5(JL,JNU,JK) = 0.0_JPRB
    ENDDO
  ENDDO
ENDDO

DO JNU=INUS,INUE

!*         1.1   LEVELS FROM SURFACE TO KLEV
!                ----------------------------

  DO JK = 1 , KLEV
    DO JL = KIDIA,KFDIA
      ZTI (JL) = PTL(JL,JK)*ZITSTAND
      ZTI5(JL) = (PTL5(JL,JK)-TSTAND)*ZITSTAND
      ZBLEV (JL,JK) = ZTI(JL)*(XP(2,JNU)+ZTI5(JL)*(2*XP(3,JNU) &
       &         + ZTI5(JL)*(3*XP(4,JNU)+ZTI5(JL)*(4*XP(5,JNU) &
       &         + ZTI5(JL)*(5*XP(6,JNU) )))))
      ZBLEV5(JL,JK) = XP(1,JNU)+ZTI5(JL)*(XP(2,JNU)+ZTI5(JL)*(XP(3,JNU)&
       &  + ZTI5(JL)*(XP(4,JNU)+ZTI5(JL)*(XP(5,JNU) &
       &  + ZTI5(JL)*(XP(6,JNU) )))))
      PBINT (JL,JK) = PBINT (JL,JK)+ZBLEV (JL,JK)
      PBINT5(JL,JK) = PBINT5(JL,JK)+ZBLEV5(JL,JK)
      PB (JL,JNU,JK) = ZBLEV (JL,JK)
      PB5(JL,JNU,JK) = ZBLEV5(JL,JK)
      ZTI2 (JL) = PTAVE(JL,JK)*ZITSTAND
      ZTI25(JL) = (PTAVE5(JL,JK)-TSTAND)*ZITSTAND
      ZBLAY (JL,JK) = ZTI2(JL)*(XP(2,JNU)+ZTI25(JL)*(2*XP(3,JNU) &
       &         + ZTI25(JL)*(3*XP(4,JNU)+ZTI25(JL)*(4*XP(5,JNU) &
       &         + ZTI25(JL)*(5*XP(6,JNU))))))
      ZBLAY5(JL,JK) = XP(1,JNU)+ZTI25(JL)*(XP(2,JNU)+ZTI25(JL)*(XP(3,JNU)&
       & + ZTI25(JL)*(XP(4,JNU)+ZTI25(JL)*(XP(5,JNU) &
       & + ZTI25(JL)*(XP(6,JNU) )))))  
    ENDDO
  ENDDO

!*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
!                ---------------------------------

  DO JL = KIDIA,KFDIA
    ZTI (JL) = PTL(JL,KLEV+1)*ZITSTAND
    ZTI5(JL) = (PTL5(JL,KLEV+1)-TSTAND)*ZITSTAND
    ZTI2 (JL) = (PTL (JL,1) + PDT0 (JL))*ZITSTAND
    ZTI25(JL) = (PTL5(JL,1) + PDT05(JL) - TSTAND) * ZITSTAND
    ZBLEV (JL,KLEV+1) = ZTI(JL)*(XP(2,JNU)+ZTI5(JL)*(2*XP(3,JNU) &
     &             + ZTI5(JL)*(3*XP(4,JNU)+ZTI5(JL)*(4*XP(5,JNU) &
     &             + ZTI5(JL)*(5*XP(6,JNU) )))))
    ZBLEV5(JL,KLEV+1) = XP(1,JNU)+ZTI5(JL)*(XP(2,JNU)+ZTI5(JL)*(XP(3,JNU)&
     &      + ZTI5(JL)*(XP(4,JNU)+ZTI5(JL)*(XP(5,JNU) &
     &      + ZTI5(JL)*(XP(6,JNU) )))))
    PBSUR (JL,JNU) = ZTI2(JL)*(XP(2,JNU)+ZTI25(JL)*(2*XP(3,JNU) &
     &          + ZTI25(JL)*(3*XP(4,JNU)+ZTI25(JL)*(4*XP(5,JNU) &
     &          + ZTI25(JL)*(5*XP(6,JNU))))))
    PBSUR5(JL,JNU) = XP(1,JNU)+ZTI25(JL)*(XP(2,JNU)+ZTI25(JL)*(XP(3,JNU)&
     &  + ZTI25(JL)*(XP(4,JNU)+ZTI25(JL)*(XP(5,JNU) &
     &  + ZTI25(JL)*(XP(6,JNU) )))))
    PBINT (JL,KLEV+1) = PBINT (JL,KLEV+1)+ZBLEV (JL,KLEV+1)
    PBINT5(JL,KLEV+1) = PBINT5(JL,KLEV+1)+ZBLEV5(JL,KLEV+1)
    PB (JL,JNU,KLEV+1) = ZBLEV (JL,KLEV+1)
    PB5(JL,JNU,KLEV+1) = ZBLEV5(JL,KLEV+1)
    PBTOP (JL,JNU) = ZBLEV (JL,KLEV+1)
    PBTOP5(JL,JNU) = ZBLEV5(JL,KLEV+1)
  ENDDO

!*         1.3   GRADIENTS IN SUB-LAYERS
!                -----------------------

  DO JK = 1 , KLEV
    JK2 = 2 * JK
    JK1 = JK2 - 1
    DO JL = KIDIA,KFDIA
      PDBSL (JL,JNU,JK1) = ZBLAY (JL,JK) - ZBLEV (JL,JK)
      PDBSL5(JL,JNU,JK1) = ZBLAY5(JL,JK) - ZBLEV5(JL,JK)
      PDBSL (JL,JNU,JK2) = ZBLEV (JL,JK+1) - ZBLAY (JL,JK)
      PDBSL5(JL,JNU,JK2) = ZBLEV5(JL,JK+1) - ZBLAY5(JL,JK)
    ENDDO
  ENDDO

ENDDO

!*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
!                ---------------------------------------------

DO JL=KIDIA,KFDIA
  ZDSTO15 = (PTL5(JL,KLEV+1)-TINTP(1)) * ZITSTP
  IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO15 + 1.0_JPRB ) ) )
  ZDSTOX5 = (PTL5(JL,KLEV+1)-TINTP(IXTOX))*ZITSTP
  IF (ZDSTOX5 < 0.5_JPRB) THEN
    INDTO=IXTOX
  ELSE
    INDTO=IXTOX+1
  ENDIF
  INDB(JL)=INDTO
  ZDST15 = (PTL5(JL,1)-TINTP(1)) * ZITSTP
  IXTX = MAX( 1, MIN( MXIXT, INT( ZDST15 + 1.0_JPRB ) ) )
  ZDSTX5 = (PTL5(JL,1)-TINTP(IXTX))*ZITSTP
  IF (ZDSTX5 < 0.5_JPRB) THEN
    INDT=IXTX
  ELSE
    INDT=IXTX+1
  ENDIF
  INDS(JL)=INDT
ENDDO

DO JF=1,2
  DO JG=1,NIPD
    DO JL=KIDIA,KFDIA
      INDSU=INDS(JL)
      PGASUR(JL,JG,JF)=PDGA(INDSU,2*JG-1,JF)
      PGBSUR(JL,JG,JF)=PDGB(INDSU,2*JG-1,JF)
      INDTP=INDB(JL)
      PGATOP(JL,JG,JF)=PDGA(INDTP,2*JG-1,JF)
      PGBTOP(JL,JG,JF)=PDGB(INDTP,2*JG-1,JF)
    ENDDO
  ENDDO
ENDDO

DO JK=1,KLEV
  DO JL=KIDIA,KFDIA
    ZDST15 = (PTAVE5(JL,JK)-TINTP(1)) * ZITSTP
    IXTX = MAX( 1, MIN( MXIXT, INT( ZDST15 + 1.0_JPRB ) ) )
    ZDSTX5 = (PTAVE5(JL,JK)-TINTP(IXTX))*ZITSTP
    IF (ZDSTX5 < 0.5_JPRB) THEN
      INDT=IXTX
    ELSE
      INDT=IXTX+1
    ENDIF
    INDB(JL)=INDT
  ENDDO

  DO JF=1,2
    DO JL=KIDIA,KFDIA
      INDT=INDB(JL)
      DO JG=1,NIPD
        PGA(JL,JG,JF,JK)=PDGA(INDT,2*JG,JF)
        PGB(JL,JG,JF,JK)=PDGB(INDT,2*JG,JF)
      ENDDO
    ENDDO
  ENDDO

ENDDO

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

IF (LHOOK) CALL DR_HOOK('LWBTL',1,ZHOOK_HANDLE)
END SUBROUTINE LWBTL
