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