Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

radiation_AR4.F90 @ 25

Last change on this file since 25 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: 201.7 KB

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

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

Download in other formats:

Original Format