Context Navigation

radlwsw.F @ 985

Last change on this file since 985 was 868, checked in by Laurent Fairhead, 17 years ago
Preparation du remplacement de la physique utilisee pour l'exercice IPCC_AR4 par la version de la physique avec thermique. On garde le repertoire phylmd pour un petit moment pour que les utilisateurs ne soient pas trop perdus ... phy_IPCC_AR4 = phylmd LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 200.0 KB

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

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

Download in other formats:

Original Format