*=*=*=*= LWVD.html =*=*=*=*
SUBROUTINE LWVD

SUBROUTINE LWVD


      SUBROUTINE LWVD ( KDLON,KFLEV,KUAER,KTRAER
     S  , pga,pgb
     S  , PABCUCO2,PABCUAER,PDBDT
     S  , PDISD,PDISU                              )
      IMPLICIT LOGICAL (L)
C
#include "dimensions.h"
#include "dimphys.h"
#include "dimradmars.h"
C
C**** *LWVD*   - L.W., VERTICAL INTEGRATION, DISTANT LAYERS
C
C     PURPOSE.
C     --------
C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
C
C**   INTERFACE.
C     ----------
C     SUBROUTINE LWVD ( KDLON,KFLEV,KUAER,KTRAER
C    S  , KXDIA,KXT
C    S  , PABCUCO2,PABCUAER,PDBDT
C    S  , PDISD,PDISU                              )
C
C        EXPLICIT ARGUMENTS :
C        --------------------
C     ==== INPUTS ===
C KX...    (KDLON,...          ; TEMPERATURE INDICES
C PABCUCO2 : (KDLON,NUA,3*KFLEV+1); ABSORBER AMOUNTS (CO2)
C PABCUAER : (KDLON,NUA,3*KFLEV+1); ABSORBER AMOUNTS (AEROSOLS)
C PDBDT  : (KDLON,KFLEV)       ; LAYER PLANCK FUNCTION GRADIENT
C     ==== OUTPUTS ===
C PDIS.. : (KDLON,KFLEV+1)     ; CONTRIBUTION BY DISTANT LAYERS
C
C        IMPLICIT ARGUMENTS :   NONE
C        --------------------
C
C     METHOD.
C     -------
C
C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
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!
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 pga(NDLO2*2*3,kflev+1),pgb(NDLO2*2*3,kflev+1)

      REAL PABCUCO2(NDLO2,NUACO2,3*KFLEV+1)
      REAL PABCUAER(NDLO2,NIR,3*KFLEV+1)
     S  ,  PDBDT(NDLO2,nir,KFLEV)
C
      REAL PDISD(NDLO2,KFLEV+1), PDISU(NDLO2,KFLEV+1)
C
C-------------------------------------------------------------------------
C
C*       0.2   LOCAL ARRAYS
C              ------------
C
      REAL ZGLAYD(NDLON),ZGLAYU(NDLON)
     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*         1.1     INITIALIZE LAYER CONTRIBUTIONS
C                  ------------------------------
C
 110  CONTINUE
C
      DO 112 JK = 1 , KFLEV+1
      DO 111 JL = 1 , KDLON
      PDISD(JL,JK)=0.
      PDISU(JL,JK)=0.
 111  CONTINUE
 112  CONTINUE
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.2     CONTRIBUTION FROM DISTANT LAYERS
C                  ---------------------------------
C
 220  CONTINUE
C
C
C*         2.2.1   DISTANT AND ABOVE LAYERS
C                  ------------------------
C
 2210 CONTINUE
C
C
C
C*         2.2.2   FIRST UPPER LEVEL
C                  -----------------
C
 2220 CONTINUE
C
      DO 225 JK = 1 , KFLEV-1
      JKP1=JK+1
      KN=(JK-1)*NG1P1+1
      KD1= JK  *NG1P1+1
C
      DO 2223 JA = 1 , 4
      DO 2222 JL = 1 , KDLON
      ZUU(JL,JA) = PABCUCO2(JL,JA,KN) - PABCUCO2(JL,JA,KD1)
 2222 CONTINUE
 2223 CONTINUE
      DO ja=3,4
      DO jl=1,kdlon
        ztt(jl,ja)=pabcuaer(jl,ja-2,kn)/pabcuaer(jl,ja-2,kd1)
      ENDDO
      ENDDO
C
         CALL LWTT(KDLON,pga(1,jk+1),pgb(1,jk+1),ZUU,ZTT)
C
      DO 2225 JA = 1 , KTRAER
      DO 2224 JL = 1 , KDLON
      ZTT1(JL,JA)=ZTT(JL,JA)
 2224 CONTINUE
 2225 CONTINUE
C
C
C
C*         2.2.3   HIGHER UP
C                  ---------
C
 2230 CONTINUE
C
      DO 224 JKJ=JKP1,KFLEV
      KJP1=JKJ+1
      KD2= JKJ  *NG1P1+1
C
      DO 2233 JA = 1 , 4
      DO 2232 JL = 1 , KDLON
      ZUU(JL,JA) = PABCUCO2(JL,JA,KN) - PABCUCO2(JL,JA,KD2)
 2232 CONTINUE
 2233 CONTINUE
      DO ja=3,4
      DO jl=1,kdlon
         ztt(jl,ja)=pabcuaer(jl,ja-2,kn)/pabcuaer(jl,ja-2,kd2)
      ENDDO
      ENDDO
C
            CALL LWTT(KDLON,pga(1,jkj+1),pgb(1,jkj+1),ZUU,ZTT)
C
      DO 2235 JA = 1 , KTRAER
      DO 2234 JL = 1 , KDLON
      ZTT2(JL,JA)=ZTT(JL,JA)
      ZTT(JL,JA)=(ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
 2234 CONTINUE
 2235 CONTINUE
C
      DO 2236 JL = 1 , KDLON
      ZWW=
     1     PDBDT(JL,1,JKJ)*ZTT(JL,1)*ZTT(JL,3)
     2   + PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,4)
      ZGLAYD(JL)=ZWW
      ZDZXDG=ZGLAYD(JL)
      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
c     PCNTRB(JL,JK,KJP1)=ZDZXDG
 2236 CONTINUE
C
      DO 2238 JA = 1 , KTRAER
      DO 2237 JL = 1 , KDLON
      ZTT1(JL,JA)=ZTT2(JL,JA)
 2237 CONTINUE
 2238 CONTINUE
C
 224  CONTINUE
 225  CONTINUE
C
C
C*         2.2.4   DISTANT AND BELOW LAYERS
C                  ------------------------
C
 2240 CONTINUE
C
C
C
C*         2.2.5   FIRST LOWER LEVEL
C                  -----------------
C
 2250 CONTINUE
C
      DO 228 JK=3,KFLEV+1
      KN=(JK-1)*NG1P1+1
      KM1=JK-1
      KJ=JK-2
      KU1= KJ  *NG1P1+1
C
      DO 2253 JA = 1 , 4
      DO 2252 JL = 1 , KDLON
      ZUU(JL,JA) = PABCUCO2(JL,JA,KU1) - PABCUCO2(JL,JA,KN)
 2252 CONTINUE
 2253 CONTINUE
      DO ja=3,4
      DO jl=1,kdlon
         ztt(jl,ja)=pabcuaer(jl,ja-2,ku1)/pabcuaer(jl,ja-2,kn)
      ENDDO
      ENDDO
C
         CALL LWTT(KDLON,pga(1,kj+1),pgb(1,kj+1),ZUU,ZTT)
C
      DO 2255 JA = 1 , KTRAER
      DO 2254 JL = 1 , KDLON
      ZTT1(JL,JA)=ZTT(JL,JA)
 2254 CONTINUE
 2255 CONTINUE
C
C
C*         2.2.6   DOWN BELOW
C                  ----------
C
 2260 CONTINUE
C
      DO 227 JLK=1,KJ
      JKL=KM1-JLK
      KU2=(JKL-1)*NG1P1+1
C
      DO 2263 JA = 1 , 4
      DO 2262 JL = 1 , KDLON
      ZUU(JL,JA) = PABCUCO2(JL,JA,KU2) - PABCUCO2(JL,JA,KN)
 2262 CONTINUE
 2263 CONTINUE
      DO ja=3,4
      DO jl=1,kdlon
         ztt(jl,ja)=pabcuaer(jl,ja-2,ku2)/pabcuaer(jl,ja-2,kn)
      ENDDO
      ENDDO
C
            CALL LWTT(KDLON,pga(1,jkl),pgb(1,jkl),ZUU,ZTT)
C
      DO 2265 JA = 1 , KTRAER
      DO 2264 JL = 1 , KDLON
      ZTT2(JL,JA)=ZTT(JL,JA)
      ZTT(JL,JA)=(ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
 2264 CONTINUE
 2265 CONTINUE
C
      DO 2266 JL = 1 , KDLON
      ZWW=
     1     PDBDT(JL,1,JKL)*ZTT(JL,1)*ZTT(JL,3)
     2   + PDBDT(JL,2,JKL)*ZTT(JL,2)*ZTT(JL,4)
      ZGLAYU(JL)=ZWW
      ZDZXMG=ZGLAYU(JL)
      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
c     PCNTRB(JL,JK,JKL)=ZDZXMG
 2266 CONTINUE
C
      DO 2268 JA = 1 , KTRAER
      DO 2267 JL = 1 , KDLON
      ZTT1(JL,JA)=ZTT2(JL,JA)
 2267 CONTINUE
 2268 CONTINUE
C
 227  CONTINUE
 228  CONTINUE
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