Context Navigation

radlwsw.F @ 4096

Last change on this file since 4096 was 699, checked in by Laurent Fairhead, 19 years ago
En fait le bug sur l'ozone n'en etait pas un! on revient a la situation precedente MPL/JLD LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 197.2 KB

Line
1	!
2	! $Header$
3	!
4	SUBROUTINE radlwsw(dist, rmu0, fract,
5	. paprs, pplay,tsol,albedo, alblw, t,q,wo,
6	. cldfra, cldemi, cldtaupd,
7	. heat,heat0,cool,cool0,radsol,albpla,
8	. topsw,toplw,solsw,sollw,
9	. sollwdown,
10	. topsw0,toplw0,solsw0,sollw0,
11	. lwdn0, lwdn, lwup0, lwup,
12	. swdn0, swdn, swup0, swup,
13	. ok_ade, ok_aie,
14	. tau_ae, piz_ae, cg_ae,
15	. topswad, solswad,
16	. cldtaupi, topswai, solswai)
17	c
18	IMPLICIT none
19	c======================================================================
20	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719
21	c Objet: interface entre le modele et les rayonnements
22	c Arguments:
23	c dist-----input-R- distance astronomique terre-soleil
24	c rmu0-----input-R- cosinus de l'angle zenithal
25	c fract----input-R- duree d'ensoleillement normalisee
26	c co2_ppm--input-R- concentration du gaz carbonique (en ppm)
27	c solaire--input-R- constante solaire (W/m**2)
28	c paprs----input-R- pression a inter-couche (Pa)
29	c pplay----input-R- pression au milieu de couche (Pa)
30	c tsol-----input-R- temperature du sol (en K)
31	c albedo---input-R- albedo du sol (entre 0 et 1)
32	c t--------input-R- temperature (K)
33	c q--------input-R- vapeur d'eau (en kg/kg)
34	c wo-------input-R- contenu en ozone (en kg/kg) correction MPL 100505
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	c convertir ozone de kg/kg en pa (modif MPL 100505)
2887	ZOZ(i,k) = POZON(i,k)PDP(i,k) RMD/RMO3
2888	c print ,'LW: ZOZ10*6=',ZOZ(i,k)1000000.
2889	ENDDO
2890	ENDDO
2891	cIM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
2892	CALL LWU(
2893	S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
2894	CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
2895	S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
2896	itaplw0 = 0
2897	ENDIF
2898	itaplw0 = itaplw0 + 1
2899	C
2900	IF (MOD(itaplw,lwpas).EQ.0) THEN
2901	CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS,
2902	S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
2903	S ZFLUX)
2904	itaplw = 0
2905	ENDIF
2906	itaplw = itaplw + 1
2907	C
2908	DO k = 1, KFLEV
2909	kpl1 = k+1
2910	DO i = 1, KDLON
2911	PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
2912	. - ZFLUX(i,1,k)- ZFLUX(i,2,k)
2913	PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
2914	PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
2915	. - ZFLUC(i,1,k)- ZFLUC(i,2,k)
2916	PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
2917	ENDDO
2918	ENDDO
2919	DO i = 1, KDLON
2920	PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
2921	PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
2922	c
2923	PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
2924	PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
2925	psollwdown(i) = -ZFLUX(i,2,1)
2926	c
2927	cIM attention aux signes !; LWtop >0, LWdn < 0
2928	DO k = 1, KFLEV+1
2929	plwup(i,k) = ZFLUX(i,1,k)
2930	plwup0(i,k) = ZFLUC(i,1,k)
2931	plwdn(i,k) = ZFLUX(i,2,k)
2932	plwdn0(i,k) = ZFLUC(i,2,k)
2933	ENDDO
2934	ENDDO
2935	C ------------------------------------------------------------------
2936	RETURN
2937	END
2938	cIM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
2939	SUBROUTINE LWU(
2940	S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
2941	S PABCU)
2942	IMPLICIT none
2943	#include "dimensions.h"
2944	#include "dimphy.h"
2945	#include "raddim.h"
2946	#include "raddimlw.h"
2947	#include "YOMCST.h"
2948	#include "radepsi.h"
2949	#include "radopt.h"
2950	C
2951	C PURPOSE.
2952	C --------
2953	C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
2954	C TEMPERATURE EFFECTS
2955	C
2956	C METHOD.
2957	C -------
2958	C
2959	C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2960	C ABSORBERS.
2961	C
2962	C
2963	C REFERENCE.
2964	C ----------
2965	C
2966	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2967	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2968	C
2969	C AUTHOR.
2970	C -------
2971	C JEAN-JACQUES MORCRETTE ECMWF
2972	C
2973	C MODIFICATIONS.
2974	C --------------
2975	C ORIGINAL : 89-07-14
2976	C Voigt lines (loop 404 modified) - JJM & PhD - 01/96
2977	C-----------------------------------------------------------------------
2978	C* ARGUMENTS:
2979	cIM ctes ds clesphys.h
2980	c REAL*8 RCO2
2981	c REAL*8 RCH4, RN2O, RCFC11, RCFC12
2982	#include "clesphys.h"
2983	REAL*8 PAER(KDLON,KFLEV,5)
2984	REAL*8 PDP(KDLON,KFLEV)
2985	REAL*8 PPMB(KDLON,KFLEV+1)
2986	REAL*8 PPSOL(KDLON)
2987	REAL*8 POZ(KDLON,KFLEV)
2988	REAL*8 PTAVE(KDLON,KFLEV)
2989	REAL*8 PVIEW(KDLON)
2990	REAL*8 PWV(KDLON,KFLEV)
2991	C
2992	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
2993	C
2994	C-----------------------------------------------------------------------
2995	C* LOCAL VARIABLES:
2996	REAL8 ZABLY(KDLON,NUA,3KFLEV+1)
2997	REAL8 ZDUC(KDLON,3KFLEV+1)
2998	REAL*8 ZPHIO(KDLON)
2999	REAL*8 ZPSC2(KDLON)
3000	REAL*8 ZPSC3(KDLON)
3001	REAL*8 ZPSH1(KDLON)
3002	REAL*8 ZPSH2(KDLON)
3003	REAL*8 ZPSH3(KDLON)
3004	REAL*8 ZPSH4(KDLON)
3005	REAL*8 ZPSH5(KDLON)
3006	REAL*8 ZPSH6(KDLON)
3007	REAL*8 ZPSIO(KDLON)
3008	REAL*8 ZTCON(KDLON)
3009	REAL*8 ZPHM6(KDLON)
3010	REAL*8 ZPSM6(KDLON)
3011	REAL*8 ZPHN6(KDLON)
3012	REAL*8 ZPSN6(KDLON)
3013	REAL8 ZSSIG(KDLON,3KFLEV+1)
3014	REAL*8 ZTAVI(KDLON)
3015	REAL*8 ZUAER(KDLON,Ninter)
3016	REAL*8 ZXOZ(KDLON)
3017	REAL*8 ZXWV(KDLON)
3018	C
3019	INTEGER jl, jk, jkj, jkjr, jkjp, ig1
3020	INTEGER jki, jkip1, ja, jj
3021	INTEGER jkl, jkp1, jkk, jkjpn
3022	INTEGER jae1, jae2, jae3, jae, jjpn
3023	INTEGER ir, jc, jcp1
3024	REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
3025	REAL*8 zfppw, ztx, ztx2, zzably
3026	REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
3027	REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
3028	REAL*8 zcac8, zcbc8
3029	REAL*8 zalup, zdiff
3030	c
3031	REAL*8 PVGCO2, PVGH2O, PVGO3
3032	C
3033	REAL*8 R10E ! DECIMAL/NATURAL LOG.FACTOR
3034	PARAMETER (R10E=0.4342945)
3035	c
3036	c Used Data Block:
3037	c
3038	REAL*8 TREF
3039	SAVE TREF
3040	REAL*8 RT1(2)
3041	SAVE RT1
3042	REAL*8 RAER(5,5)
3043	SAVE RAER
3044	REAL*8 AT(8,3), BT(8,3)
3045	SAVE AT, BT
3046	REAL*8 OCT(4)
3047	SAVE OCT
3048	DATA TREF /250.0/
3049	DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
3050	DATA RAER / .038520, .037196, .040532, .054934, .038520
3051	1 , .12613 , .18313 , .10357 , .064106, .126130
3052	2 , .012579, .013649, .018652, .025181, .012579
3053	3 , .011890, .016142, .021105, .028908, .011890
3054	4 , .013792, .026810, .052203, .066338, .013792 /
3055	DATA (AT(1,IR),IR=1,3) /
3056	S 0.298199E-02,-.394023E-03,0.319566E-04 /
3057	DATA (BT(1,IR),IR=1,3) /
3058	S-0.106432E-04,0.660324E-06,0.174356E-06 /
3059	DATA (AT(2,IR),IR=1,3) /
3060	S 0.143676E-01,0.366501E-02,-.160822E-02 /
3061	DATA (BT(2,IR),IR=1,3) /
3062	S-0.553979E-04,-.101701E-04,0.920868E-05 /
3063	DATA (AT(3,IR),IR=1,3) /
3064	S 0.197861E-01,0.315541E-02,-.174547E-02 /
3065	DATA (BT(3,IR),IR=1,3) /
3066	S-0.877012E-04,0.513302E-04,0.523138E-06 /
3067	DATA (AT(4,IR),IR=1,3) /
3068	S 0.289560E-01,-.208807E-02,-.121943E-02 /
3069	DATA (BT(4,IR),IR=1,3) /
3070	S-0.165960E-03,0.157704E-03,-.146427E-04 /
3071	DATA (AT(5,IR),IR=1,3) /
3072	S 0.103800E-01,0.436296E-02,-.161431E-02 /
3073	DATA (BT(5,IR),IR=1,3) /
3074	S -.276744E-04,-.327381E-04,0.127646E-04 /
3075	DATA (AT(6,IR),IR=1,3) /
3076	S 0.868859E-02,-.972752E-03,0.000000E-00 /
3077	DATA (BT(6,IR),IR=1,3) /
3078	S -.278412E-04,-.713940E-06,0.117469E-05 /
3079	DATA (AT(7,IR),IR=1,3) /
3080	S 0.250073E-03,0.455875E-03,0.109242E-03 /
3081	DATA (BT(7,IR),IR=1,3) /
3082	S 0.199846E-05,-.216313E-05,0.175991E-06 /
3083	DATA (AT(8,IR),IR=1,3) /
3084	S 0.307423E-01,0.110879E-02,-.322172E-03 /
3085	DATA (BT(8,IR),IR=1,3) /
3086	S-0.108482E-03,0.258096E-05,-.814575E-06 /
3087	c
3088	DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
3089	C-----------------------------------------------------------------------
3090	c
3091	IF (LEVOIGT) THEN
3092	PVGCO2= 60.
3093	PVGH2O= 30.
3094	PVGO3 =400.
3095	ELSE
3096	PVGCO2= 0.
3097	PVGH2O= 0.
3098	PVGO3 = 0.
3099	ENDIF
3100	C
3101	C
3102	C* 2. PRESSURE OVER GAUSS SUB-LEVELS
3103	C ------------------------------
3104	C
3105	200 CONTINUE
3106	C
3107	DO 201 JL = 1, KDLON
3108	ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
3109	201 CONTINUE
3110	C
3111	DO 206 JK = 1 , KFLEV
3112	JKJ=(JK-1)*NG1P1+1
3113	JKJR = JKJ
3114	JKJP = JKJ + NG1P1
3115	DO 203 JL = 1, KDLON
3116	ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
3117	203 CONTINUE
3118	DO 205 IG1=1,NG1
3119	JKJ=JKJ+1
3120	DO 204 JL = 1, KDLON
3121	ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
3122	S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
3123	204 CONTINUE
3124	205 CONTINUE
3125	206 CONTINUE
3126	C
3127	C-----------------------------------------------------------------------
3128	C
3129	C
3130	C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
3131	C --------------------------------------------------
3132	C
3133	400 CONTINUE
3134	C
3135	DO 402 JKI=1,3*KFLEV
3136	JKIP1=JKI+1
3137	DO 401 JL = 1, KDLON
3138	ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
3139	ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
3140	S /(10.*RG)
3141	401 CONTINUE
3142	402 CONTINUE
3143	C
3144	DO 406 JK = 1 , KFLEV
3145	JKP1=JK+1
3146	JKL = KFLEV+1 - JK
3147	DO 403 JL = 1, KDLON
3148	ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
3149	ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
3150	403 CONTINUE
3151	JKJ=(JK-1)*NG1P1+1
3152	JKJPN=JKJ+NG1
3153	DO 405 JKK=JKJ,JKJPN
3154	DO 404 JL = 1, KDLON
3155	ZDPM = ZABLY(JL,3,JKK)
3156	ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325.
3157	ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
3158	ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
3159	ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325.
3160	ZDUC(JL,JKK) = ZDPM
3161	ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
3162	ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
3163	ZU6 = ZXWV(JL) * ZUPM
3164	ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
3165	ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
3166	ZABLY(JL,11,JKK) = ZU6 * ZFPPW
3167	ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
3168	ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
3169	ZABLY(JL,8,JKK) = RCO2 * ZDPM
3170	404 CONTINUE
3171	405 CONTINUE
3172	406 CONTINUE
3173	C
3174	C-----------------------------------------------------------------------
3175	C
3176	C
3177	C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
3178	C --------------------------------------------------
3179	C
3180	500 CONTINUE
3181	C
3182	DO 502 JA = 1, NUA
3183	DO 501 JL = 1, KDLON
3184	PABCU(JL,JA,3*KFLEV+1) = 0.
3185	501 CONTINUE
3186	502 CONTINUE
3187	C
3188	DO 529 JK = 1 , KFLEV
3189	JJ=(JK-1)*NG1P1+1
3190	JJPN=JJ+NG1
3191	JKL=KFLEV+1-JK
3192	C
3193	C
3194	C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
3195	C --------------------------------------------------
3196	C
3197	510 CONTINUE
3198	C
3199	JAE1=3*KFLEV+1-JJ
3200	JAE2=3*KFLEV+1-(JJ+1)
3201	JAE3=3*KFLEV+1-JJPN
3202	DO 512 JAE=1,5
3203	DO 511 JL = 1, KDLON
3204	ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
3205	S +RAER(JAE,2)PAER(JL,JKL,2)+RAER(JAE,3)PAER(JL,JKL,3)
3206	S +RAER(JAE,4)PAER(JL,JKL,4)+RAER(JAE,5)PAER(JL,JKL,5))
3207	S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
3208	511 CONTINUE
3209	512 CONTINUE
3210	C
3211	C
3212	C
3213	C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
3214	C --------------------------------------------------
3215	C
3216	520 CONTINUE
3217	C
3218	DO 521 JL = 1, KDLON
3219	ZTAVI(JL)=PTAVE(JL,JKL)
3220	ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
3221	ZTX=ZTAVI(JL)-TREF
3222	ZTX2=ZTX*ZTX
3223	ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
3224	CMAF ZUP=MIN( MAX( 0.5R10ELOG( ZZABLY ) + 5., 0.), 6.0)
3225	ZUP=MIN( MAX( 0.5R10ELOG( ZZABLY ) + 5., 0.d+0), 6.d+0)
3226	ZCAH1=AT(1,1)+ZUP(AT(1,2)+ZUP(AT(1,3)))
3227	ZCBH1=BT(1,1)+ZUP(BT(1,2)+ZUP(BT(1,3)))
3228	ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
3229	ZCAH2=AT(2,1)+ZUP(AT(2,2)+ZUP(AT(2,3)))
3230	ZCBH2=BT(2,1)+ZUP(BT(2,2)+ZUP(BT(2,3)))
3231	ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
3232	ZCAH3=AT(3,1)+ZUP(AT(3,2)+ZUP(AT(3,3)))
3233	ZCBH3=BT(3,1)+ZUP(BT(3,2)+ZUP(BT(3,3)))
3234	ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
3235	ZCAH4=AT(4,1)+ZUP(AT(4,2)+ZUP(AT(4,3)))
3236	ZCBH4=BT(4,1)+ZUP(BT(4,2)+ZUP(BT(4,3)))
3237	ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
3238	ZCAH5=AT(5,1)+ZUP(AT(5,2)+ZUP(AT(5,3)))
3239	ZCBH5=BT(5,1)+ZUP(BT(5,2)+ZUP(BT(5,3)))
3240	ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
3241	ZCAH6=AT(6,1)+ZUP(AT(6,2)+ZUP(AT(6,3)))
3242	ZCBH6=BT(6,1)+ZUP(BT(6,2)+ZUP(BT(6,3)))
3243	ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
3244	ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
3245	ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
3246	ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
3247	ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
3248	521 CONTINUE
3249	C
3250	DO 522 JL = 1, KDLON
3251	ZTAVI(JL)=PTAVE(JL,JKL)
3252	ZTX=ZTAVI(JL)-TREF
3253	ZTX2=ZTX*ZTX
3254	ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
3255	ZALUP = R10E * LOG ( ZZABLY )
3256	CMAF ZUP = MAX( 0.0 , 5.0 + 0.5 * ZALUP )
3257	ZUP = MAX( 0.d+0 , 5.0 + 0.5 * ZALUP )
3258	ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
3259	ZCAC8=AT(8,1)+ZUP(AT(8,2)+ZUP(AT(8,3)))
3260	ZCBC8=BT(8,1)+ZUP(BT(8,2)+ZUP(BT(8,3)))
3261	ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
3262	ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
3263	ZPSIO(JL) = EXP( 2.* (OCT(3)ZTX+OCT(4)ZTX2))
3264	522 CONTINUE
3265	C
3266	DO 524 JKK=JJ,JJPN
3267	JC=3*KFLEV+1-JKK
3268	JCP1=JC+1
3269	DO 523 JL = 1, KDLON
3270	ZDIFF = PVIEW(JL)
3271	PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
3272	S +ZABLY(JL,10,JC) *ZDIFF
3273	PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
3274	S +ZABLY(JL,11,JC)ZTCON(JL)ZDIFF
3275	C
3276	PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
3277	S +ZABLY(JL,12,JC)ZPHIO(JL)ZDIFF
3278	PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
3279	S +ZABLY(JL,13,JC)ZPSIO(JL)ZDIFF
3280	C
3281	PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
3282	S +ZABLY(JL,9,JC)ZPSC2(JL)ZDIFF
3283	PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
3284	S +ZABLY(JL,9,JC)ZPSC3(JL)ZDIFF
3285	PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
3286	S +ZABLY(JL,9,JC)ZPSC3(JL)ZDIFF
3287	C
3288	PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
3289	S +ZABLY(JL,6,JC)ZPSH1(JL)ZDIFF
3290	PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
3291	S +ZABLY(JL,6,JC)ZPSH2(JL)ZDIFF
3292	PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
3293	S +ZABLY(JL,6,JC)ZPSH5(JL)ZDIFF
3294	PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
3295	S +ZABLY(JL,6,JC)ZPSH3(JL)ZDIFF
3296	PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
3297	S +ZABLY(JL,6,JC)ZPSH4(JL)ZDIFF
3298	PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
3299	S +ZABLY(JL,6,JC)ZPSH6(JL)ZDIFF
3300	C
3301	PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
3302	S +ZUAER(JL,1) ZDUC(JL,JC)ZDIFF
3303	PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
3304	S +ZUAER(JL,2) ZDUC(JL,JC)ZDIFF
3305	PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
3306	S +ZUAER(JL,3) ZDUC(JL,JC)ZDIFF
3307	PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
3308	S +ZUAER(JL,4) ZDUC(JL,JC)ZDIFF
3309	PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
3310	S +ZUAER(JL,5) ZDUC(JL,JC)ZDIFF
3311	C
3312	PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
3313	S +ZABLY(JL,8,JC)RCH4/RCO2ZPHM6(JL)*ZDIFF
3314	PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
3315	S +ZABLY(JL,9,JC)RCH4/RCO2ZPSM6(JL)*ZDIFF
3316	PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
3317	S +ZABLY(JL,8,JC)RN2O/RCO2ZPHN6(JL)*ZDIFF
3318	PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
3319	S +ZABLY(JL,9,JC)RN2O/RCO2ZPSN6(JL)*ZDIFF
3320	C
3321	PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
3322	S +ZABLY(JL,8,JC)RCFC11/RCO2 ZDIFF
3323	PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
3324	S +ZABLY(JL,8,JC)RCFC12/RCO2 ZDIFF
3325	523 CONTINUE
3326	524 CONTINUE
3327	C
3328	529 CONTINUE
3329	C
3330	C
3331	RETURN
3332	END
3333	SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
3334	S PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
3335	IMPLICIT none
3336	#include "dimensions.h"
3337	#include "dimphy.h"
3338	#include "raddim.h"
3339	#include "raddimlw.h"
3340	#include "YOMCST.h"
3341	C
3342	C PURPOSE.
3343	C --------
3344	C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
3345	C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
3346	C SAVING
3347	C
3348	C METHOD.
3349	C -------
3350	C
3351	C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
3352	C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
3353	C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
3354	C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
3355	C BOUNDARIES.
3356	C 3. COMPUTES THE CLEAR-SKY COOLING RATES.
3357	C
3358	C REFERENCE.
3359	C ----------
3360	C
3361	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3362	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3363	C
3364	C AUTHOR.
3365	C -------
3366	C JEAN-JACQUES MORCRETTE ECMWF
3367	C
3368	C MODIFICATIONS.
3369	C --------------
3370	C ORIGINAL : 89-07-14
3371	C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
3372	C MEMORY)
3373	C-----------------------------------------------------------------------
3374	C* ARGUMENTS:
3375	INTEGER KLIM
3376	C
3377	REAL*8 PDP(KDLON,KFLEV)
3378	REAL*8 PDT0(KDLON)
3379	REAL*8 PEMIS(KDLON)
3380	REAL*8 PPMB(KDLON,KFLEV+1)
3381	REAL*8 PTL(KDLON,KFLEV+1)
3382	REAL*8 PTAVE(KDLON,KFLEV)
3383	C
3384	REAL*8 PFLUC(KDLON,2,KFLEV+1)
3385	C
3386	REAL8 PABCU(KDLON,NUA,3KFLEV+1)
3387	REAL*8 PBINT(KDLON,KFLEV+1)
3388	REAL*8 PBSUI(KDLON)
3389	REAL*8 PCTS(KDLON,KFLEV)
3390	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
3391	C
3392	C-------------------------------------------------------------------------
3393	C
3394	C* LOCAL VARIABLES:
3395	REAL*8 ZB(KDLON,Ninter,KFLEV+1)
3396	REAL*8 ZBSUR(KDLON,Ninter)
3397	REAL*8 ZBTOP(KDLON,Ninter)
3398	REAL8 ZDBSL(KDLON,Ninter,KFLEV2)
3399	REAL*8 ZGA(KDLON,8,2,KFLEV)
3400	REAL*8 ZGB(KDLON,8,2,KFLEV)
3401	REAL*8 ZGASUR(KDLON,8,2)
3402	REAL*8 ZGBSUR(KDLON,8,2)
3403	REAL*8 ZGATOP(KDLON,8,2)
3404	REAL*8 ZGBTOP(KDLON,8,2)
3405	C
3406	INTEGER nuaer, ntraer
3407	C ------------------------------------------------------------------
3408	C* COMPUTES PLANCK FUNCTIONS:
3409	CALL LWB(PDT0,PTAVE,PTL,
3410	S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
3411	S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
3412	C ------------------------------------------------------------------
3413	C* PERFORMS THE VERTICAL INTEGRATION:
3414	NUAER = NUA
3415	NTRAER = NTRA
3416	CALL LWV(NUAER,NTRAER, KLIM
3417	R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
3418	R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
3419	S , PCNTRB,PCTS,PFLUC)
3420	C ------------------------------------------------------------------
3421	RETURN
3422	END
3423	SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
3424	R PBINT,PBSUIN,PCTS,PCNTRB,
3425	S PFLUX)
3426	IMPLICIT none
3427	#include "dimensions.h"
3428	#include "dimphy.h"
3429	#include "raddim.h"
3430	#include "radepsi.h"
3431	#include "radopt.h"
3432	C
3433	C PURPOSE.
3434	C --------
3435	C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
3436	C RADIANCES
3437	C
3438	C EXPLICIT ARGUMENTS :
3439	C --------------------
3440	C ==== INPUTS ===
3441	C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION
3442	C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3443	C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION
3444	C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION
3445	C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
3446	C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE
3447	C PEMIS : (KDLON) ; SURFACE EMISSIVITY
3448	C PFLUC
3449	C ==== OUTPUTS ===
3450	C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES :
3451	C 1 ==> UPWARD FLUX TOTAL
3452	C 2 ==> DOWNWARD FLUX TOTAL
3453	C
3454	C METHOD.
3455	C -------
3456	C
3457	C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
3458	C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
3459	C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
3460	C CLOUDS
3461	C
3462	C REFERENCE.
3463	C ----------
3464	C
3465	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3466	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3467	C
3468	C AUTHOR.
3469	C -------
3470	C JEAN-JACQUES MORCRETTE ECMWF
3471	C
3472	C MODIFICATIONS.
3473	C --------------
3474	C ORIGINAL : 89-07-14
3475	C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96
3476	C-----------------------------------------------------------------------
3477	C* ARGUMENTS:
3478	INTEGER klim
3479	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
3480	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3481	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3482	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
3483	REAL*8 PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE
3484	c
3485	REAL*8 PCLDLD(KDLON,KFLEV)
3486	REAL*8 PCLDLU(KDLON,KFLEV)
3487	REAL*8 PEMIS(KDLON)
3488	C
3489	REAL*8 PFLUX(KDLON,2,KFLEV+1)
3490	C-----------------------------------------------------------------------
3491	C* LOCAL VARIABLES:
3492	INTEGER IMX(KDLON), IMXP(KDLON)
3493	C
3494	REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
3495	S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
3496	S , ZUPF(KDLON,KFLEV+1,KFLEV+1)
3497	REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
3498	C
3499	INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
3500	INTEGER jk1, jk2, jkc, jkcp1, jcloud
3501	INTEGER imxm1, imxp1
3502	REAL*8 zcfrac
3503	C ------------------------------------------------------------------
3504	C
3505	C* 1. INITIALIZATION
3506	C --------------
3507	C
3508	100 CONTINUE
3509	C
3510	IMAXC = 0
3511	C
3512	DO 101 JL = 1, KDLON
3513	IMX(JL)=0
3514	IMXP(JL)=0
3515	ZCLOUD(JL) = 0.
3516	101 CONTINUE
3517	C
3518	C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
3519	C -------------------------------------------
3520	C
3521	110 CONTINUE
3522	C
3523	DO 112 JK = 1 , KFLEV
3524	DO 111 JL = 1, KDLON
3525	IMX1=IMX(JL)
3526	IMX2=JK
3527	IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
3528	IMXP(JL)=IMX2
3529	ELSE
3530	IMXP(JL)=IMX1
3531	END IF
3532	IMAXC=MAX(IMXP(JL),IMAXC)
3533	IMX(JL)=IMXP(JL)
3534	111 CONTINUE
3535	112 CONTINUE
3536	CGM*******
3537	IMAXC=KFLEV
3538	CGM*******
3539	C
3540	DO 114 JK = 1 , KFLEV+1
3541	DO 113 JL = 1, KDLON
3542	PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
3543	PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
3544	113 CONTINUE
3545	114 CONTINUE
3546	C
3547	C ------------------------------------------------------------------
3548	C
3549	C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
3550	C ---------------------------------------
3551	C
3552	IF (IMAXC.GT.0) THEN
3553	C
3554	IMXP1 = IMAXC + 1
3555	IMXM1 = IMAXC - 1
3556	C
3557	C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES
3558	C ------------------------------
3559	C
3560	200 CONTINUE
3561	C
3562	DO 203 JK1=1,KFLEV+1
3563	DO 202 JK2=1,KFLEV+1
3564	DO 201 JL = 1, KDLON
3565	ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
3566	ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
3567	201 CONTINUE
3568	202 CONTINUE
3569	203 CONTINUE
3570	C
3571	C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
3572	C ----------------------------------------------
3573	C
3574	210 CONTINUE
3575	C
3576	DO 213 JKC = 1 , IMAXC
3577	JCLOUD=JKC
3578	JKCP1=JCLOUD+1
3579	C
3580	C* 2.1.1 ABOVE THE CLOUD
3581	C ---------------
3582	C
3583	2110 CONTINUE
3584	C
3585	DO 2115 JK=JKCP1,KFLEV+1
3586	JKM1=JK-1
3587	DO 2111 JL = 1, KDLON
3588	ZFU(JL)=0.
3589	2111 CONTINUE
3590	IF (JK .GT. JKCP1) THEN
3591	DO 2113 JKJ=JKCP1,JKM1
3592	DO 2112 JL = 1, KDLON
3593	ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
3594	2112 CONTINUE
3595	2113 CONTINUE
3596	END IF
3597	C
3598	DO 2114 JL = 1, KDLON
3599	ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
3600	2114 CONTINUE
3601	2115 CONTINUE
3602	C
3603	C* 2.1.2 BELOW THE CLOUD
3604	C ---------------
3605	C
3606	2120 CONTINUE
3607	C
3608	DO 2125 JK=1,JCLOUD
3609	JKP1=JK+1
3610	DO 2121 JL = 1, KDLON
3611	ZFD(JL)=0.
3612	2121 CONTINUE
3613	C
3614	IF (JK .LT. JCLOUD) THEN
3615	DO 2123 JKJ=JKP1,JCLOUD
3616	DO 2122 JL = 1, KDLON
3617	ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
3618	2122 CONTINUE
3619	2123 CONTINUE
3620	END IF
3621	DO 2124 JL = 1, KDLON
3622	ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
3623	2124 CONTINUE
3624	2125 CONTINUE
3625	C
3626	213 CONTINUE
3627	C
3628	C
3629	C* 2.2 CLOUD COVER MATRIX
3630	C ------------------
3631	C
3632	C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
3633	C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
3634	C
3635	220 CONTINUE
3636	C
3637	DO 223 JK1 = 1 , KFLEV+1
3638	DO 222 JK2 = 1 , KFLEV+1
3639	DO 221 JL = 1, KDLON
3640	ZCLM(JL,JK1,JK2) = 0.
3641	221 CONTINUE
3642	222 CONTINUE
3643	223 CONTINUE
3644	C
3645	C
3646	C
3647	C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION
3648	C ------------------------------------------
3649	C
3650	240 CONTINUE
3651	C
3652	DO 244 JK1 = 2 , KFLEV+1
3653	DO 241 JL = 1, KDLON
3654	ZCLEAR(JL)=1.
3655	ZCLOUD(JL)=0.
3656	241 CONTINUE
3657	DO 243 JK = JK1 - 1 , 1 , -1
3658	DO 242 JL = 1, KDLON
3659	IF (NOVLP.EQ.1) THEN
3660	c* maximum-random
3661	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
3662	* /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3663	ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3664	ZCLOUD(JL) = PCLDLU(JL,JK)
3665	ELSE IF (NOVLP.EQ.2) THEN
3666	c* maximum
3667	ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
3668	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3669	ELSE IF (NOVLP.EQ.3) THEN
3670	c* random
3671	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
3672	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3673	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3674	END IF
3675	242 CONTINUE
3676	243 CONTINUE
3677	244 CONTINUE
3678	C
3679	C
3680	C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION
3681	C ------------------------------------------
3682	C
3683	250 CONTINUE
3684	C
3685	DO 254 JK1 = 1 , KFLEV
3686	DO 251 JL = 1, KDLON
3687	ZCLEAR(JL)=1.
3688	ZCLOUD(JL)=0.
3689	251 CONTINUE
3690	DO 253 JK = JK1 , KFLEV
3691	DO 252 JL = 1, KDLON
3692	IF (NOVLP.EQ.1) THEN
3693	c* maximum-random
3694	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
3695	* /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3696	ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3697	ZCLOUD(JL) = PCLDLD(JL,JK)
3698	ELSE IF (NOVLP.EQ.2) THEN
3699	c* maximum
3700	ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
3701	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3702	ELSE IF (NOVLP.EQ.3) THEN
3703	c* random
3704	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
3705	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3706	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3707	END IF
3708	252 CONTINUE
3709	253 CONTINUE
3710	254 CONTINUE
3711	C
3712	C
3713	C
3714	C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
3715	C ----------------------------------------------
3716	C
3717	300 CONTINUE
3718	C
3719	C* 3.1 DOWNWARD FLUXES
3720	C ---------------
3721	C
3722	310 CONTINUE
3723	C
3724	DO 311 JL = 1, KDLON
3725	PFLUX(JL,2,KFLEV+1) = 0.
3726	311 CONTINUE
3727	C
3728	DO 317 JK1 = KFLEV , 1 , -1
3729	C
3730	C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3731	C
3732	DO 312 JL = 1, KDLON
3733	ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
3734	312 CONTINUE
3735	C
3736	C* CONTRIBUTION FROM ADJACENT CLOUD
3737	C
3738	DO 313 JL = 1, KDLON
3739	ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
3740	313 CONTINUE
3741	C
3742	C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3743	C
3744	DO 315 JK = KFLEV-1 , JK1 , -1
3745	DO 314 JL = 1, KDLON
3746	ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
3747	ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
3748	314 CONTINUE
3749	315 CONTINUE
3750	C
3751	DO 316 JL = 1, KDLON
3752	PFLUX(JL,2,JK1) = ZFD (JL)
3753	316 CONTINUE
3754	C
3755	317 CONTINUE
3756	C
3757	C
3758	C
3759	C
3760	C* 3.2 UPWARD FLUX AT THE SURFACE
3761	C --------------------------
3762	C
3763	320 CONTINUE
3764	C
3765	DO 321 JL = 1, KDLON
3766	PFLUX(JL,1,1) = PEMIS(JL)PBSUIN(JL)-(1.-PEMIS(JL))PFLUX(JL,2,1)
3767	321 CONTINUE
3768	C
3769	C
3770	C
3771	C* 3.3 UPWARD FLUXES
3772	C -------------
3773	C
3774	330 CONTINUE
3775	C
3776	DO 337 JK1 = 2 , KFLEV+1
3777	C
3778	C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3779	C
3780	DO 332 JL = 1, KDLON
3781	ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
3782	332 CONTINUE
3783	C
3784	C* CONTRIBUTION FROM ADJACENT CLOUD
3785	C
3786	DO 333 JL = 1, KDLON
3787	ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
3788	333 CONTINUE
3789	C
3790	C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3791	C
3792	DO 335 JK = 2 , JK1-1
3793	DO 334 JL = 1, KDLON
3794	ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
3795	ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1)
3796	334 CONTINUE
3797	335 CONTINUE
3798	C
3799	DO 336 JL = 1, KDLON
3800	PFLUX(JL,1,JK1) = ZFU (JL)
3801	336 CONTINUE
3802	C
3803	337 CONTINUE
3804	C
3805	C
3806	END IF
3807	C
3808	C
3809	C* 2.3 END OF CLOUD EFFECT COMPUTATIONS
3810	C
3811	230 CONTINUE
3812	C
3813	IF (.NOT.LEVOIGT) THEN
3814	DO 231 JL = 1, KDLON
3815	ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
3816	231 CONTINUE
3817	DO 233 JK = KLIM+1 , KFLEV+1
3818	DO 232 JL = 1, KDLON
3819	ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
3820	PFLUX(JL,1,JK) = ZFN10(JL)
3821	PFLUX(JL,2,JK) = 0.0
3822	232 CONTINUE
3823	233 CONTINUE
3824	ENDIF
3825	C
3826	RETURN
3827	END
3828	SUBROUTINE LWB(PDT0,PTAVE,PTL
3829	S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
3830	S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
3831	IMPLICIT none
3832	#include "dimensions.h"
3833	#include "dimphy.h"
3834	#include "raddim.h"
3835	#include "raddimlw.h"
3836	C
3837	C-----------------------------------------------------------------------
3838	C PURPOSE.
3839	C --------
3840	C COMPUTES PLANCK FUNCTIONS
3841	C
3842	C EXPLICIT ARGUMENTS :
3843	C --------------------
3844	C ==== INPUTS ===
3845	C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY
3846	C PTAVE : (KDLON,KFLEV) ; TEMPERATURE
3847	C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE
3848	C ==== OUTPUTS ===
3849	C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
3850	C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION
3851	C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3852	C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION
3853	C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION
3854	C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
3855	C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3856	C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3857	C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS
3858	C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS
3859	C
3860	C IMPLICIT ARGUMENTS : NONE
3861	C --------------------
3862	C
3863	C METHOD.
3864	C -------
3865	C
3866	C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
3867	C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
3868	C
3869	C REFERENCE.
3870	C ----------
3871	C
3872	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3873	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS "
3874	C
3875	C AUTHOR.
3876	C -------
3877	C JEAN-JACQUES MORCRETTE ECMWF
3878	C
3879	C MODIFICATIONS.
3880	C --------------
3881	C ORIGINAL : 89-07-14
3882	C
3883	C-----------------------------------------------------------------------
3884	C
3885	C ARGUMENTS:
3886	C
3887	REAL*8 PDT0(KDLON)
3888	REAL*8 PTAVE(KDLON,KFLEV)
3889	REAL*8 PTL(KDLON,KFLEV+1)
3890	C
3891	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
3892	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3893	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3894	REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
3895	REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
3896	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
3897	REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3898	REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3899	REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3900	REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3901	REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3902	REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3903	C
3904	C-------------------------------------------------------------------------
3905	C* LOCAL VARIABLES:
3906	INTEGER INDB(KDLON),INDS(KDLON)
3907	REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
3908	REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
3909	c
3910	INTEGER jk, jl, ic, jnu, jf, jg
3911	INTEGER jk1, jk2
3912	INTEGER k, j, ixtox, indto, ixtx, indt
3913	INTEGER indsu, indtp
3914	REAL*8 zdsto1, zdstox, zdst1, zdstx
3915	c
3916	C* Quelques parametres:
3917	REAL*8 TSTAND
3918	PARAMETER (TSTAND=250.0)
3919	REAL*8 TSTP
3920	PARAMETER (TSTP=12.5)
3921	INTEGER MXIXT
3922	PARAMETER (MXIXT=10)
3923	C
3924	C* Used Data Block:
3925	REAL*8 TINTP(11)
3926	SAVE TINTP
3927	REAL*8 GA(11,16,3), GB(11,16,3)
3928	SAVE GA, GB
3929	REAL*8 XP(6,6)
3930	SAVE XP
3931	c
3932	DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
3933	S 262.5, 275., 287.5, 300., 312.5 /
3934	C-----------------------------------------------------------------------
3935	C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
3936	C
3937	C
3938	C
3939	C
3940	C-- R.D. -- G = - 0.2 SLA
3941	C
3942	C
3943	C----- INTERVAL = 1 ----- T = 187.5
3944	C
3945	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3946	DATA (GA( 1, 1,IC),IC=1,3) /
3947	S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
3948	DATA (GB( 1, 1,IC),IC=1,3) /
3949	S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
3950	DATA (GA( 1, 2,IC),IC=1,3) /
3951	S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
3952	DATA (GB( 1, 2,IC),IC=1,3) /
3953	S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
3954	C
3955	C----- INTERVAL = 1 ----- T = 200.0
3956	C
3957	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3958	DATA (GA( 2, 1,IC),IC=1,3) /
3959	S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
3960	DATA (GB( 2, 1,IC),IC=1,3) /
3961	S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
3962	DATA (GA( 2, 2,IC),IC=1,3) /
3963	S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
3964	DATA (GB( 2, 2,IC),IC=1,3) /
3965	S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
3966	C
3967	C----- INTERVAL = 1 ----- T = 212.5
3968	C
3969	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3970	DATA (GA( 3, 1,IC),IC=1,3) /
3971	S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
3972	DATA (GB( 3, 1,IC),IC=1,3) /
3973	S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
3974	DATA (GA( 3, 2,IC),IC=1,3) /
3975	S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
3976	DATA (GB( 3, 2,IC),IC=1,3) /
3977	S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
3978	C
3979	C----- INTERVAL = 1 ----- T = 225.0
3980	C
3981	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3982	DATA (GA( 4, 1,IC),IC=1,3) /
3983	S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
3984	DATA (GB( 4, 1,IC),IC=1,3) /
3985	S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
3986	DATA (GA( 4, 2,IC),IC=1,3) /
3987	S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
3988	DATA (GB( 4, 2,IC),IC=1,3) /
3989	S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
3990	C
3991	C----- INTERVAL = 1 ----- T = 237.5
3992	C
3993	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3994	DATA (GA( 5, 1,IC),IC=1,3) /
3995	S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
3996	DATA (GB( 5, 1,IC),IC=1,3) /
3997	S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
3998	DATA (GA( 5, 2,IC),IC=1,3) /
3999	S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
4000	DATA (GB( 5, 2,IC),IC=1,3) /
4001	S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
4002	C
4003	C----- INTERVAL = 1 ----- T = 250.0
4004	C
4005	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4006	DATA (GA( 6, 1,IC),IC=1,3) /
4007	S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
4008	DATA (GB( 6, 1,IC),IC=1,3) /
4009	S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
4010	DATA (GA( 6, 2,IC),IC=1,3) /
4011	S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
4012	DATA (GB( 6, 2,IC),IC=1,3) /
4013	S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
4014	C
4015	C----- INTERVAL = 1 ----- T = 262.5
4016	C
4017	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4018	DATA (GA( 7, 1,IC),IC=1,3) /
4019	S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
4020	DATA (GB( 7, 1,IC),IC=1,3) /
4021	S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
4022	DATA (GA( 7, 2,IC),IC=1,3) /
4023	S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
4024	DATA (GB( 7, 2,IC),IC=1,3) /
4025	S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
4026	C
4027	C----- INTERVAL = 1 ----- T = 275.0
4028	C
4029	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4030	DATA (GA( 8, 1,IC),IC=1,3) /
4031	S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
4032	DATA (GB( 8, 1,IC),IC=1,3) /
4033	S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
4034	DATA (GA( 8, 2,IC),IC=1,3) /
4035	S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
4036	DATA (GB( 8, 2,IC),IC=1,3) /
4037	S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
4038	C
4039	C----- INTERVAL = 1 ----- T = 287.5
4040	C
4041	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4042	DATA (GA( 9, 1,IC),IC=1,3) /
4043	S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
4044	DATA (GB( 9, 1,IC),IC=1,3) /
4045	S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
4046	DATA (GA( 9, 2,IC),IC=1,3) /
4047	S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
4048	DATA (GB( 9, 2,IC),IC=1,3) /
4049	S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
4050	C
4051	C----- INTERVAL = 1 ----- T = 300.0
4052	C
4053	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4054	DATA (GA(10, 1,IC),IC=1,3) /
4055	S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
4056	DATA (GB(10, 1,IC),IC=1,3) /
4057	S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
4058	DATA (GA(10, 2,IC),IC=1,3) /
4059	S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
4060	DATA (GB(10, 2,IC),IC=1,3) /
4061	S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
4062	C
4063	C----- INTERVAL = 1 ----- T = 312.5
4064	C
4065	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4066	DATA (GA(11, 1,IC),IC=1,3) /
4067	S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
4068	DATA (GB(11, 1,IC),IC=1,3) /
4069	S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
4070	DATA (GA(11, 2,IC),IC=1,3) /
4071	S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
4072	DATA (GB(11, 2,IC),IC=1,3) /
4073	S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
4074	C
4075	C
4076	C
4077	C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
4078	C
4079	C
4080	C
4081	C
4082	C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U )
4083	C
4084	C
4085	C----- INTERVAL = 2 ----- T = 187.5
4086	C
4087	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4088	DATA (GA( 1, 3,IC),IC=1,3) /
4089	S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
4090	DATA (GB( 1, 3,IC),IC=1,3) /
4091	S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
4092	DATA (GA( 1, 4,IC),IC=1,3) /
4093	S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
4094	DATA (GB( 1, 4,IC),IC=1,3) /
4095	S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
4096	C
4097	C----- INTERVAL = 2 ----- T = 200.0
4098	C
4099	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4100	DATA (GA( 2, 3,IC),IC=1,3) /
4101	S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
4102	DATA (GB( 2, 3,IC),IC=1,3) /
4103	S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
4104	DATA (GA( 2, 4,IC),IC=1,3) /
4105	S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
4106	DATA (GB( 2, 4,IC),IC=1,3) /
4107	S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
4108	C
4109	C----- INTERVAL = 2 ----- T = 212.5
4110	C
4111	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4112	DATA (GA( 3, 3,IC),IC=1,3) /
4113	S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
4114	DATA (GB( 3, 3,IC),IC=1,3) /
4115	S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
4116	DATA (GA( 3, 4,IC),IC=1,3) /
4117	S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
4118	DATA (GB( 3, 4,IC),IC=1,3) /
4119	S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
4120	C
4121	C----- INTERVAL = 2 ----- T = 225.0
4122	C
4123	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4124	DATA (GA( 4, 3,IC),IC=1,3) /
4125	S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
4126	DATA (GB( 4, 3,IC),IC=1,3) /
4127	S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
4128	DATA (GA( 4, 4,IC),IC=1,3) /
4129	S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
4130	DATA (GB( 4, 4,IC),IC=1,3) /
4131	S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
4132	C
4133	C----- INTERVAL = 2 ----- T = 237.5
4134	C
4135	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4136	DATA (GA( 5, 3,IC),IC=1,3) /
4137	S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
4138	DATA (GB( 5, 3,IC),IC=1,3) /
4139	S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
4140	DATA (GA( 5, 4,IC),IC=1,3) /
4141	S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
4142	DATA (GB( 5, 4,IC),IC=1,3) /
4143	S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
4144	C
4145	C----- INTERVAL = 2 ----- T = 250.0
4146	C
4147	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4148	DATA (GA( 6, 3,IC),IC=1,3) /
4149	S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
4150	DATA (GB( 6, 3,IC),IC=1,3) /
4151	S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
4152	DATA (GA( 6, 4,IC),IC=1,3) /
4153	S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
4154	DATA (GB( 6, 4,IC),IC=1,3) /
4155	S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
4156	C
4157	C----- INTERVAL = 2 ----- T = 262.5
4158	C
4159	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4160	DATA (GA( 7, 3,IC),IC=1,3) /
4161	S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
4162	DATA (GB( 7, 3,IC),IC=1,3) /
4163	S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
4164	DATA (GA( 7, 4,IC),IC=1,3) /
4165	S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
4166	DATA (GB( 7, 4,IC),IC=1,3) /
4167	S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
4168	C
4169	C----- INTERVAL = 2 ----- T = 275.0
4170	C
4171	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4172	DATA (GA( 8, 3,IC),IC=1,3) /
4173	S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
4174	DATA (GB( 8, 3,IC),IC=1,3) /
4175	S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
4176	DATA (GA( 8, 4,IC),IC=1,3) /
4177	S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
4178	DATA (GB( 8, 4,IC),IC=1,3) /
4179	S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
4180	C
4181	C----- INTERVAL = 2 ----- T = 287.5
4182	C
4183	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4184	DATA (GA( 9, 3,IC),IC=1,3) /
4185	S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
4186	DATA (GB( 9, 3,IC),IC=1,3) /
4187	S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
4188	DATA (GA( 9, 4,IC),IC=1,3) /
4189	S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
4190	DATA (GB( 9, 4,IC),IC=1,3) /
4191	S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
4192	C
4193	C----- INTERVAL = 2 ----- T = 300.0
4194	C
4195	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4196	DATA (GA(10, 3,IC),IC=1,3) /
4197	S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
4198	DATA (GB(10, 3,IC),IC=1,3) /
4199	S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
4200	DATA (GA(10, 4,IC),IC=1,3) /
4201	S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
4202	DATA (GB(10, 4,IC),IC=1,3) /
4203	S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
4204	C
4205	C----- INTERVAL = 2 ----- T = 312.5
4206	C
4207	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4208	DATA (GA(11, 3,IC),IC=1,3) /
4209	S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
4210	DATA (GB(11, 3,IC),IC=1,3) /
4211	S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
4212	DATA (GA(11, 4,IC),IC=1,3) /
4213	S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
4214	DATA (GB(11, 4,IC),IC=1,3) /
4215	S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
4216	C
4217	C
4218	C
4219	C
4220	C
4221	C
4222	C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
4223	C
4224	C
4225	C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
4226	C
4227	C
4228	C
4229	C--- G = 3.875E-03 ---------------
4230	C
4231	C----- INTERVAL = 3 ----- T = 187.5
4232	C
4233	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4234	DATA (GA( 1, 7,IC),IC=1,3) /
4235	S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
4236	DATA (GB( 1, 7,IC),IC=1,3) /
4237	S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
4238	DATA (GA( 1, 8,IC),IC=1,3) /
4239	S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
4240	DATA (GB( 1, 8,IC),IC=1,3) /
4241	S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
4242	C
4243	C----- INTERVAL = 3 ----- T = 200.0
4244	C
4245	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4246	DATA (GA( 2, 7,IC),IC=1,3) /
4247	S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
4248	DATA (GB( 2, 7,IC),IC=1,3) /
4249	S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
4250	DATA (GA( 2, 8,IC),IC=1,3) /
4251	S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
4252	DATA (GB( 2, 8,IC),IC=1,3) /
4253	S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
4254	C
4255	C----- INTERVAL = 3 ----- T = 212.5
4256	C
4257	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4258	DATA (GA( 3, 7,IC),IC=1,3) /
4259	S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
4260	DATA (GB( 3, 7,IC),IC=1,3) /
4261	S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
4262	DATA (GA( 3, 8,IC),IC=1,3) /
4263	S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
4264	DATA (GB( 3, 8,IC),IC=1,3) /
4265	S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
4266	C
4267	C----- INTERVAL = 3 ----- T = 225.0
4268	C
4269	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4270	DATA (GA( 4, 7,IC),IC=1,3) /
4271	S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
4272	DATA (GB( 4, 7,IC),IC=1,3) /
4273	S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
4274	DATA (GA( 4, 8,IC),IC=1,3) /
4275	S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
4276	DATA (GB( 4, 8,IC),IC=1,3) /
4277	S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
4278	C
4279	C----- INTERVAL = 3 ----- T = 237.5
4280	C
4281	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4282	DATA (GA( 5, 7,IC),IC=1,3) /
4283	S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
4284	DATA (GB( 5, 7,IC),IC=1,3) /
4285	S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
4286	DATA (GA( 5, 8,IC),IC=1,3) /
4287	S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
4288	DATA (GB( 5, 8,IC),IC=1,3) /
4289	S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
4290	C
4291	C----- INTERVAL = 3 ----- T = 250.0
4292	C
4293	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4294	DATA (GA( 6, 7,IC),IC=1,3) /
4295	S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
4296	DATA (GB( 6, 7,IC),IC=1,3) /
4297	S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
4298	DATA (GA( 6, 8,IC),IC=1,3) /
4299	S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
4300	DATA (GB( 6, 8,IC),IC=1,3) /
4301	S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
4302	C
4303	C----- INTERVAL = 3 ----- T = 262.5
4304	C
4305	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4306	DATA (GA( 7, 7,IC),IC=1,3) /
4307	S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
4308	DATA (GB( 7, 7,IC),IC=1,3) /
4309	S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
4310	DATA (GA( 7, 8,IC),IC=1,3) /
4311	S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
4312	DATA (GB( 7, 8,IC),IC=1,3) /
4313	S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
4314	C
4315	C----- INTERVAL = 3 ----- T = 275.0
4316	C
4317	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4318	DATA (GA( 8, 7,IC),IC=1,3) /
4319	S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
4320	DATA (GB( 8, 7,IC),IC=1,3) /
4321	S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
4322	DATA (GA( 8, 8,IC),IC=1,3) /
4323	S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
4324	DATA (GB( 8, 8,IC),IC=1,3) /
4325	S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
4326	C
4327	C----- INTERVAL = 3 ----- T = 287.5
4328	C
4329	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4330	DATA (GA( 9, 7,IC),IC=1,3) /
4331	S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
4332	DATA (GB( 9, 7,IC),IC=1,3) /
4333	S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
4334	DATA (GA( 9, 8,IC),IC=1,3) /
4335	S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
4336	DATA (GB( 9, 8,IC),IC=1,3) /
4337	S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
4338	C
4339	C----- INTERVAL = 3 ----- T = 300.0
4340	C
4341	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4342	DATA (GA(10, 7,IC),IC=1,3) /
4343	S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
4344	DATA (GB(10, 7,IC),IC=1,3) /
4345	S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
4346	DATA (GA(10, 8,IC),IC=1,3) /
4347	S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
4348	DATA (GB(10, 8,IC),IC=1,3) /
4349	S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
4350	C
4351	C----- INTERVAL = 3 ----- T = 312.5
4352	C
4353	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4354	DATA (GA(11, 7,IC),IC=1,3) /
4355	S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
4356	DATA (GB(11, 7,IC),IC=1,3) /
4357	S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
4358	DATA (GA(11, 8,IC),IC=1,3) /
4359	S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
4360	DATA (GB(11, 8,IC),IC=1,3) /
4361	S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
4362	C
4363	C
4364	C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
4365	C
4366	C-- G = 3.6E-03
4367	C
4368	C----- INTERVAL = 4 ----- T = 187.5
4369	C
4370	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4371	DATA (GA( 1, 9,IC),IC=1,3) /
4372	S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
4373	DATA (GB( 1, 9,IC),IC=1,3) /
4374	S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
4375	DATA (GA( 1,10,IC),IC=1,3) /
4376	S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
4377	DATA (GB( 1,10,IC),IC=1,3) /
4378	S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
4379	C
4380	C----- INTERVAL = 4 ----- T = 200.0
4381	C
4382	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4383	DATA (GA( 2, 9,IC),IC=1,3) /
4384	S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
4385	DATA (GB( 2, 9,IC),IC=1,3) /
4386	S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
4387	DATA (GA( 2,10,IC),IC=1,3) /
4388	S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
4389	DATA (GB( 2,10,IC),IC=1,3) /
4390	S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
4391	C
4392	C----- INTERVAL = 4 ----- T = 212.5
4393	C
4394	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4395	DATA (GA( 3, 9,IC),IC=1,3) /
4396	S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
4397	DATA (GB( 3, 9,IC),IC=1,3) /
4398	S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
4399	DATA (GA( 3,10,IC),IC=1,3) /
4400	S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
4401	DATA (GB( 3,10,IC),IC=1,3) /
4402	S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
4403	C
4404	C----- INTERVAL = 4 ----- T = 225.0
4405	C
4406	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4407	DATA (GA( 4, 9,IC),IC=1,3) /
4408	S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
4409	DATA (GB( 4, 9,IC),IC=1,3) /
4410	S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
4411	DATA (GA( 4,10,IC),IC=1,3) /
4412	S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
4413	DATA (GB( 4,10,IC),IC=1,3) /
4414	S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
4415	C
4416	C----- INTERVAL = 4 ----- T = 237.5
4417	C
4418	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4419	DATA (GA( 5, 9,IC),IC=1,3) /
4420	S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
4421	DATA (GB( 5, 9,IC),IC=1,3) /
4422	S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
4423	DATA (GA( 5,10,IC),IC=1,3) /
4424	S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
4425	DATA (GB( 5,10,IC),IC=1,3) /
4426	S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
4427	C
4428	C----- INTERVAL = 4 ----- T = 250.0
4429	C
4430	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4431	DATA (GA( 6, 9,IC),IC=1,3) /
4432	S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
4433	DATA (GB( 6, 9,IC),IC=1,3) /
4434	S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
4435	DATA (GA( 6,10,IC),IC=1,3) /
4436	S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
4437	DATA (GB( 6,10,IC),IC=1,3) /
4438	S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
4439	C
4440	C----- INTERVAL = 4 ----- T = 262.5
4441	C
4442	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4443	DATA (GA( 7, 9,IC),IC=1,3) /
4444	S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
4445	DATA (GB( 7, 9,IC),IC=1,3) /
4446	S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
4447	DATA (GA( 7,10,IC),IC=1,3) /
4448	S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
4449	DATA (GB( 7,10,IC),IC=1,3) /
4450	S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
4451	C
4452	C----- INTERVAL = 4 ----- T = 275.0
4453	C
4454	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4455	DATA (GA( 8, 9,IC),IC=1,3) /
4456	S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
4457	DATA (GB( 8, 9,IC),IC=1,3) /
4458	S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
4459	DATA (GA( 8,10,IC),IC=1,3) /
4460	S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
4461	DATA (GB( 8,10,IC),IC=1,3) /
4462	S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
4463	C
4464	C----- INTERVAL = 4 ----- T = 287.5
4465	C
4466	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4467	DATA (GA( 9, 9,IC),IC=1,3) /
4468	S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
4469	DATA (GB( 9, 9,IC),IC=1,3) /
4470	S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
4471	DATA (GA( 9,10,IC),IC=1,3) /
4472	S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
4473	DATA (GB( 9,10,IC),IC=1,3) /
4474	S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
4475	C
4476	C----- INTERVAL = 4 ----- T = 300.0
4477	C
4478	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4479	DATA (GA(10, 9,IC),IC=1,3) /
4480	S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
4481	DATA (GB(10, 9,IC),IC=1,3) /
4482	S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
4483	DATA (GA(10,10,IC),IC=1,3) /
4484	S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
4485	DATA (GB(10,10,IC),IC=1,3) /
4486	S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
4487	C
4488	C----- INTERVAL = 4 ----- T = 312.5
4489	C
4490	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4491	DATA (GA(11, 9,IC),IC=1,3) /
4492	S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
4493	DATA (GB(11, 9,IC),IC=1,3) /
4494	S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
4495	DATA (GA(11,10,IC),IC=1,3) /
4496	S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
4497	DATA (GB(11,10,IC),IC=1,3) /
4498	S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
4499	C
4500	C
4501	C
4502	C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ----
4503	C
4504	C-- WATER VAPOR --- 350 - 500 CM-1
4505	C
4506	C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
4507	C
4508	C----- INTERVAL = 5 ----- T = 187.5
4509	C
4510	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4511	DATA (GA( 1, 5,IC),IC=1,3) /
4512	S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
4513	DATA (GB( 1, 5,IC),IC=1,3) /
4514	S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
4515	DATA (GA( 1, 6,IC),IC=1,3) /
4516	S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
4517	DATA (GB( 1, 6,IC),IC=1,3) /
4518	S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
4519	C
4520	C----- INTERVAL = 5 ----- T = 200.0
4521	C
4522	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4523	DATA (GA( 2, 5,IC),IC=1,3) /
4524	S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
4525	DATA (GB( 2, 5,IC),IC=1,3) /
4526	S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
4527	DATA (GA( 2, 6,IC),IC=1,3) /
4528	S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
4529	DATA (GB( 2, 6,IC),IC=1,3) /
4530	S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
4531	C
4532	C----- INTERVAL = 5 ----- T = 212.5
4533	C
4534	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4535	DATA (GA( 3, 5,IC),IC=1,3) /
4536	S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
4537	DATA (GB( 3, 5,IC),IC=1,3) /
4538	S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
4539	DATA (GA( 3, 6,IC),IC=1,3) /
4540	S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
4541	DATA (GB( 3, 6,IC),IC=1,3) /
4542	S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
4543	C
4544	C----- INTERVAL = 5 ----- T = 225.0
4545	C
4546	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4547	DATA (GA( 4, 5,IC),IC=1,3) /
4548	S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
4549	DATA (GB( 4, 5,IC),IC=1,3) /
4550	S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
4551	DATA (GA( 4, 6,IC),IC=1,3) /
4552	S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
4553	DATA (GB( 4, 6,IC),IC=1,3) /
4554	S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
4555	C
4556	C----- INTERVAL = 5 ----- T = 237.5
4557	C
4558	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4559	DATA (GA( 5, 5,IC),IC=1,3) /
4560	S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
4561	DATA (GB( 5, 5,IC),IC=1,3) /
4562	S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
4563	DATA (GA( 5, 6,IC),IC=1,3) /
4564	S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
4565	DATA (GB( 5, 6,IC),IC=1,3) /
4566	S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
4567	C
4568	C----- INTERVAL = 5 ----- T = 250.0
4569	C
4570	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4571	DATA (GA( 6, 5,IC),IC=1,3) /
4572	S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
4573	DATA (GB( 6, 5,IC),IC=1,3) /
4574	S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
4575	DATA (GA( 6, 6,IC),IC=1,3) /
4576	S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
4577	DATA (GB( 6, 6,IC),IC=1,3) /
4578	S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
4579	C
4580	C----- INTERVAL = 5 ----- T = 262.5
4581	C
4582	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4583	DATA (GA( 7, 5,IC),IC=1,3) /
4584	S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
4585	DATA (GB( 7, 5,IC),IC=1,3) /
4586	S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
4587	DATA (GA( 7, 6,IC),IC=1,3) /
4588	S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
4589	DATA (GB( 7, 6,IC),IC=1,3) /
4590	S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
4591	C
4592	C----- INTERVAL = 5 ----- T = 275.0
4593	C
4594	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4595	DATA (GA( 8, 5,IC),IC=1,3) /
4596	S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
4597	DATA (GB( 8, 5,IC),IC=1,3) /
4598	S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
4599	DATA (GA( 8, 6,IC),IC=1,3) /
4600	S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
4601	DATA (GB( 8, 6,IC),IC=1,3) /
4602	S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
4603	C
4604	C----- INTERVAL = 5 ----- T = 287.5
4605	C
4606	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4607	DATA (GA( 9, 5,IC),IC=1,3) /
4608	S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
4609	DATA (GB( 9, 5,IC),IC=1,3) /
4610	S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
4611	DATA (GA( 9, 6,IC),IC=1,3) /
4612	S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
4613	DATA (GB( 9, 6,IC),IC=1,3) /
4614	S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
4615	C
4616	C----- INTERVAL = 5 ----- T = 300.0
4617	C
4618	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4619	DATA (GA(10, 5,IC),IC=1,3) /
4620	S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
4621	DATA (GB(10, 5,IC),IC=1,3) /
4622	S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
4623	DATA (GA(10, 6,IC),IC=1,3) /
4624	S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
4625	DATA (GB(10, 6,IC),IC=1,3) /
4626	S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
4627	C
4628	C----- INTERVAL = 5 ----- T = 312.5
4629	C
4630	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4631	DATA (GA(11, 5,IC),IC=1,3) /
4632	S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
4633	DATA (GB(11, 5,IC),IC=1,3) /
4634	S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
4635	DATA (GA(11, 6,IC),IC=1,3) /
4636	S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
4637	DATA (GB(11, 6,IC),IC=1,3) /
4638	S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
4639	C
4640	C
4641	C
4642	C
4643	C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
4644	C--- G = 0.0
4645	C
4646	C
4647	C----- INTERVAL = 6 ----- T = 187.5
4648	C
4649	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4650	DATA (GA( 1,11,IC),IC=1,3) /
4651	S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
4652	DATA (GB( 1,11,IC),IC=1,3) /
4653	S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
4654	DATA (GA( 1,12,IC),IC=1,3) /
4655	S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
4656	DATA (GB( 1,12,IC),IC=1,3) /
4657	S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
4658	C
4659	C----- INTERVAL = 6 ----- T = 200.0
4660	C
4661	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4662	DATA (GA( 2,11,IC),IC=1,3) /
4663	S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
4664	DATA (GB( 2,11,IC),IC=1,3) /
4665	S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
4666	DATA (GA( 2,12,IC),IC=1,3) /
4667	S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
4668	DATA (GB( 2,12,IC),IC=1,3) /
4669	S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
4670	C
4671	C----- INTERVAL = 6 ----- T = 212.5
4672	C
4673	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4674	DATA (GA( 3,11,IC),IC=1,3) /
4675	S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
4676	DATA (GB( 3,11,IC),IC=1,3) /
4677	S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
4678	DATA (GA( 3,12,IC),IC=1,3) /
4679	S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
4680	DATA (GB( 3,12,IC),IC=1,3) /
4681	S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
4682	C
4683	C----- INTERVAL = 6 ----- T = 225.0
4684	C
4685	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4686	DATA (GA( 4,11,IC),IC=1,3) /
4687	S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
4688	DATA (GB( 4,11,IC),IC=1,3) /
4689	S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
4690	DATA (GA( 4,12,IC),IC=1,3) /
4691	S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
4692	DATA (GB( 4,12,IC),IC=1,3) /
4693	S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
4694	C
4695	C----- INTERVAL = 6 ----- T = 237.5
4696	C
4697	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4698	DATA (GA( 5,11,IC),IC=1,3) /
4699	S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
4700	DATA (GB( 5,11,IC),IC=1,3) /
4701	S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
4702	DATA (GA( 5,12,IC),IC=1,3) /
4703	S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
4704	DATA (GB( 5,12,IC),IC=1,3) /
4705	S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
4706	C
4707	C----- INTERVAL = 6 ----- T = 250.0
4708	C
4709	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4710	DATA (GA( 6,11,IC),IC=1,3) /
4711	S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
4712	DATA (GB( 6,11,IC),IC=1,3) /
4713	S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
4714	DATA (GA( 6,12,IC),IC=1,3) /
4715	S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
4716	DATA (GB( 6,12,IC),IC=1,3) /
4717	S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
4718	C
4719	C----- INTERVAL = 6 ----- T = 262.5
4720	C
4721	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4722	DATA (GA( 7,11,IC),IC=1,3) /
4723	S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
4724	DATA (GB( 7,11,IC),IC=1,3) /
4725	S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
4726	DATA (GA( 7,12,IC),IC=1,3) /
4727	S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
4728	DATA (GB( 7,12,IC),IC=1,3) /
4729	S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
4730	C
4731	C----- INTERVAL = 6 ----- T = 275.0
4732	C
4733	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4734	DATA (GA( 8,11,IC),IC=1,3) /
4735	S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
4736	DATA (GB( 8,11,IC),IC=1,3) /
4737	S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
4738	DATA (GA( 8,12,IC),IC=1,3) /
4739	S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
4740	DATA (GB( 8,12,IC),IC=1,3) /
4741	S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
4742	C
4743	C----- INTERVAL = 6 ----- T = 287.5
4744	C
4745	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4746	DATA (GA( 9,11,IC),IC=1,3) /
4747	S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
4748	DATA (GB( 9,11,IC),IC=1,3) /
4749	S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
4750	DATA (GA( 9,12,IC),IC=1,3) /
4751	S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
4752	DATA (GB( 9,12,IC),IC=1,3) /
4753	S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
4754	C
4755	C----- INTERVAL = 6 ----- T = 300.0
4756	C
4757	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4758	DATA (GA(10,11,IC),IC=1,3) /
4759	S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
4760	DATA (GB(10,11,IC),IC=1,3) /
4761	S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
4762	DATA (GA(10,12,IC),IC=1,3) /
4763	S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
4764	DATA (GB(10,12,IC),IC=1,3) /
4765	S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
4766	C
4767	C----- INTERVAL = 6 ----- T = 312.5
4768	C
4769	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4770	DATA (GA(11,11,IC),IC=1,3) /
4771	S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
4772	DATA (GB(11,11,IC),IC=1,3) /
4773	S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
4774	DATA (GA(11,12,IC),IC=1,3) /
4775	S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
4776	DATA (GB(11,12,IC),IC=1,3) /
4777	S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
4778	C
4779	C
4780	C
4781	C
4782	C
4783	C-- END WATER VAPOR
4784	C
4785	C
4786	C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
4787	C
4788	C
4789	C
4790	C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9
4791	C
4792	C----- INTERVAL = 2 ----- T = 187.5
4793	C
4794	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4795	DATA (GA( 1,13,IC),IC=1,3) /
4796	S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
4797	DATA (GB( 1,13,IC),IC=1,3) /
4798	S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
4799	DATA (GA( 1,14,IC),IC=1,3) /
4800	S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
4801	DATA (GB( 1,14,IC),IC=1,3) /
4802	S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
4803	C
4804	C----- INTERVAL = 2 ----- T = 200.0
4805	C
4806	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4807	DATA (GA( 2,13,IC),IC=1,3) /
4808	S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
4809	DATA (GB( 2,13,IC),IC=1,3) /
4810	S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
4811	DATA (GA( 2,14,IC),IC=1,3) /
4812	S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
4813	DATA (GB( 2,14,IC),IC=1,3) /
4814	S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
4815	C
4816	C----- INTERVAL = 2 ----- T = 212.5
4817	C
4818	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4819	DATA (GA( 3,13,IC),IC=1,3) /
4820	S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
4821	DATA (GB( 3,13,IC),IC=1,3) /
4822	S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
4823	DATA (GA( 3,14,IC),IC=1,3) /
4824	S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
4825	DATA (GB( 3,14,IC),IC=1,3) /
4826	S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
4827	C
4828	C----- INTERVAL = 2 ----- T = 225.0
4829	C
4830	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4831	DATA (GA( 4,13,IC),IC=1,3) /
4832	S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
4833	DATA (GB( 4,13,IC),IC=1,3) /
4834	S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
4835	DATA (GA( 4,14,IC),IC=1,3) /
4836	S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
4837	DATA (GB( 4,14,IC),IC=1,3) /
4838	S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
4839	C
4840	C----- INTERVAL = 2 ----- T = 237.5
4841	C
4842	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4843	DATA (GA( 5,13,IC),IC=1,3) /
4844	S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
4845	DATA (GB( 5,13,IC),IC=1,3) /
4846	S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
4847	DATA (GA( 5,14,IC),IC=1,3) /
4848	S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
4849	DATA (GB( 5,14,IC),IC=1,3) /
4850	S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
4851	C
4852	C----- INTERVAL = 2 ----- T = 250.0
4853	C
4854	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4855	DATA (GA( 6,13,IC),IC=1,3) /
4856	S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
4857	DATA (GB( 6,13,IC),IC=1,3) /
4858	S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
4859	DATA (GA( 6,14,IC),IC=1,3) /
4860	S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
4861	DATA (GB( 6,14,IC),IC=1,3) /
4862	S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
4863	C
4864	C----- INTERVAL = 2 ----- T = 262.5
4865	C
4866	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4867	DATA (GA( 7,13,IC),IC=1,3) /
4868	S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
4869	DATA (GB( 7,13,IC),IC=1,3) /
4870	S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
4871	DATA (GA( 7,14,IC),IC=1,3) /
4872	S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
4873	DATA (GB( 7,14,IC),IC=1,3) /
4874	S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
4875	C
4876	C----- INTERVAL = 2 ----- T = 275.0
4877	C
4878	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4879	DATA (GA( 8,13,IC),IC=1,3) /
4880	S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
4881	DATA (GB( 8,13,IC),IC=1,3) /
4882	S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
4883	DATA (GA( 8,14,IC),IC=1,3) /
4884	S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
4885	DATA (GB( 8,14,IC),IC=1,3) /
4886	S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
4887	C
4888	C----- INTERVAL = 2 ----- T = 287.5
4889	C
4890	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4891	DATA (GA( 9,13,IC),IC=1,3) /
4892	S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
4893	DATA (GB( 9,13,IC),IC=1,3) /
4894	S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
4895	DATA (GA( 9,14,IC),IC=1,3) /
4896	S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
4897	DATA (GB( 9,14,IC),IC=1,3) /
4898	S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
4899	C
4900	C----- INTERVAL = 2 ----- T = 300.0
4901	C
4902	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4903	DATA (GA(10,13,IC),IC=1,3) /
4904	S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
4905	DATA (GB(10,13,IC),IC=1,3) /
4906	S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
4907	DATA (GA(10,14,IC),IC=1,3) /
4908	S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
4909	DATA (GB(10,14,IC),IC=1,3) /
4910	S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
4911	C
4912	C----- INTERVAL = 2 ----- T = 312.5
4913	C
4914	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4915	DATA (GA(11,13,IC),IC=1,3) /
4916	S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
4917	DATA (GB(11,13,IC),IC=1,3) /
4918	S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
4919	DATA (GA(11,14,IC),IC=1,3) /
4920	S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
4921	DATA (GB(11,14,IC),IC=1,3) /
4922	S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
4923	C
4924	C
4925	C
4926	C
4927	C
4928	C
4929	C
4930	C
4931	C
4932	C
4933	C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
4934	C
4935	C
4936	C-- G = 0.0
4937	C
4938	C
4939	C----- INTERVAL = 4 ----- T = 187.5
4940	C
4941	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4942	DATA (GA( 1,15,IC),IC=1,3) /
4943	S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
4944	DATA (GB( 1,15,IC),IC=1,3) /
4945	S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
4946	DATA (GA( 1,16,IC),IC=1,3) /
4947	S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
4948	DATA (GB( 1,16,IC),IC=1,3) /
4949	S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
4950	C
4951	C----- INTERVAL = 4 ----- T = 200.0
4952	C
4953	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4954	DATA (GA( 2,15,IC),IC=1,3) /
4955	S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
4956	DATA (GB( 2,15,IC),IC=1,3) /
4957	S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
4958	DATA (GA( 2,16,IC),IC=1,3) /
4959	S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
4960	DATA (GB( 2,16,IC),IC=1,3) /
4961	S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
4962	C
4963	C----- INTERVAL = 4 ----- T = 212.5
4964	C
4965	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4966	DATA (GA( 3,15,IC),IC=1,3) /
4967	S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
4968	DATA (GB( 3,15,IC),IC=1,3) /
4969	S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
4970	DATA (GA( 3,16,IC),IC=1,3) /
4971	S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
4972	DATA (GB( 3,16,IC),IC=1,3) /
4973	S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
4974	C
4975	C----- INTERVAL = 4 ----- T = 225.0
4976	C
4977	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4978	DATA (GA( 4,15,IC),IC=1,3) /
4979	S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
4980	DATA (GB( 4,15,IC),IC=1,3) /
4981	S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
4982	DATA (GA( 4,16,IC),IC=1,3) /
4983	S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
4984	DATA (GB( 4,16,IC),IC=1,3) /
4985	S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
4986	C
4987	C----- INTERVAL = 4 ----- T = 237.5
4988	C
4989	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4990	DATA (GA( 5,15,IC),IC=1,3) /
4991	S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
4992	DATA (GB( 5,15,IC),IC=1,3) /
4993	S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
4994	DATA (GA( 5,16,IC),IC=1,3) /
4995	S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
4996	DATA (GB( 5,16,IC),IC=1,3) /
4997	S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
4998	C
4999	C----- INTERVAL = 4 ----- T = 250.0
5000	C
5001	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5002	DATA (GA( 6,15,IC),IC=1,3) /
5003	S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
5004	DATA (GB( 6,15,IC),IC=1,3) /
5005	S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
5006	DATA (GA( 6,16,IC),IC=1,3) /
5007	S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
5008	DATA (GB( 6,16,IC),IC=1,3) /
5009	S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
5010	C
5011	C----- INTERVAL = 4 ----- T = 262.5
5012	C
5013	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5014	DATA (GA( 7,15,IC),IC=1,3) /
5015	S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
5016	DATA (GB( 7,15,IC),IC=1,3) /
5017	S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
5018	DATA (GA( 7,16,IC),IC=1,3) /
5019	S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
5020	DATA (GB( 7,16,IC),IC=1,3) /
5021	S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
5022	C
5023	C----- INTERVAL = 4 ----- T = 275.0
5024	C
5025	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5026	DATA (GA( 8,15,IC),IC=1,3) /
5027	S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
5028	DATA (GB( 8,15,IC),IC=1,3) /
5029	S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
5030	DATA (GA( 8,16,IC),IC=1,3) /
5031	S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
5032	DATA (GB( 8,16,IC),IC=1,3) /
5033	S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
5034	C
5035	C----- INTERVAL = 4 ----- T = 287.5
5036	C
5037	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5038	DATA (GA( 9,15,IC),IC=1,3) /
5039	S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
5040	DATA (GB( 9,15,IC),IC=1,3) /
5041	S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
5042	DATA (GA( 9,16,IC),IC=1,3) /
5043	S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
5044	DATA (GB( 9,16,IC),IC=1,3) /
5045	S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
5046	C
5047	C----- INTERVAL = 4 ----- T = 300.0
5048	C
5049	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5050	DATA (GA(10,15,IC),IC=1,3) /
5051	S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
5052	DATA (GB(10,15,IC),IC=1,3) /
5053	S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
5054	DATA (GA(10,16,IC),IC=1,3) /
5055	S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
5056	DATA (GB(10,16,IC),IC=1,3) /
5057	S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
5058	C
5059	C----- INTERVAL = 4 ----- T = 312.5
5060	C
5061	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5062	DATA (GA(11,15,IC),IC=1,3) /
5063	S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
5064	DATA (GB(11,15,IC),IC=1,3) /
5065	S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
5066	DATA (GA(11,16,IC),IC=1,3) /
5067	S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
5068	DATA (GB(11,16,IC),IC=1,3) /
5069	S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
5070
5071	C ------------------------------------------------------------------
5072	DATA (( XP( J,K),J=1,6), K=1,6) /
5073	S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
5074	S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
5075	S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
5076	S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
5077	S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
5078	S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
5079	S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
5080	S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
5081	S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
5082	S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
5083	S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
5084	S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
5085	C
5086	C
5087	C* 1.0 PLANCK FUNCTIONS AND GRADIENTS
5088	C ------------------------------
5089	C
5090	100 CONTINUE
5091	C
5092	DO 102 JK = 1 , KFLEV+1
5093	DO 101 JL = 1, KDLON
5094	PBINT(JL,JK) = 0.
5095	101 CONTINUE
5096	102 CONTINUE
5097	DO 103 JL = 1, KDLON
5098	PBSUIN(JL) = 0.
5099	103 CONTINUE
5100	C
5101	DO 141 JNU=1,Ninter
5102	C
5103	C
5104	C* 1.1 LEVELS FROM SURFACE TO KFLEV
5105	C ----------------------------
5106	C
5107	110 CONTINUE
5108	C
5109	DO 112 JK = 1 , KFLEV
5110	DO 111 JL = 1, KDLON
5111	ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
5112	ZRES(JL) = XP(1,JNU)+ZTI(JL)(XP(2,JNU)+ZTI(JL)(XP(3,JNU)
5113	S +ZTI(JL)(XP(4,JNU)+ZTI(JL)(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
5114	S )))))
5115	PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
5116	PB(JL,JNU,JK)= ZRES(JL)
5117	ZBLEV(JL,JK) = ZRES(JL)
5118	ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
5119	ZRES2(JL)=XP(1,JNU)+ZTI2(JL)(XP(2,JNU)+ZTI2(JL)(XP(3,JNU)
5120	S +ZTI2(JL)(XP(4,JNU)+ZTI2(JL)(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
5121	S )))))
5122	ZBLAY(JL,JK) = ZRES2(JL)
5123	111 CONTINUE
5124	112 CONTINUE
5125	C
5126	C
5127	C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE
5128	C ---------------------------------
5129	C
5130	120 CONTINUE
5131	C
5132	DO 121 JL = 1, KDLON
5133	ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
5134	ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
5135	ZRES(JL) = XP(1,JNU)+ZTI(JL)(XP(2,JNU)+ZTI(JL)(XP(3,JNU)
5136	S +ZTI(JL)(XP(4,JNU)+ZTI(JL)(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
5137	S )))))
5138	ZRES2(JL) = XP(1,JNU)+ZTI2(JL)(XP(2,JNU)+ZTI2(JL)(XP(3,JNU)
5139	S +ZTI2(JL)(XP(4,JNU)+ZTI2(JL)(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
5140	S )))))
5141	PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
5142	PB(JL,JNU,KFLEV+1)= ZRES(JL)
5143	ZBLEV(JL,KFLEV+1) = ZRES(JL)
5144	PBTOP(JL,JNU) = ZRES(JL)
5145	PBSUR(JL,JNU) = ZRES2(JL)
5146	PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
5147	121 CONTINUE
5148	C
5149	C
5150	C* 1.3 GRADIENTS IN SUB-LAYERS
5151	C -----------------------
5152	C
5153	130 CONTINUE
5154	C
5155	DO 132 JK = 1 , KFLEV
5156	JK2 = 2 * JK
5157	JK1 = JK2 - 1
5158	DO 131 JL = 1, KDLON
5159	PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK)
5160	PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
5161	131 CONTINUE
5162	132 CONTINUE
5163	C
5164	141 CONTINUE
5165	C
5166	C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
5167	C ---------------------------------------------
5168	C
5169	200 CONTINUE
5170	C
5171	C
5172	210 CONTINUE
5173	C
5174	DO 211 JL=1, KDLON
5175	ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
5176	IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
5177	ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
5178	IF (ZDSTOX.LT.0.5) THEN
5179	INDTO=IXTOX
5180	ELSE
5181	INDTO=IXTOX+1
5182	END IF
5183	INDB(JL)=INDTO
5184	ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
5185	IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
5186	ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
5187	IF (ZDSTX.LT.0.5) THEN
5188	INDT=IXTX
5189	ELSE
5190	INDT=IXTX+1
5191	END IF
5192	INDS(JL)=INDT
5193	211 CONTINUE
5194	C
5195	DO 214 JF=1,2
5196	DO 213 JG=1, 8
5197	DO 212 JL=1, KDLON
5198	INDSU=INDS(JL)
5199	PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
5200	PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
5201	INDTP=INDB(JL)
5202	PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
5203	PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
5204	212 CONTINUE
5205	213 CONTINUE
5206	214 CONTINUE
5207	C
5208	220 CONTINUE
5209	C
5210	DO 225 JK=1,KFLEV
5211	DO 221 JL=1, KDLON
5212	ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
5213	IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
5214	ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
5215	IF (ZDSTX.LT.0.5) THEN
5216	INDT=IXTX
5217	ELSE
5218	INDT=IXTX+1
5219	END IF
5220	INDB(JL)=INDT
5221	221 CONTINUE
5222	C
5223	DO 224 JF=1,2
5224	DO 223 JG=1, 8
5225	DO 222 JL=1, KDLON
5226	INDT=INDB(JL)
5227	PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
5228	PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
5229	222 CONTINUE
5230	223 CONTINUE
5231	224 CONTINUE
5232	225 CONTINUE
5233	C
5234	C ------------------------------------------------------------------
5235	C
5236	RETURN
5237	END
5238	SUBROUTINE LWV(KUAER,KTRAER, KLIM
5239	R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
5240	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5241	S , PCNTRB,PCTS,PFLUC)
5242	IMPLICIT none
5243	#include "dimensions.h"
5244	#include "dimphy.h"
5245	#include "raddim.h"
5246	#include "raddimlw.h"
5247	#include "YOMCST.h"
5248	C
5249	C-----------------------------------------------------------------------
5250	C PURPOSE.
5251	C --------
5252	C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
5253	C FLUXES OR RADIANCES
5254	C
5255	C METHOD.
5256	C -------
5257	C
5258	C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
5259	C CONTRIBUTIONS BY - THE NEARBY LAYERS
5260	C - THE DISTANT LAYERS
5261	C - THE BOUNDARY TERMS
5262	C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
5263	C
5264	C REFERENCE.
5265	C ----------
5266	C
5267	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5268	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5269	C
5270	C AUTHOR.
5271	C -------
5272	C JEAN-JACQUES MORCRETTE ECMWF
5273	C
5274	C MODIFICATIONS.
5275	C --------------
5276	C ORIGINAL : 89-07-14
5277	C-----------------------------------------------------------------------
5278	C
5279	C* ARGUMENTS:
5280	INTEGER KUAER,KTRAER, KLIM
5281	C
5282	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
5283	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
5284	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
5285	REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
5286	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
5287	REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
5288	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
5289	REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
5290	REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
5291	REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
5292	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5293	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5294	REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
5295	REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
5296	REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
5297	REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
5298	C
5299	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
5300	REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
5301	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
5302	C-----------------------------------------------------------------------
5303	C LOCAL VARIABLES:
5304	REAL*8 ZADJD(KDLON,KFLEV+1)
5305	REAL*8 ZADJU(KDLON,KFLEV+1)
5306	REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
5307	REAL*8 ZDISD(KDLON,KFLEV+1)
5308	REAL*8 ZDISU(KDLON,KFLEV+1)
5309	C
5310	INTEGER jk, jl
5311	C-----------------------------------------------------------------------
5312	C
5313	DO 112 JK=1,KFLEV+1
5314	DO 111 JL=1, KDLON
5315	ZADJD(JL,JK)=0.
5316	ZADJU(JL,JK)=0.
5317	ZDISD(JL,JK)=0.
5318	ZDISU(JL,JK)=0.
5319	111 CONTINUE
5320	112 CONTINUE
5321	C
5322	DO 114 JK=1,KFLEV
5323	DO 113 JL=1, KDLON
5324	PCTS(JL,JK)=0.
5325	113 CONTINUE
5326	114 CONTINUE
5327	C
5328	C* CONTRIBUTION FROM ADJACENT LAYERS
5329	C
5330	CALL LWVN(KUAER,KTRAER
5331	R , PABCU,PDBSL,PGA,PGB
5332	S , ZADJD,ZADJU,PCNTRB,ZDBDT)
5333	C* CONTRIBUTION FROM DISTANT LAYERS
5334	C
5335	CALL LWVD(KUAER,KTRAER
5336	R , PABCU,ZDBDT,PGA,PGB
5337	S , PCNTRB,ZDISD,ZDISU)
5338	C
5339	C* EXCHANGE WITH THE BOUNDARIES
5340	C
5341	CALL LWVB(KUAER,KTRAER, KLIM
5342	R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
5343	R , ZDISD,ZDISU,PEMIS,PPMB
5344	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5345	S , PCTS,PFLUC)
5346	C
5347	C
5348	RETURN
5349	END
5350	SUBROUTINE LWVB(KUAER,KTRAER, KLIM
5351	R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
5352	R , PDISD,PDISU,PEMIS,PPMB
5353	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5354	S , PCTS,PFLUC)
5355	IMPLICIT none
5356	#include "dimensions.h"
5357	#include "dimphy.h"
5358	#include "raddim.h"
5359	#include "raddimlw.h"
5360	#include "radopt.h"
5361	C
5362	C-----------------------------------------------------------------------
5363	C PURPOSE.
5364	C --------
5365	C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
5366	C INTEGRATION
5367	C
5368	C METHOD.
5369	C -------
5370	C
5371	C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
5372	C ATMOSPHERE
5373	C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
5374	C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
5375	C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
5376	C
5377	C REFERENCE.
5378	C ----------
5379	C
5380	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5381	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5382	C
5383	C AUTHOR.
5384	C -------
5385	C JEAN-JACQUES MORCRETTE ECMWF
5386	C
5387	C MODIFICATIONS.
5388	C --------------
5389	C ORIGINAL : 89-07-14
5390	C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96
5391	C-----------------------------------------------------------------------
5392	C
5393	C* 0.1 ARGUMENTS
5394	C ---------
5395	C
5396	INTEGER KUAER,KTRAER, KLIM
5397	C
5398	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5399	REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5400	REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5401	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
5402	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
5403	REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
5404	REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
5405	REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
5406	REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5407	REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5408	REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
5409	REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
5410	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5411	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5412	REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5413	REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5414	REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5415	REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5416	C
5417	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
5418	REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
5419	C
5420	C* LOCAL VARIABLES:
5421	C
5422	REAL*8 ZBGND(KDLON)
5423	REAL*8 ZFD(KDLON)
5424	REAL*8 ZFN10(KDLON)
5425	REAL*8 ZFU(KDLON)
5426	REAL*8 ZTT(KDLON,NTRA)
5427	REAL*8 ZTT1(KDLON,NTRA)
5428	REAL*8 ZTT2(KDLON,NTRA)
5429	REAL*8 ZUU(KDLON,NUA)
5430	REAL*8 ZCNSOL(KDLON)
5431	REAL*8 ZCNTOP(KDLON)
5432	C
5433	INTEGER jk, jl, ja
5434	INTEGER jstra, jstru
5435	INTEGER ind1, ind2, ind3, ind4, in, jlim
5436	REAL*8 zctstr
5437	C-----------------------------------------------------------------------
5438	C
5439	C* 1. INITIALIZATION
5440	C --------------
5441	C
5442	100 CONTINUE
5443	C
5444	C
5445	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5446	C ---------------------------------
5447	C
5448	120 CONTINUE
5449	C
5450	DO 122 JA=1,NTRA
5451	DO 121 JL=1, KDLON
5452	ZTT (JL,JA)=1.0
5453	ZTT1(JL,JA)=1.0
5454	ZTT2(JL,JA)=1.0
5455	121 CONTINUE
5456	122 CONTINUE
5457	C
5458	DO 124 JA=1,NUA
5459	DO 123 JL=1, KDLON
5460	ZUU(JL,JA)=1.0
5461	123 CONTINUE
5462	124 CONTINUE
5463	C
5464	C ------------------------------------------------------------------
5465	C
5466	C* 2. VERTICAL INTEGRATION
5467	C --------------------
5468	C
5469	200 CONTINUE
5470	C
5471	IND1=0
5472	IND3=0
5473	IND4=1
5474	IND2=1
5475	C
5476	C
5477	C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE
5478	C -----------------------------------
5479	C
5480	230 CONTINUE
5481	C
5482	DO 235 JK = 1 , KFLEV
5483	IN=(JK-1)*NG1P1+1
5484	C
5485	DO 232 JA=1,KUAER
5486	DO 231 JL=1, KDLON
5487	ZUU(JL,JA)=PABCU(JL,JA,IN)
5488	231 CONTINUE
5489	232 CONTINUE
5490	C
5491	C
5492	CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
5493	C
5494	DO 234 JL = 1, KDLON
5495	ZCNTOP(JL)=PBTOP(JL,1)ZTT(JL,1) ZTT(JL,10)
5496	2 +PBTOP(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5497	3 +PBTOP(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5498	4 +PBTOP(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5499	5 +PBTOP(JL,5)ZTT(JL,3) ZTT(JL,14)
5500	6 +PBTOP(JL,6)ZTT(JL,6) ZTT(JL,15)
5501	ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5502	PFLUC(JL,2,JK)=ZFD(JL)
5503	234 CONTINUE
5504	C
5505	235 CONTINUE
5506	C
5507	JK = KFLEV+1
5508	IN=(JK-1)*NG1P1+1
5509	C
5510	DO 236 JL = 1, KDLON
5511	ZCNTOP(JL)= PBTOP(JL,1)
5512	1 + PBTOP(JL,2)
5513	2 + PBTOP(JL,3)
5514	3 + PBTOP(JL,4)
5515	4 + PBTOP(JL,5)
5516	5 + PBTOP(JL,6)
5517	ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5518	PFLUC(JL,2,JK)=ZFD(JL)
5519	236 CONTINUE
5520	C
5521	C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
5522	C ---------------------------------------
5523	C
5524	240 CONTINUE
5525	C
5526	C
5527	C* 2.4.1 INITIALIZATION
5528	C --------------
5529	C
5530	2410 CONTINUE
5531	C
5532	JLIM = KFLEV
5533	C
5534	IF (.NOT.LEVOIGT) THEN
5535	DO 2412 JK = KFLEV,1,-1
5536	IF(PPMB(1,JK).LT.10.0) THEN
5537	JLIM=JK
5538	ENDIF
5539	2412 CONTINUE
5540	ENDIF
5541	KLIM=JLIM
5542	C
5543	IF (.NOT.LEVOIGT) THEN
5544	DO 2414 JA=1,KTRAER
5545	DO 2413 JL=1, KDLON
5546	ZTT1(JL,JA)=1.0
5547	2413 CONTINUE
5548	2414 CONTINUE
5549	C
5550	C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA
5551	C -----------------------------
5552	C
5553	2420 CONTINUE
5554	C
5555	DO 2427 JSTRA = KFLEV,JLIM,-1
5556	JSTRU=(JSTRA-1)*NG1P1+1
5557	C
5558	DO 2423 JA=1,KUAER
5559	DO 2422 JL=1, KDLON
5560	ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
5561	2422 CONTINUE
5562	2423 CONTINUE
5563	C
5564	C
5565	CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
5566	C
5567	DO 2424 JL = 1, KDLON
5568	ZCTSTR =
5569	1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
5570	1 (ZTT1(JL,1) ZTT1(JL,10)
5571	1 - ZTT (JL,1) *ZTT (JL,10))
5572	2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
5573	2 (ZTT1(JL,2)ZTT1(JL,7)*ZTT1(JL,11)
5574	2 - ZTT (JL,2)ZTT (JL,7)ZTT (JL,11))
5575	3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
5576	3 (ZTT1(JL,4)ZTT1(JL,8)*ZTT1(JL,12)
5577	3 - ZTT (JL,4)ZTT (JL,8)ZTT (JL,12))
5578	4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
5579	4 (ZTT1(JL,5)ZTT1(JL,9)*ZTT1(JL,13)
5580	4 - ZTT (JL,5)ZTT (JL,9)ZTT (JL,13))
5581	5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
5582	5 (ZTT1(JL,3) ZTT1(JL,14)
5583	5 - ZTT (JL,3) *ZTT (JL,14))
5584	6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
5585	6 (ZTT1(JL,6) ZTT1(JL,15)
5586	6 - ZTT (JL,6) *ZTT (JL,15))
5587	PCTS(JL,JSTRA)=ZCTSTR*0.5
5588	2424 CONTINUE
5589	DO 2426 JA=1,KTRAER
5590	DO 2425 JL=1, KDLON
5591	ZTT1(JL,JA)=ZTT(JL,JA)
5592	2425 CONTINUE
5593	2426 CONTINUE
5594	2427 CONTINUE
5595	ENDIF
5596	C Mise a zero de securite pour PCTS en cas de LEVOIGT
5597	IF(LEVOIGT)THEN
5598	DO 2429 JSTRA = 1,KFLEV
5599	DO 2428 JL = 1, KDLON
5600	PCTS(JL,JSTRA)=0.
5601	2428 CONTINUE
5602	2429 CONTINUE
5603	ENDIF
5604	C
5605	C
5606	C* 2.5 EXCHANGE WITH LOWER LIMIT
5607	C -------------------------
5608	C
5609	250 CONTINUE
5610	C
5611	DO 251 JL = 1, KDLON
5612	ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
5613	S *PFLUC(JL,2,1)-PBINT(JL,1)
5614	251 CONTINUE
5615	C
5616	JK = 1
5617	IN=(JK-1)*NG1P1+1
5618	C
5619	DO 252 JL = 1, KDLON
5620	ZCNSOL(JL)=PBSUR(JL,1)
5621	1 +PBSUR(JL,2)
5622	2 +PBSUR(JL,3)
5623	3 +PBSUR(JL,4)
5624	4 +PBSUR(JL,5)
5625	5 +PBSUR(JL,6)
5626	ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5627	ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5628	PFLUC(JL,1,JK)=ZFU(JL)
5629	252 CONTINUE
5630	C
5631	DO 257 JK = 2 , KFLEV+1
5632	IN=(JK-1)*NG1P1+1
5633	C
5634	C
5635	DO 255 JA=1,KUAER
5636	DO 254 JL=1, KDLON
5637	ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
5638	254 CONTINUE
5639	255 CONTINUE
5640	C
5641	C
5642	CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
5643	C
5644	DO 256 JL = 1, KDLON
5645	ZCNSOL(JL)=PBSUR(JL,1)ZTT(JL,1) ZTT(JL,10)
5646	2 +PBSUR(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5647	3 +PBSUR(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5648	4 +PBSUR(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5649	5 +PBSUR(JL,5)ZTT(JL,3) ZTT(JL,14)
5650	6 +PBSUR(JL,6)ZTT(JL,6) ZTT(JL,15)
5651	ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5652	ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5653	PFLUC(JL,1,JK)=ZFU(JL)
5654	256 CONTINUE
5655	C
5656	C
5657	257 CONTINUE
5658	C
5659	C
5660	C
5661	C* 2.7 CLEAR-SKY FLUXES
5662	C ----------------
5663	C
5664	270 CONTINUE
5665	C
5666	IF (.NOT.LEVOIGT) THEN
5667	DO 271 JL = 1, KDLON
5668	ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
5669	271 CONTINUE
5670	DO 273 JK = JLIM+1,KFLEV+1
5671	DO 272 JL = 1, KDLON
5672	ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
5673	PFLUC(JL,1,JK) = ZFN10(JL)
5674	PFLUC(JL,2,JK) = 0.
5675	272 CONTINUE
5676	273 CONTINUE
5677	ENDIF
5678	C
5679	C ------------------------------------------------------------------
5680	C
5681	RETURN
5682	END
5683	SUBROUTINE LWVD(KUAER,KTRAER
5684	S , PABCU,PDBDT
5685	R , PGA,PGB
5686	S , PCNTRB,PDISD,PDISU)
5687	IMPLICIT none
5688	#include "dimensions.h"
5689	#include "dimphy.h"
5690	#include "raddim.h"
5691	#include "raddimlw.h"
5692	C
5693	C-----------------------------------------------------------------------
5694	C PURPOSE.
5695	C --------
5696	C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
5697	C
5698	C METHOD.
5699	C -------
5700	C
5701	C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5702	C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
5703	C
5704	C REFERENCE.
5705	C ----------
5706	C
5707	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5708	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5709	C
5710	C AUTHOR.
5711	C -------
5712	C JEAN-JACQUES MORCRETTE ECMWF
5713	C
5714	C MODIFICATIONS.
5715	C --------------
5716	C ORIGINAL : 89-07-14
5717	C-----------------------------------------------------------------------
5718	C* ARGUMENTS:
5719	C
5720	INTEGER KUAER,KTRAER
5721	C
5722	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5723	REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5724	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5725	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5726	C
5727	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
5728	REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5729	REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5730	C
5731	C* LOCAL VARIABLES:
5732	C
5733	REAL*8 ZGLAYD(KDLON)
5734	REAL*8 ZGLAYU(KDLON)
5735	REAL*8 ZTT(KDLON,NTRA)
5736	REAL*8 ZTT1(KDLON,NTRA)
5737	REAL*8 ZTT2(KDLON,NTRA)
5738	C
5739	INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
5740	INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
5741	INTEGER ind1, ind2, ind3, ind4, itt
5742	REAL*8 zww, zdzxdg, zdzxmg
5743	C
5744	C* 1. INITIALIZATION
5745	C --------------
5746	C
5747	100 CONTINUE
5748	C
5749	C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
5750	C ------------------------------
5751	C
5752	110 CONTINUE
5753	C
5754	DO 112 JK = 1, KFLEV+1
5755	DO 111 JL = 1, KDLON
5756	PDISD(JL,JK) = 0.
5757	PDISU(JL,JK) = 0.
5758	111 CONTINUE
5759	112 CONTINUE
5760	C
5761	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5762	C ---------------------------------
5763	C
5764	120 CONTINUE
5765	C
5766	C
5767	DO 122 JA = 1, NTRA
5768	DO 121 JL = 1, KDLON
5769	ZTT (JL,JA) = 1.0
5770	ZTT1(JL,JA) = 1.0
5771	ZTT2(JL,JA) = 1.0
5772	121 CONTINUE
5773	122 CONTINUE
5774	C
5775	C ------------------------------------------------------------------
5776	C
5777	C* 2. VERTICAL INTEGRATION
5778	C --------------------
5779	C
5780	200 CONTINUE
5781	C
5782	IND1=0
5783	IND3=0
5784	IND4=1
5785	IND2=1
5786	C
5787	C
5788	C* 2.2 CONTRIBUTION FROM DISTANT LAYERS
5789	C ---------------------------------
5790	C
5791	220 CONTINUE
5792	C
5793	C
5794	C* 2.2.1 DISTANT AND ABOVE LAYERS
5795	C ------------------------
5796	C
5797	2210 CONTINUE
5798	C
5799	C
5800	C
5801	C* 2.2.2 FIRST UPPER LEVEL
5802	C -----------------
5803	C
5804	2220 CONTINUE
5805	C
5806	DO 225 JK = 1 , KFLEV-1
5807	IKP1=JK+1
5808	IKN=(JK-1)*NG1P1+1
5809	IKD1= JK *NG1P1+1
5810	C
5811	CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
5812	2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
5813	C
5814	C
5815	C
5816	C* 2.2.3 HIGHER UP
5817	C ---------
5818	C
5819	2230 CONTINUE
5820	C
5821	ITT=1
5822	DO 224 JKJ=IKP1,KFLEV
5823	IF(ITT.EQ.1) THEN
5824	ITT=2
5825	ELSE
5826	ITT=1
5827	ENDIF
5828	IKJP1=JKJ+1
5829	IKD2= JKJ *NG1P1+1
5830	C
5831	IF(ITT.EQ.1) THEN
5832	CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5833	2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
5834	ELSE
5835	CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5836	2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
5837	ENDIF
5838	C
5839	DO 2235 JA = 1, KTRAER
5840	DO 2234 JL = 1, KDLON
5841	ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5842	2234 CONTINUE
5843	2235 CONTINUE
5844	C
5845	DO 2236 JL = 1, KDLON
5846	ZWW=PDBDT(JL,1,JKJ)ZTT(JL,1) ZTT(JL,10)
5847	S +PDBDT(JL,2,JKJ)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5848	S +PDBDT(JL,3,JKJ)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5849	S +PDBDT(JL,4,JKJ)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5850	S +PDBDT(JL,5,JKJ)ZTT(JL,3) ZTT(JL,14)
5851	S +PDBDT(JL,6,JKJ)ZTT(JL,6) ZTT(JL,15)
5852	ZGLAYD(JL)=ZWW
5853	ZDZXDG=ZGLAYD(JL)
5854	PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
5855	PCNTRB(JL,JK,IKJP1)=ZDZXDG
5856	2236 CONTINUE
5857	C
5858	C
5859	224 CONTINUE
5860	225 CONTINUE
5861	C
5862	C
5863	C* 2.2.4 DISTANT AND BELOW LAYERS
5864	C ------------------------
5865	C
5866	2240 CONTINUE
5867	C
5868	C
5869	C
5870	C* 2.2.5 FIRST LOWER LEVEL
5871	C -----------------
5872	C
5873	2250 CONTINUE
5874	C
5875	DO 228 JK=3,KFLEV+1
5876	IKN=(JK-1)*NG1P1+1
5877	IKM1=JK-1
5878	IKJ=JK-2
5879	IKU1= IKJ *NG1P1+1
5880	C
5881	C
5882	CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
5883	2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
5884	C
5885	C
5886	C
5887	C* 2.2.6 DOWN BELOW
5888	C ----------
5889	C
5890	2260 CONTINUE
5891	C
5892	ITT=1
5893	DO 227 JLK=1,IKJ
5894	IF(ITT.EQ.1) THEN
5895	ITT=2
5896	ELSE
5897	ITT=1
5898	ENDIF
5899	IJKL=IKM1-JLK
5900	IKU2=(IJKL-1)*NG1P1+1
5901	C
5902	C
5903	IF(ITT.EQ.1) THEN
5904	CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5905	2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
5906	ELSE
5907	CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5908	2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
5909	ENDIF
5910	C
5911	DO 2265 JA = 1, KTRAER
5912	DO 2264 JL = 1, KDLON
5913	ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5914	2264 CONTINUE
5915	2265 CONTINUE
5916	C
5917	DO 2266 JL = 1, KDLON
5918	ZWW=PDBDT(JL,1,IJKL)ZTT(JL,1) ZTT(JL,10)
5919	S +PDBDT(JL,2,IJKL)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5920	S +PDBDT(JL,3,IJKL)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5921	S +PDBDT(JL,4,IJKL)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5922	S +PDBDT(JL,5,IJKL)ZTT(JL,3) ZTT(JL,14)
5923	S +PDBDT(JL,6,IJKL)ZTT(JL,6) ZTT(JL,15)
5924	ZGLAYU(JL)=ZWW
5925	ZDZXMG=ZGLAYU(JL)
5926	PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
5927	PCNTRB(JL,JK,IJKL)=ZDZXMG
5928	2266 CONTINUE
5929	C
5930	C
5931	227 CONTINUE
5932	228 CONTINUE
5933	C
5934	RETURN
5935	END
5936	SUBROUTINE LWVN(KUAER,KTRAER
5937	R , PABCU,PDBSL,PGA,PGB
5938	S , PADJD,PADJU,PCNTRB,PDBDT)
5939	IMPLICIT none
5940	#include "dimensions.h"
5941	#include "dimphy.h"
5942	#include "raddim.h"
5943	#include "raddimlw.h"
5944	C
5945	C-----------------------------------------------------------------------
5946	C PURPOSE.
5947	C --------
5948	C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
5949	C TO GIVE LONGWAVE FLUXES OR RADIANCES
5950	C
5951	C METHOD.
5952	C -------
5953	C
5954	C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5955	C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
5956	C
5957	C REFERENCE.
5958	C ----------
5959	C
5960	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5961	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5962	C
5963	C AUTHOR.
5964	C -------
5965	C JEAN-JACQUES MORCRETTE ECMWF
5966	C
5967	C MODIFICATIONS.
5968	C --------------
5969	C ORIGINAL : 89-07-14
5970	C-----------------------------------------------------------------------
5971	C
5972	C* ARGUMENTS:
5973	C
5974	INTEGER KUAER,KTRAER
5975	C
5976	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5977	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
5978	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5979	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5980	C
5981	REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5982	REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5983	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
5984	REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5985	C
5986	C* LOCAL ARRAYS:
5987	C
5988	REAL*8 ZGLAYD(KDLON)
5989	REAL*8 ZGLAYU(KDLON)
5990	REAL*8 ZTT(KDLON,NTRA)
5991	REAL*8 ZTT1(KDLON,NTRA)
5992	REAL*8 ZTT2(KDLON,NTRA)
5993	REAL*8 ZUU(KDLON,NUA)
5994	C
5995	INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
5996	INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
5997	REAL*8 zwtr
5998	c
5999	C* Data Block:
6000	c
6001	REAL*8 WG1(2)
6002	SAVE WG1
6003	DATA (WG1(jk),jk=1,2) /1.0, 1.0/
6004	C-----------------------------------------------------------------------
6005	C
6006	C* 1. INITIALIZATION
6007	C --------------
6008	C
6009	100 CONTINUE
6010	C
6011	C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
6012	C ------------------------------
6013	C
6014	110 CONTINUE
6015	C
6016	DO 112 JK = 1 , KFLEV+1
6017	DO 111 JL = 1, KDLON
6018	PADJD(JL,JK) = 0.
6019	PADJU(JL,JK) = 0.
6020	111 CONTINUE
6021	112 CONTINUE
6022	C
6023	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
6024	C ---------------------------------
6025	C
6026	120 CONTINUE
6027	C
6028	DO 122 JA = 1 , NTRA
6029	DO 121 JL = 1, KDLON
6030	ZTT (JL,JA) = 1.0
6031	ZTT1(JL,JA) = 1.0
6032	ZTT2(JL,JA) = 1.0
6033	121 CONTINUE
6034	122 CONTINUE
6035	C
6036	DO 124 JA = 1 , NUA
6037	DO 123 JL = 1, KDLON
6038	ZUU(JL,JA) = 0.
6039	123 CONTINUE
6040	124 CONTINUE
6041	C
6042	C ------------------------------------------------------------------
6043	C
6044	C* 2. VERTICAL INTEGRATION
6045	C --------------------
6046	C
6047	200 CONTINUE
6048	C
6049	C
6050	C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS
6051	C ---------------------------------
6052	C
6053	210 CONTINUE
6054	C
6055	DO 215 JK = 1 , KFLEV
6056	C
6057	C* 2.1.1 DOWNWARD LAYERS
6058	C ---------------
6059	C
6060	2110 CONTINUE
6061	C
6062	IM12 = 2 * (JK - 1)
6063	IND = (JK - 1) * NG1P1 + 1
6064	IXD = IND
6065	INU = JK * NG1P1 + 1
6066	IXU = IND
6067	C
6068	DO 2111 JL = 1, KDLON
6069	ZGLAYD(JL) = 0.
6070	ZGLAYU(JL) = 0.
6071	2111 CONTINUE
6072	C
6073	DO 213 JG = 1 , NG1
6074	IBS = IM12 + JG
6075	IDD = IXD + JG
6076	DO 2113 JA = 1 , KUAER
6077	DO 2112 JL = 1, KDLON
6078	ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
6079	2112 CONTINUE
6080	2113 CONTINUE
6081	C
6082	C
6083	CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
6084	C
6085	DO 2114 JL = 1, KDLON
6086	ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
6087	S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
6088	S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
6089	S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
6090	S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
6091	S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
6092	ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
6093	2114 CONTINUE
6094	C
6095	C* 2.1.2 DOWNWARD LAYERS
6096	C ---------------
6097	C
6098	2120 CONTINUE
6099	C
6100	IMU = IXU + JG
6101	DO 2122 JA = 1 , KUAER
6102	DO 2121 JL = 1, KDLON
6103	ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
6104	2121 CONTINUE
6105	2122 CONTINUE
6106	C
6107	C
6108	CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
6109	C
6110	DO 2123 JL = 1, KDLON
6111	ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
6112	S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
6113	S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
6114	S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
6115	S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
6116	S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
6117	ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
6118	2123 CONTINUE
6119	C
6120	213 CONTINUE
6121	C
6122	DO 214 JL = 1, KDLON
6123	PADJD(JL,JK) = ZGLAYD(JL)
6124	PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
6125	PADJU(JL,JK+1) = ZGLAYU(JL)
6126	PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
6127	PCNTRB(JL,JK ,JK) = 0.0
6128	214 CONTINUE
6129	C
6130	215 CONTINUE
6131	C
6132	DO 218 JK = 1 , KFLEV
6133	JK2 = 2 * JK
6134	JK1 = JK2 - 1
6135	DO 217 JNU = 1 , Ninter
6136	DO 216 JL = 1, KDLON
6137	PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
6138	216 CONTINUE
6139	217 CONTINUE
6140	218 CONTINUE
6141	C
6142	RETURN
6143	C
6144	END
6145	SUBROUTINE LWTT(PGA,PGB,PUU, PTT)
6146	IMPLICIT none
6147	#include "dimensions.h"
6148	#include "dimphy.h"
6149	#include "raddim.h"
6150	#include "raddimlw.h"
6151	C
6152	C-----------------------------------------------------------------------
6153	C PURPOSE.
6154	C --------
6155	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
6156	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
6157	C INTERVALS.
6158	C
6159	C METHOD.
6160	C -------
6161	C
6162	C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
6163	C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
6164	C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
6165	C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
6166	C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
6167	C
6168	C REFERENCE.
6169	C ----------
6170	C
6171	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
6172	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
6173	C
6174	C AUTHOR.
6175	C -------
6176	C JEAN-JACQUES MORCRETTE ECMWF
6177	C
6178	C MODIFICATIONS.
6179	C --------------
6180	C ORIGINAL : 88-12-15
6181	C
6182	C-----------------------------------------------------------------------
6183	REAL*8 O1H, O2H
6184	PARAMETER (O1H=2230.)
6185	PARAMETER (O2H=100.)
6186	REAL*8 RPIALF0
6187	PARAMETER (RPIALF0=2.0)
6188	C
6189	C* ARGUMENTS:
6190	C
6191	REAL*8 PUU(KDLON,NUA)
6192	REAL*8 PTT(KDLON,NTRA)
6193	REAL*8 PGA(KDLON,8,2)
6194	REAL*8 PGB(KDLON,8,2)
6195	C
6196	C* LOCAL VARIABLES:
6197	C
6198	REAL*8 zz, zxd, zxn
6199	REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
6200	REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
6201	REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
6202	REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
6203	REAL*8 zsqn21, zodn21, zsqh42, zodh42
6204	REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
6205	REAL*8 zuu11, zuu12, za11, za12
6206	INTEGER jl, ja
6207	C ------------------------------------------------------------------
6208	C
6209	C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
6210	C -----------------------------------------------
6211	C
6212	100 CONTINUE
6213	C
6214	C
6215	DO 130 JA = 1 , 8
6216	DO 120 JL = 1, KDLON
6217	ZZ =SQRT(PUU(JL,JA))
6218	c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
6219	c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
6220	c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
6221	ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
6222	ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
6223	PTT(JL,JA)=ZXN /ZXD
6224	120 CONTINUE
6225	130 CONTINUE
6226	C
6227	C ------------------------------------------------------------------
6228	C
6229	C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
6230	C ---------------------------------------------------
6231	C
6232	200 CONTINUE
6233	C
6234	DO 201 JL = 1, KDLON
6235	PTT(JL, 9) = PTT(JL, 8)
6236	C
6237	C- CONTINUUM ABSORPTION: E- AND P-TYPE
6238	C
6239	ZPU = 0.002 * PUU(JL,10)
6240	ZPU10 = 112. * ZPU
6241	ZPU11 = 6.25 * ZPU
6242	ZPU12 = 5.00 * ZPU
6243	ZPU13 = 80.0 * ZPU
6244	ZEU = PUU(JL,11)
6245	ZEU10 = 12. * ZEU
6246	ZEU11 = 6.25 * ZEU
6247	ZEU12 = 5.00 * ZEU
6248	ZEU13 = 80.0 * ZEU
6249	C
6250	C- OZONE ABSORPTION
6251	C
6252	ZX = PUU(JL,12)
6253	ZY = PUU(JL,13)
6254	ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
6255	ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
6256	ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
6257	ZVXY = RPIALF0 * ZY / (2. * ZX)
6258	ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
6259	ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
6260	ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
6261	C
6262	C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
6263	C
6264	C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
6265	C
6266	c NEXOTIC=1
6267	c IF (NEXOTIC.EQ.1) THEN
6268	ZXCH4 = PUU(JL,19)
6269	ZYCH4 = PUU(JL,20)
6270	ZUXY = 4. * ZXCH4ZXCH4/(0.103ZYCH4)
6271	ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
6272	ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
6273	ZODH41 = ZVXY * ZSQH41
6274	C
6275	C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
6276	C
6277	ZXN2O = PUU(JL,21)
6278	ZYN2O = PUU(JL,22)
6279	ZUXY = 4. * ZXN2OZXN2O/(0.416ZYN2O)
6280	ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
6281	ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
6282	ZODN21 = ZVXY * ZSQN21
6283	C
6284	C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
6285	C
6286	ZUXY = 4. * ZXCH4ZXCH4/(0.113ZYCH4)
6287	ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
6288	ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
6289	ZODH42 = ZVXY * ZSQH42
6290	C
6291	C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
6292	C
6293	ZUXY = 4. * ZXN2OZXN2O/(0.197ZYN2O)
6294	ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
6295	ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
6296	ZODN22 = ZVXY * ZSQN22
6297	C
6298	C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
6299	C
6300	ZA11 = 2. * PUU(JL,23) * 4.404E+05
6301	ZTTF11 = 1. - ZA11 * 0.003225
6302	C
6303	C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
6304	C
6305	ZA12 = 2. * PUU(JL,24) * 6.7435E+05
6306	ZTTF12 = 1. - ZA12 * 0.003225
6307	C
6308	ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
6309	ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
6310	PTT(JL,10) = EXP( - PUU(JL,14) )
6311	PTT(JL,11) = EXP( ZUU11 )
6312	PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
6313	PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
6314	PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
6315	PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
6316	201 CONTINUE
6317	C
6318	RETURN
6319	END
6320	SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)
6321	IMPLICIT none
6322	#include "dimensions.h"
6323	#include "dimphy.h"
6324	#include "raddim.h"
6325	#include "raddimlw.h"
6326	C
6327	C ------------------------------------------------------------------
6328	C PURPOSE.
6329	C --------
6330	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
6331	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
6332	C INTERVALS.
6333	C
6334	C METHOD.
6335	C -------
6336	C
6337	C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
6338	C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
6339	C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
6340	C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
6341	C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
6342	C
6343	C REFERENCE.
6344	C ----------
6345	C
6346	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
6347	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
6348	C
6349	C AUTHOR.
6350	C -------
6351	C JEAN-JACQUES MORCRETTE ECMWF
6352	C
6353	C MODIFICATIONS.
6354	C --------------
6355	C ORIGINAL : 88-12-15
6356	C
6357	C-----------------------------------------------------------------------
6358	REAL*8 O1H, O2H
6359	PARAMETER (O1H=2230.)
6360	PARAMETER (O2H=100.)
6361	REAL*8 RPIALF0
6362	PARAMETER (RPIALF0=2.0)
6363	C
6364	C* ARGUMENTS:
6365	C
6366	REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
6367	REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
6368	REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
6369	REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
6370	REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
6371	C
6372	C* LOCAL VARIABLES:
6373	C
6374	INTEGER ja, jl
6375	REAL*8 zz, zxd, zxn
6376	REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
6377	REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
6378	REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
6379	REAL*8 zxch4, zych4, zsqh41, zodh41
6380	REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
6381	REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
6382	REAL*8 zuu11, zuu12
6383	C ------------------------------------------------------------------
6384	C
6385	C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
6386	C -----------------------------------------------
6387	C
6388	100 CONTINUE
6389	C
6390	C
6391	DO 130 JA = 1 , 8
6392	DO 120 JL = 1, KDLON
6393	ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
6394	ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
6395	ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
6396	PTT(JL,JA)=ZXN /ZXD
6397	120 CONTINUE
6398	130 CONTINUE
6399	C
6400	C ------------------------------------------------------------------
6401	C
6402	C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
6403	C ---------------------------------------------------
6404	C
6405	200 CONTINUE
6406	C
6407	DO 201 JL = 1, KDLON
6408	PTT(JL, 9) = PTT(JL, 8)
6409	C
6410	C- CONTINUUM ABSORPTION: E- AND P-TYPE
6411	C
6412	ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
6413	ZPU10 = 112. * ZPU
6414	ZPU11 = 6.25 * ZPU
6415	ZPU12 = 5.00 * ZPU
6416	ZPU13 = 80.0 * ZPU
6417	ZEU = (PUU1(JL,11) - PUU2(JL,11))
6418	ZEU10 = 12. * ZEU
6419	ZEU11 = 6.25 * ZEU
6420	ZEU12 = 5.00 * ZEU
6421	ZEU13 = 80.0 * ZEU
6422	C
6423	C- OZONE ABSORPTION
6424	C
6425	ZX = (PUU1(JL,12) - PUU2(JL,12))
6426	ZY = (PUU1(JL,13) - PUU2(JL,13))
6427	ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
6428	ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
6429	ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
6430	ZVXY = RPIALF0 * ZY / (2. * ZX)
6431	ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
6432	ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
6433	ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
6434	C
6435	C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
6436	C
6437	C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
6438	C
6439	ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
6440	ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
6441	ZUXY = 4. * ZXCH4ZXCH4/(0.103ZYCH4)
6442	ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
6443	ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
6444	ZODH41 = ZVXY * ZSQH41
6445	C
6446	C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
6447	C
6448	ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
6449	ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
6450	ZUXY = 4. * ZXN2OZXN2O/(0.416ZYN2O)
6451	ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
6452	ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
6453	ZODN21 = ZVXY * ZSQN21
6454	C
6455	C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
6456	C
6457	ZUXY = 4. * ZXCH4ZXCH4/(0.113ZYCH4)
6458	ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
6459	ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
6460	ZODH42 = ZVXY * ZSQH42
6461	C
6462	C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
6463	C
6464	ZUXY = 4. * ZXN2OZXN2O/(0.197ZYN2O)
6465	ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
6466	ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
6467	ZODN22 = ZVXY * ZSQN22
6468	C
6469	C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
6470	C
6471	ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
6472	ZTTF11 = 1. - ZA11 * 0.003225
6473	C
6474	C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
6475	C
6476	ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
6477	ZTTF12 = 1. - ZA12 * 0.003225
6478	C
6479	ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
6480	ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
6481	S ZODH41 - ZODN21
6482	PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
6483	PTT(JL,11) = EXP( ZUU11 )
6484	PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
6485	PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
6486	PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
6487	PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
6488	201 CONTINUE
6489	C
6490	RETURN
6491	END

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

Download in other formats:

Original Format