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

Annotation of /trunk/Sources/phylmd/Radlwsw/swclr.f

Parent Directory Parent Directory | Revision Log Revision Log


Revision 24 - (hide annotations)
Wed Mar 3 13:23:49 2010 UTC (14 years, 2 months ago) by guez
Original Path: trunk/libf/phylmd/Radlwsw/swclr.f
File size: 10398 byte(s)
Created directory "phylmd/Radlwsw". Split "radlwsw.f" in files
containing a single procedure.

Removed variable "itaufinp1" in "leapfrog".

1 guez 24 SUBROUTINE SWCLR ( KNU
2     S , PAER , flag_aer, tauae, pizae, cgae
3     S , PALBP , PDSIG , PRAYL , PSEC
4     S , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ
5     S , PRK , PRMU0 , PTAUAZ, PTRA1 , PTRA2 )
6     use dimens_m
7     use dimphy
8     use raddim
9     use radepsi
10     use radopt
11     IMPLICIT none
12     C
13     C ------------------------------------------------------------------
14     C PURPOSE.
15     C --------
16     C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
17     C CLEAR-SKY COLUMN
18     C
19     C REFERENCE.
20     C ----------
21     C
22     C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
23     C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
24     C
25     C AUTHOR.
26     C -------
27     C JEAN-JACQUES MORCRETTE *ECMWF*
28     C
29     C MODIFICATIONS.
30     C --------------
31     C ORIGINAL : 94-11-15
32     C ------------------------------------------------------------------
33     C* ARGUMENTS:
34     C
35     INTEGER KNU
36     c-OB
37     real*8 flag_aer
38     real*8 tauae(kdlon,kflev,2)
39     real*8 pizae(kdlon,kflev,2)
40     real*8 cgae(kdlon,kflev,2)
41     REAL*8 PAER(KDLON,KFLEV,5)
42     REAL*8 PALBP(KDLON,2)
43     REAL*8 PDSIG(KDLON,KFLEV)
44     REAL*8 PRAYL(KDLON)
45     REAL*8 PSEC(KDLON)
46     C
47     REAL*8 PCGAZ(KDLON,KFLEV)
48     REAL*8 PPIZAZ(KDLON,KFLEV)
49     REAL*8 PRAY1(KDLON,KFLEV+1)
50     REAL*8 PRAY2(KDLON,KFLEV+1)
51     REAL*8 PREFZ(KDLON,2,KFLEV+1)
52     REAL*8 PRJ(KDLON,6,KFLEV+1)
53     REAL*8 PRK(KDLON,6,KFLEV+1)
54     REAL*8 PRMU0(KDLON,KFLEV+1)
55     REAL*8 PTAUAZ(KDLON,KFLEV)
56     REAL*8 PTRA1(KDLON,KFLEV+1)
57     REAL*8 PTRA2(KDLON,KFLEV+1)
58     C
59     C* LOCAL VARIABLES:
60     C
61     REAL*8 ZC0I(KDLON,KFLEV+1)
62     REAL*8 ZCLE0(KDLON,KFLEV)
63     REAL*8 ZCLEAR(KDLON)
64     REAL*8 ZR21(KDLON)
65     REAL*8 ZR23(KDLON)
66     REAL*8 ZSS0(KDLON)
67     REAL*8 ZSCAT(KDLON)
68     REAL*8 ZTR(KDLON,2,KFLEV+1)
69     C
70     INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
71     REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
72     REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
73     REAL*8 ZBMU0, ZBMU1, ZRE11
74     C
75     C* Prescribed Data for Aerosols:
76     C
77     REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)
78     SAVE TAUA, RPIZA, RCGA
79     DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /
80     S .730719, .912819, .725059, .745405, .682188 ,
81     S .730719, .912819, .725059, .745405, .682188 /
82     DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /
83     S .872212, .982545, .623143, .944887, .997975 ,
84     S .872212, .982545, .623143, .944887, .997975 /
85     DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /
86     S .647596, .739002, .580845, .662657, .624246 ,
87     S .647596, .739002, .580845, .662657, .624246 /
88     C ------------------------------------------------------------------
89     C
90     C* 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
91     C --------------------------------------------
92     C
93     100 CONTINUE
94     C
95     DO 103 JK = 1 , KFLEV+1
96     DO 102 JA = 1 , 6
97     DO 101 JL = 1, KDLON
98     PRJ(JL,JA,JK) = 0.
99     PRK(JL,JA,JK) = 0.
100     101 CONTINUE
101     102 CONTINUE
102     103 CONTINUE
103     C
104     DO 108 JK = 1 , KFLEV
105     c-OB
106     c DO 104 JL = 1, KDLON
107     c PCGAZ(JL,JK) = 0.
108     c PPIZAZ(JL,JK) = 0.
109     c PTAUAZ(JL,JK) = 0.
110     c 104 CONTINUE
111     c-OB
112     c DO 106 JAE=1,5
113     c DO 105 JL = 1, KDLON
114     c PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
115     c S +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
116     c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
117     c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
118     c PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE)
119     c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
120     c 105 CONTINUE
121     c 106 CONTINUE
122     c-OB
123     DO 105 JL = 1, KDLON
124     PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
125     PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
126     PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
127     105 CONTINUE
128     C
129     IF (flag_aer.GT.0) THEN
130     c-OB
131     DO 107 JL = 1, KDLON
132     c PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
133     c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
134     ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
135     ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
136     ZGAR = PCGAZ(JL,JK)
137     ZFF = ZGAR * ZGAR
138     PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
139     PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
140     PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
141     S / (1. - PPIZAZ(JL,JK) * ZFF)
142     107 CONTINUE
143     ELSE
144     DO JL = 1, KDLON
145     ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
146     PTAUAZ(JL,JK) = ZTRAY
147     PCGAZ(JL,JK) = 0.
148     PPIZAZ(JL,JK) = 1.-REPSCT
149     END DO
150     END IF ! check flag_aer
151     c 107 CONTINUE
152     c PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
153     c $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
154     c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
155     C
156     108 CONTINUE
157     C
158     C ------------------------------------------------------------------
159     C
160     C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
161     C ----------------------------------------------
162     C
163     200 CONTINUE
164     C
165     DO 201 JL = 1, KDLON
166     ZR23(JL) = 0.
167     ZC0I(JL,KFLEV+1) = 0.
168     ZCLEAR(JL) = 1.
169     ZSCAT(JL) = 0.
170     201 CONTINUE
171     C
172     JK = 1
173     JKL = KFLEV+1 - JK
174     JKLP1 = JKL + 1
175     DO 202 JL = 1, KDLON
176     ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
177     ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
178     ZR21(JL) = EXP(-ZCORAE )
179     ZSS0(JL) = 1.-ZR21(JL)
180     ZCLE0(JL,JKL) = ZSS0(JL)
181     C
182     IF (NOVLP.EQ.1) THEN
183     c* maximum-random
184     ZCLEAR(JL) = ZCLEAR(JL)
185     S *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
186     S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
187     ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
188     ZSCAT(JL) = ZSS0(JL)
189     ELSE IF (NOVLP.EQ.2) THEN
190     C* maximum
191     ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
192     ZC0I(JL,JKL) = ZSCAT(JL)
193     ELSE IF (NOVLP.EQ.3) THEN
194     c* random
195     ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
196     ZSCAT(JL) = 1.0 - ZCLEAR(JL)
197     ZC0I(JL,JKL) = ZSCAT(JL)
198     END IF
199     202 CONTINUE
200     C
201     DO 205 JK = 2 , KFLEV
202     JKL = KFLEV+1 - JK
203     JKLP1 = JKL + 1
204     DO 204 JL = 1, KDLON
205     ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
206     ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
207     ZR21(JL) = EXP(-ZCORAE )
208     ZSS0(JL) = 1.-ZR21(JL)
209     ZCLE0(JL,JKL) = ZSS0(JL)
210     c
211     IF (NOVLP.EQ.1) THEN
212     c* maximum-random
213     ZCLEAR(JL) = ZCLEAR(JL)
214     S *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
215     S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
216     ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
217     ZSCAT(JL) = ZSS0(JL)
218     ELSE IF (NOVLP.EQ.2) THEN
219     C* maximum
220     ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
221     ZC0I(JL,JKL) = ZSCAT(JL)
222     ELSE IF (NOVLP.EQ.3) THEN
223     c* random
224     ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
225     ZSCAT(JL) = 1.0 - ZCLEAR(JL)
226     ZC0I(JL,JKL) = ZSCAT(JL)
227     END IF
228     204 CONTINUE
229     205 CONTINUE
230     C
231     C ------------------------------------------------------------------
232     C
233     C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
234     C -----------------------------------------------
235     C
236     300 CONTINUE
237     C
238     DO 301 JL = 1, KDLON
239     PRAY1(JL,KFLEV+1) = 0.
240     PRAY2(JL,KFLEV+1) = 0.
241     PREFZ(JL,2,1) = PALBP(JL,KNU)
242     PREFZ(JL,1,1) = PALBP(JL,KNU)
243     PTRA1(JL,KFLEV+1) = 1.
244     PTRA2(JL,KFLEV+1) = 1.
245     301 CONTINUE
246     C
247     DO 346 JK = 2 , KFLEV+1
248     JKM1 = JK-1
249     DO 342 JL = 1, KDLON
250     C
251     C
252     C ------------------------------------------------------------------
253     C
254     C* 3.1 EQUIVALENT ZENITH ANGLE
255     C -----------------------
256     C
257     310 CONTINUE
258     C
259     ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
260     S + ZC0I(JL,JK) * 1.66
261     PRMU0(JL,JK) = 1./ZMUE
262     C
263     C
264     C ------------------------------------------------------------------
265     C
266     C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
267     C ----------------------------------------------------
268     C
269     320 CONTINUE
270     C
271     ZGAP = PCGAZ(JL,JKM1)
272     ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
273     ZWW = PPIZAZ(JL,JKM1)
274     ZTO = PTAUAZ(JL,JKM1)
275     ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
276     S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
277     PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
278     PTRA1(JL,JKM1) = 1. / ZDEN
279     C
280     ZMU1 = 0.5
281     ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
282     ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
283     S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
284     PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
285     PTRA2(JL,JKM1) = 1. / ZDEN1
286     C
287     C
288     C
289     PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
290     S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
291     S * PTRA2(JL,JKM1)
292     S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
293     C
294     ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
295     S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
296     C
297     PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
298     S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
299     S * PTRA2(JL,JKM1) )
300     C
301     ZTR(JL,2,JKM1) = PTRA1(JL,JKM1)
302     C
303     342 CONTINUE
304     346 CONTINUE
305     DO 347 JL = 1, KDLON
306     ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
307     PRMU0(JL,1)=1./ZMUE
308     347 CONTINUE
309     C
310     C
311     C ------------------------------------------------------------------
312     C
313     C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
314     C -------------------------------------------------
315     C
316     350 CONTINUE
317     C
318     IF (KNU.EQ.1) THEN
319     JAJ = 2
320     DO 351 JL = 1, KDLON
321     PRJ(JL,JAJ,KFLEV+1) = 1.
322     PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
323     351 CONTINUE
324     C
325     DO 353 JK = 1 , KFLEV
326     JKL = KFLEV+1 - JK
327     JKLP1 = JKL + 1
328     DO 352 JL = 1, KDLON
329     ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL)
330     PRJ(JL,JAJ,JKL) = ZRE11
331     PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL)
332     352 CONTINUE
333     353 CONTINUE
334     354 CONTINUE
335     C
336     ELSE
337     C
338     DO 358 JAJ = 1 , 2
339     DO 355 JL = 1, KDLON
340     PRJ(JL,JAJ,KFLEV+1) = 1.
341     PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
342     355 CONTINUE
343     C
344     DO 357 JK = 1 , KFLEV
345     JKL = KFLEV+1 - JK
346     JKLP1 = JKL + 1
347     DO 356 JL = 1, KDLON
348     ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
349     PRJ(JL,JAJ,JKL) = ZRE11
350     PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
351     356 CONTINUE
352     357 CONTINUE
353     358 CONTINUE
354     C
355     END IF
356     C
357     C ------------------------------------------------------------------
358     C
359     RETURN
360     END

  ViewVC Help
Powered by ViewVC 1.1.21