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

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

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

trunk/libf/phylmd/Radlwsw/swclr.f revision 71 by guez, Mon Jul 8 18:12:18 2013 UTC trunk/Sources/phylmd/Radlwsw/swclr.f revision 208 by guez, Wed Dec 7 16:44:53 2016 UTC
# Line 1  Line 1 
1        SUBROUTINE SWCLR  ( KNU  module swclr_m
2       S  , PAER  , flag_aer, tauae, pizae, cgae  
3       S  , PALBP , PDSIG , PRAYL , PSEC    IMPLICIT NONE
4       S  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ    
5       S  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )  contains
6        use dimens_m  
7        use dimphy    SUBROUTINE swclr(knu, flag_aer, tauae, pizae, cgae, palbp, pdsig, prayl, &
8        use raddim         psec, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmu0, ptauaz, &
9        use radepsi         ptra1, ptra2)
10        use radopt      
11        IMPLICIT none      USE raddim, only: kdlon, kflev
12  C      USE radepsi, only: repsct, zepsec
13  C     ------------------------------------------------------------------      USE radopt, only: novlp
14  C     PURPOSE.  
15  C     --------      ! ------------------------------------------------------------------
16  C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF      ! PURPOSE.
17  C     CLEAR-SKY COLUMN      ! --------
18  C      ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
19  C     REFERENCE.      ! CLEAR-SKY COLUMN
20  C     ----------  
21  C      ! REFERENCE.
22  C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT      ! ----------
23  C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)  
24  C      ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
25  C     AUTHOR.      ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
26  C     -------  
27  C        JEAN-JACQUES MORCRETTE  *ECMWF*      ! AUTHOR.
28  C      ! -------
29  C     MODIFICATIONS.      ! JEAN-JACQUES MORCRETTE  *ECMWF*
30  C     --------------  
31  C        ORIGINAL : 94-11-15      ! MODIFICATIONS.
32  C     ------------------------------------------------------------------      ! --------------
33  C* ARGUMENTS:      ! ORIGINAL : 94-11-15
34  C      ! ------------------------------------------------------------------
35        INTEGER KNU      ! * ARGUMENTS:
36  c-OB  
37        double precision flag_aer      INTEGER knu
38        double precision tauae(kdlon,kflev,2)      ! -OB
39        double precision pizae(kdlon,kflev,2)      DOUBLE PRECISION flag_aer
40        double precision cgae(kdlon,kflev,2)      DOUBLE PRECISION tauae(kdlon, kflev, 2)
41        DOUBLE PRECISION PAER(KDLON,KFLEV,5)      DOUBLE PRECISION pizae(kdlon, kflev, 2)
42        DOUBLE PRECISION PALBP(KDLON,2)      DOUBLE PRECISION cgae(kdlon, kflev, 2)
43        DOUBLE PRECISION PDSIG(KDLON,KFLEV)      DOUBLE PRECISION palbp(kdlon, 2)
44        DOUBLE PRECISION PRAYL(KDLON)      DOUBLE PRECISION pdsig(kdlon, kflev)
45        DOUBLE PRECISION PSEC(KDLON)      DOUBLE PRECISION prayl(kdlon)
46  C      DOUBLE PRECISION psec(kdlon)
47        DOUBLE PRECISION PCGAZ(KDLON,KFLEV)      
48        DOUBLE PRECISION PPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION pcgaz(kdlon, kflev)
49        DOUBLE PRECISION PRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION ppizaz(kdlon, kflev)
50        DOUBLE PRECISION PRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION pray1(kdlon, kflev+1)
51        DOUBLE PRECISION PREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION pray2(kdlon, kflev+1)
52        DOUBLE PRECISION PRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION prefz(kdlon, 2, kflev+1)
53        DOUBLE PRECISION PRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION prj(kdlon, 6, kflev+1)
54        DOUBLE PRECISION PRMU0(KDLON,KFLEV+1)      DOUBLE PRECISION prk(kdlon, 6, kflev+1)
55        DOUBLE PRECISION PTAUAZ(KDLON,KFLEV)      DOUBLE PRECISION prmu0(kdlon, kflev+1)
56        DOUBLE PRECISION PTRA1(KDLON,KFLEV+1)      DOUBLE PRECISION ptauaz(kdlon, kflev)
57        DOUBLE PRECISION PTRA2(KDLON,KFLEV+1)      DOUBLE PRECISION ptra1(kdlon, kflev+1)
58  C      DOUBLE PRECISION ptra2(kdlon, kflev+1)
59  C* LOCAL VARIABLES:  
60  C      ! * LOCAL VARIABLES:
61        DOUBLE PRECISION ZC0I(KDLON,KFLEV+1)        
62        DOUBLE PRECISION ZCLE0(KDLON,KFLEV)      DOUBLE PRECISION zc0i(kdlon, kflev+1)
63        DOUBLE PRECISION ZCLEAR(KDLON)      DOUBLE PRECISION zclear(kdlon)
64        DOUBLE PRECISION ZR21(KDLON)      DOUBLE PRECISION zr21(kdlon)
65        DOUBLE PRECISION ZR23(KDLON)      DOUBLE PRECISION zss0(kdlon)
66        DOUBLE PRECISION ZSS0(KDLON)      DOUBLE PRECISION zscat(kdlon)
67        DOUBLE PRECISION ZSCAT(KDLON)      DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
68        DOUBLE PRECISION ZTR(KDLON,2,KFLEV+1)  
69  C      INTEGER jl, jk, ja, jkl, jklp1, jaj, jkm1
70        INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in      DOUBLE PRECISION ztray, zgar, zratio, zff, zfacoa, zcorae
71        DOUBLE PRECISION ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE      DOUBLE PRECISION zmue, zgap, zww, zto, zden, zmu1, zden1
72        DOUBLE PRECISION ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1      DOUBLE PRECISION zbmu0, zbmu1, zre11
73        DOUBLE PRECISION ZBMU0, ZBMU1, ZRE11  
74  C      ! ------------------------------------------------------------------
75  C* Prescribed Data for Aerosols:  
76  C      ! *         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
77        DOUBLE PRECISION TAUA(2,5), RPIZA(2,5), RCGA(2,5)      ! --------------------------------------------
78        SAVE TAUA, RPIZA, RCGA  
79        DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /  
80       S .730719, .912819, .725059, .745405, .682188 ,      DO jk = 1, kflev + 1
81       S .730719, .912819, .725059, .745405, .682188 /         DO ja = 1, 6
82        DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /            DO jl = 1, kdlon
83       S .872212, .982545, .623143, .944887, .997975 ,               prj(jl, ja, jk) = 0.
84       S .872212, .982545, .623143, .944887, .997975 /               prk(jl, ja, jk) = 0.
85        DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /            END DO
86       S .647596, .739002, .580845, .662657, .624246 ,         END DO
87       S .647596, .739002, .580845, .662657, .624246 /      END DO
88  C     ------------------------------------------------------------------  
89  C      DO jk = 1, kflev
90  C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH         DO jl = 1, kdlon
91  C                --------------------------------------------            ptauaz(jl, jk) = flag_aer*tauae(jl, jk, knu)
92  C            ppizaz(jl, jk) = flag_aer*pizae(jl, jk, knu)
93   100  CONTINUE            pcgaz(jl, jk) = flag_aer*cgae(jl, jk, knu)
94  C         END DO
95        DO 103 JK = 1 , KFLEV+1  
96        DO 102 JA = 1 , 6         IF (flag_aer>0) THEN
97        DO 101 JL = 1, KDLON            ! -OB
98        PRJ(JL,JA,JK) = 0.            DO jl = 1, kdlon
99        PRK(JL,JA,JK) = 0.               ! PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
100   101  CONTINUE               ! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
101   102  CONTINUE               ztray = prayl(jl)*pdsig(jl, jk)
102   103  CONTINUE               zratio = ztray/(ztray+ptauaz(jl,jk))
103  C               zgar = pcgaz(jl, jk)
104        DO 108 JK = 1 , KFLEV               zff = zgar*zgar
105  c-OB               ptauaz(jl, jk) = ztray + ptauaz(jl, jk)*(1.-ppizaz(jl,jk)*zff)
106  c      DO 104 JL = 1, KDLON               pcgaz(jl, jk) = zgar*(1.-zratio)/(1.+zgar)
107  c      PCGAZ(JL,JK) = 0.               ppizaz(jl, jk) = zratio + (1.-zratio)*ppizaz(jl, jk)*(1.-zff)/(1.- &
108  c      PPIZAZ(JL,JK) =  0.                    ppizaz(jl,jk)*zff)
109  c      PTAUAZ(JL,JK) = 0.            END DO
110  c 104  CONTINUE         ELSE
111  c-OB            DO jl = 1, kdlon
112  c      DO 106 JAE=1,5               ztray = prayl(jl)*pdsig(jl, jk)
113  c      DO 105 JL = 1, KDLON               ptauaz(jl, jk) = ztray
114  c      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)               pcgaz(jl, jk) = 0.
115  c     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)               ppizaz(jl, jk) = 1. - repsct
116  c      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)            END DO
117  c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)         END IF ! check flag_aer
118  c      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)      END DO
119  c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)  
120  c 105  CONTINUE      ! ------------------------------------------------------------------
121  c 106  CONTINUE  
122  c-OB      ! *         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
123        DO 105 JL = 1, KDLON      ! ----------------------------------------------
124        PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)  
125        PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)  
126        PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)      DO jl = 1, kdlon
127   105  CONTINUE         zc0i(jl, kflev+1) = 0.
128  C         zclear(jl) = 1.
129        IF (flag_aer.GT.0) THEN         zscat(jl) = 0.
130  c-OB      END DO
131        DO 107 JL = 1, KDLON  
132  c         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)      jk = 1
133  c         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)      jkl = kflev + 1 - jk
134           ZTRAY = PRAYL(JL) * PDSIG(JL,JK)      jklp1 = jkl + 1
135           ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))      DO jl = 1, kdlon
136           ZGAR = PCGAZ(JL,JK)         zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
137           ZFF = ZGAR * ZGAR         zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
138           PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)         zr21(jl) = exp(-zcorae)
139           PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)         zss0(jl) = 1. - zr21(jl)
140           PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)  
141       S                       / (1. - PPIZAZ(JL,JK) * ZFF)         IF (novlp==1) THEN
142   107  CONTINUE            ! * maximum-random
143        ELSE            zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
144        DO JL = 1, KDLON                 (1.0-min(zscat(jl),1.-zepsec))
145           ZTRAY = PRAYL(JL) * PDSIG(JL,JK)            zc0i(jl, jkl) = 1.0 - zclear(jl)
146           PTAUAZ(JL,JK) = ZTRAY            zscat(jl) = zss0(jl)
147           PCGAZ(JL,JK) = 0.         ELSE IF (novlp==2) THEN
148           PPIZAZ(JL,JK) = 1.-REPSCT            ! * maximum
149        END DO            zscat(jl) = max(zss0(jl), zscat(jl))
150        END IF   ! check flag_aer            zc0i(jl, jkl) = zscat(jl)
151  c     107  CONTINUE         ELSE IF (novlp==3) THEN
152  c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)            ! * random
153  c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)            zclear(jl) = zclear(jl)*(1.0-zss0(jl))
154  c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)            zscat(jl) = 1.0 - zclear(jl)
155  C            zc0i(jl, jkl) = zscat(jl)
156   108  CONTINUE         END IF
157  C      END DO
158  C     ------------------------------------------------------------------  
159  C      DO jk = 2, kflev
160  C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL         jkl = kflev + 1 - jk
161  C                ----------------------------------------------         jklp1 = jkl + 1
162  C         DO jl = 1, kdlon
163   200  CONTINUE            zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
164  C            zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
165        DO 201 JL = 1, KDLON            zr21(jl) = exp(-zcorae)
166        ZR23(JL) = 0.            zss0(jl) = 1. - zr21(jl)
167        ZC0I(JL,KFLEV+1) = 0.  
168        ZCLEAR(JL) = 1.            IF (novlp==1) THEN
169        ZSCAT(JL) = 0.               ! * maximum-random
170   201  CONTINUE               zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
171  C                    (1.0-min(zscat(jl),1.-zepsec))
172        JK = 1               zc0i(jl, jkl) = 1.0 - zclear(jl)
173        JKL = KFLEV+1 - JK               zscat(jl) = zss0(jl)
174        JKLP1 = JKL + 1            ELSE IF (novlp==2) THEN
175        DO 202 JL = 1, KDLON               ! * maximum
176        ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)               zscat(jl) = max(zss0(jl), zscat(jl))
177        ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)               zc0i(jl, jkl) = zscat(jl)
178        ZR21(JL) = EXP(-ZCORAE   )            ELSE IF (novlp==3) THEN
179        ZSS0(JL) = 1.-ZR21(JL)               ! * random
180        ZCLE0(JL,JKL) = ZSS0(JL)               zclear(jl) = zclear(jl)*(1.0-zss0(jl))
181  C               zscat(jl) = 1.0 - zclear(jl)
182        IF (NOVLP.EQ.1) THEN               zc0i(jl, jkl) = zscat(jl)
183  c* maximum-random            END IF
184           ZCLEAR(JL) = ZCLEAR(JL)         END DO
185       S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))      END DO
186       S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))  
187           ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)      ! ------------------------------------------------------------------
188           ZSCAT(JL) = ZSS0(JL)  
189        ELSE IF (NOVLP.EQ.2) THEN      ! *         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
190  C* maximum      ! -----------------------------------------------
191           ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )  
192           ZC0I(JL,JKL) = ZSCAT(JL)  
193        ELSE IF (NOVLP.EQ.3) THEN      DO jl = 1, kdlon
194  c* random         pray1(jl, kflev+1) = 0.
195           ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))         pray2(jl, kflev+1) = 0.
196           ZSCAT(JL) = 1.0 - ZCLEAR(JL)         prefz(jl, 2, 1) = palbp(jl, knu)
197           ZC0I(JL,JKL) = ZSCAT(JL)         prefz(jl, 1, 1) = palbp(jl, knu)
198        END IF         ptra1(jl, kflev+1) = 1.
199   202  CONTINUE         ptra2(jl, kflev+1) = 1.
200  C      END DO
201        DO 205 JK = 2 , KFLEV  
202        JKL = KFLEV+1 - JK      DO jk = 2, kflev + 1
203        JKLP1 = JKL + 1         jkm1 = jk - 1
204        DO 204 JL = 1, KDLON         DO jl = 1, kdlon
205        ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)  
206        ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)  
207        ZR21(JL) = EXP(-ZCORAE   )            ! ------------------------------------------------------------------
208        ZSS0(JL) = 1.-ZR21(JL)  
209        ZCLE0(JL,JKL) = ZSS0(JL)            ! *         3.1  EQUIVALENT ZENITH ANGLE
210  c                ! -----------------------
211        IF (NOVLP.EQ.1) THEN  
212  c* maximum-random  
213           ZCLEAR(JL) = ZCLEAR(JL)            zmue = (1.-zc0i(jl,jk))*psec(jl) + zc0i(jl, jk)*1.66
214       S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))            prmu0(jl, jk) = 1./zmue
215       S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))  
216           ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)  
217           ZSCAT(JL) = ZSS0(JL)            ! ------------------------------------------------------------------
218        ELSE IF (NOVLP.EQ.2) THEN  
219  C* maximum            ! *         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
220           ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )            ! ----------------------------------------------------
221           ZC0I(JL,JKL) = ZSCAT(JL)  
222        ELSE IF (NOVLP.EQ.3) THEN  
223  c* random            zgap = pcgaz(jl, jkm1)
224           ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))            zbmu0 = 0.5 - 0.75*zgap/zmue
225           ZSCAT(JL) = 1.0 - ZCLEAR(JL)            zww = ppizaz(jl, jkm1)
226           ZC0I(JL,JKL) = ZSCAT(JL)            zto = ptauaz(jl, jkm1)
227        END IF                              zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) &
228   204  CONTINUE                 *zto*zto*zmue*zmue
229   205  CONTINUE            pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden
230  C            ptra1(jl, jkm1) = 1./zden
231  C     ------------------------------------------------------------------  
232  C            zmu1 = 0.5
233  C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING            zbmu1 = 0.5 - 0.75*zgap*zmu1
234  C                -----------------------------------------------            zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww &
235  C                 )*zto*zto/zmu1/zmu1
236   300  CONTINUE            pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1
237  C            ptra2(jl, jkm1) = 1./zden1
238        DO 301 JL = 1, KDLON  
239        PRAY1(JL,KFLEV+1) = 0.  
240        PRAY2(JL,KFLEV+1) = 0.  
241        PREFZ(JL,2,1) = PALBP(JL,KNU)            prefz(jl, 1, jk) = (pray1(jl,jkm1)+prefz(jl,1,jkm1)*ptra1(jl,jkm1)* &
242        PREFZ(JL,1,1) = PALBP(JL,KNU)                 ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1,jkm1)))
243        PTRA1(JL,KFLEV+1) = 1.  
244        PTRA2(JL,KFLEV+1) = 1.            ztr(jl, 1, jkm1) = (ptra1(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &
245   301  CONTINUE                 jkm1)))
246  C  
247        DO 346 JK = 2 , KFLEV+1            prefz(jl, 2, jk) = (pray1(jl,jkm1)+prefz(jl,2,jkm1)*ptra1(jl,jkm1)* &
248        JKM1 = JK-1                 ptra2(jl,jkm1))
249        DO 342 JL = 1, KDLON  
250  C            ztr(jl, 2, jkm1) = ptra1(jl, jkm1)
251  C  
252  C     ------------------------------------------------------------------         END DO
253  C      END DO
254  C*         3.1  EQUIVALENT ZENITH ANGLE      DO jl = 1, kdlon
255  C               -----------------------         zmue = (1.-zc0i(jl,1))*psec(jl) + zc0i(jl, 1)*1.66
256  C         prmu0(jl, 1) = 1./zmue
257   310  CONTINUE      END DO
258  C  
259        ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)  
260       S            + ZC0I(JL,JK) * 1.66      ! ------------------------------------------------------------------
261        PRMU0(JL,JK) = 1./ZMUE  
262  C      ! *         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
263  C      ! -------------------------------------------------
264  C     ------------------------------------------------------------------  
265  C  
266  C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS      IF (knu==1) THEN
267  C               ----------------------------------------------------         jaj = 2
268  C         DO jl = 1, kdlon
269   320  CONTINUE            prj(jl, jaj, kflev+1) = 1.
270  C            prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
271        ZGAP = PCGAZ(JL,JKM1)         END DO
272        ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE  
273        ZWW = PPIZAZ(JL,JKM1)         DO jk = 1, kflev
274        ZTO = PTAUAZ(JL,JKM1)            jkl = kflev + 1 - jk
275        ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE            jklp1 = jkl + 1
276       S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE            DO jl = 1, kdlon
277        PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN               zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
278        PTRA1(JL,JKM1) = 1. / ZDEN               prj(jl, jaj, jkl) = zre11
279  C               prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
280        ZMU1 = 0.5            END DO
281        ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1         END DO
282        ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1  
283       S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1      ELSE
284        PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1  
285        PTRA2(JL,JKM1) = 1. / ZDEN1         DO jaj = 1, 2
286  C            DO jl = 1, kdlon
287  C               prj(jl, jaj, kflev+1) = 1.
288  C               prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
289        PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)            END DO
290       S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)  
291       S               * PTRA2(JL,JKM1)            DO jk = 1, kflev
292       S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))               jkl = kflev + 1 - jk
293  C               jklp1 = jkl + 1
294        ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)               DO jl = 1, kdlon
295       S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))                  zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
296  C                  prj(jl, jaj, jkl) = zre11
297        PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)                  prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
298       S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)               END DO
299       S               * PTRA2(JL,JKM1) )            END DO
300  C         END DO
301        ZTR(JL,2,JKM1) = PTRA1(JL,JKM1)  
302  C      END IF
303   342  CONTINUE  
304   346  CONTINUE    END SUBROUTINE swclr
305        DO 347 JL = 1, KDLON  
306        ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66  end module swclr_m
       PRMU0(JL,1)=1./ZMUE  
  347  CONTINUE  
 C  
 C  
 C     ------------------------------------------------------------------  
 C  
 C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL  
 C                 -------------------------------------------------  
 C  
  350  CONTINUE  
 C  
       IF (KNU.EQ.1) THEN  
       JAJ = 2  
       DO 351 JL = 1, KDLON  
       PRJ(JL,JAJ,KFLEV+1) = 1.  
       PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)  
  351  CONTINUE  
 C  
       DO 353 JK = 1 , KFLEV  
       JKL = KFLEV+1 - JK  
       JKLP1 = JKL + 1  
       DO 352 JL = 1, KDLON  
       ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)  
       PRJ(JL,JAJ,JKL) = ZRE11  
       PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)  
  352  CONTINUE  
  353  CONTINUE  
  354  CONTINUE  
 C  
       ELSE  
 C  
       DO 358 JAJ = 1 , 2  
       DO 355 JL = 1, KDLON  
       PRJ(JL,JAJ,KFLEV+1) = 1.  
       PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)  
  355  CONTINUE  
 C  
       DO 357 JK = 1 , KFLEV  
       JKL = KFLEV+1 - JK  
       JKLP1 = JKL + 1  
       DO 356 JL = 1, KDLON  
       ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)  
       PRJ(JL,JAJ,JKL) = ZRE11  
       PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)  
  356  CONTINUE  
  357  CONTINUE  
  358  CONTINUE  
 C  
       END IF  
 C  
 C     ------------------------------------------------------------------  
 C  
       RETURN  
       END  
Legend:
Removed from v.71  
changed lines
  Added in v.208
  ViewVC Help
Powered by ViewVC 1.1.21