source: LMDZ6/branches/Amaury_dev/libf/phylmd/radiation_AR4.f90 @ 5220

Last change on this file since 5220 was 5185, checked in by abarral, 2 months ago

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