/[lmdze]/trunk/Sources/phylmd/Radlwsw/sw2s.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/Radlwsw/sw2s.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/phylmd/Radlwsw/sw2s.f revision 76 by guez, Fri Nov 15 18:45:49 2013 UTC trunk/phylmd/Radlwsw/sw2s.f90 revision 81 by guez, Wed Mar 5 14:38:41 2014 UTC
# Line 1  Line 1 
1        SUBROUTINE SW2S ( KNU  SUBROUTINE sw2s(knu, paer, flag_aer, tauae, pizae, cgae, paki, palbd, palbp, &
2       S  ,  PAER  , flag_aer, tauae, pizae, cgae      pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, &
3       S  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW      pwv, pqs, pfdown, pfup)
4       S  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU    USE dimens_m
5       S  ,  PUD   ,PWV , PQS    USE dimphy
6       S  ,  PFDOWN,PFUP                                            )    USE raddim
7        use dimens_m    USE radepsi
8        use dimphy    IMPLICIT NONE
9        use raddim  
10        use radepsi    ! ------------------------------------------------------------------
11        IMPLICIT none    ! PURPOSE.
12  C    ! --------
13  C     ------------------------------------------------------------------  
14  C     PURPOSE.    ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
15  C     --------    ! SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
16  C  
17  C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE    ! METHOD.
18  C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).    ! -------
19  C  
20  C     METHOD.    ! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
21  C     -------    ! CONTINUUM SCATTERING
22  C    ! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
23  C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO    ! A GREY MOLECULAR ABSORPTION
24  C     CONTINUUM SCATTERING    ! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
25  C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR    ! OF ABSORBERS
26  C     A GREY MOLECULAR ABSORPTION    ! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
27  C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS    ! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
28  C     OF ABSORBERS  
29  C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS    ! REFERENCE.
30  C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION    ! ----------
31  C  
32  C     REFERENCE.    ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
33  C     ----------    ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
34  C  
35  C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT    ! AUTHOR.
36  C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)    ! -------
37  C    ! JEAN-JACQUES MORCRETTE  *ECMWF*
38  C     AUTHOR.  
39  C     -------    ! MODIFICATIONS.
40  C        JEAN-JACQUES MORCRETTE  *ECMWF*    ! --------------
41  C    ! ORIGINAL : 89-07-14
42  C     MODIFICATIONS.    ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
43  C     --------------    ! ------------------------------------------------------------------
44  C        ORIGINAL : 89-07-14    ! * ARGUMENTS:
45  C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO  
46  C     ------------------------------------------------------------------    INTEGER knu
47  C* ARGUMENTS:    ! -OB
48  C    DOUBLE PRECISION flag_aer
49        INTEGER KNU    DOUBLE PRECISION tauae(kdlon, kflev, 2)
50  c-OB    DOUBLE PRECISION pizae(kdlon, kflev, 2)
51        double precision flag_aer    DOUBLE PRECISION cgae(kdlon, kflev, 2)
52        double precision tauae(kdlon,kflev,2)    DOUBLE PRECISION paer(kdlon, kflev, 5)
53        double precision pizae(kdlon,kflev,2)    DOUBLE PRECISION paki(kdlon, 2)
54        double precision cgae(kdlon,kflev,2)    DOUBLE PRECISION palbd(kdlon, 2)
55        DOUBLE PRECISION PAER(KDLON,KFLEV,5)    DOUBLE PRECISION palbp(kdlon, 2)
56        DOUBLE PRECISION PAKI(KDLON,2)    DOUBLE PRECISION pcg(kdlon, 2, kflev)
57        DOUBLE PRECISION PALBD(KDLON,2)    DOUBLE PRECISION pcld(kdlon, kflev)
58        DOUBLE PRECISION PALBP(KDLON,2)    DOUBLE PRECISION pcldsw(kdlon, kflev)
59        DOUBLE PRECISION PCG(KDLON,2,KFLEV)    DOUBLE PRECISION pclear(kdlon)
60        DOUBLE PRECISION PCLD(KDLON,KFLEV)    DOUBLE PRECISION pdsig(kdlon, kflev)
61        DOUBLE PRECISION PCLDSW(KDLON,KFLEV)    DOUBLE PRECISION pomega(kdlon, 2, kflev)
62        DOUBLE PRECISION PCLEAR(KDLON)    DOUBLE PRECISION poz(kdlon, kflev)
63        DOUBLE PRECISION PDSIG(KDLON,KFLEV)    DOUBLE PRECISION pqs(kdlon, kflev)
64        DOUBLE PRECISION POMEGA(KDLON,2,KFLEV)    DOUBLE PRECISION prmu(kdlon)
65        DOUBLE PRECISION POZ(KDLON,KFLEV)    DOUBLE PRECISION psec(kdlon)
66        DOUBLE PRECISION PQS(KDLON,KFLEV)    DOUBLE PRECISION ptau(kdlon, 2, kflev)
67        DOUBLE PRECISION PRMU(KDLON)    DOUBLE PRECISION pud(kdlon, 5, kflev+1)
68        DOUBLE PRECISION PSEC(KDLON)    DOUBLE PRECISION pwv(kdlon, kflev)
69        DOUBLE PRECISION PTAU(KDLON,2,KFLEV)  
70        DOUBLE PRECISION PUD(KDLON,5,KFLEV+1)    DOUBLE PRECISION pfdown(kdlon, kflev+1)
71        DOUBLE PRECISION PWV(KDLON,KFLEV)    DOUBLE PRECISION pfup(kdlon, kflev+1)
72  C  
73        DOUBLE PRECISION PFDOWN(KDLON,KFLEV+1)    ! * LOCAL VARIABLES:
74        DOUBLE PRECISION PFUP(KDLON,KFLEV+1)  
75  C    INTEGER iind2(2), iind3(3)
76  C* LOCAL VARIABLES:    DOUBLE PRECISION zcgaz(kdlon, kflev)
77  C    DOUBLE PRECISION zfd(kdlon, kflev+1)
78        INTEGER IIND2(2), IIND3(3)    DOUBLE PRECISION zfu(kdlon, kflev+1)
79        DOUBLE PRECISION ZCGAZ(KDLON,KFLEV)    DOUBLE PRECISION zg(kdlon)
80        DOUBLE PRECISION ZFD(KDLON,KFLEV+1)    DOUBLE PRECISION zgg(kdlon)
81        DOUBLE PRECISION ZFU(KDLON,KFLEV+1)    DOUBLE PRECISION zpizaz(kdlon, kflev)
82        DOUBLE PRECISION ZG(KDLON)    DOUBLE PRECISION zrayl(kdlon)
83        DOUBLE PRECISION ZGG(KDLON)    DOUBLE PRECISION zray1(kdlon, kflev+1)
84        DOUBLE PRECISION ZPIZAZ(KDLON,KFLEV)    DOUBLE PRECISION zray2(kdlon, kflev+1)
85        DOUBLE PRECISION ZRAYL(KDLON)    DOUBLE PRECISION zref(kdlon)
86        DOUBLE PRECISION ZRAY1(KDLON,KFLEV+1)    DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
87        DOUBLE PRECISION ZRAY2(KDLON,KFLEV+1)    DOUBLE PRECISION zre1(kdlon)
88        DOUBLE PRECISION ZREF(KDLON)    DOUBLE PRECISION zre2(kdlon)
89        DOUBLE PRECISION ZREFZ(KDLON,2,KFLEV+1)    DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
90        DOUBLE PRECISION ZRE1(KDLON)    DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
91        DOUBLE PRECISION ZRE2(KDLON)    DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
92        DOUBLE PRECISION ZRJ(KDLON,6,KFLEV+1)    DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
93        DOUBLE PRECISION ZRJ0(KDLON,6,KFLEV+1)    DOUBLE PRECISION zrl(kdlon, 8)
94        DOUBLE PRECISION ZRK(KDLON,6,KFLEV+1)    DOUBLE PRECISION zrmue(kdlon, kflev+1)
95        DOUBLE PRECISION ZRK0(KDLON,6,KFLEV+1)    DOUBLE PRECISION zrmu0(kdlon, kflev+1)
96        DOUBLE PRECISION ZRL(KDLON,8)    DOUBLE PRECISION zrmuz(kdlon)
97        DOUBLE PRECISION ZRMUE(KDLON,KFLEV+1)    DOUBLE PRECISION zrneb(kdlon)
98        DOUBLE PRECISION ZRMU0(KDLON,KFLEV+1)    DOUBLE PRECISION zruef(kdlon, 8)
99        DOUBLE PRECISION ZRMUZ(KDLON)    DOUBLE PRECISION zr1(kdlon)
100        DOUBLE PRECISION ZRNEB(KDLON)    DOUBLE PRECISION zr2(kdlon, 2)
101        DOUBLE PRECISION ZRUEF(KDLON,8)    DOUBLE PRECISION zr3(kdlon, 3)
102        DOUBLE PRECISION ZR1(KDLON)    DOUBLE PRECISION zr4(kdlon)
103        DOUBLE PRECISION ZR2(KDLON,2)    DOUBLE PRECISION zr21(kdlon)
104        DOUBLE PRECISION ZR3(KDLON,3)    DOUBLE PRECISION zr22(kdlon)
105        DOUBLE PRECISION ZR4(KDLON)    DOUBLE PRECISION zs(kdlon)
106        DOUBLE PRECISION ZR21(KDLON)    DOUBLE PRECISION ztauaz(kdlon, kflev)
107        DOUBLE PRECISION ZR22(KDLON)    DOUBLE PRECISION zto1(kdlon)
108        DOUBLE PRECISION ZS(KDLON)    DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
109        DOUBLE PRECISION ZTAUAZ(KDLON,KFLEV)    DOUBLE PRECISION ztra1(kdlon, kflev+1)
110        DOUBLE PRECISION ZTO1(KDLON)    DOUBLE PRECISION ztra2(kdlon, kflev+1)
111        DOUBLE PRECISION ZTR(KDLON,2,KFLEV+1)    DOUBLE PRECISION ztr1(kdlon)
112        DOUBLE PRECISION ZTRA1(KDLON,KFLEV+1)    DOUBLE PRECISION ztr2(kdlon)
113        DOUBLE PRECISION ZTRA2(KDLON,KFLEV+1)    DOUBLE PRECISION zw(kdlon)
114        DOUBLE PRECISION ZTR1(KDLON)    DOUBLE PRECISION zw1(kdlon)
115        DOUBLE PRECISION ZTR2(KDLON)    DOUBLE PRECISION zw2(kdlon, 2)
116        DOUBLE PRECISION ZW(KDLON)      DOUBLE PRECISION zw3(kdlon, 3)
117        DOUBLE PRECISION ZW1(KDLON)    DOUBLE PRECISION zw4(kdlon)
118        DOUBLE PRECISION ZW2(KDLON,2)    DOUBLE PRECISION zw5(kdlon)
119        DOUBLE PRECISION ZW3(KDLON,3)  
120        DOUBLE PRECISION ZW4(KDLON)    INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
121        DOUBLE PRECISION ZW5(KDLON)    INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
122  C    DOUBLE PRECISION zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11
123        INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1  
124        INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs    ! * Prescribed Data:
125        DOUBLE PRECISION ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11  
126  C    DOUBLE PRECISION rsun(2)
127  C* Prescribed Data:    SAVE rsun
128  C    DOUBLE PRECISION rray(2, 6)
129        DOUBLE PRECISION RSUN(2)    SAVE rray
130        SAVE RSUN    DATA rsun(1)/0.441676/
131        DOUBLE PRECISION RRAY(2,6)    DATA rsun(2)/0.558324/
132        SAVE RRAY    DATA (rray(1,k), k=1, 6)/.428937E-01, .890743E+00, -.288555E+01, &
133        DATA RSUN(1) / 0.441676 /      .522744E+01, -.469173E+01, .161645E+01/
134        DATA RSUN(2) / 0.558324 /    DATA (rray(2,k), k=1, 6)/.697200E-02, .173297E-01, -.850903E-01, &
135        DATA (RRAY(1,K),K=1,6) /      .248261E+00, -.302031E+00, .129662E+00/
136       S .428937E-01, .890743E+00,-.288555E+01,  
137       S .522744E+01,-.469173E+01, .161645E+01/    ! ------------------------------------------------------------------
138        DATA (RRAY(2,K),K=1,6) /  
139       S .697200E-02, .173297E-01,-.850903E-01,    ! *         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
140       S .248261E+00,-.302031E+00, .129662E+00/    ! -------------------------------------------
141  C  
142  C     ------------------------------------------------------------------  
143  C  
144  C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)    ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
145  C                 -------------------------------------------    ! -----------------------------------------
146  C  
147   100  CONTINUE  
148  C    DO jl = 1, kdlon
149  C      zrmum1 = 1. - prmu(jl)
150  C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING      zrayl(jl) = rray(knu, 1) + zrmum1*(rray(knu,2)+zrmum1*(rray(knu, &
151  C                 -----------------------------------------        3)+zrmum1*(rray(knu,4)+zrmum1*(rray(knu,5)+zrmum1*rray(knu,6)))))
152  C    END DO
153   110  CONTINUE  
154  C  
155        DO 111 JL = 1, KDLON    ! ------------------------------------------------------------------
156        ZRMUM1 = 1. - PRMU(JL)  
157        ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1    ! *         2.    CONTINUUM SCATTERING CALCULATIONS
158       S          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1    ! ---------------------------------
159       S          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))  
160   111  CONTINUE  
161  C    ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
162  C    ! --------------------------------
163  C     ------------------------------------------------------------------  
164  C  
165  C*         2.    CONTINUUM SCATTERING CALCULATIONS    CALL swclr(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &
166  C                ---------------------------------      psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &
167  C      ztra1, ztra2)
168   200  CONTINUE  
169  C  
170  C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN    ! *         2.2   CLOUDY FRACTION OF THE COLUMN
171  C                --------------------------------    ! -----------------------------
172  C    
173   210  CONTINUE  
174  C    CALL swr(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, zcgaz, &
175        CALL SWCLR ( KNU      zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
176       S  , PAER   , flag_aer, tauae, pizae, cgae  
177       S  , PALBP  , PDSIG , ZRAYL, PSEC  
178       S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0    ! ------------------------------------------------------------------
179       S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)  
180  C    ! *         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
181  C    ! ------------------------------------------------------
182  C*         2.2   CLOUDY FRACTION OF THE COLUMN  
183  C                -----------------------------  
184  C    jn = 2
185   220  CONTINUE  
186  C    DO jabs = 1, 2
187        CALL SWR ( KNU  
188       S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL  
189       S  , PSEC  , PTAU      ! *         3.1  SURFACE CONDITIONS
190       S  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE      ! ------------------
191       S  , ZTAUAZ, ZTRA1 , ZTRA2)  
192  C  
193  C      DO jl = 1, kdlon
194  C     ------------------------------------------------------------------        zrefz(jl, 2, 1) = palbd(jl, knu)
195  C        zrefz(jl, 1, 1) = palbd(jl, knu)
196  C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION      END DO
197  C                ------------------------------------------------------  
198  C  
199   300  CONTINUE      ! *         3.2  INTRODUCING CLOUD EFFECTS
200  C      ! -------------------------
201        JN = 2  
202  C  
203        DO 361 JABS=1,2      DO jk = 2, kflev + 1
204  C        jkm1 = jk - 1
205  C        ikl = kflev + 1 - jkm1
206  C*         3.1  SURFACE CONDITIONS        DO jl = 1, kdlon
207  C               ------------------          zrneb(jl) = pcld(jl, jkm1)
208  C          IF (jabs==1 .AND. zrneb(jl)>2.*zeelog) THEN
209   310  CONTINUE            zwh2o = max(pwv(jl,jkm1), zeelog)
210  C            zcneb = max(zeelog, min(zrneb(jl),1.-zeelog))
211        DO 311 JL = 1, KDLON            zbb = pud(jl, jabs, jkm1)*pqs(jl, jkm1)/zwh2o
212        ZREFZ(JL,2,1) = PALBD(JL,KNU)            zaa = max((pud(jl,jabs,jkm1)-zcneb*zbb)/(1.-zcneb), zeelog)
213        ZREFZ(JL,1,1) = PALBD(JL,KNU)          ELSE
214   311  CONTINUE            zaa = pud(jl, jabs, jkm1)
215  C            zbb = zaa
216  C          END IF
217  C*         3.2  INTRODUCING CLOUD EFFECTS          zrki = paki(jl, jabs)
218  C               -------------------------          zs(jl) = exp(-zrki*zaa*1.66)
219  C          zg(jl) = exp(-zrki*zaa/zrmue(jl,jk))
220   320  CONTINUE          ztr1(jl) = 0.
221  C          zre1(jl) = 0.
222        DO 324 JK = 2 , KFLEV+1          ztr2(jl) = 0.
223        JKM1 = JK - 1          zre2(jl) = 0.
224        IKL=KFLEV+1-JKM1  
225        DO 322 JL = 1, KDLON          zw(jl) = pomega(jl, knu, jkm1)
226        ZRNEB(JL) = PCLD(JL,JKM1)          zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ztauaz(jl, jkm1)/zpizaz(jl, &
227        IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN            jkm1) + zbb*zrki
228           ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)  
229           ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))          zr21(jl) = ptau(jl, knu, jkm1) + ztauaz(jl, jkm1)
230           ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O          zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
231           ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)          zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*zcgaz(jl, jkm1)
232        ELSE          zw(jl) = zr21(jl)/zto1(jl)
233           ZAA=PUD(JL,JABS,JKM1)          zref(jl) = zrefz(jl, 1, jkm1)
234           ZBB=ZAA          zrmuz(jl) = zrmue(jl, jk)
235        END IF        END DO
236        ZRKI = PAKI(JL,JABS)  
237        ZS(JL) = EXP(-ZRKI * ZAA * 1.66)        CALL swde(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
238        ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))  
239        ZTR1(JL) = 0.        DO jl = 1, kdlon
240        ZRE1(JL) = 0.  
241        ZTR2(JL) = 0.          zrefz(jl, 2, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,2,jkm1)* &
242        ZRE2(JL) = 0.            ztra1(jl,jkm1)*ztra2(jl,jkm1))*zg(jl)*zs(jl) + zrneb(jl)*zre1(jl)
243  C  
244        ZW(JL)= POMEGA(JL,KNU,JKM1)          ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + (ztra1(jl,jkm1))*zg(jl)*(1.- &
245        ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)            zrneb(jl))
246       S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)  
247       S               + ZBB * ZRKI          zrefz(jl, 1, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,1,jkm1)* &
248              ztra1(jl,jkm1)*ztra2(jl,jkm1)/(1.-zray2(jl,jkm1)*zrefz(jl,1, &
249        ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)            jkm1)))*zg(jl)*zs(jl) + zrneb(jl)*zre2(jl)
250        ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)  
251        ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)          ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ztra1(jl,jkm1)/(1.-zray2(jl, &
252       S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)            jkm1)*zrefz(jl,1,jkm1)))*zg(jl)*(1.-zrneb(jl))
253        ZW(JL) = ZR21(JL) / ZTO1(JL)  
254        ZREF(JL) = ZREFZ(JL,1,JKM1)        END DO
255        ZRMUZ(JL) = ZRMUE(JL,JK)      END DO
256   322  CONTINUE  
257  C      ! *         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
258        CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,      ! -------------------------------------------------
259       S          ZRE1, ZRE2, ZTR1, ZTR2)  
260  C  
261        DO 323 JL = 1, KDLON      DO jref = 1, 2
262  C  
263        ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)        jn = jn + 1
264       S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)  
265       S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)        DO jl = 1, kdlon
266       S               + ZRNEB(JL) * ZRE1(JL)          zrj(jl, jn, kflev+1) = 1.
267  C          zrk(jl, jn, kflev+1) = zrefz(jl, jref, kflev+1)
268        ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)        END DO
269       S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))  
270  C        DO jk = 1, kflev
271        ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)          jkl = kflev + 1 - jk
272       S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)          jklp1 = jkl + 1
273       S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)          DO jl = 1, kdlon
274       S             + ZRNEB(JL) * ZRE2(JL)            zre11 = zrj(jl, jn, jklp1)*ztr(jl, jref, jkl)
275  C            zrj(jl, jn, jkl) = zre11
276        ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)            zrk(jl, jn, jkl) = zre11*zrefz(jl, jref, jkl)
277       S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)          END DO
278       S              * ZREFZ(JL,1,JKM1)))        END DO
279       S              * ZG(JL) * (1. -ZRNEB(JL))      END DO
280  C    END DO
281   323  CONTINUE  
282   324  CONTINUE  
283  C    ! ------------------------------------------------------------------
284  C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL  
285  C               -------------------------------------------------    ! *         4.    INVERT GREY AND CONTINUUM FLUXES
286  C    ! --------------------------------
287   330  CONTINUE  
288  C  
289        DO 351 JREF=1,2  
290  C    ! *         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
291        JN = JN + 1    ! ---------------------------------------------
292  C  
293        DO 331 JL = 1, KDLON  
294        ZRJ(JL,JN,KFLEV+1) = 1.    DO jk = 1, kflev + 1
295        ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)      DO jaj = 1, 5, 2
296   331  CONTINUE        jajp = jaj + 1
297  C        DO jl = 1, kdlon
298        DO 333 JK = 1 , KFLEV          zrj(jl, jaj, jk) = zrj(jl, jaj, jk) - zrj(jl, jajp, jk)
299        JKL = KFLEV+1 - JK          zrk(jl, jaj, jk) = zrk(jl, jaj, jk) - zrk(jl, jajp, jk)
300        JKLP1 = JKL + 1          zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
301        DO 332 JL = 1, KDLON          zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
302        ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)        END DO
303        ZRJ(JL,JN,JKL) = ZRE11      END DO
304        ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)    END DO
305   332  CONTINUE  
306   333  CONTINUE    DO jk = 1, kflev + 1
307   351  CONTINUE      DO jaj = 2, 6, 2
308   361  CONTINUE        DO jl = 1, kdlon
309  C          zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
310  C          zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
311  C     ------------------------------------------------------------------        END DO
312  C      END DO
313  C*         4.    INVERT GREY AND CONTINUUM FLUXES    END DO
314  C                --------------------------------  
315  C    ! *         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
316   400  CONTINUE    ! ---------------------------------------------
317  C  
318  C  
319  C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES    DO jk = 1, kflev + 1
320  C                ---------------------------------------------      jkki = 1
321  C      DO jaj = 1, 2
322   410  CONTINUE        iind2(1) = jaj
323  C        iind2(2) = jaj
324        DO 414 JK = 1 , KFLEV+1        DO jn = 1, 2
325        DO 413 JAJ = 1 , 5 , 2          jn2j = jn + 2*jaj
326        JAJP = JAJ + 1          jkkp4 = jkki + 4
327        DO 412 JL = 1, KDLON  
328        ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)          ! *         4.2.1  EFFECTIVE ABSORBER AMOUNTS
329        ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)          ! --------------------------
330        ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )  
331        ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )  
332   412  CONTINUE          DO jl = 1, kdlon
333   413  CONTINUE            zw2(jl, 1) = log(zrj(jl,jn,jk)/zrj(jl,jn2j,jk))/paki(jl, jaj)
334   414  CONTINUE            zw2(jl, 2) = log(zrk(jl,jn,jk)/zrk(jl,jn2j,jk))/paki(jl, jaj)
335  C          END DO
336        DO 417 JK = 1 , KFLEV+1  
337        DO 416 JAJ = 2 , 6 , 2          ! *         4.2.2  TRANSMISSION FUNCTION
338        DO 415 JL = 1, KDLON          ! ---------------------
339        ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )  
340        ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )  
341   415  CONTINUE          CALL swtt1(knu, 2, iind2, zw2, zr2)
342   416  CONTINUE  
343   417  CONTINUE          DO jl = 1, kdlon
344  C            zrl(jl, jkki) = zr2(jl, 1)
345  C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE            zruef(jl, jkki) = zw2(jl, 1)
346  C                 ---------------------------------------------            zrl(jl, jkkp4) = zr2(jl, 2)
347  C            zruef(jl, jkkp4) = zw2(jl, 2)
348   420  CONTINUE          END DO
349  C  
350        DO 437 JK = 1 , KFLEV+1          jkki = jkki + 1
351        JKKI = 1        END DO
352        DO 425 JAJ = 1 , 2      END DO
353        IIND2(1)=JAJ  
354        IIND2(2)=JAJ      ! *         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
355        DO 424 JN = 1 , 2      ! ------------------------------------------------------
356        JN2J = JN + 2 * JAJ  
357        JKKP4 = JKKI + 4  
358  C      DO jl = 1, kdlon
359  C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS        pfdown(jl, jk) = zrj(jl, 1, jk)*zrl(jl, 1)*zrl(jl, 3) + &
360  C                 --------------------------          zrj(jl, 2, jk)*zrl(jl, 2)*zrl(jl, 4)
361  C        pfup(jl, jk) = zrk(jl, 1, jk)*zrl(jl, 5)*zrl(jl, 7) + &
362   4210 CONTINUE          zrk(jl, 2, jk)*zrl(jl, 6)*zrl(jl, 8)
363  C      END DO
364        DO 4211 JL = 1, KDLON    END DO
365        ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))  
366       S                               / PAKI(JL,JAJ)  
367        ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))    ! ------------------------------------------------------------------
368       S                               / PAKI(JL,JAJ)  
369   4211 CONTINUE    ! *         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
370  C    ! ----------------------------------------
371  C*         4.2.2  TRANSMISSION FUNCTION  
372  C                 ---------------------  
373  C  
374   4220 CONTINUE    ! *         5.1   DOWNWARD FLUXES
375  C    ! ---------------
376        CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)  
377  C  
378        DO 4221 JL = 1, KDLON    jaj = 2
379        ZRL(JL,JKKI) = ZR2(JL,1)    iind3(1) = 1
380        ZRUEF(JL,JKKI) = ZW2(JL,1)    iind3(2) = 2
381        ZRL(JL,JKKP4) = ZR2(JL,2)    iind3(3) = 3
382        ZRUEF(JL,JKKP4) = ZW2(JL,2)  
383   4221 CONTINUE    DO jl = 1, kdlon
384  C      zw3(jl, 1) = 0.
385        JKKI=JKKI+1      zw3(jl, 2) = 0.
386   424  CONTINUE      zw3(jl, 3) = 0.
387   425  CONTINUE      zw4(jl) = 0.
388  C      zw5(jl) = 0.
389  C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION      zr4(jl) = 1.
390  C                 ------------------------------------------------------      zfd(jl, kflev+1) = zrj0(jl, jaj, kflev+1)
391  C    END DO
392   430  CONTINUE    DO jk = 1, kflev
393  C      ikl = kflev + 1 - jk
394        DO 431 JL = 1, KDLON      DO jl = 1, kdlon
395        PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)        zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
396       S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)        zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikl)/zrmu0(jl, ikl)
397        PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)        zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikl)/zrmu0(jl, ikl)
398       S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)        zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmu0(jl, ikl)
399   431  CONTINUE        zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmu0(jl, ikl)
400   437  CONTINUE      END DO
401  C  
402  C      CALL swtt1(knu, 3, iind3, zw3, zr3)
403  C     ------------------------------------------------------------------  
404  C      DO jl = 1, kdlon
405  C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES        ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
406  C                ----------------------------------------        zfd(jl, ikl) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
407  C          zrj0(jl, jaj, ikl)
408   500  CONTINUE      END DO
409  C    END DO
410  C  
411  C*         5.1   DOWNWARD FLUXES  
412  C                ---------------    ! *         5.2   UPWARD FLUXES
413  C    ! -------------
414   510  CONTINUE  
415  C  
416        JAJ = 2    DO jl = 1, kdlon
417        IIND3(1)=1      zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu)
418        IIND3(2)=2    END DO
419        IIND3(3)=3  
420  C          DO jk = 2, kflev + 1
421        DO 511 JL = 1, KDLON      ikm1 = jk - 1
422        ZW3(JL,1)=0.      DO jl = 1, kdlon
423        ZW3(JL,2)=0.        zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikm1)*1.66
424        ZW3(JL,3)=0.        zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikm1)*1.66
425        ZW4(JL)  =0.        zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikm1)*1.66
426        ZW5(JL)  =0.        zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
427        ZR4(JL)  =1.        zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
428        ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)      END DO
429   511  CONTINUE  
430        DO 514 JK = 1 , KFLEV      CALL swtt1(knu, 3, iind3, zw3, zr3)
431        IKL = KFLEV+1-JK  
432        DO 512 JL = 1, KDLON      DO jl = 1, kdlon
433        ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)        ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
434        ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)        zfu(jl, jk) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
435        ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)          zrk0(jl, jaj, jk)
436        ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)      END DO
437        ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)    END DO
438   512  CONTINUE  
439  C  
440        CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)    ! ------------------------------------------------------------------
441  C  
442        DO 513 JL = 1, KDLON    ! *         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
443  C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))    ! --------------------------------------------------
444        ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)  
445       S            * ZRJ0(JL,JAJ,IKL)    iabs = 3
446   513  CONTINUE  
447   514  CONTINUE    ! *         6.1    DOWNWARD FLUXES
448  C    ! ---------------
449  C  
450  C*         5.2   UPWARD FLUXES    DO jl = 1, kdlon
451  C                -------------      zw1(jl) = 0.
452  C      zw4(jl) = 0.
453   520  CONTINUE      zw5(jl) = 0.
454  C      zr1(jl) = 0.
455        DO 525 JL = 1, KDLON      pfdown(jl, kflev+1) = ((1.-pclear(jl))*pfdown(jl,kflev+1)+pclear(jl)*zfd( &
456        ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)        jl,kflev+1))*rsun(knu)
457   525  CONTINUE    END DO
458  C  
459        DO 528 JK = 2 , KFLEV+1    DO jk = 1, kflev
460        IKM1=JK-1      ikl = kflev + 1 - jk
461        DO 526 JL = 1, KDLON      DO jl = 1, kdlon
462        ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66        zw1(jl) = zw1(jl) + poz(jl, ikl)/zrmue(jl, ikl)
463        ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66        zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmue(jl, ikl)
464        ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66        zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmue(jl, ikl)
465        ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66        ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
466        ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66      END DO
467   526  CONTINUE  
468  C      CALL swtt(knu, iabs, zw1, zr1)
469        CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)  
470  C      DO jl = 1, kdlon
471        DO 527 JL = 1, KDLON        pfdown(jl, ikl) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfdown(jl,ikl)+ &
472  C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))          pclear(jl)*zfd(jl,ikl))*rsun(knu)
473        ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)      END DO
474       S           * ZRK0(JL,JAJ,JK)    END DO
475   527  CONTINUE  
476   528  CONTINUE  
477  C    ! *         6.2    UPWARD FLUXES
478  C    ! -------------
479  C     ------------------------------------------------------------------  
480  C    DO jl = 1, kdlon
481  C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION      pfup(jl, 1) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,1)+pclear(jl)*zfu( &
482  C                 --------------------------------------------------        jl,1))*rsun(knu)
483  C    END DO
484   600  CONTINUE  
485        IABS=3    DO jk = 2, kflev + 1
486  C      ikm1 = jk - 1
487  C*         6.1    DOWNWARD FLUXES      DO jl = 1, kdlon
488  C                 ---------------        zw1(jl) = zw1(jl) + poz(jl, ikm1)*1.66
489  C        zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
490   610  CONTINUE        zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
491        DO 611 JL = 1, KDLON        ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
492        ZW1(JL)=0.      END DO
493        ZW4(JL)=0.  
494        ZW5(JL)=0.      CALL swtt(knu, iabs, zw1, zr1)
495        ZR1(JL)=0.  
496        PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)      DO jl = 1, kdlon
497       S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)        pfup(jl, jk) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,jk)+pclear(jl)* &
498   611  CONTINUE          zfu(jl,jk))*rsun(knu)
499  C      END DO
500        DO 614 JK = 1 , KFLEV    END DO
501        IKL=KFLEV+1-JK  
502        DO 612 JL = 1, KDLON    ! ------------------------------------------------------------------
503        ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)  
504        ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)    RETURN
505        ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)  END SUBROUTINE sw2s
 C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))  
  612  CONTINUE  
 C  
       CALL SWTT(KNU, IABS, ZW1, ZR1)  
 C  
       DO 613 JL = 1, KDLON  
       PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)  
      S                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)  
  613  CONTINUE  
  614  CONTINUE  
 C  
 C  
 C*         6.2    UPWARD FLUXES  
 C                 -------------  
 C  
  620  CONTINUE  
       DO 621 JL = 1, KDLON  
       PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)  
      S                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)  
  621  CONTINUE  
 C  
       DO 624 JK = 2 , KFLEV+1  
       IKM1=JK-1  
       DO 622 JL = 1, KDLON  
       ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66  
       ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66  
       ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66  
 C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))  
  622  CONTINUE  
 C  
       CALL SWTT(KNU, IABS, ZW1, ZR1)  
 C  
       DO 623 JL = 1, KDLON  
       PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)  
      S                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)  
  623  CONTINUE  
  624  CONTINUE  
 C  
 C     ------------------------------------------------------------------  
 C  
       RETURN  
       END  
Legend:
Removed from v.76  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21