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