/[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/Sources/phylmd/Radlwsw/swclr.f revision 157 by guez, Mon Jul 20 16:01:49 2015 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, jkl, jklp1, jaj, jkm1
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    ! ------------------------------------------------------------------
74  C  
75  C* Prescribed Data for Aerosols:    ! *         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
76  C    ! --------------------------------------------
77        REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)  
78        SAVE TAUA, RPIZA, RCGA  
79        DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /    DO jk = 1, kflev + 1
80       S .730719, .912819, .725059, .745405, .682188 ,      DO ja = 1, 6
81       S .730719, .912819, .725059, .745405, .682188 /        DO jl = 1, kdlon
82        DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /          prj(jl, ja, jk) = 0.
83       S .872212, .982545, .623143, .944887, .997975 ,          prk(jl, ja, jk) = 0.
      S .872212, .982545, .623143, .944887, .997975 /  
       DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /  
      S .647596, .739002, .580845, .662657, .624246 ,  
      S .647596, .739002, .580845, .662657, .624246 /  
 C     ------------------------------------------------------------------  
 C  
 C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH  
 C                --------------------------------------------  
 C  
  100  CONTINUE  
 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  
84        END DO        END DO
85        END IF   ! check flag_aer      END DO
86  c     107  CONTINUE    END DO
87  c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)  
88  c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)    DO jk = 1, kflev
89  c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)      DO jl = 1, kdlon
90  C        ptauaz(jl, jk) = flag_aer*tauae(jl, jk, knu)
91   108  CONTINUE        ppizaz(jl, jk) = flag_aer*pizae(jl, jk, knu)
92  C        pcgaz(jl, jk) = flag_aer*cgae(jl, jk, knu)
93  C     ------------------------------------------------------------------      END DO
94  C  
95  C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL      IF (flag_aer>0) THEN
96  C                ----------------------------------------------        ! -OB
97  C        DO jl = 1, kdlon
98   200  CONTINUE          ! PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
99  C          ! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
100        DO 201 JL = 1, KDLON          ztray = prayl(jl)*pdsig(jl, jk)
101        ZR23(JL) = 0.          zratio = ztray/(ztray+ptauaz(jl,jk))
102        ZC0I(JL,KFLEV+1) = 0.          zgar = pcgaz(jl, jk)
103        ZCLEAR(JL) = 1.          zff = zgar*zgar
104        ZSCAT(JL) = 0.          ptauaz(jl, jk) = ztray + ptauaz(jl, jk)*(1.-ppizaz(jl,jk)*zff)
105   201  CONTINUE          pcgaz(jl, jk) = zgar*(1.-zratio)/(1.+zgar)
106  C          ppizaz(jl, jk) = zratio + (1.-zratio)*ppizaz(jl, jk)*(1.-zff)/(1.- &
107        JK = 1            ppizaz(jl,jk)*zff)
108        JKL = KFLEV+1 - JK        END DO
109        JKLP1 = JKL + 1      ELSE
110        DO 202 JL = 1, KDLON        DO jl = 1, kdlon
111        ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)          ztray = prayl(jl)*pdsig(jl, jk)
112        ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)          ptauaz(jl, jk) = ztray
113        ZR21(JL) = EXP(-ZCORAE   )          pcgaz(jl, jk) = 0.
114        ZSS0(JL) = 1.-ZR21(JL)          ppizaz(jl, jk) = 1. - repsct
115        ZCLE0(JL,JKL) = ZSS0(JL)        END DO
116  C      END IF ! check flag_aer
117        IF (NOVLP.EQ.1) THEN    END DO
118  c* maximum-random  
119           ZCLEAR(JL) = ZCLEAR(JL)    ! ------------------------------------------------------------------
120       S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))  
121       S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))    ! *         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
122           ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)    ! ----------------------------------------------
123           ZSCAT(JL) = ZSS0(JL)  
124        ELSE IF (NOVLP.EQ.2) THEN  
125  C* maximum    DO jl = 1, kdlon
126           ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )      zr23(jl) = 0.
127           ZC0I(JL,JKL) = ZSCAT(JL)      zc0i(jl, kflev+1) = 0.
128        ELSE IF (NOVLP.EQ.3) THEN      zclear(jl) = 1.
129  c* random      zscat(jl) = 0.
130           ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))    END DO
131           ZSCAT(JL) = 1.0 - ZCLEAR(JL)  
132           ZC0I(JL,JKL) = ZSCAT(JL)    jk = 1
133        END IF    jkl = kflev + 1 - jk
134   202  CONTINUE    jklp1 = jkl + 1
135  C    DO jl = 1, kdlon
136        DO 205 JK = 2 , KFLEV      zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
137        JKL = KFLEV+1 - JK      zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
138        JKLP1 = JKL + 1      zr21(jl) = exp(-zcorae)
139        DO 204 JL = 1, KDLON      zss0(jl) = 1. - zr21(jl)
140        ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)      zcle0(jl, jkl) = zss0(jl)
141        ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)  
142        ZR21(JL) = EXP(-ZCORAE   )      IF (novlp==1) THEN
143        ZSS0(JL) = 1.-ZR21(JL)        ! * maximum-random
144        ZCLE0(JL,JKL) = ZSS0(JL)        zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
145  c              (1.0-min(zscat(jl),1.-zepsec))
146        IF (NOVLP.EQ.1) THEN        zc0i(jl, jkl) = 1.0 - zclear(jl)
147  c* maximum-random        zscat(jl) = zss0(jl)
148           ZCLEAR(JL) = ZCLEAR(JL)      ELSE IF (novlp==2) THEN
149       S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))        ! * maximum
150       S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))        zscat(jl) = max(zss0(jl), zscat(jl))
151           ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)        zc0i(jl, jkl) = zscat(jl)
152           ZSCAT(JL) = ZSS0(JL)      ELSE IF (novlp==3) THEN
153        ELSE IF (NOVLP.EQ.2) THEN        ! * random
154  C* maximum        zclear(jl) = zclear(jl)*(1.0-zss0(jl))
155           ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )        zscat(jl) = 1.0 - zclear(jl)
156           ZC0I(JL,JKL) = ZSCAT(JL)        zc0i(jl, jkl) = zscat(jl)
157        ELSE IF (NOVLP.EQ.3) THEN      END IF
158  c* random    END DO
159           ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))  
160           ZSCAT(JL) = 1.0 - ZCLEAR(JL)    DO jk = 2, kflev
161           ZC0I(JL,JKL) = ZSCAT(JL)      jkl = kflev + 1 - jk
162        END IF                        jklp1 = jkl + 1
163   204  CONTINUE      DO jl = 1, kdlon
164   205  CONTINUE        zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
165  C        zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
166  C     ------------------------------------------------------------------        zr21(jl) = exp(-zcorae)
167  C        zss0(jl) = 1. - zr21(jl)
168  C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING        zcle0(jl, jkl) = zss0(jl)
169  C                -----------------------------------------------  
170  C        IF (novlp==1) THEN
171   300  CONTINUE          ! * maximum-random
172  C          zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
173        DO 301 JL = 1, KDLON            (1.0-min(zscat(jl),1.-zepsec))
174        PRAY1(JL,KFLEV+1) = 0.          zc0i(jl, jkl) = 1.0 - zclear(jl)
175        PRAY2(JL,KFLEV+1) = 0.          zscat(jl) = zss0(jl)
176        PREFZ(JL,2,1) = PALBP(JL,KNU)        ELSE IF (novlp==2) THEN
177        PREFZ(JL,1,1) = PALBP(JL,KNU)          ! * maximum
178        PTRA1(JL,KFLEV+1) = 1.          zscat(jl) = max(zss0(jl), zscat(jl))
179        PTRA2(JL,KFLEV+1) = 1.          zc0i(jl, jkl) = zscat(jl)
180   301  CONTINUE        ELSE IF (novlp==3) THEN
181  C          ! * random
182        DO 346 JK = 2 , KFLEV+1          zclear(jl) = zclear(jl)*(1.0-zss0(jl))
183        JKM1 = JK-1          zscat(jl) = 1.0 - zclear(jl)
184        DO 342 JL = 1, KDLON          zc0i(jl, jkl) = zscat(jl)
 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  
185        END IF        END IF
186  C      END DO
187  C     ------------------------------------------------------------------    END DO
188  C  
189        RETURN    ! ------------------------------------------------------------------
190        END  
191      ! *         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
192      ! -----------------------------------------------
193    
194    
195      DO jl = 1, kdlon
196        pray1(jl, kflev+1) = 0.
197        pray2(jl, kflev+1) = 0.
198        prefz(jl, 2, 1) = palbp(jl, knu)
199        prefz(jl, 1, 1) = palbp(jl, knu)
200        ptra1(jl, kflev+1) = 1.
201        ptra2(jl, kflev+1) = 1.
202      END DO
203    
204      DO jk = 2, kflev + 1
205        jkm1 = jk - 1
206        DO jl = 1, kdlon
207    
208    
209          ! ------------------------------------------------------------------
210    
211          ! *         3.1  EQUIVALENT ZENITH ANGLE
212          ! -----------------------
213    
214    
215          zmue = (1.-zc0i(jl,jk))*psec(jl) + zc0i(jl, jk)*1.66
216          prmu0(jl, jk) = 1./zmue
217    
218    
219          ! ------------------------------------------------------------------
220    
221          ! *         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
222          ! ----------------------------------------------------
223    
224    
225          zgap = pcgaz(jl, jkm1)
226          zbmu0 = 0.5 - 0.75*zgap/zmue
227          zww = ppizaz(jl, jkm1)
228          zto = ptauaz(jl, jkm1)
229          zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) &
230            *zto*zto*zmue*zmue
231          pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden
232          ptra1(jl, jkm1) = 1./zden
233    
234          zmu1 = 0.5
235          zbmu1 = 0.5 - 0.75*zgap*zmu1
236          zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww &
237            )*zto*zto/zmu1/zmu1
238          pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1
239          ptra2(jl, jkm1) = 1./zden1
240    
241    
242    
243          prefz(jl, 1, jk) = (pray1(jl,jkm1)+prefz(jl,1,jkm1)*ptra1(jl,jkm1)* &
244            ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1,jkm1)))
245    
246          ztr(jl, 1, jkm1) = (ptra1(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &
247            jkm1)))
248    
249          prefz(jl, 2, jk) = (pray1(jl,jkm1)+prefz(jl,2,jkm1)*ptra1(jl,jkm1)* &
250            ptra2(jl,jkm1))
251    
252          ztr(jl, 2, jkm1) = ptra1(jl, jkm1)
253    
254        END DO
255      END DO
256      DO jl = 1, kdlon
257        zmue = (1.-zc0i(jl,1))*psec(jl) + zc0i(jl, 1)*1.66
258        prmu0(jl, 1) = 1./zmue
259      END DO
260    
261    
262      ! ------------------------------------------------------------------
263    
264      ! *         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
265      ! -------------------------------------------------
266    
267    
268      IF (knu==1) THEN
269        jaj = 2
270        DO jl = 1, kdlon
271          prj(jl, jaj, kflev+1) = 1.
272          prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
273        END DO
274    
275        DO jk = 1, kflev
276          jkl = kflev + 1 - jk
277          jklp1 = jkl + 1
278          DO jl = 1, kdlon
279            zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
280            prj(jl, jaj, jkl) = zre11
281            prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
282          END DO
283        END DO
284    
285      ELSE
286    
287        DO jaj = 1, 2
288          DO jl = 1, kdlon
289            prj(jl, jaj, kflev+1) = 1.
290            prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
291          END DO
292    
293          DO jk = 1, kflev
294            jkl = kflev + 1 - jk
295            jklp1 = jkl + 1
296            DO jl = 1, kdlon
297              zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
298              prj(jl, jaj, jkl) = zre11
299              prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
300            END DO
301          END DO
302        END DO
303    
304      END IF
305    
306      ! ------------------------------------------------------------------
307    
308      RETURN
309    END SUBROUTINE swclr
Legend:
Removed from v.24  
changed lines
  Added in v.157
  ViewVC Help
Powered by ViewVC 1.1.21