Context Navigation

radlwsw.F @ 2672

Last change on this file since 2672 was 524, checked in by lmdzadmin, 21 years ago
Initial revision
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 198.2 KB

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

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

Download in other formats:

Original Format