Context Navigation

radlwsw.F @ 5415

Last change on this file since 5415 was 368, checked in by lmdz, 23 years ago
Bug sur le chauffage solaire ciel clair PasB LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 184.6 KB

Line
1	SUBROUTINE radlwsw(dist, rmu0, fract, co2_ppm, solaire,
2	. paprs, pplay,tsol,albedo, t,q,wo,
3	. cldfra, cldemi, cldtau,
4	. heat,heat0,cool,cool0,radsol,albpla,
5	. topsw,toplw,solsw,sollw,
6	. topsw0,toplw0,solsw0,sollw0)
7	IMPLICIT none
8	c======================================================================
9	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719
10	c Objet: interface entre le modele et les rayonnements
11	c Arguments:
12	c dist-----input-R- distance astronomique terre-soleil
13	c rmu0-----input-R- cosinus de l'angle zenithal
14	c fract----input-R- duree d'ensoleillement normalisee
15	c co2_ppm--input-R- concentration du gaz carbonique (en ppm)
16	c solaire--input-R- constante solaire (W/m**2)
17	c paprs----input-R- pression a inter-couche (Pa)
18	c pplay----input-R- pression au milieu de couche (Pa)
19	c tsol-----input-R- temperature du sol (en K)
20	c albedo---input-R- albedo du sol (entre 0 et 1)
21	c t--------input-R- temperature (K)
22	c q--------input-R- vapeur d'eau (en kg/kg)
23	c wo-------input-R- contenu en ozone (en cm.atm)
24	c cldfra---input-R- fraction nuageuse (entre 0 et 1)
25	c cldtau---input-R- epaisseur optique des nuages dans le visible
26	c cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1)
27	c
28	c heat-----output-R- echauffement atmospherique (visible) (K/jour)
29	c cool-----output-R- refroidissement dans l'IR (K/jour)
30	c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas)
31	c albpla---output-R- albedo planetaire (entre 0 et 1)
32	c topsw----output-R- ray. solaire absorbe au sommet de l'atm.
33	c toplw----output-R- ray. IR emis au sommet de l'atmosphere
34	c solsw----output-R- ray. solaire net absorbe a la surface
35	c sollw----output-R- ray. IR net emis par la surface
36	c======================================================================
37	#include "dimensions.h"
38	#include "dimphy.h"
39	#include "raddim.h"
40	c
41	real rmu0(klon), fract(klon), dist
42	real co2_ppm
43	real solaire
44	c
45	real paprs(klon,klev+1), pplay(klon,klev)
46	real albedo(klon), tsol(klon)
47	real t(klon,klev), q(klon,klev), wo(klon,klev)
48	real cldfra(klon,klev), cldemi(klon,klev), cldtau(klon,klev)
49	real heat(klon,klev), cool(klon,klev)
50	real heat0(klon,klev), cool0(klon,klev)
51	real radsol(klon), topsw(klon), toplw(klon)
52	real solsw(klon), sollw(klon), albpla(klon)
53	real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
54	c
55	REAL*8 zx_alpha1, zx_alpha2
56	c
57	#include "YOMCST.h"
58	c
59	INTEGER k, kk, i, j, iof, nb_gr
60	EXTERNAL lw, sw
61	c
62	REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12
63	REAL*8 PSCT
64	c
65	REAL*8 PALBD(kdlon,2), PALBP(kdlon,2)
66	REAL*8 PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon)
67	REAL*8 PPSOL(kdlon), PDP(kdlon,klev)
68	REAL*8 PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1)
69	REAL*8 PTAVE(kdlon,kflev)
70	REAL*8 PWV(kdlon,kflev), PQS(kdlon,kflev), POZON(kdlon,kflev)
71	REAL*8 PAER(kdlon,kflev,5)
72	REAL*8 PCLDLD(kdlon,kflev)
73	REAL*8 PCLDLU(kdlon,kflev)
74	REAL*8 PCLDSW(kdlon,kflev)
75	REAL*8 PTAU(kdlon,2,kflev)
76	REAL*8 POMEGA(kdlon,2,kflev)
77	REAL*8 PCG(kdlon,2,kflev)
78	c
79	REAL*8 zfract(kdlon), zrmu0(kdlon), zdist
80	c
81	REAL*8 zheat(kdlon,kflev), zcool(kdlon,kflev)
82	REAL*8 zheat0(kdlon,kflev), zcool0(kdlon,kflev)
83	REAL*8 ztopsw(kdlon), ztoplw(kdlon)
84	REAL*8 zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon)
85	REAL*8 ztopsw0(kdlon), ztoplw0(kdlon)
86	REAL*8 zsolsw0(kdlon), zsollw0(kdlon)
87
88	c
89	c-------------------------------------------
90	nb_gr = klon / kdlon
91	IF (nb_gr*kdlon .NE. klon) THEN
92	PRINT*, "kdlon mauvais:", klon, kdlon, nb_gr
93	CALL abort
94	ENDIF
95	IF (kflev .NE. klev) THEN
96	PRINT*, "kflev differe de klev, kflev, klev"
97	CALL abort
98	ENDIF
99	c-------------------------------------------
100	DO k = 1, klev
101	DO i = 1, klon
102	heat(i,k)=0.
103	cool(i,k)=0.
104	heat0(i,k)=0.
105	cool0(i,k)=0.
106	ENDDO
107	ENDDO
108	c
109	zdist = dist
110	c
111	RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97
112	RCH4 = 1.72E-06* 16.043/28.97
113	RN2O = 310.E-09* 44.013/28.97
114	RCFC11 = 280.E-12* 137.3686/28.97
115	RCFC12 = 484.E-12* 120.9140/28.97
116	PSCT = solaire/zdist/zdist
117	c
118	DO 99999 j = 1, nb_gr
119	iof = kdlon*(j-1)
120	c
121	DO i = 1, kdlon
122	zfract(i) = fract(iof+i)
123	zrmu0(i) = rmu0(iof+i)
124	PALBD(i,1) = albedo(iof+i)
125	PALBD(i,2) = albedo(iof+i)
126	PALBP(i,1) = albedo(iof+i)
127	PALBP(i,2) = albedo(iof+i)
128	PEMIS(i) = 0.96
129	PVIEW(i) = 1.66
130	PPSOL(i) = paprs(iof+i,1)
131	zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2))
132	. / (pplay(iof+i,1)-pplay(iof+i,2))
133	zx_alpha2 = 1.0 - zx_alpha1
134	PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2
135	PTL(i,klev+1) = t(iof+i,klev)
136	PDT0(i) = tsol(iof+i) - PTL(i,1)
137	ENDDO
138	DO k = 2, kflev
139	DO i = 1, kdlon
140	PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5
141	ENDDO
142	ENDDO
143	DO k = 1, kflev
144	DO i = 1, kdlon
145	PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1)
146	PTAVE(i,k) = t(iof+i,k)
147	PWV(i,k) = MAX (q(iof+i,k), 1.0e-12)
148	PQS(i,k) = PWV(i,k)
149	c wo: cm.atm (epaisseur en cm dans la situation standard)
150	c POZON: kg/kg
151	POZON(i,k) = MAX(wo(iof+i,k),1.0e-12)*RG/46.6968
152	. /(paprs(iof+i,k)-paprs(iof+i,k+1))
153	. *(paprs(iof+i,1)/101325.0)
154	PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
155	PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
156	PCLDSW(i,k) = cldfra(iof+i,k)
157	PTAU(i,1,k) = MAX(cldtau(iof+i,k), 1.0e-05)! 1e-12 serait instable
158	PTAU(i,2,k) = MAX(cldtau(iof+i,k), 1.0e-05)! pour 32-bit machines
159	POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k))
160	POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k))
161	PCG(i,1,k) = 0.865
162	PCG(i,2,k) = 0.910
163	ENDDO
164	ENDDO
165	c
166	DO k = 1, kflev+1
167	DO i = 1, kdlon
168	PPMB(i,k) = paprs(iof+i,k)/100.0
169	ENDDO
170	ENDDO
171	c
172	DO kk = 1, 5
173	DO k = 1, kflev
174	DO i = 1, kdlon
175	PAER(i,k,kk) = 1.0E-15
176	ENDDO
177	ENDDO
178	ENDDO
179	c
180	c======================================================================
181	CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
182	. PPMB, PDP,
183	. PPSOL,PDT0,PEMIS,
184	. PTL, PTAVE, PWV, POZON, PAER,
185	. PCLDLD,PCLDLU,
186	. PVIEW,
187	. zcool, zcool0,
188	. ztoplw,zsollw,ztoplw0,zsollw0)
189	CALL SW(PSCT, RCO2, zrmu0, zfract,
190	S PPMB, PDP,
191	S PPSOL, PALBD, PALBP,
192	S PTAVE, PWV, PQS, POZON, PAER,
193	S PCLDSW, PTAU, POMEGA, PCG,
194	S zheat, zheat0,
195	S zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0)
196	c======================================================================
197	DO i = 1, kdlon
198	radsol(iof+i) = zsolsw(i) + zsollw(i)
199	topsw(iof+i) = ztopsw(i)
200	toplw(iof+i) = ztoplw(i)
201	solsw(iof+i) = zsolsw(i)
202	sollw(iof+i) = zsollw(i)
203	topsw0(iof+i) = ztopsw0(i)
204	toplw0(iof+i) = ztoplw0(i)
205	solsw0(iof+i) = zsolsw0(i)
206	sollw0(iof+i) = zsollw0(i)
207	albpla(iof+i) = zalbpla(i)
208	ENDDO
209	DO k = 1, kflev
210	DO i = 1, kdlon
211	heat(iof+i,k) = zheat(i,k)
212	cool(iof+i,k) = zcool(i,k)
213	heat0(iof+i,k) = zheat0(i,k)
214	cool0(iof+i,k) = zcool0(i,k)
215	ENDDO
216	ENDDO
217	c
218	99999 CONTINUE
219	RETURN
220	END
221	SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC,
222	S PPMB, PDP,
223	S PPSOL, PALBD, PALBP,
224	S PTAVE, PWV, PQS, POZON, PAER,
225	S PCLDSW, PTAU, POMEGA, PCG,
226	S PHEAT, PHEAT0,
227	S PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0)
228	IMPLICIT none
229
230	#include "dimensions.h"
231	#include "dimphy.h"
232	#include "raddim.h"
233	#include "YOMCST.h"
234	C
235	C ------------------------------------------------------------------
236	C
237	C PURPOSE.
238	C --------
239	C
240	C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
241	C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
242	C
243	C METHOD.
244	C -------
245	C
246	C 1. COMPUTES ABSORBER AMOUNTS (SWU)
247	C 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S)
248	C 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S)
249	C
250	C REFERENCE.
251	C ----------
252	C
253	C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
254	C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
255	C
256	C AUTHOR.
257	C -------
258	C JEAN-JACQUES MORCRETTE ECMWF
259	C
260	C MODIFICATIONS.
261	C --------------
262	C ORIGINAL : 89-07-14
263	C 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo
264	C ------------------------------------------------------------------
265	C
266	C* ARGUMENTS:
267	C
268	REAL*8 PSCT ! constante solaire (valeur conseillee: 1370)
269	REAL8 RCO2 ! concentration CO2 (IPCC: 353.E-0644.011/28.97)
270	C
271	REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (PA)
272	REAL*8 PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA)
273	REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
274	C
275	REAL*8 PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE
276	REAL*8 PFRAC(KDLON) ! fraction de la journee
277	C
278	REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K)
279	REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (KG/KG)
280	REAL*8 PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG)
281	REAL*8 POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG)
282	REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
283	C
284	REAL*8 PALBD(KDLON,2) ! albedo du sol (lumiere diffuse)
285	REAL*8 PALBP(KDLON,2) ! albedo du sol (lumiere parallele)
286	C
287	REAL*8 PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION
288	REAL*8 PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS
289	REAL*8 PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR
290	REAL*8 POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO
291	C
292	REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
293	REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
294	REAL*8 PALBPLA(KDLON) ! PLANETARY ALBEDO
295	REAL*8 PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A.
296	REAL*8 PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE
297	REAL*8 PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
298	REAL*8 PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
299	C
300	C* LOCAL VARIABLES:
301	C
302	REAL*8 ZOZ(KDLON,KFLEV)
303	REAL*8 ZAKI(KDLON,2)
304	REAL*8 ZCLD(KDLON,KFLEV)
305	REAL*8 ZCLEAR(KDLON)
306	REAL*8 ZDSIG(KDLON,KFLEV)
307	REAL*8 ZFACT(KDLON)
308	REAL*8 ZFD(KDLON,KFLEV+1)
309	REAL*8 ZFDOWN(KDLON,KFLEV+1)
310	REAL*8 ZFU(KDLON,KFLEV+1)
311	REAL*8 ZFUP(KDLON,KFLEV+1)
312	REAL*8 ZRMU(KDLON)
313	REAL*8 ZSEC(KDLON)
314	REAL*8 ZUD(KDLON,5,KFLEV+1)
315	REAL*8 ZCLDSW0(KDLON,KFLEV)
316	c
317	REAL*8 ZFSUP(KDLON,KFLEV+1)
318	REAL*8 ZFSDN(KDLON,KFLEV+1)
319	REAL*8 ZFSUP0(KDLON,KFLEV+1)
320	REAL*8 ZFSDN0(KDLON,KFLEV+1)
321	SAVE ZFSUP, ZFSDN, ZFSUP0, ZFSDN0
322	C
323	INTEGER inu, jl, jk, i, k, kpl1
324	c
325	INTEGER swpas ! Every swpas steps, sw is calculated
326	PARAMETER(swpas=1)
327	c
328	INTEGER itapsw
329	LOGICAL appel1er
330	DATA itapsw /0/
331	DATA appel1er /.TRUE./
332	c
333	IF (appel1er) THEN
334	PRINT*, 'SW calling frequency : ', swpas
335	PRINT*, " In general, it should be 1"
336	appel1er = .FALSE.
337	ENDIF
338	C ------------------------------------------------------------------
339	IF (MOD(itapsw,swpas).EQ.0) THEN
340	c
341	DO JK = 1 , KFLEV
342	DO JL = 1, KDLON
343	ZCLDSW0(JL,JK) = 0.0
344	ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG
345	. PDP(JL,JK)(101325.0/PPSOL(JL))
346	ENDDO
347	ENDDO
348	C
349	C
350	c clear-sky:
351	CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
352	S PRMU0,PFRAC,PTAVE,PWV,
353	S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
354	INU = 1
355	CALL SW1S(INU,
356	S PAER, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
357	S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
358	S ZFD, ZFU)
359	INU = 2
360	CALL SW2S(INU,
361	S PAER, ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
362	S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
363	S PWV, PQS,
364	S ZFDOWN, ZFUP)
365	DO JK = 1 , KFLEV+1
366	DO JL = 1, KDLON
367	ZFSUP0(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL)
368	ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
369	ENDDO
370	ENDDO
371	c cloudy-sky:
372	CALL SWU(PSCT,RCO2,PCLDSW,PPMB,PPSOL,
373	S PRMU0,PFRAC,PTAVE,PWV,
374	S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
375	INU = 1
376	CALL SW1S(INU,
377	S PAER, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
378	S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
379	S ZFD, ZFU)
380	INU = 2
381	CALL SW2S(INU,
382	S PAER, ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
383	S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
384	S PWV, PQS,
385	S ZFDOWN, ZFUP)
386	DO JK = 1 , KFLEV+1
387	DO JL = 1, KDLON
388	ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL)
389	ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
390	ENDDO
391	ENDDO
392	c
393	itapsw = 0
394	ENDIF
395	itapsw = itapsw + 1
396	C
397	DO k = 1, KFLEV
398	kpl1 = k+1
399	DO i = 1, KDLON
400	PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
401	. -(ZFSDN(i,k)-ZFSDN(i,kpl1))
402	PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
403	PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))
404	. -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
405	PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
406	ENDDO
407	ENDDO
408	DO i = 1, KDLON
409	PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
410	c
411	PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
412	PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
413	c
414	PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
415	PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
416	ENDDO
417	C
418	RETURN
419	END
420	c
421	SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
422	S PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
423	S PRMU,PSEC,PUD)
424	IMPLICIT none
425	#include "dimensions.h"
426	#include "dimphy.h"
427	#include "raddim.h"
428	#include "radepsi.h"
429	#include "radopt.h"
430	#include "YOMCST.h"
431	C
432	C* ARGUMENTS:
433	C
434	REAL*8 PSCT
435	REAL*8 RCO2
436	REAL*8 PCLDSW(KDLON,KFLEV)
437	REAL*8 PPMB(KDLON,KFLEV+1)
438	REAL*8 PPSOL(KDLON)
439	REAL*8 PRMU0(KDLON)
440	REAL*8 PFRAC(KDLON)
441	REAL*8 PTAVE(KDLON,KFLEV)
442	REAL*8 PWV(KDLON,KFLEV)
443	C
444	REAL*8 PAKI(KDLON,2)
445	REAL*8 PCLD(KDLON,KFLEV)
446	REAL*8 PCLEAR(KDLON)
447	REAL*8 PDSIG(KDLON,KFLEV)
448	REAL*8 PFACT(KDLON)
449	REAL*8 PRMU(KDLON)
450	REAL*8 PSEC(KDLON)
451	REAL*8 PUD(KDLON,5,KFLEV+1)
452	C
453	C* LOCAL VARIABLES:
454	C
455	INTEGER IIND(2)
456	REAL*8 ZC1J(KDLON,KFLEV+1)
457	REAL*8 ZCLEAR(KDLON)
458	REAL*8 ZCLOUD(KDLON)
459	REAL*8 ZN175(KDLON)
460	REAL*8 ZN190(KDLON)
461	REAL*8 ZO175(KDLON)
462	REAL*8 ZO190(KDLON)
463	REAL*8 ZSIGN(KDLON)
464	REAL*8 ZR(KDLON,2)
465	REAL*8 ZSIGO(KDLON)
466	REAL*8 ZUD(KDLON,2)
467	REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
468	INTEGER jl, jk, jkp1, jkl, jklp1, ja
469	C
470	C* Prescribed Data:
471	c
472	REAL*8 ZPDH2O,ZPDUMG
473	SAVE ZPDH2O,ZPDUMG
474	REAL*8 ZPRH2O,ZPRUMG
475	SAVE ZPRH2O,ZPRUMG
476	REAL*8 RTDH2O,RTDUMG
477	SAVE RTDH2O,RTDUMG
478	REAL*8 RTH2O ,RTUMG
479	SAVE RTH2O ,RTUMG
480	DATA ZPDH2O,ZPDUMG / 0.8 , 0.75 /
481	DATA ZPRH2O,ZPRUMG / 30000., 30000. /
482	DATA RTDH2O,RTDUMG / 0.40 , 0.375 /
483	DATA RTH2O ,RTUMG / 240. , 240. /
484	C ------------------------------------------------------------------
485	C
486	C* 1. COMPUTES AMOUNTS OF ABSORBERS
487	C -----------------------------
488	C
489	100 CONTINUE
490	C
491	IIND(1)=1
492	IIND(2)=2
493	C
494	C
495	C* 1.1 INITIALIZES QUANTITIES
496	C ----------------------
497	C
498	110 CONTINUE
499	C
500	DO 111 JL = 1, KDLON
501	PUD(JL,1,KFLEV+1)=0.
502	PUD(JL,2,KFLEV+1)=0.
503	PUD(JL,3,KFLEV+1)=0.
504	PUD(JL,4,KFLEV+1)=0.
505	PUD(JL,5,KFLEV+1)=0.
506	PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
507	PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
508	PSEC(JL)=1./PRMU(JL)
509	ZC1J(JL,KFLEV+1)=0.
510	111 CONTINUE
511	C
512	C* 1.3 AMOUNTS OF ABSORBERS
513	C --------------------
514	C
515	130 CONTINUE
516	C
517	DO 131 JL= 1, KDLON
518	ZUD(JL,1) = 0.
519	ZUD(JL,2) = 0.
520	ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
521	ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
522	ZSIGO(JL) = PPSOL(JL)
523	ZCLEAR(JL)=1.
524	ZCLOUD(JL)=0.
525	131 CONTINUE
526	C
527	DO 133 JK = 1 , KFLEV
528	JKP1 = JK + 1
529	JKL = KFLEV+1 - JK
530	JKLP1 = JKL+1
531	DO 132 JL = 1, KDLON
532	ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
533	ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
534	ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
535	ZSIGN(JL) = 100. * PPMB(JL,JKP1)
536	PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
537	ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
538	ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
539	ZDSCO2 = ZO175(JL) - ZN175(JL)
540	ZDSH2O = ZO190(JL) - ZN190(JL)
541	PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
542	. * ZDSH2O * ZWH2O * ZRTH
543	PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
544	. * ZDSCO2 * RCO2 * ZRTU
545	ZFPPW=1.6078ZWH2O/(1.+0.608ZWH2O)
546	PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
547	PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
548	ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
549	ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
550	ZSIGO(JL) = ZSIGN(JL)
551	ZO175(JL) = ZN175(JL)
552	ZO190(JL) = ZN190(JL)
553	C
554	IF (NOVLP.EQ.1) THEN
555	ZCLEAR(JL)=ZCLEAR(JL)
556	S *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
557	S /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
558	ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
559	ZCLOUD(JL) = PCLDSW(JL,JKL)
560	ELSE IF (NOVLP.EQ.2) THEN
561	ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
562	ZC1J(JL,JKL) = ZCLOUD(JL)
563	ELSE IF (NOVLP.EQ.3) THEN
564	ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
565	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
566	ZC1J(JL,JKL) = ZCLOUD(JL)
567	END IF
568	132 CONTINUE
569	133 CONTINUE
570	DO 134 JL=1, KDLON
571	PCLEAR(JL)=1.-ZC1J(JL,1)
572	134 CONTINUE
573	DO 136 JK=1,KFLEV
574	DO 135 JL=1, KDLON
575	IF (PCLEAR(JL).LT.1.) THEN
576	PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
577	ELSE
578	PCLD(JL,JK)=0.
579	END IF
580	135 CONTINUE
581	136 CONTINUE
582	C
583	C
584	C* 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
585	C -----------------------------------------------
586	C
587	140 CONTINUE
588	C
589	DO 142 JA = 1,2
590	DO 141 JL = 1, KDLON
591	ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
592	141 CONTINUE
593	142 CONTINUE
594	C
595	CALL SWTT1(2, 2, IIND, ZUD, ZR)
596	C
597	DO 144 JA = 1,2
598	DO 143 JL = 1, KDLON
599	PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
600	143 CONTINUE
601	144 CONTINUE
602	C
603	C
604	C ------------------------------------------------------------------
605	C
606	RETURN
607	END
608	SUBROUTINE SW1S ( KNU
609	S , PAER , PALBD , PALBP, PCG , PCLD , PCLEAR, PCLDSW
610	S , PDSIG , POMEGA, POZ , PRMU , PSEC , PTAU , PUD
611	S , PFD , PFU)
612	IMPLICIT none
613	#include "dimensions.h"
614	#include "dimphy.h"
615	#include "raddim.h"
616	C
617	C ------------------------------------------------------------------
618	C PURPOSE.
619	C --------
620	C
621	C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
622	C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
623	C
624	C METHOD.
625	C -------
626	C
627	C 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
628	C CONTINUUM SCATTERING
629	C 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
630	C
631	C REFERENCE.
632	C ----------
633	C
634	C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
635	C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
636	C
637	C AUTHOR.
638	C -------
639	C JEAN-JACQUES MORCRETTE ECMWF
640	C
641	C MODIFICATIONS.
642	C --------------
643	C ORIGINAL : 89-07-14
644	C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
645	C ------------------------------------------------------------------
646	C
647	C* ARGUMENTS:
648	C
649	INTEGER KNU
650	REAL*8 PAER(KDLON,KFLEV,5)
651	REAL*8 PALBD(KDLON,2)
652	REAL*8 PALBP(KDLON,2)
653	REAL*8 PCG(KDLON,2,KFLEV)
654	REAL*8 PCLD(KDLON,KFLEV)
655	REAL*8 PCLDSW(KDLON,KFLEV)
656	REAL*8 PCLEAR(KDLON)
657	REAL*8 PDSIG(KDLON,KFLEV)
658	REAL*8 POMEGA(KDLON,2,KFLEV)
659	REAL*8 POZ(KDLON,KFLEV)
660	REAL*8 PRMU(KDLON)
661	REAL*8 PSEC(KDLON)
662	REAL*8 PTAU(KDLON,2,KFLEV)
663	REAL*8 PUD(KDLON,5,KFLEV+1)
664	C
665	REAL*8 PFD(KDLON,KFLEV+1)
666	REAL*8 PFU(KDLON,KFLEV+1)
667	C
668	C* LOCAL VARIABLES:
669	C
670	INTEGER IIND(4)
671	C
672	REAL*8 ZCGAZ(KDLON,KFLEV)
673	REAL*8 ZDIFF(KDLON)
674	REAL*8 ZDIRF(KDLON)
675	REAL*8 ZPIZAZ(KDLON,KFLEV)
676	REAL*8 ZRAYL(KDLON)
677	REAL*8 ZRAY1(KDLON,KFLEV+1)
678	REAL*8 ZRAY2(KDLON,KFLEV+1)
679	REAL*8 ZREFZ(KDLON,2,KFLEV+1)
680	REAL*8 ZRJ(KDLON,6,KFLEV+1)
681	REAL*8 ZRJ0(KDLON,6,KFLEV+1)
682	REAL*8 ZRK(KDLON,6,KFLEV+1)
683	REAL*8 ZRK0(KDLON,6,KFLEV+1)
684	REAL*8 ZRMUE(KDLON,KFLEV+1)
685	REAL*8 ZRMU0(KDLON,KFLEV+1)
686	REAL*8 ZR(KDLON,4)
687	REAL*8 ZTAUAZ(KDLON,KFLEV)
688	REAL*8 ZTRA1(KDLON,KFLEV+1)
689	REAL*8 ZTRA2(KDLON,KFLEV+1)
690	REAL*8 ZW(KDLON,4)
691	C
692	INTEGER jl, jk, k, jaj, ikm1, ikl
693	c
694	c Prescribed Data:
695	c
696	REAL*8 RSUN(2)
697	SAVE RSUN
698	REAL*8 RRAY(2,6)
699	SAVE RRAY
700	DATA RSUN(1) / 0.441676 /
701	DATA RSUN(2) / 0.558324 /
702	DATA (RRAY(1,K),K=1,6) /
703	S .428937E-01, .890743E+00,-.288555E+01,
704	S .522744E+01,-.469173E+01, .161645E+01/
705	DATA (RRAY(2,K),K=1,6) /
706	S .697200E-02, .173297E-01,-.850903E-01,
707	S .248261E+00,-.302031E+00, .129662E+00/
708	C ------------------------------------------------------------------
709	C
710	C* 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
711	C ----------------------- ------------------
712	C
713	100 CONTINUE
714	C
715	C
716	C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
717	C -----------------------------------------
718	C
719	110 CONTINUE
720	C
721	DO 111 JL = 1, KDLON
722	ZRAYL(JL) = RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)
723	S * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)
724	S * (RRAY(KNU,5) + PRMU(JL) * RRAY(KNU,6) ))))
725	111 CONTINUE
726	C
727	C
728	C ------------------------------------------------------------------
729	C
730	C* 2. CONTINUUM SCATTERING CALCULATIONS
731	C ---------------------------------
732	C
733	200 CONTINUE
734	C
735	C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN
736	C --------------------------------
737	C
738	210 CONTINUE
739	C
740	CALL SWCLR ( KNU
741	S , PAER , PALBP , PDSIG , ZRAYL, PSEC
742	S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
743	S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
744	C
745	C
746	C* 2.2 CLOUDY FRACTION OF THE COLUMN
747	C -----------------------------
748	C
749	220 CONTINUE
750	C
751	CALL SWR ( KNU
752	S , PALBD ,PCG ,PCLD ,PDSIG ,POMEGA,ZRAYL
753	S , PSEC ,PTAU
754	S , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ ,ZRK,ZRMUE
755	S , ZTAUAZ,ZTRA1 ,ZTRA2)
756	C
757	C
758	C ------------------------------------------------------------------
759	C
760	C* 3. OZONE ABSORPTION
761	C ----------------
762	C
763	300 CONTINUE
764	C
765	IIND(1)=1
766	IIND(2)=3
767	IIND(3)=1
768	IIND(4)=3
769	C
770	C
771	C* 3.1 DOWNWARD FLUXES
772	C ---------------
773	C
774	310 CONTINUE
775	C
776	JAJ = 2
777	C
778	DO 311 JL = 1, KDLON
779	ZW(JL,1)=0.
780	ZW(JL,2)=0.
781	ZW(JL,3)=0.
782	ZW(JL,4)=0.
783	PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
784	S + PCLEAR(JL) ZRJ0(JL,JAJ,KFLEV+1)) RSUN(KNU)
785	311 CONTINUE
786	DO 314 JK = 1 , KFLEV
787	IKL = KFLEV+1-JK
788	DO 312 JL = 1, KDLON
789	ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
790	ZW(JL,2)=ZW(JL,2)+POZ(JL, IKL)/ZRMUE(JL,IKL)
791	ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
792	ZW(JL,4)=ZW(JL,4)+POZ(JL, IKL)/ZRMU0(JL,IKL)
793	312 CONTINUE
794	C
795	CALL SWTT1(KNU, 4, IIND, ZW, ZR)
796	C
797	DO 313 JL = 1, KDLON
798	ZDIFF(JL) = ZR(JL,1)ZR(JL,2)ZRJ(JL,JAJ,IKL)
799	ZDIRF(JL) = ZR(JL,3)ZR(JL,4)ZRJ0(JL,JAJ,IKL)
800	PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
801	S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU)
802	313 CONTINUE
803	314 CONTINUE
804	C
805	C
806	C* 3.2 UPWARD FLUXES
807	C -------------
808	C
809	320 CONTINUE
810	C
811	DO 325 JL = 1, KDLON
812	PFU(JL,1) = ((1.-PCLEAR(JL))ZDIFF(JL)PALBD(JL,KNU)
813	S + PCLEAR(JL) ZDIRF(JL)PALBP(JL,KNU))
814	S * RSUN(KNU)
815	325 CONTINUE
816	C
817	DO 328 JK = 2 , KFLEV+1
818	IKM1=JK-1
819	DO 326 JL = 1, KDLON
820	ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
821	ZW(JL,2)=ZW(JL,2)+POZ(JL, IKM1)*1.66
822	ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
823	ZW(JL,4)=ZW(JL,4)+POZ(JL, IKM1)*1.66
824	326 CONTINUE
825	C
826	CALL SWTT1(KNU, 4, IIND, ZW, ZR)
827	C
828	DO 327 JL = 1, KDLON
829	ZDIFF(JL) = ZR(JL,1)ZR(JL,2)ZRK(JL,JAJ,JK)
830	ZDIRF(JL) = ZR(JL,3)ZR(JL,4)ZRK0(JL,JAJ,JK)
831	PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
832	S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU)
833	327 CONTINUE
834	328 CONTINUE
835	C
836	C ------------------------------------------------------------------
837	C
838	RETURN
839	END
840	SUBROUTINE SW2S ( KNU
841	S , PAER ,PAKI, PALBD, PALBP, PCG , PCLD, PCLEAR, PCLDSW
842	S , PDSIG ,POMEGA,POZ , PRMU , PSEC , PTAU
843	S , PUD ,PWV , PQS
844	S , PFDOWN,PFUP )
845	IMPLICIT none
846	#include "dimensions.h"
847	#include "dimphy.h"
848	#include "raddim.h"
849	#include "radepsi.h"
850	C
851	C ------------------------------------------------------------------
852	C PURPOSE.
853	C --------
854	C
855	C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
856	C SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
857	C
858	C METHOD.
859	C -------
860	C
861	C 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
862	C CONTINUUM SCATTERING
863	C 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
864	C A GREY MOLECULAR ABSORPTION
865	C 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
866	C OF ABSORBERS
867	C 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
868	C 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
869	C
870	C REFERENCE.
871	C ----------
872	C
873	C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
874	C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
875	C
876	C AUTHOR.
877	C -------
878	C JEAN-JACQUES MORCRETTE ECMWF
879	C
880	C MODIFICATIONS.
881	C --------------
882	C ORIGINAL : 89-07-14
883	C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
884	C ------------------------------------------------------------------
885	C* ARGUMENTS:
886	C
887	INTEGER KNU
888	REAL*8 PAER(KDLON,KFLEV,5)
889	REAL*8 PAKI(KDLON,2)
890	REAL*8 PALBD(KDLON,2)
891	REAL*8 PALBP(KDLON,2)
892	REAL*8 PCG(KDLON,2,KFLEV)
893	REAL*8 PCLD(KDLON,KFLEV)
894	REAL*8 PCLDSW(KDLON,KFLEV)
895	REAL*8 PCLEAR(KDLON)
896	REAL*8 PDSIG(KDLON,KFLEV)
897	REAL*8 POMEGA(KDLON,2,KFLEV)
898	REAL*8 POZ(KDLON,KFLEV)
899	REAL*8 PQS(KDLON,KFLEV)
900	REAL*8 PRMU(KDLON)
901	REAL*8 PSEC(KDLON)
902	REAL*8 PTAU(KDLON,2,KFLEV)
903	REAL*8 PUD(KDLON,5,KFLEV+1)
904	REAL*8 PWV(KDLON,KFLEV)
905	C
906	REAL*8 PFDOWN(KDLON,KFLEV+1)
907	REAL*8 PFUP(KDLON,KFLEV+1)
908	C
909	C* LOCAL VARIABLES:
910	C
911	INTEGER IIND2(2), IIND3(3)
912	REAL*8 ZCGAZ(KDLON,KFLEV)
913	REAL*8 ZFD(KDLON,KFLEV+1)
914	REAL*8 ZFU(KDLON,KFLEV+1)
915	REAL*8 ZG(KDLON)
916	REAL*8 ZGG(KDLON)
917	REAL*8 ZPIZAZ(KDLON,KFLEV)
918	REAL*8 ZRAYL(KDLON)
919	REAL*8 ZRAY1(KDLON,KFLEV+1)
920	REAL*8 ZRAY2(KDLON,KFLEV+1)
921	REAL*8 ZREF(KDLON)
922	REAL*8 ZREFZ(KDLON,2,KFLEV+1)
923	REAL*8 ZRE1(KDLON)
924	REAL*8 ZRE2(KDLON)
925	REAL*8 ZRJ(KDLON,6,KFLEV+1)
926	REAL*8 ZRJ0(KDLON,6,KFLEV+1)
927	REAL*8 ZRK(KDLON,6,KFLEV+1)
928	REAL*8 ZRK0(KDLON,6,KFLEV+1)
929	REAL*8 ZRL(KDLON,8)
930	REAL*8 ZRMUE(KDLON,KFLEV+1)
931	REAL*8 ZRMU0(KDLON,KFLEV+1)
932	REAL*8 ZRMUZ(KDLON)
933	REAL*8 ZRNEB(KDLON)
934	REAL*8 ZRUEF(KDLON,8)
935	REAL*8 ZR1(KDLON)
936	REAL*8 ZR2(KDLON,2)
937	REAL*8 ZR3(KDLON,3)
938	REAL*8 ZR4(KDLON)
939	REAL*8 ZR21(KDLON)
940	REAL*8 ZR22(KDLON)
941	REAL*8 ZS(KDLON)
942	REAL*8 ZTAUAZ(KDLON,KFLEV)
943	REAL*8 ZTO1(KDLON)
944	REAL*8 ZTR(KDLON,2,KFLEV+1)
945	REAL*8 ZTRA1(KDLON,KFLEV+1)
946	REAL*8 ZTRA2(KDLON,KFLEV+1)
947	REAL*8 ZTR1(KDLON)
948	REAL*8 ZTR2(KDLON)
949	REAL*8 ZW(KDLON)
950	REAL*8 ZW1(KDLON)
951	REAL*8 ZW2(KDLON,2)
952	REAL*8 ZW3(KDLON,3)
953	REAL*8 ZW4(KDLON)
954	REAL*8 ZW5(KDLON)
955	C
956	INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
957	INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
958	REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
959	C
960	C* Prescribed Data:
961	C
962	REAL*8 RSUN(2)
963	SAVE RSUN
964	REAL*8 RRAY(2,6)
965	SAVE RRAY
966	DATA RSUN(1) / 0.441676 /
967	DATA RSUN(2) / 0.558324 /
968	DATA (RRAY(1,K),K=1,6) /
969	S .428937E-01, .890743E+00,-.288555E+01,
970	S .522744E+01,-.469173E+01, .161645E+01/
971	DATA (RRAY(2,K),K=1,6) /
972	S .697200E-02, .173297E-01,-.850903E-01,
973	S .248261E+00,-.302031E+00, .129662E+00/
974	C
975	C ------------------------------------------------------------------
976	C
977	C* 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
978	C -------------------------------------------
979	C
980	100 CONTINUE
981	C
982	C
983	C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
984	C -----------------------------------------
985	C
986	110 CONTINUE
987	C
988	DO 111 JL = 1, KDLON
989	ZRMUM1 = 1. - PRMU(JL)
990	ZRAYL(JL) = RRAY(KNU,1) + ZRMUM1 * (RRAY(KNU,2) + ZRMUM1
991	S * (RRAY(KNU,3) + ZRMUM1 * (RRAY(KNU,4) + ZRMUM1
992	S * (RRAY(KNU,5) + ZRMUM1 * RRAY(KNU,6) ))))
993	111 CONTINUE
994	C
995	C
996	C ------------------------------------------------------------------
997	C
998	C* 2. CONTINUUM SCATTERING CALCULATIONS
999	C ---------------------------------
1000	C
1001	200 CONTINUE
1002	C
1003	C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN
1004	C --------------------------------
1005	C
1006	210 CONTINUE
1007	C
1008	CALL SWCLR ( KNU
1009	S , PAER , PALBP , PDSIG , ZRAYL, PSEC
1010	S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
1011	S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
1012	C
1013	C
1014	C* 2.2 CLOUDY FRACTION OF THE COLUMN
1015	C -----------------------------
1016	C
1017	220 CONTINUE
1018	C
1019	CALL SWR ( KNU
1020	S , PALBD , PCG , PCLD , PDSIG, POMEGA, ZRAYL
1021	S , PSEC , PTAU
1022	S , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ , ZRK, ZRMUE
1023	S , ZTAUAZ, ZTRA1 , ZTRA2)
1024	C
1025	C
1026	C ------------------------------------------------------------------
1027	C
1028	C* 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
1029	C ------------------------------------------------------
1030	C
1031	300 CONTINUE
1032	C
1033	JN = 2
1034	C
1035	DO 361 JABS=1,2
1036	C
1037	C
1038	C* 3.1 SURFACE CONDITIONS
1039	C ------------------
1040	C
1041	310 CONTINUE
1042	C
1043	DO 311 JL = 1, KDLON
1044	ZREFZ(JL,2,1) = PALBD(JL,KNU)
1045	ZREFZ(JL,1,1) = PALBD(JL,KNU)
1046	311 CONTINUE
1047	C
1048	C
1049	C* 3.2 INTRODUCING CLOUD EFFECTS
1050	C -------------------------
1051	C
1052	320 CONTINUE
1053	C
1054	DO 324 JK = 2 , KFLEV+1
1055	JKM1 = JK - 1
1056	IKL=KFLEV+1-JKM1
1057	DO 322 JL = 1, KDLON
1058	ZRNEB(JL) = PCLD(JL,JKM1)
1059	IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
1060	ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
1061	ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
1062	ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
1063	ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
1064	ELSE
1065	ZAA=PUD(JL,JABS,JKM1)
1066	ZBB=ZAA
1067	END IF
1068	ZRKI = PAKI(JL,JABS)
1069	ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
1070	ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
1071	ZTR1(JL) = 0.
1072	ZRE1(JL) = 0.
1073	ZTR2(JL) = 0.
1074	ZRE2(JL) = 0.
1075	C
1076	ZW(JL)= POMEGA(JL,KNU,JKM1)
1077	ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
1078	S + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
1079	S + ZBB * ZRKI
1080
1081	ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
1082	ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
1083	ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
1084	S + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
1085	ZW(JL) = ZR21(JL) / ZTO1(JL)
1086	ZREF(JL) = ZREFZ(JL,1,JKM1)
1087	ZRMUZ(JL) = ZRMUE(JL,JK)
1088	322 CONTINUE
1089	C
1090	CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,
1091	S ZRE1, ZRE2, ZTR1, ZTR2)
1092	C
1093	DO 323 JL = 1, KDLON
1094	C
1095	ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
1096	S + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
1097	S * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
1098	S + ZRNEB(JL) * ZRE1(JL)
1099	C
1100	ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
1101	S + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
1102	C
1103	ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
1104	S +ZREFZ(JL,1,JKM1)ZTRA1(JL,JKM1)ZTRA2(JL,JKM1)
1105	S /(1.-ZRAY2(JL,JKM1)ZREFZ(JL,1,JKM1)))ZG(JL)*ZS(JL)
1106	S + ZRNEB(JL) * ZRE2(JL)
1107	C
1108	ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
1109	S + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
1110	S * ZREFZ(JL,1,JKM1)))
1111	S * ZG(JL) * (1. -ZRNEB(JL))
1112	C
1113	323 CONTINUE
1114	324 CONTINUE
1115	C
1116	C* 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
1117	C -------------------------------------------------
1118	C
1119	330 CONTINUE
1120	C
1121	DO 351 JREF=1,2
1122	C
1123	JN = JN + 1
1124	C
1125	DO 331 JL = 1, KDLON
1126	ZRJ(JL,JN,KFLEV+1) = 1.
1127	ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
1128	331 CONTINUE
1129	C
1130	DO 333 JK = 1 , KFLEV
1131	JKL = KFLEV+1 - JK
1132	JKLP1 = JKL + 1
1133	DO 332 JL = 1, KDLON
1134	ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
1135	ZRJ(JL,JN,JKL) = ZRE11
1136	ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
1137	332 CONTINUE
1138	333 CONTINUE
1139	351 CONTINUE
1140	361 CONTINUE
1141	C
1142	C
1143	C ------------------------------------------------------------------
1144	C
1145	C* 4. INVERT GREY AND CONTINUUM FLUXES
1146	C --------------------------------
1147	C
1148	400 CONTINUE
1149	C
1150	C
1151	C* 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
1152	C ---------------------------------------------
1153	C
1154	410 CONTINUE
1155	C
1156	DO 414 JK = 1 , KFLEV+1
1157	DO 413 JAJ = 1 , 5 , 2
1158	JAJP = JAJ + 1
1159	DO 412 JL = 1, KDLON
1160	ZRJ(JL,JAJ,JK)= ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
1161	ZRK(JL,JAJ,JK)= ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
1162	ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
1163	ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
1164	412 CONTINUE
1165	413 CONTINUE
1166	414 CONTINUE
1167	C
1168	DO 417 JK = 1 , KFLEV+1
1169	DO 416 JAJ = 2 , 6 , 2
1170	DO 415 JL = 1, KDLON
1171	ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
1172	ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
1173	415 CONTINUE
1174	416 CONTINUE
1175	417 CONTINUE
1176	C
1177	C* 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
1178	C ---------------------------------------------
1179	C
1180	420 CONTINUE
1181	C
1182	DO 437 JK = 1 , KFLEV+1
1183	JKKI = 1
1184	DO 425 JAJ = 1 , 2
1185	IIND2(1)=JAJ
1186	IIND2(2)=JAJ
1187	DO 424 JN = 1 , 2
1188	JN2J = JN + 2 * JAJ
1189	JKKP4 = JKKI + 4
1190	C
1191	C* 4.2.1 EFFECTIVE ABSORBER AMOUNTS
1192	C --------------------------
1193	C
1194	4210 CONTINUE
1195	C
1196	DO 4211 JL = 1, KDLON
1197	ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
1198	S / PAKI(JL,JAJ)
1199	ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
1200	S / PAKI(JL,JAJ)
1201	4211 CONTINUE
1202	C
1203	C* 4.2.2 TRANSMISSION FUNCTION
1204	C ---------------------
1205	C
1206	4220 CONTINUE
1207	C
1208	CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)
1209	C
1210	DO 4221 JL = 1, KDLON
1211	ZRL(JL,JKKI) = ZR2(JL,1)
1212	ZRUEF(JL,JKKI) = ZW2(JL,1)
1213	ZRL(JL,JKKP4) = ZR2(JL,2)
1214	ZRUEF(JL,JKKP4) = ZW2(JL,2)
1215	4221 CONTINUE
1216	C
1217	JKKI=JKKI+1
1218	424 CONTINUE
1219	425 CONTINUE
1220	C
1221	C* 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
1222	C ------------------------------------------------------
1223	C
1224	430 CONTINUE
1225	C
1226	DO 431 JL = 1, KDLON
1227	PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
1228	S + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
1229	PFUP(JL,JK) = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
1230	S + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
1231	431 CONTINUE
1232	437 CONTINUE
1233	C
1234	C
1235	C ------------------------------------------------------------------
1236	C
1237	C* 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
1238	C ----------------------------------------
1239	C
1240	500 CONTINUE
1241	C
1242	C
1243	C* 5.1 DOWNWARD FLUXES
1244	C ---------------
1245	C
1246	510 CONTINUE
1247	C
1248	JAJ = 2
1249	IIND3(1)=1
1250	IIND3(2)=2
1251	IIND3(3)=3
1252	C
1253	DO 511 JL = 1, KDLON
1254	ZW3(JL,1)=0.
1255	ZW3(JL,2)=0.
1256	ZW3(JL,3)=0.
1257	ZW4(JL) =0.
1258	ZW5(JL) =0.
1259	ZR4(JL) =1.
1260	ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
1261	511 CONTINUE
1262	DO 514 JK = 1 , KFLEV
1263	IKL = KFLEV+1-JK
1264	DO 512 JL = 1, KDLON
1265	ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
1266	ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
1267	ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKL)/ZRMU0(JL,IKL)
1268	ZW4(JL) =ZW4(JL) +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
1269	ZW5(JL) =ZW5(JL) +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
1270	512 CONTINUE
1271	C
1272	CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
1273	C
1274	DO 513 JL = 1, KDLON
1275	C ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
1276	ZFD(JL,IKL) = ZR3(JL,1)ZR3(JL,2)ZR3(JL,3)*ZR4(JL)
1277	S * ZRJ0(JL,JAJ,IKL)
1278	513 CONTINUE
1279	514 CONTINUE
1280	C
1281	C
1282	C* 5.2 UPWARD FLUXES
1283	C -------------
1284	C
1285	520 CONTINUE
1286	C
1287	DO 525 JL = 1, KDLON
1288	ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
1289	525 CONTINUE
1290	C
1291	DO 528 JK = 2 , KFLEV+1
1292	IKM1=JK-1
1293	DO 526 JL = 1, KDLON
1294	ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
1295	ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
1296	ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKM1)*1.66
1297	ZW4(JL) =ZW4(JL) +PUD(JL,4,IKM1)*1.66
1298	ZW5(JL) =ZW5(JL) +PUD(JL,5,IKM1)*1.66
1299	526 CONTINUE
1300	C
1301	CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
1302	C
1303	DO 527 JL = 1, KDLON
1304	C ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
1305	ZFU(JL,JK) = ZR3(JL,1)ZR3(JL,2)ZR3(JL,3)*ZR4(JL)
1306	S * ZRK0(JL,JAJ,JK)
1307	527 CONTINUE
1308	528 CONTINUE
1309	C
1310	C
1311	C ------------------------------------------------------------------
1312	C
1313	C* 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
1314	C --------------------------------------------------
1315	C
1316	600 CONTINUE
1317	IABS=3
1318	C
1319	C* 6.1 DOWNWARD FLUXES
1320	C ---------------
1321	C
1322	610 CONTINUE
1323	DO 611 JL = 1, KDLON
1324	ZW1(JL)=0.
1325	ZW4(JL)=0.
1326	ZW5(JL)=0.
1327	ZR1(JL)=0.
1328	PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)
1329	S + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
1330	611 CONTINUE
1331	C
1332	DO 614 JK = 1 , KFLEV
1333	IKL=KFLEV+1-JK
1334	DO 612 JL = 1, KDLON
1335	ZW1(JL) = ZW1(JL)+POZ(JL, IKL)/ZRMUE(JL,IKL)
1336	ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
1337	ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
1338	C ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
1339	612 CONTINUE
1340	C
1341	CALL SWTT(KNU, IABS, ZW1, ZR1)
1342	C
1343	DO 613 JL = 1, KDLON
1344	PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))ZR1(JL)ZR4(JL)*PFDOWN(JL,IKL)
1345	S +PCLEAR(JL)ZFD(JL,IKL)) RSUN(KNU)
1346	613 CONTINUE
1347	614 CONTINUE
1348	C
1349	C
1350	C* 6.2 UPWARD FLUXES
1351	C -------------
1352	C
1353	620 CONTINUE
1354	DO 621 JL = 1, KDLON
1355	PFUP(JL,1) = ((1.-PCLEAR(JL))ZR1(JL)ZR4(JL) * PFUP(JL,1)
1356	S +PCLEAR(JL)ZFU(JL,1)) RSUN(KNU)
1357	621 CONTINUE
1358	C
1359	DO 624 JK = 2 , KFLEV+1
1360	IKM1=JK-1
1361	DO 622 JL = 1, KDLON
1362	ZW1(JL) = ZW1(JL)+POZ(JL ,IKM1)*1.66
1363	ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
1364	ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
1365	C ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
1366	622 CONTINUE
1367	C
1368	CALL SWTT(KNU, IABS, ZW1, ZR1)
1369	C
1370	DO 623 JL = 1, KDLON
1371	PFUP(JL,JK) = ((1.-PCLEAR(JL))ZR1(JL)ZR4(JL) * PFUP(JL,JK)
1372	S +PCLEAR(JL)ZFU(JL,JK)) RSUN(KNU)
1373	623 CONTINUE
1374	624 CONTINUE
1375	C
1376	C ------------------------------------------------------------------
1377	C
1378	RETURN
1379	END
1380	SUBROUTINE SWCLR ( KNU
1381	S , PAER , PALBP , PDSIG , PRAYL , PSEC
1382	S , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ
1383	S , PRK , PRMU0 , PTAUAZ, PTRA1 , PTRA2 )
1384	IMPLICIT none
1385	#include "dimensions.h"
1386	#include "dimphy.h"
1387	#include "raddim.h"
1388	#include "radepsi.h"
1389	#include "radopt.h"
1390	C
1391	C ------------------------------------------------------------------
1392	C PURPOSE.
1393	C --------
1394	C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
1395	C CLEAR-SKY COLUMN
1396	C
1397	C REFERENCE.
1398	C ----------
1399	C
1400	C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
1401	C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
1402	C
1403	C AUTHOR.
1404	C -------
1405	C JEAN-JACQUES MORCRETTE ECMWF
1406	C
1407	C MODIFICATIONS.
1408	C --------------
1409	C ORIGINAL : 94-11-15
1410	C ------------------------------------------------------------------
1411	C* ARGUMENTS:
1412	C
1413	INTEGER KNU
1414	REAL*8 PAER(KDLON,KFLEV,5)
1415	REAL*8 PALBP(KDLON,2)
1416	REAL*8 PDSIG(KDLON,KFLEV)
1417	REAL*8 PRAYL(KDLON)
1418	REAL*8 PSEC(KDLON)
1419	C
1420	REAL*8 PCGAZ(KDLON,KFLEV)
1421	REAL*8 PPIZAZ(KDLON,KFLEV)
1422	REAL*8 PRAY1(KDLON,KFLEV+1)
1423	REAL*8 PRAY2(KDLON,KFLEV+1)
1424	REAL*8 PREFZ(KDLON,2,KFLEV+1)
1425	REAL*8 PRJ(KDLON,6,KFLEV+1)
1426	REAL*8 PRK(KDLON,6,KFLEV+1)
1427	REAL*8 PRMU0(KDLON,KFLEV+1)
1428	REAL*8 PTAUAZ(KDLON,KFLEV)
1429	REAL*8 PTRA1(KDLON,KFLEV+1)
1430	REAL*8 PTRA2(KDLON,KFLEV+1)
1431	C
1432	C* LOCAL VARIABLES:
1433	C
1434	REAL*8 ZC0I(KDLON,KFLEV+1)
1435	REAL*8 ZCLE0(KDLON,KFLEV)
1436	REAL*8 ZCLEAR(KDLON)
1437	REAL*8 ZR21(KDLON)
1438	REAL*8 ZR23(KDLON)
1439	REAL*8 ZSS0(KDLON)
1440	REAL*8 ZSCAT(KDLON)
1441	REAL*8 ZTR(KDLON,2,KFLEV+1)
1442	C
1443	INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
1444	REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
1445	REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
1446	REAL*8 ZBMU0, ZBMU1, ZRE11
1447	C
1448	C* Prescribed Data for Aerosols:
1449	C
1450	REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)
1451	SAVE TAUA, RPIZA, RCGA
1452	DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /
1453	S .730719, .912819, .725059, .745405, .682188 ,
1454	S .730719, .912819, .725059, .745405, .682188 /
1455	DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /
1456	S .872212, .982545, .623143, .944887, .997975 ,
1457	S .872212, .982545, .623143, .944887, .997975 /
1458	DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /
1459	S .647596, .739002, .580845, .662657, .624246 ,
1460	S .647596, .739002, .580845, .662657, .624246 /
1461	C ------------------------------------------------------------------
1462	C
1463	C* 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
1464	C --------------------------------------------
1465	C
1466	100 CONTINUE
1467	C
1468	DO 103 JK = 1 , KFLEV+1
1469	DO 102 JA = 1 , 6
1470	DO 101 JL = 1, KDLON
1471	PRJ(JL,JA,JK) = 0.
1472	PRK(JL,JA,JK) = 0.
1473	101 CONTINUE
1474	102 CONTINUE
1475	103 CONTINUE
1476	C
1477	DO 108 JK = 1 , KFLEV
1478	DO 104 JL = 1, KDLON
1479	PCGAZ(JL,JK) = 0.
1480	PPIZAZ(JL,JK) = 0.
1481	PTAUAZ(JL,JK) = 0.
1482	104 CONTINUE
1483	DO 106 JAE=1,5
1484	DO 105 JL = 1, KDLON
1485	PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
1486	S +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
1487	PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
1488	S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
1489	PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE)
1490	S * TAUA(KNU,JAE)RPIZA(KNU,JAE)RCGA(KNU,JAE)
1491	105 CONTINUE
1492	106 CONTINUE
1493	C
1494	DO 107 JL = 1, KDLON
1495	IF (KAER.NE.0) THEN
1496	PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
1497	PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
1498	ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
1499	ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
1500	ZGAR = PCGAZ(JL,JK)
1501	ZFF = ZGAR * ZGAR
1502	PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)(1.-PPIZAZ(JL,JK)ZFF)
1503	PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
1504	PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)PPIZAZ(JL,JK)(1.-ZFF)
1505	S / (1. - PPIZAZ(JL,JK) * ZFF)
1506	ELSE
1507	ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
1508	PTAUAZ(JL,JK) = ZTRAY
1509	PCGAZ(JL,JK) = 0.
1510	PPIZAZ(JL,JK) = 1.-REPSCT
1511	END IF
1512	107 CONTINUE
1513	c PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
1514	c $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
1515	c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
1516	C
1517	108 CONTINUE
1518	C
1519	C ------------------------------------------------------------------
1520	C
1521	C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
1522	C ----------------------------------------------
1523	C
1524	200 CONTINUE
1525	C
1526	DO 201 JL = 1, KDLON
1527	ZR23(JL) = 0.
1528	ZC0I(JL,KFLEV+1) = 0.
1529	ZCLEAR(JL) = 1.
1530	ZSCAT(JL) = 0.
1531	201 CONTINUE
1532	C
1533	JK = 1
1534	JKL = KFLEV+1 - JK
1535	JKLP1 = JKL + 1
1536	DO 202 JL = 1, KDLON
1537	ZFACOA = 1. - PPIZAZ(JL,JKL)PCGAZ(JL,JKL)PCGAZ(JL,JKL)
1538	ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
1539	ZR21(JL) = EXP(-ZCORAE )
1540	ZSS0(JL) = 1.-ZR21(JL)
1541	ZCLE0(JL,JKL) = ZSS0(JL)
1542	C
1543	IF (NOVLP.EQ.1) THEN
1544	c* maximum-random
1545	ZCLEAR(JL) = ZCLEAR(JL)
1546	S *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
1547	S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
1548	ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
1549	ZSCAT(JL) = ZSS0(JL)
1550	ELSE IF (NOVLP.EQ.2) THEN
1551	C* maximum
1552	ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
1553	ZC0I(JL,JKL) = ZSCAT(JL)
1554	ELSE IF (NOVLP.EQ.3) THEN
1555	c* random
1556	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
1557	ZSCAT(JL) = 1.0 - ZCLEAR(JL)
1558	ZC0I(JL,JKL) = ZSCAT(JL)
1559	END IF
1560	202 CONTINUE
1561	C
1562	DO 205 JK = 2 , KFLEV
1563	JKL = KFLEV+1 - JK
1564	JKLP1 = JKL + 1
1565	DO 204 JL = 1, KDLON
1566	ZFACOA = 1. - PPIZAZ(JL,JKL)PCGAZ(JL,JKL)PCGAZ(JL,JKL)
1567	ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
1568	ZR21(JL) = EXP(-ZCORAE )
1569	ZSS0(JL) = 1.-ZR21(JL)
1570	ZCLE0(JL,JKL) = ZSS0(JL)
1571	c
1572	IF (NOVLP.EQ.1) THEN
1573	c* maximum-random
1574	ZCLEAR(JL) = ZCLEAR(JL)
1575	S *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
1576	S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
1577	ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
1578	ZSCAT(JL) = ZSS0(JL)
1579	ELSE IF (NOVLP.EQ.2) THEN
1580	C* maximum
1581	ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
1582	ZC0I(JL,JKL) = ZSCAT(JL)
1583	ELSE IF (NOVLP.EQ.3) THEN
1584	c* random
1585	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
1586	ZSCAT(JL) = 1.0 - ZCLEAR(JL)
1587	ZC0I(JL,JKL) = ZSCAT(JL)
1588	END IF
1589	204 CONTINUE
1590	205 CONTINUE
1591	C
1592	C ------------------------------------------------------------------
1593	C
1594	C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
1595	C -----------------------------------------------
1596	C
1597	300 CONTINUE
1598	C
1599	DO 301 JL = 1, KDLON
1600	PRAY1(JL,KFLEV+1) = 0.
1601	PRAY2(JL,KFLEV+1) = 0.
1602	PREFZ(JL,2,1) = PALBP(JL,KNU)
1603	PREFZ(JL,1,1) = PALBP(JL,KNU)
1604	PTRA1(JL,KFLEV+1) = 1.
1605	PTRA2(JL,KFLEV+1) = 1.
1606	301 CONTINUE
1607	C
1608	DO 346 JK = 2 , KFLEV+1
1609	JKM1 = JK-1
1610	DO 342 JL = 1, KDLON
1611	C
1612	C
1613	C ------------------------------------------------------------------
1614	C
1615	C* 3.1 EQUIVALENT ZENITH ANGLE
1616	C -----------------------
1617	C
1618	310 CONTINUE
1619	C
1620	ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
1621	S + ZC0I(JL,JK) * 1.66
1622	PRMU0(JL,JK) = 1./ZMUE
1623	C
1624	C
1625	C ------------------------------------------------------------------
1626	C
1627	C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
1628	C ----------------------------------------------------
1629	C
1630	320 CONTINUE
1631	C
1632	ZGAP = PCGAZ(JL,JKM1)
1633	ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
1634	ZWW = PPIZAZ(JL,JKM1)
1635	ZTO = PTAUAZ(JL,JKM1)
1636	ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
1637	S + (1-ZWW) * (1. - ZWW +2.ZBMU0ZWW)ZTOZTOZMUEZMUE
1638	PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
1639	PTRA1(JL,JKM1) = 1. / ZDEN
1640	C
1641	ZMU1 = 0.5
1642	ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
1643	ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
1644	S + (1-ZWW) * (1. - ZWW +2.ZBMU1ZWW)ZTOZTO/ZMU1/ZMU1
1645	PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
1646	PTRA2(JL,JKM1) = 1. / ZDEN1
1647	C
1648	C
1649	C
1650	PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
1651	S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
1652	S * PTRA2(JL,JKM1)
1653	S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
1654	C
1655	ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
1656	S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
1657	C
1658	PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
1659	S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
1660	S * PTRA2(JL,JKM1) )
1661	C
1662	ZTR(JL,2,JKM1) = PTRA1(JL,JKM1)
1663	C
1664	342 CONTINUE
1665	346 CONTINUE
1666	DO 347 JL = 1, KDLON
1667	ZMUE = (1.-ZC0I(JL,1))PSEC(JL)+ZC0I(JL,1)1.66
1668	PRMU0(JL,1)=1./ZMUE
1669	347 CONTINUE
1670	C
1671	C
1672	C ------------------------------------------------------------------
1673	C
1674	C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
1675	C -------------------------------------------------
1676	C
1677	350 CONTINUE
1678	C
1679	IF (KNU.EQ.1) THEN
1680	JAJ = 2
1681	DO 351 JL = 1, KDLON
1682	PRJ(JL,JAJ,KFLEV+1) = 1.
1683	PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
1684	351 CONTINUE
1685	C
1686	DO 353 JK = 1 , KFLEV
1687	JKL = KFLEV+1 - JK
1688	JKLP1 = JKL + 1
1689	DO 352 JL = 1, KDLON
1690	ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL)
1691	PRJ(JL,JAJ,JKL) = ZRE11
1692	PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL)
1693	352 CONTINUE
1694	353 CONTINUE
1695	354 CONTINUE
1696	C
1697	ELSE
1698	C
1699	DO 358 JAJ = 1 , 2
1700	DO 355 JL = 1, KDLON
1701	PRJ(JL,JAJ,KFLEV+1) = 1.
1702	PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
1703	355 CONTINUE
1704	C
1705	DO 357 JK = 1 , KFLEV
1706	JKL = KFLEV+1 - JK
1707	JKLP1 = JKL + 1
1708	DO 356 JL = 1, KDLON
1709	ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
1710	PRJ(JL,JAJ,JKL) = ZRE11
1711	PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
1712	356 CONTINUE
1713	357 CONTINUE
1714	358 CONTINUE
1715	C
1716	END IF
1717	C
1718	C ------------------------------------------------------------------
1719	C
1720	RETURN
1721	END
1722	SUBROUTINE SWR ( KNU
1723	S , PALBD , PCG , PCLD , PDSIG, POMEGA, PRAYL
1724	S , PSEC , PTAU
1725	S , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ , PRK , PRMUE
1726	S , PTAUAZ, PTRA1 , PTRA2 )
1727	IMPLICIT none
1728	#include "dimensions.h"
1729	#include "dimphy.h"
1730	#include "raddim.h"
1731	#include "radepsi.h"
1732	#include "radopt.h"
1733	C
1734	C ------------------------------------------------------------------
1735	C PURPOSE.
1736	C --------
1737	C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
1738	C CONTINUUM SCATTERING
1739	C
1740	C METHOD.
1741	C -------
1742	C
1743	C 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
1744	C OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
1745	C
1746	C REFERENCE.
1747	C ----------
1748	C
1749	C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
1750	C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
1751	C
1752	C AUTHOR.
1753	C -------
1754	C JEAN-JACQUES MORCRETTE ECMWF
1755	C
1756	C MODIFICATIONS.
1757	C --------------
1758	C ORIGINAL : 89-07-14
1759	C ------------------------------------------------------------------
1760	C* ARGUMENTS:
1761	C
1762	INTEGER KNU
1763	REAL*8 PALBD(KDLON,2)
1764	REAL*8 PCG(KDLON,2,KFLEV)
1765	REAL*8 PCLD(KDLON,KFLEV)
1766	REAL*8 PDSIG(KDLON,KFLEV)
1767	REAL*8 POMEGA(KDLON,2,KFLEV)
1768	REAL*8 PRAYL(KDLON)
1769	REAL*8 PSEC(KDLON)
1770	REAL*8 PTAU(KDLON,2,KFLEV)
1771	C
1772	REAL*8 PRAY1(KDLON,KFLEV+1)
1773	REAL*8 PRAY2(KDLON,KFLEV+1)
1774	REAL*8 PREFZ(KDLON,2,KFLEV+1)
1775	REAL*8 PRJ(KDLON,6,KFLEV+1)
1776	REAL*8 PRK(KDLON,6,KFLEV+1)
1777	REAL*8 PRMUE(KDLON,KFLEV+1)
1778	REAL*8 PCGAZ(KDLON,KFLEV)
1779	REAL*8 PPIZAZ(KDLON,KFLEV)
1780	REAL*8 PTAUAZ(KDLON,KFLEV)
1781	REAL*8 PTRA1(KDLON,KFLEV+1)
1782	REAL*8 PTRA2(KDLON,KFLEV+1)
1783	C
1784	C* LOCAL VARIABLES:
1785	C
1786	REAL*8 ZC1I(KDLON,KFLEV+1)
1787	REAL*8 ZCLEQ(KDLON,KFLEV)
1788	REAL*8 ZCLEAR(KDLON)
1789	REAL*8 ZCLOUD(KDLON)
1790	REAL*8 ZGG(KDLON)
1791	REAL*8 ZREF(KDLON)
1792	REAL*8 ZRE1(KDLON)
1793	REAL*8 ZRE2(KDLON)
1794	REAL*8 ZRMUZ(KDLON)
1795	REAL*8 ZRNEB(KDLON)
1796	REAL*8 ZR21(KDLON)
1797	REAL*8 ZR22(KDLON)
1798	REAL*8 ZR23(KDLON)
1799	REAL*8 ZSS1(KDLON)
1800	REAL*8 ZTO1(KDLON)
1801	REAL*8 ZTR(KDLON,2,KFLEV+1)
1802	REAL*8 ZTR1(KDLON)
1803	REAL*8 ZTR2(KDLON)
1804	REAL*8 ZW(KDLON)
1805	C
1806	INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
1807	REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
1808	REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
1809	REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
1810	C
1811	C ------------------------------------------------------------------
1812	C
1813	C* 1. INITIALIZATION
1814	C --------------
1815	C
1816	100 CONTINUE
1817	C
1818	DO 103 JK = 1 , KFLEV+1
1819	DO 102 JA = 1 , 6
1820	DO 101 JL = 1, KDLON
1821	PRJ(JL,JA,JK) = 0.
1822	PRK(JL,JA,JK) = 0.
1823	101 CONTINUE
1824	102 CONTINUE
1825	103 CONTINUE
1826	C
1827	C
1828	C ------------------------------------------------------------------
1829	C
1830	C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
1831	C ----------------------------------------------
1832	C
1833	200 CONTINUE
1834	C
1835	DO 201 JL = 1, KDLON
1836	ZR23(JL) = 0.
1837	ZC1I(JL,KFLEV+1) = 0.
1838	ZCLEAR(JL) = 1.
1839	ZCLOUD(JL) = 0.
1840	201 CONTINUE
1841	C
1842	JK = 1
1843	JKL = KFLEV+1 - JK
1844	JKLP1 = JKL + 1
1845	DO 202 JL = 1, KDLON
1846	ZFACOA = 1. - PPIZAZ(JL,JKL)PCGAZ(JL,JKL)PCGAZ(JL,JKL)
1847	ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
1848	S * PCG(JL,KNU,JKL)
1849	ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
1850	ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
1851	ZR21(JL) = EXP(-ZCORAE )
1852	ZR22(JL) = EXP(-ZCORCD )
1853	ZSS1(JL) = PCLD(JL,JKL)(1.0-ZR21(JL)ZR22(JL))
1854	S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
1855	ZCLEQ(JL,JKL) = ZSS1(JL)
1856	C
1857	IF (NOVLP.EQ.1) THEN
1858	c* maximum-random
1859	ZCLEAR(JL) = ZCLEAR(JL)
1860	S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
1861	S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
1862	ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
1863	ZCLOUD(JL) = ZSS1(JL)
1864	ELSE IF (NOVLP.EQ.2) THEN
1865	C* maximum
1866	ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
1867	ZC1I(JL,JKL) = ZCLOUD(JL)
1868	ELSE IF (NOVLP.EQ.3) THEN
1869	c* random
1870	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
1871	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
1872	ZC1I(JL,JKL) = ZCLOUD(JL)
1873	END IF
1874	202 CONTINUE
1875	C
1876	DO 205 JK = 2 , KFLEV
1877	JKL = KFLEV+1 - JK
1878	JKLP1 = JKL + 1
1879	DO 204 JL = 1, KDLON
1880	ZFACOA = 1. - PPIZAZ(JL,JKL)PCGAZ(JL,JKL)PCGAZ(JL,JKL)
1881	ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
1882	S * PCG(JL,KNU,JKL)
1883	ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
1884	ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
1885	ZR21(JL) = EXP(-ZCORAE )
1886	ZR22(JL) = EXP(-ZCORCD )
1887	ZSS1(JL) = PCLD(JL,JKL)(1.0-ZR21(JL)ZR22(JL))
1888	S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
1889	ZCLEQ(JL,JKL) = ZSS1(JL)
1890	c
1891	IF (NOVLP.EQ.1) THEN
1892	c* maximum-random
1893	ZCLEAR(JL) = ZCLEAR(JL)
1894	S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
1895	S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
1896	ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
1897	ZCLOUD(JL) = ZSS1(JL)
1898	ELSE IF (NOVLP.EQ.2) THEN
1899	C* maximum
1900	ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
1901	ZC1I(JL,JKL) = ZCLOUD(JL)
1902	ELSE IF (NOVLP.EQ.3) THEN
1903	c* random
1904	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
1905	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
1906	ZC1I(JL,JKL) = ZCLOUD(JL)
1907	END IF
1908	204 CONTINUE
1909	205 CONTINUE
1910	C
1911	C ------------------------------------------------------------------
1912	C
1913	C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
1914	C -----------------------------------------------
1915	C
1916	300 CONTINUE
1917	C
1918	DO 301 JL = 1, KDLON
1919	PRAY1(JL,KFLEV+1) = 0.
1920	PRAY2(JL,KFLEV+1) = 0.
1921	PREFZ(JL,2,1) = PALBD(JL,KNU)
1922	PREFZ(JL,1,1) = PALBD(JL,KNU)
1923	PTRA1(JL,KFLEV+1) = 1.
1924	PTRA2(JL,KFLEV+1) = 1.
1925	301 CONTINUE
1926	C
1927	DO 346 JK = 2 , KFLEV+1
1928	JKM1 = JK-1
1929	DO 342 JL = 1, KDLON
1930	ZRNEB(JL)= PCLD(JL,JKM1)
1931	ZRE1(JL)=0.
1932	ZTR1(JL)=0.
1933	ZRE2(JL)=0.
1934	ZTR2(JL)=0.
1935	C
1936	C
1937	C ------------------------------------------------------------------
1938	C
1939	C* 3.1 EQUIVALENT ZENITH ANGLE
1940	C -----------------------
1941	C
1942	310 CONTINUE
1943	C
1944	ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
1945	S + ZC1I(JL,JK) * 1.66
1946	PRMUE(JL,JK) = 1./ZMUE
1947	C
1948	C
1949	C ------------------------------------------------------------------
1950	C
1951	C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
1952	C ----------------------------------------------------
1953	C
1954	320 CONTINUE
1955	C
1956	ZGAP = PCGAZ(JL,JKM1)
1957	ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
1958	ZWW = PPIZAZ(JL,JKM1)
1959	ZTO = PTAUAZ(JL,JKM1)
1960	ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
1961	S + (1-ZWW) * (1. - ZWW +2.ZBMU0ZWW)ZTOZTOZMUEZMUE
1962	PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
1963	PTRA1(JL,JKM1) = 1. / ZDEN
1964	c PRINT ,' LOOP 342 * 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
1965	C
1966	ZMU1 = 0.5
1967	ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
1968	ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
1969	S + (1-ZWW) * (1. - ZWW +2.ZBMU1ZWW)ZTOZTO/ZMU1/ZMU1
1970	PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
1971	PTRA2(JL,JKM1) = 1. / ZDEN1
1972	C
1973	C
1974	C ------------------------------------------------------------------
1975	C
1976	C* 3.3 EFFECT OF CLOUD LAYER
1977	C ---------------------
1978	C
1979	330 CONTINUE
1980	C
1981	ZW(JL) = POMEGA(JL,KNU,JKM1)
1982	ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
1983	S + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
1984	ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
1985	ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
1986	ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
1987	S + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
1988	C Modif PhD - JJM 19/03/96 pour erreurs arrondis
1989	C machine
1990	C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
1991	IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
1992	ZW(JL)=1.
1993	ELSE
1994	ZW(JL) = ZR21(JL) / ZTO1(JL)
1995	END IF
1996	ZREF(JL) = PREFZ(JL,1,JKM1)
1997	ZRMUZ(JL) = PRMUE(JL,JK)
1998	342 CONTINUE
1999	C
2000	CALL SWDE(ZGG , ZREF , ZRMUZ , ZTO1 , ZW,
2001	S ZRE1 , ZRE2 , ZTR1 , ZTR2)
2002	C
2003	DO 345 JL = 1, KDLON
2004	C
2005	PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
2006	S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
2007	S * PTRA2(JL,JKM1)
2008	S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
2009	S + ZRNEB(JL) * ZRE2(JL)
2010	C
2011	ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
2012	S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
2013	S * (1.-ZRNEB(JL))
2014	C
2015	PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
2016	S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
2017	S * PTRA2(JL,JKM1) )
2018	S + ZRNEB(JL) * ZRE1(JL)
2019	C
2020	ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
2021	S + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
2022	C
2023	345 CONTINUE
2024	346 CONTINUE
2025	DO 347 JL = 1, KDLON
2026	ZMUE = (1.-ZC1I(JL,1))PSEC(JL)+ZC1I(JL,1)1.66
2027	PRMUE(JL,1)=1./ZMUE
2028	347 CONTINUE
2029	C
2030	C
2031	C ------------------------------------------------------------------
2032	C
2033	C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
2034	C -------------------------------------------------
2035	C
2036	350 CONTINUE
2037	C
2038	IF (KNU.EQ.1) THEN
2039	JAJ = 2
2040	DO 351 JL = 1, KDLON
2041	PRJ(JL,JAJ,KFLEV+1) = 1.
2042	PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
2043	351 CONTINUE
2044	C
2045	DO 353 JK = 1 , KFLEV
2046	JKL = KFLEV+1 - JK
2047	JKLP1 = JKL + 1
2048	DO 352 JL = 1, KDLON
2049	ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL)
2050	PRJ(JL,JAJ,JKL) = ZRE11
2051	PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL)
2052	352 CONTINUE
2053	353 CONTINUE
2054	354 CONTINUE
2055	C
2056	ELSE
2057	C
2058	DO 358 JAJ = 1 , 2
2059	DO 355 JL = 1, KDLON
2060	PRJ(JL,JAJ,KFLEV+1) = 1.
2061	PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
2062	355 CONTINUE
2063	C
2064	DO 357 JK = 1 , KFLEV
2065	JKL = KFLEV+1 - JK
2066	JKLP1 = JKL + 1
2067	DO 356 JL = 1, KDLON
2068	ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
2069	PRJ(JL,JAJ,JKL) = ZRE11
2070	PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
2071	356 CONTINUE
2072	357 CONTINUE
2073	358 CONTINUE
2074	C
2075	END IF
2076	C
2077	C ------------------------------------------------------------------
2078	C
2079	RETURN
2080	END
2081	SUBROUTINE SWDE (PGG,PREF,PRMUZ,PTO1,PW,
2082	S PRE1,PRE2,PTR1,PTR2)
2083	IMPLICIT none
2084	#include "dimensions.h"
2085	#include "dimphy.h"
2086	#include "raddim.h"
2087	C
2088	C ------------------------------------------------------------------
2089	C PURPOSE.
2090	C --------
2091	C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
2092	C LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
2093	C
2094	C METHOD.
2095	C -------
2096	C
2097	C STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
2098	C
2099	C REFERENCE.
2100	C ----------
2101	C
2102	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2103	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2104	C
2105	C AUTHOR.
2106	C -------
2107	C JEAN-JACQUES MORCRETTE ECMWF
2108	C
2109	C MODIFICATIONS.
2110	C --------------
2111	C ORIGINAL : 88-12-15
2112	C ------------------------------------------------------------------
2113	C* ARGUMENTS:
2114	C
2115	REAL*8 PGG(KDLON) ! ASSYMETRY FACTOR
2116	REAL*8 PREF(KDLON) ! REFLECTIVITY OF THE UNDERLYING LAYER
2117	REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
2118	REAL*8 PTO1(KDLON) ! OPTICAL THICKNESS
2119	REAL*8 PW(KDLON) ! SINGLE SCATTERING ALBEDO
2120	REAL*8 PRE1(KDLON) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
2121	REAL*8 PRE2(KDLON) ! LAYER REFLECTIVITY
2122	REAL*8 PTR1(KDLON) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
2123	REAL*8 PTR2(KDLON) ! LAYER TRANSMISSIVITY
2124	C
2125	C* LOCAL VARIABLES:
2126	C
2127	INTEGER jl
2128	REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
2129	REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
2130	REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B
2131	REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
2132	REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
2133	REAL*8 ZRI0B, ZRI1B
2134	REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
2135	REAL*8 ZRI0C, ZRI1C, ZRI0D, ZRI1D
2136	C ------------------------------------------------------------------
2137	C
2138	C* 1. DELTA-EDDINGTON CALCULATIONS
2139	C
2140	100 CONTINUE
2141	C
2142	DO 131 JL = 1, KDLON
2143	C
2144	C* 1.1 SET UP THE DELTA-MODIFIED PARAMETERS
2145	C
2146	110 CONTINUE
2147	C
2148	ZFF = PGG(JL)*PGG(JL)
2149	ZGP = PGG(JL)/(1.+PGG(JL))
2150	ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
2151	ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
2152	ZDT = 2./3.
2153	ZX1 = 1.-ZWCP*ZGP
2154	ZWM = 1.-ZWCP
2155	ZRM2 = PRMUZ(JL) * PRMUZ(JL)
2156	ZRK = SQRT(3.ZWMZX1)
2157	ZX2 = 4.(1.-ZRKZRK*ZRM2)
2158	ZRP=ZRK/ZX1
2159	ZALPHA = 3.ZWCPZRM2(1.+ZGPZWM)/ZX2
2160	ZBETA = 3.ZWCP PRMUZ(JL) (1.+3.ZGPZRM2ZWM)/ZX2
2161	CMAF ZARG=MIN(ZTOP/PRMUZ(JL),200.)
2162	ZARG=MIN(ZTOP/PRMUZ(JL),2.0d+2)
2163	ZEXMU0=EXP(-ZARG)
2164	CMAF ZARG2=MIN(ZRK*ZTOP,200.)
2165	ZARG2=MIN(ZRK*ZTOP,2.0d+2)
2166	ZEXKP=EXP(ZARG2)
2167	ZEXKM = 1./ZEXKP
2168	ZXP2P = 1.+ZDT*ZRP
2169	ZXM2P = 1.-ZDT*ZRP
2170	ZAP2B = ZALPHA+ZDT*ZBETA
2171	ZAM2B = ZALPHA-ZDT*ZBETA
2172	C
2173	C* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER
2174	C
2175	120 CONTINUE
2176	C
2177	ZA11 = ZXP2P
2178	ZA12 = ZXM2P
2179	ZA13 = ZAP2B
2180	ZA22 = ZXP2P*ZEXKP
2181	ZA21 = ZXM2P*ZEXKM
2182	ZA23 = ZAM2B*ZEXMU0
2183	ZDENA = ZA11 * ZA22 - ZA21 * ZA12
2184	ZC1A = (ZA22ZA13-ZA12ZA23)/ZDENA
2185	ZC2A = (ZA11ZA23-ZA21ZA13)/ZDENA
2186	ZRI0A = ZC1A+ZC2A-ZALPHA
2187	ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
2188	PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
2189	ZRI0B = ZC1AZEXKM+ZC2AZEXKP-ZALPHA*ZEXMU0
2190	ZRI1B = ZRP(ZC1AZEXKM-ZC2AZEXKP)-ZBETAZEXMU0
2191	PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
2192	C
2193	C* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER
2194	C
2195	130 CONTINUE
2196	C
2197	ZB21 = ZA21- PREF(JL) ZXP2PZEXKM
2198	ZB22 = ZA22- PREF(JL) ZXM2PZEXKP
2199	ZB23 = ZA23- PREF(JL) ZEXMU0(ZAP2B - PRMUZ(JL) )
2200	ZDENB = ZA11 * ZB22 - ZB21 * ZA12
2201	ZC1B = (ZB22ZA13-ZA12ZB23)/ZDENB
2202	ZC2B = (ZA11ZB23-ZB21ZA13)/ZDENB
2203	ZRI0C = ZC1B+ZC2B-ZALPHA
2204	ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
2205	PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
2206	ZRI0D = ZC1BZEXKM + ZC2BZEXKP - ZALPHA*ZEXMU0
2207	ZRI1D = ZRP * (ZC1BZEXKM - ZC2BZEXKP) - ZBETA*ZEXMU0
2208	PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
2209	C
2210	131 CONTINUE
2211	RETURN
2212	END
2213	SUBROUTINE SWTT (KNU,KA,PU,PTR)
2214	IMPLICIT none
2215	#include "dimensions.h"
2216	#include "dimphy.h"
2217	#include "raddim.h"
2218	C
2219	C-----------------------------------------------------------------------
2220	C PURPOSE.
2221	C --------
2222	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2223	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2224	C INTERVALS.
2225	C
2226	C METHOD.
2227	C -------
2228	C
2229	C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2230	C AND HORNER'S ALGORITHM.
2231	C
2232	C REFERENCE.
2233	C ----------
2234	C
2235	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2236	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2237	C
2238	C AUTHOR.
2239	C -------
2240	C JEAN-JACQUES MORCRETTE ECMWF
2241	C
2242	C MODIFICATIONS.
2243	C --------------
2244	C ORIGINAL : 88-12-15
2245	C-----------------------------------------------------------------------
2246	C
2247	C* ARGUMENTS
2248	C
2249	INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL
2250	INTEGER KA ! INDEX OF THE ABSORBER
2251	REAL*8 PU(KDLON) ! ABSORBER AMOUNT
2252	C
2253	REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION
2254	C
2255	C* LOCAL VARIABLES:
2256	C
2257	REAL*8 ZR1(KDLON), ZR2(KDLON)
2258	INTEGER jl, i,j
2259	C
2260	C* Prescribed Data:
2261	C
2262	REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
2263	SAVE APAD, BPAD, D
2264	DATA ((APAD(1,I,J),I=1,3),J=1,7) /
2265	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2266	S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
2267	S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
2268	S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
2269	S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
2270	S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
2271	S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
2272	DATA ((APAD(2,I,J),I=1,3),J=1,7) /
2273	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2274	S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
2275	S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
2276	S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
2277	S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
2278	S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
2279	S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
2280	C
2281	DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
2282	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2283	S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
2284	S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
2285	S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
2286	S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
2287	S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
2288	S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
2289	DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
2290	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2291	S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
2292	S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
2293	S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
2294	S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
2295	S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
2296	S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
2297	c
2298	DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
2299	DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
2300	C
2301	C-----------------------------------------------------------------------
2302	C
2303	C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2304	C
2305	100 CONTINUE
2306	C
2307	DO 201 JL = 1, KDLON
2308	ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
2309	S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
2310	S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
2311	S * ( APAD(KNU,KA,7) ))))))
2312	C
2313	ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
2314	S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
2315	S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
2316	S * ( BPAD(KNU,KA,7) ))))))
2317	C
2318	C
2319	C* 2. ADD THE BACKGROUND TRANSMISSION
2320	C
2321	200 CONTINUE
2322	C
2323	C
2324	PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
2325	201 CONTINUE
2326	C
2327	RETURN
2328	END
2329	SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)
2330	IMPLICIT none
2331	#include "dimensions.h"
2332	#include "dimphy.h"
2333	#include "raddim.h"
2334	C
2335	C-----------------------------------------------------------------------
2336	C PURPOSE.
2337	C --------
2338	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2339	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2340	C INTERVALS.
2341	C
2342	C METHOD.
2343	C -------
2344	C
2345	C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2346	C AND HORNER'S ALGORITHM.
2347	C
2348	C REFERENCE.
2349	C ----------
2350	C
2351	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2352	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2353	C
2354	C AUTHOR.
2355	C -------
2356	C JEAN-JACQUES MORCRETTE ECMWF
2357	C
2358	C MODIFICATIONS.
2359	C --------------
2360	C ORIGINAL : 95-01-20
2361	C-----------------------------------------------------------------------
2362	C* ARGUMENTS:
2363	C
2364	INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL
2365	INTEGER KABS ! NUMBER OF ABSORBERS
2366	INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS
2367	REAL*8 PU(KDLON,KABS) ! ABSORBER AMOUNT
2368	C
2369	REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
2370	C
2371	C* LOCAL VARIABLES:
2372	C
2373	REAL*8 ZR1(KDLON)
2374	REAL*8 ZR2(KDLON)
2375	REAL*8 ZU(KDLON)
2376	INTEGER jl, ja, i, j, ia
2377	C
2378	C* Prescribed Data:
2379	C
2380	REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
2381	SAVE APAD, BPAD, D
2382	DATA ((APAD(1,I,J),I=1,3),J=1,7) /
2383	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2384	S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
2385	S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
2386	S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
2387	S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
2388	S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
2389	S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
2390	DATA ((APAD(2,I,J),I=1,3),J=1,7) /
2391	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2392	S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
2393	S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
2394	S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
2395	S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
2396	S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
2397	S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
2398	C
2399	DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
2400	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2401	S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
2402	S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
2403	S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
2404	S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
2405	S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
2406	S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
2407	DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
2408	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2409	S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
2410	S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
2411	S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
2412	S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
2413	S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
2414	S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
2415	c
2416	DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
2417	DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
2418	C-----------------------------------------------------------------------
2419	C
2420	C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2421	C
2422	100 CONTINUE
2423	C
2424	DO 202 JA = 1,KABS
2425	IA=KIND(JA)
2426	DO 201 JL = 1, KDLON
2427	ZU(JL) = PU(JL,JA)
2428	ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
2429	S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
2430	S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
2431	S * ( APAD(KNU,IA,7) ))))))
2432	C
2433	ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
2434	S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
2435	S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
2436	S * ( BPAD(KNU,IA,7) ))))))
2437	C
2438	C
2439	C* 2. ADD THE BACKGROUND TRANSMISSION
2440	C
2441	200 CONTINUE
2442	C
2443	PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA)
2444	201 CONTINUE
2445	202 CONTINUE
2446	C
2447	RETURN
2448	END
2449	SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
2450	. PPMB, PDP,
2451	. PPSOL,PDT0,PEMIS,
2452	. PTL, PTAVE, PWV, POZON, PAER,
2453	. PCLDLD,PCLDLU,
2454	. PVIEW,
2455	. PCOLR, PCOLR0,
2456	. PTOPLW,PSOLLW,PTOPLW0,PSOLLW0)
2457	IMPLICIT none
2458	#include "dimensions.h"
2459	#include "dimphy.h"
2460	#include "raddim.h"
2461	#include "raddimlw.h"
2462	#include "YOMCST.h"
2463	C
2464	C-----------------------------------------------------------------------
2465	C METHOD.
2466	C -------
2467	C
2468	C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2469	C ABSORBERS.
2470	C 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
2471	C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
2472	C 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
2473	C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
2474	C BOUNDARIES.
2475	C 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
2476	C 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
2477	C
2478	C
2479	C REFERENCE.
2480	C ----------
2481	C
2482	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2483	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2484	C
2485	C AUTHOR.
2486	C -------
2487	C JEAN-JACQUES MORCRETTE ECMWF
2488	C
2489	C MODIFICATIONS.
2490	C --------------
2491	C ORIGINAL : 89-07-14
2492	C-----------------------------------------------------------------------
2493	REAL8 RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06 44.011/28.97)
2494	REAL8 RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06 16.043/28.97)
2495	REAL8 RN2O ! N2O CONCENTRATION (IPCC: 310.E-09 44.013/28.97)
2496	REAL8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12 137.3686/28.97)
2497	REAL8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12 120.9140/28.97)
2498	REAL*8 PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER
2499	REAL*8 PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER
2500	REAL*8 PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa)
2501	REAL*8 PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K)
2502	REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
2503	REAL*8 PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb)
2504	REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (Pa)
2505	REAL*8 POZON(KDLON,KFLEV) ! O3 CONCENTRATION (kg/kg)
2506	REAL*8 PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K)
2507	REAL*8 PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS
2508	REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K)
2509	REAL*8 PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE
2510	REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg)
2511	C
2512	REAL*8 PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day)
2513	REAL*8 PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky
2514	REAL*8 PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A.
2515	REAL*8 PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE
2516	REAL*8 PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
2517	REAL*8 PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
2518	C
2519	C-------------------------------------------------------------------------
2520	REAL8 ZABCU(KDLON,NUA,3KFLEV+1)
2521	REAL*8 ZOZ(KDLON,KFLEV)
2522	c
2523	REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
2524	REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
2525	REAL*8 ZBINT(KDLON,KFLEV+1) ! Intermediate variable
2526	REAL*8 ZBSUI(KDLON) ! Intermediate variable
2527	REAL*8 ZCTS(KDLON,KFLEV) ! Intermediate variable
2528	REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable
2529	SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
2530	c
2531	INTEGER ilim, i, k, kpl1
2532	C
2533	INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
2534	PARAMETER (lw0pas=1)
2535	INTEGER lwpas ! Every lwpas steps, cloudy-sky is done
2536	PARAMETER (lwpas=1)
2537	c
2538	INTEGER itaplw0, itaplw
2539	LOGICAL appel1er
2540	SAVE appel1er, itaplw0, itaplw
2541	DATA appel1er /.TRUE./
2542	DATA itaplw0,itaplw /0,0/
2543	C ------------------------------------------------------------------
2544	IF (appel1er) THEN
2545	PRINT*, "LW clear-sky calling frequency: ", lw0pas
2546	PRINT*, "LW cloudy-sky calling frequency: ", lwpas
2547	PRINT*, " In general, they should be 1"
2548	appel1er=.FALSE.
2549	ENDIF
2550	C
2551	IF (MOD(itaplw0,lw0pas).EQ.0) THEN
2552	DO k = 1, KFLEV ! convertir ozone de kg/kg en pa/pa
2553	DO i = 1, KDLON
2554	ZOZ(i,k) = POZON(i,k)PDP(i,k) 28.9644/47.9942
2555	ENDDO
2556	ENDDO
2557	CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
2558	S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
2559	CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
2560	S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
2561	itaplw0 = 0
2562	ENDIF
2563	itaplw0 = itaplw0 + 1
2564	C
2565	IF (MOD(itaplw,lwpas).EQ.0) THEN
2566	CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS,
2567	S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
2568	S ZFLUX)
2569	itaplw = 0
2570	ENDIF
2571	itaplw = itaplw + 1
2572	C
2573	DO k = 1, KFLEV
2574	kpl1 = k+1
2575	DO i = 1, KDLON
2576	PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
2577	. - ZFLUX(i,1,k)- ZFLUX(i,2,k)
2578	PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
2579	PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
2580	. - ZFLUC(i,1,k)- ZFLUC(i,2,k)
2581	PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
2582	ENDDO
2583	ENDDO
2584	DO i = 1, KDLON
2585	PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
2586	PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
2587	c
2588	PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
2589	PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
2590	ENDDO
2591	C ------------------------------------------------------------------
2592	RETURN
2593	END
2594	SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
2595	S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
2596	S PABCU)
2597	IMPLICIT none
2598	#include "dimensions.h"
2599	#include "dimphy.h"
2600	#include "raddim.h"
2601	#include "raddimlw.h"
2602	#include "YOMCST.h"
2603	#include "radepsi.h"
2604	#include "radopt.h"
2605	C
2606	C PURPOSE.
2607	C --------
2608	C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
2609	C TEMPERATURE EFFECTS
2610	C
2611	C METHOD.
2612	C -------
2613	C
2614	C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2615	C ABSORBERS.
2616	C
2617	C
2618	C REFERENCE.
2619	C ----------
2620	C
2621	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2622	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2623	C
2624	C AUTHOR.
2625	C -------
2626	C JEAN-JACQUES MORCRETTE ECMWF
2627	C
2628	C MODIFICATIONS.
2629	C --------------
2630	C ORIGINAL : 89-07-14
2631	C Voigt lines (loop 404 modified) - JJM & PhD - 01/96
2632	C-----------------------------------------------------------------------
2633	C* ARGUMENTS:
2634	REAL*8 RCO2
2635	REAL*8 RCH4, RN2O, RCFC11, RCFC12
2636	REAL*8 PAER(KDLON,KFLEV,5)
2637	REAL*8 PDP(KDLON,KFLEV)
2638	REAL*8 PPMB(KDLON,KFLEV+1)
2639	REAL*8 PPSOL(KDLON)
2640	REAL*8 POZ(KDLON,KFLEV)
2641	REAL*8 PTAVE(KDLON,KFLEV)
2642	REAL*8 PVIEW(KDLON)
2643	REAL*8 PWV(KDLON,KFLEV)
2644	C
2645	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
2646	C
2647	C-----------------------------------------------------------------------
2648	C* LOCAL VARIABLES:
2649	REAL8 ZABLY(KDLON,NUA,3KFLEV+1)
2650	REAL8 ZDUC(KDLON,3KFLEV+1)
2651	REAL*8 ZPHIO(KDLON)
2652	REAL*8 ZPSC2(KDLON)
2653	REAL*8 ZPSC3(KDLON)
2654	REAL*8 ZPSH1(KDLON)
2655	REAL*8 ZPSH2(KDLON)
2656	REAL*8 ZPSH3(KDLON)
2657	REAL*8 ZPSH4(KDLON)
2658	REAL*8 ZPSH5(KDLON)
2659	REAL*8 ZPSH6(KDLON)
2660	REAL*8 ZPSIO(KDLON)
2661	REAL*8 ZTCON(KDLON)
2662	REAL*8 ZPHM6(KDLON)
2663	REAL*8 ZPSM6(KDLON)
2664	REAL*8 ZPHN6(KDLON)
2665	REAL*8 ZPSN6(KDLON)
2666	REAL8 ZSSIG(KDLON,3KFLEV+1)
2667	REAL*8 ZTAVI(KDLON)
2668	REAL*8 ZUAER(KDLON,Ninter)
2669	REAL*8 ZXOZ(KDLON)
2670	REAL*8 ZXWV(KDLON)
2671	C
2672	INTEGER jl, jk, jkj, jkjr, jkjp, ig1
2673	INTEGER jki, jkip1, ja, jj
2674	INTEGER jkl, jkp1, jkk, jkjpn
2675	INTEGER jae1, jae2, jae3, jae, jjpn
2676	INTEGER ir, jc, jcp1
2677	REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
2678	REAL*8 zfppw, ztx, ztx2, zzably
2679	REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
2680	REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
2681	REAL*8 zcac8, zcbc8
2682	REAL*8 zalup, zdiff
2683	c
2684	REAL*8 PVGCO2, PVGH2O, PVGO3
2685	C
2686	REAL*8 R10E ! DECIMAL/NATURAL LOG.FACTOR
2687	PARAMETER (R10E=0.4342945)
2688	c
2689	c Used Data Block:
2690	c
2691	REAL*8 TREF
2692	SAVE TREF
2693	REAL*8 RT1(2)
2694	SAVE RT1
2695	REAL*8 RAER(5,5)
2696	SAVE RAER
2697	REAL*8 AT(8,3), BT(8,3)
2698	SAVE AT, BT
2699	REAL*8 OCT(4)
2700	SAVE OCT
2701	DATA TREF /250.0/
2702	DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
2703	DATA RAER / .038520, .037196, .040532, .054934, .038520
2704	1 , .12613 , .18313 , .10357 , .064106, .126130
2705	2 , .012579, .013649, .018652, .025181, .012579
2706	3 , .011890, .016142, .021105, .028908, .011890
2707	4 , .013792, .026810, .052203, .066338, .013792 /
2708	DATA (AT(1,IR),IR=1,3) /
2709	S 0.298199E-02,-.394023E-03,0.319566E-04 /
2710	DATA (BT(1,IR),IR=1,3) /
2711	S-0.106432E-04,0.660324E-06,0.174356E-06 /
2712	DATA (AT(2,IR),IR=1,3) /
2713	S 0.143676E-01,0.366501E-02,-.160822E-02 /
2714	DATA (BT(2,IR),IR=1,3) /
2715	S-0.553979E-04,-.101701E-04,0.920868E-05 /
2716	DATA (AT(3,IR),IR=1,3) /
2717	S 0.197861E-01,0.315541E-02,-.174547E-02 /
2718	DATA (BT(3,IR),IR=1,3) /
2719	S-0.877012E-04,0.513302E-04,0.523138E-06 /
2720	DATA (AT(4,IR),IR=1,3) /
2721	S 0.289560E-01,-.208807E-02,-.121943E-02 /
2722	DATA (BT(4,IR),IR=1,3) /
2723	S-0.165960E-03,0.157704E-03,-.146427E-04 /
2724	DATA (AT(5,IR),IR=1,3) /
2725	S 0.103800E-01,0.436296E-02,-.161431E-02 /
2726	DATA (BT(5,IR),IR=1,3) /
2727	S -.276744E-04,-.327381E-04,0.127646E-04 /
2728	DATA (AT(6,IR),IR=1,3) /
2729	S 0.868859E-02,-.972752E-03,0.000000E-00 /
2730	DATA (BT(6,IR),IR=1,3) /
2731	S -.278412E-04,-.713940E-06,0.117469E-05 /
2732	DATA (AT(7,IR),IR=1,3) /
2733	S 0.250073E-03,0.455875E-03,0.109242E-03 /
2734	DATA (BT(7,IR),IR=1,3) /
2735	S 0.199846E-05,-.216313E-05,0.175991E-06 /
2736	DATA (AT(8,IR),IR=1,3) /
2737	S 0.307423E-01,0.110879E-02,-.322172E-03 /
2738	DATA (BT(8,IR),IR=1,3) /
2739	S-0.108482E-03,0.258096E-05,-.814575E-06 /
2740	c
2741	DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
2742	C-----------------------------------------------------------------------
2743	c
2744	IF (LEVOIGT) THEN
2745	PVGCO2= 60.
2746	PVGH2O= 30.
2747	PVGO3 =400.
2748	ELSE
2749	PVGCO2= 0.
2750	PVGH2O= 0.
2751	PVGO3 = 0.
2752	ENDIF
2753	C
2754	C
2755	C* 2. PRESSURE OVER GAUSS SUB-LEVELS
2756	C ------------------------------
2757	C
2758	200 CONTINUE
2759	C
2760	DO 201 JL = 1, KDLON
2761	ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
2762	201 CONTINUE
2763	C
2764	DO 206 JK = 1 , KFLEV
2765	JKJ=(JK-1)*NG1P1+1
2766	JKJR = JKJ
2767	JKJP = JKJ + NG1P1
2768	DO 203 JL = 1, KDLON
2769	ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
2770	203 CONTINUE
2771	DO 205 IG1=1,NG1
2772	JKJ=JKJ+1
2773	DO 204 JL = 1, KDLON
2774	ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
2775	S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
2776	204 CONTINUE
2777	205 CONTINUE
2778	206 CONTINUE
2779	C
2780	C-----------------------------------------------------------------------
2781	C
2782	C
2783	C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
2784	C --------------------------------------------------
2785	C
2786	400 CONTINUE
2787	C
2788	DO 402 JKI=1,3*KFLEV
2789	JKIP1=JKI+1
2790	DO 401 JL = 1, KDLON
2791	ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
2792	ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
2793	S /(10.*RG)
2794	401 CONTINUE
2795	402 CONTINUE
2796	C
2797	DO 406 JK = 1 , KFLEV
2798	JKP1=JK+1
2799	JKL = KFLEV+1 - JK
2800	DO 403 JL = 1, KDLON
2801	ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
2802	ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
2803	403 CONTINUE
2804	JKJ=(JK-1)*NG1P1+1
2805	JKJPN=JKJ+NG1
2806	DO 405 JKK=JKJ,JKJPN
2807	DO 404 JL = 1, KDLON
2808	ZDPM = ZABLY(JL,3,JKK)
2809	ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325.
2810	ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
2811	ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
2812	ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325.
2813	ZDUC(JL,JKK) = ZDPM
2814	ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
2815	ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
2816	ZU6 = ZXWV(JL) * ZUPM
2817	ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
2818	ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
2819	ZABLY(JL,11,JKK) = ZU6 * ZFPPW
2820	ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
2821	ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
2822	ZABLY(JL,8,JKK) = RCO2 * ZDPM
2823	404 CONTINUE
2824	405 CONTINUE
2825	406 CONTINUE
2826	C
2827	C-----------------------------------------------------------------------
2828	C
2829	C
2830	C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
2831	C --------------------------------------------------
2832	C
2833	500 CONTINUE
2834	C
2835	DO 502 JA = 1, NUA
2836	DO 501 JL = 1, KDLON
2837	PABCU(JL,JA,3*KFLEV+1) = 0.
2838	501 CONTINUE
2839	502 CONTINUE
2840	C
2841	DO 529 JK = 1 , KFLEV
2842	JJ=(JK-1)*NG1P1+1
2843	JJPN=JJ+NG1
2844	JKL=KFLEV+1-JK
2845	C
2846	C
2847	C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
2848	C --------------------------------------------------
2849	C
2850	510 CONTINUE
2851	C
2852	JAE1=3*KFLEV+1-JJ
2853	JAE2=3*KFLEV+1-(JJ+1)
2854	JAE3=3*KFLEV+1-JJPN
2855	DO 512 JAE=1,5
2856	DO 511 JL = 1, KDLON
2857	ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
2858	S +RAER(JAE,2)PAER(JL,JKL,2)+RAER(JAE,3)PAER(JL,JKL,3)
2859	S +RAER(JAE,4)PAER(JL,JKL,4)+RAER(JAE,5)PAER(JL,JKL,5))
2860	S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
2861	511 CONTINUE
2862	512 CONTINUE
2863	C
2864	C
2865	C
2866	C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
2867	C --------------------------------------------------
2868	C
2869	520 CONTINUE
2870	C
2871	DO 521 JL = 1, KDLON
2872	ZTAVI(JL)=PTAVE(JL,JKL)
2873	ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
2874	ZTX=ZTAVI(JL)-TREF
2875	ZTX2=ZTX*ZTX
2876	ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
2877	CMAF ZUP=MIN( MAX( 0.5R10ELOG( ZZABLY ) + 5., 0.), 6.0)
2878	ZUP=MIN( MAX( 0.5R10ELOG( ZZABLY ) + 5., 0.d+0), 6.d+0)
2879	ZCAH1=AT(1,1)+ZUP(AT(1,2)+ZUP(AT(1,3)))
2880	ZCBH1=BT(1,1)+ZUP(BT(1,2)+ZUP(BT(1,3)))
2881	ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
2882	ZCAH2=AT(2,1)+ZUP(AT(2,2)+ZUP(AT(2,3)))
2883	ZCBH2=BT(2,1)+ZUP(BT(2,2)+ZUP(BT(2,3)))
2884	ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
2885	ZCAH3=AT(3,1)+ZUP(AT(3,2)+ZUP(AT(3,3)))
2886	ZCBH3=BT(3,1)+ZUP(BT(3,2)+ZUP(BT(3,3)))
2887	ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
2888	ZCAH4=AT(4,1)+ZUP(AT(4,2)+ZUP(AT(4,3)))
2889	ZCBH4=BT(4,1)+ZUP(BT(4,2)+ZUP(BT(4,3)))
2890	ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
2891	ZCAH5=AT(5,1)+ZUP(AT(5,2)+ZUP(AT(5,3)))
2892	ZCBH5=BT(5,1)+ZUP(BT(5,2)+ZUP(BT(5,3)))
2893	ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
2894	ZCAH6=AT(6,1)+ZUP(AT(6,2)+ZUP(AT(6,3)))
2895	ZCBH6=BT(6,1)+ZUP(BT(6,2)+ZUP(BT(6,3)))
2896	ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
2897	ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
2898	ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
2899	ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
2900	ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
2901	521 CONTINUE
2902	C
2903	DO 522 JL = 1, KDLON
2904	ZTAVI(JL)=PTAVE(JL,JKL)
2905	ZTX=ZTAVI(JL)-TREF
2906	ZTX2=ZTX*ZTX
2907	ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
2908	ZALUP = R10E * LOG ( ZZABLY )
2909	CMAF ZUP = MAX( 0.0 , 5.0 + 0.5 * ZALUP )
2910	ZUP = MAX( 0.d+0 , 5.0 + 0.5 * ZALUP )
2911	ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
2912	ZCAC8=AT(8,1)+ZUP(AT(8,2)+ZUP(AT(8,3)))
2913	ZCBC8=BT(8,1)+ZUP(BT(8,2)+ZUP(BT(8,3)))
2914	ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
2915	ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
2916	ZPSIO(JL) = EXP( 2.* (OCT(3)ZTX+OCT(4)ZTX2))
2917	522 CONTINUE
2918	C
2919	DO 524 JKK=JJ,JJPN
2920	JC=3*KFLEV+1-JKK
2921	JCP1=JC+1
2922	DO 523 JL = 1, KDLON
2923	ZDIFF = PVIEW(JL)
2924	PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
2925	S +ZABLY(JL,10,JC) *ZDIFF
2926	PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
2927	S +ZABLY(JL,11,JC)ZTCON(JL)ZDIFF
2928	C
2929	PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
2930	S +ZABLY(JL,12,JC)ZPHIO(JL)ZDIFF
2931	PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
2932	S +ZABLY(JL,13,JC)ZPSIO(JL)ZDIFF
2933	C
2934	PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
2935	S +ZABLY(JL,9,JC)ZPSC2(JL)ZDIFF
2936	PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
2937	S +ZABLY(JL,9,JC)ZPSC3(JL)ZDIFF
2938	PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
2939	S +ZABLY(JL,9,JC)ZPSC3(JL)ZDIFF
2940	C
2941	PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
2942	S +ZABLY(JL,6,JC)ZPSH1(JL)ZDIFF
2943	PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
2944	S +ZABLY(JL,6,JC)ZPSH2(JL)ZDIFF
2945	PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
2946	S +ZABLY(JL,6,JC)ZPSH5(JL)ZDIFF
2947	PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
2948	S +ZABLY(JL,6,JC)ZPSH3(JL)ZDIFF
2949	PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
2950	S +ZABLY(JL,6,JC)ZPSH4(JL)ZDIFF
2951	PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
2952	S +ZABLY(JL,6,JC)ZPSH6(JL)ZDIFF
2953	C
2954	PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
2955	S +ZUAER(JL,1) ZDUC(JL,JC)ZDIFF
2956	PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
2957	S +ZUAER(JL,2) ZDUC(JL,JC)ZDIFF
2958	PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
2959	S +ZUAER(JL,3) ZDUC(JL,JC)ZDIFF
2960	PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
2961	S +ZUAER(JL,4) ZDUC(JL,JC)ZDIFF
2962	PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
2963	S +ZUAER(JL,5) ZDUC(JL,JC)ZDIFF
2964	C
2965	PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
2966	S +ZABLY(JL,8,JC)RCH4/RCO2ZPHM6(JL)*ZDIFF
2967	PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
2968	S +ZABLY(JL,9,JC)RCH4/RCO2ZPSM6(JL)*ZDIFF
2969	PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
2970	S +ZABLY(JL,8,JC)RN2O/RCO2ZPHN6(JL)*ZDIFF
2971	PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
2972	S +ZABLY(JL,9,JC)RN2O/RCO2ZPSN6(JL)*ZDIFF
2973	C
2974	PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
2975	S +ZABLY(JL,8,JC)RCFC11/RCO2 ZDIFF
2976	PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
2977	S +ZABLY(JL,8,JC)RCFC12/RCO2 ZDIFF
2978	523 CONTINUE
2979	524 CONTINUE
2980	C
2981	529 CONTINUE
2982	C
2983	C
2984	RETURN
2985	END
2986	SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
2987	S PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
2988	IMPLICIT none
2989	#include "dimensions.h"
2990	#include "dimphy.h"
2991	#include "raddim.h"
2992	#include "raddimlw.h"
2993	#include "YOMCST.h"
2994	C
2995	C PURPOSE.
2996	C --------
2997	C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
2998	C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
2999	C SAVING
3000	C
3001	C METHOD.
3002	C -------
3003	C
3004	C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
3005	C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
3006	C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
3007	C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
3008	C BOUNDARIES.
3009	C 3. COMPUTES THE CLEAR-SKY COOLING RATES.
3010	C
3011	C REFERENCE.
3012	C ----------
3013	C
3014	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3015	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3016	C
3017	C AUTHOR.
3018	C -------
3019	C JEAN-JACQUES MORCRETTE ECMWF
3020	C
3021	C MODIFICATIONS.
3022	C --------------
3023	C ORIGINAL : 89-07-14
3024	C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
3025	C MEMORY)
3026	C-----------------------------------------------------------------------
3027	C* ARGUMENTS:
3028	INTEGER KLIM
3029	C
3030	REAL*8 PDP(KDLON,KFLEV)
3031	REAL*8 PDT0(KDLON)
3032	REAL*8 PEMIS(KDLON)
3033	REAL*8 PPMB(KDLON,KFLEV+1)
3034	REAL*8 PTL(KDLON,KFLEV+1)
3035	REAL*8 PTAVE(KDLON,KFLEV)
3036	C
3037	REAL*8 PFLUC(KDLON,2,KFLEV+1)
3038	C
3039	REAL8 PABCU(KDLON,NUA,3KFLEV+1)
3040	REAL*8 PBINT(KDLON,KFLEV+1)
3041	REAL*8 PBSUI(KDLON)
3042	REAL*8 PCTS(KDLON,KFLEV)
3043	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
3044	C
3045	C-------------------------------------------------------------------------
3046	C
3047	C* LOCAL VARIABLES:
3048	REAL*8 ZB(KDLON,Ninter,KFLEV+1)
3049	REAL*8 ZBSUR(KDLON,Ninter)
3050	REAL*8 ZBTOP(KDLON,Ninter)
3051	REAL8 ZDBSL(KDLON,Ninter,KFLEV2)
3052	REAL*8 ZGA(KDLON,8,2,KFLEV)
3053	REAL*8 ZGB(KDLON,8,2,KFLEV)
3054	REAL*8 ZGASUR(KDLON,8,2)
3055	REAL*8 ZGBSUR(KDLON,8,2)
3056	REAL*8 ZGATOP(KDLON,8,2)
3057	REAL*8 ZGBTOP(KDLON,8,2)
3058	C
3059	INTEGER nuaer, ntraer
3060	C ------------------------------------------------------------------
3061	C* COMPUTES PLANCK FUNCTIONS:
3062	CALL LWB(PDT0,PTAVE,PTL,
3063	S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
3064	S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
3065	C ------------------------------------------------------------------
3066	C* PERFORMS THE VERTICAL INTEGRATION:
3067	NUAER = NUA
3068	NTRAER = NTRA
3069	CALL LWV(NUAER,NTRAER, KLIM
3070	R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
3071	R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
3072	S , PCNTRB,PCTS,PFLUC)
3073	C ------------------------------------------------------------------
3074	RETURN
3075	END
3076	SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
3077	R PBINT,PBSUIN,PCTS,PCNTRB,
3078	S PFLUX)
3079	IMPLICIT none
3080	#include "dimensions.h"
3081	#include "dimphy.h"
3082	#include "raddim.h"
3083	#include "radepsi.h"
3084	#include "radopt.h"
3085	C
3086	C PURPOSE.
3087	C --------
3088	C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
3089	C RADIANCES
3090	C
3091	C EXPLICIT ARGUMENTS :
3092	C --------------------
3093	C ==== INPUTS ===
3094	C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION
3095	C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3096	C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION
3097	C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION
3098	C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
3099	C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE
3100	C PEMIS : (KDLON) ; SURFACE EMISSIVITY
3101	C PFLUC
3102	C ==== OUTPUTS ===
3103	C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES :
3104	C 1 ==> UPWARD FLUX TOTAL
3105	C 2 ==> DOWNWARD FLUX TOTAL
3106	C
3107	C METHOD.
3108	C -------
3109	C
3110	C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
3111	C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
3112	C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
3113	C CLOUDS
3114	C
3115	C REFERENCE.
3116	C ----------
3117	C
3118	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3119	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3120	C
3121	C AUTHOR.
3122	C -------
3123	C JEAN-JACQUES MORCRETTE ECMWF
3124	C
3125	C MODIFICATIONS.
3126	C --------------
3127	C ORIGINAL : 89-07-14
3128	C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96
3129	C-----------------------------------------------------------------------
3130	C* ARGUMENTS:
3131	INTEGER klim
3132	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
3133	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3134	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3135	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
3136	REAL*8 PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE
3137	c
3138	REAL*8 PCLDLD(KDLON,KFLEV)
3139	REAL*8 PCLDLU(KDLON,KFLEV)
3140	REAL*8 PEMIS(KDLON)
3141	C
3142	REAL*8 PFLUX(KDLON,2,KFLEV+1)
3143	C-----------------------------------------------------------------------
3144	C* LOCAL VARIABLES:
3145	INTEGER IMX(KDLON), IMXP(KDLON)
3146	C
3147	REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
3148	S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
3149	S , ZUPF(KDLON,KFLEV+1,KFLEV+1)
3150	REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
3151	C
3152	INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
3153	INTEGER jk1, jk2, jkc, jkcp1, jcloud
3154	INTEGER imxm1, imxp1
3155	REAL*8 zcfrac
3156	C ------------------------------------------------------------------
3157	C
3158	C* 1. INITIALIZATION
3159	C --------------
3160	C
3161	100 CONTINUE
3162	C
3163	IMAXC = 0
3164	C
3165	DO 101 JL = 1, KDLON
3166	IMX(JL)=0
3167	IMXP(JL)=0
3168	ZCLOUD(JL) = 0.
3169	101 CONTINUE
3170	C
3171	C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
3172	C -------------------------------------------
3173	C
3174	110 CONTINUE
3175	C
3176	DO 112 JK = 1 , KFLEV
3177	DO 111 JL = 1, KDLON
3178	IMX1=IMX(JL)
3179	IMX2=JK
3180	IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
3181	IMXP(JL)=IMX2
3182	ELSE
3183	IMXP(JL)=IMX1
3184	END IF
3185	IMAXC=MAX(IMXP(JL),IMAXC)
3186	IMX(JL)=IMXP(JL)
3187	111 CONTINUE
3188	112 CONTINUE
3189	CGM*******
3190	IMAXC=KFLEV
3191	CGM*******
3192	C
3193	DO 114 JK = 1 , KFLEV+1
3194	DO 113 JL = 1, KDLON
3195	PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
3196	PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
3197	113 CONTINUE
3198	114 CONTINUE
3199	C
3200	C ------------------------------------------------------------------
3201	C
3202	C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
3203	C ---------------------------------------
3204	C
3205	IF (IMAXC.GT.0) THEN
3206	C
3207	IMXP1 = IMAXC + 1
3208	IMXM1 = IMAXC - 1
3209	C
3210	C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES
3211	C ------------------------------
3212	C
3213	200 CONTINUE
3214	C
3215	DO 203 JK1=1,KFLEV+1
3216	DO 202 JK2=1,KFLEV+1
3217	DO 201 JL = 1, KDLON
3218	ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
3219	ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
3220	201 CONTINUE
3221	202 CONTINUE
3222	203 CONTINUE
3223	C
3224	C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
3225	C ----------------------------------------------
3226	C
3227	210 CONTINUE
3228	C
3229	DO 213 JKC = 1 , IMAXC
3230	JCLOUD=JKC
3231	JKCP1=JCLOUD+1
3232	C
3233	C* 2.1.1 ABOVE THE CLOUD
3234	C ---------------
3235	C
3236	2110 CONTINUE
3237	C
3238	DO 2115 JK=JKCP1,KFLEV+1
3239	JKM1=JK-1
3240	DO 2111 JL = 1, KDLON
3241	ZFU(JL)=0.
3242	2111 CONTINUE
3243	IF (JK .GT. JKCP1) THEN
3244	DO 2113 JKJ=JKCP1,JKM1
3245	DO 2112 JL = 1, KDLON
3246	ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
3247	2112 CONTINUE
3248	2113 CONTINUE
3249	END IF
3250	C
3251	DO 2114 JL = 1, KDLON
3252	ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
3253	2114 CONTINUE
3254	2115 CONTINUE
3255	C
3256	C* 2.1.2 BELOW THE CLOUD
3257	C ---------------
3258	C
3259	2120 CONTINUE
3260	C
3261	DO 2125 JK=1,JCLOUD
3262	JKP1=JK+1
3263	DO 2121 JL = 1, KDLON
3264	ZFD(JL)=0.
3265	2121 CONTINUE
3266	C
3267	IF (JK .LT. JCLOUD) THEN
3268	DO 2123 JKJ=JKP1,JCLOUD
3269	DO 2122 JL = 1, KDLON
3270	ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
3271	2122 CONTINUE
3272	2123 CONTINUE
3273	END IF
3274	DO 2124 JL = 1, KDLON
3275	ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
3276	2124 CONTINUE
3277	2125 CONTINUE
3278	C
3279	213 CONTINUE
3280	C
3281	C
3282	C* 2.2 CLOUD COVER MATRIX
3283	C ------------------
3284	C
3285	C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
3286	C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
3287	C
3288	220 CONTINUE
3289	C
3290	DO 223 JK1 = 1 , KFLEV+1
3291	DO 222 JK2 = 1 , KFLEV+1
3292	DO 221 JL = 1, KDLON
3293	ZCLM(JL,JK1,JK2) = 0.
3294	221 CONTINUE
3295	222 CONTINUE
3296	223 CONTINUE
3297	C
3298	C
3299	C
3300	C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION
3301	C ------------------------------------------
3302	C
3303	240 CONTINUE
3304	C
3305	DO 244 JK1 = 2 , KFLEV+1
3306	DO 241 JL = 1, KDLON
3307	ZCLEAR(JL)=1.
3308	ZCLOUD(JL)=0.
3309	241 CONTINUE
3310	DO 243 JK = JK1 - 1 , 1 , -1
3311	DO 242 JL = 1, KDLON
3312	IF (NOVLP.EQ.1) THEN
3313	c* maximum-random
3314	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
3315	* /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3316	ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3317	ZCLOUD(JL) = PCLDLU(JL,JK)
3318	ELSE IF (NOVLP.EQ.2) THEN
3319	c* maximum
3320	ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
3321	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3322	ELSE IF (NOVLP.EQ.3) THEN
3323	c* random
3324	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
3325	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3326	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3327	END IF
3328	242 CONTINUE
3329	243 CONTINUE
3330	244 CONTINUE
3331	C
3332	C
3333	C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION
3334	C ------------------------------------------
3335	C
3336	250 CONTINUE
3337	C
3338	DO 254 JK1 = 1 , KFLEV
3339	DO 251 JL = 1, KDLON
3340	ZCLEAR(JL)=1.
3341	ZCLOUD(JL)=0.
3342	251 CONTINUE
3343	DO 253 JK = JK1 , KFLEV
3344	DO 252 JL = 1, KDLON
3345	IF (NOVLP.EQ.1) THEN
3346	c* maximum-random
3347	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
3348	* /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3349	ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3350	ZCLOUD(JL) = PCLDLD(JL,JK)
3351	ELSE IF (NOVLP.EQ.2) THEN
3352	c* maximum
3353	ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
3354	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3355	ELSE IF (NOVLP.EQ.3) THEN
3356	c* random
3357	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
3358	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3359	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3360	END IF
3361	252 CONTINUE
3362	253 CONTINUE
3363	254 CONTINUE
3364	C
3365	C
3366	C
3367	C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
3368	C ----------------------------------------------
3369	C
3370	300 CONTINUE
3371	C
3372	C* 3.1 DOWNWARD FLUXES
3373	C ---------------
3374	C
3375	310 CONTINUE
3376	C
3377	DO 311 JL = 1, KDLON
3378	PFLUX(JL,2,KFLEV+1) = 0.
3379	311 CONTINUE
3380	C
3381	DO 317 JK1 = KFLEV , 1 , -1
3382	C
3383	C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3384	C
3385	DO 312 JL = 1, KDLON
3386	ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
3387	312 CONTINUE
3388	C
3389	C* CONTRIBUTION FROM ADJACENT CLOUD
3390	C
3391	DO 313 JL = 1, KDLON
3392	ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
3393	313 CONTINUE
3394	C
3395	C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3396	C
3397	DO 315 JK = KFLEV-1 , JK1 , -1
3398	DO 314 JL = 1, KDLON
3399	ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
3400	ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
3401	314 CONTINUE
3402	315 CONTINUE
3403	C
3404	DO 316 JL = 1, KDLON
3405	PFLUX(JL,2,JK1) = ZFD (JL)
3406	316 CONTINUE
3407	C
3408	317 CONTINUE
3409	C
3410	C
3411	C
3412	C
3413	C* 3.2 UPWARD FLUX AT THE SURFACE
3414	C --------------------------
3415	C
3416	320 CONTINUE
3417	C
3418	DO 321 JL = 1, KDLON
3419	PFLUX(JL,1,1) = PEMIS(JL)PBSUIN(JL)-(1.-PEMIS(JL))PFLUX(JL,2,1)
3420	321 CONTINUE
3421	C
3422	C
3423	C
3424	C* 3.3 UPWARD FLUXES
3425	C -------------
3426	C
3427	330 CONTINUE
3428	C
3429	DO 337 JK1 = 2 , KFLEV+1
3430	C
3431	C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3432	C
3433	DO 332 JL = 1, KDLON
3434	ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
3435	332 CONTINUE
3436	C
3437	C* CONTRIBUTION FROM ADJACENT CLOUD
3438	C
3439	DO 333 JL = 1, KDLON
3440	ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
3441	333 CONTINUE
3442	C
3443	C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3444	C
3445	DO 335 JK = 2 , JK1-1
3446	DO 334 JL = 1, KDLON
3447	ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
3448	ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1)
3449	334 CONTINUE
3450	335 CONTINUE
3451	C
3452	DO 336 JL = 1, KDLON
3453	PFLUX(JL,1,JK1) = ZFU (JL)
3454	336 CONTINUE
3455	C
3456	337 CONTINUE
3457	C
3458	C
3459	END IF
3460	C
3461	C
3462	C* 2.3 END OF CLOUD EFFECT COMPUTATIONS
3463	C
3464	230 CONTINUE
3465	C
3466	IF (.NOT.LEVOIGT) THEN
3467	DO 231 JL = 1, KDLON
3468	ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
3469	231 CONTINUE
3470	DO 233 JK = KLIM+1 , KFLEV+1
3471	DO 232 JL = 1, KDLON
3472	ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
3473	PFLUX(JL,1,JK) = ZFN10(JL)
3474	PFLUX(JL,2,JK) = 0.0
3475	232 CONTINUE
3476	233 CONTINUE
3477	ENDIF
3478	C
3479	RETURN
3480	END
3481	SUBROUTINE LWB(PDT0,PTAVE,PTL
3482	S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
3483	S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
3484	IMPLICIT none
3485	#include "dimensions.h"
3486	#include "dimphy.h"
3487	#include "raddim.h"
3488	#include "raddimlw.h"
3489	C
3490	C-----------------------------------------------------------------------
3491	C PURPOSE.
3492	C --------
3493	C COMPUTES PLANCK FUNCTIONS
3494	C
3495	C EXPLICIT ARGUMENTS :
3496	C --------------------
3497	C ==== INPUTS ===
3498	C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY
3499	C PTAVE : (KDLON,KFLEV) ; TEMPERATURE
3500	C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE
3501	C ==== OUTPUTS ===
3502	C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
3503	C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION
3504	C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3505	C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION
3506	C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION
3507	C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
3508	C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3509	C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3510	C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS
3511	C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS
3512	C
3513	C IMPLICIT ARGUMENTS : NONE
3514	C --------------------
3515	C
3516	C METHOD.
3517	C -------
3518	C
3519	C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
3520	C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
3521	C
3522	C REFERENCE.
3523	C ----------
3524	C
3525	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3526	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS "
3527	C
3528	C AUTHOR.
3529	C -------
3530	C JEAN-JACQUES MORCRETTE ECMWF
3531	C
3532	C MODIFICATIONS.
3533	C --------------
3534	C ORIGINAL : 89-07-14
3535	C
3536	C-----------------------------------------------------------------------
3537	C
3538	C ARGUMENTS:
3539	C
3540	REAL*8 PDT0(KDLON)
3541	REAL*8 PTAVE(KDLON,KFLEV)
3542	REAL*8 PTL(KDLON,KFLEV+1)
3543	C
3544	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
3545	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3546	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3547	REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
3548	REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
3549	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
3550	REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3551	REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3552	REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3553	REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3554	REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3555	REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3556	C
3557	C-------------------------------------------------------------------------
3558	C* LOCAL VARIABLES:
3559	INTEGER INDB(KDLON),INDS(KDLON)
3560	REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
3561	REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
3562	c
3563	INTEGER jk, jl, ic, jnu, jf, jg
3564	INTEGER jk1, jk2
3565	INTEGER k, j, ixtox, indto, ixtx, indt
3566	INTEGER indsu, indtp
3567	REAL*8 zdsto1, zdstox, zdst1, zdstx
3568	c
3569	C* Quelques parametres:
3570	REAL*8 TSTAND
3571	PARAMETER (TSTAND=250.0)
3572	REAL*8 TSTP
3573	PARAMETER (TSTP=12.5)
3574	INTEGER MXIXT
3575	PARAMETER (MXIXT=10)
3576	C
3577	C* Used Data Block:
3578	REAL*8 TINTP(11)
3579	SAVE TINTP
3580	REAL*8 GA(11,16,3), GB(11,16,3)
3581	SAVE GA, GB
3582	REAL*8 XP(6,6)
3583	SAVE XP
3584	c
3585	DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
3586	S 262.5, 275., 287.5, 300., 312.5 /
3587	C-----------------------------------------------------------------------
3588	C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
3589	C
3590	C
3591	C
3592	C
3593	C-- R.D. -- G = - 0.2 SLA
3594	C
3595	C
3596	C----- INTERVAL = 1 ----- T = 187.5
3597	C
3598	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3599	DATA (GA( 1, 1,IC),IC=1,3) /
3600	S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
3601	DATA (GB( 1, 1,IC),IC=1,3) /
3602	S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
3603	DATA (GA( 1, 2,IC),IC=1,3) /
3604	S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
3605	DATA (GB( 1, 2,IC),IC=1,3) /
3606	S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
3607	C
3608	C----- INTERVAL = 1 ----- T = 200.0
3609	C
3610	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3611	DATA (GA( 2, 1,IC),IC=1,3) /
3612	S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
3613	DATA (GB( 2, 1,IC),IC=1,3) /
3614	S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
3615	DATA (GA( 2, 2,IC),IC=1,3) /
3616	S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
3617	DATA (GB( 2, 2,IC),IC=1,3) /
3618	S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
3619	C
3620	C----- INTERVAL = 1 ----- T = 212.5
3621	C
3622	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3623	DATA (GA( 3, 1,IC),IC=1,3) /
3624	S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
3625	DATA (GB( 3, 1,IC),IC=1,3) /
3626	S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
3627	DATA (GA( 3, 2,IC),IC=1,3) /
3628	S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
3629	DATA (GB( 3, 2,IC),IC=1,3) /
3630	S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
3631	C
3632	C----- INTERVAL = 1 ----- T = 225.0
3633	C
3634	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3635	DATA (GA( 4, 1,IC),IC=1,3) /
3636	S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
3637	DATA (GB( 4, 1,IC),IC=1,3) /
3638	S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
3639	DATA (GA( 4, 2,IC),IC=1,3) /
3640	S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
3641	DATA (GB( 4, 2,IC),IC=1,3) /
3642	S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
3643	C
3644	C----- INTERVAL = 1 ----- T = 237.5
3645	C
3646	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3647	DATA (GA( 5, 1,IC),IC=1,3) /
3648	S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
3649	DATA (GB( 5, 1,IC),IC=1,3) /
3650	S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
3651	DATA (GA( 5, 2,IC),IC=1,3) /
3652	S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
3653	DATA (GB( 5, 2,IC),IC=1,3) /
3654	S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
3655	C
3656	C----- INTERVAL = 1 ----- T = 250.0
3657	C
3658	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3659	DATA (GA( 6, 1,IC),IC=1,3) /
3660	S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
3661	DATA (GB( 6, 1,IC),IC=1,3) /
3662	S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
3663	DATA (GA( 6, 2,IC),IC=1,3) /
3664	S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
3665	DATA (GB( 6, 2,IC),IC=1,3) /
3666	S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
3667	C
3668	C----- INTERVAL = 1 ----- T = 262.5
3669	C
3670	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3671	DATA (GA( 7, 1,IC),IC=1,3) /
3672	S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
3673	DATA (GB( 7, 1,IC),IC=1,3) /
3674	S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
3675	DATA (GA( 7, 2,IC),IC=1,3) /
3676	S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
3677	DATA (GB( 7, 2,IC),IC=1,3) /
3678	S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
3679	C
3680	C----- INTERVAL = 1 ----- T = 275.0
3681	C
3682	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3683	DATA (GA( 8, 1,IC),IC=1,3) /
3684	S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
3685	DATA (GB( 8, 1,IC),IC=1,3) /
3686	S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
3687	DATA (GA( 8, 2,IC),IC=1,3) /
3688	S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
3689	DATA (GB( 8, 2,IC),IC=1,3) /
3690	S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
3691	C
3692	C----- INTERVAL = 1 ----- T = 287.5
3693	C
3694	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3695	DATA (GA( 9, 1,IC),IC=1,3) /
3696	S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
3697	DATA (GB( 9, 1,IC),IC=1,3) /
3698	S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
3699	DATA (GA( 9, 2,IC),IC=1,3) /
3700	S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
3701	DATA (GB( 9, 2,IC),IC=1,3) /
3702	S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
3703	C
3704	C----- INTERVAL = 1 ----- T = 300.0
3705	C
3706	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3707	DATA (GA(10, 1,IC),IC=1,3) /
3708	S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
3709	DATA (GB(10, 1,IC),IC=1,3) /
3710	S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
3711	DATA (GA(10, 2,IC),IC=1,3) /
3712	S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
3713	DATA (GB(10, 2,IC),IC=1,3) /
3714	S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
3715	C
3716	C----- INTERVAL = 1 ----- T = 312.5
3717	C
3718	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3719	DATA (GA(11, 1,IC),IC=1,3) /
3720	S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
3721	DATA (GB(11, 1,IC),IC=1,3) /
3722	S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
3723	DATA (GA(11, 2,IC),IC=1,3) /
3724	S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
3725	DATA (GB(11, 2,IC),IC=1,3) /
3726	S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
3727	C
3728	C
3729	C
3730	C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
3731	C
3732	C
3733	C
3734	C
3735	C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U )
3736	C
3737	C
3738	C----- INTERVAL = 2 ----- T = 187.5
3739	C
3740	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3741	DATA (GA( 1, 3,IC),IC=1,3) /
3742	S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
3743	DATA (GB( 1, 3,IC),IC=1,3) /
3744	S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
3745	DATA (GA( 1, 4,IC),IC=1,3) /
3746	S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
3747	DATA (GB( 1, 4,IC),IC=1,3) /
3748	S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
3749	C
3750	C----- INTERVAL = 2 ----- T = 200.0
3751	C
3752	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3753	DATA (GA( 2, 3,IC),IC=1,3) /
3754	S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
3755	DATA (GB( 2, 3,IC),IC=1,3) /
3756	S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
3757	DATA (GA( 2, 4,IC),IC=1,3) /
3758	S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
3759	DATA (GB( 2, 4,IC),IC=1,3) /
3760	S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
3761	C
3762	C----- INTERVAL = 2 ----- T = 212.5
3763	C
3764	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3765	DATA (GA( 3, 3,IC),IC=1,3) /
3766	S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
3767	DATA (GB( 3, 3,IC),IC=1,3) /
3768	S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
3769	DATA (GA( 3, 4,IC),IC=1,3) /
3770	S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
3771	DATA (GB( 3, 4,IC),IC=1,3) /
3772	S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
3773	C
3774	C----- INTERVAL = 2 ----- T = 225.0
3775	C
3776	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3777	DATA (GA( 4, 3,IC),IC=1,3) /
3778	S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
3779	DATA (GB( 4, 3,IC),IC=1,3) /
3780	S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
3781	DATA (GA( 4, 4,IC),IC=1,3) /
3782	S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
3783	DATA (GB( 4, 4,IC),IC=1,3) /
3784	S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
3785	C
3786	C----- INTERVAL = 2 ----- T = 237.5
3787	C
3788	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3789	DATA (GA( 5, 3,IC),IC=1,3) /
3790	S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
3791	DATA (GB( 5, 3,IC),IC=1,3) /
3792	S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
3793	DATA (GA( 5, 4,IC),IC=1,3) /
3794	S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
3795	DATA (GB( 5, 4,IC),IC=1,3) /
3796	S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
3797	C
3798	C----- INTERVAL = 2 ----- T = 250.0
3799	C
3800	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3801	DATA (GA( 6, 3,IC),IC=1,3) /
3802	S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
3803	DATA (GB( 6, 3,IC),IC=1,3) /
3804	S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
3805	DATA (GA( 6, 4,IC),IC=1,3) /
3806	S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
3807	DATA (GB( 6, 4,IC),IC=1,3) /
3808	S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
3809	C
3810	C----- INTERVAL = 2 ----- T = 262.5
3811	C
3812	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3813	DATA (GA( 7, 3,IC),IC=1,3) /
3814	S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
3815	DATA (GB( 7, 3,IC),IC=1,3) /
3816	S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
3817	DATA (GA( 7, 4,IC),IC=1,3) /
3818	S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
3819	DATA (GB( 7, 4,IC),IC=1,3) /
3820	S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
3821	C
3822	C----- INTERVAL = 2 ----- T = 275.0
3823	C
3824	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3825	DATA (GA( 8, 3,IC),IC=1,3) /
3826	S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
3827	DATA (GB( 8, 3,IC),IC=1,3) /
3828	S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
3829	DATA (GA( 8, 4,IC),IC=1,3) /
3830	S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
3831	DATA (GB( 8, 4,IC),IC=1,3) /
3832	S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
3833	C
3834	C----- INTERVAL = 2 ----- T = 287.5
3835	C
3836	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3837	DATA (GA( 9, 3,IC),IC=1,3) /
3838	S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
3839	DATA (GB( 9, 3,IC),IC=1,3) /
3840	S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
3841	DATA (GA( 9, 4,IC),IC=1,3) /
3842	S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
3843	DATA (GB( 9, 4,IC),IC=1,3) /
3844	S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
3845	C
3846	C----- INTERVAL = 2 ----- T = 300.0
3847	C
3848	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3849	DATA (GA(10, 3,IC),IC=1,3) /
3850	S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
3851	DATA (GB(10, 3,IC),IC=1,3) /
3852	S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
3853	DATA (GA(10, 4,IC),IC=1,3) /
3854	S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
3855	DATA (GB(10, 4,IC),IC=1,3) /
3856	S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
3857	C
3858	C----- INTERVAL = 2 ----- T = 312.5
3859	C
3860	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3861	DATA (GA(11, 3,IC),IC=1,3) /
3862	S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
3863	DATA (GB(11, 3,IC),IC=1,3) /
3864	S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
3865	DATA (GA(11, 4,IC),IC=1,3) /
3866	S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
3867	DATA (GB(11, 4,IC),IC=1,3) /
3868	S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
3869	C
3870	C
3871	C
3872	C
3873	C
3874	C
3875	C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
3876	C
3877	C
3878	C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
3879	C
3880	C
3881	C
3882	C--- G = 3.875E-03 ---------------
3883	C
3884	C----- INTERVAL = 3 ----- T = 187.5
3885	C
3886	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3887	DATA (GA( 1, 7,IC),IC=1,3) /
3888	S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
3889	DATA (GB( 1, 7,IC),IC=1,3) /
3890	S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
3891	DATA (GA( 1, 8,IC),IC=1,3) /
3892	S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
3893	DATA (GB( 1, 8,IC),IC=1,3) /
3894	S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
3895	C
3896	C----- INTERVAL = 3 ----- T = 200.0
3897	C
3898	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3899	DATA (GA( 2, 7,IC),IC=1,3) /
3900	S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
3901	DATA (GB( 2, 7,IC),IC=1,3) /
3902	S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
3903	DATA (GA( 2, 8,IC),IC=1,3) /
3904	S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
3905	DATA (GB( 2, 8,IC),IC=1,3) /
3906	S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
3907	C
3908	C----- INTERVAL = 3 ----- T = 212.5
3909	C
3910	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3911	DATA (GA( 3, 7,IC),IC=1,3) /
3912	S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
3913	DATA (GB( 3, 7,IC),IC=1,3) /
3914	S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
3915	DATA (GA( 3, 8,IC),IC=1,3) /
3916	S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
3917	DATA (GB( 3, 8,IC),IC=1,3) /
3918	S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
3919	C
3920	C----- INTERVAL = 3 ----- T = 225.0
3921	C
3922	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3923	DATA (GA( 4, 7,IC),IC=1,3) /
3924	S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
3925	DATA (GB( 4, 7,IC),IC=1,3) /
3926	S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
3927	DATA (GA( 4, 8,IC),IC=1,3) /
3928	S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
3929	DATA (GB( 4, 8,IC),IC=1,3) /
3930	S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
3931	C
3932	C----- INTERVAL = 3 ----- T = 237.5
3933	C
3934	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3935	DATA (GA( 5, 7,IC),IC=1,3) /
3936	S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
3937	DATA (GB( 5, 7,IC),IC=1,3) /
3938	S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
3939	DATA (GA( 5, 8,IC),IC=1,3) /
3940	S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
3941	DATA (GB( 5, 8,IC),IC=1,3) /
3942	S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
3943	C
3944	C----- INTERVAL = 3 ----- T = 250.0
3945	C
3946	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3947	DATA (GA( 6, 7,IC),IC=1,3) /
3948	S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
3949	DATA (GB( 6, 7,IC),IC=1,3) /
3950	S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
3951	DATA (GA( 6, 8,IC),IC=1,3) /
3952	S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
3953	DATA (GB( 6, 8,IC),IC=1,3) /
3954	S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
3955	C
3956	C----- INTERVAL = 3 ----- T = 262.5
3957	C
3958	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3959	DATA (GA( 7, 7,IC),IC=1,3) /
3960	S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
3961	DATA (GB( 7, 7,IC),IC=1,3) /
3962	S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
3963	DATA (GA( 7, 8,IC),IC=1,3) /
3964	S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
3965	DATA (GB( 7, 8,IC),IC=1,3) /
3966	S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
3967	C
3968	C----- INTERVAL = 3 ----- T = 275.0
3969	C
3970	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3971	DATA (GA( 8, 7,IC),IC=1,3) /
3972	S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
3973	DATA (GB( 8, 7,IC),IC=1,3) /
3974	S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
3975	DATA (GA( 8, 8,IC),IC=1,3) /
3976	S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
3977	DATA (GB( 8, 8,IC),IC=1,3) /
3978	S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
3979	C
3980	C----- INTERVAL = 3 ----- T = 287.5
3981	C
3982	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3983	DATA (GA( 9, 7,IC),IC=1,3) /
3984	S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
3985	DATA (GB( 9, 7,IC),IC=1,3) /
3986	S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
3987	DATA (GA( 9, 8,IC),IC=1,3) /
3988	S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
3989	DATA (GB( 9, 8,IC),IC=1,3) /
3990	S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
3991	C
3992	C----- INTERVAL = 3 ----- T = 300.0
3993	C
3994	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3995	DATA (GA(10, 7,IC),IC=1,3) /
3996	S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
3997	DATA (GB(10, 7,IC),IC=1,3) /
3998	S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
3999	DATA (GA(10, 8,IC),IC=1,3) /
4000	S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
4001	DATA (GB(10, 8,IC),IC=1,3) /
4002	S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
4003	C
4004	C----- INTERVAL = 3 ----- T = 312.5
4005	C
4006	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4007	DATA (GA(11, 7,IC),IC=1,3) /
4008	S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
4009	DATA (GB(11, 7,IC),IC=1,3) /
4010	S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
4011	DATA (GA(11, 8,IC),IC=1,3) /
4012	S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
4013	DATA (GB(11, 8,IC),IC=1,3) /
4014	S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
4015	C
4016	C
4017	C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
4018	C
4019	C-- G = 3.6E-03
4020	C
4021	C----- INTERVAL = 4 ----- T = 187.5
4022	C
4023	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4024	DATA (GA( 1, 9,IC),IC=1,3) /
4025	S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
4026	DATA (GB( 1, 9,IC),IC=1,3) /
4027	S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
4028	DATA (GA( 1,10,IC),IC=1,3) /
4029	S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
4030	DATA (GB( 1,10,IC),IC=1,3) /
4031	S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
4032	C
4033	C----- INTERVAL = 4 ----- T = 200.0
4034	C
4035	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4036	DATA (GA( 2, 9,IC),IC=1,3) /
4037	S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
4038	DATA (GB( 2, 9,IC),IC=1,3) /
4039	S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
4040	DATA (GA( 2,10,IC),IC=1,3) /
4041	S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
4042	DATA (GB( 2,10,IC),IC=1,3) /
4043	S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
4044	C
4045	C----- INTERVAL = 4 ----- T = 212.5
4046	C
4047	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4048	DATA (GA( 3, 9,IC),IC=1,3) /
4049	S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
4050	DATA (GB( 3, 9,IC),IC=1,3) /
4051	S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
4052	DATA (GA( 3,10,IC),IC=1,3) /
4053	S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
4054	DATA (GB( 3,10,IC),IC=1,3) /
4055	S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
4056	C
4057	C----- INTERVAL = 4 ----- T = 225.0
4058	C
4059	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4060	DATA (GA( 4, 9,IC),IC=1,3) /
4061	S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
4062	DATA (GB( 4, 9,IC),IC=1,3) /
4063	S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
4064	DATA (GA( 4,10,IC),IC=1,3) /
4065	S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
4066	DATA (GB( 4,10,IC),IC=1,3) /
4067	S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
4068	C
4069	C----- INTERVAL = 4 ----- T = 237.5
4070	C
4071	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4072	DATA (GA( 5, 9,IC),IC=1,3) /
4073	S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
4074	DATA (GB( 5, 9,IC),IC=1,3) /
4075	S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
4076	DATA (GA( 5,10,IC),IC=1,3) /
4077	S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
4078	DATA (GB( 5,10,IC),IC=1,3) /
4079	S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
4080	C
4081	C----- INTERVAL = 4 ----- T = 250.0
4082	C
4083	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4084	DATA (GA( 6, 9,IC),IC=1,3) /
4085	S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
4086	DATA (GB( 6, 9,IC),IC=1,3) /
4087	S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
4088	DATA (GA( 6,10,IC),IC=1,3) /
4089	S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
4090	DATA (GB( 6,10,IC),IC=1,3) /
4091	S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
4092	C
4093	C----- INTERVAL = 4 ----- T = 262.5
4094	C
4095	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4096	DATA (GA( 7, 9,IC),IC=1,3) /
4097	S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
4098	DATA (GB( 7, 9,IC),IC=1,3) /
4099	S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
4100	DATA (GA( 7,10,IC),IC=1,3) /
4101	S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
4102	DATA (GB( 7,10,IC),IC=1,3) /
4103	S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
4104	C
4105	C----- INTERVAL = 4 ----- T = 275.0
4106	C
4107	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4108	DATA (GA( 8, 9,IC),IC=1,3) /
4109	S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
4110	DATA (GB( 8, 9,IC),IC=1,3) /
4111	S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
4112	DATA (GA( 8,10,IC),IC=1,3) /
4113	S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
4114	DATA (GB( 8,10,IC),IC=1,3) /
4115	S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
4116	C
4117	C----- INTERVAL = 4 ----- T = 287.5
4118	C
4119	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4120	DATA (GA( 9, 9,IC),IC=1,3) /
4121	S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
4122	DATA (GB( 9, 9,IC),IC=1,3) /
4123	S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
4124	DATA (GA( 9,10,IC),IC=1,3) /
4125	S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
4126	DATA (GB( 9,10,IC),IC=1,3) /
4127	S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
4128	C
4129	C----- INTERVAL = 4 ----- T = 300.0
4130	C
4131	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4132	DATA (GA(10, 9,IC),IC=1,3) /
4133	S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
4134	DATA (GB(10, 9,IC),IC=1,3) /
4135	S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
4136	DATA (GA(10,10,IC),IC=1,3) /
4137	S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
4138	DATA (GB(10,10,IC),IC=1,3) /
4139	S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
4140	C
4141	C----- INTERVAL = 4 ----- T = 312.5
4142	C
4143	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4144	DATA (GA(11, 9,IC),IC=1,3) /
4145	S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
4146	DATA (GB(11, 9,IC),IC=1,3) /
4147	S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
4148	DATA (GA(11,10,IC),IC=1,3) /
4149	S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
4150	DATA (GB(11,10,IC),IC=1,3) /
4151	S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
4152	C
4153	C
4154	C
4155	C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ----
4156	C
4157	C-- WATER VAPOR --- 350 - 500 CM-1
4158	C
4159	C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
4160	C
4161	C----- INTERVAL = 5 ----- T = 187.5
4162	C
4163	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4164	DATA (GA( 1, 5,IC),IC=1,3) /
4165	S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
4166	DATA (GB( 1, 5,IC),IC=1,3) /
4167	S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
4168	DATA (GA( 1, 6,IC),IC=1,3) /
4169	S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
4170	DATA (GB( 1, 6,IC),IC=1,3) /
4171	S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
4172	C
4173	C----- INTERVAL = 5 ----- T = 200.0
4174	C
4175	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4176	DATA (GA( 2, 5,IC),IC=1,3) /
4177	S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
4178	DATA (GB( 2, 5,IC),IC=1,3) /
4179	S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
4180	DATA (GA( 2, 6,IC),IC=1,3) /
4181	S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
4182	DATA (GB( 2, 6,IC),IC=1,3) /
4183	S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
4184	C
4185	C----- INTERVAL = 5 ----- T = 212.5
4186	C
4187	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4188	DATA (GA( 3, 5,IC),IC=1,3) /
4189	S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
4190	DATA (GB( 3, 5,IC),IC=1,3) /
4191	S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
4192	DATA (GA( 3, 6,IC),IC=1,3) /
4193	S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
4194	DATA (GB( 3, 6,IC),IC=1,3) /
4195	S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
4196	C
4197	C----- INTERVAL = 5 ----- T = 225.0
4198	C
4199	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4200	DATA (GA( 4, 5,IC),IC=1,3) /
4201	S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
4202	DATA (GB( 4, 5,IC),IC=1,3) /
4203	S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
4204	DATA (GA( 4, 6,IC),IC=1,3) /
4205	S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
4206	DATA (GB( 4, 6,IC),IC=1,3) /
4207	S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
4208	C
4209	C----- INTERVAL = 5 ----- T = 237.5
4210	C
4211	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4212	DATA (GA( 5, 5,IC),IC=1,3) /
4213	S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
4214	DATA (GB( 5, 5,IC),IC=1,3) /
4215	S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
4216	DATA (GA( 5, 6,IC),IC=1,3) /
4217	S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
4218	DATA (GB( 5, 6,IC),IC=1,3) /
4219	S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
4220	C
4221	C----- INTERVAL = 5 ----- T = 250.0
4222	C
4223	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4224	DATA (GA( 6, 5,IC),IC=1,3) /
4225	S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
4226	DATA (GB( 6, 5,IC),IC=1,3) /
4227	S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
4228	DATA (GA( 6, 6,IC),IC=1,3) /
4229	S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
4230	DATA (GB( 6, 6,IC),IC=1,3) /
4231	S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
4232	C
4233	C----- INTERVAL = 5 ----- T = 262.5
4234	C
4235	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4236	DATA (GA( 7, 5,IC),IC=1,3) /
4237	S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
4238	DATA (GB( 7, 5,IC),IC=1,3) /
4239	S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
4240	DATA (GA( 7, 6,IC),IC=1,3) /
4241	S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
4242	DATA (GB( 7, 6,IC),IC=1,3) /
4243	S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
4244	C
4245	C----- INTERVAL = 5 ----- T = 275.0
4246	C
4247	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4248	DATA (GA( 8, 5,IC),IC=1,3) /
4249	S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
4250	DATA (GB( 8, 5,IC),IC=1,3) /
4251	S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
4252	DATA (GA( 8, 6,IC),IC=1,3) /
4253	S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
4254	DATA (GB( 8, 6,IC),IC=1,3) /
4255	S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
4256	C
4257	C----- INTERVAL = 5 ----- T = 287.5
4258	C
4259	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4260	DATA (GA( 9, 5,IC),IC=1,3) /
4261	S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
4262	DATA (GB( 9, 5,IC),IC=1,3) /
4263	S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
4264	DATA (GA( 9, 6,IC),IC=1,3) /
4265	S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
4266	DATA (GB( 9, 6,IC),IC=1,3) /
4267	S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
4268	C
4269	C----- INTERVAL = 5 ----- T = 300.0
4270	C
4271	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4272	DATA (GA(10, 5,IC),IC=1,3) /
4273	S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
4274	DATA (GB(10, 5,IC),IC=1,3) /
4275	S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
4276	DATA (GA(10, 6,IC),IC=1,3) /
4277	S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
4278	DATA (GB(10, 6,IC),IC=1,3) /
4279	S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
4280	C
4281	C----- INTERVAL = 5 ----- T = 312.5
4282	C
4283	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4284	DATA (GA(11, 5,IC),IC=1,3) /
4285	S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
4286	DATA (GB(11, 5,IC),IC=1,3) /
4287	S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
4288	DATA (GA(11, 6,IC),IC=1,3) /
4289	S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
4290	DATA (GB(11, 6,IC),IC=1,3) /
4291	S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
4292	C
4293	C
4294	C
4295	C
4296	C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
4297	C--- G = 0.0
4298	C
4299	C
4300	C----- INTERVAL = 6 ----- T = 187.5
4301	C
4302	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4303	DATA (GA( 1,11,IC),IC=1,3) /
4304	S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
4305	DATA (GB( 1,11,IC),IC=1,3) /
4306	S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
4307	DATA (GA( 1,12,IC),IC=1,3) /
4308	S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
4309	DATA (GB( 1,12,IC),IC=1,3) /
4310	S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
4311	C
4312	C----- INTERVAL = 6 ----- T = 200.0
4313	C
4314	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4315	DATA (GA( 2,11,IC),IC=1,3) /
4316	S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
4317	DATA (GB( 2,11,IC),IC=1,3) /
4318	S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
4319	DATA (GA( 2,12,IC),IC=1,3) /
4320	S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
4321	DATA (GB( 2,12,IC),IC=1,3) /
4322	S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
4323	C
4324	C----- INTERVAL = 6 ----- T = 212.5
4325	C
4326	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4327	DATA (GA( 3,11,IC),IC=1,3) /
4328	S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
4329	DATA (GB( 3,11,IC),IC=1,3) /
4330	S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
4331	DATA (GA( 3,12,IC),IC=1,3) /
4332	S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
4333	DATA (GB( 3,12,IC),IC=1,3) /
4334	S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
4335	C
4336	C----- INTERVAL = 6 ----- T = 225.0
4337	C
4338	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4339	DATA (GA( 4,11,IC),IC=1,3) /
4340	S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
4341	DATA (GB( 4,11,IC),IC=1,3) /
4342	S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
4343	DATA (GA( 4,12,IC),IC=1,3) /
4344	S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
4345	DATA (GB( 4,12,IC),IC=1,3) /
4346	S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
4347	C
4348	C----- INTERVAL = 6 ----- T = 237.5
4349	C
4350	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4351	DATA (GA( 5,11,IC),IC=1,3) /
4352	S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
4353	DATA (GB( 5,11,IC),IC=1,3) /
4354	S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
4355	DATA (GA( 5,12,IC),IC=1,3) /
4356	S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
4357	DATA (GB( 5,12,IC),IC=1,3) /
4358	S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
4359	C
4360	C----- INTERVAL = 6 ----- T = 250.0
4361	C
4362	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4363	DATA (GA( 6,11,IC),IC=1,3) /
4364	S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
4365	DATA (GB( 6,11,IC),IC=1,3) /
4366	S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
4367	DATA (GA( 6,12,IC),IC=1,3) /
4368	S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
4369	DATA (GB( 6,12,IC),IC=1,3) /
4370	S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
4371	C
4372	C----- INTERVAL = 6 ----- T = 262.5
4373	C
4374	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4375	DATA (GA( 7,11,IC),IC=1,3) /
4376	S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
4377	DATA (GB( 7,11,IC),IC=1,3) /
4378	S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
4379	DATA (GA( 7,12,IC),IC=1,3) /
4380	S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
4381	DATA (GB( 7,12,IC),IC=1,3) /
4382	S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
4383	C
4384	C----- INTERVAL = 6 ----- T = 275.0
4385	C
4386	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4387	DATA (GA( 8,11,IC),IC=1,3) /
4388	S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
4389	DATA (GB( 8,11,IC),IC=1,3) /
4390	S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
4391	DATA (GA( 8,12,IC),IC=1,3) /
4392	S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
4393	DATA (GB( 8,12,IC),IC=1,3) /
4394	S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
4395	C
4396	C----- INTERVAL = 6 ----- T = 287.5
4397	C
4398	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4399	DATA (GA( 9,11,IC),IC=1,3) /
4400	S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
4401	DATA (GB( 9,11,IC),IC=1,3) /
4402	S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
4403	DATA (GA( 9,12,IC),IC=1,3) /
4404	S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
4405	DATA (GB( 9,12,IC),IC=1,3) /
4406	S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
4407	C
4408	C----- INTERVAL = 6 ----- T = 300.0
4409	C
4410	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4411	DATA (GA(10,11,IC),IC=1,3) /
4412	S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
4413	DATA (GB(10,11,IC),IC=1,3) /
4414	S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
4415	DATA (GA(10,12,IC),IC=1,3) /
4416	S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
4417	DATA (GB(10,12,IC),IC=1,3) /
4418	S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
4419	C
4420	C----- INTERVAL = 6 ----- T = 312.5
4421	C
4422	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4423	DATA (GA(11,11,IC),IC=1,3) /
4424	S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
4425	DATA (GB(11,11,IC),IC=1,3) /
4426	S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
4427	DATA (GA(11,12,IC),IC=1,3) /
4428	S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
4429	DATA (GB(11,12,IC),IC=1,3) /
4430	S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
4431	C
4432	C
4433	C
4434	C
4435	C
4436	C-- END WATER VAPOR
4437	C
4438	C
4439	C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
4440	C
4441	C
4442	C
4443	C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9
4444	C
4445	C----- INTERVAL = 2 ----- T = 187.5
4446	C
4447	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4448	DATA (GA( 1,13,IC),IC=1,3) /
4449	S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
4450	DATA (GB( 1,13,IC),IC=1,3) /
4451	S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
4452	DATA (GA( 1,14,IC),IC=1,3) /
4453	S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
4454	DATA (GB( 1,14,IC),IC=1,3) /
4455	S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
4456	C
4457	C----- INTERVAL = 2 ----- T = 200.0
4458	C
4459	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4460	DATA (GA( 2,13,IC),IC=1,3) /
4461	S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
4462	DATA (GB( 2,13,IC),IC=1,3) /
4463	S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
4464	DATA (GA( 2,14,IC),IC=1,3) /
4465	S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
4466	DATA (GB( 2,14,IC),IC=1,3) /
4467	S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
4468	C
4469	C----- INTERVAL = 2 ----- T = 212.5
4470	C
4471	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4472	DATA (GA( 3,13,IC),IC=1,3) /
4473	S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
4474	DATA (GB( 3,13,IC),IC=1,3) /
4475	S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
4476	DATA (GA( 3,14,IC),IC=1,3) /
4477	S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
4478	DATA (GB( 3,14,IC),IC=1,3) /
4479	S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
4480	C
4481	C----- INTERVAL = 2 ----- T = 225.0
4482	C
4483	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4484	DATA (GA( 4,13,IC),IC=1,3) /
4485	S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
4486	DATA (GB( 4,13,IC),IC=1,3) /
4487	S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
4488	DATA (GA( 4,14,IC),IC=1,3) /
4489	S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
4490	DATA (GB( 4,14,IC),IC=1,3) /
4491	S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
4492	C
4493	C----- INTERVAL = 2 ----- T = 237.5
4494	C
4495	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4496	DATA (GA( 5,13,IC),IC=1,3) /
4497	S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
4498	DATA (GB( 5,13,IC),IC=1,3) /
4499	S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
4500	DATA (GA( 5,14,IC),IC=1,3) /
4501	S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
4502	DATA (GB( 5,14,IC),IC=1,3) /
4503	S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
4504	C
4505	C----- INTERVAL = 2 ----- T = 250.0
4506	C
4507	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4508	DATA (GA( 6,13,IC),IC=1,3) /
4509	S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
4510	DATA (GB( 6,13,IC),IC=1,3) /
4511	S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
4512	DATA (GA( 6,14,IC),IC=1,3) /
4513	S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
4514	DATA (GB( 6,14,IC),IC=1,3) /
4515	S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
4516	C
4517	C----- INTERVAL = 2 ----- T = 262.5
4518	C
4519	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4520	DATA (GA( 7,13,IC),IC=1,3) /
4521	S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
4522	DATA (GB( 7,13,IC),IC=1,3) /
4523	S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
4524	DATA (GA( 7,14,IC),IC=1,3) /
4525	S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
4526	DATA (GB( 7,14,IC),IC=1,3) /
4527	S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
4528	C
4529	C----- INTERVAL = 2 ----- T = 275.0
4530	C
4531	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4532	DATA (GA( 8,13,IC),IC=1,3) /
4533	S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
4534	DATA (GB( 8,13,IC),IC=1,3) /
4535	S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
4536	DATA (GA( 8,14,IC),IC=1,3) /
4537	S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
4538	DATA (GB( 8,14,IC),IC=1,3) /
4539	S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
4540	C
4541	C----- INTERVAL = 2 ----- T = 287.5
4542	C
4543	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4544	DATA (GA( 9,13,IC),IC=1,3) /
4545	S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
4546	DATA (GB( 9,13,IC),IC=1,3) /
4547	S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
4548	DATA (GA( 9,14,IC),IC=1,3) /
4549	S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
4550	DATA (GB( 9,14,IC),IC=1,3) /
4551	S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
4552	C
4553	C----- INTERVAL = 2 ----- T = 300.0
4554	C
4555	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4556	DATA (GA(10,13,IC),IC=1,3) /
4557	S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
4558	DATA (GB(10,13,IC),IC=1,3) /
4559	S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
4560	DATA (GA(10,14,IC),IC=1,3) /
4561	S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
4562	DATA (GB(10,14,IC),IC=1,3) /
4563	S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
4564	C
4565	C----- INTERVAL = 2 ----- T = 312.5
4566	C
4567	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4568	DATA (GA(11,13,IC),IC=1,3) /
4569	S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
4570	DATA (GB(11,13,IC),IC=1,3) /
4571	S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
4572	DATA (GA(11,14,IC),IC=1,3) /
4573	S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
4574	DATA (GB(11,14,IC),IC=1,3) /
4575	S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
4576	C
4577	C
4578	C
4579	C
4580	C
4581	C
4582	C
4583	C
4584	C
4585	C
4586	C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
4587	C
4588	C
4589	C-- G = 0.0
4590	C
4591	C
4592	C----- INTERVAL = 4 ----- T = 187.5
4593	C
4594	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4595	DATA (GA( 1,15,IC),IC=1,3) /
4596	S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
4597	DATA (GB( 1,15,IC),IC=1,3) /
4598	S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
4599	DATA (GA( 1,16,IC),IC=1,3) /
4600	S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
4601	DATA (GB( 1,16,IC),IC=1,3) /
4602	S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
4603	C
4604	C----- INTERVAL = 4 ----- T = 200.0
4605	C
4606	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4607	DATA (GA( 2,15,IC),IC=1,3) /
4608	S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
4609	DATA (GB( 2,15,IC),IC=1,3) /
4610	S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
4611	DATA (GA( 2,16,IC),IC=1,3) /
4612	S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
4613	DATA (GB( 2,16,IC),IC=1,3) /
4614	S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
4615	C
4616	C----- INTERVAL = 4 ----- T = 212.5
4617	C
4618	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4619	DATA (GA( 3,15,IC),IC=1,3) /
4620	S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
4621	DATA (GB( 3,15,IC),IC=1,3) /
4622	S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
4623	DATA (GA( 3,16,IC),IC=1,3) /
4624	S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
4625	DATA (GB( 3,16,IC),IC=1,3) /
4626	S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
4627	C
4628	C----- INTERVAL = 4 ----- T = 225.0
4629	C
4630	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4631	DATA (GA( 4,15,IC),IC=1,3) /
4632	S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
4633	DATA (GB( 4,15,IC),IC=1,3) /
4634	S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
4635	DATA (GA( 4,16,IC),IC=1,3) /
4636	S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
4637	DATA (GB( 4,16,IC),IC=1,3) /
4638	S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
4639	C
4640	C----- INTERVAL = 4 ----- T = 237.5
4641	C
4642	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4643	DATA (GA( 5,15,IC),IC=1,3) /
4644	S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
4645	DATA (GB( 5,15,IC),IC=1,3) /
4646	S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
4647	DATA (GA( 5,16,IC),IC=1,3) /
4648	S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
4649	DATA (GB( 5,16,IC),IC=1,3) /
4650	S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
4651	C
4652	C----- INTERVAL = 4 ----- T = 250.0
4653	C
4654	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4655	DATA (GA( 6,15,IC),IC=1,3) /
4656	S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
4657	DATA (GB( 6,15,IC),IC=1,3) /
4658	S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
4659	DATA (GA( 6,16,IC),IC=1,3) /
4660	S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
4661	DATA (GB( 6,16,IC),IC=1,3) /
4662	S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
4663	C
4664	C----- INTERVAL = 4 ----- T = 262.5
4665	C
4666	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4667	DATA (GA( 7,15,IC),IC=1,3) /
4668	S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
4669	DATA (GB( 7,15,IC),IC=1,3) /
4670	S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
4671	DATA (GA( 7,16,IC),IC=1,3) /
4672	S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
4673	DATA (GB( 7,16,IC),IC=1,3) /
4674	S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
4675	C
4676	C----- INTERVAL = 4 ----- T = 275.0
4677	C
4678	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4679	DATA (GA( 8,15,IC),IC=1,3) /
4680	S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
4681	DATA (GB( 8,15,IC),IC=1,3) /
4682	S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
4683	DATA (GA( 8,16,IC),IC=1,3) /
4684	S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
4685	DATA (GB( 8,16,IC),IC=1,3) /
4686	S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
4687	C
4688	C----- INTERVAL = 4 ----- T = 287.5
4689	C
4690	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4691	DATA (GA( 9,15,IC),IC=1,3) /
4692	S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
4693	DATA (GB( 9,15,IC),IC=1,3) /
4694	S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
4695	DATA (GA( 9,16,IC),IC=1,3) /
4696	S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
4697	DATA (GB( 9,16,IC),IC=1,3) /
4698	S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
4699	C
4700	C----- INTERVAL = 4 ----- T = 300.0
4701	C
4702	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4703	DATA (GA(10,15,IC),IC=1,3) /
4704	S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
4705	DATA (GB(10,15,IC),IC=1,3) /
4706	S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
4707	DATA (GA(10,16,IC),IC=1,3) /
4708	S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
4709	DATA (GB(10,16,IC),IC=1,3) /
4710	S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
4711	C
4712	C----- INTERVAL = 4 ----- T = 312.5
4713	C
4714	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4715	DATA (GA(11,15,IC),IC=1,3) /
4716	S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
4717	DATA (GB(11,15,IC),IC=1,3) /
4718	S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
4719	DATA (GA(11,16,IC),IC=1,3) /
4720	S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
4721	DATA (GB(11,16,IC),IC=1,3) /
4722	S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
4723
4724	C ------------------------------------------------------------------
4725	DATA (( XP( J,K),J=1,6), K=1,6) /
4726	S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
4727	S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
4728	S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
4729	S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
4730	S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
4731	S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
4732	S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
4733	S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
4734	S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
4735	S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
4736	S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
4737	S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
4738	C
4739	C
4740	C* 1.0 PLANCK FUNCTIONS AND GRADIENTS
4741	C ------------------------------
4742	C
4743	100 CONTINUE
4744	C
4745	DO 102 JK = 1 , KFLEV+1
4746	DO 101 JL = 1, KDLON
4747	PBINT(JL,JK) = 0.
4748	101 CONTINUE
4749	102 CONTINUE
4750	DO 103 JL = 1, KDLON
4751	PBSUIN(JL) = 0.
4752	103 CONTINUE
4753	C
4754	DO 141 JNU=1,Ninter
4755	C
4756	C
4757	C* 1.1 LEVELS FROM SURFACE TO KFLEV
4758	C ----------------------------
4759	C
4760	110 CONTINUE
4761	C
4762	DO 112 JK = 1 , KFLEV
4763	DO 111 JL = 1, KDLON
4764	ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
4765	ZRES(JL) = XP(1,JNU)+ZTI(JL)(XP(2,JNU)+ZTI(JL)(XP(3,JNU)
4766	S +ZTI(JL)(XP(4,JNU)+ZTI(JL)(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
4767	S )))))
4768	PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
4769	PB(JL,JNU,JK)= ZRES(JL)
4770	ZBLEV(JL,JK) = ZRES(JL)
4771	ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
4772	ZRES2(JL)=XP(1,JNU)+ZTI2(JL)(XP(2,JNU)+ZTI2(JL)(XP(3,JNU)
4773	S +ZTI2(JL)(XP(4,JNU)+ZTI2(JL)(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
4774	S )))))
4775	ZBLAY(JL,JK) = ZRES2(JL)
4776	111 CONTINUE
4777	112 CONTINUE
4778	C
4779	C
4780	C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE
4781	C ---------------------------------
4782	C
4783	120 CONTINUE
4784	C
4785	DO 121 JL = 1, KDLON
4786	ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
4787	ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
4788	ZRES(JL) = XP(1,JNU)+ZTI(JL)(XP(2,JNU)+ZTI(JL)(XP(3,JNU)
4789	S +ZTI(JL)(XP(4,JNU)+ZTI(JL)(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
4790	S )))))
4791	ZRES2(JL) = XP(1,JNU)+ZTI2(JL)(XP(2,JNU)+ZTI2(JL)(XP(3,JNU)
4792	S +ZTI2(JL)(XP(4,JNU)+ZTI2(JL)(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
4793	S )))))
4794	PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
4795	PB(JL,JNU,KFLEV+1)= ZRES(JL)
4796	ZBLEV(JL,KFLEV+1) = ZRES(JL)
4797	PBTOP(JL,JNU) = ZRES(JL)
4798	PBSUR(JL,JNU) = ZRES2(JL)
4799	PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
4800	121 CONTINUE
4801	C
4802	C
4803	C* 1.3 GRADIENTS IN SUB-LAYERS
4804	C -----------------------
4805	C
4806	130 CONTINUE
4807	C
4808	DO 132 JK = 1 , KFLEV
4809	JK2 = 2 * JK
4810	JK1 = JK2 - 1
4811	DO 131 JL = 1, KDLON
4812	PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK)
4813	PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
4814	131 CONTINUE
4815	132 CONTINUE
4816	C
4817	141 CONTINUE
4818	C
4819	C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
4820	C ---------------------------------------------
4821	C
4822	200 CONTINUE
4823	C
4824	C
4825	210 CONTINUE
4826	C
4827	DO 211 JL=1, KDLON
4828	ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
4829	IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
4830	ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
4831	IF (ZDSTOX.LT.0.5) THEN
4832	INDTO=IXTOX
4833	ELSE
4834	INDTO=IXTOX+1
4835	END IF
4836	INDB(JL)=INDTO
4837	ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
4838	IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
4839	ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
4840	IF (ZDSTX.LT.0.5) THEN
4841	INDT=IXTX
4842	ELSE
4843	INDT=IXTX+1
4844	END IF
4845	INDS(JL)=INDT
4846	211 CONTINUE
4847	C
4848	DO 214 JF=1,2
4849	DO 213 JG=1, 8
4850	DO 212 JL=1, KDLON
4851	INDSU=INDS(JL)
4852	PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
4853	PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
4854	INDTP=INDB(JL)
4855	PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
4856	PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
4857	212 CONTINUE
4858	213 CONTINUE
4859	214 CONTINUE
4860	C
4861	220 CONTINUE
4862	C
4863	DO 225 JK=1,KFLEV
4864	DO 221 JL=1, KDLON
4865	ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
4866	IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
4867	ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
4868	IF (ZDSTX.LT.0.5) THEN
4869	INDT=IXTX
4870	ELSE
4871	INDT=IXTX+1
4872	END IF
4873	INDB(JL)=INDT
4874	221 CONTINUE
4875	C
4876	DO 224 JF=1,2
4877	DO 223 JG=1, 8
4878	DO 222 JL=1, KDLON
4879	INDT=INDB(JL)
4880	PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
4881	PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
4882	222 CONTINUE
4883	223 CONTINUE
4884	224 CONTINUE
4885	225 CONTINUE
4886	C
4887	C ------------------------------------------------------------------
4888	C
4889	RETURN
4890	END
4891	SUBROUTINE LWV(KUAER,KTRAER, KLIM
4892	R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
4893	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
4894	S , PCNTRB,PCTS,PFLUC)
4895	IMPLICIT none
4896	#include "dimensions.h"
4897	#include "dimphy.h"
4898	#include "raddim.h"
4899	#include "raddimlw.h"
4900	#include "YOMCST.h"
4901	C
4902	C-----------------------------------------------------------------------
4903	C PURPOSE.
4904	C --------
4905	C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
4906	C FLUXES OR RADIANCES
4907	C
4908	C METHOD.
4909	C -------
4910	C
4911	C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
4912	C CONTRIBUTIONS BY - THE NEARBY LAYERS
4913	C - THE DISTANT LAYERS
4914	C - THE BOUNDARY TERMS
4915	C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
4916	C
4917	C REFERENCE.
4918	C ----------
4919	C
4920	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
4921	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
4922	C
4923	C AUTHOR.
4924	C -------
4925	C JEAN-JACQUES MORCRETTE ECMWF
4926	C
4927	C MODIFICATIONS.
4928	C --------------
4929	C ORIGINAL : 89-07-14
4930	C-----------------------------------------------------------------------
4931	C
4932	C* ARGUMENTS:
4933	INTEGER KUAER,KTRAER, KLIM
4934	C
4935	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
4936	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
4937	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
4938	REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
4939	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
4940	REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
4941	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
4942	REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
4943	REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
4944	REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
4945	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
4946	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
4947	REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
4948	REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
4949	REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
4950	REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
4951	C
4952	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
4953	REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
4954	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
4955	C-----------------------------------------------------------------------
4956	C LOCAL VARIABLES:
4957	REAL*8 ZADJD(KDLON,KFLEV+1)
4958	REAL*8 ZADJU(KDLON,KFLEV+1)
4959	REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
4960	REAL*8 ZDISD(KDLON,KFLEV+1)
4961	REAL*8 ZDISU(KDLON,KFLEV+1)
4962	C
4963	INTEGER jk, jl
4964	C-----------------------------------------------------------------------
4965	C
4966	DO 112 JK=1,KFLEV+1
4967	DO 111 JL=1, KDLON
4968	ZADJD(JL,JK)=0.
4969	ZADJU(JL,JK)=0.
4970	ZDISD(JL,JK)=0.
4971	ZDISU(JL,JK)=0.
4972	111 CONTINUE
4973	112 CONTINUE
4974	C
4975	DO 114 JK=1,KFLEV
4976	DO 113 JL=1, KDLON
4977	PCTS(JL,JK)=0.
4978	113 CONTINUE
4979	114 CONTINUE
4980	C
4981	C* CONTRIBUTION FROM ADJACENT LAYERS
4982	C
4983	CALL LWVN(KUAER,KTRAER
4984	R , PABCU,PDBSL,PGA,PGB
4985	S , ZADJD,ZADJU,PCNTRB,ZDBDT)
4986	C* CONTRIBUTION FROM DISTANT LAYERS
4987	C
4988	CALL LWVD(KUAER,KTRAER
4989	R , PABCU,ZDBDT,PGA,PGB
4990	S , PCNTRB,ZDISD,ZDISU)
4991	C
4992	C* EXCHANGE WITH THE BOUNDARIES
4993	C
4994	CALL LWVB(KUAER,KTRAER, KLIM
4995	R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
4996	R , ZDISD,ZDISU,PEMIS,PPMB
4997	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
4998	S , PCTS,PFLUC)
4999	C
5000	C
5001	RETURN
5002	END
5003	SUBROUTINE LWVB(KUAER,KTRAER, KLIM
5004	R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
5005	R , PDISD,PDISU,PEMIS,PPMB
5006	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5007	S , PCTS,PFLUC)
5008	IMPLICIT none
5009	#include "dimensions.h"
5010	#include "dimphy.h"
5011	#include "raddim.h"
5012	#include "raddimlw.h"
5013	#include "radopt.h"
5014	C
5015	C-----------------------------------------------------------------------
5016	C PURPOSE.
5017	C --------
5018	C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
5019	C INTEGRATION
5020	C
5021	C METHOD.
5022	C -------
5023	C
5024	C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
5025	C ATMOSPHERE
5026	C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
5027	C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
5028	C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
5029	C
5030	C REFERENCE.
5031	C ----------
5032	C
5033	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5034	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5035	C
5036	C AUTHOR.
5037	C -------
5038	C JEAN-JACQUES MORCRETTE ECMWF
5039	C
5040	C MODIFICATIONS.
5041	C --------------
5042	C ORIGINAL : 89-07-14
5043	C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96
5044	C-----------------------------------------------------------------------
5045	C
5046	C* 0.1 ARGUMENTS
5047	C ---------
5048	C
5049	INTEGER KUAER,KTRAER, KLIM
5050	C
5051	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5052	REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5053	REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5054	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
5055	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
5056	REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
5057	REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
5058	REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
5059	REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5060	REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5061	REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
5062	REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
5063	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5064	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5065	REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5066	REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5067	REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5068	REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5069	C
5070	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
5071	REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
5072	C
5073	C* LOCAL VARIABLES:
5074	C
5075	REAL*8 ZBGND(KDLON)
5076	REAL*8 ZFD(KDLON)
5077	REAL*8 ZFN10(KDLON)
5078	REAL*8 ZFU(KDLON)
5079	REAL*8 ZTT(KDLON,NTRA)
5080	REAL*8 ZTT1(KDLON,NTRA)
5081	REAL*8 ZTT2(KDLON,NTRA)
5082	REAL*8 ZUU(KDLON,NUA)
5083	REAL*8 ZCNSOL(KDLON)
5084	REAL*8 ZCNTOP(KDLON)
5085	C
5086	INTEGER jk, jl, ja
5087	INTEGER jstra, jstru
5088	INTEGER ind1, ind2, ind3, ind4, in, jlim
5089	REAL*8 zctstr
5090	C-----------------------------------------------------------------------
5091	C
5092	C* 1. INITIALIZATION
5093	C --------------
5094	C
5095	100 CONTINUE
5096	C
5097	C
5098	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5099	C ---------------------------------
5100	C
5101	120 CONTINUE
5102	C
5103	DO 122 JA=1,NTRA
5104	DO 121 JL=1, KDLON
5105	ZTT (JL,JA)=1.0
5106	ZTT1(JL,JA)=1.0
5107	ZTT2(JL,JA)=1.0
5108	121 CONTINUE
5109	122 CONTINUE
5110	C
5111	DO 124 JA=1,NUA
5112	DO 123 JL=1, KDLON
5113	ZUU(JL,JA)=1.0
5114	123 CONTINUE
5115	124 CONTINUE
5116	C
5117	C ------------------------------------------------------------------
5118	C
5119	C* 2. VERTICAL INTEGRATION
5120	C --------------------
5121	C
5122	200 CONTINUE
5123	C
5124	IND1=0
5125	IND3=0
5126	IND4=1
5127	IND2=1
5128	C
5129	C
5130	C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE
5131	C -----------------------------------
5132	C
5133	230 CONTINUE
5134	C
5135	DO 235 JK = 1 , KFLEV
5136	IN=(JK-1)*NG1P1+1
5137	C
5138	DO 232 JA=1,KUAER
5139	DO 231 JL=1, KDLON
5140	ZUU(JL,JA)=PABCU(JL,JA,IN)
5141	231 CONTINUE
5142	232 CONTINUE
5143	C
5144	C
5145	CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
5146	C
5147	DO 234 JL = 1, KDLON
5148	ZCNTOP(JL)=PBTOP(JL,1)ZTT(JL,1) ZTT(JL,10)
5149	2 +PBTOP(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5150	3 +PBTOP(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5151	4 +PBTOP(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5152	5 +PBTOP(JL,5)ZTT(JL,3) ZTT(JL,14)
5153	6 +PBTOP(JL,6)ZTT(JL,6) ZTT(JL,15)
5154	ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5155	PFLUC(JL,2,JK)=ZFD(JL)
5156	234 CONTINUE
5157	C
5158	235 CONTINUE
5159	C
5160	JK = KFLEV+1
5161	IN=(JK-1)*NG1P1+1
5162	C
5163	DO 236 JL = 1, KDLON
5164	ZCNTOP(JL)= PBTOP(JL,1)
5165	1 + PBTOP(JL,2)
5166	2 + PBTOP(JL,3)
5167	3 + PBTOP(JL,4)
5168	4 + PBTOP(JL,5)
5169	5 + PBTOP(JL,6)
5170	ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5171	PFLUC(JL,2,JK)=ZFD(JL)
5172	236 CONTINUE
5173	C
5174	C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
5175	C ---------------------------------------
5176	C
5177	240 CONTINUE
5178	C
5179	C
5180	C* 2.4.1 INITIALIZATION
5181	C --------------
5182	C
5183	2410 CONTINUE
5184	C
5185	JLIM = KFLEV
5186	C
5187	IF (.NOT.LEVOIGT) THEN
5188	DO 2412 JK = KFLEV,1,-1
5189	IF(PPMB(1,JK).LT.10.0) THEN
5190	JLIM=JK
5191	ENDIF
5192	2412 CONTINUE
5193	ENDIF
5194	KLIM=JLIM
5195	C
5196	IF (.NOT.LEVOIGT) THEN
5197	DO 2414 JA=1,KTRAER
5198	DO 2413 JL=1, KDLON
5199	ZTT1(JL,JA)=1.0
5200	2413 CONTINUE
5201	2414 CONTINUE
5202	C
5203	C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA
5204	C -----------------------------
5205	C
5206	2420 CONTINUE
5207	C
5208	DO 2427 JSTRA = KFLEV,JLIM,-1
5209	JSTRU=(JSTRA-1)*NG1P1+1
5210	C
5211	DO 2423 JA=1,KUAER
5212	DO 2422 JL=1, KDLON
5213	ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
5214	2422 CONTINUE
5215	2423 CONTINUE
5216	C
5217	C
5218	CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
5219	C
5220	DO 2424 JL = 1, KDLON
5221	ZCTSTR =
5222	1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
5223	1 (ZTT1(JL,1) ZTT1(JL,10)
5224	1 - ZTT (JL,1) *ZTT (JL,10))
5225	2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
5226	2 (ZTT1(JL,2)ZTT1(JL,7)*ZTT1(JL,11)
5227	2 - ZTT (JL,2)ZTT (JL,7)ZTT (JL,11))
5228	3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
5229	3 (ZTT1(JL,4)ZTT1(JL,8)*ZTT1(JL,12)
5230	3 - ZTT (JL,4)ZTT (JL,8)ZTT (JL,12))
5231	4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
5232	4 (ZTT1(JL,5)ZTT1(JL,9)*ZTT1(JL,13)
5233	4 - ZTT (JL,5)ZTT (JL,9)ZTT (JL,13))
5234	5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
5235	5 (ZTT1(JL,3) ZTT1(JL,14)
5236	5 - ZTT (JL,3) *ZTT (JL,14))
5237	6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
5238	6 (ZTT1(JL,6) ZTT1(JL,15)
5239	6 - ZTT (JL,6) *ZTT (JL,15))
5240	PCTS(JL,JSTRA)=ZCTSTR*0.5
5241	2424 CONTINUE
5242	DO 2426 JA=1,KTRAER
5243	DO 2425 JL=1, KDLON
5244	ZTT1(JL,JA)=ZTT(JL,JA)
5245	2425 CONTINUE
5246	2426 CONTINUE
5247	2427 CONTINUE
5248	ENDIF
5249	C Mise a zero de securite pour PCTS en cas de LEVOIGT
5250	IF(LEVOIGT)THEN
5251	DO 2429 JSTRA = 1,KFLEV
5252	DO 2428 JL = 1, KDLON
5253	PCTS(JL,JSTRA)=0.
5254	2428 CONTINUE
5255	2429 CONTINUE
5256	ENDIF
5257	C
5258	C
5259	C* 2.5 EXCHANGE WITH LOWER LIMIT
5260	C -------------------------
5261	C
5262	250 CONTINUE
5263	C
5264	DO 251 JL = 1, KDLON
5265	ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
5266	S *PFLUC(JL,2,1)-PBINT(JL,1)
5267	251 CONTINUE
5268	C
5269	JK = 1
5270	IN=(JK-1)*NG1P1+1
5271	C
5272	DO 252 JL = 1, KDLON
5273	ZCNSOL(JL)=PBSUR(JL,1)
5274	1 +PBSUR(JL,2)
5275	2 +PBSUR(JL,3)
5276	3 +PBSUR(JL,4)
5277	4 +PBSUR(JL,5)
5278	5 +PBSUR(JL,6)
5279	ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5280	ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5281	PFLUC(JL,1,JK)=ZFU(JL)
5282	252 CONTINUE
5283	C
5284	DO 257 JK = 2 , KFLEV+1
5285	IN=(JK-1)*NG1P1+1
5286	C
5287	C
5288	DO 255 JA=1,KUAER
5289	DO 254 JL=1, KDLON
5290	ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
5291	254 CONTINUE
5292	255 CONTINUE
5293	C
5294	C
5295	CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
5296	C
5297	DO 256 JL = 1, KDLON
5298	ZCNSOL(JL)=PBSUR(JL,1)ZTT(JL,1) ZTT(JL,10)
5299	2 +PBSUR(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5300	3 +PBSUR(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5301	4 +PBSUR(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5302	5 +PBSUR(JL,5)ZTT(JL,3) ZTT(JL,14)
5303	6 +PBSUR(JL,6)ZTT(JL,6) ZTT(JL,15)
5304	ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5305	ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5306	PFLUC(JL,1,JK)=ZFU(JL)
5307	256 CONTINUE
5308	C
5309	C
5310	257 CONTINUE
5311	C
5312	C
5313	C
5314	C* 2.7 CLEAR-SKY FLUXES
5315	C ----------------
5316	C
5317	270 CONTINUE
5318	C
5319	IF (.NOT.LEVOIGT) THEN
5320	DO 271 JL = 1, KDLON
5321	ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
5322	271 CONTINUE
5323	DO 273 JK = JLIM+1,KFLEV+1
5324	DO 272 JL = 1, KDLON
5325	ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
5326	PFLUC(JL,1,JK) = ZFN10(JL)
5327	PFLUC(JL,2,JK) = 0.
5328	272 CONTINUE
5329	273 CONTINUE
5330	ENDIF
5331	C
5332	C ------------------------------------------------------------------
5333	C
5334	RETURN
5335	END
5336	SUBROUTINE LWVD(KUAER,KTRAER
5337	S , PABCU,PDBDT
5338	R , PGA,PGB
5339	S , PCNTRB,PDISD,PDISU)
5340	IMPLICIT none
5341	#include "dimensions.h"
5342	#include "dimphy.h"
5343	#include "raddim.h"
5344	#include "raddimlw.h"
5345	C
5346	C-----------------------------------------------------------------------
5347	C PURPOSE.
5348	C --------
5349	C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
5350	C
5351	C METHOD.
5352	C -------
5353	C
5354	C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5355	C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
5356	C
5357	C REFERENCE.
5358	C ----------
5359	C
5360	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5361	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5362	C
5363	C AUTHOR.
5364	C -------
5365	C JEAN-JACQUES MORCRETTE ECMWF
5366	C
5367	C MODIFICATIONS.
5368	C --------------
5369	C ORIGINAL : 89-07-14
5370	C-----------------------------------------------------------------------
5371	C* ARGUMENTS:
5372	C
5373	INTEGER KUAER,KTRAER
5374	C
5375	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5376	REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5377	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5378	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5379	C
5380	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
5381	REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5382	REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5383	C
5384	C* LOCAL VARIABLES:
5385	C
5386	REAL*8 ZGLAYD(KDLON)
5387	REAL*8 ZGLAYU(KDLON)
5388	REAL*8 ZTT(KDLON,NTRA)
5389	REAL*8 ZTT1(KDLON,NTRA)
5390	REAL*8 ZTT2(KDLON,NTRA)
5391	C
5392	INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
5393	INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
5394	INTEGER ind1, ind2, ind3, ind4, itt
5395	REAL*8 zww, zdzxdg, zdzxmg
5396	C
5397	C* 1. INITIALIZATION
5398	C --------------
5399	C
5400	100 CONTINUE
5401	C
5402	C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
5403	C ------------------------------
5404	C
5405	110 CONTINUE
5406	C
5407	DO 112 JK = 1, KFLEV+1
5408	DO 111 JL = 1, KDLON
5409	PDISD(JL,JK) = 0.
5410	PDISU(JL,JK) = 0.
5411	111 CONTINUE
5412	112 CONTINUE
5413	C
5414	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5415	C ---------------------------------
5416	C
5417	120 CONTINUE
5418	C
5419	C
5420	DO 122 JA = 1, NTRA
5421	DO 121 JL = 1, KDLON
5422	ZTT (JL,JA) = 1.0
5423	ZTT1(JL,JA) = 1.0
5424	ZTT2(JL,JA) = 1.0
5425	121 CONTINUE
5426	122 CONTINUE
5427	C
5428	C ------------------------------------------------------------------
5429	C
5430	C* 2. VERTICAL INTEGRATION
5431	C --------------------
5432	C
5433	200 CONTINUE
5434	C
5435	IND1=0
5436	IND3=0
5437	IND4=1
5438	IND2=1
5439	C
5440	C
5441	C* 2.2 CONTRIBUTION FROM DISTANT LAYERS
5442	C ---------------------------------
5443	C
5444	220 CONTINUE
5445	C
5446	C
5447	C* 2.2.1 DISTANT AND ABOVE LAYERS
5448	C ------------------------
5449	C
5450	2210 CONTINUE
5451	C
5452	C
5453	C
5454	C* 2.2.2 FIRST UPPER LEVEL
5455	C -----------------
5456	C
5457	2220 CONTINUE
5458	C
5459	DO 225 JK = 1 , KFLEV-1
5460	IKP1=JK+1
5461	IKN=(JK-1)*NG1P1+1
5462	IKD1= JK *NG1P1+1
5463	C
5464	CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
5465	2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
5466	C
5467	C
5468	C
5469	C* 2.2.3 HIGHER UP
5470	C ---------
5471	C
5472	2230 CONTINUE
5473	C
5474	ITT=1
5475	DO 224 JKJ=IKP1,KFLEV
5476	IF(ITT.EQ.1) THEN
5477	ITT=2
5478	ELSE
5479	ITT=1
5480	ENDIF
5481	IKJP1=JKJ+1
5482	IKD2= JKJ *NG1P1+1
5483	C
5484	IF(ITT.EQ.1) THEN
5485	CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5486	2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
5487	ELSE
5488	CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5489	2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
5490	ENDIF
5491	C
5492	DO 2235 JA = 1, KTRAER
5493	DO 2234 JL = 1, KDLON
5494	ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5495	2234 CONTINUE
5496	2235 CONTINUE
5497	C
5498	DO 2236 JL = 1, KDLON
5499	ZWW=PDBDT(JL,1,JKJ)ZTT(JL,1) ZTT(JL,10)
5500	S +PDBDT(JL,2,JKJ)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5501	S +PDBDT(JL,3,JKJ)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5502	S +PDBDT(JL,4,JKJ)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5503	S +PDBDT(JL,5,JKJ)ZTT(JL,3) ZTT(JL,14)
5504	S +PDBDT(JL,6,JKJ)ZTT(JL,6) ZTT(JL,15)
5505	ZGLAYD(JL)=ZWW
5506	ZDZXDG=ZGLAYD(JL)
5507	PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
5508	PCNTRB(JL,JK,IKJP1)=ZDZXDG
5509	2236 CONTINUE
5510	C
5511	C
5512	224 CONTINUE
5513	225 CONTINUE
5514	C
5515	C
5516	C* 2.2.4 DISTANT AND BELOW LAYERS
5517	C ------------------------
5518	C
5519	2240 CONTINUE
5520	C
5521	C
5522	C
5523	C* 2.2.5 FIRST LOWER LEVEL
5524	C -----------------
5525	C
5526	2250 CONTINUE
5527	C
5528	DO 228 JK=3,KFLEV+1
5529	IKN=(JK-1)*NG1P1+1
5530	IKM1=JK-1
5531	IKJ=JK-2
5532	IKU1= IKJ *NG1P1+1
5533	C
5534	C
5535	CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
5536	2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
5537	C
5538	C
5539	C
5540	C* 2.2.6 DOWN BELOW
5541	C ----------
5542	C
5543	2260 CONTINUE
5544	C
5545	ITT=1
5546	DO 227 JLK=1,IKJ
5547	IF(ITT.EQ.1) THEN
5548	ITT=2
5549	ELSE
5550	ITT=1
5551	ENDIF
5552	IJKL=IKM1-JLK
5553	IKU2=(IJKL-1)*NG1P1+1
5554	C
5555	C
5556	IF(ITT.EQ.1) THEN
5557	CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5558	2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
5559	ELSE
5560	CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5561	2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
5562	ENDIF
5563	C
5564	DO 2265 JA = 1, KTRAER
5565	DO 2264 JL = 1, KDLON
5566	ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5567	2264 CONTINUE
5568	2265 CONTINUE
5569	C
5570	DO 2266 JL = 1, KDLON
5571	ZWW=PDBDT(JL,1,IJKL)ZTT(JL,1) ZTT(JL,10)
5572	S +PDBDT(JL,2,IJKL)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5573	S +PDBDT(JL,3,IJKL)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5574	S +PDBDT(JL,4,IJKL)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5575	S +PDBDT(JL,5,IJKL)ZTT(JL,3) ZTT(JL,14)
5576	S +PDBDT(JL,6,IJKL)ZTT(JL,6) ZTT(JL,15)
5577	ZGLAYU(JL)=ZWW
5578	ZDZXMG=ZGLAYU(JL)
5579	PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
5580	PCNTRB(JL,JK,IJKL)=ZDZXMG
5581	2266 CONTINUE
5582	C
5583	C
5584	227 CONTINUE
5585	228 CONTINUE
5586	C
5587	RETURN
5588	END
5589	SUBROUTINE LWVN(KUAER,KTRAER
5590	R , PABCU,PDBSL,PGA,PGB
5591	S , PADJD,PADJU,PCNTRB,PDBDT)
5592	IMPLICIT none
5593	#include "dimensions.h"
5594	#include "dimphy.h"
5595	#include "raddim.h"
5596	#include "raddimlw.h"
5597	C
5598	C-----------------------------------------------------------------------
5599	C PURPOSE.
5600	C --------
5601	C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
5602	C TO GIVE LONGWAVE FLUXES OR RADIANCES
5603	C
5604	C METHOD.
5605	C -------
5606	C
5607	C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5608	C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
5609	C
5610	C REFERENCE.
5611	C ----------
5612	C
5613	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5614	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5615	C
5616	C AUTHOR.
5617	C -------
5618	C JEAN-JACQUES MORCRETTE ECMWF
5619	C
5620	C MODIFICATIONS.
5621	C --------------
5622	C ORIGINAL : 89-07-14
5623	C-----------------------------------------------------------------------
5624	C
5625	C* ARGUMENTS:
5626	C
5627	INTEGER KUAER,KTRAER
5628	C
5629	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5630	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
5631	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5632	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5633	C
5634	REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5635	REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5636	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
5637	REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5638	C
5639	C* LOCAL ARRAYS:
5640	C
5641	REAL*8 ZGLAYD(KDLON)
5642	REAL*8 ZGLAYU(KDLON)
5643	REAL*8 ZTT(KDLON,NTRA)
5644	REAL*8 ZTT1(KDLON,NTRA)
5645	REAL*8 ZTT2(KDLON,NTRA)
5646	REAL*8 ZUU(KDLON,NUA)
5647	C
5648	INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
5649	INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
5650	REAL*8 zwtr
5651	c
5652	C* Data Block:
5653	c
5654	REAL*8 WG1(2)
5655	SAVE WG1
5656	DATA (WG1(jk),jk=1,2) /1.0, 1.0/
5657	C-----------------------------------------------------------------------
5658	C
5659	C* 1. INITIALIZATION
5660	C --------------
5661	C
5662	100 CONTINUE
5663	C
5664	C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
5665	C ------------------------------
5666	C
5667	110 CONTINUE
5668	C
5669	DO 112 JK = 1 , KFLEV+1
5670	DO 111 JL = 1, KDLON
5671	PADJD(JL,JK) = 0.
5672	PADJU(JL,JK) = 0.
5673	111 CONTINUE
5674	112 CONTINUE
5675	C
5676	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5677	C ---------------------------------
5678	C
5679	120 CONTINUE
5680	C
5681	DO 122 JA = 1 , NTRA
5682	DO 121 JL = 1, KDLON
5683	ZTT (JL,JA) = 1.0
5684	ZTT1(JL,JA) = 1.0
5685	ZTT2(JL,JA) = 1.0
5686	121 CONTINUE
5687	122 CONTINUE
5688	C
5689	DO 124 JA = 1 , NUA
5690	DO 123 JL = 1, KDLON
5691	ZUU(JL,JA) = 0.
5692	123 CONTINUE
5693	124 CONTINUE
5694	C
5695	C ------------------------------------------------------------------
5696	C
5697	C* 2. VERTICAL INTEGRATION
5698	C --------------------
5699	C
5700	200 CONTINUE
5701	C
5702	C
5703	C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS
5704	C ---------------------------------
5705	C
5706	210 CONTINUE
5707	C
5708	DO 215 JK = 1 , KFLEV
5709	C
5710	C* 2.1.1 DOWNWARD LAYERS
5711	C ---------------
5712	C
5713	2110 CONTINUE
5714	C
5715	IM12 = 2 * (JK - 1)
5716	IND = (JK - 1) * NG1P1 + 1
5717	IXD = IND
5718	INU = JK * NG1P1 + 1
5719	IXU = IND
5720	C
5721	DO 2111 JL = 1, KDLON
5722	ZGLAYD(JL) = 0.
5723	ZGLAYU(JL) = 0.
5724	2111 CONTINUE
5725	C
5726	DO 213 JG = 1 , NG1
5727	IBS = IM12 + JG
5728	IDD = IXD + JG
5729	DO 2113 JA = 1 , KUAER
5730	DO 2112 JL = 1, KDLON
5731	ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
5732	2112 CONTINUE
5733	2113 CONTINUE
5734	C
5735	C
5736	CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
5737	C
5738	DO 2114 JL = 1, KDLON
5739	ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
5740	S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5741	S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5742	S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5743	S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
5744	S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
5745	ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
5746	2114 CONTINUE
5747	C
5748	C* 2.1.2 DOWNWARD LAYERS
5749	C ---------------
5750	C
5751	2120 CONTINUE
5752	C
5753	IMU = IXU + JG
5754	DO 2122 JA = 1 , KUAER
5755	DO 2121 JL = 1, KDLON
5756	ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
5757	2121 CONTINUE
5758	2122 CONTINUE
5759	C
5760	C
5761	CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
5762	C
5763	DO 2123 JL = 1, KDLON
5764	ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
5765	S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5766	S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5767	S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5768	S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
5769	S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
5770	ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
5771	2123 CONTINUE
5772	C
5773	213 CONTINUE
5774	C
5775	DO 214 JL = 1, KDLON
5776	PADJD(JL,JK) = ZGLAYD(JL)
5777	PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
5778	PADJU(JL,JK+1) = ZGLAYU(JL)
5779	PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
5780	PCNTRB(JL,JK ,JK) = 0.0
5781	214 CONTINUE
5782	C
5783	215 CONTINUE
5784	C
5785	DO 218 JK = 1 , KFLEV
5786	JK2 = 2 * JK
5787	JK1 = JK2 - 1
5788	DO 217 JNU = 1 , Ninter
5789	DO 216 JL = 1, KDLON
5790	PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
5791	216 CONTINUE
5792	217 CONTINUE
5793	218 CONTINUE
5794	C
5795	RETURN
5796	C
5797	END
5798	SUBROUTINE LWTT(PGA,PGB,PUU, PTT)
5799	IMPLICIT none
5800	#include "dimensions.h"
5801	#include "dimphy.h"
5802	#include "raddim.h"
5803	#include "raddimlw.h"
5804	C
5805	C-----------------------------------------------------------------------
5806	C PURPOSE.
5807	C --------
5808	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
5809	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
5810	C INTERVALS.
5811	C
5812	C METHOD.
5813	C -------
5814	C
5815	C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
5816	C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
5817	C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
5818	C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
5819	C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
5820	C
5821	C REFERENCE.
5822	C ----------
5823	C
5824	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5825	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5826	C
5827	C AUTHOR.
5828	C -------
5829	C JEAN-JACQUES MORCRETTE ECMWF
5830	C
5831	C MODIFICATIONS.
5832	C --------------
5833	C ORIGINAL : 88-12-15
5834	C
5835	C-----------------------------------------------------------------------
5836	REAL*8 O1H, O2H
5837	PARAMETER (O1H=2230.)
5838	PARAMETER (O2H=100.)
5839	REAL*8 RPIALF0
5840	PARAMETER (RPIALF0=2.0)
5841	C
5842	C* ARGUMENTS:
5843	C
5844	REAL*8 PUU(KDLON,NUA)
5845	REAL*8 PTT(KDLON,NTRA)
5846	REAL*8 PGA(KDLON,8,2)
5847	REAL*8 PGB(KDLON,8,2)
5848	C
5849	C* LOCAL VARIABLES:
5850	C
5851	REAL*8 zz, zxd, zxn
5852	REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
5853	REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
5854	REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
5855	REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
5856	REAL*8 zsqn21, zodn21, zsqh42, zodh42
5857	REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
5858	REAL*8 zuu11, zuu12, za11, za12
5859	INTEGER jl, ja
5860	C ------------------------------------------------------------------
5861	C
5862	C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
5863	C -----------------------------------------------
5864	C
5865	100 CONTINUE
5866	C
5867	C
5868	DO 130 JA = 1 , 8
5869	DO 120 JL = 1, KDLON
5870	ZZ =SQRT(PUU(JL,JA))
5871	c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
5872	c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
5873	c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
5874	ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
5875	ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
5876	PTT(JL,JA)=ZXN /ZXD
5877	120 CONTINUE
5878	130 CONTINUE
5879	C
5880	C ------------------------------------------------------------------
5881	C
5882	C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
5883	C ---------------------------------------------------
5884	C
5885	200 CONTINUE
5886	C
5887	DO 201 JL = 1, KDLON
5888	PTT(JL, 9) = PTT(JL, 8)
5889	C
5890	C- CONTINUUM ABSORPTION: E- AND P-TYPE
5891	C
5892	ZPU = 0.002 * PUU(JL,10)
5893	ZPU10 = 112. * ZPU
5894	ZPU11 = 6.25 * ZPU
5895	ZPU12 = 5.00 * ZPU
5896	ZPU13 = 80.0 * ZPU
5897	ZEU = PUU(JL,11)
5898	ZEU10 = 12. * ZEU
5899	ZEU11 = 6.25 * ZEU
5900	ZEU12 = 5.00 * ZEU
5901	ZEU13 = 80.0 * ZEU
5902	C
5903	C- OZONE ABSORPTION
5904	C
5905	ZX = PUU(JL,12)
5906	ZY = PUU(JL,13)
5907	ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
5908	ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
5909	ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
5910	ZVXY = RPIALF0 * ZY / (2. * ZX)
5911	ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
5912	ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
5913	ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
5914	C
5915	C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
5916	C
5917	C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
5918	C
5919	c NEXOTIC=1
5920	c IF (NEXOTIC.EQ.1) THEN
5921	ZXCH4 = PUU(JL,19)
5922	ZYCH4 = PUU(JL,20)
5923	ZUXY = 4. * ZXCH4ZXCH4/(0.103ZYCH4)
5924	ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
5925	ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
5926	ZODH41 = ZVXY * ZSQH41
5927	C
5928	C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
5929	C
5930	ZXN2O = PUU(JL,21)
5931	ZYN2O = PUU(JL,22)
5932	ZUXY = 4. * ZXN2OZXN2O/(0.416ZYN2O)
5933	ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
5934	ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
5935	ZODN21 = ZVXY * ZSQN21
5936	C
5937	C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
5938	C
5939	ZUXY = 4. * ZXCH4ZXCH4/(0.113ZYCH4)
5940	ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
5941	ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
5942	ZODH42 = ZVXY * ZSQH42
5943	C
5944	C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
5945	C
5946	ZUXY = 4. * ZXN2OZXN2O/(0.197ZYN2O)
5947	ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
5948	ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
5949	ZODN22 = ZVXY * ZSQN22
5950	C
5951	C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
5952	C
5953	ZA11 = 2. * PUU(JL,23) * 4.404E+05
5954	ZTTF11 = 1. - ZA11 * 0.003225
5955	C
5956	C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
5957	C
5958	ZA12 = 2. * PUU(JL,24) * 6.7435E+05
5959	ZTTF12 = 1. - ZA12 * 0.003225
5960	C
5961	ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
5962	ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
5963	PTT(JL,10) = EXP( - PUU(JL,14) )
5964	PTT(JL,11) = EXP( ZUU11 )
5965	PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
5966	PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
5967	PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
5968	PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
5969	201 CONTINUE
5970	C
5971	RETURN
5972	END
5973	SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)
5974	IMPLICIT none
5975	#include "dimensions.h"
5976	#include "dimphy.h"
5977	#include "raddim.h"
5978	#include "raddimlw.h"
5979	C
5980	C ------------------------------------------------------------------
5981	C PURPOSE.
5982	C --------
5983	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
5984	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
5985	C INTERVALS.
5986	C
5987	C METHOD.
5988	C -------
5989	C
5990	C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
5991	C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
5992	C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
5993	C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
5994	C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
5995	C
5996	C REFERENCE.
5997	C ----------
5998	C
5999	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
6000	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
6001	C
6002	C AUTHOR.
6003	C -------
6004	C JEAN-JACQUES MORCRETTE ECMWF
6005	C
6006	C MODIFICATIONS.
6007	C --------------
6008	C ORIGINAL : 88-12-15
6009	C
6010	C-----------------------------------------------------------------------
6011	REAL*8 O1H, O2H
6012	PARAMETER (O1H=2230.)
6013	PARAMETER (O2H=100.)
6014	REAL*8 RPIALF0
6015	PARAMETER (RPIALF0=2.0)
6016	C
6017	C* ARGUMENTS:
6018	C
6019	REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
6020	REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
6021	REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
6022	REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
6023	REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
6024	C
6025	C* LOCAL VARIABLES:
6026	C
6027	INTEGER ja, jl
6028	REAL*8 zz, zxd, zxn
6029	REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
6030	REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
6031	REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
6032	REAL*8 zxch4, zych4, zsqh41, zodh41
6033	REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
6034	REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
6035	REAL*8 zuu11, zuu12
6036	C ------------------------------------------------------------------
6037	C
6038	C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
6039	C -----------------------------------------------
6040	C
6041	100 CONTINUE
6042	C
6043	C
6044	DO 130 JA = 1 , 8
6045	DO 120 JL = 1, KDLON
6046	ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
6047	ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
6048	ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
6049	PTT(JL,JA)=ZXN /ZXD
6050	120 CONTINUE
6051	130 CONTINUE
6052	C
6053	C ------------------------------------------------------------------
6054	C
6055	C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
6056	C ---------------------------------------------------
6057	C
6058	200 CONTINUE
6059	C
6060	DO 201 JL = 1, KDLON
6061	PTT(JL, 9) = PTT(JL, 8)
6062	C
6063	C- CONTINUUM ABSORPTION: E- AND P-TYPE
6064	C
6065	ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
6066	ZPU10 = 112. * ZPU
6067	ZPU11 = 6.25 * ZPU
6068	ZPU12 = 5.00 * ZPU
6069	ZPU13 = 80.0 * ZPU
6070	ZEU = (PUU1(JL,11) - PUU2(JL,11))
6071	ZEU10 = 12. * ZEU
6072	ZEU11 = 6.25 * ZEU
6073	ZEU12 = 5.00 * ZEU
6074	ZEU13 = 80.0 * ZEU
6075	C
6076	C- OZONE ABSORPTION
6077	C
6078	ZX = (PUU1(JL,12) - PUU2(JL,12))
6079	ZY = (PUU1(JL,13) - PUU2(JL,13))
6080	ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
6081	ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
6082	ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
6083	ZVXY = RPIALF0 * ZY / (2. * ZX)
6084	ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
6085	ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
6086	ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
6087	C
6088	C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
6089	C
6090	C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
6091	C
6092	ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
6093	ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
6094	ZUXY = 4. * ZXCH4ZXCH4/(0.103ZYCH4)
6095	ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
6096	ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
6097	ZODH41 = ZVXY * ZSQH41
6098	C
6099	C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
6100	C
6101	ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
6102	ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
6103	ZUXY = 4. * ZXN2OZXN2O/(0.416ZYN2O)
6104	ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
6105	ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
6106	ZODN21 = ZVXY * ZSQN21
6107	C
6108	C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
6109	C
6110	ZUXY = 4. * ZXCH4ZXCH4/(0.113ZYCH4)
6111	ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
6112	ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
6113	ZODH42 = ZVXY * ZSQH42
6114	C
6115	C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
6116	C
6117	ZUXY = 4. * ZXN2OZXN2O/(0.197ZYN2O)
6118	ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
6119	ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
6120	ZODN22 = ZVXY * ZSQN22
6121	C
6122	C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
6123	C
6124	ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
6125	ZTTF11 = 1. - ZA11 * 0.003225
6126	C
6127	C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
6128	C
6129	ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
6130	ZTTF12 = 1. - ZA12 * 0.003225
6131	C
6132	ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
6133	ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
6134	S ZODH41 - ZODN21
6135	PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
6136	PTT(JL,11) = EXP( ZUU11 )
6137	PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
6138	PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
6139	PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
6140	PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
6141	201 CONTINUE
6142	C
6143	RETURN
6144	END

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format