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