Context Navigation

radlwsw.F @ 281

Last change on this file since 281 was 177, checked in by lmdzadmin, 24 years ago

Lots of stuff, plus particulierement:

appel a ORCHIDEE en etat de marche (pb de grille subsiste)
modifs de Pascale sur soil dans le cas ou ok_veget=false -

Property svn:eol-style set to native
Property svn:executable set to *
Property svn:keywords set to Author Date Id Revision

File size: 184.9 KB

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

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

Download in other formats:

Original Format