Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_ra_sw.F @ 3567

Last change on this file since 3567 was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 16.9 KB

Line
1	!WRF:MODEL_LAYER:PHYSICS
2	!
3	MODULE module_ra_sw
4
5	REAL,PRIVATE,SAVE :: CSSCA
6
7	CONTAINS
8
9	!------------------------------------------------------------------
10	SUBROUTINE SWRAD(dt,RTHRATEN,GSW,XLAT,XLONG,ALBEDO, &
11	rho_phy,T3D,QV3D,QC3D,QR3D, &
12	QI3D,QS3D,QG3D,P3D,pi3D,dz8w,GMT, &
13	R,CP,G,JULDAY, &
14	XTIME,DECLIN,SOLCON, &
15	F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, &
16	pm2_5_dry,pm2_5_water,pm2_5_dry_ec, &
17	RADFRQ,ICLOUD,DEGRAD,warm_rain, &
18	ids,ide, jds,jde, kds,kde, &
19	ims,ime, jms,jme, kms,kme, &
20	its,ite, jts,jte, kts,kte, &
21	cosz_urb2d,omg_urb2d & !Optional urban
22	)
23	!------------------------------------------------------------------
24	IMPLICIT NONE
25	!------------------------------------------------------------------
26	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
27	ims,ime, jms,jme, kms,kme, &
28	its,ite, jts,jte, kts,kte
29
30	LOGICAL, INTENT(IN ) :: warm_rain
31	INTEGER, INTENT(IN ) :: icloud
32
33	REAL, INTENT(IN ) :: RADFRQ,DEGRAD, &
34	XTIME,DECLIN,SOLCON
35	!
36	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
37	INTENT(IN ) :: P3D, &
38	pi3D, &
39	rho_phy, &
40	dz8w, &
41	T3D
42	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
43	INTENT(IN ) :: pm2_5_dry, &
44	pm2_5_water, &
45	pm2_5_dry_ec
46
47
48	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
49	INTENT(INOUT) :: RTHRATEN
50	!
51	REAL, DIMENSION( ims:ime, jms:jme ), &
52	INTENT(IN ) :: XLAT, &
53	XLONG, &
54	ALBEDO
55	!
56	REAL, DIMENSION( ims:ime, jms:jme ), &
57	INTENT(INOUT) :: GSW
58	!
59	REAL, INTENT(IN ) :: GMT,R,CP,G,dt
60	!
61	INTEGER, INTENT(IN ) :: JULDAY
62	!
63	! Optional
64	!
65	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
66	OPTIONAL, &
67	INTENT(IN ) :: &
68	QV3D, &
69	QC3D, &
70	QR3D, &
71	QI3D, &
72	QS3D, &
73	QG3D
74
75	LOGICAL, OPTIONAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
76
77	! LOCAL VARS
78
79	REAL, DIMENSION( kts:kte ) :: &
80	TTEN1D, &
81	RHO01D, &
82	P1D, &
83	DZ, &
84	T1D, &
85	QV1D, &
86	QC1D, &
87	QR1D, &
88	QI1D, &
89	QS1D, &
90	QG1D
91	!
92	REAL:: XLAT0,XLONG0,ALB0,GSW0
93
94	REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZ_URB2D, OMG_URB2D !Optional urban
95	REAL :: COSZ, OMG !urban
96	!
97	INTEGER :: i,j,K,NK
98	LOGICAL :: predicate
99	real :: aer_dry1(kts:kte),aer_water1(kts:kte)
100
101	!------------------------------------------------------------------
102	j_loop: DO J=jts,jte
103	i_loop: DO I=its,ite
104
105	! reverse vars
106	DO K=kts,kte
107	QV1D(K)=0.
108	QC1D(K)=0.
109	QR1D(K)=0.
110	QI1D(K)=0.
111	QS1D(K)=0.
112	QG1D(K)=0.
113	ENDDO
114
115	DO K=kts,kte
116	NK=kme-1-K+kms
117	TTEN1D(K)=0.
118
119	T1D(K)=T3D(I,NK,J)
120	P1D(K)=P3D(I,NK,J)
121	RHO01D(K)=rho_phy(I,NK,J)
122	DZ(K)=dz8w(I,NK,J)
123	ENDDO
124
125	IF( PRESENT(pm2_5_dry) .AND. PRESENT(pm2_5_water) )THEN
126	DO K=kts,kte
127	NK=kme-1-K+kms
128	aer_dry1(k) = pm2_5_dry(i,nk,j)
129	aer_water1(k) = pm2_5_water(i,nk,j)
130	ENDDO
131	ELSE
132	DO K=kts,kte
133	aer_dry1(k) = 0.
134	aer_water1(k) = 0.
135	ENDDO
136	ENDIF
137
138	IF (PRESENT(F_QV) .AND. PRESENT(QV3D)) THEN
139	IF (F_QV) THEN
140	DO K=kts,kte
141	NK=kme-1-K+kms
142	QV1D(K)=QV3D(I,NK,J)
143	QV1D(K)=max(0.,QV1D(K))
144	ENDDO
145	ENDIF
146	ENDIF
147
148	IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
149	IF (F_QC) THEN
150	DO K=kts,kte
151	NK=kme-1-K+kms
152	QC1D(K)=QC3D(I,NK,J)
153	QC1D(K)=max(0.,QC1D(K))
154	ENDDO
155	ENDIF
156	ENDIF
157
158	IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
159	IF (F_QR) THEN
160	DO K=kts,kte
161	NK=kme-1-K+kms
162	QR1D(K)=QR3D(I,NK,J)
163	QR1D(K)=max(0.,QR1D(K))
164	ENDDO
165	ENDIF
166	ENDIF
167
168	!
169	IF ( PRESENT( F_QI ) ) THEN
170	predicate = F_QI
171	ELSE
172	predicate = .FALSE.
173	ENDIF
174
175	IF ( predicate .AND. PRESENT( QI3D ) ) THEN
176	DO K=kts,kte
177	NK=kme-1-K+kms
178	QI1D(K)=QI3D(I,NK,J)
179	QI1D(K)=max(0.,QI1D(K))
180	ENDDO
181	ELSE
182	IF (.not. warm_rain) THEN
183	DO K=kts,kte
184	IF(T1D(K) .lt. 273.15) THEN
185	QI1D(K)=QC1D(K)
186	QC1D(K)=0.
187	QS1D(K)=QR1D(K)
188	QR1D(K)=0.
189	ENDIF
190	ENDDO
191	ENDIF
192	ENDIF
193
194	IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
195	IF (F_QS) THEN
196	DO K=kts,kte
197	NK=kme-1-K+kms
198	QS1D(K)=QS3D(I,NK,J)
199	QS1D(K)=max(0.,QS1D(K))
200	ENDDO
201	ENDIF
202	ENDIF
203
204	IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
205	IF (F_QG) THEN
206	DO K=kts,kte
207	NK=kme-1-K+kms
208	QG1D(K)=QG3D(I,NK,J)
209	QG1D(K)=max(0.,QG1D(K))
210	ENDDO
211	ENDIF
212	ENDIF
213
214	XLAT0=XLAT(I,J)
215	XLONG0=XLONG(I,J)
216	ALB0=ALBEDO(I,J)
217
218	CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, &
219	T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, &
220	XTIME,GMT,RHO01D,DZ, &
221	R,CP,G,DECLIN,SOLCON, &
222	COSZ, OMG, & !urban
223	RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, &
224	kts,kte )
225
226	IF (PRESENT(COSZ_URB2D) .AND. PRESENT(OMG_URB2D)) THEN
227	COSZ_URB2D(I,J)=COSZ !urban
228	OMG_URB2D(I,J)=OMG !urban
229	ENDIF
230
231	GSW(I,J)=GSW0
232	DO K=kts,kte
233	NK=kme-1-K+kms
234	RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+TTEN1D(NK)/pi3D(I,K,J)
235	ENDDO
236	!
237	ENDDO i_loop
238	ENDDO j_loop
239
240	END SUBROUTINE SWRAD
241
242	!------------------------------------------------------------------
243	SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO, &
244	T,QV,QC,QR,QI,QS,QG,P, &
245	XTIME, GMT, RHO0, DZ, &
246	R,CP,G,DECLIN,SOLCON, &
247	COSZ, OMG, & !urban
248	RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, &
249	kts,kte )
250	!------------------------------------------------------------------
251	! TO CALCULATE SHORT-WAVE ABSORPTION AND SCATTERING IN CLEAR
252	! AIR AND REFLECTION AND ABSORPTION IN CLOUD LAYERS (STEPHENS,
253	! 1984)
254	! CHANGES:
255	! REDUCE EFFECTS OF ICE CLOUDS AND PRECIP ON LIQUID WATER PATH
256	! ADD EFFECT OF GRAUPEL
257	!------------------------------------------------------------------
258
259	IMPLICIT NONE
260
261	INTEGER, INTENT(IN ) :: kts,kte
262	!
263	REAL, DIMENSION( kts:kte ), INTENT(IN ) :: &
264	RHO0, &
265	T, &
266	P, &
267	DZ, &
268	QV, &
269	QC, &
270	QR, &
271	QI, &
272	QS, &
273	QG
274
275	REAL, DIMENSION( kts:kte ), INTENT(INOUT):: TTEN
276	!
277	REAL, INTENT(IN ) :: XTIME,GMT,R,CP,G,DECLIN, &
278	SOLCON,XLAT,XLONG,ALBEDO, &
279	RADFRQ, DEGRAD
280	!
281	INTEGER, INTENT(IN) :: icloud
282	REAL, INTENT(INOUT) :: GSW
283	!
284	! LOCAL VARS
285	!
286	REAL, DIMENSION( kts:kte+1 ) :: SDOWN
287
288	REAL, DIMENSION( kts:kte ) :: XLWP, &
289	XATP, &
290	XWVP, &
291	aer_dry1,aer_water1, &
292	RO
293	!
294	REAL, DIMENSION( 4, 5 ) :: ALBTAB, &
295	ABSTAB
296
297	REAL, DIMENSION( 4 ) :: XMUVAL
298
299	REAL, INTENT(OUT) :: COSZ !urban
300	REAL, INTENT(OUT) :: OMG !urban
301
302	REAL :: beta
303
304	!------------------------------------------------------------------
305
306	DATA ALBTAB/0.,0.,0.,0., &
307	69.,58.,40.,15., &
308	90.,80.,70.,60., &
309	94.,90.,82.,78., &
310	96.,92.,85.,80./
311
312	DATA ABSTAB/0.,0.,0.,0., &
313	0.,2.5,4.,5., &
314	0.,2.6,7.,10., &
315	0.,3.3,10.,14., &
316	0.,3.7,10.,15./
317
318	DATA XMUVAL/0.,0.2,0.5,1.0/
319
320	REAL :: bext340, absc, alba, alw, csza,dabsa,dsca,dabs
321	REAL :: bexth2o, dscld, hrang,ff,oldalb,oldabs,oldabc
322	REAL :: soltop, totabs, tloctm, ugcm, uv,xabs,xabsa,wv
323	REAL :: wgm, xalb, xi, xsca, xt24,xmu,xabsc,trans0,yj
324	REAL :: xxlat,ww
325	INTEGER :: iil,ii,jjl,ju,k,iu
326
327	GSW=0.0
328	bext340=5.E-6
329	bexth2o=5.E-6
330	SOLTOP=SOLCON
331	XT24=MOD(XTIME+RADFRQ*0.5,1440.)
332	TLOCTM=GMT+XT24/60.+XLONG/15.
333	HRANG=15.(TLOCTM-12.)DEGRAD
334	XXLAT=XLAT*DEGRAD
335	CSZA=SIN(XXLAT)SIN(DECLIN)+COS(XXLAT)COS(DECLIN)*COS(HRANG)
336
337	COSZ = CSZA !urban
338	OMG = HRANG !urban
339
340	! RETURN IF NIGHT
341	IF(CSZA.LE.1.E-9)GOTO 7
342	!
343	DO K=kts, kte
344
345	! P in the unit of 10mb
346	RO(K)=P(K)/(R*T(K))
347	XWVP(K)=RO(K)QV(K)DZ(K)*1000.
348	! KG/M**2
349	XATP(K)=RO(K)*DZ(K)
350	ENDDO
351	!
352	! G/M**2
353	! REDUCE WEIGHT OF LIQUID AND ICE IN SHORT-WAVE SCHEME
354	! ADD GRAUPEL EFFECT (ASSUMED SAME AS RAIN)
355	!
356	IF (ICLOUD.EQ.0)THEN
357	DO K=kts, kte
358	XLWP(K)=0.
359	ENDDO
360	ELSE
361	DO K=kts, kte
362	XLWP(K)=RO(K)1000.DZ(K)(QC(K)+0.1QI(K)+0.05* &
363	QR(K)+0.02QS(K)+0.05QG(K))
364	ENDDO
365	ENDIF
366	!
367	XMU=CSZA
368	SDOWN(1)=SOLTOP*XMU
369	! SET WW (G/M**2) LIQUID WATER PATH INTEGRATED DOWN
370	! SET UV (G/M**2) WATER VAPOR PATH INTEGRATED DOWN
371	WW=0.
372	UV=0.
373	OLDALB=0.
374	OLDABC=0.
375	TOTABS=0.
376	! CONTRIBUTIONS DUE TO CLEAR AIR AND CLOUD
377	DSCA=0.
378	DABS=0.
379	DSCLD=0.
380	!
381	! CONTRIBUTION DUE TO AEROSOLS (FOR CHEMISTRY)
382	DABSA=0.
383	!
384	DO 200 K=kts,kte
385	WW=WW+XLWP(K)
386	UV=UV+XWVP(K)
387	! WGM IS WW/COS(THETA) (G/M**2)
388	! UGCM IS UV/COS(THETA) (G/CM**2)
389	WGM=WW/XMU
390	UGCM=UV*0.0001/XMU
391	!
392	OLDABS=TOTABS
393	! WATER VAPOR ABSORPTION AS IN LACIS AND HANSEN (1974)
394	TOTABS=2.9UGCM/((1.+141.5UGCM)*0.635+5.925UGCM)
395	! APPROXIMATE RAYLEIGH + AEROSOL SCATTERING
396	! XSCA=1.E-5*XATP(K)/XMU
397	! XSCA=(1.E-5XATP(K)+aer_dry1(K)bext340+aer_water1(K)*bexth2o)/XMU
398	beta=0.4*(1.0-XMU)+0.1
399	! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT
400	XSCA=(csscaXATP(K)+betaaer_dry1(K)bext340DZ(K) &
401	+betaaer_water1(K)bexth2o*DZ(K))/XMU
402
403	! LAYER VAPOR ABSORPTION DONE FIRST
404	XABS=(TOTABS-OLDABS)*(SDOWN(1)-DSCLD-DSCA-DABSA)/SDOWN(K)
405	!rs AEROSOL ABSORB (would be elemental carbon). So far XABSA = 0.
406	XABSA=0.
407	IF(XABS.LT.0.)XABS=0.
408	!
409	ALW=ALOG10(WGM+1.)
410	IF(ALW.GT.3.999)ALW=3.999
411	!
412	DO II=1,3
413	IF(XMU.GT.XMUVAL(II))THEN
414	IIL=II
415	IU=II+1
416	XI=(XMU-XMUVAL(II))/(XMUVAL(II+1)-XMUVAL(II))+FLOAT(IIL)
417	ENDIF
418	ENDDO
419	!
420	JJL=IFIX(ALW)+1
421	JU=JJL+1
422	YJ=ALW+1.
423	! CLOUD ALBEDO
424	ALBA=(ALBTAB(IU,JU)(XI-IIL)(YJ-JJL) &
425	+ALBTAB(IIL,JU)(IU-XI)(YJ-JJL) &
426	+ALBTAB(IU,JJL)(XI-IIL)(JU-YJ) &
427	+ALBTAB(IIL,JJL)(IU-XI)(JU-YJ)) &
428	/((IU-IIL)*(JU-JJL))
429	! CLOUD ABSORPTION
430	ABSC=(ABSTAB(IU,JU)(XI-IIL)(YJ-JJL) &
431	+ABSTAB(IIL,JU)(IU-XI)(YJ-JJL) &
432	+ABSTAB(IU,JJL)(XI-IIL)(JU-YJ) &
433	+ABSTAB(IIL,JJL)(IU-XI)(JU-YJ)) &
434	/((IU-IIL)*(JU-JJL))
435	! LAYER ALBEDO AND ABSORPTION
436	XALB=(ALBA-OLDALB)*(SDOWN(1)-DSCA-DABS)/SDOWN(K)
437	XABSC=(ABSC-OLDABC)*(SDOWN(1)-DSCA-DABS)/SDOWN(K)
438	IF(XALB.LT.0.)XALB=0.
439	IF(XABSC.LT.0.)XABSC=0.
440	DSCLD=DSCLD+(XALB+XABSC)SDOWN(K)0.01
441	DSCA=DSCA+XSCA*SDOWN(K)
442	DABS=DABS+XABS*SDOWN(K)
443	DABSA=DABSA+XABSA*SDOWN(K)
444	OLDALB=ALBA
445	OLDABC=ABSC
446	! LAYER TRANSMISSIVITY
447	TRANS0=100.-XALB-XABSC-XABS100.-XSCA100.
448	IF(TRANS0.LT.1.)THEN
449	FF=99./(XALB+XABSC+XABS100.+XSCA100.)
450	XALB=XALB*FF
451	XABSC=XABSC*FF
452	XABS=XABS*FF
453	XSCA=XSCA*FF
454	TRANS0=1.
455	ENDIF
456	SDOWN(K+1)=AMAX1(1.E-9,SDOWN(K)TRANS00.01)
457	TTEN(K)=SDOWN(K)(XABSC+XABS100.+XABSA100.)0.01/( &
458	RO(K)CPDZ(K))
459	200 CONTINUE
460	!
461	GSW=(1.-ALBEDO)*SDOWN(kte+1)
462
463	7 CONTINUE
464	!
465	END SUBROUTINE SWPARA
466
467	!====================================================================
468	SUBROUTINE swinit(swrad_scat, &
469	allowed_to_read , &
470	ids, ide, jds, jde, kds, kde, &
471	ims, ime, jms, jme, kms, kme, &
472	its, ite, jts, jte, kts, kte )
473	!--------------------------------------------------------------------
474	IMPLICIT NONE
475	!--------------------------------------------------------------------
476	LOGICAL , INTENT(IN) :: allowed_to_read
477	INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
478	ims, ime, jms, jme, kms, kme, &
479	its, ite, jts, jte, kts, kte
480
481	REAL , INTENT(IN) :: swrad_scat
482
483	! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT
484	cssca = swrad_scat * 1.e-5
485
486	END SUBROUTINE swinit
487
488	END MODULE module_ra_sw

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format