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
      DOUBLE PRECISION PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
      DOUBLE PRECISION PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
      DOUBLE PRECISION PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
      DOUBLE PRECISION PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
C
      DOUBLE PRECISION PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
      DOUBLE PRECISION PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
      DOUBLE PRECISION PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
C
C* LOCAL VARIABLES:
C
      DOUBLE PRECISION ZGLAYD(KDLON)
      DOUBLE PRECISION ZGLAYU(KDLON)
      DOUBLE PRECISION ZTT(KDLON,NTRA)
      DOUBLE PRECISION ZTT1(KDLON,NTRA)
      DOUBLE PRECISION 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
      DOUBLE PRECISION 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	guez	71	DOUBLE PRECISION PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
41			DOUBLE PRECISION PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
42			DOUBLE PRECISION PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
43			DOUBLE PRECISION PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
44	guez	24	C
45	guez	71	DOUBLE PRECISION PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
46			DOUBLE PRECISION PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
47			DOUBLE PRECISION PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
48	guez	24	C
49			C* LOCAL VARIABLES:
50			C
51	guez	71	DOUBLE PRECISION ZGLAYD(KDLON)
52			DOUBLE PRECISION ZGLAYU(KDLON)
53			DOUBLE PRECISION ZTT(KDLON,NTRA)
54			DOUBLE PRECISION ZTT1(KDLON,NTRA)
55			DOUBLE PRECISION ZTT2(KDLON,NTRA)
56	guez	24	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	guez	71	DOUBLE PRECISION zww, zdzxdg, zdzxmg
61	guez	24	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