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