Context Navigation

radiation_AR4.F90 @ 5024

Last change on this file since 5024 was 4482, checked in by lguez, 20 months ago
Sync latest trunk changes to branch LMDZ_ECRad
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 170.2 KB

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

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

Download in other formats:

Original Format