Context Navigation

radlwsw.F @ 498

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

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

Download in other formats:

Original Format