Context Navigation

radlwsw.F @ 515

Last change on this file since 515 was 503, checked in by lmdzadmin, 20 years ago
IM: ajout/modification des flux LW/SW 3d en sortie
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 189.6 KB

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

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

Download in other formats:

Original Format