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