Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

module_ra_sw.F @ 3094

Last change on this file since 3094 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 21.1 KB

Rev	Line
[2759]	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	slope_rad,topo_shading,ht, & ! Optional
	22	dx,dy,sina,cosa,shadowmask, & ! Optional
	23	cosz_urb2d,omg_urb2d & !Optional urban
	24	)
	25	!------------------------------------------------------------------
	26	IMPLICIT NONE
	27	!------------------------------------------------------------------
	28	INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
	29	ims,ime, jms,jme, kms,kme, &
	30	its,ite, jts,jte, kts,kte
	31
	32	LOGICAL, INTENT(IN ) :: warm_rain
	33	INTEGER, INTENT(IN ) :: icloud
	34
	35	REAL, INTENT(IN ) :: RADFRQ,DEGRAD, &
	36	XTIME,DECLIN,SOLCON
	37	!
	38	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
	39	INTENT(IN ) :: P3D, &
	40	pi3D, &
	41	rho_phy, &
	42	dz8w, &
	43	T3D
	44	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
	45	INTENT(IN ) :: pm2_5_dry, &
	46	pm2_5_water, &
	47	pm2_5_dry_ec
	48
	49
	50	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
	51	INTENT(INOUT) :: RTHRATEN
	52	!
	53	REAL, DIMENSION( ims:ime, jms:jme ), &
	54	INTENT(IN ) :: XLAT, &
	55	XLONG, &
	56	ALBEDO
	57	!
	58	REAL, DIMENSION( ims:ime, jms:jme ), &
	59	INTENT(INOUT) :: GSW
	60	!
	61	REAL, INTENT(IN ) :: GMT,R,CP,G,dt
	62	!
	63	INTEGER, INTENT(IN ) :: JULDAY
	64
	65
	66
	67	!
	68	! Optional
	69	!
	70	REAL, OPTIONAL, INTENT(IN) :: dx,dy
	71
	72	REAL, DIMENSION( ims:ime, jms:jme ), &
	73	OPTIONAL, INTENT(IN) :: sina,cosa,ht
	74	REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
	75	OPTIONAL, &
	76	INTENT(IN ) :: &
	77	QV3D, &
	78	QC3D, &
	79	QR3D, &
	80	QI3D, &
	81	QS3D, &
	82	QG3D
	83
	84	INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,topo_shading
	85
	86	INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: shadowmask
	87
	88	LOGICAL, OPTIONAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
	89
	90	REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZ_URB2D, OMG_URB2D !Optional urban
	91	! LOCAL VARS
	92
	93	REAL, DIMENSION( kts:kte ) :: &
	94	TTEN1D, &
	95	RHO01D, &
	96	P1D, &
	97	DZ, &
	98	T1D, &
	99	QV1D, &
	100	QC1D, &
	101	QR1D, &
	102	QI1D, &
	103	QS1D, &
	104	QG1D
	105	!
	106	REAL:: XLAT0,XLONG0,ALB0,GSW0
	107
	108	REAL :: COSZ, OMG !urban
	109	!
	110	INTEGER :: i,j,K,NK
	111	LOGICAL :: predicate , do_topo_shading
	112	real :: aer_dry1(kts:kte),aer_water1(kts:kte)
	113
	114	real :: sinalpha,cosalpha,hx,hy,slope,slp_azi,pi
	115	integer :: shadow
	116
	117	!------------------------------------------------------------------
	118
	119	pi = 4.*atan(1.)
	120
	121	j_loop: DO J=jts,jte
	122	i_loop: DO I=its,ite
	123
	124	! reverse vars
	125	DO K=kts,kte
	126	QV1D(K)=0.
	127	QC1D(K)=0.
	128	QR1D(K)=0.
	129	QI1D(K)=0.
	130	QS1D(K)=0.
	131	QG1D(K)=0.
	132	ENDDO
	133
	134	DO K=kts,kte
	135	NK=kme-1-K+kms
	136	TTEN1D(K)=0.
	137
	138	T1D(K)=T3D(I,NK,J)
	139	P1D(K)=P3D(I,NK,J)
	140	RHO01D(K)=rho_phy(I,NK,J)
	141	DZ(K)=dz8w(I,NK,J)
	142	ENDDO
	143
	144	IF( PRESENT(pm2_5_dry) .AND. PRESENT(pm2_5_water) )THEN
	145	DO K=kts,kte
	146	NK=kme-1-K+kms
	147	aer_dry1(k) = pm2_5_dry(i,nk,j)
	148	aer_water1(k) = pm2_5_water(i,nk,j)
	149	ENDDO
	150	ELSE
	151	DO K=kts,kte
	152	aer_dry1(k) = 0.
	153	aer_water1(k) = 0.
	154	ENDDO
	155	ENDIF
	156
	157	IF (PRESENT(F_QV) .AND. PRESENT(QV3D)) THEN
	158	IF (F_QV) THEN
	159	DO K=kts,kte
	160	NK=kme-1-K+kms
	161	QV1D(K)=QV3D(I,NK,J)
	162	QV1D(K)=max(0.,QV1D(K))
	163	ENDDO
	164	ENDIF
	165	ENDIF
	166
	167	IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
	168	IF (F_QC) THEN
	169	DO K=kts,kte
	170	NK=kme-1-K+kms
	171	QC1D(K)=QC3D(I,NK,J)
	172	QC1D(K)=max(0.,QC1D(K))
	173	ENDDO
	174	ENDIF
	175	ENDIF
	176
	177	IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
	178	IF (F_QR) THEN
	179	DO K=kts,kte
	180	NK=kme-1-K+kms
	181	QR1D(K)=QR3D(I,NK,J)
	182	QR1D(K)=max(0.,QR1D(K))
	183	ENDDO
	184	ENDIF
	185	ENDIF
	186
	187	!
	188	IF ( PRESENT( F_QI ) ) THEN
	189	predicate = F_QI
	190	ELSE
	191	predicate = .FALSE.
	192	ENDIF
	193
	194	IF ( predicate .AND. PRESENT( QI3D ) ) THEN
	195	DO K=kts,kte
	196	NK=kme-1-K+kms
	197	QI1D(K)=QI3D(I,NK,J)
	198	QI1D(K)=max(0.,QI1D(K))
	199	ENDDO
	200	ELSE
	201	IF (.not. warm_rain) THEN
	202	DO K=kts,kte
	203	IF(T1D(K) .lt. 273.15) THEN
	204	QI1D(K)=QC1D(K)
	205	QC1D(K)=0.
	206	QS1D(K)=QR1D(K)
	207	QR1D(K)=0.
	208	ENDIF
	209	ENDDO
	210	ENDIF
	211	ENDIF
	212
	213	IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
	214	IF (F_QS) THEN
	215	DO K=kts,kte
	216	NK=kme-1-K+kms
	217	QS1D(K)=QS3D(I,NK,J)
	218	QS1D(K)=max(0.,QS1D(K))
	219	ENDDO
	220	ENDIF
	221	ENDIF
	222
	223	IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
	224	IF (F_QG) THEN
	225	DO K=kts,kte
	226	NK=kme-1-K+kms
	227	QG1D(K)=QG3D(I,NK,J)
	228	QG1D(K)=max(0.,QG1D(K))
	229	ENDDO
	230	ENDIF
	231	ENDIF
	232
	233	XLAT0=XLAT(I,J)
	234	XLONG0=XLONG(I,J)
	235	ALB0=ALBEDO(I,J)
	236
	237	IF (PRESENT(topo_shading)) THEN
	238	IF (topo_shading.eq.1) THEN
	239	do_topo_shading = .TRUE.
	240	ELSE
	241	do_topo_shading = .FALSE.
	242	END IF
	243	ELSE
	244	do_topo_shading = .FALSE.
	245	END IF
	246
	247	shadow = 0
	248	IF (do_topo_shading) THEN
	249	IF(PRESENT(slope_rad) .AND. PRESENT(shadowmask))THEN
	250	! Computations for slope-dependent radiation
	251
	252	sinalpha = sina(i,j)
	253	cosalpha = cosa(i,j)
	254
	255	! Compute slope and slope azimuth of local grid point
	256
	257	if ((i.ge.ids+1).and.(i.le.ide-2)) then
	258	hx = (ht(i+1,j)-ht(i-1,j))/(2.*dx)
	259	else if (i.eq.ids) then
	260	hx = (ht(i+1,j)-ht(i,j))/dx
	261	else if (i.eq.ide-1) then
	262	hx = (ht(i,j)-ht(i-1,j))/dx
	263	endif
	264	if ((j.ge.jds+1).and.(j.le.jde-2)) then
	265	hy = (ht(i,j+1)-ht(i,j-1))/(2.*dy)
	266	else if (j.eq.jds) then
	267	hy = (ht(i,j+1)-ht(i,j))/dy
	268	else if (j.eq.jde-1) then
	269	hy = (ht(i,j)-ht(i,j-1))/dy
	270	endif
	271
	272	slope = atan((hx2+hy2)**.5)
	273	if (slope.lt.1.e-4) then
	274	slope = 0.
	275	slp_azi = 0.
	276	else
	277	slp_azi = atan2(hx,hy)+pi
	278	! Rotate slope azimuth to lat-lon grid
	279	if (cosalpha.ge.0) then
	280	slp_azi = slp_azi - asin(sinalpha)
	281	else
	282	slp_azi = slp_azi - (pi - asin(sinalpha))
	283	endif
	284	endif
	285
	286	shadow = shadowmask(i,j)
	287	ENDIF
	288
	289	CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, &
	290	T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, &
	291	XTIME,GMT,RHO01D,DZ, &
	292	R,CP,G,DECLIN,SOLCON, &
	293	COSZ, OMG, & !urban
	294	RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, &
	295	kts,kte,slope_rad,shadow,slp_azi,slope )
	296	ELSE
	297	CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, &
	298	T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, &
	299	XTIME,GMT,RHO01D,DZ, &
	300	R,CP,G,DECLIN,SOLCON, &
	301	COSZ, OMG, & !urban
	302	RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, &
	303	kts,kte )
	304	ENDIF
	305
	306	IF (PRESENT(COSZ_URB2D) .AND. PRESENT(OMG_URB2D)) THEN
	307	COSZ_URB2D(I,J)=COSZ !urban
	308	OMG_URB2D(I,J)=OMG !urban
	309	ENDIF
	310
	311	GSW(I,J)=GSW0
	312	DO K=kts,kte
	313	NK=kme-1-K+kms
	314	RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+TTEN1D(NK)/pi3D(I,K,J)
	315	ENDDO
	316	!
	317	ENDDO i_loop
	318	ENDDO j_loop
	319
	320	END SUBROUTINE SWRAD
	321
	322	!------------------------------------------------------------------
	323	SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO, &
	324	T,QV,QC,QR,QI,QS,QG,P, &
	325	XTIME, GMT, RHO0, DZ, &
	326	R,CP,G,DECLIN,SOLCON, &
	327	COSZ, OMG, & !urban
	328	RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, &
	329	kts,kte,slope_rad,shadow,slp_azi,slope )
	330	!------------------------------------------------------------------
	331	! TO CALCULATE SHORT-WAVE ABSORPTION AND SCATTERING IN CLEAR
	332	! AIR AND REFLECTION AND ABSORPTION IN CLOUD LAYERS (STEPHENS,
	333	! 1984)
	334	! CHANGES:
	335	! REDUCE EFFECTS OF ICE CLOUDS AND PRECIP ON LIQUID WATER PATH
	336	! ADD EFFECT OF GRAUPEL
	337	!------------------------------------------------------------------
	338
	339	IMPLICIT NONE
	340
	341	INTEGER, INTENT(IN ) :: kts,kte
	342	!
	343	REAL, DIMENSION( kts:kte ), INTENT(IN ) :: &
	344	RHO0, &
	345	T, &
	346	P, &
	347	DZ, &
	348	QV, &
	349	QC, &
	350	QR, &
	351	QI, &
	352	QS, &
	353	QG
	354
	355	REAL, DIMENSION( kts:kte ), INTENT(INOUT):: TTEN
	356	!
	357	REAL, INTENT(IN ) :: XTIME,GMT,R,CP,G,DECLIN, &
	358	SOLCON,XLAT,XLONG,ALBEDO, &
	359	RADFRQ, DEGRAD
	360	!
	361	INTEGER, INTENT(IN) :: icloud
	362	REAL, INTENT(INOUT) :: GSW
	363	! For slope-dependent radiation
	364
	365	INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,shadow
	366	REAL, OPTIONAL, INTENT(IN) :: slp_azi,slope
	367
	368	! LOCAL VARS
	369	!
	370	REAL, DIMENSION( kts:kte+1 ) :: SDOWN
	371
	372	REAL, DIMENSION( kts:kte ) :: XLWP, &
	373	XATP, &
	374	XWVP, &
	375	aer_dry1,aer_water1, &
	376	RO
	377	!
	378	REAL, DIMENSION( 4, 5 ) :: ALBTAB, &
	379	ABSTAB
	380
	381	REAL, DIMENSION( 4 ) :: XMUVAL
	382
	383	REAL, INTENT(OUT) :: COSZ !urban
	384	REAL, INTENT(OUT) :: OMG !urban
	385
	386	REAL :: beta
	387
	388	!------------------------------------------------------------------
	389
	390	DATA ALBTAB/0.,0.,0.,0., &
	391	69.,58.,40.,15., &
	392	90.,80.,70.,60., &
	393	94.,90.,82.,78., &
	394	96.,92.,85.,80./
	395
	396	DATA ABSTAB/0.,0.,0.,0., &
	397	0.,2.5,4.,5., &
	398	0.,2.6,7.,10., &
	399	0.,3.3,10.,14., &
	400	0.,3.7,10.,15./
	401
	402	DATA XMUVAL/0.,0.2,0.5,1.0/
	403
	404	REAL :: bext340, absc, alba, alw, csza,dabsa,dsca,dabs
	405	REAL :: bexth2o, dscld, hrang,ff,oldalb,oldabs,oldabc
	406	REAL :: soltop, totabs, tloctm, ugcm, uv,xabs,xabsa,wv
	407	REAL :: wgm, xalb, xi, xsca, xt24,xmu,xabsc,trans0,yj
	408	REAL :: xxlat,ww
	409	INTEGER :: iil,ii,jjl,ju,k,iu
	410
	411	! For slope-dependent radiation
	412
	413	REAL :: diffuse_frac, corr_fac, csza_slp
	414
	415
	416	GSW=0.0
	417	bext340=5.E-6
	418	bexth2o=5.E-6
	419	SOLTOP=SOLCON
	420	XT24=MOD(XTIME+RADFRQ*0.5,1440.)
	421	TLOCTM=GMT+XT24/60.+XLONG/15.
	422	HRANG=15.(TLOCTM-12.)DEGRAD
	423	XXLAT=XLAT*DEGRAD
	424	CSZA=SIN(XXLAT)SIN(DECLIN)+COS(XXLAT)COS(DECLIN)*COS(HRANG)
	425
	426	COSZ = CSZA !urban
	427	OMG = HRANG !urban
	428
	429	! RETURN IF NIGHT
	430	IF(CSZA.LE.1.E-9)GOTO 7
	431	!
	432	DO K=kts, kte
	433
	434	! P in the unit of 10mb
	435	RO(K)=P(K)/(R*T(K))
	436	XWVP(K)=RO(K)QV(K)DZ(K)*1000.
	437	! KG/M**2
	438	XATP(K)=RO(K)*DZ(K)
	439	ENDDO
	440	!
	441	! G/M**2
	442	! REDUCE WEIGHT OF LIQUID AND ICE IN SHORT-WAVE SCHEME
	443	! ADD GRAUPEL EFFECT (ASSUMED SAME AS RAIN)
	444	!
	445	IF (ICLOUD.EQ.0)THEN
	446	DO K=kts, kte
	447	XLWP(K)=0.
	448	ENDDO
	449	ELSE
	450	DO K=kts, kte
	451	XLWP(K)=RO(K)1000.DZ(K)(QC(K)+0.1QI(K)+0.05* &
	452	QR(K)+0.02QS(K)+0.05QG(K))
	453	ENDDO
	454	ENDIF
	455	!
	456	XMU=CSZA
	457	SDOWN(1)=SOLTOP*XMU
	458	! SET WW (G/M**2) LIQUID WATER PATH INTEGRATED DOWN
	459	! SET UV (G/M**2) WATER VAPOR PATH INTEGRATED DOWN
	460	WW=0.
	461	UV=0.
	462	OLDALB=0.
	463	OLDABC=0.
	464	TOTABS=0.
	465	! CONTRIBUTIONS DUE TO CLEAR AIR AND CLOUD
	466	DSCA=0.
	467	DABS=0.
	468	DSCLD=0.
	469	!
	470	! CONTRIBUTION DUE TO AEROSOLS (FOR CHEMISTRY)
	471	DABSA=0.
	472	!
	473	DO 200 K=kts,kte
	474	WW=WW+XLWP(K)
	475	UV=UV+XWVP(K)
	476	! WGM IS WW/COS(THETA) (G/M**2)
	477	! UGCM IS UV/COS(THETA) (G/CM**2)
	478	WGM=WW/XMU
	479	UGCM=UV*0.0001/XMU
	480	!
	481	OLDABS=TOTABS
	482	! WATER VAPOR ABSORPTION AS IN LACIS AND HANSEN (1974)
	483	TOTABS=2.9UGCM/((1.+141.5UGCM)*0.635+5.925UGCM)
	484	! APPROXIMATE RAYLEIGH + AEROSOL SCATTERING
	485	! XSCA=1.E-5*XATP(K)/XMU
	486	! XSCA=(1.E-5XATP(K)+aer_dry1(K)bext340+aer_water1(K)*bexth2o)/XMU
	487	beta=0.4*(1.0-XMU)+0.1
	488	! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT
	489	XSCA=(csscaXATP(K)+betaaer_dry1(K)bext340DZ(K) &
	490	+betaaer_water1(K)bexth2o*DZ(K))/XMU
	491
	492	! LAYER VAPOR ABSORPTION DONE FIRST
	493	XABS=(TOTABS-OLDABS)*(SDOWN(1)-DSCLD-DSCA-DABSA)/SDOWN(K)
	494	!rs AEROSOL ABSORB (would be elemental carbon). So far XABSA = 0.
	495	XABSA=0.
	496	IF(XABS.LT.0.)XABS=0.
	497	!
	498	ALW=ALOG10(WGM+1.)
	499	IF(ALW.GT.3.999)ALW=3.999
	500	!
	501	DO II=1,3
	502	IF(XMU.GT.XMUVAL(II))THEN
	503	IIL=II
	504	IU=II+1
	505	XI=(XMU-XMUVAL(II))/(XMUVAL(II+1)-XMUVAL(II))+FLOAT(IIL)
	506	ENDIF
	507	ENDDO
	508	!
	509	JJL=IFIX(ALW)+1
	510	JU=JJL+1
	511	YJ=ALW+1.
	512	! CLOUD ALBEDO
	513	ALBA=(ALBTAB(IU,JU)(XI-IIL)(YJ-JJL) &
	514	+ALBTAB(IIL,JU)(IU-XI)(YJ-JJL) &
	515	+ALBTAB(IU,JJL)(XI-IIL)(JU-YJ) &
	516	+ALBTAB(IIL,JJL)(IU-XI)(JU-YJ)) &
	517	/((IU-IIL)*(JU-JJL))
	518	! CLOUD ABSORPTION
	519	ABSC=(ABSTAB(IU,JU)(XI-IIL)(YJ-JJL) &
	520	+ABSTAB(IIL,JU)(IU-XI)(YJ-JJL) &
	521	+ABSTAB(IU,JJL)(XI-IIL)(JU-YJ) &
	522	+ABSTAB(IIL,JJL)(IU-XI)(JU-YJ)) &
	523	/((IU-IIL)*(JU-JJL))
	524	! LAYER ALBEDO AND ABSORPTION
	525	XALB=(ALBA-OLDALB)*(SDOWN(1)-DSCA-DABS)/SDOWN(K)
	526	XABSC=(ABSC-OLDABC)*(SDOWN(1)-DSCA-DABS)/SDOWN(K)
	527	IF(XALB.LT.0.)XALB=0.
	528	IF(XABSC.LT.0.)XABSC=0.
	529	DSCLD=DSCLD+(XALB+XABSC)SDOWN(K)0.01
	530	DSCA=DSCA+XSCA*SDOWN(K)
	531	DABS=DABS+XABS*SDOWN(K)
	532	DABSA=DABSA+XABSA*SDOWN(K)
	533	OLDALB=ALBA
	534	OLDABC=ABSC
	535	! LAYER TRANSMISSIVITY
	536	TRANS0=100.-XALB-XABSC-XABS100.-XSCA100.
	537	IF(TRANS0.LT.1.)THEN
	538	FF=99./(XALB+XABSC+XABS100.+XSCA100.)
	539	XALB=XALB*FF
	540	XABSC=XABSC*FF
	541	XABS=XABS*FF
	542	XSCA=XSCA*FF
	543	TRANS0=1.
	544	ENDIF
	545	SDOWN(K+1)=AMAX1(1.E-9,SDOWN(K)TRANS00.01)
	546	TTEN(K)=SDOWN(K)(XABSC+XABS100.+XABSA100.)0.01/( &
	547	RO(K)CPDZ(K))
	548	200 CONTINUE
	549	!
	550	GSW=(1.-ALBEDO)*SDOWN(kte+1)
	551
	552	IF (PRESENT(slope_rad)) THEN
	553	! Slope-dependent solar radiation part
	554
	555	if (slope_rad.eq.1) then
	556
	557	! Parameterize diffuse fraction of global solar radiation as a function of the ratio between TOA radiation and surface global radiation
	558
	559	diffuse_frac = min(1.,1/(max(0.1,2.1-2.8*log(log(SDOWN(kts)/max(SDOWN(kte+1),1.e-3))))))
	560	if ((slope.eq.0).or.(diffuse_frac.eq.1).or.(csza.lt.1.e-2)) then ! no topographic effects when all radiation is diffuse or the sun is too close to the horizon
	561	corr_fac = 1
	562	goto 140
	563	endif
	564
	565	! cosine of zenith angle over sloping topography
	566
	567	csza_slp = ((SIN(XXLAT)COS(HRANG)) &
	568	(-cos(slp_azi)sin(slope))-SIN(HRANG)(sin(slp_azi)*sin(slope))+ &
	569	(COS(XXLAT)COS(HRANG))cos(slope))* &
	570	COS(DECLIN)+(COS(XXLAT)(cos(slp_azi)sin(slope))+ &
	571	SIN(XXLAT)cos(slope))SIN(DECLIN)
	572	IF(csza_slp.LE.1.E-4) csza_slp = 0
	573
	574	! Topographic shading
	575
	576	if (shadow.eq.1) csza_slp = 0
	577
	578	! Correction factor for sloping topography; the diffuse fraction of solar radiation is assumed to be unaffected by the slope
	579	corr_fac = diffuse_frac + (1-diffuse_frac)*csza_slp/csza
	580
	581	140 continue
	582
	583	GSW=(1.-ALBEDO)SDOWN(kte+1)corr_fac
	584
	585	endif
	586	ENDIF
	587
	588	7 CONTINUE
	589	!
	590	END SUBROUTINE SWPARA
	591
	592	!====================================================================
	593	SUBROUTINE swinit(swrad_scat, &
	594	allowed_to_read , &
	595	ids, ide, jds, jde, kds, kde, &
	596	ims, ime, jms, jme, kms, kme, &
	597	its, ite, jts, jte, kts, kte )
	598	!--------------------------------------------------------------------
	599	IMPLICIT NONE
	600	!--------------------------------------------------------------------
	601	LOGICAL , INTENT(IN) :: allowed_to_read
	602	INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
	603	ims, ime, jms, jme, kms, kme, &
	604	its, ite, jts, jte, kts, kte
	605
	606	REAL , INTENT(IN) :: swrad_scat
	607
	608	! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT
	609	cssca = swrad_scat * 1.e-5
	610
	611	END SUBROUTINE swinit
	612
	613	END MODULE module_ra_sw

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

Download in other formats:

Original Format