Context Navigation

radlwsw.F @ 644

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

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

Download in other formats:

Original Format