GCC Code Coverage Report

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