Context Navigation

radiation_AR4.F @ 1565

Last change on this file since 1565 was 1565, checked in by jghattas, 13 years ago

Added interface with chemestry model REPROBUS :

Compile LMDZ together with Reprobus code (dependecies in both directions) and cpp key REPROBUS :

./makelmdz_fcm -ext_src my_path_to_reprobus -cpp REPROBUS ...

For running, add type_trac=repr in run.def.

/Marion Marchand, JG

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

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

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

Download in other formats:

Original Format