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