/[lmdze]/trunk/phylmd/Radlwsw/sw2s.f
ViewVC logotype

Diff of /trunk/phylmd/Radlwsw/sw2s.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/phylmd/Radlwsw/sw2s.f revision 24 by guez, Wed Mar 3 13:23:49 2010 UTC trunk/phylmd/Radlwsw/sw2s.f90 revision 81 by guez, Wed Mar 5 14:38:41 2014 UTC
# Line 1  Line 1 
1        SUBROUTINE SW2S ( KNU  SUBROUTINE sw2s(knu, paer, flag_aer, tauae, pizae, cgae, paki, palbd, palbp, &
2       S  ,  PAER  , flag_aer, tauae, pizae, cgae      pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, &
3       S  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW      pwv, pqs, pfdown, pfup)
4       S  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU    USE dimens_m
5       S  ,  PUD   ,PWV , PQS    USE dimphy
6       S  ,  PFDOWN,PFUP                                            )    USE raddim
7        use dimens_m    USE radepsi
8        use dimphy    IMPLICIT NONE
9        use raddim  
10        use radepsi    ! ------------------------------------------------------------------
11        IMPLICIT none    ! PURPOSE.
12  C    ! --------
13  C     ------------------------------------------------------------------  
14  C     PURPOSE.    ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
15  C     --------    ! SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
16  C  
17  C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE    ! METHOD.
18  C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).    ! -------
19  C  
20  C     METHOD.    ! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
21  C     -------    ! CONTINUUM SCATTERING
22  C    ! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
23  C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO    ! A GREY MOLECULAR ABSORPTION
24  C     CONTINUUM SCATTERING    ! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
25  C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR    ! OF ABSORBERS
26  C     A GREY MOLECULAR ABSORPTION    ! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
27  C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS    ! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
28  C     OF ABSORBERS  
29  C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS    ! REFERENCE.
30  C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION    ! ----------
31  C  
32  C     REFERENCE.    ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
33  C     ----------    ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
34  C  
35  C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT    ! AUTHOR.
36  C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)    ! -------
37  C    ! JEAN-JACQUES MORCRETTE  *ECMWF*
38  C     AUTHOR.  
39  C     -------    ! MODIFICATIONS.
40  C        JEAN-JACQUES MORCRETTE  *ECMWF*    ! --------------
41  C    ! ORIGINAL : 89-07-14
42  C     MODIFICATIONS.    ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
43  C     --------------    ! ------------------------------------------------------------------
44  C        ORIGINAL : 89-07-14    ! * ARGUMENTS:
45  C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO  
46  C     ------------------------------------------------------------------    INTEGER knu
47  C* ARGUMENTS:    ! -OB
48  C    DOUBLE PRECISION flag_aer
49        INTEGER KNU    DOUBLE PRECISION tauae(kdlon, kflev, 2)
50  c-OB    DOUBLE PRECISION pizae(kdlon, kflev, 2)
51        real*8 flag_aer    DOUBLE PRECISION cgae(kdlon, kflev, 2)
52        real*8 tauae(kdlon,kflev,2)    DOUBLE PRECISION paer(kdlon, kflev, 5)
53        real*8 pizae(kdlon,kflev,2)    DOUBLE PRECISION paki(kdlon, 2)
54        real*8 cgae(kdlon,kflev,2)    DOUBLE PRECISION palbd(kdlon, 2)
55        REAL*8 PAER(KDLON,KFLEV,5)    DOUBLE PRECISION palbp(kdlon, 2)
56        REAL*8 PAKI(KDLON,2)    DOUBLE PRECISION pcg(kdlon, 2, kflev)
57        REAL*8 PALBD(KDLON,2)    DOUBLE PRECISION pcld(kdlon, kflev)
58        REAL*8 PALBP(KDLON,2)    DOUBLE PRECISION pcldsw(kdlon, kflev)
59        REAL*8 PCG(KDLON,2,KFLEV)    DOUBLE PRECISION pclear(kdlon)
60        REAL*8 PCLD(KDLON,KFLEV)    DOUBLE PRECISION pdsig(kdlon, kflev)
61        REAL*8 PCLDSW(KDLON,KFLEV)    DOUBLE PRECISION pomega(kdlon, 2, kflev)
62        REAL*8 PCLEAR(KDLON)    DOUBLE PRECISION poz(kdlon, kflev)
63        REAL*8 PDSIG(KDLON,KFLEV)    DOUBLE PRECISION pqs(kdlon, kflev)
64        REAL*8 POMEGA(KDLON,2,KFLEV)    DOUBLE PRECISION prmu(kdlon)
65        REAL*8 POZ(KDLON,KFLEV)    DOUBLE PRECISION psec(kdlon)
66        REAL*8 PQS(KDLON,KFLEV)    DOUBLE PRECISION ptau(kdlon, 2, kflev)
67        REAL*8 PRMU(KDLON)    DOUBLE PRECISION pud(kdlon, 5, kflev+1)
68        REAL*8 PSEC(KDLON)    DOUBLE PRECISION pwv(kdlon, kflev)
69        REAL*8 PTAU(KDLON,2,KFLEV)  
70        REAL*8 PUD(KDLON,5,KFLEV+1)    DOUBLE PRECISION pfdown(kdlon, kflev+1)
71        REAL*8 PWV(KDLON,KFLEV)    DOUBLE PRECISION pfup(kdlon, kflev+1)
72  C  
73        REAL*8 PFDOWN(KDLON,KFLEV+1)    ! * LOCAL VARIABLES:
74        REAL*8 PFUP(KDLON,KFLEV+1)  
75  C    INTEGER iind2(2), iind3(3)
76  C* LOCAL VARIABLES:    DOUBLE PRECISION zcgaz(kdlon, kflev)
77  C    DOUBLE PRECISION zfd(kdlon, kflev+1)
78        INTEGER IIND2(2), IIND3(3)    DOUBLE PRECISION zfu(kdlon, kflev+1)
79        REAL*8 ZCGAZ(KDLON,KFLEV)    DOUBLE PRECISION zg(kdlon)
80        REAL*8 ZFD(KDLON,KFLEV+1)    DOUBLE PRECISION zgg(kdlon)
81        REAL*8 ZFU(KDLON,KFLEV+1)    DOUBLE PRECISION zpizaz(kdlon, kflev)
82        REAL*8 ZG(KDLON)    DOUBLE PRECISION zrayl(kdlon)
83        REAL*8 ZGG(KDLON)    DOUBLE PRECISION zray1(kdlon, kflev+1)
84        REAL*8 ZPIZAZ(KDLON,KFLEV)    DOUBLE PRECISION zray2(kdlon, kflev+1)
85        REAL*8 ZRAYL(KDLON)    DOUBLE PRECISION zref(kdlon)
86        REAL*8 ZRAY1(KDLON,KFLEV+1)    DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
87        REAL*8 ZRAY2(KDLON,KFLEV+1)    DOUBLE PRECISION zre1(kdlon)
88        REAL*8 ZREF(KDLON)    DOUBLE PRECISION zre2(kdlon)
89        REAL*8 ZREFZ(KDLON,2,KFLEV+1)    DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
90        REAL*8 ZRE1(KDLON)    DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
91        REAL*8 ZRE2(KDLON)    DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
92        REAL*8 ZRJ(KDLON,6,KFLEV+1)    DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
93        REAL*8 ZRJ0(KDLON,6,KFLEV+1)    DOUBLE PRECISION zrl(kdlon, 8)
94        REAL*8 ZRK(KDLON,6,KFLEV+1)    DOUBLE PRECISION zrmue(kdlon, kflev+1)
95        REAL*8 ZRK0(KDLON,6,KFLEV+1)    DOUBLE PRECISION zrmu0(kdlon, kflev+1)
96        REAL*8 ZRL(KDLON,8)    DOUBLE PRECISION zrmuz(kdlon)
97        REAL*8 ZRMUE(KDLON,KFLEV+1)    DOUBLE PRECISION zrneb(kdlon)
98        REAL*8 ZRMU0(KDLON,KFLEV+1)    DOUBLE PRECISION zruef(kdlon, 8)
99        REAL*8 ZRMUZ(KDLON)    DOUBLE PRECISION zr1(kdlon)
100        REAL*8 ZRNEB(KDLON)    DOUBLE PRECISION zr2(kdlon, 2)
101        REAL*8 ZRUEF(KDLON,8)    DOUBLE PRECISION zr3(kdlon, 3)
102        REAL*8 ZR1(KDLON)    DOUBLE PRECISION zr4(kdlon)
103        REAL*8 ZR2(KDLON,2)    DOUBLE PRECISION zr21(kdlon)
104        REAL*8 ZR3(KDLON,3)    DOUBLE PRECISION zr22(kdlon)
105        REAL*8 ZR4(KDLON)    DOUBLE PRECISION zs(kdlon)
106        REAL*8 ZR21(KDLON)    DOUBLE PRECISION ztauaz(kdlon, kflev)
107        REAL*8 ZR22(KDLON)    DOUBLE PRECISION zto1(kdlon)
108        REAL*8 ZS(KDLON)    DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
109        REAL*8 ZTAUAZ(KDLON,KFLEV)    DOUBLE PRECISION ztra1(kdlon, kflev+1)
110        REAL*8 ZTO1(KDLON)    DOUBLE PRECISION ztra2(kdlon, kflev+1)
111        REAL*8 ZTR(KDLON,2,KFLEV+1)    DOUBLE PRECISION ztr1(kdlon)
112        REAL*8 ZTRA1(KDLON,KFLEV+1)    DOUBLE PRECISION ztr2(kdlon)
113        REAL*8 ZTRA2(KDLON,KFLEV+1)    DOUBLE PRECISION zw(kdlon)
114        REAL*8 ZTR1(KDLON)    DOUBLE PRECISION zw1(kdlon)
115        REAL*8 ZTR2(KDLON)    DOUBLE PRECISION zw2(kdlon, 2)
116        REAL*8 ZW(KDLON)      DOUBLE PRECISION zw3(kdlon, 3)
117        REAL*8 ZW1(KDLON)    DOUBLE PRECISION zw4(kdlon)
118        REAL*8 ZW2(KDLON,2)    DOUBLE PRECISION zw5(kdlon)
119        REAL*8 ZW3(KDLON,3)  
120        REAL*8 ZW4(KDLON)    INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
121        REAL*8 ZW5(KDLON)    INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
122  C    DOUBLE PRECISION zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11
123        INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1  
124        INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs    ! * Prescribed Data:
125        REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11  
126  C    DOUBLE PRECISION rsun(2)
127  C* Prescribed Data:    SAVE rsun
128  C    DOUBLE PRECISION rray(2, 6)
129        REAL*8 RSUN(2)    SAVE rray
130        SAVE RSUN    DATA rsun(1)/0.441676/
131        REAL*8 RRAY(2,6)    DATA rsun(2)/0.558324/
132        SAVE RRAY    DATA (rray(1,k), k=1, 6)/.428937E-01, .890743E+00, -.288555E+01, &
133        DATA RSUN(1) / 0.441676 /      .522744E+01, -.469173E+01, .161645E+01/
134        DATA RSUN(2) / 0.558324 /    DATA (rray(2,k), k=1, 6)/.697200E-02, .173297E-01, -.850903E-01, &
135        DATA (RRAY(1,K),K=1,6) /      .248261E+00, -.302031E+00, .129662E+00/
136       S .428937E-01, .890743E+00,-.288555E+01,  
137       S .522744E+01,-.469173E+01, .161645E+01/    ! ------------------------------------------------------------------
138        DATA (RRAY(2,K),K=1,6) /  
139       S .697200E-02, .173297E-01,-.850903E-01,    ! *         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
140       S .248261E+00,-.302031E+00, .129662E+00/    ! -------------------------------------------
141  C  
142  C     ------------------------------------------------------------------  
143  C  
144  C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)    ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
145  C                 -------------------------------------------    ! -----------------------------------------
146  C  
147   100  CONTINUE  
148  C    DO jl = 1, kdlon
149  C      zrmum1 = 1. - prmu(jl)
150  C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING      zrayl(jl) = rray(knu, 1) + zrmum1*(rray(knu,2)+zrmum1*(rray(knu, &
151  C                 -----------------------------------------        3)+zrmum1*(rray(knu,4)+zrmum1*(rray(knu,5)+zrmum1*rray(knu,6)))))
152  C    END DO
153   110  CONTINUE  
154  C  
155        DO 111 JL = 1, KDLON    ! ------------------------------------------------------------------
156        ZRMUM1 = 1. - PRMU(JL)  
157        ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1    ! *         2.    CONTINUUM SCATTERING CALCULATIONS
158       S          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1    ! ---------------------------------
159       S          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))  
160   111  CONTINUE  
161  C    ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
162  C    ! --------------------------------
163  C     ------------------------------------------------------------------  
164  C  
165  C*         2.    CONTINUUM SCATTERING CALCULATIONS    CALL swclr(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &
166  C                ---------------------------------      psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &
167  C      ztra1, ztra2)
168   200  CONTINUE  
169  C  
170  C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN    ! *         2.2   CLOUDY FRACTION OF THE COLUMN
171  C                --------------------------------    ! -----------------------------
172  C    
173   210  CONTINUE  
174  C    CALL swr(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, zcgaz, &
175        CALL SWCLR ( KNU      zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
176       S  , PAER   , flag_aer, tauae, pizae, cgae  
177       S  , PALBP  , PDSIG , ZRAYL, PSEC  
178       S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0    ! ------------------------------------------------------------------
179       S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)  
180  C    ! *         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
181  C    ! ------------------------------------------------------
182  C*         2.2   CLOUDY FRACTION OF THE COLUMN  
183  C                -----------------------------  
184  C    jn = 2
185   220  CONTINUE  
186  C    DO jabs = 1, 2
187        CALL SWR ( KNU  
188       S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL  
189       S  , PSEC  , PTAU      ! *         3.1  SURFACE CONDITIONS
190       S  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE      ! ------------------
191       S  , ZTAUAZ, ZTRA1 , ZTRA2)  
192  C  
193  C      DO jl = 1, kdlon
194  C     ------------------------------------------------------------------        zrefz(jl, 2, 1) = palbd(jl, knu)
195  C        zrefz(jl, 1, 1) = palbd(jl, knu)
196  C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION      END DO
197  C                ------------------------------------------------------  
198  C  
199   300  CONTINUE      ! *         3.2  INTRODUCING CLOUD EFFECTS
200  C      ! -------------------------
201        JN = 2  
202  C  
203        DO 361 JABS=1,2      DO jk = 2, kflev + 1
204  C        jkm1 = jk - 1
205  C        ikl = kflev + 1 - jkm1
206  C*         3.1  SURFACE CONDITIONS        DO jl = 1, kdlon
207  C               ------------------          zrneb(jl) = pcld(jl, jkm1)
208  C          IF (jabs==1 .AND. zrneb(jl)>2.*zeelog) THEN
209   310  CONTINUE            zwh2o = max(pwv(jl,jkm1), zeelog)
210  C            zcneb = max(zeelog, min(zrneb(jl),1.-zeelog))
211        DO 311 JL = 1, KDLON            zbb = pud(jl, jabs, jkm1)*pqs(jl, jkm1)/zwh2o
212        ZREFZ(JL,2,1) = PALBD(JL,KNU)            zaa = max((pud(jl,jabs,jkm1)-zcneb*zbb)/(1.-zcneb), zeelog)
213        ZREFZ(JL,1,1) = PALBD(JL,KNU)          ELSE
214   311  CONTINUE            zaa = pud(jl, jabs, jkm1)
215  C            zbb = zaa
216  C          END IF
217  C*         3.2  INTRODUCING CLOUD EFFECTS          zrki = paki(jl, jabs)
218  C               -------------------------          zs(jl) = exp(-zrki*zaa*1.66)
219  C          zg(jl) = exp(-zrki*zaa/zrmue(jl,jk))
220   320  CONTINUE          ztr1(jl) = 0.
221  C          zre1(jl) = 0.
222        DO 324 JK = 2 , KFLEV+1          ztr2(jl) = 0.
223        JKM1 = JK - 1          zre2(jl) = 0.
224        IKL=KFLEV+1-JKM1  
225        DO 322 JL = 1, KDLON          zw(jl) = pomega(jl, knu, jkm1)
226        ZRNEB(JL) = PCLD(JL,JKM1)          zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ztauaz(jl, jkm1)/zpizaz(jl, &
227        IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN            jkm1) + zbb*zrki
228           ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)  
229           ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))          zr21(jl) = ptau(jl, knu, jkm1) + ztauaz(jl, jkm1)
230           ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O          zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
231           ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)          zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*zcgaz(jl, jkm1)
232        ELSE          zw(jl) = zr21(jl)/zto1(jl)
233           ZAA=PUD(JL,JABS,JKM1)          zref(jl) = zrefz(jl, 1, jkm1)
234           ZBB=ZAA          zrmuz(jl) = zrmue(jl, jk)
235        END IF        END DO
236        ZRKI = PAKI(JL,JABS)  
237        ZS(JL) = EXP(-ZRKI * ZAA * 1.66)        CALL swde(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
238        ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))  
239        ZTR1(JL) = 0.        DO jl = 1, kdlon
240        ZRE1(JL) = 0.  
241        ZTR2(JL) = 0.          zrefz(jl, 2, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,2,jkm1)* &
242        ZRE2(JL) = 0.            ztra1(jl,jkm1)*ztra2(jl,jkm1))*zg(jl)*zs(jl) + zrneb(jl)*zre1(jl)
243  C  
244        ZW(JL)= POMEGA(JL,KNU,JKM1)          ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + (ztra1(jl,jkm1))*zg(jl)*(1.- &
245        ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)            zrneb(jl))
246       S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)  
247       S               + ZBB * ZRKI          zrefz(jl, 1, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,1,jkm1)* &
248              ztra1(jl,jkm1)*ztra2(jl,jkm1)/(1.-zray2(jl,jkm1)*zrefz(jl,1, &
249        ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)            jkm1)))*zg(jl)*zs(jl) + zrneb(jl)*zre2(jl)
250        ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)  
251        ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)          ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ztra1(jl,jkm1)/(1.-zray2(jl, &
252       S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)            jkm1)*zrefz(jl,1,jkm1)))*zg(jl)*(1.-zrneb(jl))
253        ZW(JL) = ZR21(JL) / ZTO1(JL)  
254        ZREF(JL) = ZREFZ(JL,1,JKM1)        END DO
255        ZRMUZ(JL) = ZRMUE(JL,JK)      END DO
256   322  CONTINUE  
257  C      ! *         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
258        CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,      ! -------------------------------------------------
259       S          ZRE1, ZRE2, ZTR1, ZTR2)  
260  C  
261        DO 323 JL = 1, KDLON      DO jref = 1, 2
262  C  
263        ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)        jn = jn + 1
264       S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)  
265       S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)        DO jl = 1, kdlon
266       S               + ZRNEB(JL) * ZRE1(JL)          zrj(jl, jn, kflev+1) = 1.
267  C          zrk(jl, jn, kflev+1) = zrefz(jl, jref, kflev+1)
268        ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)        END DO
269       S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))  
270  C        DO jk = 1, kflev
271        ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)          jkl = kflev + 1 - jk
272       S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)          jklp1 = jkl + 1
273       S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)          DO jl = 1, kdlon
274       S             + ZRNEB(JL) * ZRE2(JL)            zre11 = zrj(jl, jn, jklp1)*ztr(jl, jref, jkl)
275  C            zrj(jl, jn, jkl) = zre11
276        ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)            zrk(jl, jn, jkl) = zre11*zrefz(jl, jref, jkl)
277       S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)          END DO
278       S              * ZREFZ(JL,1,JKM1)))        END DO
279       S              * ZG(JL) * (1. -ZRNEB(JL))      END DO
280  C    END DO
281   323  CONTINUE  
282   324  CONTINUE  
283  C    ! ------------------------------------------------------------------
284  C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL  
285  C               -------------------------------------------------    ! *         4.    INVERT GREY AND CONTINUUM FLUXES
286  C    ! --------------------------------
287   330  CONTINUE  
288  C  
289        DO 351 JREF=1,2  
290  C    ! *         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
291        JN = JN + 1    ! ---------------------------------------------
292  C  
293        DO 331 JL = 1, KDLON  
294        ZRJ(JL,JN,KFLEV+1) = 1.    DO jk = 1, kflev + 1
295        ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)      DO jaj = 1, 5, 2
296   331  CONTINUE        jajp = jaj + 1
297  C        DO jl = 1, kdlon
298        DO 333 JK = 1 , KFLEV          zrj(jl, jaj, jk) = zrj(jl, jaj, jk) - zrj(jl, jajp, jk)
299        JKL = KFLEV+1 - JK          zrk(jl, jaj, jk) = zrk(jl, jaj, jk) - zrk(jl, jajp, jk)
300        JKLP1 = JKL + 1          zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
301        DO 332 JL = 1, KDLON          zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
302        ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)        END DO
303        ZRJ(JL,JN,JKL) = ZRE11      END DO
304        ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)    END DO
305   332  CONTINUE  
306   333  CONTINUE    DO jk = 1, kflev + 1
307   351  CONTINUE      DO jaj = 2, 6, 2
308   361  CONTINUE        DO jl = 1, kdlon
309  C          zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
310  C          zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
311  C     ------------------------------------------------------------------        END DO
312  C      END DO
313  C*         4.    INVERT GREY AND CONTINUUM FLUXES    END DO
314  C                --------------------------------  
315  C    ! *         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
316   400  CONTINUE    ! ---------------------------------------------
317  C  
318  C  
319  C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES    DO jk = 1, kflev + 1
320  C                ---------------------------------------------      jkki = 1
321  C      DO jaj = 1, 2
322   410  CONTINUE        iind2(1) = jaj
323  C        iind2(2) = jaj
324        DO 414 JK = 1 , KFLEV+1        DO jn = 1, 2
325        DO 413 JAJ = 1 , 5 , 2          jn2j = jn + 2*jaj
326        JAJP = JAJ + 1          jkkp4 = jkki + 4
327        DO 412 JL = 1, KDLON  
328        ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)          ! *         4.2.1  EFFECTIVE ABSORBER AMOUNTS
329        ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)          ! --------------------------
330        ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )  
331        ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )  
332   412  CONTINUE          DO jl = 1, kdlon
333   413  CONTINUE            zw2(jl, 1) = log(zrj(jl,jn,jk)/zrj(jl,jn2j,jk))/paki(jl, jaj)
334   414  CONTINUE            zw2(jl, 2) = log(zrk(jl,jn,jk)/zrk(jl,jn2j,jk))/paki(jl, jaj)
335  C          END DO
336        DO 417 JK = 1 , KFLEV+1  
337        DO 416 JAJ = 2 , 6 , 2          ! *         4.2.2  TRANSMISSION FUNCTION
338        DO 415 JL = 1, KDLON          ! ---------------------
339        ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )  
340        ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )  
341   415  CONTINUE          CALL swtt1(knu, 2, iind2, zw2, zr2)
342   416  CONTINUE  
343   417  CONTINUE          DO jl = 1, kdlon
344  C            zrl(jl, jkki) = zr2(jl, 1)
345  C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE            zruef(jl, jkki) = zw2(jl, 1)
346  C                 ---------------------------------------------            zrl(jl, jkkp4) = zr2(jl, 2)
347  C            zruef(jl, jkkp4) = zw2(jl, 2)
348   420  CONTINUE          END DO
349  C  
350        DO 437 JK = 1 , KFLEV+1          jkki = jkki + 1
351        JKKI = 1        END DO
352        DO 425 JAJ = 1 , 2      END DO
353        IIND2(1)=JAJ  
354        IIND2(2)=JAJ      ! *         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
355        DO 424 JN = 1 , 2      ! ------------------------------------------------------
356        JN2J = JN + 2 * JAJ  
357        JKKP4 = JKKI + 4  
358  C      DO jl = 1, kdlon
359  C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS        pfdown(jl, jk) = zrj(jl, 1, jk)*zrl(jl, 1)*zrl(jl, 3) + &
360  C                 --------------------------          zrj(jl, 2, jk)*zrl(jl, 2)*zrl(jl, 4)
361  C        pfup(jl, jk) = zrk(jl, 1, jk)*zrl(jl, 5)*zrl(jl, 7) + &
362   4210 CONTINUE          zrk(jl, 2, jk)*zrl(jl, 6)*zrl(jl, 8)
363  C      END DO
364        DO 4211 JL = 1, KDLON    END DO
365        ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))  
366       S                               / PAKI(JL,JAJ)  
367        ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))    ! ------------------------------------------------------------------
368       S                               / PAKI(JL,JAJ)  
369   4211 CONTINUE    ! *         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
370  C    ! ----------------------------------------
371  C*         4.2.2  TRANSMISSION FUNCTION  
372  C                 ---------------------  
373  C  
374   4220 CONTINUE    ! *         5.1   DOWNWARD FLUXES
375  C    ! ---------------
376        CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)  
377  C  
378        DO 4221 JL = 1, KDLON    jaj = 2
379        ZRL(JL,JKKI) = ZR2(JL,1)    iind3(1) = 1
380        ZRUEF(JL,JKKI) = ZW2(JL,1)    iind3(2) = 2
381        ZRL(JL,JKKP4) = ZR2(JL,2)    iind3(3) = 3
382        ZRUEF(JL,JKKP4) = ZW2(JL,2)  
383   4221 CONTINUE    DO jl = 1, kdlon
384  C      zw3(jl, 1) = 0.
385        JKKI=JKKI+1      zw3(jl, 2) = 0.
386   424  CONTINUE      zw3(jl, 3) = 0.
387   425  CONTINUE      zw4(jl) = 0.
388  C      zw5(jl) = 0.
389  C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION      zr4(jl) = 1.
390  C                 ------------------------------------------------------      zfd(jl, kflev+1) = zrj0(jl, jaj, kflev+1)
391  C    END DO
392   430  CONTINUE    DO jk = 1, kflev
393  C      ikl = kflev + 1 - jk
394        DO 431 JL = 1, KDLON      DO jl = 1, kdlon
395        PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)        zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
396       S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)        zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikl)/zrmu0(jl, ikl)
397        PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)        zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikl)/zrmu0(jl, ikl)
398       S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)        zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmu0(jl, ikl)
399   431  CONTINUE        zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmu0(jl, ikl)
400   437  CONTINUE      END DO
401  C  
402  C      CALL swtt1(knu, 3, iind3, zw3, zr3)
403  C     ------------------------------------------------------------------  
404  C      DO jl = 1, kdlon
405  C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES        ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
406  C                ----------------------------------------        zfd(jl, ikl) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
407  C          zrj0(jl, jaj, ikl)
408   500  CONTINUE      END DO
409  C    END DO
410  C  
411  C*         5.1   DOWNWARD FLUXES  
412  C                ---------------    ! *         5.2   UPWARD FLUXES
413  C    ! -------------
414   510  CONTINUE  
415  C  
416        JAJ = 2    DO jl = 1, kdlon
417        IIND3(1)=1      zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu)
418        IIND3(2)=2    END DO
419        IIND3(3)=3  
420  C          DO jk = 2, kflev + 1
421        DO 511 JL = 1, KDLON      ikm1 = jk - 1
422        ZW3(JL,1)=0.      DO jl = 1, kdlon
423        ZW3(JL,2)=0.        zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikm1)*1.66
424        ZW3(JL,3)=0.        zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikm1)*1.66
425        ZW4(JL)  =0.        zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikm1)*1.66
426        ZW5(JL)  =0.        zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
427        ZR4(JL)  =1.        zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
428        ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)      END DO
429   511  CONTINUE  
430        DO 514 JK = 1 , KFLEV      CALL swtt1(knu, 3, iind3, zw3, zr3)
431        IKL = KFLEV+1-JK  
432        DO 512 JL = 1, KDLON      DO jl = 1, kdlon
433        ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)        ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
434        ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)        zfu(jl, jk) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
435        ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)          zrk0(jl, jaj, jk)
436        ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)      END DO
437        ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)    END DO
438   512  CONTINUE  
439  C  
440        CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)    ! ------------------------------------------------------------------
441  C  
442        DO 513 JL = 1, KDLON    ! *         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
443  C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))    ! --------------------------------------------------
444        ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)  
445       S            * ZRJ0(JL,JAJ,IKL)    iabs = 3
446   513  CONTINUE  
447   514  CONTINUE    ! *         6.1    DOWNWARD FLUXES
448  C    ! ---------------
449  C  
450  C*         5.2   UPWARD FLUXES    DO jl = 1, kdlon
451  C                -------------      zw1(jl) = 0.
452  C      zw4(jl) = 0.
453   520  CONTINUE      zw5(jl) = 0.
454  C      zr1(jl) = 0.
455        DO 525 JL = 1, KDLON      pfdown(jl, kflev+1) = ((1.-pclear(jl))*pfdown(jl,kflev+1)+pclear(jl)*zfd( &
456        ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)        jl,kflev+1))*rsun(knu)
457   525  CONTINUE    END DO
458  C  
459        DO 528 JK = 2 , KFLEV+1    DO jk = 1, kflev
460        IKM1=JK-1      ikl = kflev + 1 - jk
461        DO 526 JL = 1, KDLON      DO jl = 1, kdlon
462        ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66        zw1(jl) = zw1(jl) + poz(jl, ikl)/zrmue(jl, ikl)
463        ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66        zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmue(jl, ikl)
464        ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66        zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmue(jl, ikl)
465        ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66        ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
466        ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66      END DO
467   526  CONTINUE  
468  C      CALL swtt(knu, iabs, zw1, zr1)
469        CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)  
470  C      DO jl = 1, kdlon
471        DO 527 JL = 1, KDLON        pfdown(jl, ikl) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfdown(jl,ikl)+ &
472  C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))          pclear(jl)*zfd(jl,ikl))*rsun(knu)
473        ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)      END DO
474       S           * ZRK0(JL,JAJ,JK)    END DO
475   527  CONTINUE  
476   528  CONTINUE  
477  C    ! *         6.2    UPWARD FLUXES
478  C    ! -------------
479  C     ------------------------------------------------------------------  
480  C    DO jl = 1, kdlon
481  C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION      pfup(jl, 1) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,1)+pclear(jl)*zfu( &
482  C                 --------------------------------------------------        jl,1))*rsun(knu)
483  C    END DO
484   600  CONTINUE  
485        IABS=3    DO jk = 2, kflev + 1
486  C      ikm1 = jk - 1
487  C*         6.1    DOWNWARD FLUXES      DO jl = 1, kdlon
488  C                 ---------------        zw1(jl) = zw1(jl) + poz(jl, ikm1)*1.66
489  C        zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
490   610  CONTINUE        zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
491        DO 611 JL = 1, KDLON        ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
492        ZW1(JL)=0.      END DO
493        ZW4(JL)=0.  
494        ZW5(JL)=0.      CALL swtt(knu, iabs, zw1, zr1)
495        ZR1(JL)=0.  
496        PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)      DO jl = 1, kdlon
497       S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)        pfup(jl, jk) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,jk)+pclear(jl)* &
498   611  CONTINUE          zfu(jl,jk))*rsun(knu)
499  C      END DO
500        DO 614 JK = 1 , KFLEV    END DO
501        IKL=KFLEV+1-JK  
502        DO 612 JL = 1, KDLON    ! ------------------------------------------------------------------
503        ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)  
504        ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)    RETURN
505        ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)  END SUBROUTINE sw2s
 C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))  
  612  CONTINUE  
 C  
       CALL SWTT(KNU, IABS, ZW1, ZR1)  
 C  
       DO 613 JL = 1, KDLON  
       PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)  
      S                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)  
  613  CONTINUE  
  614  CONTINUE  
 C  
 C  
 C*         6.2    UPWARD FLUXES  
 C                 -------------  
 C  
  620  CONTINUE  
       DO 621 JL = 1, KDLON  
       PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)  
      S                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)  
  621  CONTINUE  
 C  
       DO 624 JK = 2 , KFLEV+1  
       IKM1=JK-1  
       DO 622 JL = 1, KDLON  
       ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66  
       ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66  
       ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66  
 C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))  
  622  CONTINUE  
 C  
       CALL SWTT(KNU, IABS, ZW1, ZR1)  
 C  
       DO 623 JL = 1, KDLON  
       PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)  
      S                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)  
  623  CONTINUE  
  624  CONTINUE  
 C  
 C     ------------------------------------------------------------------  
 C  
       RETURN  
       END  
Legend:
Removed from v.24  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21