Context Navigation

radlwsw.F @ 2661

Last change on this file since 2661 was 634, checked in by Laurent Fairhead, 20 years ago
Modifications faites à la physique pour la rendre parallele YM Une branche de travail LMDZ4_par_0 a été créée provisoirement afin de tester les modifs pleinement avant leurs inclusions dans le tronc principal LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 200.0 KB

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

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

Download in other formats:

Original Format