Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

radiation_AR4.F @ 1939

Last change on this file since 1939 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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

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

Download in other formats:

Original Format