/[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 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        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)      DOUBLE PRECISION paki(kdlon, 2)
56        REAL*8 PAKI(KDLON,2)      DOUBLE PRECISION palbd(kdlon, 2)
57        REAL*8 PALBD(KDLON,2)      DOUBLE PRECISION palbp(kdlon, 2)
58        REAL*8 PALBP(KDLON,2)      DOUBLE PRECISION pcg(kdlon, 2, kflev)
59        REAL*8 PCG(KDLON,2,KFLEV)      DOUBLE PRECISION pcld(kdlon, kflev)
60        REAL*8 PCLD(KDLON,KFLEV)      DOUBLE PRECISION pclear(kdlon)
61        REAL*8 PCLDSW(KDLON,KFLEV)      DOUBLE PRECISION pdsig(kdlon, kflev)
62        REAL*8 PCLEAR(KDLON)      DOUBLE PRECISION pomega(kdlon, 2, kflev)
63        REAL*8 PDSIG(KDLON,KFLEV)      DOUBLE PRECISION poz(kdlon, kflev)
64        REAL*8 POMEGA(KDLON,2,KFLEV)      DOUBLE PRECISION pqs(kdlon, kflev)
65        REAL*8 POZ(KDLON,KFLEV)      DOUBLE PRECISION prmu(kdlon)
66        REAL*8 PQS(KDLON,KFLEV)      DOUBLE PRECISION psec(kdlon)
67        REAL*8 PRMU(KDLON)      DOUBLE PRECISION ptau(kdlon, 2, kflev)
68        REAL*8 PSEC(KDLON)      DOUBLE PRECISION pud(kdlon, 5, kflev+1)
69        REAL*8 PTAU(KDLON,2,KFLEV)      DOUBLE PRECISION pwv(kdlon, kflev)
70        REAL*8 PUD(KDLON,5,KFLEV+1)  
71        REAL*8 PWV(KDLON,KFLEV)      DOUBLE PRECISION pfdown(kdlon, kflev+1)
72  C      DOUBLE PRECISION pfup(kdlon, kflev+1)
73        REAL*8 PFDOWN(KDLON,KFLEV+1)  
74        REAL*8 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        REAL*8 ZCGAZ(KDLON,KFLEV)      DOUBLE PRECISION zfu(kdlon, kflev+1)
80        REAL*8 ZFD(KDLON,KFLEV+1)      DOUBLE PRECISION zg(kdlon)
81        REAL*8 ZFU(KDLON,KFLEV+1)      DOUBLE PRECISION zgg(kdlon)
82        REAL*8 ZG(KDLON)      DOUBLE PRECISION zpizaz(kdlon, kflev)
83        REAL*8 ZGG(KDLON)      DOUBLE PRECISION zrayl(kdlon)
84        REAL*8 ZPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION zray1(kdlon, kflev+1)
85        REAL*8 ZRAYL(KDLON)      DOUBLE PRECISION zray2(kdlon, kflev+1)
86        REAL*8 ZRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION zref(kdlon)
87        REAL*8 ZRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
88        REAL*8 ZREF(KDLON)      DOUBLE PRECISION zre1(kdlon)
89        REAL*8 ZREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION zre2(kdlon)
90        REAL*8 ZRE1(KDLON)      DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
91        REAL*8 ZRE2(KDLON)      DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
92        REAL*8 ZRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
93        REAL*8 ZRJ0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
94        REAL*8 ZRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrl(kdlon, 8)
95        REAL*8 ZRK0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrmue(kdlon, kflev+1)
96        REAL*8 ZRL(KDLON,8)      DOUBLE PRECISION zrmu0(kdlon, kflev+1)
97        REAL*8 ZRMUE(KDLON,KFLEV+1)      DOUBLE PRECISION zrmuz(kdlon)
98        REAL*8 ZRMU0(KDLON,KFLEV+1)      DOUBLE PRECISION zrneb(kdlon)
99        REAL*8 ZRMUZ(KDLON)      DOUBLE PRECISION zr1(kdlon)
100        REAL*8 ZRNEB(KDLON)      DOUBLE PRECISION zr2(kdlon, 2)
101        REAL*8 ZRUEF(KDLON,8)      DOUBLE PRECISION zr3(kdlon, 3)
102        REAL*8 ZR1(KDLON)      DOUBLE PRECISION zr4(kdlon)
103        REAL*8 ZR2(KDLON,2)      DOUBLE PRECISION zr21(kdlon)
104        REAL*8 ZR3(KDLON,3)      DOUBLE PRECISION zr22(kdlon)
105        REAL*8 ZR4(KDLON)      DOUBLE PRECISION zs(kdlon)
106        REAL*8 ZR21(KDLON)      DOUBLE PRECISION ztauaz(kdlon, kflev)
107        REAL*8 ZR22(KDLON)      DOUBLE PRECISION zto1(kdlon)
108        REAL*8 ZS(KDLON)      DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
109        REAL*8 ZTAUAZ(KDLON,KFLEV)      DOUBLE PRECISION ztra1(kdlon, kflev+1)
110        REAL*8 ZTO1(KDLON)      DOUBLE PRECISION ztra2(kdlon, kflev+1)
111        REAL*8 ZTR(KDLON,2,KFLEV+1)      DOUBLE PRECISION ztr1(kdlon)
112        REAL*8 ZTRA1(KDLON,KFLEV+1)      DOUBLE PRECISION ztr2(kdlon)
113        REAL*8 ZTRA2(KDLON,KFLEV+1)      DOUBLE PRECISION zw(kdlon)
114        REAL*8 ZTR1(KDLON)      DOUBLE PRECISION zw1(kdlon)
115        REAL*8 ZTR2(KDLON)      DOUBLE PRECISION zw2(kdlon, 2)
116        REAL*8 ZW(KDLON)        DOUBLE PRECISION zw3(kdlon, 3)
117        REAL*8 ZW1(KDLON)      DOUBLE PRECISION zw4(kdlon)
118        REAL*8 ZW2(KDLON,2)      DOUBLE PRECISION zw5(kdlon)
119        REAL*8 ZW3(KDLON,3)  
120        REAL*8 ZW4(KDLON)      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
121        REAL*8 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        REAL*8 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        REAL*8 RSUN(2)      SAVE rray
130        SAVE RSUN      DATA rsun(1)/0.441676d0/
131        REAL*8 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.24  
changed lines
  Added in v.219
  ViewVC Help
Powered by ViewVC 1.1.21