Context Navigation

radlwsw.F @ 574

Last change on this file since 574 was 556, checked in by lmdzadmin, 20 years ago
Initialisations diverses necessaires au portage Prism AC LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 198.5 KB

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

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

Download in other formats:

Original Format