Context Navigation

radlwsw.F @ 674

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

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

Download in other formats:

Original Format