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

Last change on this file since 3457 was 2346, checked in by Ehouarn Millour, 9 years ago

Physics/dynamics separation:

  • remove all references to dimensions.h from physics. nbp_lon (==iim) , nbp_lat (==jjm+1) and nbp_lev (==llm) from mod_grid_phy_lmdz should be used instead.
  • added module regular_lonlat_mod in phy_common to store information about the global (lon-lat) grid cell boundaries and centers.

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