*=*=*=*= LWVB.html =*=*=*=*
SUBROUTINE LWVB

SUBROUTINE LWVB


      SUBROUTINE LWVB ( KDLON,KFLEV,KUAER,KTRAER
     S  , pgab,pgbb
     S  , PABCUCO2,PABCUAER,PADJD,PADJU,PBINT,PBSUI,PBSUR,PBTOP
     S  , PDISD,PDISU,PEMIS
     S  , PBHDD,PBSDD
     S  , PCTS,PHFG,PFLUC                     )
      IMPLICIT LOGICAL (L)
C
#include "dimensions.h"
#include "dimphys.h"
#include "dimradmars.h"
C
C**** *LWVB*   - L.W., VERTICAL INTEGRATION, EXCHANGE WITH BOUNDARIES
C
C     PURPOSE.
C     --------
C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
C           INTEGRATION
C
C**   INTERFACE.
C     ----------
C     SUBROUTINE LWVB ( KDLON,KFLEV,KUAER,KTRAER
C    S  , KXTSU,KXTTP
C    S  , PABCUCO2,PABCUAER,PADJD,PADJU,PBINT,PBSUI,PBSUR,PBTOP
C    S  , PDISD,PDISU,PEMIS
C    S  , PBHDD,PBSDD
C    S  , PCTS,PHFG,PFLUC                     )
C
C        EXPLICIT ARGUMENTS :
C        --------------------
C     ==== INPUTS ===
C KX...    (KDLON,...          ; TEMPERATURE INDICES
C PABCUCO2 : (KDLON,NUACO2,3*KFLEV+1); ABSORBER AMOUNTS (CO2)
C PABCUAER : (KDLON,NIR,3*KFLEV+1); ABSORBER AMOUNTS (AEROSOLS)
C PADJ.. : (KDLON,KFLEV+1)     ; CONTRIBUTION BY ADJACENT LAYERS
C PBINT  : (KDLON,KFLEV+1)     ; HALF-LEVEL PLANCK FUNCTIONS
C PBSUI  : (KDLON)             ; SURFACE PLANCK FUNCTION
C PBSUR  : (KDLON,nir)        ; SURFACE SPECTRAL PLANCK FUNCTION
C PBTOP  : (KDLON,nir)        ; T.O.A. SPECTRAL PLANCK FUNCTION
C PDIS.. : (KDLON,KFLEV+1)     ; CONTRIBUTION BY DISTANT LAYERS
C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
C PBHDD  : (KDLON,KFLEV*2+1)   ; PLANCK FUNCTION AT TOP OF HALF LAYERS (diffusio
C PBSDD  : (KDLON)             ; PLANCK FUNCTION AT GROUND (diffusion)
C     ==== OUTPUTS ===
C PCTS   : (KDLON,KFLEV)       ; COOLING-TO-SPACE TERM
C PHFG   : (KDLON,KFLEV)       ; HEATING-FROM-GROUND TERM
C  IF KMODE = 0, 1, 2
C PFLUC(KDLON,2,KFLEV)         ; RADIATIVE FLUXES CLEAR-SKY:
C                     1  ==>  UPWARD   FLUX TOTAL
C
C        IMPLICIT ARGUMENTS :   NONE
C        --------------------
C
C     METHOD.
C     -------
C
C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
C     ATMOSPHERE
C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
C
C     EXTERNALS.
C     ----------
C
C          *LWTT*
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
c! modif diffusion
c! on ne prend en compte que les deux bandes du CO2.
c! le probleme devient betement d'enlever les Planck cumules hors
c! CO2 aux Planck total pour retrouver les Planck du CO2 seul.
c!
C
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 pgab(NDLO2*2*3,2),pgbb(NDLO2*2*3,2)

      REAL PABCUCO2(NDLO2,NUACO2,3*KFLEV+1)
      REAL PABCUAER(NDLO2,nir,3*KFLEV+1)
     S  ,  PADJD(NDLO2,KFLEV+1), PADJU(NDLO2,KFLEV+1)
     S  ,  PBINT(NDLO2,KFLEV+1)
     S  ,  PBSUR(NDLO2,nir), PBSUI(NDLO2), PBTOP(NDLO2,nir)
     S  ,  PDISD(NDLO2,KFLEV+1), PDISU(NDLO2,KFLEV+1)
     S  ,  PEMIS(NDLO2)
     S  ,  PBHDD(NDLO2,KFLEV*2+1),PBSDD(NDLO2)
C, PTAVE(NDLO2,KFLEV)
C
      REAL PFLUC(NDLO2,2,KFLEV+1)
     S  ,  PCTS(NDLO2,KFLEV),PHFG(NDLO2,KFLEV)
C
C-------------------------------------------------------------------------
C
C*       0.2   LOCAL ARRAYS
C              ------------
C
      REAL ZBGND(NDLON), ZFD(NDLON), ZFDN(NDLON,NFLEV+1)
     S  ,  ZFU(NDLON), ZFUP(NDLON,NFLEV+1)
     S  ,  ZTT(NDLON,NTRA), ZTT1(NDLON,NTRA), ZTT2(NDLON,NTRA)
     S  ,  ZUU(NDLON,NUA)
C
C-----------------------------------------------------------------------
C
C*         1.    INITIALIZATION
C                --------------
C
 100  CONTINUE
C
C
C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
C                  ---------------------------------
C
 120  CONTINUE
C
      DO 122 JA = 1 , NTRA
      DO 121 JL = 1 , KDLON
      ZTT (JL,JA) = 1.0
      ZTT1(JL,JA) = 1.0
      ZTT2(JL,JA) = 1.0
 121  CONTINUE
 122  CONTINUE
C
      DO 124 JA = 1 , NUA
      DO 123 JL = 1 , KDLON
      ZUU(JL,JA) = 0.
 123  CONTINUE
 124  CONTINUE
C
C     ------------------------------------------------------------------
C
C*         2.      VERTICAL INTEGRATION
C                  --------------------
C
 200  CONTINUE
C
      IND1=0
      IND3=0
      IND4=1
      IND2=1
C
C
C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
C                  -----------------------------------
C
 230  CONTINUE
C
      DO 235 JK = 1 , KFLEV+1
      KN=(JK-1)*NG1P1+1
C
      DO 232 JA = 1 , 4
      DO 231 JL = 1 , KDLON
      ZUU(JL,JA) = PABCUCO2(JL,JA,KN)
 231  CONTINUE
 232  CONTINUE
      DO ja=3,4
       DO jl=1,kdlon
          ztt(jl,ja)=pabcuaer(jl,ja-2,kn)
       ENDDO
      ENDDO
C
         CALL LWTT(KDLON,pgab(1,2),pgbb(1,2),ZUU,ZTT)
C
      DO 234 JL = 1 , KDLON
      ZCNTOP=
     1     PBTOP(JL,1)*ZTT(JL,1)*ZTT(JL,3)
     2   + PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,4)
      JKDD=2*(KFLEV-JK+1)+1
c!
      ZFD(JL)=ZCNTOP-(PBINT(JL,JK)-PBHDD(JL,JKDD))
     &-PDISD(JL,JK)-PADJD(JL,JK)
c!
      ZFDN(JL,JK)=ZFD(JL)
      PFLUC(JL,2,JK)=ZFD(JL)
 234  CONTINUE
C
 235  CONTINUE
C
C*         2.4     COOLING-TO-SPACE OF UPPERMOST LAYER
C                  -----------------------------------
C
 240  CONTINUE
C
      KTOPM = (KFLEV-1)*NG1P1 + 1
C
      DO 243 JA = 1 , 4
      DO 242 JL = 1 , KDLON
      ZUU(JL,JA) = PABCUCO2(JL,JA,KTOPM)
 242  CONTINUE
 243  CONTINUE
      DO ja=3,4
       DO jl=1,kdlon
          ztt(jl,ja)=pabcuaer(jl,ja-2,ktopm)
       ENDDO
      ENDDO
C
      CALL LWTT(KDLON,pgab(1,2),pgbb(1,2),ZUU,ZTT)
C
      DO 244 JL = 1 , KDLON
      ZCTSTOP =
     1     PBTOP(JL,1)*(1.-ZTT(JL,1)*ZTT(JL,3))
     2   + PBTOP(JL,2)*(1.-ZTT(JL,2)*ZTT(JL,4))
      PCTS(JL,KFLEV) = ZCTSTOP
 244  CONTINUE
C
C*         2.5     EXCHANGE WITH LOWER LIMIT
C                  -------------------------
C
 250  CONTINUE
C
      DO 255 JK = 1 , KFLEV+1
      KN=(JK-1)*NG1P1+1
C
      DO 251 JL = 1 , KDLON
      JKDD=2*KFLEV+1
c!
      ZBGND(JL)=(PBSUI(JL)-PBSDD(JL))*PEMIS(JL)-(1.-PEMIS(JL))
     S   *PFLUC(JL,2,1)-(PBINT(JL,1)-PBHDD(JL,JKDD))
c!
 251  CONTINUE
C
      DO 253 JA = 1 , 4
      DO 252 JL = 1 , KDLON
      ZUU(JL,JA) = PABCUCO2(JL,JA,1) - PABCUCO2(JL,JA,KN)
 252  CONTINUE
 253  CONTINUE
      DO ja=3,4
       DO jl=1,kdlon
          ztt(jl,ja)=pabcuaer(jl,ja-2,1)/pabcuaer(jl,ja-2,kn)
       ENDDO
      ENDDO
C
      CALL LWTT (KDLON,pgab(1,1),pgbb(1,1),ZUU,ZTT)
C
      DO 254 JL = 1 , KDLON
      ZCNSOL=
     1     PBSUR(JL,1)*ZTT(JL,1)*ZTT(JL,3)
     2   + PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,4)
c!
      ZCNSOL=ZCNSOL*ZBGND(JL)/(PBSUI(JL)-PBSDD(JL))
      JKDD=2*(KFLEV-JK+1)+1
c!
      ZFU(JL)=ZCNSOL
     &+(PBINT(JL,JK)-PBHDD(JL,JKDD))-PDISU(JL,JK)-PADJU(JL,JK)
c!
      ZFUP(JL,JK)=ZFU(JL)
      PFLUC(JL,1,JK)=ZFU(JL)
 254  CONTINUE
C
C     IF (NIMP.LT.3) THEN
C        JL=JLIMPRAD
C        WRITE(NOUT,890)JL,JK,ZFDN(JL,JK),PDISD(JL,JK),PADJD(JL,JK),
C    S                        PBINT(JL,JK),
C    S        ZFUP(JL,JK),PDISU(JL,JK),PADJU(JL,JK),ZCNSOL
C     END IF
 255  CONTINUE
C
C*         2.6     HEATING-FROM-GROUND OF UPPERMOST LAYER
C                  --------------------------------------
C
 260  CONTINUE
C
      DO 262 JA = 1 , KTRAER
      DO 261 JL = 1 , KDLON
      ZTT1(JL,JA) = ZTT(JL,JA)
 261  CONTINUE
 262  CONTINUE
C
      DO 265 JA = 1 , 4
      DO 264 JL = 1 , KDLON
      ZUU(JL,JA) = PABCUCO2(JL,JA,1) - PABCUCO2(JL,JA,KTOPM)
 264  CONTINUE
 265  CONTINUE
      DO ja=3,4
       DO jl=1,kdlon
          ztt(jl,ja)=pabcuaer(jl,ja-2,1)/pabcuaer(jl,ja-2,ktopm)
       ENDDO
      ENDDO
C
      CALL LWTT(KDLON,pgab(1,1),pgbb(1,1),ZUU,ZTT)
C
      DO 266 JL = 1 , KDLON
      ZHFGRND=
     S  (PBSUR(JL,1)-PBTOP(JL,1))
     S         *(ZTT(JL,1)*ZTT(JL,3)-ZTT1(JL,1)*ZTT1(JL,3))
     S +(PBSUR(JL,2)-PBTOP(JL,2))
     S         *(ZTT(JL,2)*ZTT(JL,4)-ZTT1(JL,2)*ZTT1(JL,4))
      PHFG(JL,KFLEV) = ZHFGRND
 266  CONTINUE
C
C*         2.7     CLEAR-SKY FLUXES
C                  ----------------
C
 270  CONTINUE
C
      IF (NIMP.LT.4) THEN
         WRITE(NOUT,884) (PFLUC(JLIMPRAD,1,JK),JK = 1 , KFLEV+1)
         WRITE(NOUT,884) (PFLUC(JLIMPRAD,2,JK),JK = 1 , KFLEV+1)
      END IF
C
C     ------------------------------------------------------------------
C
      RETURN
C
C-----------------------------------------------------------------------
C                       FORMATS
C                       -------
C
 884  FORMAT (1X,F7.2,18F6.1,F7.2)
 886  FORMAT (1X,20I5)
 888  FORMAT (1X,13E9.2)
 890  FORMAT (1X,2I4,13F9.2)
C
      END