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