source: trunk/WRF.COMMON/WRFV3/phys/module_ra_sw.F @ 3431

Last change on this file since 3431 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
Line 
1!WRF:MODEL_LAYER:PHYSICS
2!
3MODULE module_ra_sw
4
5      REAL,PRIVATE,SAVE :: CSSCA
6
7CONTAINS
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
119pi = 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((hx**2+hy**2)**.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.1*QI(K)+0.05* &
452                    QR(K)+0.02*QS(K)+0.05*QG(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.9*UGCM/((1.+141.5*UGCM)**0.635+5.925*UGCM)
484!     APPROXIMATE RAYLEIGH + AEROSOL SCATTERING
485!        XSCA=1.E-5*XATP(K)/XMU
486!          XSCA=(1.E-5*XATP(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=(cssca*XATP(K)+beta*aer_dry1(K)*bext340*DZ(K) &
490              +beta*aer_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-XABS*100.-XSCA*100.
537         IF(TRANS0.LT.1.)THEN
538           FF=99./(XALB+XABSC+XABS*100.+XSCA*100.)
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)*TRANS0*0.01)
546         TTEN(K)=SDOWN(K)*(XABSC+XABS*100.+XABSA*100.)*0.01/( &
547                 RO(K)*CP*DZ(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
613END MODULE module_ra_sw
Note: See TracBrowser for help on using the repository browser.