Context Navigation

radlwsw.F @ 520

Last change on this file since 520 was 517, checked in by lmdzadmin, 21 years ago
Inclusion des modifications de O. Boucher et de J. Quaas pour le calcul des premiers effets directs et indirects dus aux aerosols LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 198.2 KB

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

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

Download in other formats:

Original Format