/[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 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        real*8 flag_aer      ! -OB
38        real*8 tauae(kdlon,kflev,2)      logical, intent(in):: flag_aer
39        real*8 pizae(kdlon,kflev,2)      DOUBLE PRECISION palbp(kdlon, 2)
40        real*8 cgae(kdlon,kflev,2)      DOUBLE PRECISION pdsig(kdlon, kflev)
41        REAL*8 PAER(KDLON,KFLEV,5)      DOUBLE PRECISION prayl(kdlon)
42        REAL*8 PALBP(KDLON,2)      DOUBLE PRECISION psec(kdlon)
43        REAL*8 PDSIG(KDLON,KFLEV)  
44        REAL*8 PRAYL(KDLON)      DOUBLE PRECISION pcgaz(kdlon, kflev)
45        REAL*8 PSEC(KDLON)      DOUBLE PRECISION ppizaz(kdlon, kflev)
46  C      DOUBLE PRECISION pray1(kdlon, kflev+1)
47        REAL*8 PCGAZ(KDLON,KFLEV)          DOUBLE PRECISION pray2(kdlon, kflev+1)
48        REAL*8 PPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION prefz(kdlon, 2, kflev+1)
49        REAL*8 PRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION prj(kdlon, 6, kflev+1)
50        REAL*8 PRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION prk(kdlon, 6, kflev+1)
51        REAL*8 PREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION prmu0(kdlon, kflev+1)
52        REAL*8 PRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION ptauaz(kdlon, kflev)
53        REAL*8 PRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION ptra1(kdlon, kflev+1)
54        REAL*8 PRMU0(KDLON,KFLEV+1)      DOUBLE PRECISION ptra2(kdlon, kflev+1)
55        REAL*8 PTAUAZ(KDLON,KFLEV)  
56        REAL*8 PTRA1(KDLON,KFLEV+1)      ! * LOCAL VARIABLES:
57        REAL*8 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        REAL*8 ZC0I(KDLON,KFLEV+1)            DOUBLE PRECISION zss0(kdlon)
62        REAL*8 ZCLE0(KDLON,KFLEV)      DOUBLE PRECISION zscat(kdlon)
63        REAL*8 ZCLEAR(KDLON)      DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
64        REAL*8 ZR21(KDLON)  
65        REAL*8 ZR23(KDLON)      INTEGER jl, jk, ja, jkl, jklp1, jaj, jkm1
66        REAL*8 ZSS0(KDLON)      DOUBLE PRECISION ztray, zgar, zratio, zff, zfacoa, zcorae
67        REAL*8 ZSCAT(KDLON)      DOUBLE PRECISION zmue, zgap, zww, zto, zden, zmu1, zden1
68        REAL*8 ZTR(KDLON,2,KFLEV+1)      DOUBLE PRECISION zbmu0, zbmu1, zre11
69  C  
70        INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in      ! ------------------------------------------------------------------
71        REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE  
72        REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1      ! *         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
73        REAL*8 ZBMU0, ZBMU1, ZRE11      ! --------------------------------------------
74  C  
75  C* Prescribed Data for Aerosols:  
76  C      DO jk = 1, kflev + 1
77        REAL*8 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.24  
changed lines
  Added in v.217
  ViewVC Help
Powered by ViewVC 1.1.21