phylmd/Radlwsw/lwvd.f

      SUBROUTINE LWVD(KUAER,KTRAER
     S  , PABCU,PDBDT
     R  , PGA,PGB
     S  , PCNTRB,PDISD,PDISU)
      use dimens_m
      use dimphy
      use raddim
            use raddimlw
      IMPLICIT none
C
C-----------------------------------------------------------------------
C     PURPOSE.
C     --------
C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
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     REFERENCE.
C     ----------
C
C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
C
C     AUTHOR.
C     -------
C        JEAN-JACQUES MORCRETTE  *ECMWF*
C
C     MODIFICATIONS.
C     --------------
C        ORIGINAL : 89-07-14
C-----------------------------------------------------------------------
C* ARGUMENTS:
C
      INTEGER KUAER,KTRAER
C
      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
      REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
C
      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
      REAL*8 PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
      REAL*8 PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
C
C* LOCAL VARIABLES:
C
      REAL*8 ZGLAYD(KDLON)
      REAL*8 ZGLAYU(KDLON)
      REAL*8 ZTT(KDLON,NTRA)
      REAL*8 ZTT1(KDLON,NTRA)
      REAL*8 ZTT2(KDLON,NTRA)
C
      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
      INTEGER ind1, ind2, ind3, ind4, itt
      REAL*8 zww, zdzxdg, zdzxmg
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
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
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
      IKP1=JK+1
      IKN=(JK-1)*NG1P1+1
      IKD1= JK  *NG1P1+1
C
      CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
     2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
C
C
C
C*         2.2.3   HIGHER UP
C                  ---------
C
 2230 CONTINUE
C
      ITT=1
      DO 224 JKJ=IKP1,KFLEV
      IF(ITT.EQ.1) THEN
         ITT=2
      ELSE
         ITT=1
      ENDIF
      IKJP1=JKJ+1
      IKD2= JKJ  *NG1P1+1
C
      IF(ITT.EQ.1) THEN
         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
      ELSE
         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
      ENDIF
C
      DO 2235 JA = 1, KTRAER
      DO 2234 JL = 1, KDLON
      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
 2234 CONTINUE
 2235 CONTINUE
C
      DO 2236 JL = 1, KDLON
      ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
     S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
     S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
     S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
     S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
     S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
      ZGLAYD(JL)=ZWW
      ZDZXDG=ZGLAYD(JL)
      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
      PCNTRB(JL,JK,IKJP1)=ZDZXDG
 2236 CONTINUE
C
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
      IKN=(JK-1)*NG1P1+1
      IKM1=JK-1
      IKJ=JK-2
      IKU1= IKJ  *NG1P1+1
C
C
      CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
     2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
C
C
C
C*         2.2.6   DOWN BELOW
C                  ----------
C
 2260 CONTINUE
C
      ITT=1
      DO 227 JLK=1,IKJ
      IF(ITT.EQ.1) THEN
         ITT=2
      ELSE
         ITT=1
      ENDIF
      IJKL=IKM1-JLK
      IKU2=(IJKL-1)*NG1P1+1
C
C
      IF(ITT.EQ.1) THEN
         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
      ELSE
         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
      ENDIF
C
      DO 2265 JA = 1, KTRAER
      DO 2264 JL = 1, KDLON
      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
 2264 CONTINUE
 2265 CONTINUE
C
      DO 2266 JL = 1, KDLON
      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)
     S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
     S   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
     S   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
     S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)
     S   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
      ZGLAYU(JL)=ZWW
      ZDZXMG=ZGLAYU(JL)
      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
      PCNTRB(JL,JK,IJKL)=ZDZXMG
 2266 CONTINUE
C
C
 227  CONTINUE
 228  CONTINUE
C
      RETURN
      END
1	guez	24	SUBROUTINE LWVD(KUAER,KTRAER
2			S , PABCU,PDBDT
3			R , PGA,PGB
4			S , PCNTRB,PDISD,PDISU)
5			use dimens_m
6			use dimphy
7			use raddim
8			use raddimlw
9			IMPLICIT none
10			C
11			C-----------------------------------------------------------------------
12			C PURPOSE.
13			C --------
14			C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
15			C
16			C METHOD.
17			C -------
18			C
19			C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
20			C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
21			C
22			C REFERENCE.
23			C ----------
24			C
25			C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
26			C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
27			C
28			C AUTHOR.
29			C -------
30			C JEAN-JACQUES MORCRETTE ECMWF
31			C
32			C MODIFICATIONS.
33			C --------------
34			C ORIGINAL : 89-07-14
35			C-----------------------------------------------------------------------
36			C* ARGUMENTS:
37			C
38			INTEGER KUAER,KTRAER
39			C
40			REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
41			REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
42			REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
43			REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
44			C
45			REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
46			REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
47			REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
48			C
49			C* LOCAL VARIABLES:
50			C
51			REAL*8 ZGLAYD(KDLON)
52			REAL*8 ZGLAYU(KDLON)
53			REAL*8 ZTT(KDLON,NTRA)
54			REAL*8 ZTT1(KDLON,NTRA)
55			REAL*8 ZTT2(KDLON,NTRA)
56			C
57			INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
58			INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
59			INTEGER ind1, ind2, ind3, ind4, itt
60			REAL*8 zww, zdzxdg, zdzxmg
61			C
62			C* 1. INITIALIZATION
63			C --------------
64			C
65			100 CONTINUE
66			C
67			C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
68			C ------------------------------
69			C
70			110 CONTINUE
71			C
72			DO 112 JK = 1, KFLEV+1
73			DO 111 JL = 1, KDLON
74			PDISD(JL,JK) = 0.
75			PDISU(JL,JK) = 0.
76			111 CONTINUE
77			112 CONTINUE
78			C
79			C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
80			C ---------------------------------
81			C
82			120 CONTINUE
83			C
84			C
85			DO 122 JA = 1, NTRA
86			DO 121 JL = 1, KDLON
87			ZTT (JL,JA) = 1.0
88			ZTT1(JL,JA) = 1.0
89			ZTT2(JL,JA) = 1.0
90			121 CONTINUE
91			122 CONTINUE
92			C
93			C ------------------------------------------------------------------
94			C
95			C* 2. VERTICAL INTEGRATION
96			C --------------------
97			C
98			200 CONTINUE
99			C
100			IND1=0
101			IND3=0
102			IND4=1
103			IND2=1
104			C
105			C
106			C* 2.2 CONTRIBUTION FROM DISTANT LAYERS
107			C ---------------------------------
108			C
109			220 CONTINUE
110			C
111			C
112			C* 2.2.1 DISTANT AND ABOVE LAYERS
113			C ------------------------
114			C
115			2210 CONTINUE
116			C
117			C
118			C
119			C* 2.2.2 FIRST UPPER LEVEL
120			C -----------------
121			C
122			2220 CONTINUE
123			C
124			DO 225 JK = 1 , KFLEV-1
125			IKP1=JK+1
126			IKN=(JK-1)*NG1P1+1
127			IKD1= JK *NG1P1+1
128			C
129			CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
130			2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
131			C
132			C
133			C
134			C* 2.2.3 HIGHER UP
135			C ---------
136			C
137			2230 CONTINUE
138			C
139			ITT=1
140			DO 224 JKJ=IKP1,KFLEV
141			IF(ITT.EQ.1) THEN
142			ITT=2
143			ELSE
144			ITT=1
145			ENDIF
146			IKJP1=JKJ+1
147			IKD2= JKJ *NG1P1+1
148			C
149			IF(ITT.EQ.1) THEN
150			CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
151			2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
152			ELSE
153			CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
154			2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
155			ENDIF
156			C
157			DO 2235 JA = 1, KTRAER
158			DO 2234 JL = 1, KDLON
159			ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
160			2234 CONTINUE
161			2235 CONTINUE
162			C
163			DO 2236 JL = 1, KDLON
164			ZWW=PDBDT(JL,1,JKJ)ZTT(JL,1) ZTT(JL,10)
165			S +PDBDT(JL,2,JKJ)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
166			S +PDBDT(JL,3,JKJ)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
167			S +PDBDT(JL,4,JKJ)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
168			S +PDBDT(JL,5,JKJ)ZTT(JL,3) ZTT(JL,14)
169			S +PDBDT(JL,6,JKJ)ZTT(JL,6) ZTT(JL,15)
170			ZGLAYD(JL)=ZWW
171			ZDZXDG=ZGLAYD(JL)
172			PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
173			PCNTRB(JL,JK,IKJP1)=ZDZXDG
174			2236 CONTINUE
175			C
176			C
177			224 CONTINUE
178			225 CONTINUE
179			C
180			C
181			C* 2.2.4 DISTANT AND BELOW LAYERS
182			C ------------------------
183			C
184			2240 CONTINUE
185			C
186			C
187			C
188			C* 2.2.5 FIRST LOWER LEVEL
189			C -----------------
190			C
191			2250 CONTINUE
192			C
193			DO 228 JK=3,KFLEV+1
194			IKN=(JK-1)*NG1P1+1
195			IKM1=JK-1
196			IKJ=JK-2
197			IKU1= IKJ *NG1P1+1
198			C
199			C
200			CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
201			2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
202			C
203			C
204			C
205			C* 2.2.6 DOWN BELOW
206			C ----------
207			C
208			2260 CONTINUE
209			C
210			ITT=1
211			DO 227 JLK=1,IKJ
212			IF(ITT.EQ.1) THEN
213			ITT=2
214			ELSE
215			ITT=1
216			ENDIF
217			IJKL=IKM1-JLK
218			IKU2=(IJKL-1)*NG1P1+1
219			C
220			C
221			IF(ITT.EQ.1) THEN
222			CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
223			2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
224			ELSE
225			CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
226			2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
227			ENDIF
228			C
229			DO 2265 JA = 1, KTRAER
230			DO 2264 JL = 1, KDLON
231			ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
232			2264 CONTINUE
233			2265 CONTINUE
234			C
235			DO 2266 JL = 1, KDLON
236			ZWW=PDBDT(JL,1,IJKL)ZTT(JL,1) ZTT(JL,10)
237			S +PDBDT(JL,2,IJKL)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
238			S +PDBDT(JL,3,IJKL)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
239			S +PDBDT(JL,4,IJKL)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
240			S +PDBDT(JL,5,IJKL)ZTT(JL,3) ZTT(JL,14)
241			S +PDBDT(JL,6,IJKL)ZTT(JL,6) ZTT(JL,15)
242			ZGLAYU(JL)=ZWW
243			ZDZXMG=ZGLAYU(JL)
244			PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
245			PCNTRB(JL,JK,IJKL)=ZDZXMG
246			2266 CONTINUE
247			C
248			C
249			227 CONTINUE
250			228 CONTINUE
251			C
252			RETURN
253			END