Context Navigation

radlwsw.F @ 977

Last change on this file since 977 was 888, checked in by Laurent Fairhead, 17 years ago
Modifications sur l'albedo JG LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 200.1 KB

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

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

Download in other formats:

Original Format