Context Navigation

radlwsw.F @ 594

Last change on this file since 594 was 557, checked in by lmdzadmin, 20 years ago
Initialisations diverses heritees de LMDZ.3.3 LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 198.5 KB

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

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

Download in other formats:

Original Format