Context Navigation

radlwsw.F @ 393

Last change on this file since 393 was 393, checked in by lmdzadmin, 22 years ago
Modifications de JLD sur la conservation de l'energie On supprime les modifs de Pascale sur le cdrag, elles refroidissaient trop l'atmosphere LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 185.4 KB

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

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

Download in other formats:

Original Format