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

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

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

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