/[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/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        double precision flag_aer    DOUBLE PRECISION pizae(kdlon, kflev, 2)
38        double precision tauae(kdlon,kflev,2)    DOUBLE PRECISION cgae(kdlon, kflev, 2)
39        double precision pizae(kdlon,kflev,2)    DOUBLE PRECISION paer(kdlon, kflev, 5)
40        double precision cgae(kdlon,kflev,2)    DOUBLE PRECISION palbp(kdlon, 2)
41        DOUBLE PRECISION PAER(KDLON,KFLEV,5)    DOUBLE PRECISION pdsig(kdlon, kflev)
42        DOUBLE PRECISION PALBP(KDLON,2)    DOUBLE PRECISION prayl(kdlon)
43        DOUBLE PRECISION PDSIG(KDLON,KFLEV)    DOUBLE PRECISION psec(kdlon)
44        DOUBLE PRECISION PRAYL(KDLON)  
45        DOUBLE PRECISION PSEC(KDLON)    DOUBLE PRECISION pcgaz(kdlon, kflev)
46  C    DOUBLE PRECISION ppizaz(kdlon, kflev)
47        DOUBLE PRECISION PCGAZ(KDLON,KFLEV)        DOUBLE PRECISION pray1(kdlon, kflev+1)
48        DOUBLE PRECISION PPIZAZ(KDLON,KFLEV)    DOUBLE PRECISION pray2(kdlon, kflev+1)
49        DOUBLE PRECISION PRAY1(KDLON,KFLEV+1)    DOUBLE PRECISION prefz(kdlon, 2, kflev+1)
50        DOUBLE PRECISION PRAY2(KDLON,KFLEV+1)    DOUBLE PRECISION prj(kdlon, 6, kflev+1)
51        DOUBLE PRECISION PREFZ(KDLON,2,KFLEV+1)    DOUBLE PRECISION prk(kdlon, 6, kflev+1)
52        DOUBLE PRECISION PRJ(KDLON,6,KFLEV+1)    DOUBLE PRECISION prmu0(kdlon, kflev+1)
53        DOUBLE PRECISION PRK(KDLON,6,KFLEV+1)    DOUBLE PRECISION ptauaz(kdlon, kflev)
54        DOUBLE PRECISION PRMU0(KDLON,KFLEV+1)    DOUBLE PRECISION ptra1(kdlon, kflev+1)
55        DOUBLE PRECISION PTAUAZ(KDLON,KFLEV)    DOUBLE PRECISION ptra2(kdlon, kflev+1)
56        DOUBLE PRECISION PTRA1(KDLON,KFLEV+1)  
57        DOUBLE PRECISION 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        DOUBLE PRECISION ZC0I(KDLON,KFLEV+1)          DOUBLE PRECISION zclear(kdlon)
62        DOUBLE PRECISION ZCLE0(KDLON,KFLEV)    DOUBLE PRECISION zr21(kdlon)
63        DOUBLE PRECISION ZCLEAR(KDLON)    DOUBLE PRECISION zr23(kdlon)
64        DOUBLE PRECISION ZR21(KDLON)    DOUBLE PRECISION zss0(kdlon)
65        DOUBLE PRECISION ZR23(KDLON)    DOUBLE PRECISION zscat(kdlon)
66        DOUBLE PRECISION ZSS0(KDLON)    DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
67        DOUBLE PRECISION ZSCAT(KDLON)  
68        DOUBLE PRECISION 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        DOUBLE PRECISION ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE    DOUBLE PRECISION zbmu0, zbmu1, zre11
72        DOUBLE PRECISION ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1  
73        DOUBLE PRECISION 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        DOUBLE PRECISION 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.76  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21