/[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/phylmd/Radlwsw/swclr.f revision 254 by guez, Mon Feb 5 10:39:38 2018 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        real*8 flag_aer      DOUBLE PRECISION pray1(kdlon, kflev + 1)
38        real*8 tauae(kdlon,kflev,2)      DOUBLE PRECISION pray2(kdlon, kflev + 1)
39        real*8 pizae(kdlon,kflev,2)      DOUBLE PRECISION prefz(kdlon, 2, kflev + 1)
40        real*8 cgae(kdlon,kflev,2)      DOUBLE PRECISION prj(kdlon, 6, kflev + 1)
41        REAL*8 PAER(KDLON,KFLEV,5)      DOUBLE PRECISION prk(kdlon, 6, kflev + 1)
42        REAL*8 PALBP(KDLON,2)      DOUBLE PRECISION prmu0(kdlon, kflev + 1)
43        REAL*8 PDSIG(KDLON,KFLEV)      DOUBLE PRECISION, intent(out):: ptauaz(kdlon, kflev)
44        REAL*8 PRAYL(KDLON)      DOUBLE PRECISION ptra1(kdlon, kflev + 1)
45        REAL*8 PSEC(KDLON)      DOUBLE PRECISION ptra2(kdlon, kflev + 1)
46  C  
47        REAL*8 PCGAZ(KDLON,KFLEV)          ! LOCAL VARIABLES:
48        REAL*8 PPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION zc0i(kdlon, kflev + 1)
49        REAL*8 PRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION zclear(kdlon)
50        REAL*8 PRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION zr21(kdlon)
51        REAL*8 PREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION zss0(kdlon)
52        REAL*8 PRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION zscat(kdlon)
53        REAL*8 PRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION ztr(kdlon, 2, kflev + 1)
54        REAL*8 PRMU0(KDLON,KFLEV+1)      INTEGER jl, jk, ja, jkl, jklp1, jaj, jkm1
55        REAL*8 PTAUAZ(KDLON,KFLEV)      DOUBLE PRECISION zfacoa, zcorae
56        REAL*8 PTRA1(KDLON,KFLEV+1)      DOUBLE PRECISION zmue, zgap, zww, zto, zden, zmu1, zden1
57        REAL*8 PTRA2(KDLON,KFLEV+1)      DOUBLE PRECISION zbmu0, zbmu1, zre11
58  C      double precision, parameter:: REPSCT = 1d-10
59  C* LOCAL VARIABLES:  
60  C      !------------------------------------------------------------------
61        REAL*8 ZC0I(KDLON,KFLEV+1)            
62        REAL*8 ZCLE0(KDLON,KFLEV)      ! 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
63        REAL*8 ZCLEAR(KDLON)  
64        REAL*8 ZR21(KDLON)      DO jk = 1, kflev + 1
65        REAL*8 ZR23(KDLON)         DO ja = 1, 6
66        REAL*8 ZSS0(KDLON)            DO jl = 1, kdlon
67        REAL*8 ZSCAT(KDLON)               prj(jl, ja, jk) = 0d0
68        REAL*8 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        REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE      END DO
72        REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1  
73        REAL*8 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        REAL*8 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.24  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.21