/[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 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        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, 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        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    ! ------------------------------------------------------------------
74  C  
75  C* Prescribed Data for Aerosols:    ! *         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
76  C    ! --------------------------------------------
77        DOUBLE PRECISION 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.76  
changed lines
  Added in v.157
  ViewVC Help
Powered by ViewVC 1.1.21