*=*=*=*= LWB.html =*=*=*=*
SUBROUTINE LWB

SUBROUTINE LWB


       SUBROUTINE LWB ( KDLON,KFLEV,KMODE,KFLUX,KRAD
     S  , PDT0,PTAVE,PTL
     S  , PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
     S  , pga,pgb,pgab,pgbb )
      IMPLICIT LOGICAL (L)
C
#include "dimensions.h"
#include "dimphys.h"
#include "dimradmars.h"
C
C**** *LWB*   - COMPUTES BLACK-BODY FUNCTIONS FOR LONGWAVE CALCULATIONS
C
C     PURPOSE.
C     --------
C           COMPUTES PLANCK FUNCTIONS
C
C**   INTERFACE.
C     ----------
C      SUBROUTINE LWB ( KDLON,KFLEV,KAER,KMODE,KFLUX,KRAD
C    S  , PDT0,PTAVE,PTL
C    S  , PBINT,PBSUIN,PBSUR,PBTOP,PDBSL                   )
C
C        EXPLICIT ARGUMENTS :
C        --------------------
C     ==== INPUTS ===
C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
C     ==== OUTPUTS ===
C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
C PBSUR  : (KDLON,nir)        ; SURFACE SPECTRAL PLANCK FUNCTION
C PBTOP  : (KDLON,nir)        ; TOP SPECTRAL PLANCK FUNCTION
C PDBSL  : (KDLON,nir,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
C
C        IMPLICIT ARGUMENTS :   NONE
C        --------------------
C
C     METHOD.
C     -------
C
C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
c          2. Reindexs the Pade approximants
C
C     EXTERNALS.
C     ----------
C
C          NONE
C
C     REFERENCE.
C     ----------
C
C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "IN CORE MODEL"
C
C     AUTHOR.
C     -------
C        JEAN-JACQUES MORCRETTE  *ECMWF*
C
C     MODIFICATIONS.
C     --------------
C        ORIGINAL : 89-07-14
C-----------------------------------------------------------------------
C
#include "yomcst.h"
#include "yomrad.h"
#include "yomaer.h"
#include "yomlw.h"
#include "yomsw.h"
#include "yomrdu.h"
C     -----------------------------------------------------------------
C
C-----------------------------------------------------------------------
C
C*       0.1   ARGUMENTS
C              ---------
C
      REAL PDT0(NDLO2),PTAVE(NDLO2,KFLEV),PTL(NDLO2,KFLEV+1)

      REAL PBINT(NDLO2,KFLEV+1), PBSUIN(NDLO2), PBSUR(NDLO2,nir),
     S     PBTOP(NDLO2,nir), PDBSL(NDLO2,nir,KFLEV*2)

      REAL pga(NDLO2,3,2,kflev+1),pgb(NDLO2,3,2,kflev+1)
      REAL pgab(NDLO2,3,2,2),pgbb(NDLO2,3,2,2)

C-------------------------------------------------------------------------
C
C*       0.2   LOCAL ARRAYS
C              ------------
      REAL ZBLAY(NDLON,NFLEV),ZBLEV(NDLON,NFLEV+1)
      REAL ZRES(NDLON),ZRES2(NDLON),ZTI(NDLON),ZTI2(NDLON)
      INTEGER indt(ndlon)
c
      common/scratch/ZBLAY,ZBLEV
C
C     ------------------------------------------------------------------
C
C
C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
C                  ------------------------------
C
 100  CONTINUE
C
      DO 102 JK = 1 , KFLEV+1
      DO 101 JL = 1 , KDLON
      PBINT(JL,JK) = 0.
 101  CONTINUE
 102  CONTINUE
      DO 103 JL = 1 , KDLON
      PBSUIN(JL) = 0.
 103  CONTINUE
C
      DO 141 JNU=1,nir
C
C
C*         1.1   LEVELS FROM SURFACE TO KFLEV
C                ----------------------------
C
 110  CONTINUE
C
      DO 112 JK = 1 , KFLEV
      DO 111 JL = 1 , KDLON
      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
     S       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
     S       )))))
      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
      ZBLEV(JL,JK) = ZRES(JL)
      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
     S     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
     S       )))))
      ZBLAY(JL,JK) = ZRES2(JL)
 111  CONTINUE
 112  CONTINUE
C
C
C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
C                ---------------------------------
C
 120  CONTINUE
C
      DO 121 JL = 1 , KDLON
      ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
      ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
     S    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
     S       )))))
      ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
     S    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
     S       )))))
      PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
      ZBLEV(JL,KFLEV+1) = ZRES(JL)
      PBTOP(JL,JNU) = ZRES(JL)
      PBSUR(JL,JNU) = ZRES2(JL)
      PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
 121  CONTINUE
C
C
C*         1.3   GRADIENTS IN SUB-LAYERS
C                -----------------------
C
 130  CONTINUE
C
      DO 132 JK = 1 , KFLEV
      JK2 = 2 * JK
      JK1 = JK2 - 1
      DO 131 JL = 1 , KDLON
      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
 131  CONTINUE
 132  CONTINUE
C
 141  CONTINUE
C
C-----------------------------------------------------------------------
C*         3.    PRESSURE-WEIGHTED TEMPERATURE AND TRANSMISSIVITY INDEX
C                ------------------------------------------------------
C
 300  CONTINUE
C
c   atmosphere:
c   -----------

      jplk=2
      DO jk=1,kflev+1
         DO jl=1,kdlon
            indt(jl)=INT((ptl(jl,jk)-tmin_pade)/dt_pade+2.)
         ENDDO
         DO jl=1,kdlon
            indt(jl)=MAX0(MIN0(indt(jl),nt_pade),1)
         ENDDO
         DO ja=1,2
            DO jl=1,kdlon
               DO jpad=1,3
                  pga(jl,jpad,ja,jk)=ga(jpad,ja,jplk,indt(jl))
                  pgb(jl,jpad,ja,jk)=gb(jpad,ja,jplk,indt(jl))
               ENDDO
            ENDDO
         ENDDO
      ENDDO

c   surface:
c   --------

      jplk=1
      DO jl=1,kdlon
         indt(jl)=INT((ptl(jl,1)-tmin_pade)/dt_pade+2.)
      ENDDO
      DO jl=1,kdlon
         indt(jl)=MAX0(MIN0(indt(jl),nt_pade),1)
      ENDDO
      DO ja=1,2
         DO jl=1,kdlon
            DO jpad=1,3
               pgab(jl,jpad,ja,1)=ga(jpad,ja,jplk,indt(jl))
               pgbb(jl,jpad,ja,1)=gb(jpad,ja,jplk,indt(jl))
            ENDDO
         ENDDO
      ENDDO
C
c   top of atmosphere:
c   ------------------

      jplk=1
      DO jl=1,kdlon
         indt(jl)=INT((ptl(jl,kflev+1)-tmin_pade)/dt_pade+2.)
      ENDDO
      DO jl=1,kdlon
         indt(jl)=MAX0(MIN0(indt(jl),nt_pade),1)
      ENDDO
      DO ja=1,2
         DO jl=1,kdlon
            DO jpad=1,3
               pgab(jl,jpad,ja,2)=ga(jpad,ja,jplk,indt(jl))
               pgbb(jl,jpad,ja,2)=gb(jpad,ja,jplk,indt(jl))
            ENDDO
         ENDDO
      ENDDO

C     ------------------------------------------------------------------
C
      RETURN
      END