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