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

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

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 219 by guez, Thu Mar 30 15:59:45 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, paki, palbd, palbp, pcg, pcld, pclear, pdsig, pomega, &
8        use dimphy         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)      DOUBLE PRECISION paki(kdlon, 2)
56        DOUBLE PRECISION PAKI(KDLON,2)      DOUBLE PRECISION palbd(kdlon, 2)
57        DOUBLE PRECISION PALBD(KDLON,2)      DOUBLE PRECISION palbp(kdlon, 2)
58        DOUBLE PRECISION PALBP(KDLON,2)      DOUBLE PRECISION pcg(kdlon, 2, kflev)
59        DOUBLE PRECISION PCG(KDLON,2,KFLEV)      DOUBLE PRECISION pcld(kdlon, kflev)
60        DOUBLE PRECISION PCLD(KDLON,KFLEV)      DOUBLE PRECISION pclear(kdlon)
61        DOUBLE PRECISION PCLDSW(KDLON,KFLEV)      DOUBLE PRECISION pdsig(kdlon, kflev)
62        DOUBLE PRECISION PCLEAR(KDLON)      DOUBLE PRECISION pomega(kdlon, 2, kflev)
63        DOUBLE PRECISION PDSIG(KDLON,KFLEV)      DOUBLE PRECISION poz(kdlon, kflev)
64        DOUBLE PRECISION POMEGA(KDLON,2,KFLEV)      DOUBLE PRECISION pqs(kdlon, kflev)
65        DOUBLE PRECISION POZ(KDLON,KFLEV)      DOUBLE PRECISION prmu(kdlon)
66        DOUBLE PRECISION PQS(KDLON,KFLEV)      DOUBLE PRECISION psec(kdlon)
67        DOUBLE PRECISION PRMU(KDLON)      DOUBLE PRECISION ptau(kdlon, 2, kflev)
68        DOUBLE PRECISION PSEC(KDLON)      DOUBLE PRECISION pud(kdlon, 5, kflev+1)
69        DOUBLE PRECISION PTAU(KDLON,2,KFLEV)      DOUBLE PRECISION pwv(kdlon, kflev)
70        DOUBLE PRECISION PUD(KDLON,5,KFLEV+1)  
71        DOUBLE PRECISION PWV(KDLON,KFLEV)      DOUBLE PRECISION pfdown(kdlon, kflev+1)
72  C      DOUBLE PRECISION pfup(kdlon, kflev+1)
73        DOUBLE PRECISION PFDOWN(KDLON,KFLEV+1)  
74        DOUBLE PRECISION PFUP(KDLON,KFLEV+1)      ! * LOCAL VARIABLES:
75  C  
76  C* LOCAL VARIABLES:      INTEGER iind2(2), iind3(3)
77  C      DOUBLE PRECISION zcgaz(kdlon, kflev)
78        INTEGER IIND2(2), IIND3(3)      DOUBLE PRECISION zfd(kdlon, kflev+1)
79        DOUBLE PRECISION ZCGAZ(KDLON,KFLEV)      DOUBLE PRECISION zfu(kdlon, kflev+1)
80        DOUBLE PRECISION ZFD(KDLON,KFLEV+1)      DOUBLE PRECISION zg(kdlon)
81        DOUBLE PRECISION ZFU(KDLON,KFLEV+1)      DOUBLE PRECISION zgg(kdlon)
82        DOUBLE PRECISION ZG(KDLON)      DOUBLE PRECISION zpizaz(kdlon, kflev)
83        DOUBLE PRECISION ZGG(KDLON)      DOUBLE PRECISION zrayl(kdlon)
84        DOUBLE PRECISION ZPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION zray1(kdlon, kflev+1)
85        DOUBLE PRECISION ZRAYL(KDLON)      DOUBLE PRECISION zray2(kdlon, kflev+1)
86        DOUBLE PRECISION ZRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION zref(kdlon)
87        DOUBLE PRECISION ZRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
88        DOUBLE PRECISION ZREF(KDLON)      DOUBLE PRECISION zre1(kdlon)
89        DOUBLE PRECISION ZREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION zre2(kdlon)
90        DOUBLE PRECISION ZRE1(KDLON)      DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
91        DOUBLE PRECISION ZRE2(KDLON)      DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
92        DOUBLE PRECISION ZRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
93        DOUBLE PRECISION ZRJ0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
94        DOUBLE PRECISION ZRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrl(kdlon, 8)
95        DOUBLE PRECISION ZRK0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrmue(kdlon, kflev+1)
96        DOUBLE PRECISION ZRL(KDLON,8)      DOUBLE PRECISION zrmu0(kdlon, kflev+1)
97        DOUBLE PRECISION ZRMUE(KDLON,KFLEV+1)      DOUBLE PRECISION zrmuz(kdlon)
98        DOUBLE PRECISION ZRMU0(KDLON,KFLEV+1)      DOUBLE PRECISION zrneb(kdlon)
99        DOUBLE PRECISION ZRMUZ(KDLON)      DOUBLE PRECISION zr1(kdlon)
100        DOUBLE PRECISION ZRNEB(KDLON)      DOUBLE PRECISION zr2(kdlon, 2)
101        DOUBLE PRECISION ZRUEF(KDLON,8)      DOUBLE PRECISION zr3(kdlon, 3)
102        DOUBLE PRECISION ZR1(KDLON)      DOUBLE PRECISION zr4(kdlon)
103        DOUBLE PRECISION ZR2(KDLON,2)      DOUBLE PRECISION zr21(kdlon)
104        DOUBLE PRECISION ZR3(KDLON,3)      DOUBLE PRECISION zr22(kdlon)
105        DOUBLE PRECISION ZR4(KDLON)      DOUBLE PRECISION zs(kdlon)
106        DOUBLE PRECISION ZR21(KDLON)      DOUBLE PRECISION ztauaz(kdlon, kflev)
107        DOUBLE PRECISION ZR22(KDLON)      DOUBLE PRECISION zto1(kdlon)
108        DOUBLE PRECISION ZS(KDLON)      DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
109        DOUBLE PRECISION ZTAUAZ(KDLON,KFLEV)      DOUBLE PRECISION ztra1(kdlon, kflev+1)
110        DOUBLE PRECISION ZTO1(KDLON)      DOUBLE PRECISION ztra2(kdlon, kflev+1)
111        DOUBLE PRECISION ZTR(KDLON,2,KFLEV+1)      DOUBLE PRECISION ztr1(kdlon)
112        DOUBLE PRECISION ZTRA1(KDLON,KFLEV+1)      DOUBLE PRECISION ztr2(kdlon)
113        DOUBLE PRECISION ZTRA2(KDLON,KFLEV+1)      DOUBLE PRECISION zw(kdlon)
114        DOUBLE PRECISION ZTR1(KDLON)      DOUBLE PRECISION zw1(kdlon)
115        DOUBLE PRECISION ZTR2(KDLON)      DOUBLE PRECISION zw2(kdlon, 2)
116        DOUBLE PRECISION ZW(KDLON)        DOUBLE PRECISION zw3(kdlon, 3)
117        DOUBLE PRECISION ZW1(KDLON)      DOUBLE PRECISION zw4(kdlon)
118        DOUBLE PRECISION ZW2(KDLON,2)      DOUBLE PRECISION zw5(kdlon)
119        DOUBLE PRECISION ZW3(KDLON,3)  
120        DOUBLE PRECISION ZW4(KDLON)      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
121        DOUBLE PRECISION 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        DOUBLE PRECISION 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        DOUBLE PRECISION RSUN(2)      SAVE rray
130        SAVE RSUN      DATA rsun(1)/0.441676d0/
131        DOUBLE PRECISION RRAY(2,6)      DATA rsun(2)/0.558324d0/
132        SAVE RRAY      DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
133        DATA RSUN(1) / 0.441676 /           .522744d+01, -.469173d+01, .161645d+01/
134        DATA RSUN(2) / 0.558324 /      DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
135        DATA (RRAY(1,K),K=1,6) /           .248261d+00, -.302031d+00, .129662d+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, palbp, pdsig, zrayl, psec, zpizaz, zray1, zray2, zrefz, &
166  C                ---------------------------------           zrj0, zrk0, zrmu0, ztauaz, ztra1, ztra2)
167  C  
168   200  CONTINUE  
169  C      ! *         2.2   CLOUDY FRACTION OF THE COLUMN
170  C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN      ! -----------------------------
171  C                --------------------------------  
172  C    
173   210  CONTINUE      zcgaz = 0d0
174  C      CALL swr(knu, palbd, pcg, pcld, pomega, 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                  zrl(jl, jkkp4) = zr2(jl, 2)
346  C                 ---------------------------------------------               END DO
347  C  
348   420  CONTINUE               jkki = jkki + 1
349  C            END DO
350        DO 437 JK = 1 , KFLEV+1         END DO
351        JKKI = 1  
352        DO 425 JAJ = 1 , 2         ! *         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
353        IIND2(1)=JAJ         ! ------------------------------------------------------
354        IIND2(2)=JAJ  
355        DO 424 JN = 1 , 2  
356        JN2J = JN + 2 * JAJ         DO jl = 1, kdlon
357        JKKP4 = JKKI + 4            pfdown(jl, jk) = zrj(jl, 1, jk)*zrl(jl, 1)*zrl(jl, 3) + &
358  C                 zrj(jl, 2, jk)*zrl(jl, 2)*zrl(jl, 4)
359  C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS            pfup(jl, jk) = zrk(jl, 1, jk)*zrl(jl, 5)*zrl(jl, 7) + &
360  C                 --------------------------                 zrk(jl, 2, jk)*zrl(jl, 6)*zrl(jl, 8)
361  C         END DO
362   4210 CONTINUE      END DO
363  C  
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))      ! *         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
368       S                               / PAKI(JL,JAJ)      ! ----------------------------------------
369   4211 CONTINUE  
370  C  
371  C*         4.2.2  TRANSMISSION FUNCTION  
372  C                 ---------------------      ! *         5.1   DOWNWARD FLUXES
373  C      ! ---------------
374   4220 CONTINUE  
375  C  
376        CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)      jaj = 2
377  C      iind3(1) = 1
378        DO 4221 JL = 1, KDLON      iind3(2) = 2
379        ZRL(JL,JKKI) = ZR2(JL,1)      iind3(3) = 3
380        ZRUEF(JL,JKKI) = ZW2(JL,1)  
381        ZRL(JL,JKKP4) = ZR2(JL,2)      DO jl = 1, kdlon
382        ZRUEF(JL,JKKP4) = ZW2(JL,2)         zw3(jl, 1) = 0.
383   4221 CONTINUE         zw3(jl, 2) = 0.
384  C         zw3(jl, 3) = 0.
385        JKKI=JKKI+1         zw4(jl) = 0.
386   424  CONTINUE         zw5(jl) = 0.
387   425  CONTINUE         zr4(jl) = 1.
388  C         zfd(jl, kflev+1) = zrj0(jl, jaj, kflev+1)
389  C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION      END DO
390  C                 ------------------------------------------------------      DO jk = 1, kflev
391  C         ikl = kflev + 1 - jk
392   430  CONTINUE         DO jl = 1, kdlon
393  C            zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
394        DO 431 JL = 1, KDLON            zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikl)/zrmu0(jl, ikl)
395        PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)            zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikl)/zrmu0(jl, ikl)
396       S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)            zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmu0(jl, ikl)
397        PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)            zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmu0(jl, ikl)
398       S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)         END DO
399   431  CONTINUE  
400   437  CONTINUE         CALL swtt1(knu, 3, iind3, zw3, zr3)
401  C  
402  C         DO jl = 1, kdlon
403  C     ------------------------------------------------------------------            ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
404  C            zfd(jl, ikl) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
405  C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES                 zrj0(jl, jaj, ikl)
406  C                ----------------------------------------         END DO
407  C      END DO
408   500  CONTINUE  
409  C  
410  C      ! *         5.2   UPWARD FLUXES
411  C*         5.1   DOWNWARD FLUXES      ! -------------
412  C                ---------------  
413  C  
414   510  CONTINUE      DO jl = 1, kdlon
415  C         zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu)
416        JAJ = 2      END DO
417        IIND3(1)=1  
418        IIND3(2)=2      DO jk = 2, kflev + 1
419        IIND3(3)=3         ikm1 = jk - 1
420  C               DO jl = 1, kdlon
421        DO 511 JL = 1, KDLON            zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikm1)*1.66
422        ZW3(JL,1)=0.            zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikm1)*1.66
423        ZW3(JL,2)=0.            zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikm1)*1.66
424        ZW3(JL,3)=0.            zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
425        ZW4(JL)  =0.            zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
426        ZW5(JL)  =0.         END DO
427        ZR4(JL)  =1.  
428        ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)         CALL swtt1(knu, 3, iind3, zw3, zr3)
429   511  CONTINUE  
430        DO 514 JK = 1 , KFLEV         DO jl = 1, kdlon
431        IKL = KFLEV+1-JK            ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
432        DO 512 JL = 1, KDLON            zfu(jl, jk) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
433        ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)                 zrk0(jl, jaj, jk)
434        ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)         END DO
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)  
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)      ! *         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
441  C      ! --------------------------------------------------
442        DO 513 JL = 1, KDLON  
443  C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))      iabs = 3
444        ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)  
445       S            * ZRJ0(JL,JAJ,IKL)      ! *         6.1    DOWNWARD FLUXES
446   513  CONTINUE      ! ---------------
447   514  CONTINUE  
448  C      DO jl = 1, kdlon
449  C         zw1(jl) = 0.
450  C*         5.2   UPWARD FLUXES         zw4(jl) = 0.
451  C                -------------         zw5(jl) = 0.
452  C         zr1(jl) = 0.
453   520  CONTINUE         pfdown(jl, kflev+1) = ((1.-pclear(jl))*pfdown(jl,kflev+1)+pclear(jl)*zfd( &
454  C              jl,kflev+1))*rsun(knu)
455        DO 525 JL = 1, KDLON      END DO
456        ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)  
457   525  CONTINUE      DO jk = 1, kflev
458  C         ikl = kflev + 1 - jk
459        DO 528 JK = 2 , KFLEV+1         DO jl = 1, kdlon
460        IKM1=JK-1            zw1(jl) = zw1(jl) + poz(jl, ikl)/zrmue(jl, ikl)
461        DO 526 JL = 1, KDLON            zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmue(jl, ikl)
462        ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66            zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmue(jl, ikl)
463        ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66            ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
464        ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66         END DO
465        ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66  
466        ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66         CALL swtt(knu, iabs, zw1, zr1)
467   526  CONTINUE  
468  C         DO jl = 1, kdlon
469        CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)            pfdown(jl, ikl) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfdown(jl,ikl)+ &
470  C                 pclear(jl)*zfd(jl,ikl))*rsun(knu)
471        DO 527 JL = 1, KDLON         END DO
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)  
474       S           * ZRK0(JL,JAJ,JK)  
475   527  CONTINUE      ! *         6.2    UPWARD FLUXES
476   528  CONTINUE      ! -------------
477  C  
478  C      DO jl = 1, kdlon
479  C     ------------------------------------------------------------------         pfup(jl, 1) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,1)+pclear(jl)*zfu( &
480  C              jl,1))*rsun(knu)
481  C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION      END DO
482  C                 --------------------------------------------------  
483  C      DO jk = 2, kflev + 1
484   600  CONTINUE         ikm1 = jk - 1
485        IABS=3         DO jl = 1, kdlon
486  C            zw1(jl) = zw1(jl) + poz(jl, ikm1)*1.66
487  C*         6.1    DOWNWARD FLUXES            zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
488  C                 ---------------            zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
489  C            ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
490   610  CONTINUE         END DO
491        DO 611 JL = 1, KDLON  
492        ZW1(JL)=0.         CALL swtt(knu, iabs, zw1, zr1)
493        ZW4(JL)=0.  
494        ZW5(JL)=0.         DO jl = 1, kdlon
495        ZR1(JL)=0.            pfup(jl, jk) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,jk)+pclear(jl)* &
496        PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)                 zfu(jl,jk))*rsun(knu)
497       S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)         END DO
498   611  CONTINUE      END DO
499  C  
500        DO 614 JK = 1 , KFLEV    END SUBROUTINE sw2s
501        IKL=KFLEV+1-JK  
502        DO 612 JL = 1, KDLON  end module sw2s_m
       ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)  
       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.219
  ViewVC Help
Powered by ViewVC 1.1.21