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

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

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

trunk/libf/phylmd/Radlwsw/swclr.f revision 24 by guez, Wed Mar 3 13:23:49 2010 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        real*8 flag_aer      INTEGER knu
38        real*8 tauae(kdlon,kflev,2)      ! -OB
39        real*8 pizae(kdlon,kflev,2)      DOUBLE PRECISION flag_aer
40        real*8 cgae(kdlon,kflev,2)      DOUBLE PRECISION tauae(kdlon, kflev, 2)
41        REAL*8 PAER(KDLON,KFLEV,5)      DOUBLE PRECISION pizae(kdlon, kflev, 2)
42        REAL*8 PALBP(KDLON,2)      DOUBLE PRECISION cgae(kdlon, kflev, 2)
43        REAL*8 PDSIG(KDLON,KFLEV)      DOUBLE PRECISION palbp(kdlon, 2)
44        REAL*8 PRAYL(KDLON)      DOUBLE PRECISION pdsig(kdlon, kflev)
45        REAL*8 PSEC(KDLON)      DOUBLE PRECISION prayl(kdlon)
46  C      DOUBLE PRECISION psec(kdlon)
47        REAL*8 PCGAZ(KDLON,KFLEV)      
48        REAL*8 PPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION pcgaz(kdlon, kflev)
49        REAL*8 PRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION ppizaz(kdlon, kflev)
50        REAL*8 PRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION pray1(kdlon, kflev+1)
51        REAL*8 PREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION pray2(kdlon, kflev+1)
52        REAL*8 PRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION prefz(kdlon, 2, kflev+1)
53        REAL*8 PRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION prj(kdlon, 6, kflev+1)
54        REAL*8 PRMU0(KDLON,KFLEV+1)      DOUBLE PRECISION prk(kdlon, 6, kflev+1)
55        REAL*8 PTAUAZ(KDLON,KFLEV)      DOUBLE PRECISION prmu0(kdlon, kflev+1)
56        REAL*8 PTRA1(KDLON,KFLEV+1)      DOUBLE PRECISION ptauaz(kdlon, kflev)
57        REAL*8 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        REAL*8 ZC0I(KDLON,KFLEV+1)        
62        REAL*8 ZCLE0(KDLON,KFLEV)      DOUBLE PRECISION zc0i(kdlon, kflev+1)
63        REAL*8 ZCLEAR(KDLON)      DOUBLE PRECISION zclear(kdlon)
64        REAL*8 ZR21(KDLON)      DOUBLE PRECISION zr21(kdlon)
65        REAL*8 ZR23(KDLON)      DOUBLE PRECISION zss0(kdlon)
66        REAL*8 ZSS0(KDLON)      DOUBLE PRECISION zscat(kdlon)
67        REAL*8 ZSCAT(KDLON)      DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
68        REAL*8 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        REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE      DOUBLE PRECISION zmue, zgap, zww, zto, zden, zmu1, zden1
72        REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1      DOUBLE PRECISION zbmu0, zbmu1, zre11
73        REAL*8 ZBMU0, ZBMU1, ZRE11  
74  C      ! ------------------------------------------------------------------
75  C* Prescribed Data for Aerosols:  
76  C      ! *         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
77        REAL*8 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.24  
changed lines
  Added in v.208
  ViewVC Help
Powered by ViewVC 1.1.21