Context Navigation

radiation_AR4.F @ 1059

Last change on this file since 1059 was 998, checked in by Laurent Fairhead, 16 years ago
Modifications necessaires a la preparation au passage au nouveau rayonnement RRTM MPL LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 186.2 KB

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

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

Download in other formats:

Original Format