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