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

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

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

trunk/libf/phylmd/Radlwsw/sw2s.f revision 24 by guez, Wed Mar 3 13:23:49 2010 UTC trunk/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        real*8 flag_aer      ! ------------------------------------------------------------------
52        real*8 tauae(kdlon,kflev,2)      ! * ARGUMENTS:
53        real*8 pizae(kdlon,kflev,2)  
54        real*8 cgae(kdlon,kflev,2)      INTEGER knu
55        REAL*8 PAER(KDLON,KFLEV,5)      ! -OB
56        REAL*8 PAKI(KDLON,2)      DOUBLE PRECISION flag_aer
57        REAL*8 PALBD(KDLON,2)      DOUBLE PRECISION tauae(kdlon, kflev, 2)
58        REAL*8 PALBP(KDLON,2)      DOUBLE PRECISION pizae(kdlon, kflev, 2)
59        REAL*8 PCG(KDLON,2,KFLEV)      DOUBLE PRECISION cgae(kdlon, kflev, 2)
60        REAL*8 PCLD(KDLON,KFLEV)      DOUBLE PRECISION paki(kdlon, 2)
61        REAL*8 PCLDSW(KDLON,KFLEV)      DOUBLE PRECISION palbd(kdlon, 2)
62        REAL*8 PCLEAR(KDLON)      DOUBLE PRECISION palbp(kdlon, 2)
63        REAL*8 PDSIG(KDLON,KFLEV)      DOUBLE PRECISION pcg(kdlon, 2, kflev)
64        REAL*8 POMEGA(KDLON,2,KFLEV)      DOUBLE PRECISION pcld(kdlon, kflev)
65        REAL*8 POZ(KDLON,KFLEV)      DOUBLE PRECISION pclear(kdlon)
66        REAL*8 PQS(KDLON,KFLEV)      DOUBLE PRECISION pdsig(kdlon, kflev)
67        REAL*8 PRMU(KDLON)      DOUBLE PRECISION pomega(kdlon, 2, kflev)
68        REAL*8 PSEC(KDLON)      DOUBLE PRECISION poz(kdlon, kflev)
69        REAL*8 PTAU(KDLON,2,KFLEV)      DOUBLE PRECISION pqs(kdlon, kflev)
70        REAL*8 PUD(KDLON,5,KFLEV+1)      DOUBLE PRECISION prmu(kdlon)
71        REAL*8 PWV(KDLON,KFLEV)      DOUBLE PRECISION psec(kdlon)
72  C      DOUBLE PRECISION ptau(kdlon, 2, kflev)
73        REAL*8 PFDOWN(KDLON,KFLEV+1)      DOUBLE PRECISION pud(kdlon, 5, kflev+1)
74        REAL*8 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        REAL*8 ZCGAZ(KDLON,KFLEV)      ! * LOCAL VARIABLES:
80        REAL*8 ZFD(KDLON,KFLEV+1)  
81        REAL*8 ZFU(KDLON,KFLEV+1)      INTEGER iind2(2), iind3(3)
82        REAL*8 ZG(KDLON)      DOUBLE PRECISION zcgaz(kdlon, kflev)
83        REAL*8 ZGG(KDLON)      DOUBLE PRECISION zfd(kdlon, kflev+1)
84        REAL*8 ZPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION zfu(kdlon, kflev+1)
85        REAL*8 ZRAYL(KDLON)      DOUBLE PRECISION zg(kdlon)
86        REAL*8 ZRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION zgg(kdlon)
87        REAL*8 ZRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION zpizaz(kdlon, kflev)
88        REAL*8 ZREF(KDLON)      DOUBLE PRECISION zrayl(kdlon)
89        REAL*8 ZREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION zray1(kdlon, kflev+1)
90        REAL*8 ZRE1(KDLON)      DOUBLE PRECISION zray2(kdlon, kflev+1)
91        REAL*8 ZRE2(KDLON)      DOUBLE PRECISION zref(kdlon)
92        REAL*8 ZRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
93        REAL*8 ZRJ0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zre1(kdlon)
94        REAL*8 ZRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION zre2(kdlon)
95        REAL*8 ZRK0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
96        REAL*8 ZRL(KDLON,8)      DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
97        REAL*8 ZRMUE(KDLON,KFLEV+1)      DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
98        REAL*8 ZRMU0(KDLON,KFLEV+1)      DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
99        REAL*8 ZRMUZ(KDLON)      DOUBLE PRECISION zrl(kdlon, 8)
100        REAL*8 ZRNEB(KDLON)      DOUBLE PRECISION zrmue(kdlon, kflev+1)
101        REAL*8 ZRUEF(KDLON,8)      DOUBLE PRECISION zrmu0(kdlon, kflev+1)
102        REAL*8 ZR1(KDLON)      DOUBLE PRECISION zrmuz(kdlon)
103        REAL*8 ZR2(KDLON,2)      DOUBLE PRECISION zrneb(kdlon)
104        REAL*8 ZR3(KDLON,3)      DOUBLE PRECISION zr1(kdlon)
105        REAL*8 ZR4(KDLON)      DOUBLE PRECISION zr2(kdlon, 2)
106        REAL*8 ZR21(KDLON)      DOUBLE PRECISION zr3(kdlon, 3)
107        REAL*8 ZR22(KDLON)      DOUBLE PRECISION zr4(kdlon)
108        REAL*8 ZS(KDLON)      DOUBLE PRECISION zr21(kdlon)
109        REAL*8 ZTAUAZ(KDLON,KFLEV)      DOUBLE PRECISION zr22(kdlon)
110        REAL*8 ZTO1(KDLON)      DOUBLE PRECISION zs(kdlon)
111        REAL*8 ZTR(KDLON,2,KFLEV+1)      DOUBLE PRECISION ztauaz(kdlon, kflev)
112        REAL*8 ZTRA1(KDLON,KFLEV+1)      DOUBLE PRECISION zto1(kdlon)
113        REAL*8 ZTRA2(KDLON,KFLEV+1)      DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
114        REAL*8 ZTR1(KDLON)      DOUBLE PRECISION ztra1(kdlon, kflev+1)
115        REAL*8 ZTR2(KDLON)      DOUBLE PRECISION ztra2(kdlon, kflev+1)
116        REAL*8 ZW(KDLON)        DOUBLE PRECISION ztr1(kdlon)
117        REAL*8 ZW1(KDLON)      DOUBLE PRECISION ztr2(kdlon)
118        REAL*8 ZW2(KDLON,2)      DOUBLE PRECISION zw(kdlon)
119        REAL*8 ZW3(KDLON,3)      DOUBLE PRECISION zw1(kdlon)
120        REAL*8 ZW4(KDLON)      DOUBLE PRECISION zw2(kdlon, 2)
121        REAL*8 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        REAL*8 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        REAL*8 RSUN(2)      ! * Prescribed Data:
130        SAVE RSUN  
131        REAL*8 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.24  
changed lines
  Added in v.207
  ViewVC Help
Powered by ViewVC 1.1.21