source: LMDZ5/trunk/libf/phylmd/radiation_AR4.F90 @ 2172

Last change on this file since 2172 was 1992, checked in by lguez, 11 years ago

Converted to free source form files in libf/phylmd which were still in
fixed source form. The conversion was done using the polish mode of
the NAG Fortran Compiler.

In addition to converting to free source form, the processing of the
files also:

-- indented the code (including comments);

-- set Fortran keywords to uppercase, and set all other identifiers
to lower case;

-- added qualifiers to end statements (for example "end subroutine
conflx", instead of "end");

-- changed the terminating statements of all DO loops so that each
loop ends with an ENDDO statement (instead of a labeled continue).

-- replaced #include by include.

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