wrfv2_fire/phys/module_ra_sw.F

   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((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
 613 END MODULE module_ra_sw