Context Navigation

radlwsw.F @ 338

Last change on this file since 338 was 283, checked in by lmdzadmin, 23 years ago
Modifs pour la prise en compte du passage des deux albedos de surface LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 185.0 KB

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

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

Download in other formats:

Original Format