Context Navigation

radiation_AR4.F @ 1106

Last change on this file since 1106 was 1106, checked in by lguez, 15 years ago
"comconst.h", and "comgeom2.h" are now both fixed and free form. Removed calls to procedure "flush". Corrected kinds of constants which appeared as arguments to "min" or "max" (all arguments are now of the same type and kind).
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 186.0 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	ZARG=MIN(ZTOP/PRMUZ(JL),200._8)
2126	ZEXMU0=EXP(-ZARG)
2127	ZARG2=MIN(ZRK*ZTOP,200._8)
2128	ZEXKP=EXP(ZARG2)
2129	ZEXKM = 1./ZEXKP
2130	ZXP2P = 1.+ZDT*ZRP
2131	ZXM2P = 1.-ZDT*ZRP
2132	ZAP2B = ZALPHA+ZDT*ZBETA
2133	ZAM2B = ZALPHA-ZDT*ZBETA
2134	C
2135	C* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER
2136	C
2137	120 CONTINUE
2138	C
2139	ZA11 = ZXP2P
2140	ZA12 = ZXM2P
2141	ZA13 = ZAP2B
2142	ZA22 = ZXP2P*ZEXKP
2143	ZA21 = ZXM2P*ZEXKM
2144	ZA23 = ZAM2B*ZEXMU0
2145	ZDENA = ZA11 * ZA22 - ZA21 * ZA12
2146	ZC1A = (ZA22ZA13-ZA12ZA23)/ZDENA
2147	ZC2A = (ZA11ZA23-ZA21ZA13)/ZDENA
2148	ZRI0A = ZC1A+ZC2A-ZALPHA
2149	ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
2150	PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
2151	ZRI0B = ZC1AZEXKM+ZC2AZEXKP-ZALPHA*ZEXMU0
2152	ZRI1B = ZRP(ZC1AZEXKM-ZC2AZEXKP)-ZBETAZEXMU0
2153	PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
2154	C
2155	C* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER
2156	C
2157	130 CONTINUE
2158	C
2159	ZB21 = ZA21- PREF(JL) ZXP2PZEXKM
2160	ZB22 = ZA22- PREF(JL) ZXM2PZEXKP
2161	ZB23 = ZA23- PREF(JL) ZEXMU0(ZAP2B - PRMUZ(JL) )
2162	ZDENB = ZA11 * ZB22 - ZB21 * ZA12
2163	ZC1B = (ZB22ZA13-ZA12ZB23)/ZDENB
2164	ZC2B = (ZA11ZB23-ZB21ZA13)/ZDENB
2165	ZRI0C = ZC1B+ZC2B-ZALPHA
2166	ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
2167	PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
2168	ZRI0D = ZC1BZEXKM + ZC2BZEXKP - ZALPHA*ZEXMU0
2169	ZRI1D = ZRP * (ZC1BZEXKM - ZC2BZEXKP) - ZBETA*ZEXMU0
2170	PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
2171	C
2172	131 CONTINUE
2173	RETURN
2174	END
2175	SUBROUTINE SWTT_LMDAR4 (KNU,KA,PU,PTR)
2176	USE dimphy
2177	IMPLICIT none
2178	cym#include "dimensions.h"
2179	cym#include "dimphy.h"
2180	cym#include "raddim.h"
2181	C
2182	C-----------------------------------------------------------------------
2183	C PURPOSE.
2184	C --------
2185	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2186	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2187	C INTERVALS.
2188	C
2189	C METHOD.
2190	C -------
2191	C
2192	C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2193	C AND HORNER'S ALGORITHM.
2194	C
2195	C REFERENCE.
2196	C ----------
2197	C
2198	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2199	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2200	C
2201	C AUTHOR.
2202	C -------
2203	C JEAN-JACQUES MORCRETTE ECMWF
2204	C
2205	C MODIFICATIONS.
2206	C --------------
2207	C ORIGINAL : 88-12-15
2208	C-----------------------------------------------------------------------
2209	C
2210	C* ARGUMENTS
2211	C
2212	INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL
2213	INTEGER KA ! INDEX OF THE ABSORBER
2214	REAL*8 PU(KDLON) ! ABSORBER AMOUNT
2215	C
2216	REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION
2217	C
2218	C* LOCAL VARIABLES:
2219	C
2220	REAL*8 ZR1(KDLON), ZR2(KDLON)
2221	INTEGER jl, i,j
2222	C
2223	C* Prescribed Data:
2224	C
2225	REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
2226	SAVE APAD, BPAD, D
2227	c$OMP THREADPRIVATE(APAD, BPAD, D)
2228	DATA ((APAD(1,I,J),I=1,3),J=1,7) /
2229	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2230	S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
2231	S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
2232	S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
2233	S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
2234	S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
2235	S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
2236	DATA ((APAD(2,I,J),I=1,3),J=1,7) /
2237	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2238	S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
2239	S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
2240	S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
2241	S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
2242	S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
2243	S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
2244	C
2245	DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
2246	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2247	S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
2248	S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
2249	S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
2250	S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
2251	S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
2252	S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
2253	DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
2254	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2255	S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
2256	S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
2257	S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
2258	S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
2259	S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
2260	S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
2261	c
2262	DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
2263	DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
2264	C
2265	C-----------------------------------------------------------------------
2266	C
2267	C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2268	C
2269	100 CONTINUE
2270	C
2271	DO 201 JL = 1, KDLON
2272	ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
2273	S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
2274	S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
2275	S * ( APAD(KNU,KA,7) ))))))
2276	C
2277	ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
2278	S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
2279	S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
2280	S * ( BPAD(KNU,KA,7) ))))))
2281	C
2282	C
2283	C* 2. ADD THE BACKGROUND TRANSMISSION
2284	C
2285	200 CONTINUE
2286	C
2287	C
2288	PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
2289	201 CONTINUE
2290	C
2291	RETURN
2292	END
2293	SUBROUTINE SWTT1_LMDAR4(KNU,KABS,KIND, PU, PTR)
2294	USE dimphy
2295	IMPLICIT none
2296	cym#include "dimensions.h"
2297	cym#include "dimphy.h"
2298	cym#include "raddim.h"
2299	C
2300	C-----------------------------------------------------------------------
2301	C PURPOSE.
2302	C --------
2303	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2304	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2305	C INTERVALS.
2306	C
2307	C METHOD.
2308	C -------
2309	C
2310	C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2311	C AND HORNER'S ALGORITHM.
2312	C
2313	C REFERENCE.
2314	C ----------
2315	C
2316	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2317	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2318	C
2319	C AUTHOR.
2320	C -------
2321	C JEAN-JACQUES MORCRETTE ECMWF
2322	C
2323	C MODIFICATIONS.
2324	C --------------
2325	C ORIGINAL : 95-01-20
2326	C-----------------------------------------------------------------------
2327	C* ARGUMENTS:
2328	C
2329	INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL
2330	INTEGER KABS ! NUMBER OF ABSORBERS
2331	INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS
2332	REAL*8 PU(KDLON,KABS) ! ABSORBER AMOUNT
2333	C
2334	REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
2335	C
2336	C* LOCAL VARIABLES:
2337	C
2338	REAL*8 ZR1(KDLON)
2339	REAL*8 ZR2(KDLON)
2340	REAL*8 ZU(KDLON)
2341	INTEGER jl, ja, i, j, ia
2342	C
2343	C* Prescribed Data:
2344	C
2345	REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
2346	SAVE APAD, BPAD, D
2347	c$OMP THREADPRIVATE(APAD, BPAD, D)
2348	DATA ((APAD(1,I,J),I=1,3),J=1,7) /
2349	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2350	S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
2351	S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
2352	S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
2353	S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
2354	S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
2355	S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
2356	DATA ((APAD(2,I,J),I=1,3),J=1,7) /
2357	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2358	S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
2359	S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
2360	S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
2361	S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
2362	S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
2363	S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
2364	C
2365	DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
2366	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2367	S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
2368	S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
2369	S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
2370	S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
2371	S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
2372	S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
2373	DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
2374	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2375	S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
2376	S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
2377	S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
2378	S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
2379	S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
2380	S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
2381	c
2382	DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
2383	DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
2384	C-----------------------------------------------------------------------
2385	C
2386	C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2387	C
2388	100 CONTINUE
2389	C
2390	DO 202 JA = 1,KABS
2391	IA=KIND(JA)
2392	DO 201 JL = 1, KDLON
2393	ZU(JL) = PU(JL,JA)
2394	ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
2395	S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
2396	S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
2397	S * ( APAD(KNU,IA,7) ))))))
2398	C
2399	ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
2400	S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
2401	S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
2402	S * ( BPAD(KNU,IA,7) ))))))
2403	C
2404	C
2405	C* 2. ADD THE BACKGROUND TRANSMISSION
2406	C
2407	200 CONTINUE
2408	C
2409	PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA)
2410	201 CONTINUE
2411	202 CONTINUE
2412	C
2413	RETURN
2414	END
2415	cIM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
2416	SUBROUTINE LW_LMDAR4(
2417	. PPMB, PDP,
2418	. PPSOL,PDT0,PEMIS,
2419	. PTL, PTAVE, PWV, POZON, PAER,
2420	. PCLDLD,PCLDLU,
2421	. PVIEW,
2422	. PCOLR, PCOLR0,
2423	. PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
2424	. psollwdown,
2425	cIM . psollwdown,psollwdownclr,
2426	cIM . ptoplwdown,ptoplwdownclr)
2427	. plwup, plwdn, plwup0, plwdn0)
2428	USE dimphy
2429	IMPLICIT none
2430	cym#include "dimensions.h"
2431	cym#include "dimphy.h"
2432	cym#include "raddim.h"
2433	#include "raddimlw.h"
2434	#include "YOMCST.h"
2435	C
2436	C-----------------------------------------------------------------------
2437	C METHOD.
2438	C -------
2439	C
2440	C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2441	C ABSORBERS.
2442	C 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
2443	C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
2444	C 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
2445	C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
2446	C BOUNDARIES.
2447	C 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
2448	C 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
2449	C
2450	C
2451	C REFERENCE.
2452	C ----------
2453	C
2454	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2455	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2456	C
2457	C AUTHOR.
2458	C -------
2459	C JEAN-JACQUES MORCRETTE ECMWF
2460	C
2461	C MODIFICATIONS.
2462	C --------------
2463	C ORIGINAL : 89-07-14
2464	C-----------------------------------------------------------------------
2465	cIM ctes ds clesphys.h
2466	c REAL8 RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06 44.011/28.97)
2467	c REAL8 RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06 16.043/28.97)
2468	c REAL8 RN2O ! N2O CONCENTRATION (IPCC: 310.E-09 44.013/28.97)
2469	c REAL8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12 137.3686/28.97)
2470	c REAL8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12 120.9140/28.97)
2471	#include "clesphys.h"
2472	REAL*8 PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER
2473	REAL*8 PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER
2474	REAL*8 PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa)
2475	REAL*8 PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K)
2476	REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
2477	REAL*8 PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb)
2478	REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (Pa)
2479	REAL*8 POZON(KDLON,KFLEV) ! O3 CONCENTRATION (kg/kg)
2480	REAL*8 PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K)
2481	REAL*8 PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS
2482	REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K)
2483	REAL*8 PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE
2484	REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg)
2485	C
2486	REAL*8 PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day)
2487	REAL*8 PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky
2488	REAL*8 PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A.
2489	REAL*8 PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE
2490	REAL*8 PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
2491	REAL*8 PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
2492	c Rajout LF
2493	real*8 psollwdown(kdlon) ! LONGWAVE downwards flux at surface
2494	c Rajout IM
2495	cIM real*8 psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
2496	cIM real*8 ptoplwdown(kdlon) ! LONGWAVE downwards flux at T.O.A.
2497	cIM real*8 ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
2498	cIM
2499	REAL*8 plwup(KDLON,KFLEV+1) ! LW up total sky
2500	REAL*8 plwup0(KDLON,KFLEV+1) ! LW up clear sky
2501	REAL*8 plwdn(KDLON,KFLEV+1) ! LW down total sky
2502	REAL*8 plwdn0(KDLON,KFLEV+1) ! LW down clear sky
2503	C-------------------------------------------------------------------------
2504	REAL8 ZABCU(KDLON,NUA,3KFLEV+1)
2505	REAL*8 ZOZ(KDLON,KFLEV)
2506	c
2507	cym REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
2508	cym REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
2509	cym REAL*8 ZBINT(KDLON,KFLEV+1) ! Intermediate variable
2510	cym REAL*8 ZBSUI(KDLON) ! Intermediate variable
2511	cym REAL*8,ZCTS(KDLON,KFLEV) ! Intermediate variable
2512	cym REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable
2513	cym SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
2514	REAL*8,allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
2515	REAL*8,allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
2516	REAL*8,allocatable,save :: ZBINT(:,:) ! Intermediate variable
2517	REAL*8,allocatable,save :: ZBSUI(:) ! Intermediate variable
2518	REAL*8,allocatable,save :: ZCTS(:,:) ! Intermediate variable
2519	REAL*8,allocatable,save :: ZCNTRB(:,:,:) ! Intermediate variable
2520	c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
2521	c
2522	INTEGER ilim, i, k, kpl1
2523	C
2524	INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
2525	PARAMETER (lw0pas=1)
2526	INTEGER lwpas ! Every lwpas steps, cloudy-sky is done
2527	PARAMETER (lwpas=1)
2528	c
2529	INTEGER itaplw0, itaplw
2530	LOGICAL appel1er
2531	SAVE appel1er, itaplw0, itaplw
2532	c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
2533	DATA appel1er /.TRUE./
2534	DATA itaplw0,itaplw /0,0/
2535
2536	C ------------------------------------------------------------------
2537	IF (appel1er) THEN
2538	PRINT*, "LW clear-sky calling frequency: ", lw0pas
2539	PRINT*, "LW cloudy-sky calling frequency: ", lwpas
2540	PRINT*, " In general, they should be 1"
2541	cym
2542	allocate(ZFLUX(KDLON,2,KFLEV+1) )
2543	allocate(ZFLUC(KDLON,2,KFLEV+1) )
2544	allocate(ZBINT(KDLON,KFLEV+1))
2545	allocate(ZBSUI(KDLON))
2546	allocate(ZCTS(KDLON,KFLEV))
2547	allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
2548	appel1er=.FALSE.
2549	ENDIF
2550	C
2551	IF (MOD(itaplw0,lw0pas).EQ.0) THEN
2552	DO k = 1, KFLEV ! convertir ozone de kg/kg en pa/pa
2553	DO i = 1, KDLON
2554	c convertir ozone de kg/kg en pa (modif MPL 100505)
2555	ZOZ(i,k) = POZON(i,k)PDP(i,k) RMD/RMO3
2556	c print ,'LW: ZOZ10*6=',ZOZ(i,k)1000000.
2557	ENDDO
2558	ENDDO
2559	cIM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
2560	CALL LWU_LMDAR4(
2561	S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
2562	CALL LWBV_LMDAR4(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
2563	S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
2564	itaplw0 = 0
2565	ENDIF
2566	itaplw0 = itaplw0 + 1
2567	C
2568	IF (MOD(itaplw,lwpas).EQ.0) THEN
2569	CALL LWC_LMDAR4(ILIM,PCLDLD,PCLDLU,PEMIS,
2570	S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
2571	S ZFLUX)
2572	itaplw = 0
2573	ENDIF
2574	itaplw = itaplw + 1
2575	C
2576	DO k = 1, KFLEV
2577	kpl1 = k+1
2578	DO i = 1, KDLON
2579	PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
2580	. - ZFLUX(i,1,k)- ZFLUX(i,2,k)
2581	PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
2582	PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
2583	. - ZFLUC(i,1,k)- ZFLUC(i,2,k)
2584	PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
2585	ENDDO
2586	ENDDO
2587	DO i = 1, KDLON
2588	PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
2589	PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
2590	c
2591	PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
2592	PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
2593	psollwdown(i) = -ZFLUX(i,2,1)
2594	c
2595	cIM attention aux signes !; LWtop >0, LWdn < 0
2596	DO k = 1, KFLEV+1
2597	plwup(i,k) = ZFLUX(i,1,k)
2598	plwup0(i,k) = ZFLUC(i,1,k)
2599	plwdn(i,k) = ZFLUX(i,2,k)
2600	plwdn0(i,k) = ZFLUC(i,2,k)
2601	ENDDO
2602	ENDDO
2603	C ------------------------------------------------------------------
2604	RETURN
2605	END
2606	cIM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
2607	SUBROUTINE LWU_LMDAR4(
2608	S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
2609	S PABCU)
2610	USE dimphy
2611	IMPLICIT none
2612	cym#include "dimensions.h"
2613	cym#include "dimphy.h"
2614	cym#include "raddim.h"
2615	#include "raddimlw.h"
2616	#include "YOMCST.h"
2617	#include "radepsi.h"
2618	#include "radopt.h"
2619	C
2620	C PURPOSE.
2621	C --------
2622	C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
2623	C TEMPERATURE EFFECTS
2624	C
2625	C METHOD.
2626	C -------
2627	C
2628	C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2629	C ABSORBERS.
2630	C
2631	C
2632	C REFERENCE.
2633	C ----------
2634	C
2635	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2636	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2637	C
2638	C AUTHOR.
2639	C -------
2640	C JEAN-JACQUES MORCRETTE ECMWF
2641	C
2642	C MODIFICATIONS.
2643	C --------------
2644	C ORIGINAL : 89-07-14
2645	C Voigt lines (loop 404 modified) - JJM & PhD - 01/96
2646	C-----------------------------------------------------------------------
2647	C* ARGUMENTS:
2648	cIM ctes ds clesphys.h
2649	c REAL*8 RCO2
2650	c REAL*8 RCH4, RN2O, RCFC11, RCFC12
2651	#include "clesphys.h"
2652	REAL*8 PAER(KDLON,KFLEV,5)
2653	REAL*8 PDP(KDLON,KFLEV)
2654	REAL*8 PPMB(KDLON,KFLEV+1)
2655	REAL*8 PPSOL(KDLON)
2656	REAL*8 POZ(KDLON,KFLEV)
2657	REAL*8 PTAVE(KDLON,KFLEV)
2658	REAL*8 PVIEW(KDLON)
2659	REAL*8 PWV(KDLON,KFLEV)
2660	C
2661	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
2662	C
2663	C-----------------------------------------------------------------------
2664	C* LOCAL VARIABLES:
2665	REAL8 ZABLY(KDLON,NUA,3KFLEV+1)
2666	REAL8 ZDUC(KDLON,3KFLEV+1)
2667	REAL*8 ZPHIO(KDLON)
2668	REAL*8 ZPSC2(KDLON)
2669	REAL*8 ZPSC3(KDLON)
2670	REAL*8 ZPSH1(KDLON)
2671	REAL*8 ZPSH2(KDLON)
2672	REAL*8 ZPSH3(KDLON)
2673	REAL*8 ZPSH4(KDLON)
2674	REAL*8 ZPSH5(KDLON)
2675	REAL*8 ZPSH6(KDLON)
2676	REAL*8 ZPSIO(KDLON)
2677	REAL*8 ZTCON(KDLON)
2678	REAL*8 ZPHM6(KDLON)
2679	REAL*8 ZPSM6(KDLON)
2680	REAL*8 ZPHN6(KDLON)
2681	REAL*8 ZPSN6(KDLON)
2682	REAL8 ZSSIG(KDLON,3KFLEV+1)
2683	REAL*8 ZTAVI(KDLON)
2684	REAL*8 ZUAER(KDLON,Ninter)
2685	REAL*8 ZXOZ(KDLON)
2686	REAL*8 ZXWV(KDLON)
2687	C
2688	INTEGER jl, jk, jkj, jkjr, jkjp, ig1
2689	INTEGER jki, jkip1, ja, jj
2690	INTEGER jkl, jkp1, jkk, jkjpn
2691	INTEGER jae1, jae2, jae3, jae, jjpn
2692	INTEGER ir, jc, jcp1
2693	REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
2694	REAL*8 zfppw, ztx, ztx2, zzably
2695	REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
2696	REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
2697	REAL*8 zcac8, zcbc8
2698	REAL*8 zalup, zdiff
2699	c
2700	REAL*8 PVGCO2, PVGH2O, PVGO3
2701	C
2702	REAL*8 R10E ! DECIMAL/NATURAL LOG.FACTOR
2703	PARAMETER (R10E=0.4342945)
2704	c
2705	c Used Data Block:
2706	c
2707	REAL*8 TREF
2708	SAVE TREF
2709	c$OMP THREADPRIVATE(TREF)
2710	REAL*8 RT1(2)
2711	SAVE RT1
2712	c$OMP THREADPRIVATE(RT1)
2713	REAL*8 RAER(5,5)
2714	SAVE RAER
2715	c$OMP THREADPRIVATE(RAER)
2716	REAL*8 AT(8,3), BT(8,3)
2717	SAVE AT, BT
2718	c$OMP THREADPRIVATE(AT, BT)
2719	REAL*8 OCT(4)
2720	SAVE OCT
2721	c$OMP THREADPRIVATE(OCT)
2722	DATA TREF /250.0/
2723	DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
2724	DATA RAER / .038520, .037196, .040532, .054934, .038520
2725	1 , .12613 , .18313 , .10357 , .064106, .126130
2726	2 , .012579, .013649, .018652, .025181, .012579
2727	3 , .011890, .016142, .021105, .028908, .011890
2728	4 , .013792, .026810, .052203, .066338, .013792 /
2729	DATA (AT(1,IR),IR=1,3) /
2730	S 0.298199E-02,-.394023E-03,0.319566E-04 /
2731	DATA (BT(1,IR),IR=1,3) /
2732	S-0.106432E-04,0.660324E-06,0.174356E-06 /
2733	DATA (AT(2,IR),IR=1,3) /
2734	S 0.143676E-01,0.366501E-02,-.160822E-02 /
2735	DATA (BT(2,IR),IR=1,3) /
2736	S-0.553979E-04,-.101701E-04,0.920868E-05 /
2737	DATA (AT(3,IR),IR=1,3) /
2738	S 0.197861E-01,0.315541E-02,-.174547E-02 /
2739	DATA (BT(3,IR),IR=1,3) /
2740	S-0.877012E-04,0.513302E-04,0.523138E-06 /
2741	DATA (AT(4,IR),IR=1,3) /
2742	S 0.289560E-01,-.208807E-02,-.121943E-02 /
2743	DATA (BT(4,IR),IR=1,3) /
2744	S-0.165960E-03,0.157704E-03,-.146427E-04 /
2745	DATA (AT(5,IR),IR=1,3) /
2746	S 0.103800E-01,0.436296E-02,-.161431E-02 /
2747	DATA (BT(5,IR),IR=1,3) /
2748	S -.276744E-04,-.327381E-04,0.127646E-04 /
2749	DATA (AT(6,IR),IR=1,3) /
2750	S 0.868859E-02,-.972752E-03,0.000000E-00 /
2751	DATA (BT(6,IR),IR=1,3) /
2752	S -.278412E-04,-.713940E-06,0.117469E-05 /
2753	DATA (AT(7,IR),IR=1,3) /
2754	S 0.250073E-03,0.455875E-03,0.109242E-03 /
2755	DATA (BT(7,IR),IR=1,3) /
2756	S 0.199846E-05,-.216313E-05,0.175991E-06 /
2757	DATA (AT(8,IR),IR=1,3) /
2758	S 0.307423E-01,0.110879E-02,-.322172E-03 /
2759	DATA (BT(8,IR),IR=1,3) /
2760	S-0.108482E-03,0.258096E-05,-.814575E-06 /
2761	c
2762	DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
2763	C-----------------------------------------------------------------------
2764	c
2765	IF (LEVOIGT) THEN
2766	PVGCO2= 60.
2767	PVGH2O= 30.
2768	PVGO3 =400.
2769	ELSE
2770	PVGCO2= 0.
2771	PVGH2O= 0.
2772	PVGO3 = 0.
2773	ENDIF
2774	C
2775	C
2776	C* 2. PRESSURE OVER GAUSS SUB-LEVELS
2777	C ------------------------------
2778	C
2779	200 CONTINUE
2780	C
2781	DO 201 JL = 1, KDLON
2782	ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
2783	201 CONTINUE
2784	C
2785	DO 206 JK = 1 , KFLEV
2786	JKJ=(JK-1)*NG1P1+1
2787	JKJR = JKJ
2788	JKJP = JKJ + NG1P1
2789	DO 203 JL = 1, KDLON
2790	ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
2791	203 CONTINUE
2792	DO 205 IG1=1,NG1
2793	JKJ=JKJ+1
2794	DO 204 JL = 1, KDLON
2795	ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
2796	S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
2797	204 CONTINUE
2798	205 CONTINUE
2799	206 CONTINUE
2800	C
2801	C-----------------------------------------------------------------------
2802	C
2803	C
2804	C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
2805	C --------------------------------------------------
2806	C
2807	400 CONTINUE
2808	C
2809	DO 402 JKI=1,3*KFLEV
2810	JKIP1=JKI+1
2811	DO 401 JL = 1, KDLON
2812	ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
2813	ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
2814	S /(10.*RG)
2815	401 CONTINUE
2816	402 CONTINUE
2817	C
2818	DO 406 JK = 1 , KFLEV
2819	JKP1=JK+1
2820	JKL = KFLEV+1 - JK
2821	DO 403 JL = 1, KDLON
2822	ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
2823	ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
2824	403 CONTINUE
2825	JKJ=(JK-1)*NG1P1+1
2826	JKJPN=JKJ+NG1
2827	DO 405 JKK=JKJ,JKJPN
2828	DO 404 JL = 1, KDLON
2829	ZDPM = ZABLY(JL,3,JKK)
2830	ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325.
2831	ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
2832	ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
2833	ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325.
2834	ZDUC(JL,JKK) = ZDPM
2835	ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
2836	ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
2837	ZU6 = ZXWV(JL) * ZUPM
2838	ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
2839	ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
2840	ZABLY(JL,11,JKK) = ZU6 * ZFPPW
2841	ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
2842	ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
2843	ZABLY(JL,8,JKK) = RCO2 * ZDPM
2844	404 CONTINUE
2845	405 CONTINUE
2846	406 CONTINUE
2847	C
2848	C-----------------------------------------------------------------------
2849	C
2850	C
2851	C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
2852	C --------------------------------------------------
2853	C
2854	500 CONTINUE
2855	C
2856	DO 502 JA = 1, NUA
2857	DO 501 JL = 1, KDLON
2858	PABCU(JL,JA,3*KFLEV+1) = 0.
2859	501 CONTINUE
2860	502 CONTINUE
2861	C
2862	DO 529 JK = 1 , KFLEV
2863	JJ=(JK-1)*NG1P1+1
2864	JJPN=JJ+NG1
2865	JKL=KFLEV+1-JK
2866	C
2867	C
2868	C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
2869	C --------------------------------------------------
2870	C
2871	510 CONTINUE
2872	C
2873	JAE1=3*KFLEV+1-JJ
2874	JAE2=3*KFLEV+1-(JJ+1)
2875	JAE3=3*KFLEV+1-JJPN
2876	DO 512 JAE=1,5
2877	DO 511 JL = 1, KDLON
2878	ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
2879	S +RAER(JAE,2)PAER(JL,JKL,2)+RAER(JAE,3)PAER(JL,JKL,3)
2880	S +RAER(JAE,4)PAER(JL,JKL,4)+RAER(JAE,5)PAER(JL,JKL,5))
2881	S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
2882	511 CONTINUE
2883	512 CONTINUE
2884	C
2885	C
2886	C
2887	C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
2888	C --------------------------------------------------
2889	C
2890	520 CONTINUE
2891	C
2892	DO 521 JL = 1, KDLON
2893	ZTAVI(JL)=PTAVE(JL,JKL)
2894	ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
2895	ZTX=ZTAVI(JL)-TREF
2896	ZTX2=ZTX*ZTX
2897	ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
2898	ZUP=MIN( MAX( 0.5R10ELOG( ZZABLY ) + 5., 0._8), 6._8)
2899	ZCAH1=AT(1,1)+ZUP(AT(1,2)+ZUP(AT(1,3)))
2900	ZCBH1=BT(1,1)+ZUP(BT(1,2)+ZUP(BT(1,3)))
2901	ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
2902	ZCAH2=AT(2,1)+ZUP(AT(2,2)+ZUP(AT(2,3)))
2903	ZCBH2=BT(2,1)+ZUP(BT(2,2)+ZUP(BT(2,3)))
2904	ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
2905	ZCAH3=AT(3,1)+ZUP(AT(3,2)+ZUP(AT(3,3)))
2906	ZCBH3=BT(3,1)+ZUP(BT(3,2)+ZUP(BT(3,3)))
2907	ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
2908	ZCAH4=AT(4,1)+ZUP(AT(4,2)+ZUP(AT(4,3)))
2909	ZCBH4=BT(4,1)+ZUP(BT(4,2)+ZUP(BT(4,3)))
2910	ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
2911	ZCAH5=AT(5,1)+ZUP(AT(5,2)+ZUP(AT(5,3)))
2912	ZCBH5=BT(5,1)+ZUP(BT(5,2)+ZUP(BT(5,3)))
2913	ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
2914	ZCAH6=AT(6,1)+ZUP(AT(6,2)+ZUP(AT(6,3)))
2915	ZCBH6=BT(6,1)+ZUP(BT(6,2)+ZUP(BT(6,3)))
2916	ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
2917	ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
2918	ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
2919	ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
2920	ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
2921	521 CONTINUE
2922	C
2923	DO 522 JL = 1, KDLON
2924	ZTAVI(JL)=PTAVE(JL,JKL)
2925	ZTX=ZTAVI(JL)-TREF
2926	ZTX2=ZTX*ZTX
2927	ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
2928	ZALUP = R10E * LOG ( ZZABLY )
2929	ZUP = MAX( 0._8, 5.0 + 0.5 * ZALUP )
2930	ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
2931	ZCAC8=AT(8,1)+ZUP(AT(8,2)+ZUP(AT(8,3)))
2932	ZCBC8=BT(8,1)+ZUP(BT(8,2)+ZUP(BT(8,3)))
2933	ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
2934	ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
2935	ZPSIO(JL) = EXP( 2.* (OCT(3)ZTX+OCT(4)ZTX2))
2936	522 CONTINUE
2937	C
2938	DO 524 JKK=JJ,JJPN
2939	JC=3*KFLEV+1-JKK
2940	JCP1=JC+1
2941	DO 523 JL = 1, KDLON
2942	ZDIFF = PVIEW(JL)
2943	PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
2944	S +ZABLY(JL,10,JC) *ZDIFF
2945	PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
2946	S +ZABLY(JL,11,JC)ZTCON(JL)ZDIFF
2947	C
2948	PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
2949	S +ZABLY(JL,12,JC)ZPHIO(JL)ZDIFF
2950	PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
2951	S +ZABLY(JL,13,JC)ZPSIO(JL)ZDIFF
2952	C
2953	PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
2954	S +ZABLY(JL,9,JC)ZPSC2(JL)ZDIFF
2955	PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
2956	S +ZABLY(JL,9,JC)ZPSC3(JL)ZDIFF
2957	PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
2958	S +ZABLY(JL,9,JC)ZPSC3(JL)ZDIFF
2959	C
2960	PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
2961	S +ZABLY(JL,6,JC)ZPSH1(JL)ZDIFF
2962	PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
2963	S +ZABLY(JL,6,JC)ZPSH2(JL)ZDIFF
2964	PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
2965	S +ZABLY(JL,6,JC)ZPSH5(JL)ZDIFF
2966	PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
2967	S +ZABLY(JL,6,JC)ZPSH3(JL)ZDIFF
2968	PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
2969	S +ZABLY(JL,6,JC)ZPSH4(JL)ZDIFF
2970	PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
2971	S +ZABLY(JL,6,JC)ZPSH6(JL)ZDIFF
2972	C
2973	PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
2974	S +ZUAER(JL,1) ZDUC(JL,JC)ZDIFF
2975	PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
2976	S +ZUAER(JL,2) ZDUC(JL,JC)ZDIFF
2977	PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
2978	S +ZUAER(JL,3) ZDUC(JL,JC)ZDIFF
2979	PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
2980	S +ZUAER(JL,4) ZDUC(JL,JC)ZDIFF
2981	PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
2982	S +ZUAER(JL,5) ZDUC(JL,JC)ZDIFF
2983	C
2984	PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
2985	S +ZABLY(JL,8,JC)RCH4/RCO2ZPHM6(JL)*ZDIFF
2986	PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
2987	S +ZABLY(JL,9,JC)RCH4/RCO2ZPSM6(JL)*ZDIFF
2988	PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
2989	S +ZABLY(JL,8,JC)RN2O/RCO2ZPHN6(JL)*ZDIFF
2990	PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
2991	S +ZABLY(JL,9,JC)RN2O/RCO2ZPSN6(JL)*ZDIFF
2992	C
2993	PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
2994	S +ZABLY(JL,8,JC)RCFC11/RCO2 ZDIFF
2995	PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
2996	S +ZABLY(JL,8,JC)RCFC12/RCO2 ZDIFF
2997	523 CONTINUE
2998	524 CONTINUE
2999	C
3000	529 CONTINUE
3001	C
3002	C
3003	RETURN
3004	END
3005	SUBROUTINE LWBV_LMDAR4(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
3006	S PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
3007	USE dimphy
3008	IMPLICIT none
3009	cym#include "dimensions.h"
3010	cym#include "dimphy.h"
3011	cym#include "raddim.h"
3012	#include "raddimlw.h"
3013	#include "YOMCST.h"
3014	C
3015	C PURPOSE.
3016	C --------
3017	C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
3018	C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
3019	C SAVING
3020	C
3021	C METHOD.
3022	C -------
3023	C
3024	C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
3025	C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
3026	C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
3027	C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
3028	C BOUNDARIES.
3029	C 3. COMPUTES THE CLEAR-SKY COOLING RATES.
3030	C
3031	C REFERENCE.
3032	C ----------
3033	C
3034	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3035	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3036	C
3037	C AUTHOR.
3038	C -------
3039	C JEAN-JACQUES MORCRETTE ECMWF
3040	C
3041	C MODIFICATIONS.
3042	C --------------
3043	C ORIGINAL : 89-07-14
3044	C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
3045	C MEMORY)
3046	C-----------------------------------------------------------------------
3047	C* ARGUMENTS:
3048	INTEGER KLIM
3049	C
3050	REAL*8 PDP(KDLON,KFLEV)
3051	REAL*8 PDT0(KDLON)
3052	REAL*8 PEMIS(KDLON)
3053	REAL*8 PPMB(KDLON,KFLEV+1)
3054	REAL*8 PTL(KDLON,KFLEV+1)
3055	REAL*8 PTAVE(KDLON,KFLEV)
3056	C
3057	REAL*8 PFLUC(KDLON,2,KFLEV+1)
3058	C
3059	REAL8 PABCU(KDLON,NUA,3KFLEV+1)
3060	REAL*8 PBINT(KDLON,KFLEV+1)
3061	REAL*8 PBSUI(KDLON)
3062	REAL*8 PCTS(KDLON,KFLEV)
3063	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
3064	C
3065	C-------------------------------------------------------------------------
3066	C
3067	C* LOCAL VARIABLES:
3068	REAL*8 ZB(KDLON,Ninter,KFLEV+1)
3069	REAL*8 ZBSUR(KDLON,Ninter)
3070	REAL*8 ZBTOP(KDLON,Ninter)
3071	REAL8 ZDBSL(KDLON,Ninter,KFLEV2)
3072	REAL*8 ZGA(KDLON,8,2,KFLEV)
3073	REAL*8 ZGB(KDLON,8,2,KFLEV)
3074	REAL*8 ZGASUR(KDLON,8,2)
3075	REAL*8 ZGBSUR(KDLON,8,2)
3076	REAL*8 ZGATOP(KDLON,8,2)
3077	REAL*8 ZGBTOP(KDLON,8,2)
3078	C
3079	INTEGER nuaer, ntraer
3080	C ------------------------------------------------------------------
3081	C* COMPUTES PLANCK FUNCTIONS:
3082	CALL LWB_LMDAR4(PDT0,PTAVE,PTL,
3083	S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
3084	S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
3085	C ------------------------------------------------------------------
3086	C* PERFORMS THE VERTICAL INTEGRATION:
3087	NUAER = NUA
3088	NTRAER = NTRA
3089	CALL LWV_LMDAR4(NUAER,NTRAER, KLIM
3090	R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
3091	R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
3092	S , PCNTRB,PCTS,PFLUC)
3093	C ------------------------------------------------------------------
3094	RETURN
3095	END
3096	SUBROUTINE LWC_LMDAR4(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
3097	R PBINT,PBSUIN,PCTS,PCNTRB,
3098	S PFLUX)
3099	USE dimphy
3100	IMPLICIT none
3101	cym#include "dimensions.h"
3102	cym#include "dimphy.h"
3103	cym#include "raddim.h"
3104	#include "radepsi.h"
3105	#include "radopt.h"
3106	C
3107	C PURPOSE.
3108	C --------
3109	C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
3110	C RADIANCES
3111	C
3112	C EXPLICIT ARGUMENTS :
3113	C --------------------
3114	C ==== INPUTS ===
3115	C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION
3116	C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3117	C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION
3118	C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION
3119	C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
3120	C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE
3121	C PEMIS : (KDLON) ; SURFACE EMISSIVITY
3122	C PFLUC
3123	C ==== OUTPUTS ===
3124	C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES :
3125	C 1 ==> UPWARD FLUX TOTAL
3126	C 2 ==> DOWNWARD FLUX TOTAL
3127	C
3128	C METHOD.
3129	C -------
3130	C
3131	C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
3132	C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
3133	C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
3134	C CLOUDS
3135	C
3136	C REFERENCE.
3137	C ----------
3138	C
3139	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3140	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3141	C
3142	C AUTHOR.
3143	C -------
3144	C JEAN-JACQUES MORCRETTE ECMWF
3145	C
3146	C MODIFICATIONS.
3147	C --------------
3148	C ORIGINAL : 89-07-14
3149	C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96
3150	C-----------------------------------------------------------------------
3151	C* ARGUMENTS:
3152	INTEGER klim
3153	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
3154	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3155	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3156	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
3157	REAL*8 PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE
3158	c
3159	REAL*8 PCLDLD(KDLON,KFLEV)
3160	REAL*8 PCLDLU(KDLON,KFLEV)
3161	REAL*8 PEMIS(KDLON)
3162	C
3163	REAL*8 PFLUX(KDLON,2,KFLEV+1)
3164	C-----------------------------------------------------------------------
3165	C* LOCAL VARIABLES:
3166	INTEGER IMX(KDLON), IMXP(KDLON)
3167	C
3168	REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
3169	S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
3170	S , ZUPF(KDLON,KFLEV+1,KFLEV+1)
3171	REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
3172	C
3173	INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
3174	INTEGER jk1, jk2, jkc, jkcp1, jcloud
3175	INTEGER imxm1, imxp1
3176	REAL*8 zcfrac
3177	C ------------------------------------------------------------------
3178	C
3179	C* 1. INITIALIZATION
3180	C --------------
3181	C
3182	100 CONTINUE
3183	C
3184	IMAXC = 0
3185	C
3186	DO 101 JL = 1, KDLON
3187	IMX(JL)=0
3188	IMXP(JL)=0
3189	ZCLOUD(JL) = 0.
3190	101 CONTINUE
3191	C
3192	C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
3193	C -------------------------------------------
3194	C
3195	110 CONTINUE
3196	C
3197	DO 112 JK = 1 , KFLEV
3198	DO 111 JL = 1, KDLON
3199	IMX1=IMX(JL)
3200	IMX2=JK
3201	IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
3202	IMXP(JL)=IMX2
3203	ELSE
3204	IMXP(JL)=IMX1
3205	END IF
3206	IMAXC=MAX(IMXP(JL),IMAXC)
3207	IMX(JL)=IMXP(JL)
3208	111 CONTINUE
3209	112 CONTINUE
3210	CGM*******
3211	IMAXC=KFLEV
3212	CGM*******
3213	C
3214	DO 114 JK = 1 , KFLEV+1
3215	DO 113 JL = 1, KDLON
3216	PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
3217	PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
3218	113 CONTINUE
3219	114 CONTINUE
3220	C
3221	C ------------------------------------------------------------------
3222	C
3223	C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
3224	C ---------------------------------------
3225	C
3226	IF (IMAXC.GT.0) THEN
3227	C
3228	IMXP1 = IMAXC + 1
3229	IMXM1 = IMAXC - 1
3230	C
3231	C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES
3232	C ------------------------------
3233	C
3234	200 CONTINUE
3235	C
3236	DO 203 JK1=1,KFLEV+1
3237	DO 202 JK2=1,KFLEV+1
3238	DO 201 JL = 1, KDLON
3239	ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
3240	ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
3241	201 CONTINUE
3242	202 CONTINUE
3243	203 CONTINUE
3244	C
3245	C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
3246	C ----------------------------------------------
3247	C
3248	210 CONTINUE
3249	C
3250	DO 213 JKC = 1 , IMAXC
3251	JCLOUD=JKC
3252	JKCP1=JCLOUD+1
3253	C
3254	C* 2.1.1 ABOVE THE CLOUD
3255	C ---------------
3256	C
3257	2110 CONTINUE
3258	C
3259	DO 2115 JK=JKCP1,KFLEV+1
3260	JKM1=JK-1
3261	DO 2111 JL = 1, KDLON
3262	ZFU(JL)=0.
3263	2111 CONTINUE
3264	IF (JK .GT. JKCP1) THEN
3265	DO 2113 JKJ=JKCP1,JKM1
3266	DO 2112 JL = 1, KDLON
3267	ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
3268	2112 CONTINUE
3269	2113 CONTINUE
3270	END IF
3271	C
3272	DO 2114 JL = 1, KDLON
3273	ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
3274	2114 CONTINUE
3275	2115 CONTINUE
3276	C
3277	C* 2.1.2 BELOW THE CLOUD
3278	C ---------------
3279	C
3280	2120 CONTINUE
3281	C
3282	DO 2125 JK=1,JCLOUD
3283	JKP1=JK+1
3284	DO 2121 JL = 1, KDLON
3285	ZFD(JL)=0.
3286	2121 CONTINUE
3287	C
3288	IF (JK .LT. JCLOUD) THEN
3289	DO 2123 JKJ=JKP1,JCLOUD
3290	DO 2122 JL = 1, KDLON
3291	ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
3292	2122 CONTINUE
3293	2123 CONTINUE
3294	END IF
3295	DO 2124 JL = 1, KDLON
3296	ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
3297	2124 CONTINUE
3298	2125 CONTINUE
3299	C
3300	213 CONTINUE
3301	C
3302	C
3303	C* 2.2 CLOUD COVER MATRIX
3304	C ------------------
3305	C
3306	C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
3307	C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
3308	C
3309	220 CONTINUE
3310	C
3311	DO 223 JK1 = 1 , KFLEV+1
3312	DO 222 JK2 = 1 , KFLEV+1
3313	DO 221 JL = 1, KDLON
3314	ZCLM(JL,JK1,JK2) = 0.
3315	221 CONTINUE
3316	222 CONTINUE
3317	223 CONTINUE
3318	C
3319	C
3320	C
3321	C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION
3322	C ------------------------------------------
3323	C
3324	240 CONTINUE
3325	C
3326	DO 244 JK1 = 2 , KFLEV+1
3327	DO 241 JL = 1, KDLON
3328	ZCLEAR(JL)=1.
3329	ZCLOUD(JL)=0.
3330	241 CONTINUE
3331	DO 243 JK = JK1 - 1 , 1 , -1
3332	DO 242 JL = 1, KDLON
3333	IF (NOVLP.EQ.1) THEN
3334	c* maximum-random
3335	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
3336	* /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3337	ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3338	ZCLOUD(JL) = PCLDLU(JL,JK)
3339	ELSE IF (NOVLP.EQ.2) THEN
3340	c* maximum
3341	ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
3342	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3343	ELSE IF (NOVLP.EQ.3) THEN
3344	c* random
3345	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
3346	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3347	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3348	END IF
3349	242 CONTINUE
3350	243 CONTINUE
3351	244 CONTINUE
3352	C
3353	C
3354	C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION
3355	C ------------------------------------------
3356	C
3357	250 CONTINUE
3358	C
3359	DO 254 JK1 = 1 , KFLEV
3360	DO 251 JL = 1, KDLON
3361	ZCLEAR(JL)=1.
3362	ZCLOUD(JL)=0.
3363	251 CONTINUE
3364	DO 253 JK = JK1 , KFLEV
3365	DO 252 JL = 1, KDLON
3366	IF (NOVLP.EQ.1) THEN
3367	c* maximum-random
3368	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
3369	* /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3370	ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3371	ZCLOUD(JL) = PCLDLD(JL,JK)
3372	ELSE IF (NOVLP.EQ.2) THEN
3373	c* maximum
3374	ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
3375	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3376	ELSE IF (NOVLP.EQ.3) THEN
3377	c* random
3378	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
3379	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3380	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3381	END IF
3382	252 CONTINUE
3383	253 CONTINUE
3384	254 CONTINUE
3385	C
3386	C
3387	C
3388	C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
3389	C ----------------------------------------------
3390	C
3391	300 CONTINUE
3392	C
3393	C* 3.1 DOWNWARD FLUXES
3394	C ---------------
3395	C
3396	310 CONTINUE
3397	C
3398	DO 311 JL = 1, KDLON
3399	PFLUX(JL,2,KFLEV+1) = 0.
3400	311 CONTINUE
3401	C
3402	DO 317 JK1 = KFLEV , 1 , -1
3403	C
3404	C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3405	C
3406	DO 312 JL = 1, KDLON
3407	ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
3408	312 CONTINUE
3409	C
3410	C* CONTRIBUTION FROM ADJACENT CLOUD
3411	C
3412	DO 313 JL = 1, KDLON
3413	ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
3414	313 CONTINUE
3415	C
3416	C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3417	C
3418	DO 315 JK = KFLEV-1 , JK1 , -1
3419	DO 314 JL = 1, KDLON
3420	ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
3421	ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
3422	314 CONTINUE
3423	315 CONTINUE
3424	C
3425	DO 316 JL = 1, KDLON
3426	PFLUX(JL,2,JK1) = ZFD (JL)
3427	316 CONTINUE
3428	C
3429	317 CONTINUE
3430	C
3431	C
3432	C
3433	C
3434	C* 3.2 UPWARD FLUX AT THE SURFACE
3435	C --------------------------
3436	C
3437	320 CONTINUE
3438	C
3439	DO 321 JL = 1, KDLON
3440	PFLUX(JL,1,1) = PEMIS(JL)PBSUIN(JL)-(1.-PEMIS(JL))PFLUX(JL,2,1)
3441	321 CONTINUE
3442	C
3443	C
3444	C
3445	C* 3.3 UPWARD FLUXES
3446	C -------------
3447	C
3448	330 CONTINUE
3449	C
3450	DO 337 JK1 = 2 , KFLEV+1
3451	C
3452	C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3453	C
3454	DO 332 JL = 1, KDLON
3455	ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
3456	332 CONTINUE
3457	C
3458	C* CONTRIBUTION FROM ADJACENT CLOUD
3459	C
3460	DO 333 JL = 1, KDLON
3461	ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
3462	333 CONTINUE
3463	C
3464	C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3465	C
3466	DO 335 JK = 2 , JK1-1
3467	DO 334 JL = 1, KDLON
3468	ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
3469	ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1)
3470	334 CONTINUE
3471	335 CONTINUE
3472	C
3473	DO 336 JL = 1, KDLON
3474	PFLUX(JL,1,JK1) = ZFU (JL)
3475	336 CONTINUE
3476	C
3477	337 CONTINUE
3478	C
3479	C
3480	END IF
3481	C
3482	C
3483	C* 2.3 END OF CLOUD EFFECT COMPUTATIONS
3484	C
3485	230 CONTINUE
3486	C
3487	IF (.NOT.LEVOIGT) THEN
3488	DO 231 JL = 1, KDLON
3489	ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
3490	231 CONTINUE
3491	DO 233 JK = KLIM+1 , KFLEV+1
3492	DO 232 JL = 1, KDLON
3493	ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
3494	PFLUX(JL,1,JK) = ZFN10(JL)
3495	PFLUX(JL,2,JK) = 0.0
3496	232 CONTINUE
3497	233 CONTINUE
3498	ENDIF
3499	C
3500	RETURN
3501	END
3502	SUBROUTINE LWB_LMDAR4(PDT0,PTAVE,PTL
3503	S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
3504	S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
3505	USE dimphy
3506	IMPLICIT none
3507	cym#include "dimensions.h"
3508	cym#include "dimphy.h"
3509	cym#include "raddim.h"
3510	#include "raddimlw.h"
3511	C
3512	C-----------------------------------------------------------------------
3513	C PURPOSE.
3514	C --------
3515	C COMPUTES PLANCK FUNCTIONS
3516	C
3517	C EXPLICIT ARGUMENTS :
3518	C --------------------
3519	C ==== INPUTS ===
3520	C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY
3521	C PTAVE : (KDLON,KFLEV) ; TEMPERATURE
3522	C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE
3523	C ==== OUTPUTS ===
3524	C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
3525	C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION
3526	C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3527	C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION
3528	C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION
3529	C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
3530	C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3531	C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3532	C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS
3533	C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS
3534	C
3535	C IMPLICIT ARGUMENTS : NONE
3536	C --------------------
3537	C
3538	C METHOD.
3539	C -------
3540	C
3541	C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
3542	C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
3543	C
3544	C REFERENCE.
3545	C ----------
3546	C
3547	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3548	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS "
3549	C
3550	C AUTHOR.
3551	C -------
3552	C JEAN-JACQUES MORCRETTE ECMWF
3553	C
3554	C MODIFICATIONS.
3555	C --------------
3556	C ORIGINAL : 89-07-14
3557	C
3558	C-----------------------------------------------------------------------
3559	C
3560	C ARGUMENTS:
3561	C
3562	REAL*8 PDT0(KDLON)
3563	REAL*8 PTAVE(KDLON,KFLEV)
3564	REAL*8 PTL(KDLON,KFLEV+1)
3565	C
3566	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
3567	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3568	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3569	REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
3570	REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
3571	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
3572	REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3573	REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3574	REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3575	REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3576	REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3577	REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3578	C
3579	C-------------------------------------------------------------------------
3580	C* LOCAL VARIABLES:
3581	INTEGER INDB(KDLON),INDS(KDLON)
3582	REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
3583	REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
3584	c
3585	INTEGER jk, jl, ic, jnu, jf, jg
3586	INTEGER jk1, jk2
3587	INTEGER k, j, ixtox, indto, ixtx, indt
3588	INTEGER indsu, indtp
3589	REAL*8 zdsto1, zdstox, zdst1, zdstx
3590	c
3591	C* Quelques parametres:
3592	REAL*8 TSTAND
3593	PARAMETER (TSTAND=250.0)
3594	REAL*8 TSTP
3595	PARAMETER (TSTP=12.5)
3596	INTEGER MXIXT
3597	PARAMETER (MXIXT=10)
3598	C
3599	C* Used Data Block:
3600	REAL*8 TINTP(11)
3601	SAVE TINTP
3602	c$OMP THREADPRIVATE(TINTP)
3603	REAL*8 GA(11,16,3), GB(11,16,3)
3604	SAVE GA, GB
3605	c$OMP THREADPRIVATE(GA, GB)
3606	REAL*8 XP(6,6)
3607	SAVE XP
3608	c$OMP THREADPRIVATE(XP)
3609	c
3610	DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
3611	S 262.5, 275., 287.5, 300., 312.5 /
3612	C-----------------------------------------------------------------------
3613	C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
3614	C
3615	C
3616	C
3617	C
3618	C-- R.D. -- G = - 0.2 SLA
3619	C
3620	C
3621	C----- INTERVAL = 1 ----- T = 187.5
3622	C
3623	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3624	DATA (GA( 1, 1,IC),IC=1,3) /
3625	S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
3626	DATA (GB( 1, 1,IC),IC=1,3) /
3627	S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
3628	DATA (GA( 1, 2,IC),IC=1,3) /
3629	S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
3630	DATA (GB( 1, 2,IC),IC=1,3) /
3631	S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
3632	C
3633	C----- INTERVAL = 1 ----- T = 200.0
3634	C
3635	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3636	DATA (GA( 2, 1,IC),IC=1,3) /
3637	S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
3638	DATA (GB( 2, 1,IC),IC=1,3) /
3639	S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
3640	DATA (GA( 2, 2,IC),IC=1,3) /
3641	S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
3642	DATA (GB( 2, 2,IC),IC=1,3) /
3643	S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
3644	C
3645	C----- INTERVAL = 1 ----- T = 212.5
3646	C
3647	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3648	DATA (GA( 3, 1,IC),IC=1,3) /
3649	S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
3650	DATA (GB( 3, 1,IC),IC=1,3) /
3651	S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
3652	DATA (GA( 3, 2,IC),IC=1,3) /
3653	S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
3654	DATA (GB( 3, 2,IC),IC=1,3) /
3655	S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
3656	C
3657	C----- INTERVAL = 1 ----- T = 225.0
3658	C
3659	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3660	DATA (GA( 4, 1,IC),IC=1,3) /
3661	S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
3662	DATA (GB( 4, 1,IC),IC=1,3) /
3663	S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
3664	DATA (GA( 4, 2,IC),IC=1,3) /
3665	S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
3666	DATA (GB( 4, 2,IC),IC=1,3) /
3667	S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
3668	C
3669	C----- INTERVAL = 1 ----- T = 237.5
3670	C
3671	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3672	DATA (GA( 5, 1,IC),IC=1,3) /
3673	S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
3674	DATA (GB( 5, 1,IC),IC=1,3) /
3675	S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
3676	DATA (GA( 5, 2,IC),IC=1,3) /
3677	S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
3678	DATA (GB( 5, 2,IC),IC=1,3) /
3679	S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
3680	C
3681	C----- INTERVAL = 1 ----- T = 250.0
3682	C
3683	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3684	DATA (GA( 6, 1,IC),IC=1,3) /
3685	S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
3686	DATA (GB( 6, 1,IC),IC=1,3) /
3687	S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
3688	DATA (GA( 6, 2,IC),IC=1,3) /
3689	S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
3690	DATA (GB( 6, 2,IC),IC=1,3) /
3691	S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
3692	C
3693	C----- INTERVAL = 1 ----- T = 262.5
3694	C
3695	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3696	DATA (GA( 7, 1,IC),IC=1,3) /
3697	S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
3698	DATA (GB( 7, 1,IC),IC=1,3) /
3699	S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
3700	DATA (GA( 7, 2,IC),IC=1,3) /
3701	S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
3702	DATA (GB( 7, 2,IC),IC=1,3) /
3703	S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
3704	C
3705	C----- INTERVAL = 1 ----- T = 275.0
3706	C
3707	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3708	DATA (GA( 8, 1,IC),IC=1,3) /
3709	S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
3710	DATA (GB( 8, 1,IC),IC=1,3) /
3711	S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
3712	DATA (GA( 8, 2,IC),IC=1,3) /
3713	S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
3714	DATA (GB( 8, 2,IC),IC=1,3) /
3715	S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
3716	C
3717	C----- INTERVAL = 1 ----- T = 287.5
3718	C
3719	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3720	DATA (GA( 9, 1,IC),IC=1,3) /
3721	S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
3722	DATA (GB( 9, 1,IC),IC=1,3) /
3723	S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
3724	DATA (GA( 9, 2,IC),IC=1,3) /
3725	S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
3726	DATA (GB( 9, 2,IC),IC=1,3) /
3727	S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
3728	C
3729	C----- INTERVAL = 1 ----- T = 300.0
3730	C
3731	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3732	DATA (GA(10, 1,IC),IC=1,3) /
3733	S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
3734	DATA (GB(10, 1,IC),IC=1,3) /
3735	S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
3736	DATA (GA(10, 2,IC),IC=1,3) /
3737	S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
3738	DATA (GB(10, 2,IC),IC=1,3) /
3739	S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
3740	C
3741	C----- INTERVAL = 1 ----- T = 312.5
3742	C
3743	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3744	DATA (GA(11, 1,IC),IC=1,3) /
3745	S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
3746	DATA (GB(11, 1,IC),IC=1,3) /
3747	S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
3748	DATA (GA(11, 2,IC),IC=1,3) /
3749	S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
3750	DATA (GB(11, 2,IC),IC=1,3) /
3751	S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
3752	C
3753	C
3754	C
3755	C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
3756	C
3757	C
3758	C
3759	C
3760	C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U )
3761	C
3762	C
3763	C----- INTERVAL = 2 ----- T = 187.5
3764	C
3765	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3766	DATA (GA( 1, 3,IC),IC=1,3) /
3767	S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
3768	DATA (GB( 1, 3,IC),IC=1,3) /
3769	S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
3770	DATA (GA( 1, 4,IC),IC=1,3) /
3771	S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
3772	DATA (GB( 1, 4,IC),IC=1,3) /
3773	S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
3774	C
3775	C----- INTERVAL = 2 ----- T = 200.0
3776	C
3777	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3778	DATA (GA( 2, 3,IC),IC=1,3) /
3779	S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
3780	DATA (GB( 2, 3,IC),IC=1,3) /
3781	S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
3782	DATA (GA( 2, 4,IC),IC=1,3) /
3783	S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
3784	DATA (GB( 2, 4,IC),IC=1,3) /
3785	S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
3786	C
3787	C----- INTERVAL = 2 ----- T = 212.5
3788	C
3789	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3790	DATA (GA( 3, 3,IC),IC=1,3) /
3791	S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
3792	DATA (GB( 3, 3,IC),IC=1,3) /
3793	S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
3794	DATA (GA( 3, 4,IC),IC=1,3) /
3795	S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
3796	DATA (GB( 3, 4,IC),IC=1,3) /
3797	S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
3798	C
3799	C----- INTERVAL = 2 ----- T = 225.0
3800	C
3801	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3802	DATA (GA( 4, 3,IC),IC=1,3) /
3803	S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
3804	DATA (GB( 4, 3,IC),IC=1,3) /
3805	S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
3806	DATA (GA( 4, 4,IC),IC=1,3) /
3807	S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
3808	DATA (GB( 4, 4,IC),IC=1,3) /
3809	S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
3810	C
3811	C----- INTERVAL = 2 ----- T = 237.5
3812	C
3813	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3814	DATA (GA( 5, 3,IC),IC=1,3) /
3815	S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
3816	DATA (GB( 5, 3,IC),IC=1,3) /
3817	S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
3818	DATA (GA( 5, 4,IC),IC=1,3) /
3819	S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
3820	DATA (GB( 5, 4,IC),IC=1,3) /
3821	S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
3822	C
3823	C----- INTERVAL = 2 ----- T = 250.0
3824	C
3825	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3826	DATA (GA( 6, 3,IC),IC=1,3) /
3827	S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
3828	DATA (GB( 6, 3,IC),IC=1,3) /
3829	S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
3830	DATA (GA( 6, 4,IC),IC=1,3) /
3831	S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
3832	DATA (GB( 6, 4,IC),IC=1,3) /
3833	S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
3834	C
3835	C----- INTERVAL = 2 ----- T = 262.5
3836	C
3837	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3838	DATA (GA( 7, 3,IC),IC=1,3) /
3839	S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
3840	DATA (GB( 7, 3,IC),IC=1,3) /
3841	S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
3842	DATA (GA( 7, 4,IC),IC=1,3) /
3843	S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
3844	DATA (GB( 7, 4,IC),IC=1,3) /
3845	S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
3846	C
3847	C----- INTERVAL = 2 ----- T = 275.0
3848	C
3849	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3850	DATA (GA( 8, 3,IC),IC=1,3) /
3851	S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
3852	DATA (GB( 8, 3,IC),IC=1,3) /
3853	S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
3854	DATA (GA( 8, 4,IC),IC=1,3) /
3855	S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
3856	DATA (GB( 8, 4,IC),IC=1,3) /
3857	S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
3858	C
3859	C----- INTERVAL = 2 ----- T = 287.5
3860	C
3861	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3862	DATA (GA( 9, 3,IC),IC=1,3) /
3863	S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
3864	DATA (GB( 9, 3,IC),IC=1,3) /
3865	S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
3866	DATA (GA( 9, 4,IC),IC=1,3) /
3867	S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
3868	DATA (GB( 9, 4,IC),IC=1,3) /
3869	S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
3870	C
3871	C----- INTERVAL = 2 ----- T = 300.0
3872	C
3873	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3874	DATA (GA(10, 3,IC),IC=1,3) /
3875	S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
3876	DATA (GB(10, 3,IC),IC=1,3) /
3877	S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
3878	DATA (GA(10, 4,IC),IC=1,3) /
3879	S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
3880	DATA (GB(10, 4,IC),IC=1,3) /
3881	S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
3882	C
3883	C----- INTERVAL = 2 ----- T = 312.5
3884	C
3885	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3886	DATA (GA(11, 3,IC),IC=1,3) /
3887	S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
3888	DATA (GB(11, 3,IC),IC=1,3) /
3889	S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
3890	DATA (GA(11, 4,IC),IC=1,3) /
3891	S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
3892	DATA (GB(11, 4,IC),IC=1,3) /
3893	S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
3894	C
3895	C
3896	C
3897	C
3898	C
3899	C
3900	C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
3901	C
3902	C
3903	C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
3904	C
3905	C
3906	C
3907	C--- G = 3.875E-03 ---------------
3908	C
3909	C----- INTERVAL = 3 ----- T = 187.5
3910	C
3911	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3912	DATA (GA( 1, 7,IC),IC=1,3) /
3913	S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
3914	DATA (GB( 1, 7,IC),IC=1,3) /
3915	S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
3916	DATA (GA( 1, 8,IC),IC=1,3) /
3917	S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
3918	DATA (GB( 1, 8,IC),IC=1,3) /
3919	S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
3920	C
3921	C----- INTERVAL = 3 ----- T = 200.0
3922	C
3923	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3924	DATA (GA( 2, 7,IC),IC=1,3) /
3925	S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
3926	DATA (GB( 2, 7,IC),IC=1,3) /
3927	S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
3928	DATA (GA( 2, 8,IC),IC=1,3) /
3929	S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
3930	DATA (GB( 2, 8,IC),IC=1,3) /
3931	S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
3932	C
3933	C----- INTERVAL = 3 ----- T = 212.5
3934	C
3935	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3936	DATA (GA( 3, 7,IC),IC=1,3) /
3937	S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
3938	DATA (GB( 3, 7,IC),IC=1,3) /
3939	S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
3940	DATA (GA( 3, 8,IC),IC=1,3) /
3941	S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
3942	DATA (GB( 3, 8,IC),IC=1,3) /
3943	S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
3944	C
3945	C----- INTERVAL = 3 ----- T = 225.0
3946	C
3947	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3948	DATA (GA( 4, 7,IC),IC=1,3) /
3949	S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
3950	DATA (GB( 4, 7,IC),IC=1,3) /
3951	S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
3952	DATA (GA( 4, 8,IC),IC=1,3) /
3953	S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
3954	DATA (GB( 4, 8,IC),IC=1,3) /
3955	S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
3956	C
3957	C----- INTERVAL = 3 ----- T = 237.5
3958	C
3959	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3960	DATA (GA( 5, 7,IC),IC=1,3) /
3961	S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
3962	DATA (GB( 5, 7,IC),IC=1,3) /
3963	S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
3964	DATA (GA( 5, 8,IC),IC=1,3) /
3965	S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
3966	DATA (GB( 5, 8,IC),IC=1,3) /
3967	S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
3968	C
3969	C----- INTERVAL = 3 ----- T = 250.0
3970	C
3971	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3972	DATA (GA( 6, 7,IC),IC=1,3) /
3973	S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
3974	DATA (GB( 6, 7,IC),IC=1,3) /
3975	S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
3976	DATA (GA( 6, 8,IC),IC=1,3) /
3977	S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
3978	DATA (GB( 6, 8,IC),IC=1,3) /
3979	S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
3980	C
3981	C----- INTERVAL = 3 ----- T = 262.5
3982	C
3983	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3984	DATA (GA( 7, 7,IC),IC=1,3) /
3985	S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
3986	DATA (GB( 7, 7,IC),IC=1,3) /
3987	S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
3988	DATA (GA( 7, 8,IC),IC=1,3) /
3989	S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
3990	DATA (GB( 7, 8,IC),IC=1,3) /
3991	S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
3992	C
3993	C----- INTERVAL = 3 ----- T = 275.0
3994	C
3995	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3996	DATA (GA( 8, 7,IC),IC=1,3) /
3997	S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
3998	DATA (GB( 8, 7,IC),IC=1,3) /
3999	S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
4000	DATA (GA( 8, 8,IC),IC=1,3) /
4001	S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
4002	DATA (GB( 8, 8,IC),IC=1,3) /
4003	S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
4004	C
4005	C----- INTERVAL = 3 ----- T = 287.5
4006	C
4007	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4008	DATA (GA( 9, 7,IC),IC=1,3) /
4009	S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
4010	DATA (GB( 9, 7,IC),IC=1,3) /
4011	S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
4012	DATA (GA( 9, 8,IC),IC=1,3) /
4013	S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
4014	DATA (GB( 9, 8,IC),IC=1,3) /
4015	S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
4016	C
4017	C----- INTERVAL = 3 ----- T = 300.0
4018	C
4019	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4020	DATA (GA(10, 7,IC),IC=1,3) /
4021	S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
4022	DATA (GB(10, 7,IC),IC=1,3) /
4023	S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
4024	DATA (GA(10, 8,IC),IC=1,3) /
4025	S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
4026	DATA (GB(10, 8,IC),IC=1,3) /
4027	S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
4028	C
4029	C----- INTERVAL = 3 ----- T = 312.5
4030	C
4031	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4032	DATA (GA(11, 7,IC),IC=1,3) /
4033	S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
4034	DATA (GB(11, 7,IC),IC=1,3) /
4035	S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
4036	DATA (GA(11, 8,IC),IC=1,3) /
4037	S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
4038	DATA (GB(11, 8,IC),IC=1,3) /
4039	S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
4040	C
4041	C
4042	C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
4043	C
4044	C-- G = 3.6E-03
4045	C
4046	C----- INTERVAL = 4 ----- T = 187.5
4047	C
4048	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4049	DATA (GA( 1, 9,IC),IC=1,3) /
4050	S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
4051	DATA (GB( 1, 9,IC),IC=1,3) /
4052	S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
4053	DATA (GA( 1,10,IC),IC=1,3) /
4054	S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
4055	DATA (GB( 1,10,IC),IC=1,3) /
4056	S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
4057	C
4058	C----- INTERVAL = 4 ----- T = 200.0
4059	C
4060	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4061	DATA (GA( 2, 9,IC),IC=1,3) /
4062	S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
4063	DATA (GB( 2, 9,IC),IC=1,3) /
4064	S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
4065	DATA (GA( 2,10,IC),IC=1,3) /
4066	S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
4067	DATA (GB( 2,10,IC),IC=1,3) /
4068	S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
4069	C
4070	C----- INTERVAL = 4 ----- T = 212.5
4071	C
4072	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4073	DATA (GA( 3, 9,IC),IC=1,3) /
4074	S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
4075	DATA (GB( 3, 9,IC),IC=1,3) /
4076	S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
4077	DATA (GA( 3,10,IC),IC=1,3) /
4078	S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
4079	DATA (GB( 3,10,IC),IC=1,3) /
4080	S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
4081	C
4082	C----- INTERVAL = 4 ----- T = 225.0
4083	C
4084	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4085	DATA (GA( 4, 9,IC),IC=1,3) /
4086	S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
4087	DATA (GB( 4, 9,IC),IC=1,3) /
4088	S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
4089	DATA (GA( 4,10,IC),IC=1,3) /
4090	S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
4091	DATA (GB( 4,10,IC),IC=1,3) /
4092	S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
4093	C
4094	C----- INTERVAL = 4 ----- T = 237.5
4095	C
4096	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4097	DATA (GA( 5, 9,IC),IC=1,3) /
4098	S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
4099	DATA (GB( 5, 9,IC),IC=1,3) /
4100	S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
4101	DATA (GA( 5,10,IC),IC=1,3) /
4102	S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
4103	DATA (GB( 5,10,IC),IC=1,3) /
4104	S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
4105	C
4106	C----- INTERVAL = 4 ----- T = 250.0
4107	C
4108	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4109	DATA (GA( 6, 9,IC),IC=1,3) /
4110	S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
4111	DATA (GB( 6, 9,IC),IC=1,3) /
4112	S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
4113	DATA (GA( 6,10,IC),IC=1,3) /
4114	S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
4115	DATA (GB( 6,10,IC),IC=1,3) /
4116	S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
4117	C
4118	C----- INTERVAL = 4 ----- T = 262.5
4119	C
4120	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4121	DATA (GA( 7, 9,IC),IC=1,3) /
4122	S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
4123	DATA (GB( 7, 9,IC),IC=1,3) /
4124	S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
4125	DATA (GA( 7,10,IC),IC=1,3) /
4126	S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
4127	DATA (GB( 7,10,IC),IC=1,3) /
4128	S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
4129	C
4130	C----- INTERVAL = 4 ----- T = 275.0
4131	C
4132	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4133	DATA (GA( 8, 9,IC),IC=1,3) /
4134	S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
4135	DATA (GB( 8, 9,IC),IC=1,3) /
4136	S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
4137	DATA (GA( 8,10,IC),IC=1,3) /
4138	S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
4139	DATA (GB( 8,10,IC),IC=1,3) /
4140	S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
4141	C
4142	C----- INTERVAL = 4 ----- T = 287.5
4143	C
4144	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4145	DATA (GA( 9, 9,IC),IC=1,3) /
4146	S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
4147	DATA (GB( 9, 9,IC),IC=1,3) /
4148	S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
4149	DATA (GA( 9,10,IC),IC=1,3) /
4150	S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
4151	DATA (GB( 9,10,IC),IC=1,3) /
4152	S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
4153	C
4154	C----- INTERVAL = 4 ----- T = 300.0
4155	C
4156	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4157	DATA (GA(10, 9,IC),IC=1,3) /
4158	S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
4159	DATA (GB(10, 9,IC),IC=1,3) /
4160	S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
4161	DATA (GA(10,10,IC),IC=1,3) /
4162	S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
4163	DATA (GB(10,10,IC),IC=1,3) /
4164	S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
4165	C
4166	C----- INTERVAL = 4 ----- T = 312.5
4167	C
4168	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4169	DATA (GA(11, 9,IC),IC=1,3) /
4170	S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
4171	DATA (GB(11, 9,IC),IC=1,3) /
4172	S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
4173	DATA (GA(11,10,IC),IC=1,3) /
4174	S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
4175	DATA (GB(11,10,IC),IC=1,3) /
4176	S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
4177	C
4178	C
4179	C
4180	C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ----
4181	C
4182	C-- WATER VAPOR --- 350 - 500 CM-1
4183	C
4184	C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
4185	C
4186	C----- INTERVAL = 5 ----- T = 187.5
4187	C
4188	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4189	DATA (GA( 1, 5,IC),IC=1,3) /
4190	S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
4191	DATA (GB( 1, 5,IC),IC=1,3) /
4192	S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
4193	DATA (GA( 1, 6,IC),IC=1,3) /
4194	S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
4195	DATA (GB( 1, 6,IC),IC=1,3) /
4196	S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
4197	C
4198	C----- INTERVAL = 5 ----- T = 200.0
4199	C
4200	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4201	DATA (GA( 2, 5,IC),IC=1,3) /
4202	S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
4203	DATA (GB( 2, 5,IC),IC=1,3) /
4204	S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
4205	DATA (GA( 2, 6,IC),IC=1,3) /
4206	S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
4207	DATA (GB( 2, 6,IC),IC=1,3) /
4208	S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
4209	C
4210	C----- INTERVAL = 5 ----- T = 212.5
4211	C
4212	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4213	DATA (GA( 3, 5,IC),IC=1,3) /
4214	S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
4215	DATA (GB( 3, 5,IC),IC=1,3) /
4216	S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
4217	DATA (GA( 3, 6,IC),IC=1,3) /
4218	S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
4219	DATA (GB( 3, 6,IC),IC=1,3) /
4220	S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
4221	C
4222	C----- INTERVAL = 5 ----- T = 225.0
4223	C
4224	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4225	DATA (GA( 4, 5,IC),IC=1,3) /
4226	S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
4227	DATA (GB( 4, 5,IC),IC=1,3) /
4228	S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
4229	DATA (GA( 4, 6,IC),IC=1,3) /
4230	S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
4231	DATA (GB( 4, 6,IC),IC=1,3) /
4232	S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
4233	C
4234	C----- INTERVAL = 5 ----- T = 237.5
4235	C
4236	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4237	DATA (GA( 5, 5,IC),IC=1,3) /
4238	S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
4239	DATA (GB( 5, 5,IC),IC=1,3) /
4240	S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
4241	DATA (GA( 5, 6,IC),IC=1,3) /
4242	S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
4243	DATA (GB( 5, 6,IC),IC=1,3) /
4244	S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
4245	C
4246	C----- INTERVAL = 5 ----- T = 250.0
4247	C
4248	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4249	DATA (GA( 6, 5,IC),IC=1,3) /
4250	S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
4251	DATA (GB( 6, 5,IC),IC=1,3) /
4252	S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
4253	DATA (GA( 6, 6,IC),IC=1,3) /
4254	S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
4255	DATA (GB( 6, 6,IC),IC=1,3) /
4256	S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
4257	C
4258	C----- INTERVAL = 5 ----- T = 262.5
4259	C
4260	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4261	DATA (GA( 7, 5,IC),IC=1,3) /
4262	S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
4263	DATA (GB( 7, 5,IC),IC=1,3) /
4264	S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
4265	DATA (GA( 7, 6,IC),IC=1,3) /
4266	S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
4267	DATA (GB( 7, 6,IC),IC=1,3) /
4268	S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
4269	C
4270	C----- INTERVAL = 5 ----- T = 275.0
4271	C
4272	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4273	DATA (GA( 8, 5,IC),IC=1,3) /
4274	S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
4275	DATA (GB( 8, 5,IC),IC=1,3) /
4276	S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
4277	DATA (GA( 8, 6,IC),IC=1,3) /
4278	S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
4279	DATA (GB( 8, 6,IC),IC=1,3) /
4280	S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
4281	C
4282	C----- INTERVAL = 5 ----- T = 287.5
4283	C
4284	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4285	DATA (GA( 9, 5,IC),IC=1,3) /
4286	S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
4287	DATA (GB( 9, 5,IC),IC=1,3) /
4288	S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
4289	DATA (GA( 9, 6,IC),IC=1,3) /
4290	S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
4291	DATA (GB( 9, 6,IC),IC=1,3) /
4292	S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
4293	C
4294	C----- INTERVAL = 5 ----- T = 300.0
4295	C
4296	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4297	DATA (GA(10, 5,IC),IC=1,3) /
4298	S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
4299	DATA (GB(10, 5,IC),IC=1,3) /
4300	S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
4301	DATA (GA(10, 6,IC),IC=1,3) /
4302	S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
4303	DATA (GB(10, 6,IC),IC=1,3) /
4304	S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
4305	C
4306	C----- INTERVAL = 5 ----- T = 312.5
4307	C
4308	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4309	DATA (GA(11, 5,IC),IC=1,3) /
4310	S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
4311	DATA (GB(11, 5,IC),IC=1,3) /
4312	S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
4313	DATA (GA(11, 6,IC),IC=1,3) /
4314	S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
4315	DATA (GB(11, 6,IC),IC=1,3) /
4316	S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
4317	C
4318	C
4319	C
4320	C
4321	C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
4322	C--- G = 0.0
4323	C
4324	C
4325	C----- INTERVAL = 6 ----- T = 187.5
4326	C
4327	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4328	DATA (GA( 1,11,IC),IC=1,3) /
4329	S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
4330	DATA (GB( 1,11,IC),IC=1,3) /
4331	S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
4332	DATA (GA( 1,12,IC),IC=1,3) /
4333	S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
4334	DATA (GB( 1,12,IC),IC=1,3) /
4335	S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
4336	C
4337	C----- INTERVAL = 6 ----- T = 200.0
4338	C
4339	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4340	DATA (GA( 2,11,IC),IC=1,3) /
4341	S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
4342	DATA (GB( 2,11,IC),IC=1,3) /
4343	S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
4344	DATA (GA( 2,12,IC),IC=1,3) /
4345	S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
4346	DATA (GB( 2,12,IC),IC=1,3) /
4347	S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
4348	C
4349	C----- INTERVAL = 6 ----- T = 212.5
4350	C
4351	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4352	DATA (GA( 3,11,IC),IC=1,3) /
4353	S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
4354	DATA (GB( 3,11,IC),IC=1,3) /
4355	S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
4356	DATA (GA( 3,12,IC),IC=1,3) /
4357	S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
4358	DATA (GB( 3,12,IC),IC=1,3) /
4359	S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
4360	C
4361	C----- INTERVAL = 6 ----- T = 225.0
4362	C
4363	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4364	DATA (GA( 4,11,IC),IC=1,3) /
4365	S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
4366	DATA (GB( 4,11,IC),IC=1,3) /
4367	S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
4368	DATA (GA( 4,12,IC),IC=1,3) /
4369	S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
4370	DATA (GB( 4,12,IC),IC=1,3) /
4371	S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
4372	C
4373	C----- INTERVAL = 6 ----- T = 237.5
4374	C
4375	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4376	DATA (GA( 5,11,IC),IC=1,3) /
4377	S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
4378	DATA (GB( 5,11,IC),IC=1,3) /
4379	S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
4380	DATA (GA( 5,12,IC),IC=1,3) /
4381	S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
4382	DATA (GB( 5,12,IC),IC=1,3) /
4383	S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
4384	C
4385	C----- INTERVAL = 6 ----- T = 250.0
4386	C
4387	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4388	DATA (GA( 6,11,IC),IC=1,3) /
4389	S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
4390	DATA (GB( 6,11,IC),IC=1,3) /
4391	S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
4392	DATA (GA( 6,12,IC),IC=1,3) /
4393	S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
4394	DATA (GB( 6,12,IC),IC=1,3) /
4395	S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
4396	C
4397	C----- INTERVAL = 6 ----- T = 262.5
4398	C
4399	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4400	DATA (GA( 7,11,IC),IC=1,3) /
4401	S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
4402	DATA (GB( 7,11,IC),IC=1,3) /
4403	S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
4404	DATA (GA( 7,12,IC),IC=1,3) /
4405	S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
4406	DATA (GB( 7,12,IC),IC=1,3) /
4407	S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
4408	C
4409	C----- INTERVAL = 6 ----- T = 275.0
4410	C
4411	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4412	DATA (GA( 8,11,IC),IC=1,3) /
4413	S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
4414	DATA (GB( 8,11,IC),IC=1,3) /
4415	S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
4416	DATA (GA( 8,12,IC),IC=1,3) /
4417	S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
4418	DATA (GB( 8,12,IC),IC=1,3) /
4419	S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
4420	C
4421	C----- INTERVAL = 6 ----- T = 287.5
4422	C
4423	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4424	DATA (GA( 9,11,IC),IC=1,3) /
4425	S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
4426	DATA (GB( 9,11,IC),IC=1,3) /
4427	S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
4428	DATA (GA( 9,12,IC),IC=1,3) /
4429	S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
4430	DATA (GB( 9,12,IC),IC=1,3) /
4431	S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
4432	C
4433	C----- INTERVAL = 6 ----- T = 300.0
4434	C
4435	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4436	DATA (GA(10,11,IC),IC=1,3) /
4437	S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
4438	DATA (GB(10,11,IC),IC=1,3) /
4439	S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
4440	DATA (GA(10,12,IC),IC=1,3) /
4441	S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
4442	DATA (GB(10,12,IC),IC=1,3) /
4443	S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
4444	C
4445	C----- INTERVAL = 6 ----- T = 312.5
4446	C
4447	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4448	DATA (GA(11,11,IC),IC=1,3) /
4449	S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
4450	DATA (GB(11,11,IC),IC=1,3) /
4451	S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
4452	DATA (GA(11,12,IC),IC=1,3) /
4453	S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
4454	DATA (GB(11,12,IC),IC=1,3) /
4455	S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
4456	C
4457	C
4458	C
4459	C
4460	C
4461	C-- END WATER VAPOR
4462	C
4463	C
4464	C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
4465	C
4466	C
4467	C
4468	C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9
4469	C
4470	C----- INTERVAL = 2 ----- T = 187.5
4471	C
4472	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4473	DATA (GA( 1,13,IC),IC=1,3) /
4474	S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
4475	DATA (GB( 1,13,IC),IC=1,3) /
4476	S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
4477	DATA (GA( 1,14,IC),IC=1,3) /
4478	S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
4479	DATA (GB( 1,14,IC),IC=1,3) /
4480	S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
4481	C
4482	C----- INTERVAL = 2 ----- T = 200.0
4483	C
4484	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4485	DATA (GA( 2,13,IC),IC=1,3) /
4486	S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
4487	DATA (GB( 2,13,IC),IC=1,3) /
4488	S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
4489	DATA (GA( 2,14,IC),IC=1,3) /
4490	S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
4491	DATA (GB( 2,14,IC),IC=1,3) /
4492	S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
4493	C
4494	C----- INTERVAL = 2 ----- T = 212.5
4495	C
4496	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4497	DATA (GA( 3,13,IC),IC=1,3) /
4498	S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
4499	DATA (GB( 3,13,IC),IC=1,3) /
4500	S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
4501	DATA (GA( 3,14,IC),IC=1,3) /
4502	S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
4503	DATA (GB( 3,14,IC),IC=1,3) /
4504	S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
4505	C
4506	C----- INTERVAL = 2 ----- T = 225.0
4507	C
4508	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4509	DATA (GA( 4,13,IC),IC=1,3) /
4510	S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
4511	DATA (GB( 4,13,IC),IC=1,3) /
4512	S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
4513	DATA (GA( 4,14,IC),IC=1,3) /
4514	S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
4515	DATA (GB( 4,14,IC),IC=1,3) /
4516	S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
4517	C
4518	C----- INTERVAL = 2 ----- T = 237.5
4519	C
4520	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4521	DATA (GA( 5,13,IC),IC=1,3) /
4522	S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
4523	DATA (GB( 5,13,IC),IC=1,3) /
4524	S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
4525	DATA (GA( 5,14,IC),IC=1,3) /
4526	S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
4527	DATA (GB( 5,14,IC),IC=1,3) /
4528	S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
4529	C
4530	C----- INTERVAL = 2 ----- T = 250.0
4531	C
4532	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4533	DATA (GA( 6,13,IC),IC=1,3) /
4534	S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
4535	DATA (GB( 6,13,IC),IC=1,3) /
4536	S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
4537	DATA (GA( 6,14,IC),IC=1,3) /
4538	S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
4539	DATA (GB( 6,14,IC),IC=1,3) /
4540	S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
4541	C
4542	C----- INTERVAL = 2 ----- T = 262.5
4543	C
4544	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4545	DATA (GA( 7,13,IC),IC=1,3) /
4546	S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
4547	DATA (GB( 7,13,IC),IC=1,3) /
4548	S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
4549	DATA (GA( 7,14,IC),IC=1,3) /
4550	S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
4551	DATA (GB( 7,14,IC),IC=1,3) /
4552	S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
4553	C
4554	C----- INTERVAL = 2 ----- T = 275.0
4555	C
4556	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4557	DATA (GA( 8,13,IC),IC=1,3) /
4558	S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
4559	DATA (GB( 8,13,IC),IC=1,3) /
4560	S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
4561	DATA (GA( 8,14,IC),IC=1,3) /
4562	S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
4563	DATA (GB( 8,14,IC),IC=1,3) /
4564	S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
4565	C
4566	C----- INTERVAL = 2 ----- T = 287.5
4567	C
4568	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4569	DATA (GA( 9,13,IC),IC=1,3) /
4570	S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
4571	DATA (GB( 9,13,IC),IC=1,3) /
4572	S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
4573	DATA (GA( 9,14,IC),IC=1,3) /
4574	S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
4575	DATA (GB( 9,14,IC),IC=1,3) /
4576	S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
4577	C
4578	C----- INTERVAL = 2 ----- T = 300.0
4579	C
4580	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4581	DATA (GA(10,13,IC),IC=1,3) /
4582	S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
4583	DATA (GB(10,13,IC),IC=1,3) /
4584	S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
4585	DATA (GA(10,14,IC),IC=1,3) /
4586	S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
4587	DATA (GB(10,14,IC),IC=1,3) /
4588	S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
4589	C
4590	C----- INTERVAL = 2 ----- T = 312.5
4591	C
4592	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4593	DATA (GA(11,13,IC),IC=1,3) /
4594	S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
4595	DATA (GB(11,13,IC),IC=1,3) /
4596	S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
4597	DATA (GA(11,14,IC),IC=1,3) /
4598	S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
4599	DATA (GB(11,14,IC),IC=1,3) /
4600	S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
4601	C
4602	C
4603	C
4604	C
4605	C
4606	C
4607	C
4608	C
4609	C
4610	C
4611	C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
4612	C
4613	C
4614	C-- G = 0.0
4615	C
4616	C
4617	C----- INTERVAL = 4 ----- T = 187.5
4618	C
4619	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4620	DATA (GA( 1,15,IC),IC=1,3) /
4621	S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
4622	DATA (GB( 1,15,IC),IC=1,3) /
4623	S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
4624	DATA (GA( 1,16,IC),IC=1,3) /
4625	S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
4626	DATA (GB( 1,16,IC),IC=1,3) /
4627	S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
4628	C
4629	C----- INTERVAL = 4 ----- T = 200.0
4630	C
4631	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4632	DATA (GA( 2,15,IC),IC=1,3) /
4633	S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
4634	DATA (GB( 2,15,IC),IC=1,3) /
4635	S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
4636	DATA (GA( 2,16,IC),IC=1,3) /
4637	S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
4638	DATA (GB( 2,16,IC),IC=1,3) /
4639	S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
4640	C
4641	C----- INTERVAL = 4 ----- T = 212.5
4642	C
4643	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4644	DATA (GA( 3,15,IC),IC=1,3) /
4645	S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
4646	DATA (GB( 3,15,IC),IC=1,3) /
4647	S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
4648	DATA (GA( 3,16,IC),IC=1,3) /
4649	S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
4650	DATA (GB( 3,16,IC),IC=1,3) /
4651	S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
4652	C
4653	C----- INTERVAL = 4 ----- T = 225.0
4654	C
4655	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4656	DATA (GA( 4,15,IC),IC=1,3) /
4657	S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
4658	DATA (GB( 4,15,IC),IC=1,3) /
4659	S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
4660	DATA (GA( 4,16,IC),IC=1,3) /
4661	S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
4662	DATA (GB( 4,16,IC),IC=1,3) /
4663	S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
4664	C
4665	C----- INTERVAL = 4 ----- T = 237.5
4666	C
4667	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4668	DATA (GA( 5,15,IC),IC=1,3) /
4669	S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
4670	DATA (GB( 5,15,IC),IC=1,3) /
4671	S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
4672	DATA (GA( 5,16,IC),IC=1,3) /
4673	S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
4674	DATA (GB( 5,16,IC),IC=1,3) /
4675	S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
4676	C
4677	C----- INTERVAL = 4 ----- T = 250.0
4678	C
4679	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4680	DATA (GA( 6,15,IC),IC=1,3) /
4681	S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
4682	DATA (GB( 6,15,IC),IC=1,3) /
4683	S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
4684	DATA (GA( 6,16,IC),IC=1,3) /
4685	S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
4686	DATA (GB( 6,16,IC),IC=1,3) /
4687	S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
4688	C
4689	C----- INTERVAL = 4 ----- T = 262.5
4690	C
4691	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4692	DATA (GA( 7,15,IC),IC=1,3) /
4693	S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
4694	DATA (GB( 7,15,IC),IC=1,3) /
4695	S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
4696	DATA (GA( 7,16,IC),IC=1,3) /
4697	S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
4698	DATA (GB( 7,16,IC),IC=1,3) /
4699	S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
4700	C
4701	C----- INTERVAL = 4 ----- T = 275.0
4702	C
4703	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4704	DATA (GA( 8,15,IC),IC=1,3) /
4705	S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
4706	DATA (GB( 8,15,IC),IC=1,3) /
4707	S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
4708	DATA (GA( 8,16,IC),IC=1,3) /
4709	S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
4710	DATA (GB( 8,16,IC),IC=1,3) /
4711	S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
4712	C
4713	C----- INTERVAL = 4 ----- T = 287.5
4714	C
4715	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4716	DATA (GA( 9,15,IC),IC=1,3) /
4717	S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
4718	DATA (GB( 9,15,IC),IC=1,3) /
4719	S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
4720	DATA (GA( 9,16,IC),IC=1,3) /
4721	S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
4722	DATA (GB( 9,16,IC),IC=1,3) /
4723	S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
4724	C
4725	C----- INTERVAL = 4 ----- T = 300.0
4726	C
4727	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4728	DATA (GA(10,15,IC),IC=1,3) /
4729	S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
4730	DATA (GB(10,15,IC),IC=1,3) /
4731	S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
4732	DATA (GA(10,16,IC),IC=1,3) /
4733	S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
4734	DATA (GB(10,16,IC),IC=1,3) /
4735	S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
4736	C
4737	C----- INTERVAL = 4 ----- T = 312.5
4738	C
4739	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4740	DATA (GA(11,15,IC),IC=1,3) /
4741	S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
4742	DATA (GB(11,15,IC),IC=1,3) /
4743	S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
4744	DATA (GA(11,16,IC),IC=1,3) /
4745	S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
4746	DATA (GB(11,16,IC),IC=1,3) /
4747	S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
4748
4749	C ------------------------------------------------------------------
4750	DATA (( XP( J,K),J=1,6), K=1,6) /
4751	S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
4752	S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
4753	S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
4754	S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
4755	S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
4756	S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
4757	S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
4758	S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
4759	S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
4760	S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
4761	S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
4762	S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
4763	C
4764	C
4765	C* 1.0 PLANCK FUNCTIONS AND GRADIENTS
4766	C ------------------------------
4767	C
4768	100 CONTINUE
4769	C
4770	DO 102 JK = 1 , KFLEV+1
4771	DO 101 JL = 1, KDLON
4772	PBINT(JL,JK) = 0.
4773	101 CONTINUE
4774	102 CONTINUE
4775	DO 103 JL = 1, KDLON
4776	PBSUIN(JL) = 0.
4777	103 CONTINUE
4778	C
4779	DO 141 JNU=1,Ninter
4780	C
4781	C
4782	C* 1.1 LEVELS FROM SURFACE TO KFLEV
4783	C ----------------------------
4784	C
4785	110 CONTINUE
4786	C
4787	DO 112 JK = 1 , KFLEV
4788	DO 111 JL = 1, KDLON
4789	ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
4790	ZRES(JL) = XP(1,JNU)+ZTI(JL)(XP(2,JNU)+ZTI(JL)(XP(3,JNU)
4791	S +ZTI(JL)(XP(4,JNU)+ZTI(JL)(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
4792	S )))))
4793	PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
4794	PB(JL,JNU,JK)= ZRES(JL)
4795	ZBLEV(JL,JK) = ZRES(JL)
4796	ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
4797	ZRES2(JL)=XP(1,JNU)+ZTI2(JL)(XP(2,JNU)+ZTI2(JL)(XP(3,JNU)
4798	S +ZTI2(JL)(XP(4,JNU)+ZTI2(JL)(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
4799	S )))))
4800	ZBLAY(JL,JK) = ZRES2(JL)
4801	111 CONTINUE
4802	112 CONTINUE
4803	C
4804	C
4805	C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE
4806	C ---------------------------------
4807	C
4808	120 CONTINUE
4809	C
4810	DO 121 JL = 1, KDLON
4811	ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
4812	ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
4813	ZRES(JL) = XP(1,JNU)+ZTI(JL)(XP(2,JNU)+ZTI(JL)(XP(3,JNU)
4814	S +ZTI(JL)(XP(4,JNU)+ZTI(JL)(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
4815	S )))))
4816	ZRES2(JL) = XP(1,JNU)+ZTI2(JL)(XP(2,JNU)+ZTI2(JL)(XP(3,JNU)
4817	S +ZTI2(JL)(XP(4,JNU)+ZTI2(JL)(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
4818	S )))))
4819	PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
4820	PB(JL,JNU,KFLEV+1)= ZRES(JL)
4821	ZBLEV(JL,KFLEV+1) = ZRES(JL)
4822	PBTOP(JL,JNU) = ZRES(JL)
4823	PBSUR(JL,JNU) = ZRES2(JL)
4824	PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
4825	121 CONTINUE
4826	C
4827	C
4828	C* 1.3 GRADIENTS IN SUB-LAYERS
4829	C -----------------------
4830	C
4831	130 CONTINUE
4832	C
4833	DO 132 JK = 1 , KFLEV
4834	JK2 = 2 * JK
4835	JK1 = JK2 - 1
4836	DO 131 JL = 1, KDLON
4837	PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK)
4838	PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
4839	131 CONTINUE
4840	132 CONTINUE
4841	C
4842	141 CONTINUE
4843	C
4844	C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
4845	C ---------------------------------------------
4846	C
4847	200 CONTINUE
4848	C
4849	C
4850	210 CONTINUE
4851	C
4852	DO 211 JL=1, KDLON
4853	ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
4854	IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
4855	ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
4856	IF (ZDSTOX.LT.0.5) THEN
4857	INDTO=IXTOX
4858	ELSE
4859	INDTO=IXTOX+1
4860	END IF
4861	INDB(JL)=INDTO
4862	ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
4863	IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
4864	ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
4865	IF (ZDSTX.LT.0.5) THEN
4866	INDT=IXTX
4867	ELSE
4868	INDT=IXTX+1
4869	END IF
4870	INDS(JL)=INDT
4871	211 CONTINUE
4872	C
4873	DO 214 JF=1,2
4874	DO 213 JG=1, 8
4875	DO 212 JL=1, KDLON
4876	INDSU=INDS(JL)
4877	PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
4878	PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
4879	INDTP=INDB(JL)
4880	PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
4881	PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
4882	212 CONTINUE
4883	213 CONTINUE
4884	214 CONTINUE
4885	C
4886	220 CONTINUE
4887	C
4888	DO 225 JK=1,KFLEV
4889	DO 221 JL=1, KDLON
4890	ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
4891	IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
4892	ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
4893	IF (ZDSTX.LT.0.5) THEN
4894	INDT=IXTX
4895	ELSE
4896	INDT=IXTX+1
4897	END IF
4898	INDB(JL)=INDT
4899	221 CONTINUE
4900	C
4901	DO 224 JF=1,2
4902	DO 223 JG=1, 8
4903	DO 222 JL=1, KDLON
4904	INDT=INDB(JL)
4905	PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
4906	PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
4907	222 CONTINUE
4908	223 CONTINUE
4909	224 CONTINUE
4910	225 CONTINUE
4911	C
4912	C ------------------------------------------------------------------
4913	C
4914	RETURN
4915	END
4916	SUBROUTINE LWV_LMDAR4(KUAER,KTRAER, KLIM
4917	R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
4918	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
4919	S , PCNTRB,PCTS,PFLUC)
4920	USE dimphy
4921	IMPLICIT none
4922	cym#include "dimensions.h"
4923	cym#include "dimphy.h"
4924	cym#include "raddim.h"
4925	#include "raddimlw.h"
4926	#include "YOMCST.h"
4927	C
4928	C-----------------------------------------------------------------------
4929	C PURPOSE.
4930	C --------
4931	C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
4932	C FLUXES OR RADIANCES
4933	C
4934	C METHOD.
4935	C -------
4936	C
4937	C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
4938	C CONTRIBUTIONS BY - THE NEARBY LAYERS
4939	C - THE DISTANT LAYERS
4940	C - THE BOUNDARY TERMS
4941	C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
4942	C
4943	C REFERENCE.
4944	C ----------
4945	C
4946	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
4947	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
4948	C
4949	C AUTHOR.
4950	C -------
4951	C JEAN-JACQUES MORCRETTE ECMWF
4952	C
4953	C MODIFICATIONS.
4954	C --------------
4955	C ORIGINAL : 89-07-14
4956	C-----------------------------------------------------------------------
4957	C
4958	C* ARGUMENTS:
4959	INTEGER KUAER,KTRAER, KLIM
4960	C
4961	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
4962	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
4963	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
4964	REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
4965	REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
4966	REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
4967	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
4968	REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
4969	REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
4970	REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
4971	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
4972	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
4973	REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
4974	REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
4975	REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
4976	REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
4977	C
4978	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
4979	REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
4980	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
4981	C-----------------------------------------------------------------------
4982	C LOCAL VARIABLES:
4983	REAL*8 ZADJD(KDLON,KFLEV+1)
4984	REAL*8 ZADJU(KDLON,KFLEV+1)
4985	REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
4986	REAL*8 ZDISD(KDLON,KFLEV+1)
4987	REAL*8 ZDISU(KDLON,KFLEV+1)
4988	C
4989	INTEGER jk, jl
4990	C-----------------------------------------------------------------------
4991	C
4992	DO 112 JK=1,KFLEV+1
4993	DO 111 JL=1, KDLON
4994	ZADJD(JL,JK)=0.
4995	ZADJU(JL,JK)=0.
4996	ZDISD(JL,JK)=0.
4997	ZDISU(JL,JK)=0.
4998	111 CONTINUE
4999	112 CONTINUE
5000	C
5001	DO 114 JK=1,KFLEV
5002	DO 113 JL=1, KDLON
5003	PCTS(JL,JK)=0.
5004	113 CONTINUE
5005	114 CONTINUE
5006	C
5007	C* CONTRIBUTION FROM ADJACENT LAYERS
5008	C
5009	CALL LWVN_LMDAR4(KUAER,KTRAER
5010	R , PABCU,PDBSL,PGA,PGB
5011	S , ZADJD,ZADJU,PCNTRB,ZDBDT)
5012	C* CONTRIBUTION FROM DISTANT LAYERS
5013	C
5014	CALL LWVD_LMDAR4(KUAER,KTRAER
5015	R , PABCU,ZDBDT,PGA,PGB
5016	S , PCNTRB,ZDISD,ZDISU)
5017	C
5018	C* EXCHANGE WITH THE BOUNDARIES
5019	C
5020	CALL LWVB_LMDAR4(KUAER,KTRAER, KLIM
5021	R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
5022	R , ZDISD,ZDISU,PEMIS,PPMB
5023	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5024	S , PCTS,PFLUC)
5025	C
5026	C
5027	RETURN
5028	END
5029	SUBROUTINE LWVB_LMDAR4(KUAER,KTRAER, KLIM
5030	R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
5031	R , PDISD,PDISU,PEMIS,PPMB
5032	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5033	S , PCTS,PFLUC)
5034	USE dimphy
5035	IMPLICIT none
5036	cym#include "dimensions.h"
5037	cym#include "dimphy.h"
5038	cym#include "raddim.h"
5039	#include "raddimlw.h"
5040	#include "radopt.h"
5041	C
5042	C-----------------------------------------------------------------------
5043	C PURPOSE.
5044	C --------
5045	C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
5046	C INTEGRATION
5047	C
5048	C METHOD.
5049	C -------
5050	C
5051	C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
5052	C ATMOSPHERE
5053	C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
5054	C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
5055	C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
5056	C
5057	C REFERENCE.
5058	C ----------
5059	C
5060	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5061	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5062	C
5063	C AUTHOR.
5064	C -------
5065	C JEAN-JACQUES MORCRETTE ECMWF
5066	C
5067	C MODIFICATIONS.
5068	C --------------
5069	C ORIGINAL : 89-07-14
5070	C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96
5071	C-----------------------------------------------------------------------
5072	C
5073	C* 0.1 ARGUMENTS
5074	C ---------
5075	C
5076	INTEGER KUAER,KTRAER, KLIM
5077	C
5078	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5079	REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5080	REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5081	REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
5082	REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
5083	REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
5084	REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
5085	REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
5086	REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5087	REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5088	REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
5089	REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
5090	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5091	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5092	REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5093	REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5094	REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5095	REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5096	C
5097	REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
5098	REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
5099	C
5100	C* LOCAL VARIABLES:
5101	C
5102	REAL*8 ZBGND(KDLON)
5103	REAL*8 ZFD(KDLON)
5104	REAL*8 ZFN10(KDLON)
5105	REAL*8 ZFU(KDLON)
5106	REAL*8 ZTT(KDLON,NTRA)
5107	REAL*8 ZTT1(KDLON,NTRA)
5108	REAL*8 ZTT2(KDLON,NTRA)
5109	REAL*8 ZUU(KDLON,NUA)
5110	REAL*8 ZCNSOL(KDLON)
5111	REAL*8 ZCNTOP(KDLON)
5112	C
5113	INTEGER jk, jl, ja
5114	INTEGER jstra, jstru
5115	INTEGER ind1, ind2, ind3, ind4, in, jlim
5116	REAL*8 zctstr
5117	C-----------------------------------------------------------------------
5118	C
5119	C* 1. INITIALIZATION
5120	C --------------
5121	C
5122	100 CONTINUE
5123	C
5124	C
5125	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5126	C ---------------------------------
5127	C
5128	120 CONTINUE
5129	C
5130	DO 122 JA=1,NTRA
5131	DO 121 JL=1, KDLON
5132	ZTT (JL,JA)=1.0
5133	ZTT1(JL,JA)=1.0
5134	ZTT2(JL,JA)=1.0
5135	121 CONTINUE
5136	122 CONTINUE
5137	C
5138	DO 124 JA=1,NUA
5139	DO 123 JL=1, KDLON
5140	ZUU(JL,JA)=1.0
5141	123 CONTINUE
5142	124 CONTINUE
5143	C
5144	C ------------------------------------------------------------------
5145	C
5146	C* 2. VERTICAL INTEGRATION
5147	C --------------------
5148	C
5149	200 CONTINUE
5150	C
5151	IND1=0
5152	IND3=0
5153	IND4=1
5154	IND2=1
5155	C
5156	C
5157	C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE
5158	C -----------------------------------
5159	C
5160	230 CONTINUE
5161	C
5162	DO 235 JK = 1 , KFLEV
5163	IN=(JK-1)*NG1P1+1
5164	C
5165	DO 232 JA=1,KUAER
5166	DO 231 JL=1, KDLON
5167	ZUU(JL,JA)=PABCU(JL,JA,IN)
5168	231 CONTINUE
5169	232 CONTINUE
5170	C
5171	C
5172	CALL LWTT_LMDAR4(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
5173	C
5174	DO 234 JL = 1, KDLON
5175	ZCNTOP(JL)=PBTOP(JL,1)ZTT(JL,1) ZTT(JL,10)
5176	2 +PBTOP(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5177	3 +PBTOP(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5178	4 +PBTOP(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5179	5 +PBTOP(JL,5)ZTT(JL,3) ZTT(JL,14)
5180	6 +PBTOP(JL,6)ZTT(JL,6) ZTT(JL,15)
5181	ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5182	PFLUC(JL,2,JK)=ZFD(JL)
5183	234 CONTINUE
5184	C
5185	235 CONTINUE
5186	C
5187	JK = KFLEV+1
5188	IN=(JK-1)*NG1P1+1
5189	C
5190	DO 236 JL = 1, KDLON
5191	ZCNTOP(JL)= PBTOP(JL,1)
5192	1 + PBTOP(JL,2)
5193	2 + PBTOP(JL,3)
5194	3 + PBTOP(JL,4)
5195	4 + PBTOP(JL,5)
5196	5 + PBTOP(JL,6)
5197	ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5198	PFLUC(JL,2,JK)=ZFD(JL)
5199	236 CONTINUE
5200	C
5201	C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
5202	C ---------------------------------------
5203	C
5204	240 CONTINUE
5205	C
5206	C
5207	C* 2.4.1 INITIALIZATION
5208	C --------------
5209	C
5210	2410 CONTINUE
5211	C
5212	JLIM = KFLEV
5213	C
5214	IF (.NOT.LEVOIGT) THEN
5215	DO 2412 JK = KFLEV,1,-1
5216	IF(PPMB(1,JK).LT.10.0) THEN
5217	JLIM=JK
5218	ENDIF
5219	2412 CONTINUE
5220	ENDIF
5221	KLIM=JLIM
5222	C
5223	IF (.NOT.LEVOIGT) THEN
5224	DO 2414 JA=1,KTRAER
5225	DO 2413 JL=1, KDLON
5226	ZTT1(JL,JA)=1.0
5227	2413 CONTINUE
5228	2414 CONTINUE
5229	C
5230	C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA
5231	C -----------------------------
5232	C
5233	2420 CONTINUE
5234	C
5235	DO 2427 JSTRA = KFLEV,JLIM,-1
5236	JSTRU=(JSTRA-1)*NG1P1+1
5237	C
5238	DO 2423 JA=1,KUAER
5239	DO 2422 JL=1, KDLON
5240	ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
5241	2422 CONTINUE
5242	2423 CONTINUE
5243	C
5244	C
5245	CALL LWTT_LMDAR4(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
5246	C
5247	DO 2424 JL = 1, KDLON
5248	ZCTSTR =
5249	1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
5250	1 (ZTT1(JL,1) ZTT1(JL,10)
5251	1 - ZTT (JL,1) *ZTT (JL,10))
5252	2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
5253	2 (ZTT1(JL,2)ZTT1(JL,7)*ZTT1(JL,11)
5254	2 - ZTT (JL,2)ZTT (JL,7)ZTT (JL,11))
5255	3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
5256	3 (ZTT1(JL,4)ZTT1(JL,8)*ZTT1(JL,12)
5257	3 - ZTT (JL,4)ZTT (JL,8)ZTT (JL,12))
5258	4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
5259	4 (ZTT1(JL,5)ZTT1(JL,9)*ZTT1(JL,13)
5260	4 - ZTT (JL,5)ZTT (JL,9)ZTT (JL,13))
5261	5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
5262	5 (ZTT1(JL,3) ZTT1(JL,14)
5263	5 - ZTT (JL,3) *ZTT (JL,14))
5264	6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
5265	6 (ZTT1(JL,6) ZTT1(JL,15)
5266	6 - ZTT (JL,6) *ZTT (JL,15))
5267	PCTS(JL,JSTRA)=ZCTSTR*0.5
5268	2424 CONTINUE
5269	DO 2426 JA=1,KTRAER
5270	DO 2425 JL=1, KDLON
5271	ZTT1(JL,JA)=ZTT(JL,JA)
5272	2425 CONTINUE
5273	2426 CONTINUE
5274	2427 CONTINUE
5275	ENDIF
5276	C Mise a zero de securite pour PCTS en cas de LEVOIGT
5277	IF(LEVOIGT)THEN
5278	DO 2429 JSTRA = 1,KFLEV
5279	DO 2428 JL = 1, KDLON
5280	PCTS(JL,JSTRA)=0.
5281	2428 CONTINUE
5282	2429 CONTINUE
5283	ENDIF
5284	C
5285	C
5286	C* 2.5 EXCHANGE WITH LOWER LIMIT
5287	C -------------------------
5288	C
5289	250 CONTINUE
5290	C
5291	DO 251 JL = 1, KDLON
5292	ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
5293	S *PFLUC(JL,2,1)-PBINT(JL,1)
5294	251 CONTINUE
5295	C
5296	JK = 1
5297	IN=(JK-1)*NG1P1+1
5298	C
5299	DO 252 JL = 1, KDLON
5300	ZCNSOL(JL)=PBSUR(JL,1)
5301	1 +PBSUR(JL,2)
5302	2 +PBSUR(JL,3)
5303	3 +PBSUR(JL,4)
5304	4 +PBSUR(JL,5)
5305	5 +PBSUR(JL,6)
5306	ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5307	ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5308	PFLUC(JL,1,JK)=ZFU(JL)
5309	252 CONTINUE
5310	C
5311	DO 257 JK = 2 , KFLEV+1
5312	IN=(JK-1)*NG1P1+1
5313	C
5314	C
5315	DO 255 JA=1,KUAER
5316	DO 254 JL=1, KDLON
5317	ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
5318	254 CONTINUE
5319	255 CONTINUE
5320	C
5321	C
5322	CALL LWTT_LMDAR4(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
5323	C
5324	DO 256 JL = 1, KDLON
5325	ZCNSOL(JL)=PBSUR(JL,1)ZTT(JL,1) ZTT(JL,10)
5326	2 +PBSUR(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5327	3 +PBSUR(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5328	4 +PBSUR(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5329	5 +PBSUR(JL,5)ZTT(JL,3) ZTT(JL,14)
5330	6 +PBSUR(JL,6)ZTT(JL,6) ZTT(JL,15)
5331	ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5332	ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5333	PFLUC(JL,1,JK)=ZFU(JL)
5334	256 CONTINUE
5335	C
5336	C
5337	257 CONTINUE
5338	C
5339	C
5340	C
5341	C* 2.7 CLEAR-SKY FLUXES
5342	C ----------------
5343	C
5344	270 CONTINUE
5345	C
5346	IF (.NOT.LEVOIGT) THEN
5347	DO 271 JL = 1, KDLON
5348	ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
5349	271 CONTINUE
5350	DO 273 JK = JLIM+1,KFLEV+1
5351	DO 272 JL = 1, KDLON
5352	ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
5353	PFLUC(JL,1,JK) = ZFN10(JL)
5354	PFLUC(JL,2,JK) = 0.
5355	272 CONTINUE
5356	273 CONTINUE
5357	ENDIF
5358	C
5359	C ------------------------------------------------------------------
5360	C
5361	RETURN
5362	END
5363	SUBROUTINE LWVD_LMDAR4(KUAER,KTRAER
5364	S , PABCU,PDBDT
5365	R , PGA,PGB
5366	S , PCNTRB,PDISD,PDISU)
5367	USE dimphy
5368	IMPLICIT none
5369	cym#include "dimensions.h"
5370	cym#include "dimphy.h"
5371	cym#include "raddim.h"
5372	#include "raddimlw.h"
5373	C
5374	C-----------------------------------------------------------------------
5375	C PURPOSE.
5376	C --------
5377	C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
5378	C
5379	C METHOD.
5380	C -------
5381	C
5382	C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5383	C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
5384	C
5385	C REFERENCE.
5386	C ----------
5387	C
5388	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5389	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5390	C
5391	C AUTHOR.
5392	C -------
5393	C JEAN-JACQUES MORCRETTE ECMWF
5394	C
5395	C MODIFICATIONS.
5396	C --------------
5397	C ORIGINAL : 89-07-14
5398	C-----------------------------------------------------------------------
5399	C* ARGUMENTS:
5400	C
5401	INTEGER KUAER,KTRAER
5402	C
5403	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5404	REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5405	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5406	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5407	C
5408	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
5409	REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5410	REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5411	C
5412	C* LOCAL VARIABLES:
5413	C
5414	REAL*8 ZGLAYD(KDLON)
5415	REAL*8 ZGLAYU(KDLON)
5416	REAL*8 ZTT(KDLON,NTRA)
5417	REAL*8 ZTT1(KDLON,NTRA)
5418	REAL*8 ZTT2(KDLON,NTRA)
5419	C
5420	INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
5421	INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
5422	INTEGER ind1, ind2, ind3, ind4, itt
5423	REAL*8 zww, zdzxdg, zdzxmg
5424	C
5425	C* 1. INITIALIZATION
5426	C --------------
5427	C
5428	100 CONTINUE
5429	C
5430	C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
5431	C ------------------------------
5432	C
5433	110 CONTINUE
5434	C
5435	DO 112 JK = 1, KFLEV+1
5436	DO 111 JL = 1, KDLON
5437	PDISD(JL,JK) = 0.
5438	PDISU(JL,JK) = 0.
5439	111 CONTINUE
5440	112 CONTINUE
5441	C
5442	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5443	C ---------------------------------
5444	C
5445	120 CONTINUE
5446	C
5447	C
5448	DO 122 JA = 1, NTRA
5449	DO 121 JL = 1, KDLON
5450	ZTT (JL,JA) = 1.0
5451	ZTT1(JL,JA) = 1.0
5452	ZTT2(JL,JA) = 1.0
5453	121 CONTINUE
5454	122 CONTINUE
5455	C
5456	C ------------------------------------------------------------------
5457	C
5458	C* 2. VERTICAL INTEGRATION
5459	C --------------------
5460	C
5461	200 CONTINUE
5462	C
5463	IND1=0
5464	IND3=0
5465	IND4=1
5466	IND2=1
5467	C
5468	C
5469	C* 2.2 CONTRIBUTION FROM DISTANT LAYERS
5470	C ---------------------------------
5471	C
5472	220 CONTINUE
5473	C
5474	C
5475	C* 2.2.1 DISTANT AND ABOVE LAYERS
5476	C ------------------------
5477	C
5478	2210 CONTINUE
5479	C
5480	C
5481	C
5482	C* 2.2.2 FIRST UPPER LEVEL
5483	C -----------------
5484	C
5485	2220 CONTINUE
5486	C
5487	DO 225 JK = 1 , KFLEV-1
5488	IKP1=JK+1
5489	IKN=(JK-1)*NG1P1+1
5490	IKD1= JK *NG1P1+1
5491	C
5492	CALL LWTTM_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK)
5493	2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
5494	C
5495	C
5496	C
5497	C* 2.2.3 HIGHER UP
5498	C ---------
5499	C
5500	2230 CONTINUE
5501	C
5502	ITT=1
5503	DO 224 JKJ=IKP1,KFLEV
5504	IF(ITT.EQ.1) THEN
5505	ITT=2
5506	ELSE
5507	ITT=1
5508	ENDIF
5509	IKJP1=JKJ+1
5510	IKD2= JKJ *NG1P1+1
5511	C
5512	IF(ITT.EQ.1) THEN
5513	CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5514	2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
5515	ELSE
5516	CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5517	2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
5518	ENDIF
5519	C
5520	DO 2235 JA = 1, KTRAER
5521	DO 2234 JL = 1, KDLON
5522	ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5523	2234 CONTINUE
5524	2235 CONTINUE
5525	C
5526	DO 2236 JL = 1, KDLON
5527	ZWW=PDBDT(JL,1,JKJ)ZTT(JL,1) ZTT(JL,10)
5528	S +PDBDT(JL,2,JKJ)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5529	S +PDBDT(JL,3,JKJ)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5530	S +PDBDT(JL,4,JKJ)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5531	S +PDBDT(JL,5,JKJ)ZTT(JL,3) ZTT(JL,14)
5532	S +PDBDT(JL,6,JKJ)ZTT(JL,6) ZTT(JL,15)
5533	ZGLAYD(JL)=ZWW
5534	ZDZXDG=ZGLAYD(JL)
5535	PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
5536	PCNTRB(JL,JK,IKJP1)=ZDZXDG
5537	2236 CONTINUE
5538	C
5539	C
5540	224 CONTINUE
5541	225 CONTINUE
5542	C
5543	C
5544	C* 2.2.4 DISTANT AND BELOW LAYERS
5545	C ------------------------
5546	C
5547	2240 CONTINUE
5548	C
5549	C
5550	C
5551	C* 2.2.5 FIRST LOWER LEVEL
5552	C -----------------
5553	C
5554	2250 CONTINUE
5555	C
5556	DO 228 JK=3,KFLEV+1
5557	IKN=(JK-1)*NG1P1+1
5558	IKM1=JK-1
5559	IKJ=JK-2
5560	IKU1= IKJ *NG1P1+1
5561	C
5562	C
5563	CALL LWTTM_LMDAR4(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
5564	2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
5565	C
5566	C
5567	C
5568	C* 2.2.6 DOWN BELOW
5569	C ----------
5570	C
5571	2260 CONTINUE
5572	C
5573	ITT=1
5574	DO 227 JLK=1,IKJ
5575	IF(ITT.EQ.1) THEN
5576	ITT=2
5577	ELSE
5578	ITT=1
5579	ENDIF
5580	IJKL=IKM1-JLK
5581	IKU2=(IJKL-1)*NG1P1+1
5582	C
5583	C
5584	IF(ITT.EQ.1) THEN
5585	CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5586	2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
5587	ELSE
5588	CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5589	2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
5590	ENDIF
5591	C
5592	DO 2265 JA = 1, KTRAER
5593	DO 2264 JL = 1, KDLON
5594	ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5595	2264 CONTINUE
5596	2265 CONTINUE
5597	C
5598	DO 2266 JL = 1, KDLON
5599	ZWW=PDBDT(JL,1,IJKL)ZTT(JL,1) ZTT(JL,10)
5600	S +PDBDT(JL,2,IJKL)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5601	S +PDBDT(JL,3,IJKL)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5602	S +PDBDT(JL,4,IJKL)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5603	S +PDBDT(JL,5,IJKL)ZTT(JL,3) ZTT(JL,14)
5604	S +PDBDT(JL,6,IJKL)ZTT(JL,6) ZTT(JL,15)
5605	ZGLAYU(JL)=ZWW
5606	ZDZXMG=ZGLAYU(JL)
5607	PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
5608	PCNTRB(JL,JK,IJKL)=ZDZXMG
5609	2266 CONTINUE
5610	C
5611	C
5612	227 CONTINUE
5613	228 CONTINUE
5614	C
5615	RETURN
5616	END
5617	SUBROUTINE LWVN_LMDAR4(KUAER,KTRAER
5618	R , PABCU,PDBSL,PGA,PGB
5619	S , PADJD,PADJU,PCNTRB,PDBDT)
5620	USE dimphy
5621	IMPLICIT none
5622	cym#include "dimensions.h"
5623	cym#include "dimphy.h"
5624	cym#include "raddim.h"
5625	#include "raddimlw.h"
5626	C
5627	C-----------------------------------------------------------------------
5628	C PURPOSE.
5629	C --------
5630	C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
5631	C TO GIVE LONGWAVE FLUXES OR RADIANCES
5632	C
5633	C METHOD.
5634	C -------
5635	C
5636	C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5637	C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
5638	C
5639	C REFERENCE.
5640	C ----------
5641	C
5642	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5643	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5644	C
5645	C AUTHOR.
5646	C -------
5647	C JEAN-JACQUES MORCRETTE ECMWF
5648	C
5649	C MODIFICATIONS.
5650	C --------------
5651	C ORIGINAL : 89-07-14
5652	C-----------------------------------------------------------------------
5653	C
5654	C* ARGUMENTS:
5655	C
5656	INTEGER KUAER,KTRAER
5657	C
5658	REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
5659	REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
5660	REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5661	REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5662	C
5663	REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5664	REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5665	REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
5666	REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5667	C
5668	C* LOCAL ARRAYS:
5669	C
5670	REAL*8 ZGLAYD(KDLON)
5671	REAL*8 ZGLAYU(KDLON)
5672	REAL*8 ZTT(KDLON,NTRA)
5673	REAL*8 ZTT1(KDLON,NTRA)
5674	REAL*8 ZTT2(KDLON,NTRA)
5675	REAL*8 ZUU(KDLON,NUA)
5676	C
5677	INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
5678	INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
5679	REAL*8 zwtr
5680	c
5681	C* Data Block:
5682	c
5683	REAL*8 WG1(2)
5684	SAVE WG1
5685	c$OMP THREADPRIVATE(WG1)
5686	DATA (WG1(jk),jk=1,2) /1.0, 1.0/
5687	C-----------------------------------------------------------------------
5688	C
5689	C* 1. INITIALIZATION
5690	C --------------
5691	C
5692	100 CONTINUE
5693	C
5694	C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
5695	C ------------------------------
5696	C
5697	110 CONTINUE
5698	C
5699	DO 112 JK = 1 , KFLEV+1
5700	DO 111 JL = 1, KDLON
5701	PADJD(JL,JK) = 0.
5702	PADJU(JL,JK) = 0.
5703	111 CONTINUE
5704	112 CONTINUE
5705	C
5706	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5707	C ---------------------------------
5708	C
5709	120 CONTINUE
5710	C
5711	DO 122 JA = 1 , NTRA
5712	DO 121 JL = 1, KDLON
5713	ZTT (JL,JA) = 1.0
5714	ZTT1(JL,JA) = 1.0
5715	ZTT2(JL,JA) = 1.0
5716	121 CONTINUE
5717	122 CONTINUE
5718	C
5719	DO 124 JA = 1 , NUA
5720	DO 123 JL = 1, KDLON
5721	ZUU(JL,JA) = 0.
5722	123 CONTINUE
5723	124 CONTINUE
5724	C
5725	C ------------------------------------------------------------------
5726	C
5727	C* 2. VERTICAL INTEGRATION
5728	C --------------------
5729	C
5730	200 CONTINUE
5731	C
5732	C
5733	C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS
5734	C ---------------------------------
5735	C
5736	210 CONTINUE
5737	C
5738	DO 215 JK = 1 , KFLEV
5739	C
5740	C* 2.1.1 DOWNWARD LAYERS
5741	C ---------------
5742	C
5743	2110 CONTINUE
5744	C
5745	IM12 = 2 * (JK - 1)
5746	IND = (JK - 1) * NG1P1 + 1
5747	IXD = IND
5748	INU = JK * NG1P1 + 1
5749	IXU = IND
5750	C
5751	DO 2111 JL = 1, KDLON
5752	ZGLAYD(JL) = 0.
5753	ZGLAYU(JL) = 0.
5754	2111 CONTINUE
5755	C
5756	DO 213 JG = 1 , NG1
5757	IBS = IM12 + JG
5758	IDD = IXD + JG
5759	DO 2113 JA = 1 , KUAER
5760	DO 2112 JL = 1, KDLON
5761	ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
5762	2112 CONTINUE
5763	2113 CONTINUE
5764	C
5765	C
5766	CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
5767	C
5768	DO 2114 JL = 1, KDLON
5769	ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
5770	S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5771	S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5772	S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5773	S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
5774	S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
5775	ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
5776	2114 CONTINUE
5777	C
5778	C* 2.1.2 DOWNWARD LAYERS
5779	C ---------------
5780	C
5781	2120 CONTINUE
5782	C
5783	IMU = IXU + JG
5784	DO 2122 JA = 1 , KUAER
5785	DO 2121 JL = 1, KDLON
5786	ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
5787	2121 CONTINUE
5788	2122 CONTINUE
5789	C
5790	C
5791	CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
5792	C
5793	DO 2123 JL = 1, KDLON
5794	ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
5795	S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5796	S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5797	S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5798	S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
5799	S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
5800	ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
5801	2123 CONTINUE
5802	C
5803	213 CONTINUE
5804	C
5805	DO 214 JL = 1, KDLON
5806	PADJD(JL,JK) = ZGLAYD(JL)
5807	PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
5808	PADJU(JL,JK+1) = ZGLAYU(JL)
5809	PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
5810	PCNTRB(JL,JK ,JK) = 0.0
5811	214 CONTINUE
5812	C
5813	215 CONTINUE
5814	C
5815	DO 218 JK = 1 , KFLEV
5816	JK2 = 2 * JK
5817	JK1 = JK2 - 1
5818	DO 217 JNU = 1 , Ninter
5819	DO 216 JL = 1, KDLON
5820	PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
5821	216 CONTINUE
5822	217 CONTINUE
5823	218 CONTINUE
5824	C
5825	RETURN
5826	C
5827	END
5828	SUBROUTINE LWTT_LMDAR4(PGA,PGB,PUU, PTT)
5829	USE dimphy
5830	IMPLICIT none
5831	cym#include "dimensions.h"
5832	cym#include "dimphy.h"
5833	cym#include "raddim.h"
5834	#include "raddimlw.h"
5835	C
5836	C-----------------------------------------------------------------------
5837	C PURPOSE.
5838	C --------
5839	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
5840	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
5841	C INTERVALS.
5842	C
5843	C METHOD.
5844	C -------
5845	C
5846	C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
5847	C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
5848	C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
5849	C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
5850	C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
5851	C
5852	C REFERENCE.
5853	C ----------
5854	C
5855	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5856	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5857	C
5858	C AUTHOR.
5859	C -------
5860	C JEAN-JACQUES MORCRETTE ECMWF
5861	C
5862	C MODIFICATIONS.
5863	C --------------
5864	C ORIGINAL : 88-12-15
5865	C
5866	C-----------------------------------------------------------------------
5867	REAL*8 O1H, O2H
5868	PARAMETER (O1H=2230.)
5869	PARAMETER (O2H=100.)
5870	REAL*8 RPIALF0
5871	PARAMETER (RPIALF0=2.0)
5872	C
5873	C* ARGUMENTS:
5874	C
5875	REAL*8 PUU(KDLON,NUA)
5876	REAL*8 PTT(KDLON,NTRA)
5877	REAL*8 PGA(KDLON,8,2)
5878	REAL*8 PGB(KDLON,8,2)
5879	C
5880	C* LOCAL VARIABLES:
5881	C
5882	REAL*8 zz, zxd, zxn
5883	REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
5884	REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
5885	REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
5886	REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
5887	REAL*8 zsqn21, zodn21, zsqh42, zodh42
5888	REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
5889	REAL*8 zuu11, zuu12, za11, za12
5890	INTEGER jl, ja
5891	C ------------------------------------------------------------------
5892	C
5893	C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
5894	C -----------------------------------------------
5895	C
5896	100 CONTINUE
5897	C
5898	C
5899	DO 130 JA = 1 , 8
5900	DO 120 JL = 1, KDLON
5901	ZZ =SQRT(PUU(JL,JA))
5902	c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
5903	c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
5904	c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
5905	ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
5906	ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
5907	PTT(JL,JA)=ZXN /ZXD
5908	120 CONTINUE
5909	130 CONTINUE
5910	C
5911	C ------------------------------------------------------------------
5912	C
5913	C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
5914	C ---------------------------------------------------
5915	C
5916	200 CONTINUE
5917	C
5918	DO 201 JL = 1, KDLON
5919	PTT(JL, 9) = PTT(JL, 8)
5920	C
5921	C- CONTINUUM ABSORPTION: E- AND P-TYPE
5922	C
5923	ZPU = 0.002 * PUU(JL,10)
5924	ZPU10 = 112. * ZPU
5925	ZPU11 = 6.25 * ZPU
5926	ZPU12 = 5.00 * ZPU
5927	ZPU13 = 80.0 * ZPU
5928	ZEU = PUU(JL,11)
5929	ZEU10 = 12. * ZEU
5930	ZEU11 = 6.25 * ZEU
5931	ZEU12 = 5.00 * ZEU
5932	ZEU13 = 80.0 * ZEU
5933	C
5934	C- OZONE ABSORPTION
5935	C
5936	ZX = PUU(JL,12)
5937	ZY = PUU(JL,13)
5938	ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
5939	ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
5940	ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
5941	ZVXY = RPIALF0 * ZY / (2. * ZX)
5942	ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
5943	ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
5944	ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
5945	C
5946	C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
5947	C
5948	C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
5949	C
5950	c NEXOTIC=1
5951	c IF (NEXOTIC.EQ.1) THEN
5952	ZXCH4 = PUU(JL,19)
5953	ZYCH4 = PUU(JL,20)
5954	ZUXY = 4. * ZXCH4ZXCH4/(0.103ZYCH4)
5955	ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
5956	ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
5957	ZODH41 = ZVXY * ZSQH41
5958	C
5959	C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
5960	C
5961	ZXN2O = PUU(JL,21)
5962	ZYN2O = PUU(JL,22)
5963	ZUXY = 4. * ZXN2OZXN2O/(0.416ZYN2O)
5964	ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
5965	ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
5966	ZODN21 = ZVXY * ZSQN21
5967	C
5968	C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
5969	C
5970	ZUXY = 4. * ZXCH4ZXCH4/(0.113ZYCH4)
5971	ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
5972	ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
5973	ZODH42 = ZVXY * ZSQH42
5974	C
5975	C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
5976	C
5977	ZUXY = 4. * ZXN2OZXN2O/(0.197ZYN2O)
5978	ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
5979	ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
5980	ZODN22 = ZVXY * ZSQN22
5981	C
5982	C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
5983	C
5984	ZA11 = 2. * PUU(JL,23) * 4.404E+05
5985	ZTTF11 = 1. - ZA11 * 0.003225
5986	C
5987	C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
5988	C
5989	ZA12 = 2. * PUU(JL,24) * 6.7435E+05
5990	ZTTF12 = 1. - ZA12 * 0.003225
5991	C
5992	ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
5993	ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
5994	PTT(JL,10) = EXP( - PUU(JL,14) )
5995	PTT(JL,11) = EXP( ZUU11 )
5996	PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
5997	PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
5998	PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
5999	PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
6000	201 CONTINUE
6001	C
6002	RETURN
6003	END
6004	SUBROUTINE LWTTM_LMDAR4(PGA,PGB,PUU1,PUU2, PTT)
6005	USE dimphy
6006	IMPLICIT none
6007	cym#include "dimensions.h"
6008	cym#include "dimphy.h"
6009	cym#include "raddim.h"
6010	#include "raddimlw.h"
6011	C
6012	C ------------------------------------------------------------------
6013	C PURPOSE.
6014	C --------
6015	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
6016	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
6017	C INTERVALS.
6018	C
6019	C METHOD.
6020	C -------
6021	C
6022	C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
6023	C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
6024	C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
6025	C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
6026	C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
6027	C
6028	C REFERENCE.
6029	C ----------
6030	C
6031	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
6032	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
6033	C
6034	C AUTHOR.
6035	C -------
6036	C JEAN-JACQUES MORCRETTE ECMWF
6037	C
6038	C MODIFICATIONS.
6039	C --------------
6040	C ORIGINAL : 88-12-15
6041	C
6042	C-----------------------------------------------------------------------
6043	REAL*8 O1H, O2H
6044	PARAMETER (O1H=2230.)
6045	PARAMETER (O2H=100.)
6046	REAL*8 RPIALF0
6047	PARAMETER (RPIALF0=2.0)
6048	C
6049	C* ARGUMENTS:
6050	C
6051	REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
6052	REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
6053	REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
6054	REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
6055	REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
6056	C
6057	C* LOCAL VARIABLES:
6058	C
6059	INTEGER ja, jl
6060	REAL*8 zz, zxd, zxn
6061	REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
6062	REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
6063	REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
6064	REAL*8 zxch4, zych4, zsqh41, zodh41
6065	REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
6066	REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
6067	REAL*8 zuu11, zuu12
6068	C ------------------------------------------------------------------
6069	C
6070	C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
6071	C -----------------------------------------------
6072	C
6073	100 CONTINUE
6074	C
6075	C
6076	DO 130 JA = 1 , 8
6077	DO 120 JL = 1, KDLON
6078	ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
6079	ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
6080	ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
6081	PTT(JL,JA)=ZXN /ZXD
6082	120 CONTINUE
6083	130 CONTINUE
6084	C
6085	C ------------------------------------------------------------------
6086	C
6087	C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
6088	C ---------------------------------------------------
6089	C
6090	200 CONTINUE
6091	C
6092	DO 201 JL = 1, KDLON
6093	PTT(JL, 9) = PTT(JL, 8)
6094	C
6095	C- CONTINUUM ABSORPTION: E- AND P-TYPE
6096	C
6097	ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
6098	ZPU10 = 112. * ZPU
6099	ZPU11 = 6.25 * ZPU
6100	ZPU12 = 5.00 * ZPU
6101	ZPU13 = 80.0 * ZPU
6102	ZEU = (PUU1(JL,11) - PUU2(JL,11))
6103	ZEU10 = 12. * ZEU
6104	ZEU11 = 6.25 * ZEU
6105	ZEU12 = 5.00 * ZEU
6106	ZEU13 = 80.0 * ZEU
6107	C
6108	C- OZONE ABSORPTION
6109	C
6110	ZX = (PUU1(JL,12) - PUU2(JL,12))
6111	ZY = (PUU1(JL,13) - PUU2(JL,13))
6112	ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
6113	ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
6114	ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
6115	ZVXY = RPIALF0 * ZY / (2. * ZX)
6116	ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
6117	ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
6118	ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
6119	C
6120	C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
6121	C
6122	C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
6123	C
6124	ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
6125	ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
6126	ZUXY = 4. * ZXCH4ZXCH4/(0.103ZYCH4)
6127	ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
6128	ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
6129	ZODH41 = ZVXY * ZSQH41
6130	C
6131	C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
6132	C
6133	ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
6134	ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
6135	ZUXY = 4. * ZXN2OZXN2O/(0.416ZYN2O)
6136	ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
6137	ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
6138	ZODN21 = ZVXY * ZSQN21
6139	C
6140	C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
6141	C
6142	ZUXY = 4. * ZXCH4ZXCH4/(0.113ZYCH4)
6143	ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
6144	ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
6145	ZODH42 = ZVXY * ZSQH42
6146	C
6147	C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
6148	C
6149	ZUXY = 4. * ZXN2OZXN2O/(0.197ZYN2O)
6150	ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
6151	ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
6152	ZODN22 = ZVXY * ZSQN22
6153	C
6154	C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
6155	C
6156	ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
6157	ZTTF11 = 1. - ZA11 * 0.003225
6158	C
6159	C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
6160	C
6161	ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
6162	ZTTF12 = 1. - ZA12 * 0.003225
6163	C
6164	ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
6165	ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
6166	S ZODH41 - ZODN21
6167	PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
6168	PTT(JL,11) = EXP( ZUU11 )
6169	PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
6170	PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
6171	PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
6172	PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
6173	201 CONTINUE
6174	C
6175	RETURN
6176	END

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

Download in other formats:

Original Format