source: LMDZ6/trunk/libf/phylmd/radiation_AR4.F90 @ 5069

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