<p><b>laura@ucar.edu</b> 2011-01-13 16:29:23 -0700 (Thu, 13 Jan 2011)</p><p>Added Noah Land Surface Model<br>
</p><hr noshade><pre><font color="gray">Added: branches/atmos_physics/src/core_physics/physics_wrf/module_sf_bem.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_sf_bem.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_sf_bem.F 2011-01-13 23:29:23 UTC (rev 685)
@@ -0,0 +1,2345 @@
+MODULE module_sf_bem
+! -----------------------------------------------------------------------
+! Variables and constants used in the BEM module
+! -----------------------------------------------------------------------
+
+ real emins !emissivity of the internal walls
+ parameter (emins=0.9)
+ real albins !albedo of the internal walls
+!! parameter (albins=0.5)
+ parameter (albins=0.3)
+
+ real thickwin !thickness of the window [m]
+ parameter (thickwin=0.006)
+ real cswin !Specific heat of the windows [J/(m3.K)]
+ parameter(cswin= 2.268e+06)
+
+ real temp_rat !power of the A.C. heating/cooling the indoor air [K/s]
+ parameter(temp_rat=0.001)
+
+ real hum_rat !power of the A.C. drying/moistening the indoor air [(Kg/kg)/s]
+ parameter(hum_rat=1.e-06)
+
+
+ CONTAINS
+
+!====6================================================================72
+!====6================================================================72
+
+ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, &
+ nwal,nflo,nrof,ngrd,hswalout,gswal, &
+ hswinout,hsrof,gsrof, &
+ latent,sigma,albwal,albwin,albrof, &
+ emrof,emwal,emwin,rswal,rlwal,rair,cp, &
+ rhoout,tout,humout,press, &
+ rs,rl,dzwal,cswal,kwal,pwin,cop,beta,sw_cond, &
+ timeon,timeoff,targtemp,gaptemp,targhum,gaphum, &
+ perflo,hsesf,hsequip,dzflo, &
+ csflo,kflo,dzgrd,csgrd,kgrd,dzrof,csrof, &
+ krof,tlev,shumlev,twal,twin,tflo,tgrd,trof, &
+ hsout,hlout,consump,hsvent,hlvent)
+
+
+! ---------------------------------------------------------------------
+ implicit none
+
+! ---------------------------------------------------------------------
+! TOP
+! ---------------------
+! ! ----------------- !--->roof (-) : level number
+! ! ! ! ! rem: the windows are given
+! ! !---------------! ! with respect to the
+! ! !---------------! ! vertical walls-->win(2)
+! (n)! !(1) (1)!-!(n)
+! ! !---------------! ! 2D vision of the building
+! WEST ! !-------4-------! ! EAST
+! I ! ! 1 ilev 2! ! II ^
+! ! !-------3--------! ! !
+! ! !---------------! !--->floor 1 !
+! ! ! ! ! !
+! ! ! ! ! !
+! ! ----------------- ! <--------------(n)
+! ------------------------>ground ------------(1)
+! BOTTOM
+! i(6)
+! i
+! +---------v-----+
+! /| /| 3D vision of a room
+! / | 4 / |
+! / | / |
+! / | / |
+! / | / |
+! +---------------+ |
+! | 1 | | 2 |
+! | +---------|-----+
+! dzlev | / | /
+! | / 3 | /
+! | /bw | /
+! | / | /
+! |/ |/
+! +---------------+
+! ^ bl
+! i
+! i
+! (5)
+!-----------------------------------------------------------------------
+
+
+! Input:
+! -----
+
+ real dt !time step [s]
+
+ integer nzcanm !Maximum number of vertical levels in the urban grid
+ integer nlev !number of floors in the building
+ integer nwal !number of levels inside the wall
+ integer nrof !number of levels inside the roof
+ integer nflo !number of levels inside the floor
+ integer ngrd !number of levels inside the ground
+ real dzlev !vertical grid resolution [m]
+ real bl !Building length [m]
+ real bw !Building width [m]
+
+ real albwal !albedo of the walls
+ real albwin !albedo of the windows
+ real albrof !albedo of the roof
+
+ real emwal !emissivity of the walls
+
+ real emrof !emissivity of the roof
+ real emwin !emissivity of the windows
+
+ real pwin !window proportion
+ real, intent(in) :: cop !Coefficient of performance of the A/C systems
+ real, intent(in) :: beta !Thermal efficiency of the heat exchanger
+ integer, intent(in) :: sw_cond ! Air Conditioning switch
+ real, intent(in) :: timeon ! Initial local time of A/C systems
+ real, intent(in) :: timeoff ! Ending local time of A/C systems
+ real, intent(in) :: targtemp ! Target temperature of A/C systems
+ real, intent(in) :: gaptemp ! Comfort range of indoor temperature
+ real, intent(in) :: targhum ! Target humidity of A/C systems
+ real, intent(in) :: gaphum ! Comfort range of specific humidity
+ real, intent(in) :: perflo ! Peak number of occupants per unit floor area
+ real, intent(in) :: hsesf !
+ real, intent(in) :: hsequip(24) !
+
+ real cswal(nwal) !Specific heat of the wall [J/(m3.K)]
+
+ real csflo(nflo) !Specific heat of the floor [J/(m3.K)]
+ real csrof(nrof) !Specific heat of the roof [J/(m3.K)]
+ real csgrd(ngrd) !Specific heat of the ground [J/(m3.K)]
+
+ real kwal(nwal+1) !Thermal conductivity in each layers of the walls (face) [W/(m.K)]
+ real kflo(nflo+1) !Thermal diffusivity in each layers of the floors (face) [W/(m.K)]
+ real krof(nrof+1) !Thermal diffusivity in each layers of the roof (face) [W/(m.K)]
+ real kgrd(ngrd+1) !Thermal diffusivity in each layers of the ground (face) [W/(m.K)]
+
+ real dzwal(nwal) !Layer sizes of walls [m]
+ real dzflo(nflo) !Layer sizes of floors [m]
+ real dzrof(nrof) !Layer sizes of roof [m]
+ real dzgrd(ngrd) !Layer sizes of ground [m]
+
+ real latent !latent heat of evaporation [J/Kg]
+
+
+ real rs !external short wave radiation [W/m2]
+ real rl !external long wave radiation [W/m2]
+ real rswal(4,nzcanm) !short wave radiation reaching the exterior walls [W/m2]
+ real rlwal(4,nzcanm) !long wave radiation reaching the walls [W/m2]
+ real rhoout(nzcanm) !exterior air density [kg/m3]
+ real tout(nzcanm) !external temperature [K]
+ real humout(nzcanm) !absolute humidity [Kgwater/Kgair]
+ real press(nzcanm) !external air pressure [Pa]
+
+ real hswalout(4,nzcanm) !outside walls sensible heat flux [W/m2]
+ real hswinout(4,nzcanm) !outside window sensible heat flux [W/m2]
+ real hsrof !Sensible heat flux at the roof [W/m2]
+
+ real rair !ideal gas constant [J.kg-1.K-1]
+ real sigma !parameter (wall is not black body) [W/m2.K4]
+ real cp !specific heat of air [J/kg.K]
+
+
+!Input-Output
+!------------
+ real tlev(nzcanm) !temperature of the floors [K]
+ real shumlev(nzcanm) !specific humidity of the floor [kg/kg]
+ real twal(4,nwal,nzcanm) !walls temperatures [K]
+ real twin(4,nzcanm) !windows temperatures [K]
+ real tflo(nflo,nzcanm-1) !floor temperatures [K]
+ real tgrd(ngrd) !ground temperature [K]
+ real trof(nrof) !roof temperature [K]
+ real hsout(nzcanm) !sensible heat emitted outside the floor [W]
+ real hlout(nzcanm) !latent heat emitted outside the floor [W]
+ real consump(nzcanm) !Consumption for the a.c. in each floor [W]
+ real hsvent(nzcanm) !sensible heat generated by natural ventilation [W]
+ real hlvent(nzcanm) !latent heat generated by natural ventilation [W]
+ real gsrof !heat flux flowing inside the roof [W/mē]
+ real gswal(4,nzcanm) !heat flux flowing inside the floors [W/mē]
+
+! Local:
+! -----
+ integer swwal !swich for the physical coefficients calculation
+ integer ilev !index for rooms
+ integer iwal !index for walls
+ integer iflo !index for floors
+ integer ivw !index for vertical walls
+ integer igrd !index for ground
+ integer irof !index for roof
+ real hseqocc(nzcanm) !sensible heat generated by equipments and occupants [W]
+ real hleqocc(nzcanm) !latent heat generated by occupants [W]
+ real hscond(nzcanm) !sensible heat generated by wall conduction [W]
+ real hslev(nzcanm) !sensible heat flux generated inside the room [W]
+ real hllev(nzcanm) !latent heat flux generatd inside the room [W]
+ real surwal(6,nzcanm) !Surface of the walls [m2]
+ real surwal1D(6) !wall surfaces of a generic room [m2]
+ real rsint(6) !short wave radiation reaching the indoor walls[W/m2]
+ real rswalins(6,nzcanm) !internal short wave radiation for the building [W/m2]
+ real twin1D(4) !temperature of windows for a particular room [K]
+ real twal_int(6) !temperature of the first internal layers of a room [K]
+ real rlint(6) !internal wall long wave radiation [w/m2]
+ real rlwalins(6,nzcanm) !internal long wave radiation for the building [W/m2]
+ real hrwalout(4,nzcanm) !external radiative flux to the walls [W/m2]
+ real hrwalins(6,nzcanm) !inside radiative flux to the walls [W/m2]
+ real hrwinout(4,nzcanm) !external radiative flux to the window [W/m2]
+ real hrwinins(4,nzcanm) !inside radiative flux to the window [W/m2]
+ real hrrof !external radiative flux to the roof [W/m2]
+ real hs
+ real hsneed(nzcanm) !sensible heat needed by the room [W]
+ real hlneed(nzcanm) !latent heat needed by the room [W]
+ real hswalins(6,nzcanm) !inside walls sensible heat flux [W/m2]
+ real hswalins1D(6)
+ real hswinins(4,nzcanm) !inside window sensible heat flux [W/m2]
+ real hswinins1D(4)
+ real htot(2) !total heat flux at the wall [W/m2]
+ real twal1D(nwal)
+ real tflo1D(nflo)
+ real tgrd1D(ngrd)
+ real trof1D(nrof)
+ real rswal1D(4)
+ real Qb !Overall heat capacity of the indoor air [J/K]
+ real vollev !volume of the room [m3]
+ real rhoint !density of the internal air [Kg/m3]
+ real cpint !specific heat of the internal air [J/kg.K]
+ real humdry !specific humidiy of dry air [kg water/kg dry air]
+ real radflux !Function to compute the total radiation budget
+ real consumpbuild !Energetic consumption for the entire building [KWh/s]
+ real hsoutbuild !Total sensible heat ejected into the atmosphere[W]
+ !by the air conditioning system and per building
+ real nhourday !number of hours from midnight, local time
+!--------------------------------------------
+!Initialization
+!--------------------------------------------
+
+ do ilev=1,nzcanm
+ hseqocc(ilev)=0.
+ hleqocc(ilev)=0.
+ hscond(ilev)=0.
+ hslev(ilev)=0.
+ hllev(ilev)=0.
+ enddo
+
+!Calculation of the surfaces of the building
+!--------------------------------------------
+
+
+ do ivw=1,6
+ do ilev=1,nzcanm
+ surwal(ivw,ilev)=1. !initialisation
+ end do
+ end do
+
+ do ilev=1,nlev
+ do ivw=1,2
+ surwal(ivw,ilev)=dzlev*bw
+ end do
+ do ivw=3,4
+ surwal(ivw,ilev)=dzlev*bl
+ end do
+ do ivw=5,6
+ surwal(ivw,ilev)=bw*bl
+ end do
+ end do
+
+
+! Calculation of the short wave radiations at the internal walls
+! ---------------------------------------------------------------
+
+
+ do ilev=1,nlev
+
+ do ivw=1,4
+ rswal1D(ivw)=rswal(ivw,ilev)
+ end do
+
+ do ivw=1,6
+ surwal1D(ivw)=surwal(ivw,ilev)
+ end do
+
+ call int_rsrad(albwin,albins,pwin,rswal1D,&
+ surwal1D,bw,bl,dzlev,rsint)
+
+ do ivw=1,6
+ rswalins(ivw,ilev)=rsint(ivw)
+ end do
+
+ end do !ilev
+
+
+
+! Calculation of the long wave radiation at the internal walls
+!-------------------------------------------------------------
+
+
+!Intermediate rooms
+
+ if (nlev.gt.2) then
+ do ilev=2,nlev-1
+
+ do ivw=1,4
+ twin1D(ivw)=twin(ivw,ilev)
+ twal_int(ivw)=twal(ivw,1,ilev)
+ end do
+
+ twal_int(5)=tflo(nflo,ilev-1)
+ twal_int(6)=tflo(1,ilev)
+
+ call int_rlrad(emins,emwin,sigma,twal_int,twin1D,&
+ pwin,bw,bl,dzlev,rlint)
+
+
+ do ivw=1,6
+ rlwalins(ivw,ilev)=rlint(ivw)
+ end do
+
+ end do !ilev
+ end if
+
+
+ if (nlev.ne.1) then
+
+!bottom room
+
+ do ivw=1,4
+ twin1D(ivw)=twin(ivw,1)
+ twal_int(ivw)=twal(ivw,1,1)
+ end do
+
+ twal_int(5)=tgrd(ngrd)
+ twal_int(6)=tflo(1,1)
+
+
+ call int_rlrad(emins,emwin,sigma,twal_int,twin1D,&
+ pwin,bw,bl,dzlev,rlint)
+
+ do ivw=1,6
+ rlwalins(ivw,1)=rlint(ivw)
+ end do
+
+!top room
+
+ do ivw=1,4
+ twin1D(ivw)=twin(ivw,nlev)
+ twal_int(ivw)=twal(ivw,1,nlev)
+ end do
+
+ twal_int(5)=tflo(nflo,nlev-1)
+ twal_int(6)=trof(1)
+
+
+ call int_rlrad(emins,emwin,sigma,twal_int,twin1D,&
+ pwin,bw,bl,dzlev,rlint)
+
+ do ivw=1,6
+ rlwalins(ivw,nlev)=rlint(ivw)
+ end do
+
+ else !Top <---> Bottom
+
+ do ivw=1,4
+ twin1D(ivw)=twin(ivw,1)
+ twal_int(ivw)=twal(ivw,1,1)
+ end do
+
+ twal_int(5)=tgrd(ngrd)
+ twal_int(6)=trof(1)
+
+ call int_rlrad(emins,emwin,sigma,twal_int,twin1D, &
+ pwin,bw,bl,dzlev,rlint)
+
+ do ivw=1,6
+ rlwalins(ivw,1)=rlint(ivw)
+ end do
+
+ end if
+
+
+! Calculation of the radiative fluxes
+! -----------------------------------
+
+!External vertical walls and windows
+
+ do ilev=1,nlev
+ do ivw=1,4
+ call radfluxs(radflux,albwal,rswal(ivw,ilev), &
+ emwal,rlwal(ivw,ilev),sigma, &
+ twal(ivw,nwal,ilev))
+
+ hrwalout(ivw,ilev)=radflux
+
+ hrwinout(ivw,ilev)=emwin*rlwal(ivw,ilev)- &
+ emwin*sigma*(twin(ivw,ilev)**4)
+
+
+ end do ! ivw
+ end do ! ilev
+
+!Roof
+
+ call radfluxs(radflux,albrof,rs,emrof,rl,sigma,trof(nrof))
+
+ hrrof=radflux
+
+!Internal walls for intermediate rooms
+
+ if(nlev.gt.2) then
+
+ do ilev=2,nlev-1
+ do ivw=1,4
+
+ call radfluxs(radflux,albins,rswalins(ivw,ilev), &
+ emins,rlwalins(ivw,ilev),sigma, &
+ twal(ivw,1,ilev))
+
+ hrwalins(ivw,ilev)=radflux
+
+ end do !ivw
+
+ call radfluxs(radflux,albins,rswalins(5,ilev), &
+ emins,rlwalins(5,ilev),sigma,&
+ tflo(nflo,ilev-1))
+
+ hrwalins(5,ilev)=radflux
+
+ call radfluxs(radflux,albins,rswalins(6,ilev), &
+ emins,rlwalins(6,ilev),sigma,&
+ tflo(1,ilev))
+ hrwalins(6,ilev)=radflux
+
+ end do !ilev
+
+ end if
+
+
+!Internal walls for the bottom and the top room
+!
+ if (nlev.ne.1) then
+
+!bottom floor
+
+ do ivw=1,4
+
+ call radfluxs(radflux,albins,rswalins(ivw,1), &
+ emins,rlwalins(ivw,1),sigma, &
+ twal(ivw,1,1))
+
+ hrwalins(ivw,1)=radflux
+
+ end do
+
+
+ call radfluxs(radflux,albins,rswalins(5,1),&
+ emins,rlwalins(5,1),sigma,& !bottom
+ tgrd(ngrd))
+
+ hrwalins(5,1)=radflux
+
+
+ call radfluxs(radflux,albins,rswalins(6,1),&
+ emins,rlwalins(6,1),sigma,&
+ tflo(1,1))
+
+ hrwalins(6,1)=radflux
+
+!roof floor
+
+ do ivw=1,4
+
+ call radfluxs(radflux,albins,rswalins(ivw,nlev), &
+ emins,rlwalins(ivw,nlev),sigma,&
+ twal(ivw,1,nlev))
+
+ hrwalins(ivw,nlev)=radflux
+
+ end do !top
+
+
+ call radfluxs(radflux,albins,rswalins(5,nlev), &
+ emins,rlwalins(5,nlev),sigma,&
+ tflo(nflo,nlev-1))
+
+ hrwalins(5,nlev)=radflux
+
+ call radfluxs(radflux,albins,rswalins(6,nlev), &
+ emins,rlwalins(6,nlev),sigma,&
+ trof(1))
+
+ hrwalins(6,nlev)=radflux
+
+ else ! Top <---> Bottom room
+
+ do ivw=1,4
+
+ call radfluxs(radflux,albins,rswalins(ivw,1),&
+ emins,rlwalins(ivw,1),sigma, &
+ twal(ivw,1,1))
+
+ hrwalins(ivw,1)=radflux
+
+ end do
+
+ call radfluxs(radflux,albins,rswalins(5,1),&
+ emins,rlwalins(5,1),sigma, &
+ tgrd(ngrd))
+
+ hrwalins(5,1)=radflux
+
+ call radfluxs(radflux,albins,rswalins(6,nlev), &
+ emins,rlwalins(6,nlev),sigma,&
+ trof(1))
+ hrwalins(6,1)=radflux
+
+ end if
+
+
+!Windows
+
+ do ilev=1,nlev
+ do ivw=1,4
+ hrwinins(ivw,ilev)=emwin*rlwalins(ivw,ilev)- &
+ emwin*sigma*(twin(ivw,ilev)**4)
+ end do
+ end do
+
+
+! Calculation of the sensible heat fluxes
+! ---------------------------------------
+
+!Vertical fluxes for walls
+
+ do ilev=1,nlev
+ do ivw=1,4
+
+ call hsinsflux (2,2,tlev(ilev),twal(ivw,1,ilev),hs)
+
+ hswalins(ivw,ilev)=hs
+
+ end do ! ivw
+ end do ! ilev
+
+
+!Vertical fluxes for windows
+
+ do ilev=1,nlev
+
+ do ivw=1,4
+
+ call hsinsflux (2,1,tlev(ilev),twin(ivw,ilev),hs)
+
+ hswinins(ivw,ilev)=hs
+
+ end do ! ivw
+
+ end do !ilev
+
+!Horizontal fluxes
+
+ if (nlev.gt.2) then
+
+ do ilev=2,nlev-1
+
+ call hsinsflux (1,2,tlev(ilev),tflo(nflo,ilev-1),hs)
+
+ hswalins(5,ilev)=hs
+
+ call hsinsflux (1,2,tlev(ilev),tflo(1,ilev),hs)
+
+ hswalins(6,ilev)=hs
+
+ end do ! ilev
+
+ end if
+
+ if (nlev.ne.1) then
+
+ call hsinsflux (1,2,tlev(1),tgrd(ngrd),hs)
+
+ hswalins(5,1)=hs !Bottom room
+
+ call hsinsflux (1,2,tlev(1),tflo(1,1),hs)
+
+ hswalins(6,1)=hs
+
+ call hsinsflux (1,2,tlev(nlev),tflo(nflo,nlev-1),hs)
+
+ hswalins(5,nlev)=hs !Top room
+
+ call hsinsflux (1,2,tlev(nlev),trof(1),hs)
+
+ hswalins(6,nlev)=hs
+
+ else ! Bottom<--->Top
+
+ call hsinsflux (1,2,tlev(1),tgrd(ngrd),hs)
+
+ hswalins(5,1)=hs
+
+ call hsinsflux (1,2,tlev(nlev),trof(1),hs)
+
+ hswalins(6,nlev)=hs
+
+ end if
+
+
+!Calculation of the temperature for the different surfaces
+! --------------------------------------------------------
+
+! Vertical walls
+
+ swwal=1
+ do ilev=1,nlev
+ do ivw=1,4
+
+ htot(1)=hswalins(ivw,ilev)+hrwalins(ivw,ilev)
+ htot(2)=hswalout(ivw,ilev)+hrwalout(ivw,ilev)
+ gswal(ivw,ilev)=htot(2)
+
+ do iwal=1,nwal
+ twal1D(iwal)=twal(ivw,iwal,ilev)
+ end do
+
+ call wall(swwal,nwal,dt,dzwal,kwal,cswal,htot,twal1D)
+
+ do iwal=1,nwal
+ twal(ivw,iwal,ilev)=twal1D(iwal)
+ end do
+
+ end do ! ivw
+ end do ! ilev
+
+! Windows
+
+ do ilev=1,nlev
+ do ivw=1,4
+
+ htot(1)=hswinins(ivw,ilev)+hrwinins(ivw,ilev)
+ htot(2)=hswinout(ivw,ilev)+hrwinout(ivw,ilev)
+
+ twin(ivw,ilev)=twin(ivw,ilev)+(dt/(cswin*thickwin))* &
+ (htot(1)+htot(2))
+
+ end do ! ivw
+ end do ! ilev
+
+! Horizontal floors
+
+
+ if (nlev.gt.1) then
+ swwal=1
+ do ilev=1,nlev-1
+
+ htot(1)=hrwalins(6,ilev)+hswalins(6,ilev)
+ htot(2)=hrwalins(5,ilev+1)+hswalins(5,ilev+1)
+
+ do iflo=1,nflo
+ tflo1D(iflo)=tflo(iflo,ilev)
+ end do
+
+ call wall(swwal,nflo,dt,dzflo,kflo,csflo,htot,tflo1D)
+
+ do iflo=1,nflo
+ tflo(iflo,ilev)=tflo1D(iflo)
+ end do
+
+ end do ! ilev
+ end if
+
+
+! Ground
+
+ swwal=1
+
+ htot(1)=0. !Diriclet b.c. at the internal boundary
+ htot(2)=hswalins(5,1)+hrwalins(5,1)
+
+ do igrd=1,ngrd
+ tgrd1D(igrd)=tgrd(igrd)
+ end do
+
+ call wall(swwal,ngrd,dt,dzgrd,kgrd,csgrd,htot,tgrd1D)
+
+ do igrd=1,ngrd
+ tgrd(igrd)=tgrd1D(igrd)
+ end do
+
+
+! Roof
+
+ swwal=1
+
+ htot(1)=hswalins(6,nlev)+hrwalins(6,nlev)
+ htot(2)=hsrof+hrrof
+ gsrof=htot(2)
+
+ do irof=1,nrof
+ trof1D(irof)=trof(irof)
+ end do
+
+ call wall(swwal,nrof,dt,dzrof,krof,csrof,htot,trof1D)
+
+ do irof=1,nrof
+ trof(irof)=trof1D(irof)
+ end do
+
+! Calculation of the heat fluxes and of the temperature of the rooms
+! ------------------------------------------------------------------
+
+ do ilev=1,nlev
+
+ !Calculation of the heat generated by equipments and occupants
+
+ call fluxeqocc(nhourday,bw,bl,perflo,hsesf,hsequip,hseqocc(ilev),hleqocc(ilev))
+
+ !Calculation of the heat generated by natural ventilation
+
+ vollev=bw*bl*dzlev
+ humdry=shumlev(ilev)/(1.-shumlev(ilev))
+ rhoint=(press(ilev))/(rair*(1.+0.61*humdry)*tlev(ilev))
+ cpint=cp*(1.+0.84*humdry)
+
+
+ call fluxvent(cpint,rhoint,vollev,tlev(ilev),tout(ilev), &
+ latent,humout(ilev),rhoout(ilev),shumlev(ilev),&
+ beta,hsvent(ilev),hlvent(ilev))
+
+ !Calculation of the heat generated by conduction
+
+ do iwal=1,6
+ hswalins1D(iwal)=hswalins(iwal,ilev)
+ surwal1D(iwal)=surwal(iwal,ilev)
+ end do
+
+ do iwal=1,4
+ hswinins1D(iwal)=hswinins(iwal,ilev)
+ end do
+
+ call fluxcond(hswalins1D,hswinins1D,surwal1D,pwin,&
+ hscond(ilev))
+
+ !Calculation of the heat generated inside the room
+
+ call fluxroo(hseqocc(ilev),hleqocc(ilev),hsvent(ilev), &
+ hlvent(ilev),hscond(ilev),hslev(ilev),hllev(ilev))
+
+
+ !Evolution of the temperature and of the specific humidity
+
+ Qb=rhoint*cpint*vollev
+
+ ! temperature regulation
+
+ call regtemp(sw_cond,nhourday,dt,Qb,hslev(ilev), &
+ tlev(ilev),timeon,timeoff,targtemp,gaptemp,hsneed(ilev))
+
+ ! humidity regulation
+
+ call reghum(sw_cond,nhourday,dt,vollev,rhoint,latent, &
+ hllev(ilev),shumlev(ilev),timeon,timeoff,&
+ targhum,gaphum,hlneed(ilev))
+!
+!performance of the air conditioning system for the test
+!
+
+ call air_cond(hsneed(ilev),hlneed(ilev),dt, &
+ hsout(ilev),hlout(ilev),consump(ilev), cop)
+
+ tlev(ilev)=tlev(ilev)+(dt/Qb)*(hslev(ilev)-hsneed(ilev))
+
+ shumlev(ilev)=shumlev(ilev)+(dt/(vollev*rhoint*latent))* &
+ (hllev(ilev)-hlneed(ilev))
+
+ end do !ilev
+
+ call consump_total(nzcanm,nlev,consumpbuild,hsoutbuild, &
+ hsout,consump)
+
+ return
+ end subroutine BEM
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp)
+
+!______________________________________________________________________
+
+!The aim of this subroutine is to solve the 1D heat fiffusion equation
+!for roof, walls and streets:
+!
+! dT/dt=d/dz[K*dT/dz] where:
+!
+! -T is the surface temperature(wall, street, roof)
+! -Kz is the heat diffusivity inside the material.
+!
+!The resolution is done implicitly with a FV discretisation along the
+!different layers of the material:
+
+! ____________________________
+! n *
+! *
+! *
+! ____________________________
+! i+2
+! I+1
+! ____________________________
+! i+1
+! I ==> [T(I,n+1)-T(I,n)]/DT=
+! ____________________________ [F(i+1)-F(i)]/DZI
+! i
+! I-1 ==> A*T(n+1)=B where:
+! ____________________________
+! i-1 * * A is a TRIDIAGONAL matrix.
+! * * B=T(n)+S takes into account the sources.
+! *
+! 1 ____________________________
+
+!________________________________________________________________
+
+ implicit none
+
+!Input:
+!-----
+ integer nz !Number of layers inside the material
+ real dt !Time step
+ real dz(nz) !Layer sizes [m]
+ real cs(nz) !Specific heat of the material [J/(m3.K)]
+ real k(nz+1) !Thermal conductivity in each layers (face) [W/(m.K)]
+ real flux(2) !Internal and external flux terms.
+
+!Input-Output:
+!-------------
+
+ integer swwall !swich for the physical coefficients calculation
+ real temp(nz) !Temperature at each layer
+
+!Local:
+!-----
+
+ real a(-1:1,nz) ! a(-1,*) lower diagonal A(i,i-1)
+ ! a(0,*) principal diagonal A(i,i)
+ ! a(1,*) upper diagonal A(i,i+1).
+
+ real b(nz) !Coefficients of the second term.
+ real k1(20)
+ real k2(20)
+ real kc(20)
+ save k1,k2,kc
+ integer iz
+
+!________________________________________________________________
+!
+!Calculation of the coefficients
+
+ if (swwall.eq.1) then
+
+ if (nz.gt.20) then
+ write(*,*) 'number of layers in the walls/roofs too big ',nz
+ write(*,*) 'please decrease under of',20
+ stop
+ endif
+
+ call wall_coeff(nz,dt,dz,cs,k,k1,k2,kc)
+ swwall=0
+
+ end if
+
+!Computation of the first value (iz=1) of A and B:
+
+ a(-1,1)=0.
+ a(0,1)=1+k2(1)
+ a(1,1)=-k2(1)
+
+ b(1)=temp(1)+flux(1)*kc(1)
+
+!!
+!!We can fixed the internal temperature
+!!
+!! a(-1,1)=0.
+!! a(0,1)=1
+!! a(1,1)=0.
+!!
+!! b(1)=temp(1)
+!!
+!Computation of the internal values (iz=2,...,n-1) of A and B:
+
+ do iz=2,nz-1
+ a(-1,iz)=-k1(iz)
+ a(0,iz)=1+k1(iz)+k2(iz)
+ a(1,iz)=-k2(iz)
+ b(iz)=temp(iz)
+ end do
+
+!Computation of the external value (iz=n) of A and B:
+
+ a(-1,nz)=-k1(nz)
+ a(0,nz)=1+k1(nz)
+ a(1,nz)=0.
+
+ b(nz)=temp(nz)+flux(2)*kc(nz)
+
+!Resolution of the system A*T(n+1)=B
+
+ call tridia(nz,a,b,temp)
+
+ return
+ end subroutine wall
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine wall_coeff(nz,dt,dz,cs,k,k1,k2,kc)
+
+ implicit none
+
+!---------------------------------------------------------------------
+!Input
+!-----
+ integer nz !Number of layers inside the material
+ real dt !Time step
+ real dz(nz) !Layer sizes [m]
+ real cs(nz) !Specific heat of the material [J/(m3.K)]
+ real k(nz+1) !Thermal diffusivity in each layers (face) [W/(m.K)]
+
+
+!Input-Output
+!------------
+
+ real flux(2) !Internal and external flux terms.
+
+
+!Output
+!------
+ real k1(20)
+ real k2(20)
+ real kc(20)
+
+!Local
+!-----
+ integer iz
+ real kf(nz)
+
+!------------------------------------------------------------------
+
+ do iz=2,nz
+ kc(iz)=dt/(dz(iz)*cs(iz))
+ kf(iz)=2*k(iz)/(dz(iz)+dz(iz-1))
+ end do
+
+ kc(1)=dt/(dz(1)*cs(1))
+ kf(1)=2*k(1)/(dz(1))
+
+ do iz=1,nz
+ k1(iz)=kc(iz)*kf(iz)
+ end do
+
+ do iz=1,nz-1
+ k2(iz)=kc(iz)*kf(iz+1)*cs(iz)/cs(iz+1)
+ end do
+
+ return
+ end subroutine wall_coeff
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+ subroutine hsinsflux(swsurf,swwin,tin,tw,hsins)
+
+ implicit none
+
+! --------------------------------------------------------------------
+! This routine computes the internal sensible heat flux.
+! The swsurf, makes rhe difference between a vertical and a
+! horizontal surface.
+! The values of the heat conduction coefficients hc are obtained from the book
+! "Energy Simulation in Building Design". J.A. Clarke.
+! Adam Hilger, Bristol, 362 pp.
+! --------------------------------------------------------------------
+!Input
+!----
+ integer swsurf !swich for the type of surface (horizontal/vertical)
+ integer swwin !swich for the type of surface (window/wall)
+ real tin !Inside temperature [K]
+ real tw !Internal wall temperature [K]
+
+
+!Output
+!------
+ real hsins !internal sensible heat flux [W/m2]
+!Local
+!-----
+ real hc !heat conduction coefficient [W/°C.m2]
+!--------------------------------------------------------------------
+
+ if (swsurf.eq.2) then !vertical surface
+ if (swwin.eq.1) then
+ hc=5.678*0.99 !window surface (smooth surface)
+ else
+ hc=5.678*1.09 !wall surface (rough surface)
+ endif
+ hsins=hc*(tin-tw)
+ endif
+
+ if (swsurf.eq.1) then !horizontal surface
+ if (swwin.eq.1) then
+ hc=5.678*0.99 !window surface (smooth surface)
+ else
+ hc=5.678*1.09 !wall surface (rough surface)
+ endif
+ hsins=hc*(tin-tw)
+ endif
+
+ return
+ end subroutine hsinsflux
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine int_rsrad(albwin,albwal,pwin,rswal,&
+ surwal,bw,bl,zw,rsint)
+
+! ------------------------------------------------------------------
+ implicit none
+! ------------------------------------------------------------------
+
+!Input
+!-----
+ real albwin !albedo of the windows
+ real albwal !albedo of the internal wall
+ real rswal(4) !incoming short wave radiation [W/m2]
+ real surwal(6) !surface of the indoor walls [m2]
+ real bw,bl !width of the walls [m]
+ real zw !height of the wall [m]
+ real pwin !window proportion
+
+!Output
+!------
+ real rsint(6) !internal walls short wave radiation [W/m2]
+
+!Local
+!-----
+ real transmit !transmittance of the direct/diffused radiation
+ real rstr !solar radiation transmitted through the windows
+ real surtotwal !total indoor surface of the walls in the room
+ integer iw
+ real b(6) !second member for the system
+ real a(6,6) !matrix for the system
+
+!-------------------------------------------------------------------
+
+
+! Calculation of the solar radiation transmitted through windows
+
+ rstr = 0.
+ do iw=1,4
+ transmit=1.-albwin
+ rstr = rstr+(surwal(iw)*pwin)*(transmit*rswal(iw))
+ enddo
+
+!We suppose that the radiation is spread isotropically within the
+!room when it passes through the windows, so the flux [W/mē] in every
+!wall is:
+
+ surtotwal=0.
+ do iw=1,6
+ surtotwal=surtotwal+surwal(iw)
+ enddo
+
+ rstr=rstr/surtotwal
+
+!Computation of the short wave radiation reaching the internal walls
+
+ call algebra_short(rstr,albwal,albwin,bw,bl,zw,pwin,a,b)
+
+ call gaussjbem(a,6,b,6)
+
+ do iw=1,6
+ rsint(iw)=b(iw)
+ enddo
+
+ return
+ end subroutine int_rsrad
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine int_rlrad(emwal,emwin,sigma,twal_int,twin,&
+ pwin,bw,bl,zw,rlint)
+
+! ------------------------------------------------------------------
+ implicit none
+! ------------------------------------------------------------------
+
+!Input
+!-----
+
+ real emwal !emissivity of the internal walls
+ real emwin !emissivity of the window
+ real sigma !Stefan-Boltzmann constant [W/m2.K4]
+ real twal_int(6)!temperature of the first internal layers of a room [K]
+ real twin(4) !temperature of the windows [K]
+ real bw !width of the wall
+ real bl !length of the wall
+ real zw !height of the wall
+ real pwin !window proportion
+
+!Output
+!------
+
+ real rlint(6) !internal walls long wave radiation [W/m2]
+
+!Local
+!------
+
+ real b(6) !second member vector for the system
+ real a(6,6) !matrix for the system
+ integer iw
+!----------------------------------------------------------------
+
+!Compute the long wave radiation reachs the internal walls
+
+ call algebra_long(emwal,emwin,sigma,twal_int,twin,pwin,&
+ bw,bl,zw,a,b)
+
+ call gaussjbem(a,6,b,6)
+
+ do iw=1,6
+ rlint(iw)=b(iw)
+ enddo
+
+ return
+ end subroutine int_rlrad
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine algebra_short(rstr,albwal,albwin,aw,bw,zw,pwin,a,b)
+
+!--------------------------------------------------------------------
+!This routine calculates the algebraic system that will be solved for
+!the computation of the total shortwave radiation that reachs every
+!indoor wall in a floor.
+!Write the matrix system ax=b to solve
+!
+! -Rs(1)+a(1,2)Rs(2)+.................+a(1,6)Rs(6)=-Rs=b(1)
+!a(2,1)Rs(1)- Rs(2)+.................+a(2,6)Rs(6)=-Rs=b(2)
+!a(3,1)Rs(1)+a(3,2)Rs(3)-Rs(3)+...........+a(3,6)Rs(6)=-Rs=b(3)
+!a(4,1)Rs(1)+.................-Rs(4)+.....+a(4,6)Rs(6)=-Rs=b(4)
+!a(5,1)Rs(1)+.......................-Rs(5)+a(5,6)Rs(6)=-Rs=b(5)
+!a(6,1)Rs(1)+....................................-R(6)=-Rs=b(6)
+!
+!This version suppose the albedo of the indoor walls is the same.
+!--------------------------------------------------------------------
+ implicit none
+!--------------------------------------------------------------------
+
+!Input
+!-----
+ real rstr !solar radiation transmitted through the windows
+ real albwal !albedo of the internal walls
+ real albwin !albedo of the windows.
+ real bw !length of the wall
+ real aw !width of the wall
+ real zw !height of the wall
+ real fprl_int !view factor
+ real fnrm_int !view factor
+ real pwin !window proportion
+!Output
+!------
+ real a(6,6) !Matrix for the system
+ real b(6) !Second member for the system
+!Local
+!-----
+ integer iw,jw
+ real albm !averaged albedo
+!----------------------------------------------------------------
+
+!Initialise the variables
+
+ do iw=1,6
+ b(iw)= 0.
+ do jw=1,6
+ a(iw,jw)= 0.
+ enddo
+ enddo
+
+!Calculation of the second member b
+
+ do iw=1,6
+ b(iw)=-rstr
+ end do
+
+!Calculation of the averaged albedo
+
+ albm=pwin*albwin+(1-pwin)*albwal
+
+!Calculation of the matrix a
+
+ a(1,1)=-1.
+
+ call fprl_ints(fprl_int,aw/bw,zw/bw)
+
+ a(1,2)=albm*fprl_int
+
+ call fnrm_ints(fnrm_int,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+
+ a(1,3)=albm*(bw/aw)*fnrm_int
+
+ a(1,4)=a(1,3)
+
+ call fnrm_ints(fnrm_int,zw/aw,bw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ a(1,5)=albwal*(bw/zw)*fnrm_int
+
+ a(1,6)=a(1,5)
+
+
+ a(2,1)=a(1,2)
+ a(2,2)=-1.
+ a(2,3)=a(1,3)
+ a(2,4)=a(1,4)
+ a(2,5)=a(1,5)
+ a(2,6)=a(1,6)
+
+
+ call fnrm_ints(fnrm_int,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+
+ a(3,1)=albm*(aw/bw)*fnrm_int
+ a(3,2)=a(3,1)
+ a(3,3)=-1.
+
+ call fprl_ints(fprl_int,zw/aw,bw/aw)
+
+ a(3,4)=albm*fprl_int
+
+ call fnrm_ints(fnrm_int,zw/bw,aw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+ a(3,5)=albwal*(aw/zw)*fnrm_int
+ a(3,6)=a(3,5)
+
+
+ a(4,1)=a(3,1)
+ a(4,2)=a(3,2)
+ a(4,3)=a(3,4)
+ a(4,4)=-1.
+ a(4,5)=a(3,5)
+ a(4,6)=a(3,6)
+
+ call fnrm_ints(fnrm_int,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ a(5,1)=albm*(zw/bw)*fnrm_int
+
+ a(5,2)=a(5,1)
+
+ call fnrm_ints(fnrm_int,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+ a(5,3)=albm*(zw/aw)*fnrm_int
+
+ a(5,4)=a(5,3)
+ a(5,5)=-1.
+
+ call fprl_ints(fprl_int,aw/zw,bw/zw)
+
+ a(5,6)=albwal*fprl_int
+
+
+ a(6,1)=a(5,1)
+ a(6,2)=a(5,2)
+ a(6,3)=a(5,3)
+ a(6,4)=a(5,4)
+ a(6,5)=a(5,6)
+ a(6,6)=-1.
+
+ return
+ end subroutine algebra_short
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine algebra_long(emwal,emwin,sigma,twalint,twinint,&
+ pwin,aw,bw,zw,a,b)
+
+!--------------------------------------------------------------------
+!This routine computes the algebraic system that will be solved to
+!compute the longwave radiation that reachs the indoor
+!walls in a floor.
+!Write the matrix system ax=b to solve
+!
+!a(1,1)Rl(1)+.............................+Rl(6)=b(1)
+!a(2,1)Rl(1)+.................+Rl(5)+a(2,6)Rl(6)=b(2)
+!a(3,1)Rl(1)+.....+Rl(3)+...........+a(3,6)Rl(6)=b(3)
+!a(4,1)Rl(1)+...........+Rl(4)+.....+a(4,6)Rl(6)=b(4)
+! Rl(1)+.......................+a(5,6)Rl(6)=b(5)
+!a(6,1)Rl(1)+Rl(2)+.................+a(6,6)Rl(6)=b(6)
+!
+!--------------------------------------------------------------------
+ implicit none
+
+!--------------------------------------------------------------------
+
+!Input
+!-----
+
+ real pwin !window proportion
+ real emwal !emissivity of the internal walls
+ real emwin !emissivity of the window
+ real sigma !Stefan-Boltzmann constant [W/m2.K4]
+ real twalint(6) !temperature of the first internal layers of a room [K]
+ real twinint(4) !temperature of the windows [K]
+ real aw !width of the wall
+ real bw !length of the wall
+ real zw !height of the wall
+ real fprl_int !view factor
+ real fnrm_int !view factor
+ real fnrm_intx !view factor
+ real fnrm_inty !view factor
+
+!Output
+!------
+ real b(6) !second member vector for the system
+ real a(6,6) !matrix for the system
+!Local
+!-----
+ integer iw,jw
+ real b_wall(6)
+ real b_wind(6)
+ real emwal_av !averadge emissivity of the wall
+ real emwin_av !averadge emissivity of the window
+ real em_av !averadge emissivity
+ real twal_int(6) !twalint
+ real twin(4) !twinint
+!------------------------------------------------------------------
+
+!Initialise the variables
+!-------------------------
+
+ do iw=1,6
+ b(iw)= 0.
+ b_wall(iw)=0.
+ b_wind(iw)=0.
+ do jw=1,6
+ a(iw,jw)= 0.
+ enddo
+ enddo
+
+ do iw=1,6
+ twal_int(iw)=twalint(iw)
+ enddo
+
+ do iw=1,4
+ twin(iw)=twinint(iw)
+ enddo
+
+!Calculation of the averadge emissivities
+!-----------------------------------------
+
+ emwal_av=(1-pwin)*emwal
+ emwin_av=pwin*emwin
+ em_av=emwal_av+emwin_av
+
+!Calculation of the second term for the walls
+!-------------------------------------------
+
+ call fprl_ints(fprl_int,aw/zw,bw/zw)
+ call fnrm_ints(fnrm_intx,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+ call fnrm_ints(fnrm_inty,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ b_wall(1)=(emwal*sigma*(twal_int(5)**4)* &
+ fprl_int)+ &
+ (sigma*(emwal_av*(twal_int(3)**4)+ &
+ emwal_av*(twal_int(4)**4))* &
+ (zw/aw)*fnrm_intx)+ &
+ (sigma*(emwal_av*(twal_int(1)**4)+ &
+ emwal_av*(twal_int(2)**4))* &
+ (zw/bw)*fnrm_inty)
+
+ call fprl_ints(fprl_int,aw/zw,bw/zw)
+ call fnrm_ints(fnrm_intx,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+ call fnrm_ints(fnrm_inty,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ b_wall(2)=(emwal*sigma*(twal_int(6)**4)* &
+ fprl_int)+ &
+ (sigma*(emwal_av*(twal_int(3)**4)+ &
+ emwal_av*(twal_int(4)**4))* &
+ (zw/aw)*fnrm_intx)+ &
+ (sigma*(emwal_av*(twal_int(1)**4)+ &
+ emwal_av*(twal_int(2)**4))* &
+ (zw/bw)*fnrm_inty)
+
+ call fprl_ints(fprl_int,zw/aw,bw/aw)
+ call fnrm_ints(fnrm_intx,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+ call fnrm_ints(fnrm_inty,zw/bw,aw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+ b_wall(3)=(emwal_av*sigma*(twal_int(4)**4)* &
+ fprl_int)+ &
+ (sigma*(emwal_av*(twal_int(2)**4)+ &
+ emwal_av*(twal_int(1)**4))* &
+ (aw/bw)*fnrm_intx)+ &
+ (sigma*(emwal*(twal_int(5)**4)+ &
+ emwal*(twal_int(6)**4))* &
+ (aw/zw)*fnrm_inty)
+
+ call fprl_ints(fprl_int,zw/aw,bw/aw)
+ call fnrm_ints(fnrm_intx,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+ call fnrm_ints(fnrm_inty,zw/bw,aw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+ b_wall(4)=(emwal_av*sigma*(twal_int(3)**4)* &
+ fprl_int)+ &
+ (sigma*(emwal_av*(twal_int(2)**4)+ &
+ emwal_av*(twal_int(1)**4))* &
+ (aw/bw)*fnrm_intx)+ &
+ (sigma*(emwal*(twal_int(5)**4)+ &
+ emwal*(twal_int(6)**4))* &
+ (aw/zw)*fnrm_inty)
+
+ call fprl_ints(fprl_int,aw/bw,zw/bw)
+ call fnrm_ints(fnrm_intx,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+ call fnrm_ints(fnrm_inty,zw/aw,bw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ b_wall(5)=(emwal_av*sigma*(twal_int(2)**4)* &
+ fprl_int)+ &
+ (sigma*(emwal_av*(twal_int(3)**4)+ &
+ emwal_av*(twal_int(4)**4))* &
+ (bw/aw)*fnrm_intx)+ &
+ (sigma*(emwal*(twal_int(5)**4)+ &
+ emwal*(twal_int(6)**4))* &
+ (bw/zw)*fnrm_inty)
+
+ call fprl_ints(fprl_int,aw/bw,zw/bw)
+ call fnrm_ints(fnrm_intx,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+ call fnrm_ints(fnrm_inty,zw/aw,bw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ b_wall(6)=(emwal_av*sigma*(twal_int(1)**4)* &
+ fprl_int)+ &
+ (sigma*(emwal_av*(twal_int(3)**4)+ &
+ emwal_av*(twal_int(4)**4))* &
+ (bw/aw)*fnrm_intx)+ &
+ (sigma*(emwal*(twal_int(5)**4)+ &
+ emwal*(twal_int(6)**4))* &
+ (bw/zw)*fnrm_inty)
+
+!Calculation of the second term for the windows
+!---------------------------------------------
+ call fnrm_ints(fnrm_intx,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+ call fnrm_ints(fnrm_inty,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ b_wind(1)=(sigma*(emwin_av*(twin(3)**4)+ &
+ emwin_av*(twin(4)**4))* &
+ (zw/aw)*fnrm_intx)+ &
+ (sigma*(emwin_av*(twin(1)**4)+ &
+ emwin_av*(twin(2)**4))* &
+ (zw/bw)*fnrm_inty)
+
+ call fnrm_ints(fnrm_intx,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+ call fnrm_ints(fnrm_inty,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ b_wind(2)=(sigma*(emwin_av*(twin(3)**4)+ &
+ emwin_av*(twin(4)**4))* &
+ (zw/aw)*fnrm_intx)+ &
+ (sigma*(emwin_av*(twin(1)**4)+ &
+ emwin_av*(twin(2)**4))* &
+ (zw/bw)*fnrm_inty)
+
+ call fprl_ints(fprl_int,zw/aw,bw/aw)
+ call fnrm_ints(fnrm_int,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+
+ b_wind(3)=emwin_av*sigma*(twin(4)**4)* &
+ fprl_int+(sigma*(emwin_av* &
+ (twin(2)**4)+emwin_av*(twin(1)**4))* &
+ (aw/bw)*fnrm_int)
+
+ call fprl_ints(fprl_int,zw/aw,bw/aw)
+ call fnrm_ints(fnrm_int,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+
+ b_wind(4)=emwin_av*sigma*(twin(3)**4)* &
+ fprl_int+(sigma*(emwin_av* &
+ (twin(2)**4)+emwin_av*(twin(1)**4))* &
+ (aw/bw)*fnrm_int)
+
+ call fprl_ints(fprl_int,aw/bw,zw/bw)
+ call fnrm_ints(fnrm_int,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+
+ b_wind(5)=emwin_av*sigma*(twin(2)**4)* &
+ fprl_int+(sigma*(emwin_av* &
+ (twin(3)**4)+emwin_av*(twin(4)**4))* &
+ (bw/aw)*fnrm_int)
+
+ call fprl_ints(fprl_int,aw/bw,zw/bw)
+ call fnrm_ints(fnrm_int,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+
+ b_wind(6)=emwin_av*sigma*(twin(1)**4)* &
+ fprl_int+(sigma*(emwin_av* &
+ (twin(3)**4)+emwin_av*(twin(4)**4))* &
+ (bw/aw)*fnrm_int)
+
+!Calculation of the total b term
+!-------------------------------
+
+ do iw=1,6
+ b(iw)=b_wall(iw)+b_wind(iw)
+ end do
+
+
+!Calculation of the matrix of the system
+!----------------------------------------
+
+ call fnrm_ints(fnrm_int,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ a(1,1)=(em_av-1.)*(zw/bw)*fnrm_int
+
+ a(1,2)=a(1,1)
+
+ call fnrm_ints(fnrm_int,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+ a(1,3)=(em_av-1.)*(zw/aw)*fnrm_int
+
+ a(1,4)=a(1,3)
+
+ call fprl_ints(fprl_int,aw/zw,bw/zw)
+
+ a(1,5)=(emwal-1.)*fprl_int
+ a(1,6)=1.
+
+ a(2,1)=a(1,1)
+ a(2,2)=a(1,2)
+ a(2,3)=a(1,3)
+ a(2,4)=a(1,4)
+ a(2,5)=1.
+ a(2,6)=a(1,5)
+
+ call fnrm_ints(fnrm_int,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+
+ a(3,1)=(em_av-1.)*(aw/bw)*fnrm_int
+
+ a(3,2)=a(3,1)
+ a(3,3)=1.
+
+ call fprl_ints(fprl_int,zw/aw,bw/aw)
+
+ a(3,4)=(em_av-1.)*fprl_int
+
+ call fnrm_ints(fnrm_int,zw/bw,aw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+ a(3,5)=(emwal-1.)*(aw/zw)*fnrm_int
+
+ a(3,6)=a(3,5)
+
+ a(4,1)=a(3,1)
+ a(4,2)=a(3,2)
+ a(4,3)=a(3,4)
+ a(4,4)=1.
+ a(4,5)=a(3,5)
+ a(4,6)=a(3,6)
+
+ a(5,1)=1.
+
+ call fprl_ints(fprl_int,aw/bw,zw/bw)
+
+ a(5,2)=(em_av-1.)*fprl_int
+
+ call fnrm_ints(fnrm_int,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+
+ a(5,3)=(em_av-1.)*(bw/aw)*fnrm_int
+
+ a(5,4)=a(5,3)
+
+ call fnrm_ints(fnrm_int,zw/aw,bw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+ a(5,5)=(emwal-1.)*(bw/zw)*fnrm_int
+
+ a(5,6)=a(5,5)
+
+ a(6,1)=a(5,2)
+ a(6,2)=1.
+ a(6,3)=a(5,3)
+ a(6,4)=a(5,4)
+ a(6,5)=a(5,5)
+ a(6,6)=a(6,5)
+
+ return
+ end subroutine algebra_long
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+
+ subroutine fluxroo(hseqocc,hleqocc,hsvent,hlvent, &
+ hscond,hslev,hllev)
+
+!-----------------------------------------------------------------------
+!This routine calculates the heat flux generated inside the room
+!and the heat ejected to the atmosphere.
+!----------------------------------------------------------------------
+
+ implicit none
+
+!-----------------------------------------------------------------------
+
+!Input
+!-----
+ real hseqocc !sensible heat generated by equipments and occupants [W]
+ real hleqocc !latent heat generated by occupants [W]
+ real hsvent !sensible heat generated by natural ventilation [W]
+ real hlvent !latent heat generated by natural ventilation [W]
+ real hscond !sensible heat generated by wall conduction
+
+!Output
+!------
+ real hslev !sensible heat flux generated inside the room [W]
+ real hllev !latent heat flux generatd inside the room
+
+
+!Calculation of the total sensible heat generated inside the room
+
+ hslev=hseqocc+hsvent+hscond
+
+!Calculation of the total latent heat generated inside the room
+
+ hllev=hleqocc+hlvent
+
+ return
+ end subroutine fluxroo
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine phirat(nhourday,rocc)
+
+!----------------------------------------------------------------------
+!This routine calculates the occupation ratio of a floor
+!By now we suppose a constant value
+!----------------------------------------------------------------------
+
+ implicit none
+
+!Input
+!-----
+
+ real nhourday ! number of hours from midnight (local time)
+
+!Output
+!------
+ real rocc !value between 0 and 1
+
+!!TEST
+ rocc=1.
+
+ return
+ end subroutine phirat
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine phiequ(nhourday,hsesf,hsequip,hsequ)
+
+!----------------------------------------------------------------------
+!This routine calculates the sensible heat gain from equipments
+!----------------------------------------------------------------------
+ implicit none
+!Input
+!-----
+
+ real nhourday ! number of hours from midnight, Local time
+ real, intent(in) :: hsesf
+ real, intent(in), dimension(24) :: hsequip
+
+!Output
+!------
+ real hsequ !sensible heat gain from equipment [WmŊ2]
+
+!---------------------------------------------------------------------
+
+ hsequ = hsequip(int(nhourday)+1) * hsesf
+
+ end subroutine phiequ
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine fluxeqocc(nhourday,bw,bl,perflo,hsesf,hsequip,hseqocc,hleqocc)
+
+ implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the sensible and the latent heat flux
+!generated by equipments and occupants
+!---------------------------------------------------------------------
+
+!Input
+!-----
+ real bw !Room width [m]
+ real bl !Room lengzh [m]
+ real nhourday !number of hours from the beginning of the day
+ real, intent(in) :: perflo ! Peak number of occupants per unit floor area
+ real, intent(in) :: hsesf
+ real, intent(in), dimension(24) :: hsequip
+
+!Output
+!------
+ real hseqocc !sensible heat generated by equipments and occupants [W]
+ real hleqocc !latent heat generated by occupants [W]
+!Local
+!-----
+ real Af !Air conditioned floor area [m2]
+ real rocc !Occupation ratio of the floor [0,1]
+ real hsequ !Heat generated from equipments
+
+ real hsocc !Sensible heat generated by a person [W/Person]
+ !Source Boundary Layer Climates,page 195 (book)
+ parameter (hsocc=160.)
+
+ real hlocc !Latent heat generated by a person [W/Person]
+ !Source Boundary Layer Climates,page 225 (book)
+ parameter (hlocc=1.96e6/86400.)
+
+!------------------------------------------------------------------
+! Sensible heat flux
+! ------------------
+
+ Af=bw*bl
+
+ call phirat(nhourday,rocc)
+
+ call phiequ(nhourday,hsesf,hsequip,hsequ)
+
+ hseqocc=Af*rocc*perflo*hsocc+Af*hsequ
+
+!
+! Latent heat
+! -----------
+!
+
+ hleqocc=Af*rocc*perflo*hlocc
+
+ return
+ end subroutine fluxeqocc
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine fluxvent(cpint,rhoint,vollev,tlev,tout,latent,&
+ humout,rhoout,humlev,beta,hsvent,hlvent)
+
+ implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the sensible and the latent heat flux
+!generated by natural ventilation
+!---------------------------------------------------------------------
+
+!Input
+!-----
+ real cpint !specific heat of the indoor air [J/kg.K]
+ real rhoint !density of the indoor air [Kg/m3]
+ real vollev !volume of the room [m3]
+ real tlev !Room temperature [K]
+ real tout !outside air temperature [K]
+ real latent !latent heat of evaporation [J/Kg]
+ real humout !outside absolute humidity [Kgwater/Kgair]
+ real rhoout !air density [kg/m3]
+ real humlev !Specific humidity of the indoor air [Kgwater/Kgair]
+ real, intent(in) :: beta!Thermal efficiency of the heat exchanger
+
+!Output
+!------
+ real hsvent !sensible heat generated by natural ventilation [W]
+ real hlvent !latent heat generated by natural ventilation [W]
+
+!Local
+!-----
+
+!----------------------------------------------------------------------
+
+! Sensible heat flux
+! ------------------
+
+ hsvent=(1.-beta)*cpint*rhoint*(vollev/3600.)* &
+ (tout-tlev)
+
+! Latent heat flux
+! ----------------
+
+ hlvent=(1.-beta)*latent*rhoint*(vollev/3600.)* &
+ (humout-humlev)
+
+
+ return
+ end subroutine fluxvent
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine fluxcond(hswalins,hswinins,surwal,pwin,hscond)
+
+ implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the sensible heat flux generated by
+!wall conduction.
+!---------------------------------------------------------------------
+
+!Input
+!-----
+ real hswalins(6) !sensible heat at the internal layers of the wall [W/m2]
+ real hswinins(4) !internal window sensible heat flux [W/m2]
+ real surwal(6) !surfaces of the room walls [m2]
+ real pwin !window proportion
+
+
+!Output
+!------
+
+ real hscond !sensible heat generated by wall conduction [W]
+
+!Local
+!-----
+
+ integer ivw
+
+!----------------------------------------------------------------------
+
+ hscond=0.
+
+ do ivw=1,4
+ hscond=hscond+surwal(ivw)*(1-pwin)*hswalins(ivw)+ &
+ surwal(ivw)*pwin*hswinins(ivw)
+ end do
+
+ do ivw=5,6
+ hscond=hscond+surwal(ivw)*hswalins(ivw)
+ end do
+!
+!Finally we must change the sign in hscond to be proportional
+!to the difference (Twall-Tindoor).
+!
+ hscond=(-1)*hscond
+
+ return
+ end subroutine fluxcond
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine regtemp(swcond,nhourday,dt,Qb,hsroo, &
+ tlev,timeon,timeoff,targtemp,gaptemp,hsneed)
+
+ implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the sensible heat fluxes,
+!after anthropogenic regulation (air conditioning)
+!---------------------------------------------------------------------
+
+!Input:
+!-----.
+ integer swcond !swich air conditioning
+ real nhourday !number of hours from the beginning of the day real
+ real dt !time step [s]
+ real Qb !overall heat capacity of the indoor air [J/K]
+ real hsroo !sensible heat flux generated inside the room [W]
+ real tlev !room air temperature [K]
+ real, intent(in) :: timeon ! Initial local time of A/C systems
+ real, intent(in) :: timeoff ! Ending local time of A/C systems
+ real, intent(in) :: targtemp! Target temperature of A/C systems
+ real, intent(in) :: gaptemp ! Comfort range of indoor temperature
+
+
+!Local:
+!-----.
+
+ real templev !hipotetical room air temperature [K]
+ real alpha !variable to control the heating/cooling of
+ !the air conditining system
+!Output:
+!-----.
+ real hsneed !sensible heat extracted to the indoor air [W]
+!---------------------------------------------------------------------
+!initialize variables
+!---------------------
+ templev = 0.
+ alpha = 0.
+
+ if (swcond.eq.0) then ! there is not air conditioning in the floor
+ hsneed = 0.
+ goto 100
+ else
+ if ((nhourday.ge.timeon).and.(nhourday.le.timeoff)) then
+ templev=tlev+(dt/Qb)*hsroo
+ goto 200
+ else
+ hsneed = 0. ! air conditioning is switched off
+ goto 100
+ endif
+ endif
+
+200 continue
+
+ if (abs(templev-targtemp).le.gaptemp) then
+ hsneed = 0.
+ else
+ if (templev.gt.(targtemp+gaptemp)) then
+ hsneed=hsroo-(Qb/dt)*(targtemp+gaptemp-tlev)
+ alpha=(abs(hsneed-hsroo)/Qb)
+ if (alpha.gt.temp_rat) then
+ hsneed=hsroo+temp_rat*Qb
+ goto 100
+ else
+ goto 100
+ endif
+ else
+ hsneed=hsroo-(Qb/dt)*(targtemp-gaptemp-tlev)
+ alpha=(abs(hsneed-hsroo)/Qb)
+ if (alpha.gt.temp_rat) then
+ hsneed=hsroo-temp_rat*Qb
+ goto 100
+ else
+ goto 100
+ endif
+ endif
+ endif
+
+100 continue
+ return
+ end subroutine regtemp
+
+!====6=8==============================================================72
+!====6=8==============================================================72
+
+ subroutine reghum(swcond,nhourday,dt,volroo,rhoint,latent, &
+ hlroo,shumroo,timeon,timeoff,targhum,gaphum,hlneed)
+
+ implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the latent heat fluxes,
+!after anthropogenic regulation (air conditioning)
+!---------------------------------------------------------------------
+
+!Input:
+!-----.
+ integer swcond !swich air conditioning
+ real nhourday !number of hours from the beginning of the day real[h]
+ real dt !time step [s]
+ real volroo !volume of the room [m3]
+ real rhoint !density of the internal air [Kg/m3]
+ real latent !latent heat of evaporation [J/Kg]
+ real hlroo !latent heat flux generated inside the room [W]
+ real shumroo !specific humidity of the indoor air [kg/kg]
+ real, intent(in) :: timeon ! Initial local time of A/C systems
+ real, intent(in) :: timeoff ! Ending local time of A/C systems
+ real, intent(in) :: targhum ! Target humidity of the A/C systems
+ real, intent(in) :: gaphum ! comfort range of the specific humidity
+
+!Local:
+!-----.
+
+ real humlev !hipotetical specific humidity of the indoor [kg/kg]
+ real betha !variable to control the drying/moistening of
+ !the air conditioning system
+!Output:
+!-----.
+ real hlneed !latent heat extracted to the indoor air [W]
+!------------------------------------------------------------------------
+!initialize variables
+!---------------------
+ humlev = 0.
+ betha = 0.
+
+ if (swcond.eq.0) then ! there is not air conditioning in the floor
+ hlneed = 0.
+ goto 100
+ else
+ if ((nhourday.ge.timeon).and.(nhourday.le.timeoff)) then
+ humlev=shumroo+(dt/(latent*rhoint*volroo))*hlroo
+ goto 200
+ else
+ hlneed = 0. ! air conditioning is switched off
+ goto 100
+ endif
+ endif
+
+200 continue
+
+ if (abs(humlev-targhum).le.gaphum) then
+ hlneed = 0.
+ else
+ if (humlev.gt.(targhum+gaphum)) then
+ hlneed=hlroo-((latent*rhoint*volroo)/dt)* &
+ (targhum+gaphum-shumroo)
+ betha=abs(hlneed-hlroo)/(latent*rhoint*volroo)
+ if (betha.gt.hum_rat) then
+ hlneed=hlroo+hum_rat*(latent*rhoint*volroo)
+ goto 100
+ else
+ goto 100
+ endif
+ else
+ hlneed=hlroo-((latent*rhoint*volroo)/dt)* &
+ (targhum-gaphum-shumroo)
+ betha=abs(hlneed-hlroo)/(latent*rhoint*volroo)
+ if (betha.gt.hum_rat) then
+ hlneed=hlroo-hum_rat*(latent*rhoint*volroo)
+ goto 100
+ else
+ goto 100
+ endif
+ endif
+ endif
+
+100 continue
+ return
+ end subroutine reghum
+
+!====6=8==============================================================72
+!====6=8==============================================================72
+
+ subroutine air_cond(hsneed,hlneed,dt,hsout,hlout,consump,cop)
+
+ implicit none
+
+!
+!Performance of the air conditioning system
+!
+!INPUT/OUTPUT VARIABLES
+ real, intent(in) :: cop
+!
+!INPUT/OUTPUT VARIABLES
+!
+ real hsneed !sensible heat that is necessary for cooling/heating
+ !the indoor air temperature [W]
+ real hlneed !latent heat that is necessary for controling
+ !the humidity of the indoor air [W]
+ real dt !time step [s]
+!
+!OUTPUT VARIABLES
+!
+ real hsout !sensible heat pumped out into the atmosphere [W]
+ real hlout !latent heat pumped out into the atmosphere [W]
+ real consump !Electrical consumption of the air conditioning system [W]
+
+
+!
+!Performance of the air conditioning system
+!
+ if (hsneed.gt.0) then ! air conditioning is cooling
+ ! and the heat is pumped out into the atmosphere
+ hsout=(1/cop)*(abs(hsneed)+abs(hlneed))+hsneed
+ hlout=hlneed
+ consump=(1./cop)*(abs(hsneed)+abs(hlneed))
+!! hsout=0.
+!! hlout=0.
+
+ else if(hsneed.eq.0.) then !air conditioning is not working to regulate the indoor temperature
+ hlneed=0. !no humidity regulation is considered
+ hsout=0. !no output into the atmosphere (sensible heat)
+ hlout=0. !no output into the atmosphere (latent heat)
+ consump=0. !no electrical consumption
+
+ else !! hsneed < 0. !air conditioning is heating
+ hlneed=0. !no humidity regulation is considered
+ hlout=0. !no output into the atmosphere (latent heat)
+ consump=(1./cop)*(abs(hsneed)+abs(hlneed))
+!
+!!We have two possibilities
+!
+!! hsout=(1./cop)*(abs(hsneed)+abs(hlneed)) !output into the atmosphere
+ hsout=0. !no output into the atmosphere
+ end if
+
+ return
+ end subroutine air_cond
+
+!====6=8==============================================================72
+!====6=8==============================================================72
+
+ subroutine consump_total(nzcanm,nlev,consumpbuild,hsoutbuild, &
+ hsout,consump)
+
+ implicit none
+
+!-----------------------------------------------------------------------
+!Compute the total consumption in kWh/s (1kWh=3.6e+6 J) and sensible heat
+!ejected into the atmosphere per building
+!------------------------------------------------------------------------
+!
+!INPUT VARIABLES
+!
+!
+ integer nzcanm !Maximum number of vertical levels in the urban grid
+ real hsout(nzcanm) !sensible heat emitted outside the room [W]
+ real consump(nzcanm) !Electricity consumption for the a.c. in each floor[W]
+!
+!OUTPUT VARIABLES
+!
+ real consumpbuild !Energetic consumption for the entire building[kWh/s]
+ real hsoutbuild !Total sensible heat ejected into the atmosphere
+ !by the air conditioning systems per building [W]
+!
+!LOCAL VARIABLES
+!
+ integer ilev
+
+!
+!INPUT VARIABLES
+!
+ integer nlev
+
+!
+!INITIALIZE VARIABLES
+!
+ consumpbuild=0.
+ hsoutbuild=0.
+!
+ do ilev=1,nlev
+ consumpbuild=consumpbuild+consump(ilev)
+ hsoutbuild=hsoutbuild+hsout(ilev)
+ enddo !ilev
+
+ consumpbuild=consumpbuild/(3.6e+06)
+
+ return
+ end subroutine consump_total
+!====6=8==============================================================72
+!====6=8==============================================================72
+ subroutine tridia(n,a,b,x)
+
+! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! + by A. Clappier, EPFL, CH 1015 Lausanne +
+! + phone: ++41-(0)21-693-61-60 +
+! + email:alain.clappier@epfl.ch +
+! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! ----------------------------------------------------------------------
+! Resolution of a * x = b where a is a tridiagonal matrix
+!
+! ----------------------------------------------------------------------
+
+ implicit none
+
+! Input
+ integer n
+ real a(-1:1,n) ! a(-1,*) lower diagonal A(i,i-1)
+ ! a(0,*) principal diagonal A(i,i)
+ ! a(1,*) upper diagonal A(i,i+1)
+ real b(n)
+
+! Output
+ real x(n)
+
+! Local
+ integer i
+
+! ----------------------------------------------------------------------
+
+ do i=n-1,1,-1
+ b(i)=b(i)-a(1,i)*b(i+1)/a(0,i+1)
+ a(0,i)=a(0,i)-a(1,i)*a(-1,i+1)/a(0,i+1)
+ enddo
+
+ do i=2,n
+ b(i)=b(i)-a(-1,i)*b(i-1)/a(0,i-1)
+ enddo
+
+ do i=1,n
+ x(i)=b(i)/a(0,i)
+ enddo
+
+ return
+ end subroutine tridia
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine gaussjbem(a,n,b,np)
+
+! ----------------------------------------------------------------------
+! This routine solve a linear system of n equations of the form
+! A X = B
+! where A is a matrix a(i,j)
+! B a vector and X the solution
+! In output b is replaced by the solution
+! ----------------------------------------------------------------------
+
+ implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer np
+ real a(np,np)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real b(np)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer nmax
+ parameter (nmax=150)
+
+ real big,dum
+ integer i,icol,irow
+ integer j,k,l,ll,n
+ integer ipiv(nmax)
+ real pivinv
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+ do j=1,n
+ ipiv(j)=0.
+ enddo
+
+ do i=1,n
+ big=0.
+ do j=1,n
+ if(ipiv(j).ne.1)then
+ do k=1,n
+ if(ipiv(k).eq.0)then
+ if(abs(a(j,k)).ge.big)then
+ big=abs(a(j,k))
+ irow=j
+ icol=k
+ endif
+ elseif(ipiv(k).gt.1)then
+ pause 'singular matrix in gaussjbem'
+ endif
+ enddo
+ endif
+ enddo
+
+ ipiv(icol)=ipiv(icol)+1
+
+ if(irow.ne.icol)then
+ do l=1,n
+ dum=a(irow,l)
+ a(irow,l)=a(icol,l)
+ a(icol,l)=dum
+ enddo
+
+ dum=b(irow)
+ b(irow)=b(icol)
+ b(icol)=dum
+
+ endif
+
+ if(a(icol,icol).eq.0)pause 'singular matrix in gaussjbem'
+
+ pivinv=1./a(icol,icol)
+ a(icol,icol)=1
+
+ do l=1,n
+ a(icol,l)=a(icol,l)*pivinv
+ enddo
+
+ b(icol)=b(icol)*pivinv
+
+ do ll=1,n
+ if(ll.ne.icol)then
+ dum=a(ll,icol)
+ a(ll,icol)=0.
+ do l=1,n
+ a(ll,l)=a(ll,l)-a(icol,l)*dum
+ enddo
+
+ b(ll)=b(ll)-b(icol)*dum
+
+ endif
+ enddo
+ enddo
+
+ return
+ end subroutine gaussjbem
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+ subroutine radfluxs(radflux,alb,rs,em,rl,sigma,twal)
+
+ implicit none
+!-------------------------------------------------------------------
+!This function calculates the radiative fluxe at a surface
+!-------------------------------------------------------------------
+
+
+ real alb !albedo of the surface
+ real rs !shor wave radiation
+ real em !emissivity of the surface
+ real rl !lon wave radiation
+ real sigma !parameter (wall is not black body) [W/m2.K4]
+ real twal !wall temperature [K]
+ real radflux
+
+ radflux=(1.-alb)*rs+em*rl-em*sigma*twal**4
+
+ return
+ end subroutine radfluxs
+
+!====6=8==============================================================72
+!====6=8==============================================================72
+!
+! we define the view factors fprl and fnrm, which are the angle
+! factors between two equal and parallel planes, fprl, and two
+! equal and orthogonal planes, fnrm, respectively
+!
+ subroutine fprl_ints(fprl_int,vx,vy)
+
+ implicit none
+
+ real vx,vy
+ real fprl_int
+
+ fprl_int=(2./(3.141592653*vx*vy))* &
+ (log(sqrt((1.+vx*vx)*(1.+vy*vy)/(1.+vx*vx+vy*vy)))+ &
+ (vy*sqrt(1.+vx*vx)*atan(vy/sqrt(1.+vx*vx)))+ &
+ (vx*sqrt(1.+vy*vy)*atan(vx/sqrt(1.+vy*vy)))- &
+ vy*atan(vy)-vx*atan(vx))
+
+ return
+ end subroutine fprl_ints
+
+!====6=8==============================================================72
+!====6=8==============================================================72
+!
+! we define the view factors fprl and fnrm, which are the angle
+! factors between two equal and parallel planes, fprl, and two
+! equal and orthogonal planes, fnrm, respectively
+!
+
+ subroutine fnrm_ints(fnrm_int,wx,wy,wz)
+
+ implicit none
+
+ real wx,wy,wz
+ real fnrm_int
+
+ fnrm_int=(1./(3.141592653*wy))*(wy*atan(1./wy)+wx*atan(1./wx)- &
+ (sqrt(wz)*atan(1./sqrt(wz)))+ &
+ (1./4.)*(log((1.+wx*wx)*(1.+wy*wy)/(1.+wz))+ &
+ wy*wy*log(wy*wy*(1.+wz)/(wz*(1.+wy*wy)))+ &
+ wx*wx*log(wx*wx*(1.+wz)/(wz*(1.+wx*wx)))))
+
+ return
+ end subroutine fnrm_ints
+
+!====6=8==============================================================72
+!====6=8==============================================================72
+END MODULE module_sf_bem
Added: branches/atmos_physics/src/core_physics/physics_wrf/module_sf_bep.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_sf_bep.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_sf_bep.F 2011-01-13 23:29:23 UTC (rev 685)
@@ -0,0 +1,3239 @@
+MODULE module_sf_bep
+
+!USE module_model_constants
+ USE module_sf_urban
+
+! SGClarke 09/11/2008
+! Access urban_param.tbl values through calling urban_param_init in module_physics_init
+! for CASE (BEPSCHEME) select sf_urban_physics
+!
+ ! -----------------------------------------------------------------------
+! Dimension for the array used in the BEP module
+! -----------------------------------------------------------------------
+
+ integer nurbm ! Maximum number of urban classes
+ parameter (nurbm=3)
+
+ integer ndm ! Maximum number of street directions
+ parameter (ndm=2)
+
+ integer nz_um ! Maximum number of vertical levels in the urban grid
+ parameter(nz_um=13)
+
+ integer ng_u ! Number of grid levels in the ground
+ parameter (ng_u=10)
+ integer nwr_u ! Number of grid levels in the walls or roofs
+ parameter (nwr_u=10)
+
+ real dz_u ! Urban grid resolution
+ parameter (dz_u=5.)
+
+! The change of ng_u, nwr_u should be done in agreement with the block data
+! in the routine "surf_temp"
+! -----------------------------------------------------------------------
+! Constant used in the BEP module
+! -----------------------------------------------------------------------
+
+ real vk ! von Karman constant
+ real g_u ! Gravity acceleration
+ real pi !
+ real r ! Perfect gas constant
+ real cp_u ! Specific heat at constant pressure
+ real rcp_u !
+ real sigma !
+ real p0 ! Reference pressure at the sea level
+ real cdrag ! Drag force constant
+ parameter(vk=0.40,g_u=9.81,pi=3.141592653,r=287.,cp_u=1004.)
+ parameter(rcp_u=r/cp_u,sigma=5.67e-08,p0=1.e+5,cdrag=0.4)
+
+! -----------------------------------------------------------------------
+
+
+
+
+ CONTAINS
+
+ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, &
+ th_phy,rho,p_phy,swdown,glw, &
+ gmt,julday,xlong,xlat, &
+ declin_urb,cosz_urb2d,omg_urb2d, &
+ num_urban_layers, &
+ trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, &
+ sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, &
+ a_u,a_v,a_t,a_e,b_u,b_v, &
+ b_t,b_e,dlg,dl_u,sf,vl, &
+ rl_up,rs_abs,emiss,grdflx_urb, &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte)
+
+ implicit none
+
+!------------------------------------------------------------------------
+! Input
+!------------------------------------------------------------------------
+ INTEGER :: ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte, &
+ itimestep
+
+
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: DZ8W
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: P_PHY
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: RHO
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: TH_PHY
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: T_PHY
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: U_PHY
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: V_PHY
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: U
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: V
+ REAL, DIMENSION( ims:ime , jms:jme ) :: GLW
+ REAL, DIMENSION( ims:ime , jms:jme ) :: swdown
+ REAL, DIMENSION( ims:ime, jms:jme ) :: UST
+ INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: UTYPE_URB2D
+ REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: FRC_URB2D
+ REAL, INTENT(IN ) :: GMT
+ INTEGER, INTENT(IN ) :: JULDAY
+ REAL, DIMENSION( ims:ime, jms:jme ), &
+ INTENT(IN ) :: XLAT, XLONG
+ REAL, INTENT(IN) :: DECLIN_URB
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D
+ INTEGER, INTENT(IN ) :: num_urban_layers
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d
+! integer nx,ny,nz ! Number of points in the mesocsale grid
+ real z(ims:ime,kms:kme,jms:jme) ! Vertical coordinates
+ REAL, INTENT(IN ):: DT ! Time step
+! real zr(ims:ime,jms:jme) ! Solar zenith angle
+! real deltar(ims:ime,jms:jme) ! Declination of the sun
+! real ah(ims:ime,jms:jme) ! Hour angle
+! real rs(ims:ime,jms:jme) ! Solar radiation
+!------------------------------------------------------------------------
+! Output
+!------------------------------------------------------------------------
+! real tsk(ims:ime,jms:jme) ! Average of surface temperatures (roads and roofs)
+!
+! Implicit and explicit components of the source and sink terms at each levels,
+! the fluxes can be computed as follow: FX = A*X + B example: t_fluxes = a_t * pt + b_t
+ real a_u(ims:ime,kms:kme,jms:jme) ! Implicit component for the momemtum in X-direction (center)
+ real a_v(ims:ime,kms:kme,jms:jme) ! Implicit component for the momemtum in Y-direction (center)
+ real a_t(ims:ime,kms:kme,jms:jme) ! Implicit component for the temperature
+ real a_e(ims:ime,kms:kme,jms:jme) ! Implicit component for the TKE
+ real b_u(ims:ime,kms:kme,jms:jme) ! Explicit component for the momemtum in X-direction (center)
+ real b_v(ims:ime,kms:kme,jms:jme) ! Explicit component for the momemtum in Y-direction (center)
+ real b_t(ims:ime,kms:kme,jms:jme) ! Explicit component for the temperature
+ real b_e(ims:ime,kms:kme,jms:jme) ! Explicit component for the TKE
+ real dlg(ims:ime,kms:kme,jms:jme) ! Height above ground (L_ground in formula (24) of the BLM paper).
+ real dl_u(ims:ime,kms:kme,jms:jme) ! Length scale (lb in formula (22) ofthe BLM paper).
+! urban surface and volumes
+ real sf(ims:ime,kms:kme,jms:jme) ! surface of the urban grid cells
+ real vl(ims:ime,kms:kme,jms:jme) ! volume of the urban grid cells
+! urban fluxes
+ real rl_up(ims:ime,jms:jme) ! upward long wave radiation
+ real rs_abs(ims:ime,jms:jme) ! absorbed short wave radiation
+ real emiss(ims:ime,jms:jme) ! emissivity averaged for urban surfaces
+ real grdflx_urb(ims:ime,jms:jme) ! ground heat flux for urban areas
+!------------------------------------------------------------------------
+! Local
+!------------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Building parameters
+ real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1]
+ real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1]
+ real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1]
+ real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1]
+ real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1]
+ real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1]
+ real twini_u(nurbm) ! Initial temperature inside the building's wall [K]
+ real trini_u(nurbm) ! Initial temperature inside the building's roof [K]
+ real tgini_u(nurbm) ! Initial road temperature
+!
+! for twini_u, and trini_u the initial value at the deepest level is kept constant during the simulation
+!
+! Radiation paramters
+ real albg_u(nurbm) ! Albedo of the ground
+ real albw_u(nurbm) ! Albedo of the wall
+ real albr_u(nurbm) ! Albedo of the roof
+ real emg_u(nurbm) ! Emissivity of ground
+ real emw_u(nurbm) ! Emissivity of wall
+ real emr_u(nurbm) ! Emissivity of roof
+
+! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+! and the short wave radation.
+ real fww(nz_um,nz_um,ndm,nurbm) ! from wall to wall
+ real fwg(nz_um,ndm,nurbm) ! from wall to ground
+ real fgw(nz_um,ndm,nurbm) ! from ground to wall
+ real fsw(nz_um,ndm,nurbm) ! from sky to wall
+ real fws(nz_um,ndm,nurbm) ! from sky to wall
+ real fsg(ndm,nurbm) ! from sky to ground
+
+! Roughness parameters
+ real z0g_u(nurbm) ! The ground's roughness length
+ real z0r_u(nurbm) ! The roof's roughness length
+
+! Street parameters
+ integer nd_u(nurbm) ! Number of street direction for each urban class
+ real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells)
+ real drst_u(ndm,nurbm) ! Street direction
+ real ws_u(ndm,nurbm) ! Street width
+ real bs_u(ndm,nurbm) ! Building width
+ real h_b(nz_um,nurbm) ! Bulding's heights
+ real d_b(nz_um,nurbm) ! Probability that a building has an height h_b
+ real ss_u(nz_um,nurbm) ! Probability that a building has an height equal to z
+ real pb_u(nz_um,nurbm) ! Probability that a building has an height greater or equal to z
+
+
+! Grid parameters
+ integer nz_u(nurbm) ! Number of layer in the urban grid
+
+ real z_u(nz_um) ! Height of the urban grid levels
+
+! 1D array used for the input and output of the routine "urban"
+
+ real z1D(kms:kme) ! vertical coordinates
+ real ua1D(kms:kme) ! wind speed in the x directions
+ real va1D(kms:kme) ! wind speed in the y directions
+ real pt1D(kms:kme) ! potential temperature
+ real da1D(kms:kme) ! air density
+ real pr1D(kms:kme) ! air pressure
+ real pt01D(kms:kme) ! reference potential temperature
+ real zr1D ! zenith angle
+ real deltar1D ! declination of the sun
+ real ah1D ! hour angle (it should come from the radiation routine)
+ real rs1D ! solar radiation
+ real rld1D ! downward flux of the longwave radiation
+
+
+ real tw1D(2*ndm,nz_um,nwr_u) ! temperature in each layer of the wall
+ real tg1D(ndm,ng_u) ! temperature in each layer of the ground
+ real tr1D(ndm,nz_um,nwr_u) ! temperature in each layer of the roof
+ real sfw1D(2*ndm,nz_um) ! sensible heat flux from walls
+ real sfg1D(ndm) ! sensible heat flux from ground (road)
+ real sfr1D(ndm,nz_um) ! sensible heat flux from roofs
+ real sf1D(kms:kme) ! surface of the urban grid cells
+ real vl1D(kms:kme) ! volume of the urban grid cells
+ real a_u1D(kms:kme) ! Implicit component of the momentum sources or sinks in the X-direction
+ real a_v1D(kms:kme) ! Implicit component of the momentum sources or sinks in the Y-direction
+ real a_t1D(kms:kme) ! Implicit component of the heat sources or sinks
+ real a_e1D(kms:kme) ! Implicit component of the TKE sources or sinks
+ real b_u1D(kms:kme) ! Explicit component of the momentum sources or sinks in the X-direction
+ real b_v1D(kms:kme) ! Explicit component of the momentum sources or sinks in the Y-direction
+ real b_t1D(kms:kme) ! Explicit component of the heat sources or sinks
+ real b_e1D(kms:kme) ! Explicit component of the TKE sources or sinks
+ real dlg1D(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper).
+ real dl_u1D(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper)
+ real tsk1D ! Average of the road surface temperatures
+ real time_bep
+! arrays used to collapse indexes
+ integer ind_zwd(nz_um,nwr_u,ndm)
+ integer ind_gd(ng_u,ndm)
+ integer ind_zd(nz_um,ndm)
+!
+ integer ix,iy,iz,iurb,id,iz_u,iw,ig,ir,ix1,iy1,k
+ integer it, nint
+ integer iii
+ real time_h,tempo,shtot
+ logical first
+ character(len=80) :: text
+ data first/.true./
+ save first,time_bep
+
+ save alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, &
+ albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,fww,fwg,fgw,fsw,fws,fsg, &
+ z0g_u,z0r_u, nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, &
+ nz_u,z_u
+
+!------------------------------------------------------------------------
+! Calculation of the momentum, heat and turbulent kinetic fluxes
+! produced by builgings
+!
+! Reference:
+! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE
+! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104:
+! 261-304
+!------------------------------------------------------------------------
+!prepare the arrays to collapse indexes
+
+ if(num_urban_layers.lt.nz_um*ndm*nwr_u)then
+ write(*,*)'num_urban_layers too small, please increase to at least ', nz_um*ndm*nwr_u
+ stop
+ endif
+ iii=0
+ do iz_u=1,nz_um
+ do iw=1,nwr_u
+ do id=1,ndm
+ iii=iii+1
+ ind_zwd(iz_u,iw,id)=iii
+ enddo
+ enddo
+ enddo
+
+ iii=0
+ do ig=1,ng_u
+ do id=1,ndm
+ iii=iii+1
+ ind_gd(ig,id)=iii
+ enddo
+ enddo
+
+ iii=0
+ do iz_u=1,nz_um
+ do id=1,ndm
+ iii=iii+1
+ ind_zd(iz_u,id)=iii
+ enddo
+ enddo
+ do ix=its,ite
+ do iy=jts,jte
+ z(ix,kts,iy)=0.
+ do iz=kts+1,kte+1
+ z(ix,iz,iy)=z(ix,iz-1,iy)+dz8w(ix,iz-1,iy)
+ enddo
+ enddo
+ enddo
+
+ if (first) then ! True only on first call
+ call init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,&
+ twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,emg_u,emw_u,&
+ emr_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b)
+
+! Initialisation of the urban parameters and calculation of the view factors
+ call icBEP(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, &
+ albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, &
+ fww,fwg,fgw,fsw,fws,fsg, &
+ z0g_u,z0r_u, &
+ nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, &
+ nz_u,z_u, &
+ twini_u,trini_u)
+
+ first=.false.
+
+ endif ! first
+
+ do ix=its,ite
+ do iy=jts,jte
+ if (FRC_URB2D(ix,iy).gt.0.) then ! Calling BEP only for existing urban classes.
+
+ iurb=UTYPE_URB2D(ix,iy)
+
+ do iz= kts,kte
+ ua1D(iz)=u_phy(ix,iz,iy)
+ va1D(iz)=v_phy(ix,iz,iy)
+ pt1D(iz)=th_phy(ix,iz,iy)
+ da1D(iz)=rho(ix,iz,iy)
+ pr1D(iz)=p_phy(ix,iz,iy)
+! pt01D(iz)=th_phy(ix,iz,iy)
+ pt01D(iz)=300.
+ z1D(iz)=z(ix,iz,iy)
+ a_u1D(iz)=0.
+ a_v1D(iz)=0.
+ a_t1D(iz)=0.
+ a_e1D(iz)=0.
+ b_u1D(iz)=0.
+ b_v1D(iz)=0.
+ b_t1D(iz)=0.
+ b_e1D(iz)=0.
+ enddo
+ z1D(kte+1)=z(ix,kte+1,iy)
+
+ do id=1,ndm
+ do iz_u=1,nz_um
+ do iw=1,nwr_u
+! tw1D(2*id-1,iz_u,iw)=tw1_u(ix,iy,ind_zwd(iz_u,iw,id))
+! tw1D(2*id,iz_u,iw)=tw2_u(ix,iy,ind_zwd(iz_u,iw,id))
+ if(ind_zwd(iz_u,iw,id).gt.num_urban_layers)write(*,*)'ind_zwd too big w',ind_zwd(iz_u,iw,id)
+ tw1D(2*id-1,iz_u,iw)=tw1_urb4d(ix,ind_zwd(iz_u,iw,id),iy)
+ tw1D(2*id,iz_u,iw)=tw2_urb4d(ix,ind_zwd(iz_u,iw,id),iy)
+ enddo
+ enddo
+ enddo
+
+ do id=1,ndm
+ do ig=1,ng_u
+! tg1D(id,ig)=tg_u(ix,iy,ind_gd(ig,id))
+ tg1D(id,ig)=tgb_urb4d(ix,ind_gd(ig,id),iy)
+ enddo
+ do iz_u=1,nz_um
+ do ir=1,nwr_u
+! tr1D(id,iz_u,ir)=tr_u(ix,iy,ind_zwd(iz_u,ir,id))
+ if(ind_zwd(iz_u,ir,id).gt.num_urban_layers)write(*,*)'ind_zwd too big r',ind_zwd(iz_u,ir,id)
+ tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zwd(iz_u,ir,id),iy)
+ enddo
+ enddo
+ enddo
+
+ do id=1,ndm
+ do iz=1,nz_um
+! sfw1D(2*id-1,iz)=sfw1(ix,iy,ind_zd(iz,id))
+! sfw1D(2*id,iz)=sfw2(ix,iy,ind_zd(iz,id))
+ sfw1D(2*id-1,iz)=sfw1_urb3d(ix,ind_zd(iz,id),iy)
+ sfw1D(2*id,iz)=sfw2_urb3d(ix,ind_zd(iz,id),iy)
+ enddo
+ enddo
+
+ do id=1,ndm
+! sfg1D(id)=sfg(ix,iy,id)
+ sfg1D(id)=sfg_urb3d(ix,id,iy)
+ enddo
+
+ do id=1,ndm
+ do iz=1,nz_um
+! sfr1D(id,iz)=sfr(ix,iy,ind_zd(iz,id))
+ sfr1D(id,iz)=sfr_urb3d(ix,ind_zd(iz,id),iy)
+ enddo
+ enddo
+
+
+ rs1D=swdown(ix,iy)
+ rld1D=glw(ix,iy)
+ time_h=(itimestep*dt)/3600.+gmt
+
+ zr1D=acos(COSZ_URB2D(ix,iy))
+ deltar1D=DECLIN_URB
+ ah1D=OMG_URB2D(ix,iy)
+! call angle(xlong(ix,iy),xlat(ix,iy),julday,time_h,zr1D,deltar1D,ah1D)
+
+ call BEP1D(iurb,kms,kme,kts,kte,z1D,dt,ua1D,va1D,pt1D,da1D,pr1D,pt01D, &
+ zr1D,deltar1D,ah1D,rs1D,rld1D, &
+ alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, &
+ albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, &
+ fww,fwg,fgw,fsw,fws,fsg, &
+ z0g_u,z0r_u, &
+ nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, &
+ nz_u,z_u, &
+ tw1D,tg1D,tr1D,sfw1D,sfg1D,sfr1D, &
+ a_u1D,a_v1D,a_t1D,a_e1D, &
+ b_u1D,b_v1D,b_t1D,b_e1D, &
+ dlg1D,dl_u1D,tsk1D,sf1D,vl1D,rl_up(ix,iy), &
+ rs_abs(ix,iy),emiss(ix,iy),grdflx_urb(ix,iy))
+
+ do id=1,ndm
+ do iz=1,nz_um
+ sfw1_urb3d(ix,ind_zd(iz,id),iy)=sfw1D(2*id-1,iz)
+ sfw2_urb3d(ix,ind_zd(iz,id),iy)=sfw1D(2*id,iz)
+ enddo
+ enddo
+
+ do id=1,ndm
+ sfg_urb3d(ix,id,iy)=sfg1D(id)
+ enddo
+
+ do id=1,ndm
+ do iz=1,nz_um
+ sfr_urb3d(ix,ind_zd(iz,id),iy)=sfr1D(id,iz)
+ enddo
+ enddo
+!
+ do id=1,ndm
+ do iz_u=1,nz_um
+ do iw=1,nwr_u
+ tw1_urb4d(ix,ind_zwd(iz_u,iw,id),iy)=tw1D(2*id-1,iz_u,iw)
+ tw2_urb4d(ix,ind_zwd(iz_u,iw,id),iy)=tw1D(2*id,iz_u,iw)
+ enddo
+ enddo
+ enddo
+
+ do id=1,ndm
+ do ig=1,ng_u
+ tgb_urb4d(ix,ind_gd(ig,id),iy)=tg1D(id,ig)
+ enddo
+ do iz_u=1,nz_um
+ do ir=1,nwr_u
+ trb_urb4d(ix,ind_zwd(iz_u,ir,id),iy)=tr1D(id,iz_u,ir)
+ enddo
+ enddo
+ enddo
+
+ do iz= kts,kte
+ sf(ix,iz,iy)=sf1D(iz)
+ vl(ix,iz,iy)=vl1D(iz)
+ a_u(ix,iz,iy)=a_u1D(iz)
+ a_v(ix,iz,iy)=a_v1D(iz)
+ a_t(ix,iz,iy)=a_t1D(iz)
+ a_e(ix,iz,iy)=a_e1D(iz)
+ b_u(ix,iz,iy)=b_u1D(iz)
+ b_v(ix,iz,iy)=b_v1D(iz)
+ b_t(ix,iz,iy)=b_t1D(iz)
+ b_e(ix,iz,iy)=b_e1D(iz)
+ dlg(ix,iz,iy)=dlg1D(iz)
+ dl_u(ix,iz,iy)=dl_u1D(iz)
+ enddo
+ sf(ix,kte+1,iy)=sf1D(kte+1)
+! tsk(ix,iy)=tsk1D
+!
+ endif ! FRC_URB2D
+
+ enddo ! iy
+ enddo ! ix
+
+
+ time_bep=time_bep+dt
+
+
+ return
+ end subroutine BEP
+
+! ===6=8===============================================================72
+
+ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, &
+ zr,deltar,ah,rs,rld, &
+ alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, &
+ albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, &
+ fww,fwg,fgw,fsw,fws,fsg, &
+ z0g_u,z0r_u, &
+ nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, &
+ nz_u,z_u, &
+ tw,tg,tr,sfw,sfg,sfr, &
+ a_u,a_v,a_t,a_e, &
+ b_u,b_v,b_t,b_e, &
+ dlg,dl_u,tsk,sf,vl,rl_up,rs_abs,emiss,grdflx_urb)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of buildings on momentum, heat and
+! TKE (turbulent kinetic energy) sources or sinks and on the mixing length.
+! It provides momentum, heat and TKE sources or sinks at different levels of a
+! mesoscale grid defined by the altitude of its cell interfaces "z" and
+! its number of levels "nz".
+! The meteorological input parameters (wind, temperature, solar radiation)
+! are specified on the "mesoscale grid".
+! The inputs concerning the building and street charateristics are defined
+! on a "urban grid". The "urban grid" is defined with its number of levels
+! "nz_u" and its space step "dz_u".
+! The input parameters are interpolated on the "urban grid". The sources or sinks
+! are calculated on the "urban grid". Finally the sources or sinks are
+! interpolated on the "mesoscale grid".
+
+
+! Mesoscale grid Urban grid Mesoscale grid
+!
+! z(4) --- ---
+! | |
+! | |
+! | Interpolation Interpolation |
+! | Sources or sinks calculation |
+! z(3) --- ---
+! | ua ua_u --- uv_a a_u |
+! | va va_u | uv_b b_u |
+! | pt pt_u --- uh_b a_v |
+! z(2) --- | etc... etc...---
+! | z_u(1) --- |
+! | | |
+! z(1) ------------------------------------------------------------
+
+!
+! Reference:
+! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE
+! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104:
+! 261-304
+
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+
+! Data relative to the "mesoscale grid"
+
+! integer nz ! Number of vertical levels
+ integer kms,kme,kts,kte
+ real z(kms:kme) ! Altitude above the ground of the cell interfaces.
+ real ua(kms:kme) ! Wind speed in the x direction
+ real va(kms:kme) ! Wind speed in the y direction
+ real pt(kms:kme) ! Potential temperature
+ real da(kms:kme) ! Air density
+ real pr(kms:kme) ! Air pressure
+ real pt0(kms:kme) ! Reference potential temperature (could be equal to "pt")
+ real dt ! Time step
+ real zr ! Zenith angle
+ real deltar ! Declination of the sun
+ real ah ! Hour angle
+ real rs ! Solar radiation
+ real rld ! Downward flux of the longwave radiation
+
+! Data relative to the "urban grid"
+
+ integer iurb ! Current urban class
+
+! Building parameters
+ real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1]
+ real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1]
+ real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1]
+ real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1]
+ real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1]
+ real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1]
+
+! Radiation parameters
+ real albg_u(nurbm) ! Albedo of the ground
+ real albw_u(nurbm) ! Albedo of the wall
+ real albr_u(nurbm) ! Albedo of the roof
+ real emg_u(nurbm) ! Emissivity of ground
+ real emw_u(nurbm) ! Emissivity of wall
+ real emr_u(nurbm) ! Emissivity of roof
+
+! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long and
+! short wave radation.
+! The calculation of these factor is explained in the Appendix A of the BLM paper
+ real fww(nz_um,nz_um,ndm,nurbm) ! from wall to wall
+ real fwg(nz_um,ndm,nurbm) ! from wall to ground
+ real fgw(nz_um,ndm,nurbm) ! from ground to wall
+ real fsw(nz_um,ndm,nurbm) ! from sky to wall
+ real fws(nz_um,ndm,nurbm) ! from wall to sky
+ real fsg(ndm,nurbm) ! from sky to ground
+
+! Roughness parameters
+ real z0g_u(nurbm) ! The ground's roughness length
+ real z0r_u(nurbm) ! The roof's roughness length
+
+! Street parameters
+ integer nd_u(nurbm) ! Number of street direction for each urban class
+ real strd_u(ndm,nurbm) ! Street length (set to a greater value then the horizontal length of the cells)
+ real drst_u(ndm,nurbm) ! Street direction
+ real ws_u(ndm,nurbm) ! Street width
+ real bs_u(ndm,nurbm) ! Building width
+ real h_b(nz_um,nurbm) ! Bulding's heights
+ real d_b(nz_um,nurbm) ! The probability that a building has an height "h_b"
+ real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to "z"
+ real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to "z"
+
+! Grid parameters
+ integer nz_u(nurbm) ! Number of layer in the urban grid
+! real dz_u ! Urban grid resolution
+ real z_u(nz_um) ! Height of the urban grid levels
+
+
+! ----------------------------------------------------------------------
+! INPUT-OUTPUT
+! ----------------------------------------------------------------------
+
+! Data relative to the "urban grid" which should be stored from the current time step to the next one
+
+ real tw(2*ndm,nz_um,nwr_u) ! Temperature in each layer of the wall [K]
+ real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K]
+ real tg(ndm,ng_u) ! Temperature in each layer of the ground [K]
+ real sfw(2*ndm,nz_um) ! Sensible heat flux from walls
+ real sfg(ndm) ! Sensible heat flux from ground (road)
+ real sfr(ndm,nz_um) ! Sensible heat flux from roofs
+ real gfg(ndm) ! Heat flux transferred from the surface of the ground (road) towards the interior
+ real gfr(ndm,nz_um) ! Heat flux transferred from the surface of the roof towards the interior
+ real gfw(2*ndm,nz_um) ! Heat flux transfered from the surface of the walls towards the interior
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+
+! Data relative to the "mesoscale grid"
+
+ real sf(kms:kme) ! Surface of the "mesoscale grid" cells taking into account the buildings
+ real vl(kms:kme) ! Volume of the "mesoscale grid" cells taking into account the buildings
+
+! Implicit and explicit components of the source and sink terms at each levels,
+! the fluxes can be computed as follow: FX = A*X + B example: Heat fluxes = a_t * pt + b_t
+ real a_u(kms:kme) ! Implicit component of the momentum sources or sinks in the X-direction
+ real a_v(kms:kme) ! Implicit component of the momentum sources or sinks in the Y-direction
+ real a_t(kms:kme) ! Implicit component of the heat sources or sinks
+ real a_e(kms:kme) ! Implicit component of the TKE sources or sinks
+ real b_u(kms:kme) ! Explicit component of the momentum sources or sinks in the X-direction
+ real b_v(kms:kme) ! Explicit component of the momentum sources or sinks in the Y-direction
+ real b_t(kms:kme) ! Explicit component of the heat sources or sinks
+ real b_e(kms:kme) ! Explicit component of the TKE sources or sinks
+ real dlg(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper).
+ real dl_u(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper).
+ real tsk ! Average of the road surface temperatures
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+
+ real dz(kms:kme) ! vertical space steps of the "mesoscale grid"
+
+! Data interpolated from the "mesoscale grid" to the "urban grid"
+
+ real ua_u(nz_um) ! Wind speed in the x direction
+ real va_u(nz_um) ! Wind speed in the y direction
+ real pt_u(nz_um) ! Potential temperature
+ real da_u(nz_um) ! Air density
+ real pt0_u(nz_um) ! Reference potential temperature
+ real pr_u(nz_um) ! Air pressure
+
+! Data defining the building and street charateristics
+
+ integer nd ! Number of street direction for the current urban class
+
+ real alag(ng_u) ! Ground thermal diffusivity for the current urban class [m^2 s^-1]
+ real alar(nwr_u) ! Roof thermal diffusivity for the current urban class [m^2 s^-1]
+ real alaw(nwr_u) ! Walls thermal diffusivity for the current urban class [m^2 s^-1]
+ real csg(ng_u) ! Specific heat of the ground material of the current urban class [J m^3 K^-1]
+ real csr(nwr_u) ! Specific heat of the roof material for the current urban class [J m^3 K^-1]
+ real csw(nwr_u) ! Specific heat of the wall material for the current urban class [J m^3 K^-1]
+
+ real z0(ndm,nz_um) ! Roughness lengths "profiles"
+ real ws(ndm) ! Street widths of the current urban class
+ real bs(ndm) ! Building widths of the current urban class
+ real strd(ndm) ! Street lengths for the current urban class
+ real drst(ndm) ! Street directions for the current urban class
+ real ss(nz_um) ! Probability to have a building with height h
+ real pb(nz_um) ! Probability to have a building with an height equal
+
+! Solar radiation at each level of the "urban grid"
+
+ real rsg(ndm) ! Short wave radiation from the ground
+ real rsw(2*ndm,nz_um) ! Short wave radiation from the walls
+ real rlg(ndm) ! Long wave radiation from the ground
+ real rlw(2*ndm,nz_um) ! Long wave radiation from the walls
+
+! Potential temperature of the surfaces at each level of the "urban grid"
+
+ real ptg(ndm) ! Ground potential temperatures
+ real ptr(ndm,nz_um) ! Roof potential temperatures
+ real ptw(2*ndm,nz_um) ! Walls potential temperatures
+
+
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+! vertical surfaces (walls) ans horizontal surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+! Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+
+ real uhb_u(ndm,nz_um) ! U (wind component) Horizontal surfaces, B (explicit) term
+ real uva_u(2*ndm,nz_um) ! U (wind component) Vertical surfaces, A (implicit) term
+ real uvb_u(2*ndm,nz_um) ! U (wind component) Vertical surfaces, B (explicit) term
+ real vhb_u(ndm,nz_um) ! V (wind component) Horizontal surfaces, B (explicit) term
+ real vva_u(2*ndm,nz_um) ! V (wind component) Vertical surfaces, A (implicit) term
+ real vvb_u(2*ndm,nz_um) ! V (wind component) Vertical surfaces, B (explicit) term
+ real thb_u(ndm,nz_um) ! Temperature Horizontal surfaces, B (explicit) term
+ real tva_u(2*ndm,nz_um) ! Temperature Vertical surfaces, A (implicit) term
+ real tvb_u(2*ndm,nz_um) ! Temperature Vertical surfaces, B (explicit) term
+ real ehb_u(ndm,nz_um) ! Energy (TKE) Horizontal surfaces, B (explicit) term
+ real evb_u(2*ndm,nz_um) ! Energy (TKE) Vertical surfaces, B (explicit) term
+
+!
+ real rs_abs ! solar radiation absorbed by urban surfaces
+ real rl_up ! longwave radiation emitted by urban surface to the atmosphere
+ real emiss ! mean emissivity of the urban surface
+ real grdflx_urb ! ground heat flux
+ real shtot,aaa
+ real dt_int ! internal time step
+ integer nt_int ! number of internal time step
+ integer iz,id, it_int
+ integer iwrong,iw,ix,iy
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+! Fix some usefull parameters for the computation of the sources or sinks
+
+ do iz=kts,kte
+ dz(iz)=z(iz+1)-z(iz)
+ end do
+ call param(iurb,nz_u(iurb),nd_u(iurb), &
+ csg_u,csg,alag_u,alag,csr_u,csr, &
+ alar_u,alar,csw_u,csw,alaw_u,alaw, &
+ ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0, &
+ strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb)
+
+! Interpolation on the "urban grid"
+ call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,ua,ua_u)
+ call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,va,va_u)
+ call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt,pt_u)
+ call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt0,pt0_u)
+ call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pr,pr_u)
+ call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,da,da_u)
+
+
+! Compute the modification of the radiation due to the buildings
+
+ call modif_rad(iurb,nd_u(iurb),nz_u(iurb),z_u,ws, &
+ drst,strd,ss,pb, &
+ tw,tg,albg_u(iurb),albw_u(iurb), &
+ emw_u(iurb),emg_u(iurb), &
+ fww,fwg,fgw,fsw,fsg, &
+ zr,deltar,ah, &
+ rs,rld,rsw,rsg,rlw,rlg)
+
+! calculation of the urban albedo and the upward long wave radiation
+ call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss, &
+ tg,emg_u(iurb),albg_u(iurb),rlg,rsg,sfg, &
+ tw,emw_u(iurb),albw_u(iurb),rlw,rsw,sfw, &
+ tr,emr_u(iurb),albr_u(iurb),rld,rs,sfr, &
+ rs_abs,rl_up,emiss,grdflx_urb)
+
+! Compute the surface temperatures
+
+
+ call surf_temp(nz_u(iurb),nd_u(iurb),pr_u,dt,ss, &
+ rs,rld,rsg,rlg,rsw,rlw, &
+ tg,alag,csg,emg_u(iurb),albg_u(iurb),ptg,sfg,gfg, &
+ tr,alar,csr,emr_u(iurb),albr_u(iurb),ptr,sfr,gfr, &
+ tw,alaw,csw,emw_u(iurb),albw_u(iurb),ptw,sfw,gfw)
+
+
+! Compute the implicit and explicit components of the sources or sinks on the "urban grid"
+
+ call buildings(nd_u(iurb),nz_u(iurb),z0,ua_u,va_u, &
+ pt_u,pt0_u,ptg,ptr,da_u,ptw,drst, &
+ uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, &
+ uhb_u,vhb_u,thb_u,ehb_u,ss,dt)
+
+
+! Calculation of the sensible heat fluxes for the ground, the wall and roof
+! Sensible Heat Flux = density * Cp_U * ( A* potential temperature + B )
+! where A and B are the implicit and explicit components of the heat sources or sinks.
+!
+!
+
+ do id=1,nd_u(iurb)
+ sfg(id)=-da_u(1)*cp_u*thb_u(id,1)
+ do iz=2,nz_u(iurb)
+ sfr(id,iz)=-da_u(iz)*cp_u*thb_u(id,iz)
+ enddo
+
+ do iz=1,nz_u(iurb)
+ sfw(2*id-1,iz)=-da_u(iz)*cp_u*(tvb_u(2*id-1,iz)+ &
+ tva_u(2*id-1,iz)*pt_u(iz))
+ sfw(2*id,iz)=-da_u(iz)*cp_u*(tvb_u(2*id,iz)+ &
+ tva_u(2*id,iz)*pt_u(iz))
+ enddo
+ enddo
+
+! calculation of the urban albedo and the upward long wave radiation
+
+! call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss, &
+! tg,emg_u(iurb),albg_u(iurb),rlg,rsg, &
+! tw,emw_u(iurb),albw_u(iurb),rlw,rsw, &
+! tr,emr_u(iurb),albr_u(iurb),rld,rs, &
+! rs_abs,rl_up,emiss)
+
+! Interpolation on the "mesoscale grid"
+
+ call urban_meso(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z,dz,z_u,pb,ss,bs,ws,sf, &
+ vl,uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, &
+ uhb_u,vhb_u,thb_u,ehb_u, &
+ a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e)
+
+
+! computation of the mean road temperature tsk (this value could be used
+! to replace the surface temperature in the radiation routines, if needed).
+
+! tsk=0.
+! do id=1,nd_u(iurb)
+! tsk=tsk+tg(id,ng_u)/nd_u(iurb)
+! enddo
+
+! Calculation of the length scale taking into account the buildings effects
+
+ call interp_length(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z_u,z,ss,ws,bs,dlg,dl_u)
+
+ return
+ end subroutine BEP1D
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine param(iurb,nz,nd, &
+ csg_u,csg,alag_u,alag,csr_u,csr, &
+ alar_u,alar,csw_u,csw,alaw_u,alaw, &
+ ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0, &
+ strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb)
+
+! ----------------------------------------------------------------------
+! This routine prepare some usefull parameters
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer iurb ! Current urban class
+ integer nz ! Number of vertical urban levels in the current class
+ integer nd ! Number of street direction for the current urban class
+ real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1]
+ real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1]
+ real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1]
+ real bs_u(ndm,nurbm) ! Building width
+ real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1]
+ real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1]
+ real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1]
+ real drst_u(ndm,nurbm) ! Street direction
+ real strd_u(ndm,nurbm) ! Street length
+ real ws_u(ndm,nurbm) ! Street width
+ real z0g_u(nurbm) ! The ground's roughness length
+ real z0r_u(nurbm) ! The roof's roughness length
+ real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to "z"
+ real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to "z"
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real alag(ng_u) ! Ground thermal diffusivity at each ground levels
+ real alar(nwr_u) ! Roof thermal diffusivity at each roof levels
+ real alaw(nwr_u) ! Wall thermal diffusivity at each wall levels
+ real csg(ng_u) ! Specific heat of the ground material at each ground levels
+ real csr(nwr_u) ! Specific heat of the roof material at each roof levels
+ real csw(nwr_u) ! Specific heat of the wall material at each wall levels
+ real bs(ndm) ! Building width for the current urban class
+ real drst(ndm) ! street directions for the current urban class
+ real strd(ndm) ! Street lengths for the current urban class
+ real ws(ndm) ! Street widths of the current urban class
+ real z0(ndm,nz_um) ! Roughness lengths "profiles"
+ real ss(nz_um) ! Probability to have a building with height h
+ real pb(nz_um) ! Probability to have a building with an height equal
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer id,ig,ir,iw,iz
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+!
+!Initialize the variables
+!
+ ss=0.
+ pb=0.
+ csg=0.
+ alag=0.
+ csr=0.
+ alar=0.
+ csw=0.
+ alaw=0.
+ z0=0.
+ ws=0.
+ bs=0.
+ strd=0.
+ drst=0.
+
+ do iz=1,nz+1
+ ss(iz)=ss_u(iz,iurb)
+ pb(iz)=pb_u(iz,iurb)
+ end do
+
+ do ig=1,ng_u
+ csg(ig)=csg_u(iurb)
+ alag(ig)=alag_u(iurb)
+ enddo
+
+ do ir=1,nwr_u
+ csr(ir)=csr_u(iurb)
+ alar(ir)=alar_u(iurb)
+ enddo
+
+ do iw=1,nwr_u
+ csw(iw)=csw_u(iurb)
+ alaw(iw)=alaw_u(iurb)
+ enddo
+
+ do id=1,nd
+ z0(id,1)=z0g_u(iurb)
+ do iz=2,nz+1
+ z0(id,iz)=z0r_u(iurb)
+ enddo
+ enddo
+
+ do id=1,nd
+ ws(id)=ws_u(id,iurb)
+ bs(id)=bs_u(id,iurb)
+ strd(id)=strd_u(id,iurb)
+ drst(id)=drst_u(id,iurb)
+ enddo
+
+
+ return
+ end subroutine param
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine interpol(kms,kme,kts,kte,nz_u,z,z_u,c,c_u)
+
+! ----------------------------------------------------------------------
+! This routine interpolate para
+! meters from the "mesoscale grid" to
+! the "urban grid".
+! See p300 Appendix B.1 of the BLM paper.
+! ----------------------------------------------------------------------
+
+ implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+ integer kts,kte,kms,kme
+ real z(kms:kme) ! Altitude of the cell interface
+ real c(kms:kme) ! Parameter which has to be interpolated
+! Data relative to the "urban grid"
+ integer nz_u ! Number of levels
+!! real z_u(nz_u+1) ! Altitude of the cell interface
+ real z_u(nz_um) ! Altitude of the cell interface
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+!! real c_u(nz_u) ! Interpolated paramters in the "urban grid"
+ real c_u(nz_um) ! Interpolated paramters in the "urban grid"
+
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer iz_u,iz
+ real ctot,dz
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+ do iz_u=1,nz_u
+ ctot=0.
+ do iz=kts,kte
+ dz=max(min(z(iz+1),z_u(iz_u+1))-max(z(iz),z_u(iz_u)),0.)
+ ctot=ctot+c(iz)*dz
+ enddo
+ c_u(iz_u)=ctot/(z_u(iz_u+1)-z_u(iz_u))
+ enddo
+
+ return
+ end subroutine interpol
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, &
+ tw,tg,albg,albw,emw,emg, &
+ fww,fwg,fgw,fsw,fsg, &
+ zr,deltar,ah, &
+ rs,rl,rsw,rsg,rlw,rlg)
+
+! ----------------------------------------------------------------------
+! This routine computes the modification of the short wave and
+! long wave radiation due to the buildings.
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer iurb ! current urban class
+ integer nd ! Number of street direction for the current urban class
+ integer nz_u ! Number of layer in the urban grid
+ real z(nz_um) ! Height of the urban grid levels
+ real ws(ndm) ! Street widths of the current urban class
+ real drst(ndm) ! street directions for the current urban class
+ real strd(ndm) ! Street lengths for the current urban class
+ real ss(nz_um) ! probability to have a building with height h
+ real pb(nz_um) ! probability to have a building with an height equal
+ real tw(2*ndm,nz_um,nwr_u) ! Temperature in each layer of the wall [K]
+ real tg(ndm,ng_u) ! Temperature in each layer of the ground [K]
+ real albg ! Albedo of the ground for the current urban class
+ real albw ! Albedo of the wall for the current urban class
+ real emg ! Emissivity of ground for the current urban class
+ real emw ! Emissivity of wall for the current urban class
+ real fgw(nz_um,ndm,nurbm) ! View factors from ground to wall
+ real fsg(ndm,nurbm) ! View factors from sky to ground
+ real fsw(nz_um,ndm,nurbm) ! View factors from sky to wall
+ real fws(nz_um,ndm,nurbm) ! View factors from wall to sky
+ real fwg(nz_um,ndm,nurbm) ! View factors from wall to ground
+ real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+ real ah ! Hour angle (it should come from the radiation routine)
+ real zr ! zenith angle
+ real deltar ! Declination of the sun
+ real rs ! solar radiation
+ real rl ! downward flux of the longwave radiation
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real rlg(ndm) ! Long wave radiation at the ground
+ real rlw(2*ndm,nz_um) ! Long wave radiation at the walls
+ real rsg(ndm) ! Short wave radiation at the ground
+ real rsw(2*ndm,nz_um) ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+
+ integer id,iz
+
+! Calculation of the shadow effects
+
+ call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, &
+ rs,rsw,rsg)
+
+! Calculation of the reflection effects
+ do id=1,nd
+ call long_rad(iurb,nz_u,id,emw,emg, &
+ fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb)
+
+ call short_rad(iurb,nz_u,id,albw,albg,fwg,fww,fgw,rsg,rsw,pb)
+
+ enddo
+
+ return
+ end subroutine modif_rad
+
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine surf_temp(nz_u,nd,pr,dt,ss,rs,rl,rsg,rlg,rsw,rlw, &
+ tg,alag,csg,emg,albg,ptg,sfg,gfg, &
+ tr,alar,csr,emr,albr,ptr,sfr,gfr, &
+ tw,alaw,csw,emw,albw,ptw,sfw,gfw)
+
+
+! ----------------------------------------------------------------------
+! Computation of the surface temperatures for walls, ground and roofs
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer nz_u ! Number of vertical layers defined in the urban grid
+ integer nd ! Number of street direction for the current urban class
+ real alag(ng_u) ! Ground thermal diffusivity for the current urban class [m^2 s^-1]
+ real alar(nwr_u) ! Roof thermal diffusivity for the current urban class [m^2 s^-1]
+ real alaw(nwr_u) ! Wall thermal diffusivity for the current urban class [m^2 s^-1]
+ real albg ! Albedo of the ground for the current urban class
+ real albr ! Albedo of the roof for the current urban class
+ real albw ! Albedo of the wall for the current urban class
+ real csg(ng_u) ! Specific heat of the ground material of the current urban class [J m^3 K^-1]
+ real csr(nwr_u) ! Specific heat of the roof material for the current urban class [J m^3 K^-1]
+ real csw(nwr_u) ! Specific heat of the wall material for the current urban class [J m^3 K^-1]
+ real dt ! Time step
+ real emg ! Emissivity of ground for the current urban class
+ real emr ! Emissivity of roof for the current urban class
+ real emw ! Emissivity of wall for the current urban class
+ real pr(nz_um) ! Air pressure
+ real rs ! Solar radiation
+ real rl ! Downward flux of the longwave radiation
+ real rlg(ndm) ! Long wave radiation at the ground
+ real rlw(2*ndm,nz_um) ! Long wave radiation at the walls
+ real rsg(ndm) ! Short wave radiation at the ground
+ real rsw(2*ndm,nz_um) ! Short wave radiation at the walls
+ real sfg(ndm) ! Sensible heat flux from ground (road)
+ real sfr(ndm,nz_um) ! Sensible heat flux from roofs
+ real sfw(2*ndm,nz_um) ! Sensible heat flux from walls
+ real gfg(ndm) ! Heat flux transferred from the surface of the ground (road) toward the interior
+ real gfr(ndm,nz_um) ! Heat flux transferred from the surface of the roof toward the interior
+ real gfw(2*ndm,nz_um) ! Heat flux transfered from the surface of the walls toward the interior
+ real ss(nz_um) ! Probability to have a building with height h
+ real tg(ndm,ng_u) ! Temperature in each layer of the ground [K]
+ real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K]
+ real tw(2*ndm,nz_um,nwr_u) ! Temperature in each layer of the wall [K]
+
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real ptg(ndm) ! Ground potential temperatures
+ real ptr(ndm,nz_um) ! Roof potential temperatures
+ real ptw(2*ndm,nz_um) ! Walls potential temperatures
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer id,ig,ir,iw,iz
+
+ real rtg(ndm) ! Total radiation at ground(road) surface (solar+incoming long+outgoing long)
+ real rtr(ndm,nz_um) ! Total radiation at roof surface (solar+incoming long+outgoing long)
+ real rtw(2*ndm,nz_um) ! Radiation at walls surface (solar+incoming long+outgoing long)
+ real tg_tmp(ng_u)
+ real tr_tmp(nwr_u)
+ real tw_tmp(nwr_u)
+
+ real dzg_u(ng_u) ! Layer sizes in the ground
+
+ real dzr_u(nwr_u) ! Layers sizes in the roof
+
+ real dzw_u(nwr_u) ! Layer sizes in the wall
+
+
+ data dzg_u /0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/
+ data dzr_u /0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.01,0.005,0.0025/
+ data dzw_u /0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.01,0.005,0.0025/
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+
+
+ do id=1,nd
+
+! Calculation for the ground surfaces
+ do ig=1,ng_u
+ tg_tmp(ig)=tg(id,ig)
+ end do
+!
+ call soil_temp(ng_u,dzg_u,tg_tmp,ptg(id),alag,csg, &
+ rsg(id),rlg(id),pr(1), &
+ dt,emg,albg, &
+ rtg(id),sfg(id),gfg(id))
+ do ig=1,ng_u
+ tg(id,ig)=tg_tmp(ig)
+ end do
+
+! Calculation for the roofs surfaces
+
+ do iz=2,nz_u
+
+ if(ss(iz).gt.0.)then
+ do ir=1,nwr_u
+ tr_tmp(ir)=tr(id,iz,ir)
+ end do
+
+ call soil_temp(nwr_u,dzr_u,tr_tmp,ptr(id,iz), &
+ alar,csr,rs,rl,pr(iz),dt,emr,albr, &
+ rtr(id,iz),sfr(id,iz),gfr(id,iz))
+ do ir=1,nwr_u
+ tr(id,iz,ir)=tr_tmp(ir)
+ end do
+
+ end if
+
+ end do !iz
+
+! Calculation for the walls surfaces
+
+ do iz=1,nz_u
+
+ do iw=1,nwr_u
+ tw_tmp(iw)=tw(2*id-1,iz,iw)
+ end do
+ call soil_temp(nwr_u,dzw_u,tw_tmp,ptw(2*id-1,iz),alaw, &
+ csw, &
+ rsw(2*id-1,iz),rlw(2*id-1,iz), &
+ pr(iz),dt,emw, &
+ albw,rtw(2*id-1,iz),sfw(2*id-1,iz),gfw(2*id-1,iz))
+
+ do iw=1,nwr_u
+ tw(2*id-1,iz,iw)=tw_tmp(iw)
+ end do
+
+ do iw=1,nwr_u
+ tw_tmp(iw)=tw(2*id,iz,iw)
+ end do
+
+ call soil_temp(nwr_u,dzw_u,tw_tmp,ptw(2*id,iz),alaw, &
+ csw, &
+ rsw(2*id,iz),rlw(2*id,iz), &
+ pr(iz),dt,emw, &
+ albw,rtw(2*id,iz),sfw(2*id,iz),gfw(2*id,iz))
+ do iw=1,nwr_u
+ tw(2*id,iz,iw)=tw_tmp(iw)
+ end do
+
+ end do !iz
+
+ end do !id
+
+ return
+ end subroutine surf_temp
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine buildings(nd,nz,z0,ua_u,va_u,pt_u,pt0_u, &
+ ptg,ptr,da_u,ptw, &
+ drst,uva_u,vva_u,uvb_u,vvb_u, &
+ tva_u,tvb_u,evb_u, &
+ uhb_u,vhb_u,thb_u,ehb_u,ss,dt)
+
+! ----------------------------------------------------------------------
+! This routine computes the sources or sinks of the different quantities
+! on the urban grid. The actual calculation is done in the subroutines
+! called flux_wall, and flux_flat.
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer nd ! Number of street direction for the current urban class
+ integer nz ! number of vertical space steps
+ real ua_u(nz_um) ! Wind speed in the x direction on the urban grid
+ real va_u(nz_um) ! Wind speed in the y direction on the urban grid
+ real da_u(nz_um) ! air density on the urban grid
+ real drst(ndm) ! Street directions for the current urban class
+ real dz
+ real pt_u(nz_um) ! Potential temperature on the urban grid
+ real pt0_u(nz_um) ! reference potential temperature on the urban grid
+ real ptg(ndm) ! Ground potential temperatures
+ real ptr(ndm,nz_um) ! Roof potential temperatures
+ real ptw(2*ndm,nz_um) ! Walls potential temperatures
+ real ss(nz_um) ! probability to have a building with height h
+ real z0(ndm,nz_um) ! Roughness lengths "profiles"
+ real dt ! time step
+
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+! vertical surfaces (walls) and horizontal surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+! Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+
+ real uhb_u(ndm,nz_um) ! U (wind component) Horizontal surfaces, B (explicit) term
+ real uva_u(2*ndm,nz_um) ! U (wind component) Vertical surfaces, A (implicit) term
+ real uvb_u(2*ndm,nz_um) ! U (wind component) Vertical surfaces, B (explicit) term
+ real vhb_u(ndm,nz_um) ! V (wind component) Horizontal surfaces, B (explicit) term
+ real vva_u(2*ndm,nz_um) ! V (wind component) Vertical surfaces, A (implicit) term
+ real vvb_u(2*ndm,nz_um) ! V (wind component) Vertical surfaces, B (explicit) term
+ real thb_u(ndm,nz_um) ! Temperature Horizontal surfaces, B (explicit) term
+ real tva_u(2*ndm,nz_um) ! Temperature Vertical surfaces, A (implicit) term
+ real tvb_u(2*ndm,nz_um) ! Temperature Vertical surfaces, B (explicit) term
+ real ehb_u(ndm,nz_um) ! Energy (TKE) Horizontal surfaces, B (explicit) term
+ real evb_u(2*ndm,nz_um) ! Energy (TKE) Vertical surfaces, B (explicit) term
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer id,iz
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+ dz=dz_u
+
+ do id=1,nd
+
+! Calculation at the ground surfaces
+ call flux_flat(dz,z0(id,1),ua_u(1),va_u(1),pt_u(1),pt0_u(1), &
+ ptg(id),uhb_u(id,1), &
+ vhb_u(id,1),thb_u(id,1),ehb_u(id,1))
+
+! Calculation at the roof surfaces
+ do iz=2,nz
+ if(ss(iz).gt.0)then
+ call flux_flat(dz,z0(id,iz),ua_u(iz), &
+ va_u(iz),pt_u(iz),pt0_u(iz), &
+ ptr(id,iz),uhb_u(id,iz), &
+ vhb_u(id,iz),thb_u(id,iz),ehb_u(id,iz))
+ else
+ uhb_u(id,iz) = 0.0
+ vhb_u(id,iz) = 0.0
+ thb_u(id,iz) = 0.0
+ ehb_u(id,iz) = 0.0
+ endif
+ end do
+
+! Calculation at the wall surfaces
+ do iz=1,nz
+ call flux_wall(ua_u(iz),va_u(iz),pt_u(iz),da_u(iz), &
+ ptw(2*id-1,iz), &
+ uva_u(2*id-1,iz),vva_u(2*id-1,iz), &
+ uvb_u(2*id-1,iz),vvb_u(2*id-1,iz), &
+ tva_u(2*id-1,iz),tvb_u(2*id-1,iz), &
+ evb_u(2*id-1,iz),drst(id),dt)
+
+ call flux_wall(ua_u(iz),va_u(iz),pt_u(iz),da_u(iz), &
+ ptw(2*id,iz), &
+ uva_u(2*id,iz),vva_u(2*id,iz), &
+ uvb_u(2*id,iz),vvb_u(2*id,iz), &
+ tva_u(2*id,iz),tvb_u(2*id,iz), &
+ evb_u(2*id,iz),drst(id),dt)
+!
+
+ end do
+
+ end do
+
+ return
+ end subroutine buildings
+
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine urban_meso(nd,kms,kme,kts,kte,nz_u,z,dz,z_u,pb,ss,bs,ws,sf,vl, &
+ uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, &
+ uhb_u,vhb_u,thb_u,ehb_u, &
+ a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e)
+
+! ----------------------------------------------------------------------
+! This routine interpolates the parameters from the "urban grid" to the
+! "mesoscale grid".
+! See p300-301 Appendix B.2 of the BLM paper.
+! ----------------------------------------------------------------------
+
+ implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+ integer kms,kme,kts,kte
+ real z(kms:kme) ! Altitude above the ground of the cell interface
+ real dz(kms:kme) ! Vertical space steps
+
+! Data relative to the "uban grid"
+ integer nz_u ! Number of layer in the urban grid
+ integer nd ! Number of street direction for the current urban class
+ real bs(ndm) ! Building widths of the current urban class
+ real ws(ndm) ! Street widths of the current urban class
+ real z_u(nz_um) ! Height of the urban grid levels
+ real pb(nz_um) ! Probability to have a building with an height equal
+ real ss(nz_um) ! Probability to have a building with height h
+ real uhb_u(ndm,nz_um) ! U (x-wind component) Horizontal surfaces, B (explicit) term
+ real uva_u(2*ndm,nz_um) ! U (x-wind component) Vertical surfaces, A (implicit) term
+ real uvb_u(2*ndm,nz_um) ! U (x-wind component) Vertical surfaces, B (explicit) term
+ real vhb_u(ndm,nz_um) ! V (y-wind component) Horizontal surfaces, B (explicit) term
+ real vva_u(2*ndm,nz_um) ! V (y-wind component) Vertical surfaces, A (implicit) term
+ real vvb_u(2*ndm,nz_um) ! V (y-wind component) Vertical surfaces, B (explicit) term
+ real thb_u(ndm,nz_um) ! Temperature Horizontal surfaces, B (explicit) term
+ real tva_u(2*ndm,nz_um) ! Temperature Vertical surfaces, A (implicit) term
+ real tvb_u(2*ndm,nz_um) ! Temperature Vertical surfaces, B (explicit) term
+ real ehb_u(ndm,nz_um) ! Energy (TKE) Horizontal surfaces, B (explicit) term
+ real evb_u(2*ndm,nz_um) ! Energy (TKE) Vertical surfaces, B (explicit) term
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+ real sf(kms:kme) ! Surface of the "mesoscale grid" cells taking into account the buildings
+ real vl(kms:kme) ! Volume of the "mesoscale grid" cells taking into account the buildings
+ real a_u(kms:kme) ! Implicit component of the momentum sources or sinks in the X-direction
+ real a_v(kms:kme) ! Implicit component of the momentum sources or sinks in the Y-direction
+ real a_t(kms:kme) ! Implicit component of the heat sources or sinks
+ real a_e(kms:kme) ! Implicit component of the TKE sources or sinks
+ real b_u(kms:kme) ! Explicit component of the momentum sources or sinks in the X-direction
+ real b_v(kms:kme) ! Explicit component of the momentum sources or sinks in the Y-direction
+ real b_t(kms:kme) ! Explicit component of the heat sources or sinks
+ real b_e(kms:kme) ! Explicit component of the TKE sources or sinks
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ real dzz
+ real fact
+ integer id,iz,iz_u
+ real se,sr,st,su,sv
+ real uet(kms:kme) ! Contribution to TKE due to walls
+ real veb,vta,vtb,vte,vtot,vua,vub,vva,vvb
+
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+! initialisation
+
+ do iz=kts,kte
+ a_u(iz)=0.
+ a_v(iz)=0.
+ a_t(iz)=0.
+ a_e(iz)=0.
+ b_u(iz)=0.
+ b_v(iz)=0.
+ b_e(iz)=0.
+ b_t(iz)=0.
+ uet(iz)=0.
+ end do
+
+! horizontal surfaces
+ do iz=kts,kte
+ sf(iz)=0.
+ vl(iz)=0.
+ enddo
+ sf(kte+1)=0.
+
+ do id=1,nd
+ do iz=kts+1,kte+1
+ sr=0.
+ do iz_u=2,nz_u
+ if(z(iz).lt.z_u(iz_u).and.z(iz).ge.z_u(iz_u-1))then
+ sr=pb(iz_u)
+ endif
+ enddo
+ sf(iz)=sf(iz)+((ws(id)+(1.-sr)*bs(id))/(ws(id)+bs(id)))/nd
+ enddo
+ enddo
+
+! volume
+ do iz=kts,kte
+ do id=1,nd
+ vtot=0.
+ do iz_u=1,nz_u
+ dzz=max(min(z_u(iz_u+1),z(iz+1))-max(z_u(iz_u),z(iz)),0.)
+ vtot=vtot+pb(iz_u+1)*dzz
+ enddo
+ vtot=vtot/(z(iz+1)-z(iz))
+ vl(iz)=vl(iz)+(1.-vtot*bs(id)/(ws(id)+bs(id)))/nd
+ enddo
+ enddo
+
+! horizontal surface impact
+
+ do id=1,nd
+
+ fact=1./vl(kts)/dz(kts)*ws(id)/(ws(id)+bs(id))/nd
+ b_t(kts)=b_t(kts)+thb_u(id,1)*fact
+ b_u(kts)=b_u(kts)+uhb_u(id,1)*fact
+ b_v(kts)=b_v(kts)+vhb_u(id,1)*fact
+ b_e(kts)=b_e(kts)+ehb_u(id,1)*fact*(z_u(2)-z_u(1))
+
+ do iz=kts,kte
+ st=0.
+ su=0.
+ sv=0.
+ se=0.
+ do iz_u=2,nz_u
+ if(z(iz).le.z_u(iz_u).and.z(iz+1).gt.z_u(iz_u))then
+ st=st+ss(iz_u)*thb_u(id,iz_u)
+ su=su+ss(iz_u)*uhb_u(id,iz_u)
+ sv=sv+ss(iz_u)*vhb_u(id,iz_u)
+ se=se+ss(iz_u)*ehb_u(id,iz_u)*(z_u(iz_u+1)-z_u(iz_u))
+ endif
+ enddo
+
+ fact=bs(id)/(ws(id)+bs(id))/vl(iz)/dz(iz)/nd
+ b_t(iz)=b_t(iz)+st*fact
+ b_u(iz)=b_u(iz)+su*fact
+ b_v(iz)=b_v(iz)+sv*fact
+ b_e(iz)=b_e(iz)+se*fact
+ enddo
+ enddo
+
+! vertical surface impact
+
+ do iz=kts,kte
+ uet(iz)=0.
+ do id=1,nd
+ vtb=0.
+ vta=0.
+ vua=0.
+ vub=0.
+ vva=0.
+ vvb=0.
+ veb=0.
+ vte=0.
+ do iz_u=1,nz_u
+ dzz=max(min(z_u(iz_u+1),z(iz+1))-max(z_u(iz_u),z(iz)),0.)
+ fact=dzz/(ws(id)+bs(id))
+ vtb=vtb+pb(iz_u+1)* &
+ (tvb_u(2*id-1,iz_u)+tvb_u(2*id,iz_u))*fact
+ vta=vta+pb(iz_u+1)* &
+ (tva_u(2*id-1,iz_u)+tva_u(2*id,iz_u))*fact
+ vua=vua+pb(iz_u+1)* &
+ (uva_u(2*id-1,iz_u)+uva_u(2*id,iz_u))*fact
+ vva=vva+pb(iz_u+1)* &
+ (vva_u(2*id-1,iz_u)+vva_u(2*id,iz_u))*fact
+ vub=vub+pb(iz_u+1)* &
+ (uvb_u(2*id-1,iz_u)+uvb_u(2*id,iz_u))*fact
+ vvb=vvb+pb(iz_u+1)* &
+ (vvb_u(2*id-1,iz_u)+vvb_u(2*id,iz_u))*fact
+ veb=veb+pb(iz_u+1)* &
+ (evb_u(2*id-1,iz_u)+evb_u(2*id,iz_u))*fact
+ enddo
+
+ fact=1./vl(iz)/dz(iz)/nd
+ b_t(iz)=b_t(iz)+vtb*fact
+ a_t(iz)=a_t(iz)+vta*fact
+ a_u(iz)=a_u(iz)+vua*fact
+ a_v(iz)=a_v(iz)+vva*fact
+ b_u(iz)=b_u(iz)+vub*fact
+ b_v(iz)=b_v(iz)+vvb*fact
+ b_e(iz)=b_e(iz)+veb*fact
+ uet(iz)=uet(iz)+vte*fact
+ enddo
+ enddo
+
+
+
+ return
+ end subroutine urban_meso
+
+! ===6=8===============================================================72
+
+! ===6=8===============================================================72
+
+ subroutine interp_length(nd,kms,kme,kts,kte,nz_u,z_u,z,ss,ws,bs, &
+ dlg,dl_u)
+
+! ----------------------------------------------------------------------
+! Calculation of the length scales
+! See p272-274 formula (22) and (24) of the BLM paper
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer kms,kme,kts,kte
+ real z(kms:kme) ! Altitude above the ground of the cell interface
+ integer nd ! Number of street direction for the current urban class
+ integer nz_u ! Number of levels in the "urban grid"
+ real z_u(nz_um) ! Height of the urban grid levels
+ real bs(ndm) ! Building widths of the current urban class
+ real ss(nz_um) ! Probability to have a building with height h
+ real ws(ndm) ! Street widths of the current urban class
+
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real dlg(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper).
+ real dl_u(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper).
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ real dlgtmp
+ integer id,iz,iz_u
+ real sftot
+ real ulu,ssl
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+ do iz=kts,kte
+ ulu=0.
+ ssl=0.
+ do id=1,nd
+ do iz_u=2,nz_u
+ if(z_u(iz_u).gt.z(iz))then
+ ulu=ulu+ss(iz_u)/z_u(iz_u)/nd
+ ssl=ssl+ss(iz_u)/nd
+ endif
+ enddo
+ enddo
+
+ if(ulu.ne.0)then
+ dl_u(iz)=ssl/ulu
+ else
+ dl_u(iz)=0.
+ endif
+ enddo
+
+
+ do iz=kts,kte
+ dlg(iz)=0.
+ do id=1,nd
+ sftot=ws(id)
+ dlgtmp=ws(id)/((z(iz)+z(iz+1))/2.)
+ do iz_u=1,nz_u
+ if((z(iz)+z(iz+1))/2..gt.z_u(iz_u))then
+ dlgtmp=dlgtmp+ss(iz_u)*bs(id)/ &
+ ((z(iz)+z(iz+1))/2.-z_u(iz_u))
+ sftot=sftot+ss(iz_u)*bs(id)
+ endif
+ enddo
+ dlg(iz)=dlg(iz)+dlgtmp/sftot/nd
+ enddo
+ dlg(iz)=1./dlg(iz)
+ enddo
+
+ return
+ end subroutine interp_length
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, &
+ rs,rsw,rsg)
+
+! ----------------------------------------------------------------------
+! Modification of short wave radiation to take into account
+! the shadow produced by the buildings
+! ----------------------------------------------------------------------
+
+ implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer nd ! Number of street direction for the current urban class
+ integer nz_u ! number of vertical layers defined in the urban grid
+ real ah ! Hour angle (it should come from the radiation routine)
+ real deltar ! Declination of the sun
+ real drst(ndm) ! street directions for the current urban class
+ real rs ! solar radiation
+ real ss(nz_um) ! probability to have a building with height h
+ real pb(nz_um) ! Probability that a building has an height greater or equal to h
+ real ws(ndm) ! Street width of the current urban class
+ real z(nz_um) ! Height of the urban grid levels
+ real zr ! zenith angle
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real rsg(ndm) ! Short wave radiation at the ground
+ real rsw(2*ndm,nz_um) ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer id,iz,jz
+ real aae,aaw,bbb,phix,rd,rtot,wsd
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+ if(rs.eq.0.or.sin(zr).eq.1)then
+ do id=1,nd
+ rsg(id)=0.
+ do iz=1,nz_u
+ rsw(2*id-1,iz)=0.
+ rsw(2*id,iz)=0.
+ enddo
+ enddo
+ else
+!test
+ if(abs(sin(zr)).gt.1.e-10)then
+ if(cos(deltar)*sin(ah)/sin(zr).ge.1)then
+ bbb=pi/2.
+ elseif(cos(deltar)*sin(ah)/sin(zr).le.-1)then
+ bbb=-pi/2.
+ else
+ bbb=asin(cos(deltar)*sin(ah)/sin(zr))
+ endif
+ else
+ if(cos(deltar)*sin(ah).ge.0)then
+ bbb=pi/2.
+ elseif(cos(deltar)*sin(ah).lt.0)then
+ bbb=-pi/2.
+ endif
+ endif
+
+ phix=zr
+
+ do id=1,nd
+
+ rsg(id)=0.
+
+ aae=bbb-drst(id)
+ aaw=bbb-drst(id)+pi
+
+ do iz=1,nz_u
+ rsw(2*id-1,iz)=0.
+ rsw(2*id,iz)=0.
+ if(pb(iz+1).gt.0.)then
+ do jz=1,nz_u
+ if(abs(sin(aae)).gt.1.e-10)then
+ call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae, &
+ ws(id),rd)
+ rsw(2*id-1,iz)=rsw(2*id-1,iz)+rs*rd*ss(jz+1)/pb(iz+1)
+
+ endif
+
+ if(abs(sin(aaw)).gt.1.e-10)then
+ call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw, &
+ ws(id),rd)
+ rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1)/pb(iz+1)
+
+ endif
+ enddo
+ endif
+ enddo
+ if(abs(sin(aae)).gt.1.e-10)then
+ wsd=abs(ws(id)/sin(aae))
+
+ do jz=1,nz_u
+ rd=max(0.,wsd-z(jz+1)*tan(phix))
+ rsg(id)=rsg(id)+rs*rd*ss(jz+1)/wsd
+ enddo
+ rtot=0.
+
+ do iz=1,nz_u
+ rtot=rtot+(rsw(2*id,iz)+rsw(2*id-1,iz))* &
+ (z(iz+1)-z(iz))
+ enddo
+ rtot=rtot+rsg(id)*ws(id)
+ else
+ rsg(id)=rs
+ endif
+
+ enddo
+ endif
+
+ return
+ end subroutine shadow_mas
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine shade_wall(z1,z2,hu,phix,aa,ws,rd)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of a shadow induced by a building of
+! height hu, on a portion of wall between z1 and z2. See equation A10,
+! and correction described below formula A11, and figure A1. Basically rd
+! is the ratio between the horizontal surface illuminated and the portion
+! of wall. Referring to figure A1, multiplying radiation flux density on
+! a horizontal surface (rs) by x1-x2 we have the radiation energy per
+! unit time. Dividing this by z2-z1, we obtain the radiation flux
+! density reaching the portion of the wall between z2 and z1
+! (everything is assumed in 2D)
+! ----------------------------------------------------------------------
+
+ implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ real aa ! Angle between the sun direction and the face of the wall (A12)
+ real hu ! Height of the building that generates the shadow
+ real phix ! Solar zenith angle
+ real ws ! Width of the street
+ real z1 ! Height of the level z(iz)
+ real z2 ! Height of the level z(iz+1)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real rd ! Ratio between (x1-x2)/(z2-z1), see Fig. 1A.
+ ! Multiplying rd by rs (radiation flux
+ ! density on a horizontal surface) gives
+ ! the radiation flux density on the
+ ! portion of wall between z1 and z2.
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ real x1,x2 ! x1,x2 see Fig. A1.
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+ x1=min((hu-z1)*tan(phix),max(0.,ws/sin(aa)))
+
+ x2=max((hu-z2)*tan(phix),0.)
+
+ rd=max(0.,sin(aa)*(max(0.,x1-x2))/(z2-z1))
+
+ return
+ end subroutine shade_wall
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine long_rad(iurb,nz_u,id,emw,emg, &
+ fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of the reflections of long-wave
+! radiation in the street canyon by solving the system
+! of 2*nz_u+1 eqn. in 2*nz_u+1
+! unkonwn defined in A4, A5 and A6 of the paper (pages 295 and 296).
+! The system is solved by solving A X= B,
+! with A matrix B vector, and X solution.
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ real emg ! Emissivity of ground for the current urban class
+ real emw ! Emissivity of wall for the current urban class
+ real fgw(nz_um,ndm,nurbm) ! View factors from ground to wall
+ real fsg(ndm,nurbm) ! View factors from sky to ground
+ real fsw(nz_um,ndm,nurbm) ! View factors from sky to wall
+ real fwg(nz_um,ndm,nurbm) ! View factors from wall to ground
+ real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+ integer id ! Current street direction
+ integer iurb ! Current urban class
+ integer nz_u ! Number of layer in the urban grid
+ real pb(nz_um) ! Probability to have a building with an height equal
+ real rl ! Downward flux of the longwave radiation
+ real tg(ndm,ng_u) ! Temperature in each layer of the ground [K]
+ real tw(2*ndm,nz_um,nwr_u) ! Temperature in each layer of the wall [K]
+
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real rlg(ndm) ! Long wave radiation at the ground
+ real rlw(2*ndm,nz_um) ! Long wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer i,j
+ real aaa(2*nz_um+1,2*nz_um+1) ! terms of the matrix
+ real bbb(2*nz_um+1) ! terms of the vector
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+
+! west wall
+
+ do i=1,nz_u
+
+ do j=1,nz_u
+ aaa(i,j)=0.
+ enddo
+
+ aaa(i,i)=1.
+
+ do j=nz_u+1,2*nz_u
+ aaa(i,j)=-(1.-emw)*fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1)
+ enddo
+
+!! aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)*pb(i+1)
+ aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)
+
+ bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg(id,ng_u)**4
+ do j=1,nz_u
+ bbb(i)=bbb(i)+pb(j+1)*emw*sigma*fww(j,i,id,iurb)* &
+ tw(2*id,j,nwr_u)**4+ &
+ fww(j,i,id,iurb)*rl*(1.-pb(j+1))
+ enddo
+
+ enddo
+
+! east wall
+
+ do i=1+nz_u,2*nz_u
+
+ do j=1,nz_u
+ aaa(i,j)=-(1.-emw)*fww(j,i-nz_u,id,iurb)*pb(j+1)
+ enddo
+
+ do j=1+nz_u,2*nz_u
+ aaa(i,j)=0.
+ enddo
+
+ aaa(i,i)=1.
+
+!! aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb)*pb(i-nz_u+1)
+ aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb)
+
+ bbb(i)=fsw(i-nz_u,id,iurb)*rl+ &
+ emg*fgw(i-nz_u,id,iurb)*sigma*tg(id,ng_u)**4
+
+ do j=1,nz_u
+ bbb(i)=bbb(i)+pb(j+1)*emw*sigma*fww(j,i-nz_u,id,iurb)* &
+ tw(2*id-1,j,nwr_u)**4+ &
+ fww(j,i-nz_u,id,iurb)*rl*(1.-pb(j+1))
+ enddo
+
+ enddo
+
+! ground
+ do j=1,nz_u
+ aaa(2*nz_u+1,j)=-(1.-emw)*fwg(j,id,iurb)*pb(j+1)
+ enddo
+
+ do j=nz_u+1,2*nz_u
+ aaa(2*nz_u+1,j)=-(1.-emw)*fwg(j-nz_u,id,iurb)*pb(j-nz_u+1)
+ enddo
+
+ aaa(2*nz_u+1,2*nz_u+1)=1.
+
+ bbb(2*nz_u+1)=fsg(id,iurb)*rl
+
+ do i=1,nz_u
+ bbb(2*nz_u+1)=bbb(2*nz_u+1)+emw*sigma*fwg(i,id,iurb)*pb(i+1)* &
+ (tw(2*id-1,i,nwr_u)**4+tw(2*id,i,nwr_u)**4)+ &
+ 2.*fwg(i,id,iurb)*(1.-pb(i+1))*rl
+ enddo
+
+
+
+ call gaussj(aaa,2*nz_u+1,bbb,2*nz_um+1)
+
+ do i=1,nz_u
+ rlw(2*id-1,i)=bbb(i)
+ enddo
+
+ do i=nz_u+1,2*nz_u
+ rlw(2*id,i-nz_u)=bbb(i)
+ enddo
+
+ rlg(id)=bbb(2*nz_u+1)
+
+ return
+ end subroutine long_rad
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine short_rad(iurb,nz_u,id,albw, &
+ albg,fwg,fww,fgw,rsg,rsw,pb)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of the reflections of short-wave
+! (solar) radiation in the street canyon by solving the system
+! of 2*nz_u+1 eqn. in 2*nz_u+1
+! unkonwn defined in A4, A5 and A6 of the paper (pages 295 and 296).
+! The system is solved by solving A X= B,
+! with A matrix B vector, and X solution.
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ real albg ! Albedo of the ground for the current urban class
+ real albw ! Albedo of the wall for the current urban class
+ real fgw(nz_um,ndm,nurbm) ! View factors from ground to wall
+ real fwg(nz_um,ndm,nurbm) ! View factors from wall to ground
+ real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+ integer id ! current street direction
+ integer iurb ! current urban class
+ integer nz_u ! Number of layer in the urban grid
+ real pb(nz_um) ! probability to have a building with an height equal
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real rsg(ndm) ! Short wave radiation at the ground
+ real rsw(2*ndm,nz_um) ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer i,j
+ real aaa(2*nz_um+1,2*nz_um+1) ! terms of the matrix
+ real bbb(2*nz_um+1) ! terms of the vector
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+
+! west wall
+
+ do i=1,nz_u
+ do j=1,nz_u
+ aaa(i,j)=0.
+ enddo
+
+ aaa(i,i)=1.
+
+ do j=nz_u+1,2*nz_u
+ aaa(i,j)=-albw*fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1)
+ enddo
+
+ aaa(i,2*nz_u+1)=-albg*fgw(i,id,iurb)
+ bbb(i)=rsw(2*id-1,i)
+
+ enddo
+
+! east wall
+
+ do i=1+nz_u,2*nz_u
+ do j=1,nz_u
+ aaa(i,j)=-albw*fww(j,i-nz_u,id,iurb)*pb(j+1)
+ enddo
+
+ do j=1+nz_u,2*nz_u
+ aaa(i,j)=0.
+ enddo
+
+ aaa(i,i)=1.
+ aaa(i,2*nz_u+1)=-albg*fgw(i-nz_u,id,iurb)
+ bbb(i)=rsw(2*id,i-nz_u)
+
+ enddo
+
+! ground
+
+ do j=1,nz_u
+ aaa(2*nz_u+1,j)=-albw*fwg(j,id,iurb)*pb(j+1)
+ enddo
+
+ do j=nz_u+1,2*nz_u
+ aaa(2*nz_u+1,j)=-albw*fwg(j-nz_u,id,iurb)*pb(j-nz_u+1)
+ enddo
+
+ aaa(2*nz_u+1,2*nz_u+1)=1.
+ bbb(2*nz_u+1)=rsg(id)
+
+ call gaussj(aaa,2*nz_u+1,bbb,2*nz_um+1)
+
+ do i=1,nz_u
+ rsw(2*id-1,i)=bbb(i)
+ enddo
+
+ do i=nz_u+1,2*nz_u
+ rsw(2*id,i-nz_u)=bbb(i)
+ enddo
+
+ rsg(id)=bbb(2*nz_u+1)
+
+ return
+ end subroutine short_rad
+
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine gaussj(a,n,b,np)
+
+! ----------------------------------------------------------------------
+! This routine solve a linear system of n equations of the form
+! A X = B
+! where A is a matrix a(i,j)
+! B a vector and X the solution
+! In output b is replaced by the solution
+! ----------------------------------------------------------------------
+
+ implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer np
+ real a(np,np)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real b(np)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer nmax
+ parameter (nmax=150)
+
+ real big,dum
+ integer i,icol,irow
+ integer j,k,l,ll,n
+ integer ipiv(nmax)
+ real pivinv
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+ do j=1,n
+ ipiv(j)=0.
+ enddo
+
+ do i=1,n
+ big=0.
+ do j=1,n
+ if(ipiv(j).ne.1)then
+ do k=1,n
+ if(ipiv(k).eq.0)then
+ if(abs(a(j,k)).ge.big)then
+ big=abs(a(j,k))
+ irow=j
+ icol=k
+ endif
+ elseif(ipiv(k).gt.1)then
+ pause 'singular matrix in gaussj'
+ endif
+ enddo
+ endif
+ enddo
+
+ ipiv(icol)=ipiv(icol)+1
+
+ if(irow.ne.icol)then
+ do l=1,n
+ dum=a(irow,l)
+ a(irow,l)=a(icol,l)
+ a(icol,l)=dum
+ enddo
+
+ dum=b(irow)
+ b(irow)=b(icol)
+ b(icol)=dum
+
+ endif
+
+ if(a(icol,icol).eq.0)pause 'singular matrix in gaussj'
+
+ pivinv=1./a(icol,icol)
+ a(icol,icol)=1
+
+ do l=1,n
+ a(icol,l)=a(icol,l)*pivinv
+ enddo
+
+ b(icol)=b(icol)*pivinv
+
+ do ll=1,n
+ if(ll.ne.icol)then
+ dum=a(ll,icol)
+ a(ll,icol)=0.
+ do l=1,n
+ a(ll,l)=a(ll,l)-a(icol,l)*dum
+ enddo
+
+ b(ll)=b(ll)-b(icol)*dum
+
+ endif
+ enddo
+ enddo
+
+ return
+ end subroutine gaussj
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine soil_temp(nz,dz,temp,pt,ala,cs, &
+ rs,rl,press,dt,em,alb,rt,sf,gf)
+
+! ----------------------------------------------------------------------
+! This routine solves the Fourier diffusion equation for heat in
+! the material (wall, roof, or ground). Resolution is done implicitely.
+! Boundary conditions are:
+! - fixed temperature at the interior
+! - energy budget at the surface
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer nz ! Number of layers
+ real ala(nz) ! Thermal diffusivity in each layers [m^2 s^-1]
+ real alb ! Albedo of the surface
+ real cs(nz) ! Specific heat of the material [J m^3 K^-1]
+ real dt ! Time step
+ real em ! Emissivity of the surface
+ real press ! Pressure at ground level
+ real rl ! Downward flux of the longwave radiation
+ real rs ! Solar radiation
+ real sf ! Sensible heat flux at the surface
+ real temp(nz) ! Temperature in each layer [K]
+ real dz(nz) ! Layer sizes [m]
+
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real gf ! Heat flux transferred from the surface toward the interior
+ real pt ! Potential temperature at the surface
+ real rt ! Total radiation at the surface (solar+incoming long+outgoing long)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer iz
+ real a(nz,3)
+ real alpha
+ real c(nz)
+ real cddz(nz+2)
+ real tsig
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+ tsig=temp(nz)
+ alpha=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf
+! Compute cddz=2*cd/dz
+
+ cddz(1)=ala(1)/dz(1)
+ do iz=2,nz
+ cddz(iz)=2.*ala(iz)/(dz(iz)+dz(iz-1))
+ enddo
+! cddz(nz+1)=ala(nz+1)/dz(nz)
+
+ a(1,1)=0.
+ a(1,2)=1.
+ a(1,3)=0.
+ c(1)=temp(1)
+
+ do iz=2,nz-1
+ a(iz,1)=-cddz(iz)*dt/dz(iz)
+ a(iz,2)=1+dt*(cddz(iz)+cddz(iz+1))/dz(iz)
+ a(iz,3)=-cddz(iz+1)*dt/dz(iz)
+ c(iz)=temp(iz)
+ enddo
+
+ a(nz,1)=-dt*cddz(nz)/dz(nz)
+ a(nz,2)=1.+dt*cddz(nz)/dz(nz)
+ a(nz,3)=0.
+ c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz)
+
+
+ call invert(nz,a,c,temp)
+
+
+ pt=temp(nz)*(press/1.e+5)**(-rcp_u)
+
+ rt=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)
+
+! gf=-cddz(nz)*(temp(nz)-temp(nz-1))*cs(nz)
+ gf=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf
+ return
+ end subroutine soil_temp
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine invert(n,a,c,x)
+
+! ----------------------------------------------------------------------
+! Inversion and resolution of a tridiagonal matrix
+! A X = C
+! ----------------------------------------------------------------------
+
+ implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ integer n
+ real a(n,3) ! a(*,1) lower diagonal (Ai,i-1)
+ ! a(*,2) principal diagonal (Ai,i)
+ ! a(*,3) upper diagonal (Ai,i+1)
+ real c(n)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+ real x(n)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ integer i
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+ do i=n-1,1,-1
+ c(i)=c(i)-a(i,3)*c(i+1)/a(i+1,2)
+ a(i,2)=a(i,2)-a(i,3)*a(i+1,1)/a(i+1,2)
+ enddo
+
+ do i=2,n
+ c(i)=c(i)-a(i,1)*c(i-1)/a(i-1,2)
+ enddo
+
+ do i=1,n
+ x(i)=c(i)/a(i,2)
+ enddo
+
+ return
+ end subroutine invert
+
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine flux_wall(ua,va,pt,da,ptw,uva,vva,uvb,vvb, &
+ tva,tvb,evb,drst,dt)
+
+! ----------------------------------------------------------------------
+! This routine computes the surface sources or sinks of momentum, tke,
+! and heat from vertical surfaces (walls).
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+
+! INPUT:
+! -----
+ real drst ! street directions for the current urban class
+ real da ! air density
+ real pt ! potential temperature
+ real ptw ! Walls potential temperatures
+ real ua ! wind speed
+ real va ! wind speed
+
+ real dt !time step
+! OUTPUT:
+! ------
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+! vertical surfaces (walls).
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+! Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+ real uva ! U (wind component) Vertical surfaces, A (implicit) term
+ real uvb ! U (wind component) Vertical surfaces, B (explicit) term
+ real vva ! V (wind component) Vertical surfaces, A (implicit) term
+ real vvb ! V (wind component) Vertical surfaces, B (explicit) term
+ real tva ! Temperature Vertical surfaces, A (implicit) term
+ real tvb ! Temperature Vertical surfaces, B (explicit) term
+ real evb ! Energy (TKE) Vertical surfaces, B (explicit) term
+
+! LOCAL:
+! -----
+ real hc
+ real u_ort
+ real vett
+
+! -------------------------
+! END VARIABLES DEFINITIONS
+! -------------------------
+
+ vett=(ua**2+va**2)**.5
+
+ u_ort=abs((cos(drst)*ua-sin(drst)*va))
+
+ uva=-cdrag*u_ort/2.*cos(drst)*cos(drst)
+ vva=-cdrag*u_ort/2.*sin(drst)*sin(drst)
+
+ uvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*va
+ vvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*ua
+
+ hc=5.678*(1.09+0.23*(vett/0.3048))
+
+ if(hc.gt.da*cp_u/dt)then
+ hc=da*cp_u/dt
+ endif
+
+! tvb=hc*ptw/da/cp_u
+! tva=-hc/da/cp_u
+!!!!!!!!!!!!!!!!!!!!
+! explicit
+ tvb=hc*ptw/da/cp_u-hc/da/cp_u*pt !c
+ tva = 0. !c
+
+ evb=cdrag*(abs(u_ort)**3.)/2.
+
+ return
+ end subroutine flux_wall
+
+! ===6=8===============================================================72
+
+! ===6=8===============================================================72
+
+ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, &
+ uhb,vhb,thb,ehb)
+
+! ----------------------------------------------------------------------
+! Calculation of the flux at the ground
+! Formulation of Louis (Louis, 1979)
+! ----------------------------------------------------------------------
+
+ implicit none
+
+
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+ real dz ! first vertical level
+ real pt ! potential temperature
+ real pt0 ! reference potential temperature
+ real ptg ! ground potential temperature
+ real ua ! wind speed
+ real va ! wind speed
+ real z0 ! Roughness length
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Explicit component of the momentum, temperature and TKE sources or sinks on horizontal
+! surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = B
+! Example: Momentum fluxes on horizontal surfaces = uhb_u
+ real uhb ! U (wind component) Horizontal surfaces, B (explicit) term
+ real vhb ! V (wind component) Horizontal surfaces, B (explicit) term
+ real thb ! Temperature Horizontal surfaces, B (explicit) term
+ real tva ! Temperature Vertical surfaces, A (implicit) term
+ real tvb ! Temperature Vertical surfaces, B (explicit) term
+ real ehb ! Energy (TKE) Horizontal surfaces, B (explicit) term
+
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+ real aa
+ real al
+ real buu
+ real c
+ real fbuw
+ real fbpt
+ real fh
+ real fm
+ real ric
+ real tstar
+ real ustar
+ real utot
+ real wstar
+ real zz
+
+ real b,cm,ch,rr,tol
+ parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001)
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+
+! computation of the ground temperature
+
+ utot=(ua**2+va**2)**.5
+
+
+!!!! Louis formulation
+!
+! compute the bulk Richardson Number
+
+ zz=dz/2.
+
+! if(tstar.lt.0.)then
+! wstar=(-ustar*tstar*g*hii/pt)**(1./3.)
+! else
+! wstar=0.
+! endif
+!
+! if (utot.le.0.7*wstar) utot=max(0.7*wstar,0.00001)
+
+ utot=max(utot,0.01)
+
+ ric=2.*g_u*zz*(pt-ptg)/((pt+ptg)*(utot**2))
+
+ aa=vk/log(zz/z0)
+
+! determine the parameters fm and fh for stable, neutral and unstable conditions
+
+ if(ric.gt.0)then
+ fm=1/(1+0.5*b*ric)**2
+ fh=fm
+ else
+ c=b*cm*aa*aa*(zz/z0)**.5
+ fm=1-b*ric/(1+c*(-ric)**.5)
+ c=c*ch/cm
+ fh=1-b*ric/(1+c*(-ric)**.5)
+ endif
+
+ fbuw=-aa*aa*utot*utot*fm
+ fbpt=-aa*aa*utot*(pt-ptg)*fh/rr
+
+ ustar=(-fbuw)**.5
+ tstar=-fbpt/ustar
+
+ al=(vk*g_u*tstar)/(pt*ustar*ustar)
+
+ buu=-g_u/pt0*ustar*tstar
+
+ uhb=-ustar*ustar*ua/utot
+ vhb=-ustar*ustar*va/utot
+ thb=-ustar*tstar
+! thb= 0.
+ ehb=buu
+!!!!!!!!!!!!!!!
+
+ return
+ end subroutine flux_flat
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine icBEP (alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, &
+ albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, &
+ fww,fwg,fgw,fsw,fws,fsg, &
+ z0g_u,z0r_u, &
+ nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, &
+ nz_u,z_u, &
+ twini_u,trini_u)
+
+
+ implicit none
+
+
+! Building parameters
+ real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1]
+ real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1]
+ real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1]
+ real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1]
+ real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1]
+ real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1]
+ real twini_u(nurbm) ! Temperature inside the buildings behind the wall [K]
+ real trini_u(nurbm) ! Temperature inside the buildings behind the roof [K]
+
+! Radiation parameters
+ real albg_u(nurbm) ! Albedo of the ground
+ real albw_u(nurbm) ! Albedo of the wall
+ real albr_u(nurbm) ! Albedo of the roof
+ real emg_u(nurbm) ! Emissivity of ground
+ real emw_u(nurbm) ! Emissivity of wall
+ real emr_u(nurbm) ! Emissivity of roof
+
+! Roughness parameters
+ real z0g_u(nurbm) ! The ground's roughness length
+ real z0r_u(nurbm) ! The roof's roughness length
+
+! Street parameters
+ integer nd_u(nurbm) ! Number of street direction for each urban class
+
+ real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells)
+ real drst_u(ndm,nurbm) ! Street direction [degree]
+ real ws_u(ndm,nurbm) ! Street width [m]
+ real bs_u(ndm,nurbm) ! Building width [m]
+ real h_b(nz_um,nurbm) ! Bulding's heights [m]
+ real d_b(nz_um,nurbm) ! The probability that a building has an height h_b
+! -----------------------------------------------------------------------
+! Output
+!------------------------------------------------------------------------
+
+
+
+! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+! and the short wave radation. They are the part of radiation from a surface
+! or from the sky to another surface.
+ real fww(nz_um,nz_um,ndm,nurbm) ! from wall to wall
+ real fwg(nz_um,ndm,nurbm) ! from wall to ground
+ real fgw(nz_um,ndm,nurbm) ! from ground to wall
+ real fsw(nz_um,ndm,nurbm) ! from sky to wall
+ real fws(nz_um,ndm,nurbm) ! from wall to sky
+ real fsg(ndm,nurbm) ! from sky to ground
+
+ real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to z
+ real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to z
+
+! Grid parameters
+ integer nz_u(nurbm) ! Number of layer in the urban grid
+ real z_u(nz_um) ! Height of the urban grid levels
+
+
+! -----------------------------------------------------------------------
+! Local
+!------------------------------------------------------------------------
+
+ integer iz_u,id,ilu,iurb
+
+ real dtot
+ real hbmax
+
+!------------------------------------------------------------------------
+
+
+! -----------------------------------------------------------------------
+! This routine initialise the urban paramters for the BEP module
+!------------------------------------------------------------------------
+!
+!Initialize variables
+!
+ nz_u=0
+ z_u=0.
+ ss_u=0.
+ pb_u=0.
+ fww=0.
+ fwg=0.
+ fgw=0.
+ fsw=0.
+ fws=0.
+ fsg=0.
+
+! Computation of the urban levels height
+
+ z_u(1)=0.
+
+ do iz_u=1,nz_um-1
+ z_u(iz_u+1)=z_u(iz_u)+dz_u
+ enddo
+
+! Normalisation of the building density
+
+ do iurb=1,nurbm
+ dtot=0.
+ do ilu=1,nz_um
+ dtot=dtot+d_b(ilu,iurb)
+ enddo
+ do ilu=1,nz_um
+ d_b(ilu,iurb)=d_b(ilu,iurb)/dtot
+ enddo
+ enddo
+
+! Compute the view factors, pb and ss
+
+ do iurb=1,nurbm
+ hbmax=0.
+ nz_u(iurb)=0
+ do ilu=1,nz_um
+ if(h_b(ilu,iurb).gt.hbmax)hbmax=h_b(ilu,iurb)
+ enddo
+
+ do iz_u=1,nz_um-1
+ if(z_u(iz_u+1).gt.hbmax)go to 10
+ enddo
+
+ 10 continue
+ nz_u(iurb)=iz_u+1
+
+ do id=1,nd_u(iurb)
+
+ call view_factors(iurb,nz_u(iurb),id,strd_u(id,iurb), &
+ z_u,ws_u(id,iurb), &
+ fww,fwg,fgw,fsg,fsw,fws)
+
+ do iz_u=1,nz_u(iurb)
+ ss_u(iz_u,iurb)=0.
+ do ilu=1,nz_um
+ if(z_u(iz_u).le.h_b(ilu,iurb) &
+ .and.z_u(iz_u+1).gt.h_b(ilu,iurb))then
+ ss_u(iz_u,iurb)=ss_u(iz_u,iurb)+d_b(ilu,iurb)
+ endif
+ enddo
+ enddo
+
+ pb_u(1,iurb)=1.
+ do iz_u=1,nz_u(iurb)
+ pb_u(iz_u+1,iurb)=max(0.,pb_u(iz_u,iurb)-ss_u(iz_u,iurb))
+ enddo
+
+ enddo
+ end do
+
+
+ return
+ end subroutine icBEP
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ subroutine view_factors(iurb,nz_u,id,dxy,z,ws,fww,fwg,fgw,fsg,fsw,fws)
+
+ implicit none
+
+
+
+! -----------------------------------------------------------------------
+! Input
+!------------------------------------------------------------------------
+
+ integer iurb ! Number of the urban class
+ integer nz_u ! Number of levels in the urban grid
+ integer id ! Street direction number
+ real ws ! Street width
+ real z(nz_um) ! Height of the urban grid levels
+ real dxy ! Street lenght
+
+
+! -----------------------------------------------------------------------
+! Output
+!------------------------------------------------------------------------
+
+! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+! and the short wave radation. They are the part of radiation from a surface
+! or from the sky to another surface.
+
+ real fww(nz_um,nz_um,ndm,nurbm) ! from wall to wall
+ real fwg(nz_um,ndm,nurbm) ! from wall to ground
+ real fgw(nz_um,ndm,nurbm) ! from ground to wall
+ real fsw(nz_um,ndm,nurbm) ! from sky to wall
+ real fws(nz_um,ndm,nurbm) ! from wall to sky
+ real fsg(ndm,nurbm) ! from sky to ground
+
+
+! -----------------------------------------------------------------------
+! Local
+!------------------------------------------------------------------------
+
+ integer jz,iz
+
+ real hut
+ real f1,f2,f12,f23,f123,ftot
+ real fprl,fnrm
+ real a1,a2,a3,a4,a12,a23,a123
+
+! -----------------------------------------------------------------------
+! This routine calculates the view factors
+!------------------------------------------------------------------------
+
+ hut=z(nz_u+1)
+
+ do jz=1,nz_u
+
+! radiation from wall to wall
+
+ do iz=1,nz_u
+
+ call fprls (fprl,dxy,abs(z(jz+1)-z(iz )),ws)
+ f123=fprl
+ call fprls (fprl,dxy,abs(z(jz+1)-z(iz+1)),ws)
+ f23=fprl
+ call fprls (fprl,dxy,abs(z(jz )-z(iz )),ws)
+ f12=fprl
+ call fprls (fprl,dxy,abs(z(jz )-z(iz+1)),ws)
+ f2 = fprl
+
+ a123=dxy*(abs(z(jz+1)-z(iz )))
+ a12 =dxy*(abs(z(jz )-z(iz )))
+ a23 =dxy*(abs(z(jz+1)-z(iz+1)))
+ a1 =dxy*(abs(z(iz+1)-z(iz )))
+ a2 =dxy*(abs(z(jz )-z(iz+1)))
+ a3 =dxy*(abs(z(jz+1)-z(jz )))
+
+ ftot=0.5*(a123*f123-a23*f23-a12*f12+a2*f2)/a1
+
+ fww(iz,jz,id,iurb)=ftot*a1/a3
+
+ enddo
+
+! radiation from ground to wall
+
+ call fnrms (fnrm,z(jz+1),dxy,ws)
+ f12=fnrm
+ call fnrms (fnrm,z(jz) ,dxy,ws)
+ f1=fnrm
+
+ a1 = ws*dxy
+
+ a12= ws*dxy
+
+ a4=(z(jz+1)-z(jz))*dxy
+
+ ftot=(a12*f12-a12*f1)/a1
+
+ fgw(jz,id,iurb)=ftot*a1/a4
+
+! radiation from sky to wall
+
+ call fnrms(fnrm,hut-z(jz) ,dxy,ws)
+ f12 = fnrm
+ call fnrms (fnrm,hut-z(jz+1),dxy,ws)
+ f1 =fnrm
+
+ a1 = ws*dxy
+
+ a12= ws*dxy
+
+ a4 = (z(jz+1)-z(jz))*dxy
+
+ ftot=(a12*f12-a12*f1)/a1
+
+ fsw(jz,id,iurb)=ftot*a1/a4
+
+ enddo
+
+! radiation from wall to sky
+ do iz=1,nz_u
+ call fnrms(fnrm,ws,dxy,hut-z(iz))
+ f12=fnrm
+ call fnrms(fnrm,ws,dxy,hut-z(iz+1))
+ f1=fnrm
+ a1 = (z(iz+1)-z(iz))*dxy
+ a2 = (hut-z(iz+1))*dxy
+ a12= (hut-z(iz))*dxy
+ a4 = ws*dxy
+ ftot=(a12*f12-a2*f1)/a1
+ fws(iz,id,iurb)=ftot*a1/a4
+
+ enddo
+!!!!!!!!!!!!!
+
+
+ do iz=1,nz_u
+
+! radiation from wall to ground
+
+ call fnrms (fnrm,ws,dxy,z(iz+1))
+ f12=fnrm
+ call fnrms (fnrm,ws,dxy,z(iz ))
+ f1 =fnrm
+
+ a1= (z(iz+1)-z(iz) )*dxy
+
+ a2 = z(iz)*dxy
+ a12= z(iz+1)*dxy
+ a4 = ws*dxy
+
+ ftot=(a12*f12-a2*f1)/a1
+
+ fwg(iz,id,iurb)=ftot*a1/a4
+
+ enddo
+
+! radiation from sky to ground
+
+ call fprls (fprl,dxy,ws,hut)
+ fsg(id,iurb)=fprl
+
+ return
+ end subroutine view_factors
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ SUBROUTINE fprls (fprl,a,b,c)
+
+ implicit none
+
+
+
+ real a,b,c
+ real x,y
+ real fprl
+
+
+ x=a/c
+ y=b/c
+
+ if(a.eq.0.or.b.eq.0.)then
+ fprl=0.
+ else
+ fprl=log( ( (1.+x**2)*(1.+y**2)/(1.+x**2+y**2) )**.5)+ &
+ y*((1.+x**2)**.5)*atan(y/((1.+x**2)**.5))+ &
+ x*((1.+y**2)**.5)*atan(x/((1.+y**2)**.5))- &
+ y*atan(y)-x*atan(x)
+ fprl=fprl*2./(pi*x*y)
+ endif
+
+ return
+ end subroutine fprls
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+ SUBROUTINE fnrms (fnrm,a,b,c)
+
+ implicit none
+
+
+
+ real a,b,c
+ real x,y,z,a1,a2,a3,a4,a5,a6
+ real fnrm
+
+ x=a/b
+ y=c/b
+ z=x**2+y**2
+
+ if(y.eq.0.or.x.eq.0)then
+ fnrm=0.
+ else
+ a1=log( (1.+x*x)*(1.+y*y)/(1.+z) )
+ a2=y*y*log(y*y*(1.+z)/z/(1.+y*y) )
+ a3=x*x*log(x*x*(1.+z)/z/(1.+x*x) )
+ a4=y*atan(1./y)
+ a5=x*atan(1./x)
+ a6=sqrt(z)*atan(1./sqrt(z))
+ fnrm=0.25*(a1+a2+a3)+a4+a5-a6
+ fnrm=fnrm/(pi*y)
+ endif
+
+ return
+ end subroutine fnrms
+ ! ===6=8===============================================================72
+
+ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,&
+ twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,emg_u,emw_u,&
+ emr_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b)
+
+! initialization routine, where the variables from the table are read
+
+ implicit none
+
+ integer iurb ! urban class number
+! Building parameters
+ real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1]
+ real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1]
+ real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1]
+ real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1]
+ real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1]
+ real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1]
+ real twini_u(nurbm) ! Temperature inside the buildings behind the wall [K]
+ real trini_u(nurbm) ! Temperature inside the buildings behind the roof [K]
+ real tgini_u(nurbm) ! Initial road temperature
+
+! Radiation parameters
+ real albg_u(nurbm) ! Albedo of the ground
+ real albw_u(nurbm) ! Albedo of the wall
+ real albr_u(nurbm) ! Albedo of the roof
+ real emg_u(nurbm) ! Emissivity of ground
+ real emw_u(nurbm) ! Emissivity of wall
+ real emr_u(nurbm) ! Emissivity of roof
+
+! Roughness parameters
+ real z0g_u(nurbm) ! The ground's roughness length
+ real z0r_u(nurbm) ! The roof's roughness length
+
+! Street parameters
+ integer nd_u(nurbm) ! Number of street direction for each urban class
+
+ real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells)
+ real drst_u(ndm,nurbm) ! Street direction [degree]
+ real ws_u(ndm,nurbm) ! Street width [m]
+ real bs_u(ndm,nurbm) ! Building width [m]
+ real h_b(nz_um,nurbm) ! Bulding's heights [m]
+ real d_b(nz_um,nurbm) ! The probability that a building has an height h_b
+
+ integer i,iu
+ integer nurb ! number of urban classes used
+
+!
+!Initialize some variables
+!
+
+ h_b=0.
+ d_b=0.
+
+ nurb=ICATE
+ do iu=1,nurb
+ nd_u(iu)=0
+ enddo
+
+ csw_u=CAPB_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+ csr_u=CAPR_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+ csg_u=CAPG_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+ do i=1,icate
+ alaw_u(i)=AKSB_TBL(i) / csw_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+ alar_u(i)=AKSR_TBL(i) / csr_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+ alag_u(i)=AKSG_TBL(i) / csg_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+ enddo
+ twini_u=TBLEND_TBL
+ trini_u=TRLEND_TBL
+ tgini_u=TGLEND_TBL
+ albw_u=ALBB_TBL
+ albr_u=ALBR_TBL
+ albg_u=ALBG_TBL
+ emw_u=EPSB_TBL
+ emr_u=EPSR_TBL
+ emg_u=EPSG_TBL
+ z0r_u=Z0R_TBL
+ z0g_u=Z0G_TBL
+ nd_u=NUMDIR_TBL
+ do iu=1,icate
+ if(ndm.lt.nd_u(iu))then
+ write(*,*)'ndm too small in module_sf_bep, please increase to at least ', nd_u(iu)
+ write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!'
+ stop
+ endif
+ do i=1,nd_u(iu)
+ drst_u(i,iu)=STREET_DIRECTION_TBL(i,iu) * pi/180.
+ ws_u(i,iu)=STREET_WIDTH_TBL(i,iu)
+ bs_u(i,iu)=BUILDING_WIDTH_TBL(i,iu)
+ enddo
+ enddo
+ do iu=1,ICATE
+ if(nz_um.lt.numhgt_tbl(iu)+3)then
+ write(*,*)'nz_um too small in module_sf_bep, please increase to at least ',numhgt_tbl(iu)+3
+ write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!'
+ stop
+ endif
+ do i=1,NUMHGT_TBL(iu)
+ h_b(i,iu)=HEIGHT_BIN_TBL(i,iu)
+ d_b(i,iu)=HPERCENT_BIN_TBL(i,iu)
+ enddo
+ enddo
+
+ do i=1,ndm
+ do iu=1,nurbm
+ strd_u(i,iu)=100000.
+ enddo
+ enddo
+
+ return
+ END SUBROUTINE init_para
+!==============================================================
+
+!==============================================================
+ subroutine angle(along,alat,day,realt,zr,deltar,ah)
+! ----------------
+!
+! Computation of the solar angles
+! schayes (1982,atm. env. , p1407)
+! Inputs
+!========================
+! along=longitud
+! alat=latitude
+! day=julian day (from the beginning of the year)
+! realt= time GMT in hours
+! Outputs
+!============================
+! zr=solar zenith angle
+! deltar=declination angle
+! ah=hour angle
+!===============================
+
+ implicit none
+ real along,alat, realt, zr, deltar, ah, arg
+ real rad,om,radh,initt, pii, drad, alongt, cphi, sphi
+ real c1, c2, c3, s1, s2, s3, delta, rmsr2, cd, sid
+ real et, ahor, chor, coznt
+ integer day
+
+
+ data rad,om,radh,initt/0.0174533,0.0172142,0.26179939,0/
+
+ zr=0.
+ deltar=0.
+ ah=0.
+
+ pii = 3.14159265358979312
+ drad = pii/180.
+
+ alongt=along/15.
+ cphi=cos(alat*drad)
+ sphi=sin(alat*drad)
+!
+! declination
+!
+ arg=om*day
+ c1=cos(arg)
+ c2=cos(2.*arg)
+ c3=cos(3.*arg)
+ s1=sin(arg)
+ s2=sin(2.*arg)
+ s3=sin(3.*arg)
+ delta=0.33281-22.984*c1-0.3499*c2-0.1398*c3+3.7872*s1+0.03205*s2+0.07187*s3
+ rmsr2=(1./(1.-0.01673*c1))**2
+ deltar=delta*rad
+ cd=cos(deltar)
+ sid=sin(deltar)
+!
+! time equation in hours
+!
+ et=0.0072*c1-0.0528*c2-0.0012*c3-0.1229*s1-0.1565*s2-0.0041*s3
+!
+!
+! hour angle
+!
+
+! ifh=0
+
+ ! ahor=realt-12.+ifh+et+alongt
+ ahor=realt-12.+et+alongt
+ ah=ahor*radh
+ chor=cos(ah)
+!
+! zenith angle
+!
+ coznt=sphi*sid+cphi*cd*chor
+
+ zr=acos(coznt)
+
+ return
+
+ END SUBROUTINE angle
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine upward_rad(nd_u,iurb,nz_u,ws,bs,sigma,fsw,fsg,pb,ss, &
+ tg,emg_u,albg_u,rlg,rsg,sfg, &
+ tw,emw_u,albw_u,rlw,rsw,sfw, &
+ tr,emr_u,albr_u,rld,rs, sfr, &
+ rs_abs,rl_up,emiss,grdflx_urb)
+!
+! IN this surboutine we compute the upward longwave flux, and the albedo
+! needed for the radiation scheme
+!
+ implicit none
+
+!
+!INPUT VARIABLES
+!
+ real rsw(2*ndm,nz_um) ! Short wave radiation at the wall for a given canyon direction [W/m2]
+ real rlw(2*ndm,nz_um) ! Long wave radiation at the walls for a given canyon direction [W/m2]
+ real rsg(ndm) ! Short wave radiation at the canyon for a given canyon direction [W/m2]
+ real rlg(ndm) ! Long wave radiation at the ground for a given canyon direction [W/m2]
+ real rs ! Short wave radiation at the horizontal surface from the sun [W/mÂē]
+ real sfw(2*ndm,nz_um) ! Sensible heat flux from walls [W/mÂē]
+ real sfg(ndm) ! Sensible heat flux from ground (road) [W/mÂē]
+ real sfr(ndm,nz_um) ! Sensible heat flux from roofs [W/mÂē]
+ real rld ! Long wave radiation from the sky [W/mÂē]
+ real albg_u ! albedo of the ground/street
+ real albw_u ! albedo of the walls
+ real albr_u ! albedo of the roof
+ real ws(ndm) ! width of the street
+ real bs(ndm)
+ ! building size
+ real pb(nz_um) ! Probability to have a building with an height equal or higher
+ integer nz_u
+ real ss(nz_um) ! Probability to have a building of a given height
+ real sigma
+ real emg_u ! emissivity of the street
+ real emw_u ! emissivity of the wall
+ real emr_u ! emissivity of the roof
+ real fsw(nz_um,ndm,nurbm) ! View factors from sky to wall
+ real fsg(ndm,nurbm) ! groud to sky view factor
+ real tw(2*ndm,nz_um,nwr_u) ! Temperature in each layer of the wall [K]
+ real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K]
+ real tg(ndm,ng_u) ! Temperature in each layer of the ground [K]
+ integer iurb ! urban class
+ integer id ! street direction
+ integer nd_u ! number of street directions
+!OUTPUT/INPUT
+ real rs_abs ! absrobed solar radiationfor this street direction
+ real rl_up ! upward longwave radiation for this street direction
+ real emiss ! mean emissivity
+ real grdflx_urb ! ground heat flux
+!LOCAL
+ integer iz,iw
+ real rl_inc,rl_emit
+ real gfl
+ integer ix,iy,iwrong
+
+ iwrong=1
+ do iz=1,nz_u+1
+ do id=1,nd_u
+ do iw=1,nwr_u
+ if(tr(id,iz,iw).lt.100.)then
+ write(*,*)'in upward_rad ',iz,id,iw,tr(id,iz,iw)
+ iwrong=0
+ endif
+ enddo
+ enddo
+ enddo
+ if(iwrong.eq.0)stop
+
+ rl_up=0.
+
+ rs_abs=0.
+ rl_inc=0.
+ emiss=0.
+ rl_emit=0.
+ grdflx_urb=0.
+ do id=1,nd_u
+ rl_emit=rl_emit-( emg_u*sigma*(tg(id,ng_u)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/nd_u
+ rl_inc=rl_inc+rlg(id)*ws(id)/(ws(id)+bs(id))/nd_u
+ rs_abs=rs_abs+(1.-albg_u)*rsg(id)*ws(id)/(ws(id)+bs(id))/nd_u
+ gfl=(1.-albg_u)*rsg(id)+emg_u*rlg(id)-emg_u*sigma*(tg(id,ng_u)**4.)+sfg(id)
+ grdflx_urb=grdflx_urb-gfl*ws(id)/(ws(id)+bs(id))/nd_u
+
+ do iz=2,nz_u
+ rl_emit=rl_emit-(emr_u*sigma*(tr(id,iz,nwr_u)**4.)+(1-emr_u)*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+ rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+ rs_abs=rs_abs+(1.-albr_u)*rs*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+ gfl=(1.-albr_u)*rs+emr_u*rld-emr_u*sigma*(tr(id,iz,nwr_u)**4.)+sfr(id,iz)
+ grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+ enddo
+
+ do iz=1,nz_u
+ rl_emit=rl_emit-(emw_u*sigma*( tw(2*id-1,iz,nwr_u)**4.+tw(2*id,iz,nwr_u)**4. )+ &
+ (1-emw_u)*( rlw(2*id-1,iz)+rlw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+ rl_inc=rl_inc+(( rlw(2*id-1,iz)+rlw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+ rs_abs=rs_abs+((1.-albw_u)*( rsw(2*id-1,iz)+rsw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+ gfl=(1.-albw_u)*(rsw(2*id-1,iz)+rsw(2*id,iz)) +emw_u*( rlw(2*id-1,iz)+rlw(2*id,iz) ) &
+ -emw_u*sigma*( tw(2*id-1,iz,nwr_u)**4.+tw(2*id,iz,nwr_u)**4. )+(sfw(2*id-1,iz)+sfw(2*id,iz))
+ grdflx_urb=grdflx_urb-gfl*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+ enddo
+
+ enddo
+ emiss=(emg_u+emw_u+emr_u)/3.
+ rl_up=(rl_inc+rl_emit)-rld
+
+
+ return
+
+ END SUBROUTINE upward_rad
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+END MODULE module_sf_bep
Added: branches/atmos_physics/src/core_physics/physics_wrf/module_sf_noahdrv.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_sf_noahdrv.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_sf_noahdrv.F 2011-01-13 23:29:23 UTC (rev 685)
@@ -0,0 +1,1826 @@
+MODULE module_sf_noahdrv
+
+!-------------------------------
+ USE module_sf_noahlsm
+ USE module_sf_urban
+ USE module_sf_bep
+ USE module_sf_bep_bem
+#ifdef WRF_CHEM
+ USE module_data_gocart_dust
+#endif
+!-------------------------------
+
+!
+CONTAINS
+!
+!----------------------------------------------------------------
+! Urban related variable are added to arguments - urban
+!----------------------------------------------------------------
+ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, &
+ HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,GLW,SMSTAV,SMSTOT, &
+ SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,ISURBAN,ISICE,VEGFRA, &
+ ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE,EMISS,EMBCK, &
+ SNOWC,QSFC,RAINBL,MMINLU, &
+ num_soil_layers,DT,DZS,ITIMESTEP, &
+ SMOIS,TSLB,SNOW,CANWAT, &
+ CHS,CHS2,CQS2,CPM,ROVCP,SR,chklowq,lai,qz0, & !H
+ myj,frpcpn, &
+ SH2O,SNOWH, & !H
+ U_PHY,V_PHY, & !I
+ SNOALB,SHDMIN,SHDMAX, & !I
+ SNOTIME, & !?
+ ACSNOM,ACSNOW, & !O
+ SNOPCX, & !O
+ POTEVP, & !O
+ SMCREL, & !O
+ XICE_THRESHOLD, &
+ RDLAI2D,USEMONALB, &
+ RIB, & !?
+ NOAHRES, &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte, &
+ sf_urban_physics, &
+ CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, &
+!Optional Urban
+ TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban
+ UC_URB2D, & !H urban
+ XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !H urban
+ TRL_URB3D,TBL_URB3D,TGL_URB3D, & !H urban
+ SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D,TS_URB2D, & !H urban
+ PSIM_URB2D,PSIH_URB2D,U10_URB2D,V10_URB2D, & !O urban
+ GZ1OZ0_URB2D, AKMS_URB2D, & !O urban
+ TH2_URB2D,Q2_URB2D, UST_URB2D, & !O urban
+ DECLIN_URB,COSZ_URB2D,OMG_URB2D, & !I urban
+ XLAT_URB2D, & !I urban
+ num_roof_layers, num_wall_layers, & !I urban
+ num_road_layers, DZR, DZB, DZG, & !I urban
+ FRC_URB2D,UTYPE_URB2D, & !O
+ num_urban_layers, & !I multi-layer urban
+ trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban
+ tlev_urb3d,qlev_urb3d, & !H multi-layer urban
+ tw1lev_urb3d,tw2lev_urb3d, & !H multi-layer urban
+ tglev_urb3d,tflev_urb3d, & !H multi-layer urban
+ sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d, & !H multi-layer urban
+ sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban
+ sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban
+ sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban
+ th_phy,rho,p_phy,ust, & !I multi-layer urban
+ gmt,julday,xlong,xlat, & !I multi-layer urban
+ a_u_bep,a_v_bep,a_t_bep,a_q_bep, & !O multi-layer urban
+ a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban
+ b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban
+ dl_u_bep,sf_bep,vl_bep ) !O multi-layer urban
+
+!----------------------------------------------------------------
+ IMPLICIT NONE
+!----------------------------------------------------------------
+!----------------------------------------------------------------
+! --- atmospheric (WRF generic) variables
+!-- DT time step (seconds)
+!-- DZ8W thickness of layers (m)
+!-- T3D temperature (K)
+!-- QV3D 3D water vapor mixing ratio (Kg/Kg)
+!-- P3D 3D pressure (Pa)
+!-- FLHC exchange coefficient for heat (m/s)
+!-- FLQC exchange coefficient for moisture (m/s)
+!-- PSFC surface pressure (Pa)
+!-- XLAND land mask (1 for land, 2 for water)
+!-- QGH saturated mixing ratio at 2 meter
+!-- GSW downward short wave flux at ground surface (W/m^2)
+!-- GLW downward long wave flux at ground surface (W/m^2)
+!-- History variables
+!-- CANWAT canopy moisture content (mm)
+!-- TSK surface temperature (K)
+!-- TSLB soil temp (k)
+!-- SMOIS total soil moisture content (volumetric fraction)
+!-- SH2O unfrozen soil moisture content (volumetric fraction)
+! note: frozen soil moisture (i.e., soil ice) = SMOIS - SH2O
+!-- SNOWH actual snow depth (m)
+!-- SNOW liquid water-equivalent snow depth (m)
+!-- ALBEDO time-varying surface albedo including snow effect (unitless fraction)
+!-- ALBBCK background surface albedo (unitless fraction)
+!-- CHS surface exchange coefficient for heat and moisture (m s-1);
+!-- CHS2 2m surface exchange coefficient for heat (m s-1);
+!-- CQS2 2m surface exchange coefficient for moisture (m s-1);
+! --- soil variables
+!-- num_soil_layers the number of soil layers
+!-- ZS depths of centers of soil layers (m)
+!-- DZS thicknesses of soil layers (m)
+!-- SLDPTH thickness of each soil layer (m, same as DZS)
+!-- TMN soil temperature at lower boundary (K)
+!-- SMCWLT wilting point (volumetric)
+!-- SMCDRY dry soil moisture threshold where direct evap from
+! top soil layer ends (volumetric)
+!-- SMCREF soil moisture threshold below which transpiration begins to
+! stress (volumetric)
+!-- SMCMAX porosity, i.e. saturated value of soil moisture (volumetric)
+!-- NROOT number of root layers, a function of veg type, determined
+! in subroutine redprm.
+!-- SMSTAV Soil moisture availability for evapotranspiration (
+! fraction between SMCWLT and SMCMXA)
+!-- SMSTOT Total soil moisture content frozen+unfrozen) in the soil column (mm)
+! --- snow variables
+!-- SNOWC fraction snow coverage (0-1.0)
+! --- vegetation variables
+!-- SNOALB upper bound on maximum albedo over deep snow
+!-- SHDMIN minimum areal fractional coverage of annual green vegetation
+!-- SHDMAX maximum areal fractional coverage of annual green vegetation
+!-- XLAI leaf area index (dimensionless)
+!-- Z0BRD Background fixed roughness length (M)
+!-- Z0 Background vroughness length (M) as function
+!-- ZNT Time varying roughness length (M) as function
+!-- ALBD(IVGTPK,ISN) background albedo reading from a table
+! --- LSM output
+!-- HFX upward heat flux at the surface (W/m^2)
+!-- QFX upward moisture flux at the surface (kg/m^2/s)
+!-- LH upward moisture flux at the surface (W m-2)
+!-- GRDFLX(I,J) ground heat flux (W m-2)
+!-- FDOWN radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN
+!----------------------------------------------------------------------------
+!-- EC canopy water evaporation ((W m-2)
+!-- EDIR direct soil evaporation (W m-2)
+!-- ET plant transpiration from a particular root layer (W m-2)
+!-- ETT total plant transpiration (W m-2)
+!-- ESNOW sublimation from (or deposition to if <0) snowpack (W m-2)
+!-- DRIP through-fall of precip and/or dew in excess of canopy
+! water-holding capacity (m)
+!-- DEW dewfall (or frostfall for t<273.15) (M)
+!-- SMAV Soil Moisture Availability for each layer, as a fraction
+! between SMCWLT and SMCMAX (dimensionless fraction)
+! ----------------------------------------------------------------------
+!-- BETA ratio of actual/potential evap (dimensionless)
+!-- ETP potential evaporation (W m-2)
+! ----------------------------------------------------------------------
+!-- FLX1 precip-snow sfc (W m-2)
+!-- FLX2 freezing rain latent heat flux (W m-2)
+!-- FLX3 phase-change heat flux from snowmelt (W m-2)
+! ----------------------------------------------------------------------
+!-- ACSNOM snow melt (mm) (water equivalent)
+!-- ACSNOW accumulated snow fall (mm) (water equivalent)
+!-- SNOPCX snow phase change heat flux (W/m^2)
+!-- POTEVP accumulated potential evaporation (W/m^2)
+!-- RIB Documentation needed!!!
+! ----------------------------------------------------------------------
+!-- RUNOFF1 surface runoff (m s-1), not infiltrating the surface
+!-- RUNOFF2 subsurface runoff (m s-1), drainage out bottom of last
+! soil layer (baseflow)
+! important note: here RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3
+!-- RUNOFF3 numerical trunctation in excess of porosity (smcmax)
+! for a given soil layer at the end of a time step (m s-1).
+! ----------------------------------------------------------------------
+!-- RC canopy resistance (s m-1)
+!-- PC plant coefficient (unitless fraction, 0-1) where PC*ETP = actual transp
+!-- RSMIN minimum canopy resistance (s m-1)
+!-- RCS incoming solar rc factor (dimensionless)
+!-- RCT air temperature rc factor (dimensionless)
+!-- RCQ atmos vapor pressure deficit rc factor (dimensionless)
+!-- RCSOIL soil moisture rc factor (dimensionless)
+
+!-- EMISS surface emissivity (between 0 and 1)
+!-- EMBCK Background surface emissivity (between 0 and 1)
+
+!-- ROVCP R/CP
+! (R_d/R_v) (dimensionless)
+!-- ids start index for i in domain
+!-- ide end index for i in domain
+!-- jds start index for j in domain
+!-- jde end index for j in domain
+!-- kds start index for k in domain
+!-- kde end index for k in domain
+!-- ims start index for i in memory
+!-- ime end index for i in memory
+!-- jms start index for j in memory
+!-- jme end index for j in memory
+!-- kms start index for k in memory
+!-- kme end index for k in memory
+!-- its start index for i in tile
+!-- ite end index for i in tile
+!-- jts start index for j in tile
+!-- jte end index for j in tile
+!-- kts start index for k in tile
+!-- kte end index for k in tile
+!
+!-- SR fraction of frozen precip (0.0 to 1.0)
+!----------------------------------------------------------------
+
+! IN only
+
+ INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte
+
+ INTEGER, INTENT(IN ) :: sf_urban_physics !urban
+ INTEGER, INTENT(IN ) :: isurban
+ INTEGER, INTENT(IN ) :: isice
+
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(IN ) :: TMN, &
+ XLAND, &
+ XICE, &
+ VEGFRA, &
+ SHDMIN, &
+ SHDMAX, &
+ SNOALB, &
+ GSW, &
+ SWDOWN, & !added 10 jan 2007
+ GLW, &
+ RAINBL, &
+ EMBCK, &
+ SR
+
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(INOUT) :: ALBBCK, &
+ Z0
+ CHARACTER(LEN=*), INTENT(IN ) :: MMINLU
+
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
+ INTENT(IN ) :: QV3D, &
+ p8w3D, &
+ DZ8W, &
+ T3D
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(IN ) :: QGH, &
+ CPM
+
+ INTEGER, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(IN ) :: IVGTYP, &
+ ISLTYP
+
+ INTEGER, INTENT(IN) :: num_soil_layers,ITIMESTEP
+
+ REAL, INTENT(IN ) :: DT,ROVCP
+
+ REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::DZS
+
+! IN and OUT
+
+ REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), &
+ INTENT(INOUT) :: SMOIS, & ! total soil moisture
+ SH2O, & ! new soil liquid
+ TSLB ! TSLB STEMP
+
+ REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), &
+ INTENT(OUT) :: SMCREL
+
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(INOUT) :: TSK, & !was TGB (temperature)
+ HFX, &
+ QFX, &
+ LH, &
+ GRDFLX, &
+ QSFC,&
+ CQS2,&
+ CHS, &
+ CHS2,&
+ SNOW, &
+ SNOWC, &
+ SNOWH, & !new
+ CANWAT, &
+ SMSTAV, &
+ SMSTOT, &
+ SFCRUNOFF, &
+ UDRUNOFF, &
+ ACSNOM, &
+ ACSNOW, &
+ SNOTIME, &
+ SNOPCX, &
+ EMISS, &
+ RIB, &
+ POTEVP, &
+ ALBEDO, &
+ ZNT
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(OUT) :: NOAHRES
+
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(OUT) :: CHKLOWQ
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LAI
+ REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: QZ0
+
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF
+! Local variables (moved here from driver to make routine thread safe, 20031007 jm)
+
+ REAL, DIMENSION(1:num_soil_layers) :: ET
+
+ REAL, DIMENSION(1:num_soil_layers) :: SMAV
+
+ REAL :: BETA, ETP, SSOIL,EC, EDIR, ESNOW, ETT, &
+ FLX1,FLX2,FLX3, DRIP,DEW,FDOWN,RC,PC,RSMIN,XLAI, &
+! RCS,RCT,RCQ,RCSOIL
+ RCS,RCT,RCQ,RCSOIL,FFROZP
+
+ LOGICAL, INTENT(IN ) :: myj,frpcpn
+
+! DECLARATIONS - LOGICAL
+! ----------------------------------------------------------------------
+ LOGICAL, PARAMETER :: LOCAL=.false.
+ LOGICAL :: FRZGRA, SNOWNG
+
+ LOGICAL :: IPRINT
+
+! ----------------------------------------------------------------------
+! DECLARATIONS - INTEGER
+! ----------------------------------------------------------------------
+ INTEGER :: I,J, ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP
+ INTEGER :: NROOT
+ INTEGER :: KZ ,K
+ INTEGER :: NS
+! ----------------------------------------------------------------------
+! DECLARATIONS - REAL
+! ----------------------------------------------------------------------
+
+ REAL :: SHMIN,SHMAX,DQSDT2,LWDN,PRCP,PRCPRAIN, &
+ Q2SAT,Q2SATI,SFCPRS,SFCSPD,SFCTMP,SHDFAC,SNOALB1, &
+ SOLDN,TBOT,ZLVL, Q2K,ALBBRD, ALBEDOK, ETA, ETA_KINEMATIC, &
+ EMBRD, &
+ Z0K,RUNOFF1,RUNOFF2,RUNOFF3,SHEAT,SOLNET,E2SAT,SFCTSNO, &
+! mek, WRF testing, expanded diagnostics
+ SOLUP,LWUP,RNET,RES,Q1SFC,TAIRV,SATFLG
+! MEK MAY 2007
+ REAL :: FDTLIW
+! MEK JUL2007 for pot. evap.
+ REAL :: RIBB
+ REAL :: FDTW
+
+ REAL :: EMISSI
+
+ REAL :: SNCOVR,SNEQV,SNOWHK,CMC, CHK,TH2
+
+ REAL :: SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT,SOILM,SOILW,Q1,T1
+ REAL :: SNOTIME1 ! LSTSNW1 INITIAL NUMBER OF TIMESTEPS SINCE LAST SNOWFALL
+
+ REAL :: DUMMY,Z0BRD
+!
+ REAL :: COSZ, SOLARDIRECT
+!
+ REAL, DIMENSION(1:num_soil_layers):: SLDPTH, STC,SMC,SWC
+!
+ REAL, DIMENSION(1:num_soil_layers) :: ZSOIL, RTDIS
+ REAL, PARAMETER :: TRESH=.95E0, A2=17.67,A3=273.15,A4=29.65, &
+ T0=273.16E0, ELWV=2.50E6, A23M4=A2*(A3-A4)
+! MEK MAY 2007
+ REAL, PARAMETER :: ROW=1.E3,ELIW=XLF,ROWLIW=ROW*ELIW
+
+! ----------------------------------------------------------------------
+! DECLARATIONS START - urban
+! ----------------------------------------------------------------------
+
+! input variables surface_driver --> lsm
+ INTEGER, INTENT(IN) :: num_roof_layers
+ INTEGER, INTENT(IN) :: num_wall_layers
+ INTEGER, INTENT(IN) :: num_road_layers
+ REAL, OPTIONAL, DIMENSION(1:num_roof_layers), INTENT(IN) :: DZR
+ REAL, OPTIONAL, DIMENSION(1:num_wall_layers), INTENT(IN) :: DZB
+ REAL, OPTIONAL, DIMENSION(1:num_road_layers), INTENT(IN) :: DZG
+ REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: U_PHY
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: V_PHY
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: TH_PHY
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: P_PHY
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: RHO
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST
+
+ LOGICAL, intent(in) :: rdlai2d
+ LOGICAL, intent(in) :: USEMONALB
+
+! input variables lsm --> urban
+ INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3]
+ REAL :: TA_URB ! potential temp at 1st atmospheric level [K]
+ REAL :: QA_URB ! mixing ratio at 1st atmospheric level [kg/kg]
+ REAL :: UA_URB ! wind speed at 1st atmospheric level [m/s]
+ REAL :: U1_URB ! u at 1st atmospheric level [m/s]
+ REAL :: V1_URB ! v at 1st atmospheric level [m/s]
+ REAL :: SSG_URB ! downward total short wave radiation [W/m/m]
+ REAL :: LLG_URB ! downward long wave radiation [W/m/m]
+ REAL :: RAIN_URB ! precipitation [mm/h]
+ REAL :: RHOO_URB ! air density [kg/m^3]
+ REAL :: ZA_URB ! first atmospheric level [m]
+ REAL :: DELT_URB ! time step [s]
+ REAL :: SSGD_URB ! downward direct short wave radiation [W/m/m]
+ REAL :: SSGQ_URB ! downward diffuse short wave radiation [W/m/m]
+ REAL :: XLAT_URB ! latitude [deg]
+ REAL :: COSZ_URB ! cosz
+ REAL :: OMG_URB ! hour angle
+ REAL :: ZNT_URB ! roughness length [m]
+ REAL :: TR_URB
+ REAL :: TB_URB
+ REAL :: TG_URB
+ REAL :: TC_URB
+ REAL :: QC_URB
+ REAL :: UC_URB
+ REAL :: XXXR_URB
+ REAL :: XXXB_URB
+ REAL :: XXXG_URB
+ REAL :: XXXC_URB
+ REAL, DIMENSION(1:num_roof_layers) :: TRL_URB ! roof layer temp [K]
+ REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K]
+ REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K]
+ LOGICAL :: LSOLAR_URB
+! state variable surface_driver <--> lsm <--> urban
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D
+!
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D
+
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D
+
+! output variable lsm --> surface_driver
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D
+!
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D
+!
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FRC_URB2D
+ INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D
+
+
+! output variables urban --> lsm
+ REAL :: TS_URB ! surface radiative temperature [K]
+ REAL :: QS_URB ! surface humidity [-]
+ REAL :: SH_URB ! sensible heat flux [W/m/m]
+ REAL :: LH_URB ! latent heat flux [W/m/m]
+ REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic [kg/m/m/s]
+ REAL :: SW_URB ! upward short wave radiation flux [W/m/m]
+ REAL :: ALB_URB ! time-varying albedo [fraction]
+ REAL :: LW_URB ! upward long wave radiation flux [W/m/m]
+ REAL :: G_URB ! heat flux into the ground [W/m/m]
+ REAL :: RN_URB ! net radiation [W/m/m]
+ REAL :: PSIM_URB ! shear f for momentum [-]
+ REAL :: PSIH_URB ! shear f for heat [-]
+ REAL :: GZ1OZ0_URB ! shear f for heat [-]
+ REAL :: U10_URB ! wind u component at 10 m [m/s]
+ REAL :: V10_URB ! wind v component at 10 m [m/s]
+ REAL :: TH2_URB ! potential temperature at 2 m [K]
+ REAL :: Q2_URB ! humidity at 2 m [-]
+ REAL :: CHS_URB
+ REAL :: CHS2_URB
+ REAL :: UST_URB
+! Variables for multi-layer UCM (Martilli et al. 2002)
+ REAL, OPTIONAL, INTENT(IN ) :: GMT
+ INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) ::XLAT, XLONG
+ INTEGER, INTENT(IN ) :: NUM_URBAN_LAYERS
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep !Implicit momemtum component X-direction
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep !Implicit momemtum component Y-direction
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep !Implicit component pot. temperature
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_q_bep !Implicit momemtum component X-direction
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_e_bep !Implicit component TKE
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_u_bep !Explicit momentum component X-direction
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_v_bep !Explicit momentum component Y-direction
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_t_bep !Explicit component pot. temperature
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_q_bep !Implicit momemtum component Y-direction
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_e_bep !Explicit component TKE
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::vl_bep !Fraction air volume in grid cell
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dlg_bep !Height above ground
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::sf_bep !Fraction air at the face of grid cell
+ REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep !Length scale
+
+! Local variables for multi-layer UCM (Martilli et al. 2002)
+ REAL, DIMENSION( ims:ime, jms:jme ) :: HFX_RURAL,LH_RURAL,GRDFLX_RURAL,RN_RURAL
+ REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_RURAL,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL
+ REAL, DIMENSION( ims:ime, jms:jme ) :: ALB_RURAL,EMISS_RURAL,UST_RURAL,TSK_RURAL
+! REAL, DIMENSION( ims:ime, jms:jme ) :: GRDFLX_URB
+! REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_URB,QSFC_URB,UMOM_URB,VMOM_URB
+ REAL, DIMENSION( ims:ime, jms:jme ) :: HFX_URB,UMOM_URB,VMOM_URB
+ REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_URB
+! REAL, DIMENSION( ims:ime, jms:jme ) :: ALBEDO_URB,EMISS_URB,UMOM,VMOM,UST
+ REAL, DIMENSION(ims:ime,jms:jme) ::EMISS_URB
+ REAL, DIMENSION(ims:ime,jms:jme) :: RL_UP_URB
+ REAL, DIMENSION(ims:ime,jms:jme) ::RS_ABS_URB
+ REAL, DIMENSION(ims:ime,jms:jme) ::GRDFLX_URB
+ REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM
+ REAL :: r1,r2,r3
+ REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB
+! ----------------------------------------------------------------------
+! DECLARATIONS END - urban
+! ----------------------------------------------------------------------
+
+ REAL, PARAMETER :: CAPA=R_D/CP
+ REAL :: APELM,APES,SFCTH2,PSFC
+
+ real, intent(in) :: xice_threshold
+ character(len=80) :: message_text
+
+! MEK MAY 2007
+ FDTLIW=DT/ROWLIW
+! MEK JUL2007
+ FDTW=DT/(XLV*RHOWATER)
+! debug printout
+ IPRINT=.false.
+
+! SLOPETYP=2
+ SLOPETYP=1
+! SHDMIN=0.00
+
+
+ NSOIL=num_soil_layers
+
+ DO NS=1,NSOIL
+ SLDPTH(NS)=DZS(NS)
+ ENDDO
+
+ DO J=jts,jte
+
+ IF(ITIMESTEP.EQ.1)THEN
+ DO 50 I=its,ite
+!*** initialize soil conditions for IHOP 31 May case
+! IF((XLAND(I,J)-1.5) < 0.)THEN
+! if (I==108.and.j==85) then
+! DO NS=1,NSOIL
+! SMOIS(I,NS,J)=0.10
+! SH2O(I,NS,J)=0.10
+! enddo
+! endif
+! ENDIF
+
+!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS
+ IF((XLAND(I,J)-1.5).GE.0.)THEN
+! check sea-ice point
+#if 0
+ IF( XICE(I,J).GE. XICE_THRESHOLD .and. IPRINT ) PRINT*, ' sea-ice at water point, I=',I,'J=',J
+#endif
+!*** Open Water Case
+ SMSTAV(I,J)=1.0
+ SMSTOT(I,J)=1.0
+ DO NS=1,NSOIL
+ SMOIS(I,NS,J)=1.0
+ TSLB(I,NS,J)=273.16 !STEMP
+ SMCREL(I,NS,J)=1.0
+ ENDDO
+ ELSE
+ IF ( XICE(I,J) .GE. XICE_THRESHOLD ) THEN
+!*** SEA-ICE CASE
+ SMSTAV(I,J)=1.0
+ SMSTOT(I,J)=1.0
+ DO NS=1,NSOIL
+ SMOIS(I,NS,J)=1.0
+ SMCREL(I,NS,J)=1.0
+ ENDDO
+ ENDIF
+ ENDIF
+!
+ 50 CONTINUE
+ ENDIF ! end of initialization over ocean
+
+!-----------------------------------------------------------------------
+ DO 100 I=its,ite
+! surface pressure
+ PSFC=P8w3D(i,1,j)
+! pressure in middle of lowest layer
+ SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5
+! convert from mixing ratio to specific humidity
+ Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j))
+!
+! Q2SAT=QGH(I,j)
+ Q2SAT=QGH(I,J)/(1.0+QGH(I,J)) ! Q2SAT is sp humidity
+! add check on myj=.true.
+! IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
+ IF((myj).AND.(Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
+ SATFLG=0.
+ CHKLOWQ(I,J)=0.
+ ELSE
+ SATFLG=1.0
+ CHKLOWQ(I,J)=1.
+ ENDIF
+
+ SFCTMP=T3D(i,1,j)
+ ZLVL=0.5*DZ8W(i,1,j)
+
+! TH2=SFCTMP+(0.0097545*ZLVL)
+! calculate SFCTH2 via Exner function vs lapse-rate (above)
+ APES=(1.E5/PSFC)**CAPA
+ APELM=(1.E5/SFCPRS)**CAPA
+ SFCTH2=SFCTMP*APELM
+ TH2=SFCTH2/APES
+!
+ EMISSI = EMISS(I,J)
+ LWDN=GLW(I,J)*EMISSI
+! SOLDN is total incoming solar
+ SOLDN=SWDOWN(I,J)
+! GSW is net downward solar
+! SOLNET=GSW(I,J)
+! use mid-day albedo to determine net downward solar (no solar zenith angle correction)
+ SOLNET=SOLDN*(1.-ALBEDO(I,J))
+ PRCP=RAINBL(i,j)/DT
+ VEGTYP=IVGTYP(I,J)
+ SOILTYP=ISLTYP(I,J)
+ SHDFAC=VEGFRA(I,J)/100.
+ T1=TSK(I,J)
+ CHK=CHS(I,J)
+ SHMIN=SHDMIN(I,J)/100. !NEW
+ SHMAX=SHDMAX(I,J)/100. !NEW
+! convert snow water equivalent from mm to meter
+ SNEQV=SNOW(I,J)*0.001
+! snow depth in meters
+ SNOWHK=SNOWH(I,J)
+ SNCOVR=SNOWC(I,J)
+
+! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1)
+! SR from e.g. Ferrier microphysics
+! otherwise define from 1st atmos level temperature
+ IF(FRPCPN) THEN
+ FFROZP=SR(I,J)
+ ELSE
+ IF (SFCTMP <= 273.15) THEN
+ FFROZP = 1.0
+ ELSE
+ FFROZP = 0.0
+ ENDIF
+ ENDIF
+!***
+ IF((XLAND(I,J)-1.5).GE.0.)THEN ! begining of land/sea if block
+! Open water points
+ TSK_RURAL(I,J)=TSK(I,J)
+ HFX_RURAL(I,J)=HFX(I,J)
+ QFX_RURAL(I,J)=QFX(I,J)
+ LH_RURAL(I,J)=LH(I,J)
+ EMISS_RURAL(I,J)=EMISS(I,J)
+ GRDFLX_RURAL(I,J)=GRDFLX(I,J)
+ ELSE
+! Land or sea-ice case
+
+ IF (XICE(I,J) >= XICE_THRESHOLD) THEN
+ ! Sea-ice point
+ ICE = 1
+ ELSE IF ( VEGTYP == ISICE ) THEN
+ ! Land-ice point
+ ICE = -1
+ ELSE
+ ! Neither sea ice or land ice.
+ ICE=0
+ ENDIF
+ DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2
+
+ IF(SNOW(I,J).GT.0.0)THEN
+! snow on surface (use ice saturation properties)
+ SFCTSNO=SFCTMP
+ E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO))
+ Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT)
+ Q2SATI=Q2SATI/(1.0+Q2SATI) ! spec. hum.
+ IF (T1 .GT. 273.14) THEN
+! warm ground temps, weight the saturation between ice and water according to SNOWC
+ Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J)
+ DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J)
+ ELSE
+! cold ground temps, use ice saturation only
+ Q2SAT=Q2SATI
+ DQSDT2=Q2SATI*6174./(SFCTSNO**2)
+ ENDIF
+! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero
+ IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J))
+ ENDIF
+
+ IF(ICE.EQ.1)THEN
+ ! Sea-ice point has deep-level temperature of -2 C
+ TBOT=271.16
+ ELSE
+ ! Land-ice or land points have the usual deep-soil temperature.
+ TBOT=TMN(I,J)
+ ENDIF
+ IF(VEGTYP.EQ.25) SHDFAC=0.0000
+ IF(VEGTYP.EQ.26) SHDFAC=0.0000
+ IF(VEGTYP.EQ.27) SHDFAC=0.0000
+ IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN
+#if 0
+ IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT'
+ IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F'
+#endif
+ SOILTYP=7
+ ENDIF
+ SNOALB1 = SNOALB(I,J)
+ CMC=CANWAT(I,J)
+
+!-------------------------------------------
+!*** convert snow depth from mm to meter
+!
+! IF(RDMAXALB) THEN
+! SNOALB=ALBMAX(I,J)*0.01
+! ELSE
+! SNOALB=MAXALB(IVGTPK)*0.01
+! ENDIF
+
+! SNOALB1=0.80
+! SHMIN=0.00
+ ALBBRD=ALBBCK(I,J)
+ Z0BRD=Z0(I,J)
+ EMBRD=EMBCK(I,J)
+ SNOTIME1 = SNOTIME(I,J)
+ RIBB=RIB(I,J)
+!FEI: temporaray arrays above need to be changed later by using SI
+
+ DO 70 NS=1,NSOIL
+ SMC(NS)=SMOIS(I,NS,J)
+ STC(NS)=TSLB(I,NS,J) !STEMP
+ SWC(NS)=SH2O(I,NS,J)
+ 70 CONTINUE
+!
+ if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN
+ SNOWHK= 5.*SNEQV
+ endif
+!
+
+!Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as
+! the "NATURAL" category in the VEGPARM.TBL
+
+ IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
+ IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+ IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+ VEGTYP = NATURAL
+ SHDFAC = SHDTBL(NATURAL)
+ ALBEDOK =0.2 ! 0.2
+ ALBBRD =0.2 !0.2
+ EMISSI = 0.98 !for VEGTYP=5
+ IF ( FRC_URB2D(I,J) < 0.99 ) THEN
+ if(sf_urban_physics.eq.1)then
+ T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J))
+ elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then
+ r1= (tsk(i,j)**4.)
+ r2= frc_urb2d(i,j)*(ts_urb2d(i,j)**4.)
+ r3= (1.-frc_urb2d(i,j))
+ t1= ((r1-r2)/r3)**.25
+ endif
+ ELSE
+ T1 = TSK(I,J)
+ ENDIF
+ ENDIF
+ ELSE
+ IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+ IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+ VEGTYP = ISURBAN
+ ENDIF
+ ENDIF
+
+#if 0
+ IF(IPRINT) THEN
+!
+ print*, 'BEFORE SFLX, in Noahlsm_driver'
+ print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, &
+ 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
+ LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, &
+ 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, &
+ 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
+ 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
+ 'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',&
+ TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
+ STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
+ 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, &
+ 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, &
+ 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
+ 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
+ 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
+ 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
+ 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, &
+ 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, &
+ 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
+ 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
+ endif
+#endif
+
+
+ IF (rdlai2d) THEN
+ xlai = lai(i,j)
+ endif
+
+ CALL SFLX (FFROZP, ICE, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C
+ LOCAL, & !L
+ LUTYPE, SLTYPE, & !CL
+ LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F
+ DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used
+ TH2,Q2SAT,DQSDT2, & !I
+ VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I
+ ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S
+ CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H
+ ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O
+ EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O
+ BETA,ETP,SSOIL, & !O
+ FLX1,FLX2,FLX3, & !O
+ SNOMLT,SNCOVR, & !O
+ RUNOFF1,RUNOFF2,RUNOFF3, & !O
+ RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O
+ SOILW,SOILM,Q1,SMAV, & !D
+ RDLAI2D,USEMONALB, &
+ SNOTIME1, &
+ RIBB, &
+ SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT)
+
+
+ lai(i,j) = xlai
+
+#if 0
+ IF(IPRINT) THEN
+
+ print*, 'AFTER SFLX, in Noahlsm_driver'
+ print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, &
+ 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
+ LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, &
+ 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, &
+ 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
+ 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
+ 'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',&
+ TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
+ STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
+ 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, &
+ 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, &
+ 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
+ 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
+ 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
+ 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
+ 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, &
+ 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, &
+ 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
+ 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
+ endif
+#endif
+
+!*** UPDATE STATE VARIABLES
+ CANWAT(I,J)=CMC
+ SNOW(I,J)=SNEQV*1000.
+! SNOWH(I,J)=SNOWHK*1000.
+ SNOWH(I,J)=SNOWHK ! SNOWHK in meters
+ ALBEDO(I,J)=ALBEDOK
+ ALB_RURAL(I,J)=ALBEDOK
+ ALBBCK(I,J)=ALBBRD
+ Z0(I,J)=Z0BRD
+ EMISS(I,J) = EMISSI
+ EMISS_RURAL(I,J) = EMISSI
+! MEK Nov2006 turn off
+! ZNT(I,J)=Z0K
+ TSK(I,J)=T1
+ TSK_RURAL(I,J)=T1
+ HFX(I,J)=SHEAT
+ HFX_RURAL(I,J)=SHEAT
+! MEk Jul07 add potential evap accum
+ POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW
+ QFX(I,J)=ETA_KINEMATIC
+ QFX_RURAL(I,J)=ETA_KINEMATIC
+ LH(I,J)=ETA
+ LH_RURAL(I,J)=ETA
+ GRDFLX(I,J)=SSOIL
+ GRDFLX_RURAL(I,J)=SSOIL
+ SNOWC(I,J)=SNCOVR
+ CHS2(I,J)=CQS2(I,J)
+ SNOTIME(I,J) = SNOTIME1
+! prevent diagnostic ground q (q1) from being greater than qsat(tsk)
+! as happens over snow cover where the cqs2 value also becomes irrelevant
+! by setting cqs2=chs in this situation the 2m q should become just qv(k=1)
+ IF (Q1 .GT. QSFC(I,J)) THEN
+ CQS2(I,J) = CHS(I,J)
+ ENDIF
+! QSFC(I,J)=Q1
+! Convert QSFC back to mixing ratio
+ QSFC(I,J)= Q1/(1.0-Q1)
+!
+ QSFC_RURAL(I,J)= Q1/(1.0-Q1)
+! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002)
+
+ DO 80 NS=1,NSOIL
+ SMOIS(I,NS,J)=SMC(NS)
+ TSLB(I,NS,J)=STC(NS) ! STEMP
+ SH2O(I,NS,J)=SWC(NS)
+ 80 CONTINUE
+! ENDIF
+
+ !
+ ! Residual of surface energy balance equation terms
+ !
+ noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3
+
+
+ IF (SF_URBAN_PHYSICS == 1 ) THEN ! Beginning of UCM CALL if block
+!--------------------------------------
+! URBAN CANOPY MODEL START - urban
+!--------------------------------------
+! Input variables lsm --> urban
+
+
+ IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+ IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN
+
+! Call urban
+
+!
+ UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial)
+
+ TA_URB = SFCTMP ! [K]
+ QA_URB = Q2K ! [kg/kg]
+ UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.)
+ U1_URB = U_PHY(I,1,J)
+ V1_URB = V_PHY(I,1,J)
+ IF(UA_URB < 1.) UA_URB=1. ! [m/s]
+ SSG_URB = SOLDN ! [W/m/m]
+ SSGD_URB = 0.8*SOLDN ! [W/m/m]
+ SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m]
+ LLG_URB = GLW(I,J) ! [W/m/m]
+ RAIN_URB = RAINBL(I,J) ! [mm]
+ RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m]
+ ZA_URB = ZLVL ! [m]
+ DELT_URB = DT ! [sec]
+ XLAT_URB = XLAT_URB2D(I,J) ! [deg]
+ COSZ_URB = COSZ_URB2D(I,J) !
+ OMG_URB = OMG_URB2D(I,J) !
+ ZNT_URB = ZNT(I,J)
+
+ LSOLAR_URB = .FALSE.
+
+ TR_URB = TR_URB2D(I,J)
+ TB_URB = TB_URB2D(I,J)
+ TG_URB = TG_URB2D(I,J)
+ TC_URB = TC_URB2D(I,J)
+ QC_URB = QC_URB2D(I,J)
+ UC_URB = UC_URB2D(I,J)
+
+ DO K = 1,num_roof_layers
+ TRL_URB(K) = TRL_URB3D(I,K,J)
+ END DO
+ DO K = 1,num_wall_layers
+ TBL_URB(K) = TBL_URB3D(I,K,J)
+ END DO
+ DO K = 1,num_road_layers
+ TGL_URB(K) = TGL_URB3D(I,K,J)
+ END DO
+
+ XXXR_URB = XXXR_URB2D(I,J)
+ XXXB_URB = XXXB_URB2D(I,J)
+ XXXG_URB = XXXG_URB2D(I,J)
+ XXXC_URB = XXXC_URB2D(I,J)
+!
+!
+! Limits to avoid dividing by small number
+ if (CHS(I,J) < 1.0E-02) then
+ CHS(I,J) = 1.0E-02
+ endif
+ if (CHS2(I,J) < 1.0E-02) then
+ CHS2(I,J) = 1.0E-02
+ endif
+ if (CQS2(I,J) < 1.0E-02) then
+ CQS2(I,J) = 1.0E-02
+ endif
+!
+ CHS_URB = CHS(I,J)
+ CHS2_URB = CHS2(I,J)
+ IF (PRESENT(CMR_SFCDIF)) THEN
+ CMR_URB = CMR_SFCDIF(I,J)
+ CHR_URB = CHR_SFCDIF(I,J)
+ CMC_URB = CMC_SFCDIF(I,J)
+ CHC_URB = CHC_SFCDIF(I,J)
+ ENDIF
+!
+! Call urban
+
+ CALL urban(LSOLAR_URB, & ! I
+ num_roof_layers,num_wall_layers,num_road_layers, & ! C
+ DZR,DZB,DZG, & ! C
+ UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I
+ SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB, & ! I
+ ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB, & ! I
+ XLAT_URB,DELT_URB,ZNT_URB, & ! I
+ CHS_URB, CHS2_URB, & ! I
+ TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB, & ! H
+ TRL_URB,TBL_URB,TGL_URB, & ! H
+ XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H
+ TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O
+ SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O
+ GZ1OZ0_URB, & !O
+ CMR_URB, CHR_URB, CMC_URB, CHC_URB, &
+ U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O
+ UST_URB) !O
+
+#if 0
+ IF(IPRINT) THEN
+
+ print*, 'AFTER CALL URBAN'
+ print*,'num_roof_layers',num_roof_layers, 'num_wall_layers', &
+ num_wall_layers, &
+ 'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', &
+ TA_URB, &
+ 'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB', &
+ V1_URB, &
+ 'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB, &
+ 'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB, &
+ 'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,&
+ 'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB, &
+ 'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',&
+ TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB, &
+ 'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB, &
+ 'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,&
+ 'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB', &
+ LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,&
+ 'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB', &
+ RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB, &
+ 'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB, &
+ 'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB
+ endif
+#endif
+
+ TS_URB2D(I,J) = TS_URB
+
+ ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK ![-]
+ HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT ![W/m/m]
+ QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB &
+ + (1-FRC_URB2D(I,J))*ETA_KINEMATIC ![kg/m/m/s]
+ LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA ![W/m/m]
+ GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL ![W/m/m]
+ TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1 ![K]
+ Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1 ![-]
+! Convert QSFC back to mixing ratio
+ QSFC(I,J)= Q1/(1.0-Q1)
+ UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J) ![m/s]
+
+#if 0
+ IF(IPRINT)THEN
+
+ print*, ' FRC_URB2D', FRC_URB2D, &
+ 'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, &
+ 'ALBEDO(I,J)', ALBEDO(I,J), &
+ 'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J), &
+ 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC', &
+ ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J), &
+ 'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J), &
+ 'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),&
+ 'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J), &
+ 'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J)
+ endif
+#endif
+
+
+
+! Renew Urban State Varialbes
+
+ TR_URB2D(I,J) = TR_URB
+ TB_URB2D(I,J) = TB_URB
+ TG_URB2D(I,J) = TG_URB
+ TC_URB2D(I,J) = TC_URB
+ QC_URB2D(I,J) = QC_URB
+ UC_URB2D(I,J) = UC_URB
+
+ DO K = 1,num_roof_layers
+ TRL_URB3D(I,K,J) = TRL_URB(K)
+ END DO
+ DO K = 1,num_wall_layers
+ TBL_URB3D(I,K,J) = TBL_URB(K)
+ END DO
+ DO K = 1,num_road_layers
+ TGL_URB3D(I,K,J) = TGL_URB(K)
+ END DO
+ XXXR_URB2D(I,J) = XXXR_URB
+ XXXB_URB2D(I,J) = XXXB_URB
+ XXXG_URB2D(I,J) = XXXG_URB
+ XXXC_URB2D(I,J) = XXXC_URB
+
+ SH_URB2D(I,J) = SH_URB
+ LH_URB2D(I,J) = LH_URB
+ G_URB2D(I,J) = G_URB
+ RN_URB2D(I,J) = RN_URB
+ PSIM_URB2D(I,J) = PSIM_URB
+ PSIH_URB2D(I,J) = PSIH_URB
+ GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB
+ U10_URB2D(I,J) = U10_URB
+ V10_URB2D(I,J) = V10_URB
+ TH2_URB2D(I,J) = TH2_URB
+ Q2_URB2D(I,J) = Q2_URB
+ UST_URB2D(I,J) = UST_URB
+ AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J))
+ IF (PRESENT(CMR_SFCDIF)) THEN
+ CMR_SFCDIF(I,J) = CMR_URB
+ CHR_SFCDIF(I,J) = CHR_URB
+ CMC_SFCDIF(I,J) = CMC_URB
+ CHC_SFCDIF(I,J) = CHC_URB
+ ENDIF
+ END IF
+
+ ENDIF ! end of UCM CALL if block
+!--------------------------------------
+! Urban Part End - urban
+!--------------------------------------
+
+!*** DIAGNOSTICS
+ SMSTAV(I,J)=SOILW
+ SMSTOT(I,J)=SOILM*1000.
+ DO NS=1,NSOIL
+ SMCREL(I,NS,J)=SMAV(NS)
+ ENDDO
+! Convert the water unit into mm
+ SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0
+ UDRUNOFF(I,J)=UDRUNOFF(I,J)+(RUNOFF2+RUNOFF3)*DT*1000.0
+! snow defined when fraction of frozen precip (FFROZP) > 0.5,
+ IF(FFROZP.GT.0.5)THEN
+ ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT
+ ENDIF
+ IF(SNOW(I,J).GT.0.)THEN
+ ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000.
+! accumulated snow-melt energy
+ SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW
+ ENDIF
+
+ ENDIF ! endif of land-sea test
+
+ 100 CONTINUE ! of I loop
+
+ ENDDO ! of J loop
+
+ IF (SF_URBAN_PHYSICS == 2) THEN
+
+
+ do j=jts,jte
+ do i=its,ite
+ EMISS_URB(i,j)=0.
+ RL_UP_URB(i,j)=0.
+ RS_ABS_URB(i,j)=0.
+ GRDFLX_URB(i,j)=0.
+ end do
+ end do
+ CALL BEP(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, &
+ th_phy,rho,p_phy,swdown,glw, &
+ gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, &
+ num_urban_layers, &
+ trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, &
+ sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, &
+ a_u_bep,a_v_bep,a_t_bep, &
+ a_e_bep,b_u_bep,b_v_bep, &
+ b_t_bep,b_e_bep,dlg_bep, &
+ dl_u_bep,sf_bep,vl_bep, &
+ rl_up_urb,rs_abs_urb,emiss_urb,grdflx_urb, &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte )
+
+ ENDIF
+
+
+ IF (SF_URBAN_PHYSICS == 3) THEN
+
+
+ do j=jts,jte
+ do i=its,ite
+ EMISS_URB(i,j)=0.
+ RL_UP_URB(i,j)=0.
+ RS_ABS_URB(i,j)=0.
+ GRDFLX_URB(i,j)=0.
+ end do
+ end do
+
+ CALL BEP_BEM(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, &
+ th_phy,rho,p_phy,swdown,glw, &
+ gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, &
+ num_urban_layers, &
+ trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, &
+ tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d, &
+ tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, &
+ cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d, &
+ sfwin1_urb3d,sfwin2_urb3d, &
+ sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, &
+ a_u_bep,a_v_bep,a_t_bep, &
+ a_e_bep,b_u_bep,b_v_bep, &
+ b_t_bep,b_e_bep,b_q_bep,dlg_bep, &
+ dl_u_bep,sf_bep,vl_bep, &
+ rl_up_urb,rs_abs_urb,emiss_urb,grdflx_urb,qv3d, &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte )
+
+ ENDIF
+
+ if((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then !Bep begin
+! fix the value of the Stefan-Boltzmann constant
+ sigma_sb=5.67e-08
+ do j=jts,jte
+ do i=its,ite
+ UMOM_URB(I,J)=0.
+ VMOM_URB(I,J)=0.
+ HFX_URB(I,J)=0.
+ QFX_URB(I,J)=0.
+ do k=kts,kte
+ a_u_bep(i,k,j)=a_u_bep(i,k,j)*frc_urb2d(i,j)
+ a_v_bep(i,k,j)=a_v_bep(i,k,j)*frc_urb2d(i,j)
+ a_t_bep(i,k,j)=a_t_bep(i,k,j)*frc_urb2d(i,j)
+ a_q_bep(i,k,j)=0.
+ a_e_bep(i,k,j)=0.
+ b_u_bep(i,k,j)=b_u_bep(i,k,j)*frc_urb2d(i,j)
+ b_v_bep(i,k,j)=b_v_bep(i,k,j)*frc_urb2d(i,j)
+ b_t_bep(i,k,j)=b_t_bep(i,k,j)*frc_urb2d(i,j)
+ b_q_bep(i,k,j)=b_q_bep(i,k,j)*frc_urb2d(i,j)
+ b_e_bep(i,k,j)=b_e_bep(i,k,j)*frc_urb2d(i,j)
+ HFX_URB(I,J)=HFX_URB(I,J)+B_T_BEP(I,K,J)*RHO(I,K,J)*CP* &
+ DZ8W(I,K,J)*VL_BEP(I,K,J)
+ QFX_URB(I,J)=QFX_URB(I,J)+B_Q_BEP(I,K,J)* &
+ DZ8W(I,K,J)*VL_BEP(I,K,J)
+ UMOM_URB(I,J)=UMOM_URB(I,J)+ (A_U_BEP(I,K,J)*U_PHY(I,K,J)+ &
+ B_U_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J)
+ VMOM_URB(I,J)=VMOM_URB(I,J)+ (A_V_BEP(I,K,J)*V_PHY(I,K,J)+ &
+ B_V_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J)
+ vl_bep(i,k,j)=(1.-frc_urb2d(i,j))+vl_bep(i,k,j)*frc_urb2d(i,j)
+ sf_bep(i,k,j)=(1.-frc_urb2d(i,j))+sf_bep(i,k,j)*frc_urb2d(i,j)
+ end do
+ a_u_bep(i,1,j)=(1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/ &
+ ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_u_bep(i,1,j)
+ a_v_bep(i,1,j)=(1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/ &
+ ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_v_bep(i,1,j)
+ b_t_bep(i,1,j)=(1.-frc_urb2d(i,j))*hfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)/CP+ &
+ b_t_bep(i,1,j)
+ b_q_bep(i,1,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)+b_q_bep(i,1,j)
+ umom=(1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*u_phy(i,1,j)/ &
+ ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+umom_urb(i,j)
+ vmom=(1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*v_phy(i,1,j)/ &
+ ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+vmom_urb(i,j)
+ sf_bep(i,1,j)=1.
+
+! compute upward longwave radiation from the rural part and total
+! rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j)
+! rl_up_tot=(1.-frc_urb2d(i,j))*rl_up_rural+frc_urb2d(i,j)*rl_up_urb(i,j)
+! emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j)
+! using the emissivity and the total longwave upward radiation estimate the averaged skin temperature
+ IF (FRC_URB2D(I,J).GT.0.) THEN
+ rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j)
+ rl_up_tot=(1.-frc_urb2d(i,j))*rl_up_rural+frc_urb2d(i,j)*rl_up_urb(i,j)
+ emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j)
+ ts_urb2d(i,j)=((-rl_up_urb(i,j)-(1.-emiss_urb(i,j))*glw(i,j))/emiss_urb(i,j)/sigma_sb)**0.25
+ tsk(i,j)=( (-1.*rl_up_tot-(1.-emiss(i,j))*glw(i,j) )/emiss(i,j)/sigma_sb)**.25
+ rs_abs_tot=(1.-frc_urb2d(i,j))*swdown(i,j)*(1.-albedo(i,j))+frc_urb2d(i,j)*rs_abs_urb(i,j)
+ if(swdown(i,j).gt.0.)then
+ albedo(i,j)=1.-rs_abs_tot/swdown(i,j)
+ else
+ albedo(i,j)=alb_rural(i,j)
+ endif
+! rename *_urb to sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d
+ grdflx(i,j)= (1.-frc_urb2d(i,j))*grdflx_rural(i,j)+frc_urb2d(i,j)*grdflx_urb(i,j)
+ qfx(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)+qfx_urb(i,j)
+! lh(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)*xlv
+ lh(i,j)=qfx(i,j)*xlv
+ HFX(I,J) = HFX_URB(I,J)+(1-FRC_URB2D(I,J))*HFX_RURAL(I,J) ![W/m/m]
+ SH_URB2D(I,J) = HFX_URB(I,J)/FRC_URB2D(I,J)
+ LH_URB2D(I,J) = qfx_urb(i,j)*xlv
+ G_URB2D(I,J) = grdflx_urb(i,j)
+ RN_URB2D(I,J) = rs_abs_urb(i,j)+emiss_urb(i,j)*glw(i,j)-rl_up_urb(i,j)
+ ust(i,j)=(umom**2.+vmom**2.)**.25
+! if(tsk(i,j).gt.350)write(*,*)'tsk too big!',i,j,tsk(i,j)
+! if(tsk(i,j).lt.260)write(*,*)'tsk too small!',i,j,tsk(i,j),rl_up_tot,rl_up_urb(i,j),rl_up_rural
+! print*,'ivgtyp,i,j,sigma_sb',ivgtyp(i,j),i,j,sigma_sb
+! print*,'hfx,lh,qfx,grdflx,ts_urb2d',hfx(i,j),lh(i,j),qfx(i,j),grdflx(i,j),ts_urb2d(i,j)
+! print*,'tsk,albedo,emiss',tsk(i,j),albedo(i,j),emiss(i,j)
+! if(i.eq.56.and.j.eq.29)then
+! print*,'ivgtyp, qfx, hfx',ivgtyp(i,j),hfx_rural(i,j),qfx_rural(i,j)
+! print*,'emiss_rural,emiss_urb',emiss_rural(i,j),emiss_urb(i,j)
+! print*,'rl_up_rural,rl_up_urb(i,j)',rl_up_rural,rl_up_urb(i,j)
+! print*,'tsk_rural,ts_urb2d(i,j),tsk',tsk_rural(i,j),ts_urb2d(i,j),tsk(i,j)
+! print*,'reconstruction fei',((emiss(i,j)*tsk(i,j)**4.-frc_urb2d(i,j)*emiss_urb(i,j)*ts_urb2d(i,j)**4.)/(emiss_rural(i,j)*(1.-frc_urb2d(i,j))))**.25
+! print*,'ivgtyp,hfx,hfx_urb,hfx_rural',hfx(i,j),hfx_urb(i,j),hfx_rural(i,j)
+! print*,'lh,lh_rural',lh(i,j),lh_rural(i,j)
+! print*,'qfx',qfx(i,j)
+! print*,'ts_urb2d',ts_urb2d(i,j)
+! print*,'ust',ust(i,j)
+! print*,'swdown,glw',swdown(i,j),glw(i,j)
+! endif
+ else
+ SH_URB2D(I,J) = 0.
+ LH_URB2D(I,J) = 0.
+ G_URB2D(I,J) = 0.
+ RN_URB2D(I,J) = 0.
+ endif
+! IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. &
+! IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+! print*,'ivgtyp, qfx, hfx',ivgtyp(i,j),hfx_rural(i,j),qfx_rural(i,j)
+! print*,'ivgtyp,hfx,hfx_urb,hfx_rural',hfx(i,j),hfx_urb(i,j),hfx_rural(i,j)
+! print*,'lh,lh_rural',lh(i,j),lh_rural(i,j)
+! print*,'qfx',qfx(i,j)
+! print*,'ts_urb2d',ts_urb2d(i,j)
+! print*,'ust',ust(i,j)
+! endif
+ enddo
+ enddo
+
+
+ endif !Bep end
+
+!------------------------------------------------------
+ END SUBROUTINE lsm
+!------------------------------------------------------
+
+!ldf (01-04-2011): This section of the module is moved to module_physics_lsm_noahinit.F in
+!./../core_physics to accomodate differences in the mpi calls between WRF and MPAS.I thought
+!that it would be cleaner to do this instead of adding a lot of #ifdef statements throughout
+!the initialization subroutine.
+
+#ifndef non_hydrostatic_core
+
+ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, &
+ SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW, &
+ ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, &
+ MMINLU, &
+ SNOALB, FNDSOILW, FNDSNOWH, RDMAXALB, &
+ num_soil_layers, restart, &
+ allowed_to_read , &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte )
+
+ INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte
+
+ INTEGER, INTENT(IN) :: num_soil_layers
+
+ LOGICAL , INTENT(IN) :: restart , allowed_to_read
+
+ REAL, DIMENSION( num_soil_layers), INTENT(INOUT) :: ZS, DZS
+
+ REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
+ INTENT(INOUT) :: SMOIS, & !Total soil moisture
+ SH2O, & !liquid soil moisture
+ TSLB !STEMP
+
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(INOUT) :: SNOW, &
+ SNOWH, &
+ SNOWC, &
+ SNOALB, &
+ CANWAT, &
+ SMSTAV, &
+ SMSTOT, &
+ SFCRUNOFF, &
+ UDRUNOFF, &
+ ACSNOW, &
+ VEGFRA, &
+ ACSNOM
+
+ INTEGER, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(IN) :: IVGTYP, &
+ ISLTYP
+ CHARACTER(LEN=*), INTENT(IN) :: MMINLU
+
+ LOGICAL, INTENT(IN) :: FNDSOILW , &
+ FNDSNOWH
+ LOGICAL, INTENT(IN) :: RDMAXALB
+
+
+ INTEGER :: L
+ REAL :: BX, SMCMAX, PSISAT, FREE
+ REAL, PARAMETER :: BLIM = 5.5, HLICE = 3.335E5, &
+ GRAV = 9.81, T0 = 273.15
+ INTEGER :: errflag
+
+ character*256 :: MMINSL
+ MMINSL='STAS'
+!
+
+! initialize three Noah LSM related tables
+ IF ( allowed_to_read ) THEN
+! CALL wrf_message( 'INITIALIZE THREE Noah LSM RELATED TABLES' )
+ CALL SOIL_VEG_GEN_PARM( MMINLU, MMINSL )
+ ENDIF
+
+#ifdef WRF_CHEM
+!
+! need this parameter for dust parameterization in wrf/chem
+!
+ do I=1,NSLTYPE
+ porosity(i)=maxsmc(i)
+ enddo
+#endif
+
+ IF(.not.restart)THEN
+
+ itf=min0(ite,ide-1)
+ jtf=min0(jte,jde-1)
+
+ errflag = 0
+ DO j = jts,jtf
+ DO i = its,itf
+ IF ( ISLTYP( i,j ) .LT. 1 ) THEN
+ errflag = 1
+ WRITE(err_message,*)"module_sf_noahlsm.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j )
+ CALL wrf_message(err_message)
+ ENDIF
+ IF(.not.RDMAXALB) THEN
+ SNOALB(i,j)=MAXALB(IVGTYP(i,j))*0.01
+ ENDIF
+ ENDDO
+ ENDDO
+ IF ( errflag .EQ. 1 ) THEN
+ CALL wrf_error_fatal( "module_sf_noahlsm.F: lsminit: out of range value "// &
+ "of ISLTYP. Is this field in the input?" )
+ ENDIF
+
+! initialize soil liquid water content SH2O
+
+! IF(.NOT.FNDSOILW) THEN
+
+! If no SWC, do the following
+! PRINT *,'SOIL WATER NOT FOUND - VALUE SET IN LSMINIT'
+ DO J = jts,jtf
+ DO I = its,itf
+ BX = BB(ISLTYP(I,J))
+ SMCMAX = MAXSMC(ISLTYP(I,J))
+ PSISAT = SATPSI(ISLTYP(I,J))
+ if ((bx > 0.0).and.(smcmax > 0.0).and.(psisat > 0.0)) then
+ DO NS=1, num_soil_layers
+! ----------------------------------------------------------------------
+!SH2O <= SMOIS for T < 273.149K (-0.001C)
+ IF (TSLB(I,NS,J) < 273.149) THEN
+! ----------------------------------------------------------------------
+! first guess following explicit solution for Flerchinger Eqn from Koren
+! et al, JGR, 1999, Eqn 17 (KCOUNT=0 in FUNCTION FRH2O).
+! ISLTPK is soil type
+ BX = BB(ISLTYP(I,J))
+ SMCMAX = MAXSMC(ISLTYP(I,J))
+ PSISAT = SATPSI(ISLTYP(I,J))
+ IF ( BX > BLIM ) BX = BLIM
+ FK=(( (HLICE/(GRAV*(-PSISAT))) * &
+ ((TSLB(I,NS,J)-T0)/TSLB(I,NS,J)) )**(-1/BX) )*SMCMAX
+ IF (FK < 0.02) FK = 0.02
+ SH2O(I,NS,J) = MIN( FK, SMOIS(I,NS,J) )
+! ----------------------------------------------------------------------
+! now use iterative solution for liquid soil water content using
+! FUNCTION FRH2O with the initial guess for SH2O from above explicit
+! first guess.
+ CALL FRH2O (FREE,TSLB(I,NS,J),SMOIS(I,NS,J),SH2O(I,NS,J), &
+ SMCMAX,BX,PSISAT)
+ SH2O(I,NS,J) = FREE
+ ELSE ! of IF (TSLB(I,NS,J)
+! ----------------------------------------------------------------------
+! SH2O = SMOIS ( for T => 273.149K (-0.001C)
+ SH2O(I,NS,J)=SMOIS(I,NS,J)
+! ----------------------------------------------------------------------
+ ENDIF ! of IF (TSLB(I,NS,J)
+ END DO ! of DO NS=1, num_soil_layers
+ else ! of if ((bx > 0.0)
+ DO NS=1, num_soil_layers
+ SH2O(I,NS,J)=SMOIS(I,NS,J)
+ END DO
+ endif ! of if ((bx > 0.0)
+ ENDDO ! DO I = its,itf
+ ENDDO ! DO J = jts,jtf
+! ENDIF ! of IF(.NOT.FNDSOILW)THEN
+
+! initialize physical snow height SNOWH
+
+ IF(.NOT.FNDSNOWH)THEN
+! If no SNOWH do the following
+ CALL wrf_message( 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' )
+ DO J = jts,jtf
+ DO I = its,itf
+ SNOWH(I,J)=SNOW(I,J)*0.005 ! SNOW in mm and SNOWH in m
+ ENDDO
+ ENDDO
+ ENDIF
+
+! initialize canopy water to ZERO
+
+! GO TO 110
+! print*,'Note that canopy water content (CANWAT) is set to ZERO in LSMINIT'
+ DO J = jts,jtf
+ DO I = its,itf
+ CANWAT(I,J)=0.0
+ ENDDO
+ ENDDO
+ 110 CONTINUE
+
+ ENDIF
+!------------------------------------------------------------------------------
+ END SUBROUTINE lsminit
+!------------------------------------------------------------------------------
+
+
+
+!-----------------------------------------------------------------
+ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL)
+!-----------------------------------------------------------------
+
+! USE module_wrf_error
+ IMPLICIT NONE
+
+ CHARACTER(LEN=*), INTENT(IN) :: MMINLU, MMINSL
+ integer :: LUMATCH, IINDEX, LC, NUM_SLOPE
+ integer :: ierr
+ INTEGER , PARAMETER :: OPEN_OK = 0
+
+ character*128 :: mess , message
+ logical, external :: wrf_dm_on_monitor
+
+
+!-----SPECIFY VEGETATION RELATED CHARACTERISTICS :
+! ALBBCK: SFC albedo (in percentage)
+! Z0: Roughness length (m)
+! SHDFAC: Green vegetation fraction (in percentage)
+! Note: The ALBEDO, Z0, and SHDFAC values read from the following table
+! ALBEDO, amd Z0 are specified in LAND-USE TABLE; and SHDFAC is
+! the monthly green vegetation data
+! CMXTBL: MAX CNPY Capacity (m)
+! NROTBL: Rooting depth (layer)
+! RSMIN: Mimimum stomatal resistance (s m-1)
+! RSMAX: Max. stomatal resistance (s m-1)
+! RGL: Parameters used in radiation stress function
+! HS: Parameter used in vapor pressure deficit functio
+! TOPT: Optimum transpiration air temperature. (K)
+! CMCMAX: Maximum canopy water capacity
+! CFACTR: Parameter used in the canopy inteception calculati
+! SNUP: Threshold snow depth (in water equivalent m) that
+! implies 100% snow cover
+! LAI: Leaf area index (dimensionless)
+! MAXALB: Upper bound on maximum albedo over deep snow
+!
+!-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL
+!
+
+ IF ( wrf_dm_on_monitor() ) THEN
+
+ OPEN(19, FILE='VEGPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
+ IF(ierr .NE. OPEN_OK ) THEN
+ WRITE(message,FMT='(A)') &
+ 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening VEGPARM.TBL'
+ CALL wrf_error_fatal ( message )
+ END IF
+
+
+ LUMATCH=0
+
+ FIND_LUTYPE : DO WHILE (LUMATCH == 0)
+ READ (19,*,END=2002)
+ READ (19,*,END=2002)LUTYPE
+ READ (19,*)LUCATS,IINDEX
+
+ IF(LUTYPE.EQ.MMINLU)THEN
+ WRITE( mess , * ) 'LANDUSE TYPE = ' // TRIM ( LUTYPE ) // ' FOUND', LUCATS,' CATEGORIES'
+ CALL wrf_message( mess )
+ LUMATCH=1
+ ELSE
+ call wrf_message ( "Skipping over LUTYPE = " // TRIM ( LUTYPE ) )
+ DO LC = 1, LUCATS+12
+ read(19,*)
+ ENDDO
+ ENDIF
+ ENDDO FIND_LUTYPE
+! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
+ IF ( SIZE(SHDTBL) < LUCATS .OR. &
+ SIZE(NROTBL) < LUCATS .OR. &
+ SIZE(RSTBL) < LUCATS .OR. &
+ SIZE(RGLTBL) < LUCATS .OR. &
+ SIZE(HSTBL) < LUCATS .OR. &
+ SIZE(SNUPTBL) < LUCATS .OR. &
+ SIZE(MAXALB) < LUCATS .OR. &
+ SIZE(LAIMINTBL) < LUCATS .OR. &
+ SIZE(LAIMAXTBL) < LUCATS .OR. &
+ SIZE(Z0MINTBL) < LUCATS .OR. &
+ SIZE(Z0MAXTBL) < LUCATS .OR. &
+ SIZE(ALBEDOMINTBL) < LUCATS .OR. &
+ SIZE(ALBEDOMAXTBL) < LUCATS .OR. &
+ SIZE(EMISSMINTBL ) < LUCATS .OR. &
+ SIZE(EMISSMAXTBL ) < LUCATS ) THEN
+ CALL wrf_error_fatal('Table sizes too small for value of LUCATS in module_sf_noahdrv.F')
+ ENDIF
+
+ IF(LUTYPE.EQ.MMINLU)THEN
+ DO LC=1,LUCATS
+ READ (19,*)IINDEX,SHDTBL(LC), &
+ NROTBL(LC),RSTBL(LC),RGLTBL(LC),HSTBL(LC), &
+ SNUPTBL(LC),MAXALB(LC), LAIMINTBL(LC), &
+ LAIMAXTBL(LC),EMISSMINTBL(LC), &
+ EMISSMAXTBL(LC), ALBEDOMINTBL(LC), &
+ ALBEDOMAXTBL(LC), Z0MINTBL(LC), Z0MAXTBL(LC)
+ ENDDO
+!
+ READ (19,*)
+ READ (19,*)TOPT_DATA
+ READ (19,*)
+ READ (19,*)CMCMAX_DATA
+ READ (19,*)
+ READ (19,*)CFACTR_DATA
+ READ (19,*)
+ READ (19,*)RSMAX_DATA
+ READ (19,*)
+ READ (19,*)BARE
+ READ (19,*)
+ READ (19,*)NATURAL
+ ENDIF
+!
+ 2002 CONTINUE
+
+ CLOSE (19)
+ IF (LUMATCH == 0) then
+ CALL wrf_error_fatal ("Land Use Dataset '"//MMINLU//"' not found in VEGPARM.TBL.")
+ ENDIF
+ ENDIF
+
+ CALL wrf_dm_bcast_string ( LUTYPE , 4 )
+ CALL wrf_dm_bcast_integer ( LUCATS , 1 )
+ CALL wrf_dm_bcast_integer ( IINDEX , 1 )
+ CALL wrf_dm_bcast_integer ( LUMATCH , 1 )
+ CALL wrf_dm_bcast_real ( SHDTBL , NLUS )
+ CALL wrf_dm_bcast_real ( NROTBL , NLUS )
+ CALL wrf_dm_bcast_real ( RSTBL , NLUS )
+ CALL wrf_dm_bcast_real ( RGLTBL , NLUS )
+ CALL wrf_dm_bcast_real ( HSTBL , NLUS )
+ CALL wrf_dm_bcast_real ( SNUPTBL , NLUS )
+ CALL wrf_dm_bcast_real ( LAIMINTBL , NLUS )
+ CALL wrf_dm_bcast_real ( LAIMAXTBL , NLUS )
+ CALL wrf_dm_bcast_real ( Z0MINTBL , NLUS )
+ CALL wrf_dm_bcast_real ( Z0MAXTBL , NLUS )
+ CALL wrf_dm_bcast_real ( EMISSMINTBL , NLUS )
+ CALL wrf_dm_bcast_real ( EMISSMAXTBL , NLUS )
+ CALL wrf_dm_bcast_real ( ALBEDOMINTBL , NLUS )
+ CALL wrf_dm_bcast_real ( ALBEDOMAXTBL , NLUS )
+ CALL wrf_dm_bcast_real ( MAXALB , NLUS )
+ CALL wrf_dm_bcast_real ( TOPT_DATA , 1 )
+ CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 )
+ CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 )
+ CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 )
+ CALL wrf_dm_bcast_integer ( BARE , 1 )
+ CALL wrf_dm_bcast_integer ( NATURAL , 1 )
+
+!
+!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL
+!
+ IF ( wrf_dm_on_monitor() ) THEN
+ OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
+ IF(ierr .NE. OPEN_OK ) THEN
+ WRITE(message,FMT='(A)') &
+ 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening SOILPARM.TBL'
+ CALL wrf_error_fatal ( message )
+ END IF
+
+ WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICAION = ', TRIM ( MMINSL )
+ CALL wrf_message( mess )
+
+ LUMATCH=0
+
+ READ (19,*)
+ READ (19,2000,END=2003)SLTYPE
+ 2000 FORMAT (A4)
+ READ (19,*)SLCATS,IINDEX
+ IF(SLTYPE.EQ.MMINSL)THEN
+ WRITE( mess , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', &
+ SLCATS,' CATEGORIES'
+ CALL wrf_message ( mess )
+ LUMATCH=1
+ ENDIF
+! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
+ IF ( SIZE(BB ) < SLCATS .OR. &
+ SIZE(DRYSMC) < SLCATS .OR. &
+ SIZE(F11 ) < SLCATS .OR. &
+ SIZE(MAXSMC) < SLCATS .OR. &
+ SIZE(REFSMC) < SLCATS .OR. &
+ SIZE(SATPSI) < SLCATS .OR. &
+ SIZE(SATDK ) < SLCATS .OR. &
+ SIZE(SATDW ) < SLCATS .OR. &
+ SIZE(WLTSMC) < SLCATS .OR. &
+ SIZE(QTZ ) < SLCATS ) THEN
+ CALL wrf_error_fatal('Table sizes too small for value of SLCATS in module_sf_noahdrv.F')
+ ENDIF
+ IF(SLTYPE.EQ.MMINSL)THEN
+ DO LC=1,SLCATS
+ READ (19,*) IINDEX,BB(LC),DRYSMC(LC),F11(LC),MAXSMC(LC),&
+ REFSMC(LC),SATPSI(LC),SATDK(LC), SATDW(LC), &
+ WLTSMC(LC), QTZ(LC)
+ ENDDO
+ ENDIF
+
+ 2003 CONTINUE
+
+ CLOSE (19)
+ ENDIF
+
+ CALL wrf_dm_bcast_integer ( LUMATCH , 1 )
+ CALL wrf_dm_bcast_string ( SLTYPE , 4 )
+ CALL wrf_dm_bcast_string ( MMINSL , 4 ) ! since this is reset above, see oct2 ^
+ CALL wrf_dm_bcast_integer ( SLCATS , 1 )
+ CALL wrf_dm_bcast_integer ( IINDEX , 1 )
+ CALL wrf_dm_bcast_real ( BB , NSLTYPE )
+ CALL wrf_dm_bcast_real ( DRYSMC , NSLTYPE )
+ CALL wrf_dm_bcast_real ( F11 , NSLTYPE )
+ CALL wrf_dm_bcast_real ( MAXSMC , NSLTYPE )
+ CALL wrf_dm_bcast_real ( REFSMC , NSLTYPE )
+ CALL wrf_dm_bcast_real ( SATPSI , NSLTYPE )
+ CALL wrf_dm_bcast_real ( SATDK , NSLTYPE )
+ CALL wrf_dm_bcast_real ( SATDW , NSLTYPE )
+ CALL wrf_dm_bcast_real ( WLTSMC , NSLTYPE )
+ CALL wrf_dm_bcast_real ( QTZ , NSLTYPE )
+
+ IF(LUMATCH.EQ.0)THEN
+ CALL wrf_message( 'SOIl TEXTURE IN INPUT FILE DOES NOT ' )
+ CALL wrf_message( 'MATCH SOILPARM TABLE' )
+ CALL wrf_error_fatal ( 'INCONSISTENT OR MISSING SOILPARM FILE' )
+ ENDIF
+
+!
+!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL
+!
+ IF ( wrf_dm_on_monitor() ) THEN
+ OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
+ IF(ierr .NE. OPEN_OK ) THEN
+ WRITE(message,FMT='(A)') &
+ 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening GENPARM.TBL'
+ CALL wrf_error_fatal ( message )
+ END IF
+
+ READ (19,*)
+ READ (19,*)
+ READ (19,*) NUM_SLOPE
+
+ SLPCATS=NUM_SLOPE
+! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
+ IF ( SIZE(slope_data) < NUM_SLOPE ) THEN
+ CALL wrf_error_fatal('NUM_SLOPE too large for slope_data array in module_sf_noahdrv')
+ ENDIF
+
+ DO LC=1,SLPCATS
+ READ (19,*)SLOPE_DATA(LC)
+ ENDDO
+
+ READ (19,*)
+ READ (19,*)SBETA_DATA
+ READ (19,*)
+ READ (19,*)FXEXP_DATA
+ READ (19,*)
+ READ (19,*)CSOIL_DATA
+ READ (19,*)
+ READ (19,*)SALP_DATA
+ READ (19,*)
+ READ (19,*)REFDK_DATA
+ READ (19,*)
+ READ (19,*)REFKDT_DATA
+ READ (19,*)
+ READ (19,*)FRZK_DATA
+ READ (19,*)
+ READ (19,*)ZBOT_DATA
+ READ (19,*)
+ READ (19,*)CZIL_DATA
+ READ (19,*)
+ READ (19,*)SMLOW_DATA
+ READ (19,*)
+ READ (19,*)SMHIGH_DATA
+ READ (19,*)
+ READ (19,*)LVCOEF_DATA
+ CLOSE (19)
+ ENDIF
+
+ CALL wrf_dm_bcast_integer ( NUM_SLOPE , 1 )
+ CALL wrf_dm_bcast_integer ( SLPCATS , 1 )
+ CALL wrf_dm_bcast_real ( SLOPE_DATA , NSLOPE )
+ CALL wrf_dm_bcast_real ( SBETA_DATA , 1 )
+ CALL wrf_dm_bcast_real ( FXEXP_DATA , 1 )
+ CALL wrf_dm_bcast_real ( CSOIL_DATA , 1 )
+ CALL wrf_dm_bcast_real ( SALP_DATA , 1 )
+ CALL wrf_dm_bcast_real ( REFDK_DATA , 1 )
+ CALL wrf_dm_bcast_real ( REFKDT_DATA , 1 )
+ CALL wrf_dm_bcast_real ( FRZK_DATA , 1 )
+ CALL wrf_dm_bcast_real ( ZBOT_DATA , 1 )
+ CALL wrf_dm_bcast_real ( CZIL_DATA , 1 )
+ CALL wrf_dm_bcast_real ( SMLOW_DATA , 1 )
+ CALL wrf_dm_bcast_real ( SMHIGH_DATA , 1 )
+ CALL wrf_dm_bcast_real ( LVCOEF_DATA , 1 )
+
+
+!-----------------------------------------------------------------
+ END SUBROUTINE SOIL_VEG_GEN_PARM
+!-----------------------------------------------------------------
+
+#endif
+
+END MODULE module_sf_noahdrv
Added: branches/atmos_physics/src/core_physics/physics_wrf/module_sf_noahlsm.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_sf_noahlsm.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_sf_noahlsm.F 2011-01-13 23:29:23 UTC (rev 685)
@@ -0,0 +1,4458 @@
+MODULE module_sf_noahlsm
+
+#ifdef non_hydrostatic_core
+!MPAS specific (Laura D. Fowler):
+use module_physics_constants, rhowater => rho_w
+#elif hydrostatic_core
+!MPAS specific (Laura D. Fowler):
+use module_physics_constants, rhowater => rho_w
+#else
+ USE module_model_constants
+#endif
+!MPAS specific end.
+
+
+! REAL, PARAMETER :: CP = 1004.5
+ REAL, PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, &
+ CPH2O = 4.218E+3,CPICE = 2.106E+3, &
+ LSUBF = 3.335E+5, &
+ EMISSI_S = 0.95
+
+! VEGETATION PARAMETERS
+ INTEGER :: LUCATS , BARE
+ INTEGER :: NATURAL
+ integer, PARAMETER :: NLUS=50
+ CHARACTER(LEN=256) LUTYPE
+ INTEGER, DIMENSION(1:NLUS) :: NROTBL
+ real, dimension(1:NLUS) :: SNUPTBL, RSTBL, RGLTBL, HSTBL, &
+ SHDTBL, MAXALB, &
+ EMISSMINTBL, EMISSMAXTBL, &
+ LAIMINTBL, LAIMAXTBL, &
+ Z0MINTBL, Z0MAXTBL, &
+ ALBEDOMINTBL, ALBEDOMAXTBL
+ REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA
+
+! SOIL PARAMETERS
+ INTEGER :: SLCATS
+ INTEGER, PARAMETER :: NSLTYPE=30
+ CHARACTER(LEN=256) SLTYPE
+ REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, &
+ MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ
+
+! LSM GENERAL PARAMETERS
+ INTEGER :: SLPCATS
+ INTEGER, PARAMETER :: NSLOPE=30
+ REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA
+ REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, &
+ REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, &
+ CZIL_DATA
+ REAL :: LVCOEF_DATA
+
+ CHARACTER*256 :: err_message
+
+!
+CONTAINS
+!
+
+ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C
+ LOCAL, & !L
+ LLANDUSE, LSOIL, & !CL
+ LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2,SFCSPD, & !F
+ COSZ,PRCPRAIN, SOLARDIRECT, & !F
+ TH2,Q2SAT,DQSDT2, & !I
+ VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHDMIN,SHDMAX, & !I
+ ALB, SNOALB,TBOT, Z0BRD, Z0, EMISSI, EMBRD, & !S
+ CMC,T1,STC,SMC,SH2O,SNOWH,SNEQV,ALBEDO,CH,CM, & !H
+! ----------------------------------------------------------------------
+! OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN
+! COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA
+! MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES.
+! ----------------------------------------------------------------------
+ ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O
+ EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O
+ BETA,ETP,SSOIL, & !O
+ FLX1,FLX2,FLX3, & !O
+ SNOMLT,SNCOVR, & !O
+ RUNOFF1,RUNOFF2,RUNOFF3, & !O
+ RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O
+ SOILW,SOILM,Q1,SMAV, & !D
+ RDLAI2D,USEMONALB, &
+ SNOTIME1, &
+ RIBB, &
+ SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT) !P
+! ----------------------------------------------------------------------
+! SUBROUTINE SFLX - UNIFIED NOAHLSM VERSION 1.0 JULY 2007
+! ----------------------------------------------------------------------
+! SUB-DRIVER FOR "Noah LSM" FAMILY OF PHYSICS SUBROUTINES FOR A
+! SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE SOIL MOISTURE, SOIL
+! ICE, SOIL TEMPERATURE, SKIN TEMPERATURE, SNOWPACK WATER CONTENT,
+! SNOWDEPTH, AND ALL TERMS OF THE SURFACE ENERGY BALANCE AND SURFACE
+! WATER BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF DOWNWARD
+! RADIATION AND PRECIP)
+! ----------------------------------------------------------------------
+! SFLX ARGUMENT LIST KEY:
+! ----------------------------------------------------------------------
+! C CONFIGURATION INFORMATION
+! L LOGICAL
+! CL 4-string character bearing logical meaning
+! F FORCING DATA
+! I OTHER (INPUT) FORCING DATA
+! S SURFACE CHARACTERISTICS
+! H HISTORY (STATE) VARIABLES
+! O OUTPUT VARIABLES
+! D DIAGNOSTIC OUTPUT
+! P Parameters
+! Msic Miscellaneous terms passed from gridded driver
+! ----------------------------------------------------------------------
+! 1. CONFIGURATION INFORMATION (C):
+! ----------------------------------------------------------------------
+! ICE SEA-ICE FLAG (=1: SEA-ICE, =0: LAND (NO ICE), --1 LAND-ICE).
+! DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND
+! 1800 SECS OR LESS)
+! ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES
+! NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2, AND NOT GREATER THAN
+! PARAMETER NSOLD SET BELOW)
+! SLDPTH THE THICKNESS OF EACH SOIL LAYER (M)
+! ----------------------------------------------------------------------
+! 2. LOGICAL:
+! ----------------------------------------------------------------------
+! LCH Exchange coefficient (Ch) calculation flag (false: using
+! ch-routine SFCDIF; true: Ch is brought in)
+! LOCAL Flag for local-site simulation (where there is no
+! maps for albedo, veg fraction, and roughness
+! true: all LSM parameters (inluding albedo, veg fraction and
+! roughness length) will be defined by three tables
+! LLANDUSE (=USGS, using USGS landuse classification)
+! LSOIL (=STAS, using FAO/STATSGO soil texture classification)
+! ----------------------------------------------------------------------
+! 3. FORCING DATA (F):
+! ----------------------------------------------------------------------
+! LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE)
+! SOLDN SOLAR DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET SOLAR)
+! SOLNET NET DOWNWARD SOLAR RADIATION ((W M-2; POSITIVE)
+! SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS)
+! PRCP PRECIP RATE (KG M-2 S-1) (NOTE, THIS IS A RATE)
+! SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND
+! TH2 AIR POTENTIAL TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND
+! Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1)
+! COSZ Solar zenith angle (not used for now)
+! PRCPRAIN Liquid-precipitation rate (KG M-2 S-1) (not used)
+! SOLARDIRECT Direct component of downward solar radiation (W M-2) (not used)
+! FFROZP FRACTION OF FROZEN PRECIPITATION
+! ----------------------------------------------------------------------
+! 4. OTHER FORCING (INPUT) DATA (I):
+! ----------------------------------------------------------------------
+! SFCSPD WIND SPEED (M S-1) AT HEIGHT ZLVL ABOVE GROUND
+! Q2SAT SAT SPECIFIC HUMIDITY AT HEIGHT ZLVL ABOVE GROUND (KG KG-1)
+! DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP
+! (KG KG-1 K-1)
+! ----------------------------------------------------------------------
+! 5. CANOPY/SOIL CHARACTERISTICS (S):
+! ----------------------------------------------------------------------
+! VEGTYP VEGETATION TYPE (INTEGER INDEX)
+! SOILTYP SOIL TYPE (INTEGER INDEX)
+! SLOPETYP CLASS OF SFC SLOPE (INTEGER INDEX)
+! SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION
+! (FRACTION= 0.0-1.0)
+! SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION
+! (FRACTION= 0.0-1.0) <= SHDFAC
+! PTU PHOTO THERMAL UNIT (PLANT PHENOLOGY FOR ANNUALS/CROPS)
+! (NOT YET USED, BUT PASSED TO REDPRM FOR FUTURE USE IN
+! VEG PARMS)
+! ALB BACKROUND SNOW-FREE SURFACE ALBEDO (FRACTION), FOR JULIAN
+! DAY OF YEAR (USUALLY FROM TEMPORAL INTERPOLATION OF
+! MONTHLY MEAN VALUES' CALLING PROG MAY OR MAY NOT
+! INCLUDE DIURNAL SUN ANGLE EFFECT)
+! SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW (E.G. FROM
+! ROBINSON AND KUKLA, 1985, J. CLIM. & APPL. METEOR.)
+! TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR
+! TEMPERATURE)
+! Z0BRD Background fixed roughness length (M)
+! Z0 Time varying roughness length (M) as function of snow depth
+!
+! EMBRD Background surface emissivity (between 0 and 1)
+! EMISSI Surface emissivity (between 0 and 1)
+! ----------------------------------------------------------------------
+! 6. HISTORY (STATE) VARIABLES (H):
+! ----------------------------------------------------------------------
+! CMC CANOPY MOISTURE CONTENT (M)
+! T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K)
+! STC(NSOIL) SOIL TEMP (K)
+! SMC(NSOIL) TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION)
+! SH2O(NSOIL) UNFROZEN SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION)
+! NOTE: FROZEN SOIL MOISTURE = SMC - SH2O
+! SNOWH ACTUAL SNOW DEPTH (M)
+! SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M)
+! NOTE: SNOW DENSITY = SNEQV/SNOWH
+! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT (UNITLESS FRACTION)
+! =SNOW-FREE ALBEDO (ALB) WHEN SNEQV=0, OR
+! =FCT(MSNOALB,ALB,VEGTYP,SHDFAC,SHDMIN) WHEN SNEQV>0
+! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE
+! (M S-1); NOTE: CH IS TECHNICALLY A CONDUCTANCE SINCE
+! IT HAS BEEN MULTIPLIED BY WIND SPEED.
+! CM SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM (M S-1); NOTE:
+! CM IS TECHNICALLY A CONDUCTANCE SINCE IT HAS BEEN
+! MULTIPLIED BY WIND SPEED.
+! ----------------------------------------------------------------------
+! 7. OUTPUT (O):
+! ----------------------------------------------------------------------
+! OUTPUT VARIABLES NECESSARY FOR A COUPLED NUMERICAL WEATHER PREDICTION
+! MODEL, E.G. NOAA/NWS/NCEP MESOSCALE ETA MODEL. FOR THIS APPLICATION,
+! THE REMAINING OUTPUT/DIAGNOSTIC/PARAMETER BLOCKS BELOW ARE NOT
+! NECESSARY. OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES.
+! ETA ACTUAL LATENT HEAT FLUX (W m-2: NEGATIVE, IF UP FROM
+! SURFACE)
+! ETA_KINEMATIC atctual latent heat flux in Kg m-2 s-1
+! SHEAT SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM
+! SURFACE)
+! FDOWN Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN
+! ----------------------------------------------------------------------
+! EC CANOPY WATER EVAPORATION (W m-2)
+! EDIR DIRECT SOIL EVAPORATION (W m-2)
+! ET(NSOIL) PLANT TRANSPIRATION FROM A PARTICULAR ROOT (SOIL) LAYER
+! (W m-2)
+! ETT TOTAL PLANT TRANSPIRATION (W m-2)
+! ESNOW SUBLIMATION FROM (OR DEPOSITION TO IF <0) SNOWPACK
+! (W m-2)
+! DRIP THROUGH-FALL OF PRECIP AND/OR DEW IN EXCESS OF CANOPY
+! WATER-HOLDING CAPACITY (M)
+! DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M)
+! ----------------------------------------------------------------------
+! BETA RATIO OF ACTUAL/POTENTIAL EVAP (DIMENSIONLESS)
+! ETP POTENTIAL EVAPORATION (W m-2)
+! SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE)
+! ----------------------------------------------------------------------
+! FLX1 PRECIP-SNOW SFC (W M-2)
+! FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2)
+! FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2)
+! ----------------------------------------------------------------------
+! SNOMLT SNOW MELT (M) (WATER EQUIVALENT)
+! SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1)
+! ----------------------------------------------------------------------
+! RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE
+! RUNOFF2 SUBSURFACE RUNOFF (M S-1), DRAINAGE OUT BOTTOM OF LAST
+! SOIL LAYER (BASEFLOW)
+! RUNOFF3 NUMERICAL TRUNCTATION IN EXCESS OF POROSITY (SMCMAX)
+! FOR A GIVEN SOIL LAYER AT THE END OF A TIME STEP (M S-1).
+! Note: the above RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3
+! ----------------------------------------------------------------------
+! RC CANOPY RESISTANCE (S M-1)
+! PC PLANT COEFFICIENT (UNITLESS FRACTION, 0-1) WHERE PC*ETP
+! = ACTUAL TRANSP
+! XLAI LEAF AREA INDEX (DIMENSIONLESS)
+! RSMIN MINIMUM CANOPY RESISTANCE (S M-1)
+! RCS INCOMING SOLAR RC FACTOR (DIMENSIONLESS)
+! RCT AIR TEMPERATURE RC FACTOR (DIMENSIONLESS)
+! RCQ ATMOS VAPOR PRESSURE DEFICIT RC FACTOR (DIMENSIONLESS)
+! RCSOIL SOIL MOISTURE RC FACTOR (DIMENSIONLESS)
+! ----------------------------------------------------------------------
+! 8. DIAGNOSTIC OUTPUT (D):
+! ----------------------------------------------------------------------
+! SOILW AVAILABLE SOIL MOISTURE IN ROOT ZONE (UNITLESS FRACTION
+! BETWEEN SMCWLT AND SMCMAX)
+! SOILM TOTAL SOIL COLUMN MOISTURE CONTENT (FROZEN+UNFROZEN) (M)
+! Q1 Effective mixing ratio at surface (kg kg-1), used for
+! diagnosing the mixing ratio at 2 meter for coupled model
+! SMAV Soil Moisture Availability for each layer, as a fraction
+! between SMCWLT and SMCMAX.
+! Documentation for SNOTIME1 and SNOABL2 ?????
+! What categories of arguments do these variables fall into ????
+! Documentation for RIBB ?????
+! What category of argument does RIBB fall into ?????
+! ----------------------------------------------------------------------
+! 9. PARAMETERS (P):
+! ----------------------------------------------------------------------
+! SMCWLT WILTING POINT (VOLUMETRIC)
+! SMCDRY DRY SOIL MOISTURE THRESHOLD WHERE DIRECT EVAP FRM TOP
+! LAYER ENDS (VOLUMETRIC)
+! SMCREF SOIL MOISTURE THRESHOLD WHERE TRANSPIRATION BEGINS TO
+! STRESS (VOLUMETRIC)
+! SMCMAX POROSITY, I.E. SATURATED VALUE OF SOIL MOISTURE
+! (VOLUMETRIC)
+! NROOT NUMBER OF ROOT LAYERS, A FUNCTION OF VEG TYPE, DETERMINED
+! IN SUBROUTINE REDPRM.
+! ----------------------------------------------------------------------
+
+
+ IMPLICIT NONE
+! ----------------------------------------------------------------------
+
+! DECLARATIONS - LOGICAL AND CHARACTERS
+! ----------------------------------------------------------------------
+ LOGICAL, INTENT(IN):: LOCAL
+ LOGICAL :: FRZGRA, SNOWNG
+ CHARACTER (LEN=256), INTENT(IN):: LLANDUSE, LSOIL
+
+! ----------------------------------------------------------------------
+! 1. CONFIGURATION INFORMATION (C):
+! ----------------------------------------------------------------------
+ INTEGER,INTENT(IN) :: ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP
+ INTEGER, INTENT(IN) :: ISURBAN
+ INTEGER,INTENT(OUT):: NROOT
+ INTEGER KZ, K, iout
+
+! ----------------------------------------------------------------------
+! 2. LOGICAL:
+! ----------------------------------------------------------------------
+ LOGICAL, INTENT(IN) :: RDLAI2D
+ LOGICAL, INTENT(IN) :: USEMONALB
+
+ REAL, INTENT(IN) :: SHDMIN,SHDMAX,DT,DQSDT2,LWDN,PRCP,PRCPRAIN, &
+ Q2,Q2SAT,SFCPRS,SFCSPD,SFCTMP, SNOALB, &
+ SOLDN,SOLNET,TBOT,TH2,ZLVL, &
+ FFROZP
+ REAL, INTENT(OUT) :: EMBRD
+ REAL, INTENT(OUT) :: ALBEDO
+ REAL, INTENT(INOUT):: COSZ, SOLARDIRECT,CH,CM, &
+ CMC,SNEQV,SNCOVR,SNOWH,T1,XLAI,SHDFAC,Z0BRD, &
+ EMISSI, ALB
+ REAL, INTENT(INOUT):: SNOTIME1
+ REAL, INTENT(INOUT):: RIBB
+ REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SLDPTH
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT):: ET
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT):: SMAV
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O, SMC, STC
+ REAL,DIMENSION(1:NSOIL):: RTDIS, ZSOIL
+
+ REAL,INTENT(OUT) :: ETA_KINEMATIC,BETA,DEW,DRIP,EC,EDIR,ESNOW,ETA, &
+ ETP,FLX1,FLX2,FLX3,SHEAT,PC,RUNOFF1,RUNOFF2, &
+ RUNOFF3,RC,RSMIN,RCQ,RCS,RCSOIL,RCT,SSOIL, &
+ SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT, SOILM, &
+ SOILW,FDOWN,Q1
+ REAL :: BEXP,CFACTR,CMCMAX,CSOIL,CZIL,DF1,DF1H,DF1A,DKSAT,DWSAT, &
+ DSOIL,DTOT,ETT,FRCSNO,FRCSOI,EPSCA,F1,FXEXP,FRZX,HS, &
+ KDT,LVH2O,PRCP1,PSISAT,QUARTZ,R,RCH,REFKDT,RR,RGL, &
+ RSMAX, &
+ RSNOW,SNDENS,SNCOND,SBETA,SN_NEW,SLOPE,SNUP,SALP,SOILWM, &
+ SOILWW,T1V,T24,T2V,TH2V,TOPT,TFREEZ,TSNOW,ZBOT,Z0,PRCPF, &
+ ETNS,PTU,LSUBS
+ REAL :: LVCOEF
+ REAL :: INTERP_FRACTION
+ REAL :: LAIMIN, LAIMAX
+ REAL :: ALBEDOMIN, ALBEDOMAX
+ REAL :: EMISSMIN, EMISSMAX
+ REAL :: Z0MIN, Z0MAX
+
+! ----------------------------------------------------------------------
+! DECLARATIONS - PARAMETERS
+! ----------------------------------------------------------------------
+ PARAMETER (TFREEZ = 273.15)
+ PARAMETER (LVH2O = 2.501E+6)
+ PARAMETER (LSUBS = 2.83E+6)
+ PARAMETER (R = 287.04)
+! ----------------------------------------------------------------------
+! INITIALIZATION
+! ----------------------------------------------------------------------
+ RUNOFF1 = 0.0
+ RUNOFF2 = 0.0
+ RUNOFF3 = 0.0
+ SNOMLT = 0.0
+
+! ----------------------------------------------------------------------
+! THE VARIABLE "ICE" IS A FLAG DENOTING SEA-ICE / LAND-ICE / ICE-FREE LAND
+! SEA-ICE CASE, ICE = 1
+! NON-GLACIAL LAND, ICE = 0
+! GLACIAL-ICE LAND, ICE = -1
+ IF (ICE /= 0) SHDFAC = 0.0
+! ----------------------------------------------------------------------
+! SEA-ICE LAYERS ARE EQUAL THICKNESS AND SUM TO 3 METERS
+! ----------------------------------------------------------------------
+ IF (ICE == 1) THEN
+ DO KZ = 1,NSOIL
+ ZSOIL (KZ) = -3.* FLOAT (KZ)/ FLOAT (NSOIL)
+ END DO
+
+! ----------------------------------------------------------------------
+! CALCULATE DEPTH (NEGATIVE) BELOW GROUND FROM TOP SKIN SFC TO BOTTOM OF
+! EACH SOIL LAYER. NOTE: SIGN OF ZSOIL IS NEGATIVE (DENOTING BELOW
+! GROUND)
+! ----------------------------------------------------------------------
+ ELSE
+ ZSOIL (1) = - SLDPTH (1)
+ DO KZ = 2,NSOIL
+ ZSOIL (KZ) = - SLDPTH (KZ) + ZSOIL (KZ -1)
+ END DO
+ END IF
+! ----------------------------------------------------------------------
+! NEXT IS CRUCIAL CALL TO SET THE LAND-SURFACE PARAMETERS, INCLUDING
+! SOIL-TYPE AND VEG-TYPE DEPENDENT PARAMETERS.
+! ----------------------------------------------------------------------
+ CALL REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX,TOPT, &
+ REFKDT,KDT,SBETA, SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX, &
+ PSISAT,SLOPE,SNUP,SALP,BEXP,DKSAT,DWSAT, &
+ SMCMAX,SMCWLT,SMCREF,SMCDRY,F1,QUARTZ,FXEXP, &
+ RTDIS,SLDPTH,ZSOIL,NROOT,NSOIL,CZIL, &
+ LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN, &
+ ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE, &
+ LSOIL,LOCAL,LVCOEF)
+
+!urban
+ IF(VEGTYP==ISURBAN)THEN
+ SHDFAC=0.05
+ RSMIN=400.0
+ SMCMAX = 0.45
+ SMCREF = 0.42
+ SMCWLT = 0.40
+ SMCDRY = 0.40
+ ENDIF
+
+ IF ( SHDFAC >= SHDMAX ) THEN
+ EMBRD = EMISSMAX
+ IF (.NOT. RDLAI2D) THEN
+ XLAI = LAIMAX
+ ENDIF
+ IF (.NOT. USEMONALB) THEN
+ ALB = ALBEDOMIN
+ ENDIF
+ Z0BRD = Z0MAX
+ ELSE IF ( SHDFAC <= SHDMIN ) THEN
+ EMBRD = EMISSMIN
+ IF(.NOT. RDLAI2D) THEN
+ XLAI = LAIMIN
+ ENDIF
+ IF(.NOT. USEMONALB) then
+ ALB = ALBEDOMAX
+ ENDIF
+ Z0BRD = Z0MIN
+ ELSE
+
+ IF ( SHDMAX > SHDMIN ) THEN
+
+ INTERP_FRACTION = ( SHDFAC - SHDMIN ) / ( SHDMAX - SHDMIN )
+ ! Bound INTERP_FRACTION between 0 and 1
+ INTERP_FRACTION = MIN ( INTERP_FRACTION, 1.0 )
+ INTERP_FRACTION = MAX ( INTERP_FRACTION, 0.0 )
+ ! Scale Emissivity and LAI between EMISSMIN and EMISSMAX by INTERP_FRACTION
+ EMBRD = ( ( 1.0 - INTERP_FRACTION ) * EMISSMIN ) + ( INTERP_FRACTION * EMISSMAX )
+ IF (.NOT. RDLAI2D) THEN
+ XLAI = ( ( 1.0 - INTERP_FRACTION ) * LAIMIN ) + ( INTERP_FRACTION * LAIMAX )
+ ENDIF
+ if (.not. USEMONALB) then
+ ALB = ( ( 1.0 - INTERP_FRACTION ) * ALBEDOMAX ) + ( INTERP_FRACTION * ALBEDOMIN )
+ endif
+ Z0BRD = ( ( 1.0 - INTERP_FRACTION ) * Z0MIN ) + ( INTERP_FRACTION * Z0MAX )
+
+ ELSE
+
+ EMBRD = 0.5 * EMISSMIN + 0.5 * EMISSMAX
+ IF (.NOT. RDLAI2D) THEN
+ XLAI = 0.5 * LAIMIN + 0.5 * LAIMAX
+ ENDIF
+ if (.not. USEMONALB) then
+ ALB = 0.5 * ALBEDOMIN + 0.5 * ALBEDOMAX
+ endif
+ Z0BRD = 0.5 * Z0MIN + 0.5 * Z0MAX
+
+ ENDIF
+
+ ENDIF
+! ----------------------------------------------------------------------
+! INITIALIZE PRECIPITATION LOGICALS.
+! ----------------------------------------------------------------------
+ SNOWNG = .FALSE.
+ FRZGRA = .FALSE.
+
+! ----------------------------------------------------------------------
+! OVER SEA-ICE OR GLACIAL-ICE, IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER
+! BOUND (0.01 M FOR SEA-ICE, 0.10 M FOR GLACIAL-ICE), THEN SET AT LOWER
+! BOUND
+! ----------------------------------------------------------------------
+! IF SEA-ICE CASE, ASSIGN DEFAULT WATER-EQUIV SNOW ON TOP
+! ----------------------------------------------------------------------
+ IF (ICE == 1) THEN
+ ! Sea-ice case
+ IF ( SNEQV < 0.01 ) THEN
+ SNEQV = 0.01
+ SNOWH = 0.05
+ ENDIF
+ ELSE IF ( ICE == -1 ) THEN
+ ! Land-ice case
+ IF ( SNEQV < 0.10 ) THEN
+ SNEQV = 0.10
+ SNOWH = 0.50
+ ENDIF
+ END IF
+! ----------------------------------------------------------------------
+! FOR SEA-ICE AND GLACIAL-ICE CASES, SET SMC AND SH20 VALUES = 1.0
+! ----------------------------------------------------------------------
+ IF ( ICE /= 0 ) THEN
+ DO KZ = 1,NSOIL
+ SMC(KZ) = 1.0
+ SH2O(KZ) = 1.0
+ END DO
+ ENDIF
+! ----------------------------------------------------------------------
+! IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND
+! SNOW THERMAL CONDUCTIVITY "SNCOND" (NOTE THAT CSNOW IS A FUNCTION
+! SUBROUTINE)
+! ----------------------------------------------------------------------
+ IF ( SNEQV <= 1.E-7 ) THEN ! safer IF kmh (2008/03/25)
+ SNEQV = 0.0
+ SNDENS = 0.0
+ SNOWH = 0.0
+ SNCOND = 1.0
+ ELSE
+ SNDENS = SNEQV / SNOWH
+ IF(SNDENS > 1.0) THEN
+! CALL wrf_error_fatal ( 'Physical snow depth is less than snow water equiv.' )
+ ENDIF
+ CALL CSNOW (SNCOND,SNDENS)
+ END IF
+! ----------------------------------------------------------------------
+! DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS.
+! IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING!
+! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND
+! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING.
+! ----------------------------------------------------------------------
+ IF (PRCP > 0.0) THEN
+! snow defined when fraction of frozen precip (FFROZP) > 0.5,
+! passed in from model microphysics.
+ IF (FFROZP .GT. 0.5) THEN
+ SNOWNG = .TRUE.
+ ELSE
+ IF (T1 <= TFREEZ) FRZGRA = .TRUE.
+ END IF
+ END IF
+! ----------------------------------------------------------------------
+! IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP
+! RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD
+! IT TO THE EXISTING SNOWPACK.
+! NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES
+! INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO.
+! ----------------------------------------------------------------------
+ IF ( (SNOWNG) .OR. (FRZGRA) ) THEN
+ SN_NEW = PRCP * DT * 0.001
+ SNEQV = SNEQV + SN_NEW
+ PRCPF = 0.0
+
+! ----------------------------------------------------------------------
+! UPDATE SNOW DENSITY BASED ON NEW SNOWFALL, USING OLD AND NEW SNOW.
+! UPDATE SNOW THERMAL CONDUCTIVITY
+! ----------------------------------------------------------------------
+ CALL SNOW_NEW (SFCTMP,SN_NEW,SNOWH,SNDENS)
+!
+! kmh 09/04/2006 set Snow Density at 0.2 g/cm**3
+! for "cold permanent ice" or new "dry" snow
+!
+ IF ( (ICE /= 0) .and. SNCOVR .GT. 0.99 ) THEN
+! if soil temperature less than 268.15 K, treat as typical Antarctic/Greenland snow firn
+ IF ( STC(1) .LT. (TFREEZ - 5.) ) SNDENS = 0.2
+ IF ( SNOWNG .AND. (T1.LT.273.) .AND. (SFCTMP.LT.273.) ) SNDENS=0.2
+ ENDIF
+!
+ CALL CSNOW (SNCOND,SNDENS)
+
+! ----------------------------------------------------------------------
+! PRECIP IS LIQUID (RAIN), HENCE SAVE IN THE PRECIP VARIABLE THAT
+! LATER CAN WHOLELY OR PARTIALLY INFILTRATE THE SOIL (ALONG WITH
+! ANY CANOPY "DRIP" ADDED TO THIS LATER)
+! ----------------------------------------------------------------------
+ ELSE
+ PRCPF = PRCP
+ END IF
+! ----------------------------------------------------------------------
+! DETERMINE SNOWCOVER AND ALBEDO OVER LAND.
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! IF SNOW DEPTH=0, SET SNOW FRACTION=0, ALBEDO=SNOW FREE ALBEDO.
+! ----------------------------------------------------------------------
+ IF (ICE == 0 .OR. ICE == -1) THEN
+ IF (SNEQV == 0.0) THEN
+ SNCOVR = 0.0
+ ALBEDO = ALB
+ EMISSI = EMBRD
+ ELSE
+! ----------------------------------------------------------------------
+! DETERMINE SNOW FRACTIONAL COVERAGE.
+! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE.
+! ----------------------------------------------------------------------
+ CALL SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR)
+! Don't limit snow cover fraction over permanent ice kmh 2008/03/25
+ if ( ICE == 0 ) then
+ SNCOVR = MIN(SNCOVR,0.98)
+ endif
+ CALL ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,T1,ALBEDO,EMISSI, &
+ DT,SNOWNG,SNOTIME1,LVCOEF)
+ END IF
+! ----------------------------------------------------------------------
+! SNOW COVER, ALBEDO OVER SEA-ICE, GLACIAL ICE
+! ----------------------------------------------------------------------
+ ELSE
+ SNCOVR = 1.0
+!
+! Albedo of sea ice
+!
+! This value should vary seasonally. 0.65 may be good for Arctic Ocean summer bare ice
+! value could be as low as 0.4 for Arctic bare ice and melt pond combo (Perovich data)
+! 0.82 may be good for Arctic spring/fall sea ice (Perovich data)
+! 0.81 may be good for Antarctic sea ice (Wendler et al. December cruise data)
+!
+ ALBEDO = 0.80
+!
+ EMISSI = 0.98
+ END IF
+! ----------------------------------------------------------------------
+! THERMAL CONDUCTIVITY FOR SEA-ICE CASE, GLACIAL-ICE CASE
+! ----------------------------------------------------------------------
+ IF ( (ICE == 1) .or. (ICE == -1) ) THEN
+ DF1 = 2.2
+!
+! kmh 09/03/2006
+! kmh 03/25/2008 change SNCOVR threshold to 0.97
+!
+ IF ( SNCOVR .GT. 0.97 ) THEN
+ DF1 = SNCOND
+ ENDIF
+!
+ ELSE
+! ----------------------------------------------------------------------
+! NEXT CALCULATE THE SUBSURFACE HEAT FLUX, WHICH FIRST REQUIRES
+! CALCULATION OF THE THERMAL DIFFUSIVITY. TREATMENT OF THE
+! LATTER FOLLOWS THAT ON PAGES 148-149 FROM "HEAT TRANSFER IN
+! COLD CLIMATES", BY V. J. LUNARDINI (PUBLISHED IN 1981
+! BY VAN NOSTRAND REINHOLD CO.) I.E. TREATMENT OF TWO CONTIGUOUS
+! "PLANE PARALLEL" MEDIUMS (NAMELY HERE THE FIRST SOIL LAYER
+! AND THE SNOWPACK LAYER, IF ANY). THIS DIFFUSIVITY TREATMENT
+! BEHAVES WELL FOR BOTH ZERO AND NONZERO SNOWPACK, INCLUDING THE
+! LIMIT OF VERY THIN SNOWPACK. THIS TREATMENT ALSO ELIMINATES
+! THE NEED TO IMPOSE AN ARBITRARY UPPER BOUND ON SUBSURFACE
+! HEAT FLUX WHEN THE SNOWPACK BECOMES EXTREMELY THIN.
+! ----------------------------------------------------------------------
+! FIRST CALCULATE THERMAL DIFFUSIVITY OF TOP SOIL LAYER, USING
+! BOTH THE FROZEN AND LIQUID SOIL MOISTURE, FOLLOWING THE
+! SOIL THERMAL DIFFUSIVITY FUNCTION OF PETERS-LIDARD ET AL.
+! (1998,JAS, VOL 55, 1209-1224), WHICH REQUIRES THE SPECIFYING
+! THE QUARTZ CONTENT OF THE GIVEN SOIL CLASS (SEE ROUTINE REDPRM)
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! NEXT ADD SUBSURFACE HEAT FLUX REDUCTION EFFECT FROM THE
+! OVERLYING GREEN CANOPY, ADAPTED FROM SECTION 2.1.2 OF
+! PETERS-LIDARD ET AL. (1997, JGR, VOL 102(D4))
+! ----------------------------------------------------------------------
+ CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1))
+
+!urban
+ IF ( VEGTYP == ISURBAN ) DF1=3.24
+
+ DF1 = DF1 * EXP (SBETA * SHDFAC)
+!
+! kmh 09/03/2006
+! kmh 03/25/2008 change SNCOVR threshold to 0.97
+!
+ IF ( SNCOVR .GT. 0.97 ) THEN
+ DF1 = SNCOND
+ ENDIF
+!
+! ----------------------------------------------------------------------
+! FINALLY "PLANE PARALLEL" SNOWPACK EFFECT FOLLOWING
+! V.J. LINARDINI REFERENCE CITED ABOVE. NOTE THAT DTOT IS
+! COMBINED DEPTH OF SNOWDEPTH AND THICKNESS OF FIRST SOIL LAYER
+! ----------------------------------------------------------------------
+ END IF
+
+ DSOIL = - (0.5 * ZSOIL (1))
+ IF (SNEQV == 0.) THEN
+ SSOIL = DF1 * (T1- STC (1) ) / DSOIL
+ ELSE
+ DTOT = SNOWH + DSOIL
+ FRCSNO = SNOWH / DTOT
+
+! 1. HARMONIC MEAN (SERIES FLOW)
+! DF1 = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1)
+ FRCSOI = DSOIL / DTOT
+! 2. ARITHMETIC MEAN (PARALLEL FLOW)
+! DF1 = FRCSNO*SNCOND + FRCSOI*DF1
+ DF1H = (SNCOND * DF1)/ (FRCSOI * SNCOND+ FRCSNO * DF1)
+
+! 3. GEOMETRIC MEAN (INTERMEDIATE BETWEEN HARMONIC AND ARITHMETIC MEAN)
+! DF1 = (SNCOND**FRCSNO)*(DF1**FRCSOI)
+! weigh DF by snow fraction
+! DF1 = DF1H*SNCOVR + DF1A*(1.0-SNCOVR)
+! DF1 = DF1H*SNCOVR + DF1*(1.0-SNCOVR)
+ DF1A = FRCSNO * SNCOND+ FRCSOI * DF1
+
+! ----------------------------------------------------------------------
+! CALCULATE SUBSURFACE HEAT FLUX, SSOIL, FROM FINAL THERMAL DIFFUSIVITY
+! OF SURFACE MEDIUMS, DF1 ABOVE, AND SKIN TEMPERATURE AND TOP
+! MID-LAYER SOIL TEMPERATURE
+! ----------------------------------------------------------------------
+ DF1 = DF1A * SNCOVR + DF1* (1.0- SNCOVR)
+ IF ( ICE /= 0 ) then
+ ! kmh 12/15/2005 correct for too deep snow layer
+ ! kmh 09/03/2006 adjust DTOT
+ IF ( DTOT .GT. 2.*DSOIL ) then
+ DTOT = 2.*DSOIL
+ ENDIF
+ ENDIF
+ SSOIL = DF1 * (T1- STC (1) ) / DTOT
+ END IF
+! ----------------------------------------------------------------------
+! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM
+! THE PREVIOUS TIMESTEP.
+! ----------------------------------------------------------------------
+ IF (SNCOVR > 0. ) THEN
+ CALL SNOWZ0 (SNCOVR,Z0,Z0BRD,SNOWH)
+ ELSE
+ Z0=Z0BRD
+ END IF
+! ----------------------------------------------------------------------
+! NEXT CALL ROUTINE SFCDIF TO CALCULATE THE SFC EXCHANGE COEF (CH) FOR
+! HEAT AND MOISTURE.
+
+! NOTE !!!
+! DO NOT CALL SFCDIF UNTIL AFTER ABOVE CALL TO REDPRM, IN CASE
+! ALTERNATIVE VALUES OF ROUGHNESS LENGTH (Z0) AND ZILINTINKEVICH COEF
+! (CZIL) ARE SET THERE VIA NAMELIST I/O.
+
+! NOTE !!!
+! ROUTINE SFCDIF RETURNS A CH THAT REPRESENTS THE WIND SPD TIMES THE
+! "ORIGINAL" NONDIMENSIONAL "Ch" TYPICAL IN LITERATURE. HENCE THE CH
+! RETURNED FROM SFCDIF HAS UNITS OF M/S. THE IMPORTANT COMPANION
+! COEFFICIENT OF CH, CARRIED HERE AS "RCH", IS THE CH FROM SFCDIF TIMES
+! AIR DENSITY AND PARAMETER "CP". "RCH" IS COMPUTED IN "CALL PENMAN".
+! RCH RATHER THAN CH IS THE COEFF USUALLY INVOKED LATER IN EQNS.
+
+! NOTE !!!
+! ----------------------------------------------------------------------
+! SFCDIF ALSO RETURNS THE SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM, CM,
+! ALSO KNOWN AS THE SURFACE DRAGE COEFFICIENT. Needed as a state variable
+! for iterative/implicit solution of CH in SFCDIF
+! ----------------------------------------------------------------------
+! IF(.NOT.LCH) THEN
+! T1V = T1 * (1.0+ 0.61 * Q2)
+! TH2V = TH2 * (1.0+ 0.61 * Q2)
+! CALL SFCDIF_off (ZLVL,Z0,T1V,TH2V,SFCSPD,CZIL,CM,CH)
+! ENDIF
+
+! ----------------------------------------------------------------------
+! CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND
+! OTHER PARTIAL PRODUCTS AND SUMS SAVE IN COMMON/RITE FOR LATER
+! CALCULATIONS.
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! CALCULATE TOTAL DOWNWARD RADIATION (SOLAR PLUS LONGWAVE) NEEDED IN
+! PENMAN EP SUBROUTINE THAT FOLLOWS
+! ----------------------------------------------------------------------
+! FDOWN = SOLDN * (1.0- ALBEDO) + LWDN
+ FDOWN = SOLNET + LWDN
+! ----------------------------------------------------------------------
+! CALC VIRTUAL TEMPS AND VIRTUAL POTENTIAL TEMPS NEEDED BY SUBROUTINES
+! PENMAN.
+ T2V = SFCTMP * (1.0+ 0.61 * Q2 )
+
+ iout=0
+ if(iout.eq.1) then
+ print*,'before penman'
+ print*,' SFCTMP',SFCTMP,'SFCPRS',SFCPRS,'CH',CH,'T2V',T2V, &
+ 'TH2',TH2,'PRCP',PRCP,'FDOWN',FDOWN,'T24',T24,'SSOIL',SSOIL, &
+ 'Q2',Q2,'Q2SAT',Q2SAT,'ETP',ETP,'RCH',RCH, &
+ 'EPSCA',EPSCA,'RR',RR ,'SNOWNG',SNOWNG,'FRZGRA',FRZGRA, &
+ 'DQSDT2',DQSDT2,'FLX2',FLX2,'SNOWH',SNOWH,'SNEQV',SNEQV, &
+ ' DSOIL',DSOIL,' FRCSNO',FRCSNO,' SNCOVR',SNCOVR,' DTOT',DTOT, &
+ ' ZSOIL (1)',ZSOIL(1),' DF1',DF1,'T1',T1,' STC1',STC(1), &
+ 'ALBEDO',ALBEDO,'SMC',SMC,'STC',STC,'SH2O',SH2O
+ endif
+
+ CALL PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, &
+ Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, &
+!
+! kmh 01/09/2007 add T1,ICE,SNCOVR to call
+!
+ DQSDT2,FLX2,EMISSI,SNEQV,T1,ICE,SNCOVR)
+!
+! ----------------------------------------------------------------------
+! CALL CANRES TO CALCULATE THE CANOPY RESISTANCE AND CONVERT IT INTO PC
+! IF NONZERO GREENNESS FRACTION
+! ----------------------------------------------------------------------
+
+! ----------------------------------------------------------------------
+! FROZEN GROUND EXTENSION: TOTAL SOIL WATER "SMC" WAS REPLACED
+! BY UNFROZEN SOIL WATER "SH2O" IN CALL TO CANRES BELOW
+! ----------------------------------------------------------------------
+ IF (SHDFAC > 0.) THEN
+ CALL CANRES (SOLDN,CH,SFCTMP,Q2,SFCPRS,SH2O,ZSOIL,NSOIL, &
+ SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, &
+ TOPT,RSMAX,RGL,HS,XLAI, &
+ RCS,RCT,RCQ,RCSOIL,EMISSI)
+ ELSE
+ RC = 0.0
+ END IF
+! ----------------------------------------------------------------------
+! NOW DECIDE MAJOR PATHWAY BRANCH TO TAKE DEPENDING ON WHETHER SNOWPACK
+! EXISTS OR NOT:
+! ----------------------------------------------------------------------
+ ESNOW = 0.0
+ IF (SNEQV == 0.0) THEN
+ CALL NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, &
+ SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, &
+ SHDFAC, &
+ SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,EMISSI, &
+ SSOIL, &
+ STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, &
+ SH2O,SLOPE,KDT,FRZX,PSISAT,ZSOIL, &
+ DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, &
+ RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, &
+ QUARTZ,FXEXP,CSOIL, &
+ BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN)
+ ETA_KINEMATIC = ETA
+ ELSE
+ CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, &
+ SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, &
+ SBETA,DF1, &
+ Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA, &
+ SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,SNEQV,SNDENS,&
+ SNOWH,SH2O,SLOPE,KDT,FRZX,PSISAT, &
+ ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, &
+ RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, &
+ ICE,RTDIS,QUARTZ,FXEXP,CSOIL, &
+ BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW,ETNS,EMISSI, &
+ RIBB,SOLDN, &
+ ISURBAN, &
+ VEGTYP)
+ ETA_KINEMATIC = ESNOW + ETNS
+ END IF
+
+! Calculate effective mixing ratio at grnd level (skin)
+!
+! Q1=Q2+ETA*CP/RCH
+ Q1=Q2+ETA_KINEMATIC*CP/RCH
+!
+! ----------------------------------------------------------------------
+! DETERMINE SENSIBLE HEAT (H) IN ENERGY UNITS (W M-2)
+! ----------------------------------------------------------------------
+ SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 )
+
+! ----------------------------------------------------------------------
+! CONVERT EVAP TERMS FROM KINEMATIC (KG M-2 S-1) TO ENERGY UNITS (W M-2)
+! ----------------------------------------------------------------------
+ EDIR = EDIR * LVH2O
+ EC = EC * LVH2O
+ DO K=1,4
+ ET(K) = ET(K) * LVH2O
+ ENDDO
+ ETT = ETT * LVH2O
+ ESNOW = ESNOW * LSUBS
+ ETP = ETP*((1.-SNCOVR)*LVH2O + SNCOVR*LSUBS)
+ IF (ETP .GT. 0.) THEN
+ ETA = EDIR + EC + ETT + ESNOW
+ ELSE
+ ETA = ETP
+ ENDIF
+! ----------------------------------------------------------------------
+! DETERMINE BETA (RATIO OF ACTUAL TO POTENTIAL EVAP)
+! ----------------------------------------------------------------------
+ IF (ETP == 0.0) THEN
+ BETA = 0.0
+ ELSE
+ BETA = ETA/ETP
+ ENDIF
+
+! ----------------------------------------------------------------------
+! CONVERT THE SIGN OF SOIL HEAT FLUX SO THAT:
+! SSOIL>0: WARM THE SURFACE (NIGHT TIME)
+! SSOIL<0: COOL THE SURFACE (DAY TIME)
+! ----------------------------------------------------------------------
+ SSOIL = -1.0* SSOIL
+
+! ----------------------------------------------------------------------
+! FOR THE CASE OF LAND (BUT NOT GLACIAL-ICE):
+! CONVERT RUNOFF3 (INTERNAL LAYER RUNOFF FROM SUPERSAT) FROM M TO M S-1
+! AND ADD TO SUBSURFACE RUNOFF/DRAINAGE/BASEFLOW. RUNOFF2 IS ALREADY
+! A RATE AT THIS POINT
+! ----------------------------------------------------------------------
+ IF (ICE == 0) THEN
+ RUNOFF3 = RUNOFF3/ DT
+ RUNOFF2 = RUNOFF2+ RUNOFF3
+ SOILM = -1.0* SMC (1)* ZSOIL (1)
+ DO K = 2,NSOIL
+ SOILM = SOILM + SMC (K)* (ZSOIL (K -1) - ZSOIL (K))
+ END DO
+ SOILWM = -1.0* (SMCMAX - SMCWLT)* ZSOIL (1)
+ SOILWW = -1.0* (SMC (1) - SMCWLT)* ZSOIL (1)
+!
+ DO K = 1,NSOIL
+ SMAV(K)=(SMC(K) - SMCWLT)/(SMCMAX - SMCWLT)
+ END DO
+
+ IF (NROOT >= 2) THEN
+ DO K = 2,NROOT
+ SOILWM = SOILWM + (SMCMAX - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K))
+ SOILWW = SOILWW + (SMC(K) - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K))
+ END DO
+ END IF
+ IF (SOILWM .LT. 1.E-6) THEN
+ SOILWM = 0.0
+ SOILW = 0.0
+ SOILM = 0.0
+ ELSE
+ SOILW = SOILWW / SOILWM
+ END IF
+ ELSE
+! ----------------------------------------------------------------------
+! FOR THE CASE OF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), ADD ANY
+! SNOWMELT DIRECTLY TO SURFACE RUNOFF (RUNOFF1) SINCE THERE IS NO
+! SOIL MEDIUM, AND THUS NO CALL TO SUBROUTINE SMFLX (FOR SOIL MOISTURE
+! TENDENCY).
+! ----------------------------------------------------------------------
+ RUNOFF1 = SNOMLT/DT
+ SOILWM = 0.0
+ SOILW = 0.0
+ SOILM = 0.0
+ DO K = 1,NSOIL
+ SMAV(K)= 1.0
+ END DO
+ END IF
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SFLX
+! ----------------------------------------------------------------------
+
+ SUBROUTINE ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO,EMISSI, &
+ DT,SNOWNG,SNOTIME1,LVCOEF)
+
+! ----------------------------------------------------------------------
+! CALCULATE ALBEDO INCLUDING SNOW EFFECT (0 -> 1)
+! ALB SNOWFREE ALBEDO
+! SNOALB MAXIMUM (DEEP) SNOW ALBEDO
+! SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION
+! SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION
+! SNCOVR FRACTIONAL SNOW COVER
+! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT
+! TSNOW SNOW SURFACE TEMPERATURE (K)
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+! ----------------------------------------------------------------------
+! SNOALB IS ARGUMENT REPRESENTING MAXIMUM ALBEDO OVER DEEP SNOW,
+! AS PASSED INTO SFLX, AND ADAPTED FROM THE SATELLITE-BASED MAXIMUM
+! SNOW ALBEDO FIELDS PROVIDED BY D. ROBINSON AND G. KUKLA
+! (1985, JCAM, VOL 24, 402-411)
+! ----------------------------------------------------------------------
+ REAL, INTENT(IN) :: ALB, SNOALB, EMBRD, SHDFAC, SHDMIN, SNCOVR, TSNOW
+ REAL, INTENT(IN) :: DT
+ LOGICAL, INTENT(IN) :: SNOWNG
+ REAL, INTENT(INOUT):: SNOTIME1
+ REAL, INTENT(OUT) :: ALBEDO, EMISSI
+ REAL :: SNOALB2
+ REAL :: TM,SNOALB1
+ REAL, INTENT(IN) :: LVCOEF
+ REAL, PARAMETER :: SNACCA=0.94,SNACCB=0.58,SNTHWA=0.82,SNTHWB=0.46
+! turn of vegetation effect
+! ALBEDO = ALB + (1.0- (SHDFAC - SHDMIN))* SNCOVR * (SNOALB - ALB)
+! ALBEDO = (1.0-SNCOVR)*ALB + SNCOVR*SNOALB !this is equivalent to below
+ ALBEDO = ALB + SNCOVR*(SNOALB-ALB)
+ EMISSI = EMBRD + SNCOVR*(EMISSI_S - EMBRD)
+
+! BASE FORMULATION (DICKINSON ET AL., 1986, COGLEY ET AL., 1990)
+! IF (TSNOW.LE.263.16) THEN
+! ALBEDO=SNOALB
+! ELSE
+! IF (TSNOW.LT.273.16) THEN
+! TM=0.1*(TSNOW-263.16)
+! SNOALB1=0.5*((0.9-0.2*(TM**3))+(0.8-0.16*(TM**3)))
+! ELSE
+! SNOALB1=0.67
+! IF(SNCOVR.GT.0.95) SNOALB1= 0.6
+! SNOALB1 = ALB + SNCOVR*(SNOALB-ALB)
+! ENDIF
+! ENDIF
+! ALBEDO = ALB + SNCOVR*(SNOALB1-ALB)
+
+! ISBA FORMULATION (VERSEGHY, 1991; BAKER ET AL., 1990)
+! SNOALB1 = SNOALB+COEF*(0.85-SNOALB)
+! SNOALB2=SNOALB1
+!!m LSTSNW=LSTSNW+1
+! SNOTIME1 = SNOTIME1 + DT
+! IF (SNOWNG) THEN
+! SNOALB2=SNOALB
+!!m LSTSNW=0
+! SNOTIME1 = 0.0
+! ELSE
+! IF (TSNOW.LT.273.16) THEN
+!! SNOALB2=SNOALB-0.008*LSTSNW*DT/86400
+!!m SNOALB2=SNOALB-0.008*SNOTIME1/86400
+! SNOALB2=(SNOALB2-0.65)*EXP(-0.05*DT/3600)+0.65
+!! SNOALB2=(ALBEDO-0.65)*EXP(-0.01*DT/3600)+0.65
+! ELSE
+! SNOALB2=(SNOALB2-0.5)*EXP(-0.0005*DT/3600)+0.5
+!! SNOALB2=(SNOALB-0.5)*EXP(-0.24*LSTSNW*DT/86400)+0.5
+!!m SNOALB2=(SNOALB-0.5)*EXP(-0.24*SNOTIME1/86400)+0.5
+! ENDIF
+! ENDIF
+!
+!! print*,'SNOALB2',SNOALB2,'ALBEDO',ALBEDO,'DT',DT
+! ALBEDO = ALB + SNCOVR*(SNOALB2-ALB)
+! IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2
+!!m LSTSNW1=LSTSNW
+!! SNOTIME = SNOTIME1
+
+! formulation by Livneh
+! ----------------------------------------------------------------------
+! SNOALB IS CONSIDERED AS THE MAXIMUM SNOW ALBEDO FOR NEW SNOW, AT
+! A VALUE OF 85%. SNOW ALBEDO CURVE DEFAULTS ARE FROM BRAS P.263. SHOULD
+! NOT BE CHANGED EXCEPT FOR SERIOUS PROBLEMS WITH SNOW MELT.
+! TO IMPLEMENT ACCUMULATIN PARAMETERS, SNACCA AND SNACCB, ASSERT THAT IT
+! IS INDEED ACCUMULATION SEASON. I.E. THAT SNOW SURFACE TEMP IS BELOW
+! ZERO AND THE DATE FALLS BETWEEN OCTOBER AND FEBRUARY
+! ----------------------------------------------------------------------
+ SNOALB1 = SNOALB+LVCOEF*(0.85-SNOALB)
+ SNOALB2=SNOALB1
+! ---------------- Initial LSTSNW --------------------------------------
+ IF (SNOWNG) THEN
+ SNOTIME1 = 0.
+ ELSE
+ SNOTIME1=SNOTIME1+DT
+! IF (TSNOW.LT.273.16) THEN
+ SNOALB2=SNOALB1*(SNACCA**((SNOTIME1/86400.0)**SNACCB))
+! ELSE
+! SNOALB2 =SNOALB1*(SNTHWA**((SNOTIME1/86400.0)**SNTHWB))
+! ENDIF
+ ENDIF
+!
+ SNOALB2 = MAX ( SNOALB2, ALB )
+ ALBEDO = ALB + SNCOVR*(SNOALB2-ALB)
+ IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2
+
+! IF (TSNOW.LT.273.16) THEN
+! ALBEDO=SNOALB-0.008*DT/86400
+! ELSE
+! ALBEDO=(SNOALB-0.5)*EXP(-0.24*DT/86400)+0.5
+! ENDIF
+
+! IF (ALBEDO > SNOALB) ALBEDO = SNOALB
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE ALCALC
+! ----------------------------------------------------------------------
+
+ SUBROUTINE CANRES (SOLAR,CH,SFCTMP,Q2,SFCPRS,SMC,ZSOIL,NSOIL, &
+ SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, &
+ TOPT,RSMAX,RGL,HS,XLAI, &
+ RCS,RCT,RCQ,RCSOIL,EMISSI)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE CANRES
+! ----------------------------------------------------------------------
+! CALCULATE CANOPY RESISTANCE WHICH DEPENDS ON INCOMING SOLAR RADIATION,
+! AIR TEMPERATURE, ATMOSPHERIC WATER VAPOR PRESSURE DEFICIT AT THE
+! LOWEST MODEL LEVEL, AND SOIL MOISTURE (PREFERABLY UNFROZEN SOIL
+! MOISTURE RATHER THAN TOTAL)
+! ----------------------------------------------------------------------
+! SOURCE: JARVIS (1976), NOILHAN AND PLANTON (1989, MWR), JACQUEMIN AND
+! NOILHAN (1990, BLM)
+! SEE ALSO: CHEN ET AL (1996, JGR, VOL 101(D3), 7251-7268), EQNS 12-14
+! AND TABLE 2 OF SEC. 3.1.2
+! ----------------------------------------------------------------------
+! INPUT:
+! SOLAR INCOMING SOLAR RADIATION
+! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE
+! SFCTMP AIR TEMPERATURE AT 1ST LEVEL ABOVE GROUND
+! Q2 AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND
+! Q2SAT SATURATION AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND
+! DQSDT2 SLOPE OF SATURATION HUMIDITY FUNCTION WRT TEMP
+! SFCPRS SURFACE PRESSURE
+! SMC VOLUMETRIC SOIL MOISTURE
+! ZSOIL SOIL DEPTH (NEGATIVE SIGN, AS IT IS BELOW GROUND)
+! NSOIL NO. OF SOIL LAYERS
+! NROOT NO. OF SOIL LAYERS IN ROOT ZONE (1.LE.NROOT.LE.NSOIL)
+! XLAI LEAF AREA INDEX
+! SMCWLT WILTING POINT
+! SMCREF REFERENCE SOIL MOISTURE (WHERE SOIL WATER DEFICIT STRESS
+! SETS IN)
+! RSMIN, RSMAX, TOPT, RGL, HS ARE CANOPY STRESS PARAMETERS SET IN
+! SURBOUTINE REDPRM
+! OUTPUT:
+! PC PLANT COEFFICIENT
+! RC CANOPY RESISTANCE
+! ----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: NROOT,NSOIL
+ INTEGER K
+ REAL, INTENT(IN) :: CH,DQSDT2,HS,Q2,Q2SAT,RSMIN,RGL,RSMAX, &
+ SFCPRS,SFCTMP,SMCREF,SMCWLT, SOLAR,TOPT,XLAI, &
+ EMISSI
+ REAL,DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL
+ REAL, INTENT(OUT):: PC,RC,RCQ,RCS,RCSOIL,RCT
+ REAL :: DELTA,FF,GX,P,RR
+ REAL, DIMENSION(1:NSOIL) :: PART
+ REAL, PARAMETER :: SLV = 2.501000E6
+
+
+! ----------------------------------------------------------------------
+! INITIALIZE CANOPY RESISTANCE MULTIPLIER TERMS.
+! ----------------------------------------------------------------------
+ RCS = 0.0
+ RCT = 0.0
+ RCQ = 0.0
+ RCSOIL = 0.0
+
+! ----------------------------------------------------------------------
+! CONTRIBUTION DUE TO INCOMING SOLAR RADIATION
+! ----------------------------------------------------------------------
+ RC = 0.0
+ FF = 0.55*2.0* SOLAR / (RGL * XLAI)
+ RCS = (FF + RSMIN / RSMAX) / (1.0+ FF)
+
+! ----------------------------------------------------------------------
+! CONTRIBUTION DUE TO AIR TEMPERATURE AT FIRST MODEL LEVEL ABOVE GROUND
+! RCT EXPRESSION FROM NOILHAN AND PLANTON (1989, MWR).
+! ----------------------------------------------------------------------
+ RCS = MAX (RCS,0.0001)
+ RCT = 1.0- 0.0016* ( (TOPT - SFCTMP)**2.0)
+
+! ----------------------------------------------------------------------
+! CONTRIBUTION DUE TO VAPOR PRESSURE DEFICIT AT FIRST MODEL LEVEL.
+! RCQ EXPRESSION FROM SSIB
+! ----------------------------------------------------------------------
+ RCT = MAX (RCT,0.0001)
+ RCQ = 1.0/ (1.0+ HS * (Q2SAT - Q2))
+
+! ----------------------------------------------------------------------
+! CONTRIBUTION DUE TO SOIL MOISTURE AVAILABILITY.
+! DETERMINE CONTRIBUTION FROM EACH SOIL LAYER, THEN ADD THEM UP.
+! ----------------------------------------------------------------------
+ RCQ = MAX (RCQ,0.01)
+ GX = (SMC (1) - SMCWLT) / (SMCREF - SMCWLT)
+ IF (GX > 1.) GX = 1.
+ IF (GX < 0.) GX = 0.
+
+! ----------------------------------------------------------------------
+! USE SOIL DEPTH AS WEIGHTING FACTOR
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! USE ROOT DISTRIBUTION AS WEIGHTING FACTOR
+! PART(1) = RTDIS(1) * GX
+! ----------------------------------------------------------------------
+ PART (1) = (ZSOIL (1)/ ZSOIL (NROOT)) * GX
+ DO K = 2,NROOT
+ GX = (SMC (K) - SMCWLT) / (SMCREF - SMCWLT)
+ IF (GX > 1.) GX = 1.
+ IF (GX < 0.) GX = 0.
+! ----------------------------------------------------------------------
+! USE SOIL DEPTH AS WEIGHTING FACTOR
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! USE ROOT DISTRIBUTION AS WEIGHTING FACTOR
+! PART(K) = RTDIS(K) * GX
+! ----------------------------------------------------------------------
+ PART (K) = ( (ZSOIL (K) - ZSOIL (K -1))/ ZSOIL (NROOT)) * GX
+ END DO
+ DO K = 1,NROOT
+ RCSOIL = RCSOIL + PART (K)
+ END DO
+
+! ----------------------------------------------------------------------
+! DETERMINE CANOPY RESISTANCE DUE TO ALL FACTORS. CONVERT CANOPY
+! RESISTANCE (RC) TO PLANT COEFFICIENT (PC) TO BE USED WITH POTENTIAL
+! EVAP IN DETERMINING ACTUAL EVAP. PC IS DETERMINED BY:
+! PC * LINERIZED PENMAN POTENTIAL EVAP =
+! PENMAN-MONTEITH ACTUAL EVAPORATION (CONTAINING RC TERM).
+! ----------------------------------------------------------------------
+ RCSOIL = MAX (RCSOIL,0.0001)
+
+ RC = RSMIN / (XLAI * RCS * RCT * RCQ * RCSOIL)
+! RR = (4.* SIGMA * RD / CP)* (SFCTMP **4.)/ (SFCPRS * CH) + 1.0
+ RR = (4.* EMISSI *SIGMA * RD / CP)* (SFCTMP **4.)/ (SFCPRS * CH) &
+ + 1.0
+
+ DELTA = (SLV / CP)* DQSDT2
+
+ PC = (RR + DELTA)/ (RR * (1. + RC * CH) + DELTA)
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE CANRES
+! ----------------------------------------------------------------------
+
+ SUBROUTINE CSNOW (SNCOND,DSNOW)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE CSNOW
+! FUNCTION CSNOW
+! ----------------------------------------------------------------------
+! CALCULATE SNOW TERMAL CONDUCTIVITY
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ REAL, INTENT(IN) :: DSNOW
+ REAL, INTENT(OUT):: SNCOND
+ REAL :: C
+ REAL, PARAMETER :: UNIT = 0.11631
+
+! ----------------------------------------------------------------------
+! SNCOND IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C)
+! CSNOW IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C)
+! BASIC VERSION IS DYACHKOVA EQUATION (1960), FOR RANGE 0.1-0.4
+! ----------------------------------------------------------------------
+ C = 0.328*10** (2.25* DSNOW)
+! CSNOW=UNIT*C
+
+! ----------------------------------------------------------------------
+! DE VAUX EQUATION (1933), IN RANGE 0.1-0.6
+! ----------------------------------------------------------------------
+! SNCOND=0.0293*(1.+100.*DSNOW**2)
+! CSNOW=0.0293*(1.+100.*DSNOW**2)
+
+! ----------------------------------------------------------------------
+! E. ANDERSEN FROM FLERCHINGER
+! ----------------------------------------------------------------------
+! SNCOND=0.021+2.51*DSNOW**2
+! CSNOW=0.021+2.51*DSNOW**2
+
+! SNCOND = UNIT * C
+! double snow thermal conductivity
+ SNCOND = 2.0 * UNIT * C
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE CSNOW
+! ----------------------------------------------------------------------
+
+ SUBROUTINE DEVAP (EDIR,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, &
+ DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE DEVAP
+! FUNCTION DEVAP
+! ----------------------------------------------------------------------
+! CALCULATE DIRECT SOIL EVAPORATION
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ REAL, INTENT(IN) :: ETP1,SMC,BEXP,DKSAT,DWSAT,FXEXP, &
+ SHDFAC,SMCDRY,SMCMAX,ZSOIL,SMCREF,SMCWLT
+ REAL, INTENT(OUT):: EDIR
+ REAL :: FX, SRATIO
+
+
+! ----------------------------------------------------------------------
+! DIRECT EVAP A FUNCTION OF RELATIVE SOIL MOISTURE AVAILABILITY, LINEAR
+! WHEN FXEXP=1.
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! FX > 1 REPRESENTS DEMAND CONTROL
+! FX < 1 REPRESENTS FLUX CONTROL
+! ----------------------------------------------------------------------
+
+ SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY)
+ IF (SRATIO > 0.) THEN
+ FX = SRATIO**FXEXP
+ FX = MAX ( MIN ( FX, 1. ) ,0. )
+ ELSE
+ FX = 0.
+ ENDIF
+
+! ----------------------------------------------------------------------
+! ALLOW FOR THE DIRECT-EVAP-REDUCING EFFECT OF SHADE
+! ----------------------------------------------------------------------
+ EDIR = FX * ( 1.0- SHDFAC ) * ETP1
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE DEVAP
+! ----------------------------------------------------------------------
+
+ SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, &
+ SH2O, &
+ SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, &
+ SMCREF,SHDFAC,CMCMAX, &
+ SMCDRY,CFACTR, &
+ EDIR,EC,ET,ETT,SFCTMP,Q2,NROOT,RTDIS,FXEXP)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE EVAPO
+! ----------------------------------------------------------------------
+! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER
+! UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH
+! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED.
+! FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND
+! CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: NSOIL, NROOT
+ INTEGER :: I,K
+ REAL, INTENT(IN) :: BEXP, CFACTR,CMC,CMCMAX,DKSAT, &
+ DT,DWSAT,ETP1,FXEXP,PC,Q2,SFCTMP, &
+ SHDFAC,SMCDRY,SMCMAX,SMCREF,SMCWLT
+ REAL, INTENT(OUT) :: EC,EDIR,ETA1,ETT
+ REAL :: CMC2MS
+ REAL,DIMENSION(1:NSOIL), INTENT(IN) :: RTDIS, SMC, SH2O, ZSOIL
+ REAL,DIMENSION(1:NSOIL), INTENT(OUT) :: ET
+
+! ----------------------------------------------------------------------
+! EXECUTABLE CODE BEGINS HERE IF THE POTENTIAL EVAPOTRANSPIRATION IS
+! GREATER THAN ZERO.
+! ----------------------------------------------------------------------
+ EDIR = 0.
+ EC = 0.
+ ETT = 0.
+ DO K = 1,NSOIL
+ ET (K) = 0.
+ END DO
+
+! ----------------------------------------------------------------------
+! RETRIEVE DIRECT EVAPORATION FROM SOIL SURFACE. CALL THIS FUNCTION
+! ONLY IF VEG COVER NOT COMPLETE.
+! FROZEN GROUND VERSION: SH2O STATES REPLACE SMC STATES.
+! ----------------------------------------------------------------------
+ IF (ETP1 > 0.0) THEN
+ IF (SHDFAC < 1.) THEN
+ CALL DEVAP (EDIR,ETP1,SMC (1),ZSOIL (1),SHDFAC,SMCMAX, &
+ BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP)
+ END IF
+! ----------------------------------------------------------------------
+! INITIALIZE PLANT TOTAL TRANSPIRATION, RETRIEVE PLANT TRANSPIRATION,
+! AND ACCUMULATE IT FOR ALL SOIL LAYERS.
+! ----------------------------------------------------------------------
+
+ IF (SHDFAC > 0.0) THEN
+ CALL TRANSP (ET,NSOIL,ETP1,SH2O,CMC,ZSOIL,SHDFAC,SMCWLT, &
+ CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT,RTDIS)
+ DO K = 1,NSOIL
+ ETT = ETT + ET ( K )
+ END DO
+! ----------------------------------------------------------------------
+! CALCULATE CANOPY EVAPORATION.
+! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR CMC=0.0.
+! ----------------------------------------------------------------------
+ IF (CMC > 0.0) THEN
+ EC = SHDFAC * ( ( CMC / CMCMAX ) ** CFACTR ) * ETP1
+ ELSE
+ EC = 0.0
+ END IF
+! ----------------------------------------------------------------------
+! EC SHOULD BE LIMITED BY THE TOTAL AMOUNT OF AVAILABLE WATER ON THE
+! CANOPY. -F.CHEN, 18-OCT-1994
+! ----------------------------------------------------------------------
+ CMC2MS = CMC / DT
+ EC = MIN ( CMC2MS, EC )
+ END IF
+ END IF
+! ----------------------------------------------------------------------
+! TOTAL UP EVAP AND TRANSP TYPES TO OBTAIN ACTUAL EVAPOTRANSP
+! ----------------------------------------------------------------------
+ ETA1 = EDIR + ETT + EC
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE EVAPO
+! ----------------------------------------------------------------------
+
+ SUBROUTINE FAC2MIT(SMCMAX,FLIMIT)
+ IMPLICIT NONE
+ REAL, INTENT(IN) :: SMCMAX
+ REAL, INTENT(OUT) :: FLIMIT
+
+ FLIMIT = 0.90
+
+ IF ( SMCMAX == 0.395 ) THEN
+ FLIMIT = 0.59
+ ELSE IF ( ( SMCMAX == 0.434 ) .OR. ( SMCMAX == 0.404 ) ) THEN
+ FLIMIT = 0.85
+ ELSE IF ( ( SMCMAX == 0.465 ) .OR. ( SMCMAX == 0.406 ) ) THEN
+ FLIMIT = 0.86
+ ELSE IF ( ( SMCMAX == 0.476 ) .OR. ( SMCMAX == 0.439 ) ) THEN
+ FLIMIT = 0.74
+ ELSE IF ( ( SMCMAX == 0.200 ) .OR. ( SMCMAX == 0.464 ) ) THEN
+ FLIMIT = 0.80
+ ENDIF
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE FAC2MIT
+! ----------------------------------------------------------------------
+
+ SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O,SMCMAX,BEXP,PSIS)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE FRH2O
+! ----------------------------------------------------------------------
+! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF
+! TEMPERATURE IS BELOW 273.15K (T0). REQUIRES NEWTON-TYPE ITERATION TO
+! SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL
+! (1999, JGR, VOL 104(D16), 19569-19585).
+! ----------------------------------------------------------------------
+! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON
+! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN
+! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT
+! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH
+! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM,
+! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE
+! LIMIT OF FREEZING POINT TEMPERATURE T0.
+! ----------------------------------------------------------------------
+! INPUT:
+
+! TKELV.........TEMPERATURE (Kelvin)
+! SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC)
+! SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC)
+! SMCMAX........SATURATION SOIL MOISTURE CONTENT (FROM REDPRM)
+! B.............SOIL TYPE "B" PARAMETER (FROM REDPRM)
+! PSIS..........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM)
+
+! OUTPUT:
+! FRH2O.........SUPERCOOLED LIQUID WATER CONTENT
+! FREE..........SUPERCOOLED LIQUID WATER CONTENT
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ REAL, INTENT(IN) :: BEXP,PSIS,SH2O,SMC,SMCMAX,TKELV
+ REAL, INTENT(OUT) :: FREE
+ REAL :: BX,DENOM,DF,DSWL,FK,SWL,SWLK
+ INTEGER :: NLOG,KCOUNT
+! PARAMETER(CK = 0.0)
+ REAL, PARAMETER :: CK = 8.0, BLIM = 5.5, ERROR = 0.005, &
+ HLICE = 3.335E5, GS = 9.81,DICE = 920.0, &
+ DH2O = 1000.0, T0 = 273.15
+
+! ----------------------------------------------------------------------
+! LIMITS ON PARAMETER B: B < 5.5 (use parameter BLIM)
+! SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS
+! NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES.
+! ----------------------------------------------------------------------
+ BX = BEXP
+
+! ----------------------------------------------------------------------
+! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG.
+! ----------------------------------------------------------------------
+ IF (BEXP > BLIM) BX = BLIM
+ NLOG = 0
+
+! ----------------------------------------------------------------------
+! IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), SH2O = SMC
+! ----------------------------------------------------------------------
+ KCOUNT = 0
+! FRH2O = SMC
+ IF (TKELV > (T0- 1.E-3)) THEN
+ FREE = SMC
+ ELSE
+
+! ----------------------------------------------------------------------
+! OPTION 1: ITERATED SOLUTION FOR NONZERO CK
+! IN KOREN ET AL, JGR, 1999, EQN 17
+! ----------------------------------------------------------------------
+! INITIAL GUESS FOR SWL (frozen content)
+! ----------------------------------------------------------------------
+ IF (CK /= 0.0) THEN
+ SWL = SMC - SH2O
+! ----------------------------------------------------------------------
+! KEEP WITHIN BOUNDS.
+! ----------------------------------------------------------------------
+ IF (SWL > (SMC -0.02)) SWL = SMC -0.02
+
+! ----------------------------------------------------------------------
+! START OF ITERATIONS
+! ----------------------------------------------------------------------
+ IF (SWL < 0.) SWL = 0.
+ 1001 Continue
+ IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0))) goto 1002
+ NLOG = NLOG +1
+ DF = ALOG ( ( PSIS * GS / HLICE ) * ( ( 1. + CK * SWL )**2.) * &
+ ( SMCMAX / (SMC - SWL) )** BX) - ALOG ( - ( &
+ TKELV - T0)/ TKELV)
+ DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL )
+ SWLK = SWL - DF / DENOM
+! ----------------------------------------------------------------------
+! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION.
+! ----------------------------------------------------------------------
+ IF (SWLK > (SMC -0.02)) SWLK = SMC - 0.02
+ IF (SWLK < 0.) SWLK = 0.
+
+! ----------------------------------------------------------------------
+! MATHEMATICAL SOLUTION BOUNDS APPLIED.
+! ----------------------------------------------------------------------
+ DSWL = ABS (SWLK - SWL)
+
+! ----------------------------------------------------------------------
+! IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.)
+! WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED.
+! ----------------------------------------------------------------------
+ SWL = SWLK
+ IF ( DSWL <= ERROR ) THEN
+ KCOUNT = KCOUNT +1
+ END IF
+! ----------------------------------------------------------------------
+! END OF ITERATIONS
+! ----------------------------------------------------------------------
+! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION.
+! ----------------------------------------------------------------------
+! FRH2O = SMC - SWL
+ goto 1001
+ 1002 continue
+ FREE = SMC - SWL
+ END IF
+! ----------------------------------------------------------------------
+! END OPTION 1
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0
+! IN KOREN ET AL., JGR, 1999, EQN 17
+! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION
+! ----------------------------------------------------------------------
+ IF (KCOUNT == 0) THEN
+ PRINT *,'Flerchinger USEd in NEW version. Iterations=',NLOG
+ FK = ( ( (HLICE / (GS * ( - PSIS)))* &
+ ( (TKELV - T0)/ TKELV))** ( -1/ BX))* SMCMAX
+! FRH2O = MIN (FK, SMC)
+ IF (FK < 0.02) FK = 0.02
+ FREE = MIN (FK, SMC)
+! ----------------------------------------------------------------------
+! END OPTION 2
+! ----------------------------------------------------------------------
+ END IF
+ END IF
+! ----------------------------------------------------------------------
+ END SUBROUTINE FRH2O
+! ----------------------------------------------------------------------
+
+ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, &
+ TBOT,ZBOT,PSISAT,SH2O,DT,BEXP, &
+ F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE HRT
+! ----------------------------------------------------------------------
+! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL
+! THERMAL DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX
+! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ LOGICAL :: ITAVG
+ INTEGER, INTENT(IN) :: NSOIL, VEGTYP
+ INTEGER, INTENT(IN) :: ISURBAN
+ INTEGER :: I, K
+
+ REAL, INTENT(IN) :: BEXP, CSOIL, DF1, DT,F1,PSISAT,QUARTZ, &
+ SMCMAX ,TBOT,YY,ZZ1, ZBOT
+ REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,STC,ZSOIL
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SH2O
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTS
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI,CI
+ REAL :: DDZ, DDZ2, DENOM, DF1N, DF1K, DTSDZ, &
+ DTSDZ2,HCPCT,QTOT,SSOIL,SICE,TAVG,TBK, &
+ TBK1,TSNSR,TSURF,CSOIL_LOC
+ REAL, PARAMETER :: T0 = 273.15, CAIR = 1004.0, CICE = 2.106E6,&
+ CH2O = 4.2E6
+
+
+!urban
+ IF( VEGTYP == ISURBAN ) then
+ CSOIL_LOC=3.0E6
+ ELSE
+ CSOIL_LOC=CSOIL
+ ENDIF
+
+! ----------------------------------------------------------------------
+! INITIALIZE LOGICAL FOR SOIL LAYER TEMPERATURE AVERAGING.
+! ----------------------------------------------------------------------
+ ITAVG = .TRUE.
+! ----------------------------------------------------------------------
+! BEGIN SECTION FOR TOP SOIL LAYER
+! ----------------------------------------------------------------------
+! CALC THE HEAT CAPACITY OF THE TOP SOIL LAYER
+! ----------------------------------------------------------------------
+ HCPCT = SH2O (1)* CH2O + (1.0- SMCMAX)* CSOIL_LOC + (SMCMAX - SMC (1))&
+ * CAIR &
+ + ( SMC (1) - SH2O (1) )* CICE
+
+! ----------------------------------------------------------------------
+! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER
+! ----------------------------------------------------------------------
+ DDZ = 1.0 / ( -0.5 * ZSOIL (2) )
+ AI (1) = 0.0
+ CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT)
+
+! ----------------------------------------------------------------------
+! CALCULATE THE VERTICAL SOIL TEMP GRADIENT BTWN THE 1ST AND 2ND SOIL
+! LAYERS. THEN CALCULATE THE SUBSURFACE HEAT FLUX. USE THE TEMP
+! GRADIENT AND SUBSFC HEAT FLUX TO CALC "RIGHT-HAND SIDE TENDENCY
+! TERMS", OR "RHSTS", FOR TOP SOIL LAYER.
+! ----------------------------------------------------------------------
+ BI (1) = - CI (1) + DF1 / (0.5 * ZSOIL (1) * ZSOIL (1)* HCPCT * &
+ ZZ1)
+ DTSDZ = (STC (1) - STC (2)) / ( -0.5 * ZSOIL (2))
+ SSOIL = DF1 * (STC (1) - YY) / (0.5 * ZSOIL (1) * ZZ1)
+! RHSTS(1) = (DF1 * DTSDZ - SSOIL) / (ZSOIL(1) * HCPCT)
+ DENOM = (ZSOIL (1) * HCPCT)
+
+! ----------------------------------------------------------------------
+! NEXT CAPTURE THE VERTICAL DIFFERENCE OF THE HEAT FLUX AT TOP AND
+! BOTTOM OF FIRST SOIL LAYER FOR USE IN HEAT FLUX CONSTRAINT APPLIED TO
+! POTENTIAL SOIL FREEZING/THAWING IN ROUTINE SNKSRC.
+! ----------------------------------------------------------------------
+! QTOT = SSOIL - DF1*DTSDZ
+ RHSTS (1) = (DF1 * DTSDZ - SSOIL) / DENOM
+
+! ----------------------------------------------------------------------
+! CALCULATE FROZEN WATER CONTENT IN 1ST SOIL LAYER.
+! ----------------------------------------------------------------------
+ QTOT = -1.0* RHSTS (1)* DENOM
+
+! ----------------------------------------------------------------------
+! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP):
+! SET TEMP "TSURF" AT TOP OF SOIL COLUMN (FOR USE IN FREEZING SOIL
+! PHYSICS LATER IN FUNCTION SUBROUTINE SNKSRC). IF SNOWPACK CONTENT IS
+! ZERO, THEN TSURF EXPRESSION BELOW GIVES TSURF = SKIN TEMP. IF
+! SNOWPACK IS NONZERO (HENCE ARGUMENT ZZ1=1), THEN TSURF EXPRESSION
+! BELOW YIELDS SOIL COLUMN TOP TEMPERATURE UNDER SNOWPACK. THEN
+! CALCULATE TEMPERATURE AT BOTTOM INTERFACE OF 1ST SOIL LAYER FOR USE
+! LATER IN FUNCTION SUBROUTINE SNKSRC
+! ----------------------------------------------------------------------
+ SICE = SMC (1) - SH2O (1)
+ IF (ITAVG) THEN
+ TSURF = (YY + (ZZ1-1) * STC (1)) / ZZ1
+! ----------------------------------------------------------------------
+! IF FROZEN WATER PRESENT OR ANY OF LAYER-1 MID-POINT OR BOUNDING
+! INTERFACE TEMPERATURES BELOW FREEZING, THEN CALL SNKSRC TO
+! COMPUTE HEAT SOURCE/SINK (AND CHANGE IN FROZEN WATER CONTENT)
+! DUE TO POSSIBLE SOIL WATER PHASE CHANGE
+! ----------------------------------------------------------------------
+ CALL TBND (STC (1),STC (2),ZSOIL,ZBOT,1,NSOIL,TBK)
+ IF ( (SICE > 0.) .OR. (STC (1) < T0) .OR. &
+ (TSURF < T0) .OR. (TBK < T0) ) THEN
+! TSNSR = SNKSRC (TAVG,SMC(1),SH2O(1),
+ CALL TMPAVG (TAVG,TSURF,STC (1),TBK,ZSOIL,NSOIL,1)
+ CALL SNKSRC (TSNSR,TAVG,SMC (1),SH2O (1), &
+ ZSOIL,NSOIL,SMCMAX,PSISAT,BEXP,DT,1,QTOT)
+! RHSTS(1) = RHSTS(1) - TSNSR / ( ZSOIL(1) * HCPCT )
+ RHSTS (1) = RHSTS (1) - TSNSR / DENOM
+ END IF
+ ELSE
+! TSNSR = SNKSRC (STC(1),SMC(1),SH2O(1),
+ IF ( (SICE > 0.) .OR. (STC (1) < T0) ) THEN
+ CALL SNKSRC (TSNSR,STC (1),SMC (1),SH2O (1), &
+ ZSOIL,NSOIL,SMCMAX,PSISAT,BEXP,DT,1,QTOT)
+! RHSTS(1) = RHSTS(1) - TSNSR / ( ZSOIL(1) * HCPCT )
+ RHSTS (1) = RHSTS (1) - TSNSR / DENOM
+ END IF
+! ----------------------------------------------------------------------
+! THIS ENDS SECTION FOR TOP SOIL LAYER.
+! ----------------------------------------------------------------------
+ END IF
+
+! INITIALIZE DDZ2
+! ----------------------------------------------------------------------
+
+ DDZ2 = 0.0
+ DF1K = DF1
+
+! ----------------------------------------------------------------------
+! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS
+! (EXCEPT SUBSFC OR "GROUND" HEAT FLUX NOT REPEATED IN LOWER LAYERS)
+! ----------------------------------------------------------------------
+! CALCULATE HEAT CAPACITY FOR THIS SOIL LAYER.
+! ----------------------------------------------------------------------
+ DO K = 2,NSOIL
+ HCPCT = SH2O (K)* CH2O + (1.0- SMCMAX)* CSOIL_LOC + (SMCMAX - SMC ( &
+ K))* CAIR + ( SMC (K) - SH2O (K) )* CICE
+! ----------------------------------------------------------------------
+! THIS SECTION FOR LAYER 2 OR GREATER, BUT NOT LAST LAYER.
+! ----------------------------------------------------------------------
+! CALCULATE THERMAL DIFFUSIVITY FOR THIS LAYER.
+! ----------------------------------------------------------------------
+ IF (K /= NSOIL) THEN
+
+! ----------------------------------------------------------------------
+! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER
+! ----------------------------------------------------------------------
+ CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K))
+
+!urban
+ IF ( VEGTYP == ISURBAN ) DF1N = 3.24
+
+ DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) )
+
+! ----------------------------------------------------------------------
+! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT
+! ----------------------------------------------------------------------
+ DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM
+ DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1))
+
+! ----------------------------------------------------------------------
+! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE
+! TEMP AT BOTTOM OF LAYER.
+! ----------------------------------------------------------------------
+ CI (K) = - DF1N * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K)) * &
+ HCPCT)
+ IF (ITAVG) THEN
+ CALL TBND (STC (K),STC (K +1),ZSOIL,ZBOT,K,NSOIL,TBK1)
+ END IF
+
+ ELSE
+! ----------------------------------------------------------------------
+! SPECIAL CASE OF BOTTOM SOIL LAYER: CALCULATE THERMAL DIFFUSIVITY FOR
+! BOTTOM LAYER.
+! ----------------------------------------------------------------------
+
+! ----------------------------------------------------------------------
+! CALC THE VERTICAL SOIL TEMP GRADIENT THRU BOTTOM LAYER.
+! ----------------------------------------------------------------------
+ CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K))
+
+
+!urban
+ IF ( VEGTYP == ISURBAN ) DF1N = 3.24
+
+ DENOM = .5 * (ZSOIL (K -1) + ZSOIL (K)) - ZBOT
+
+! ----------------------------------------------------------------------
+! SET MATRIX COEF, CI TO ZERO IF BOTTOM LAYER.
+! ----------------------------------------------------------------------
+ DTSDZ2 = (STC (K) - TBOT) / DENOM
+
+! ----------------------------------------------------------------------
+! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE
+! TEMP AT BOTTOM OF LAST LAYER.
+! ----------------------------------------------------------------------
+ CI (K) = 0.
+ IF (ITAVG) THEN
+ CALL TBND (STC (K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1)
+ END IF
+! ----------------------------------------------------------------------
+! THIS ENDS SPECIAL LOOP FOR BOTTOM LAYER.
+ END IF
+! ----------------------------------------------------------------------
+! CALCULATE RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT.
+! ----------------------------------------------------------------------
+ DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT
+ RHSTS (K) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM
+ QTOT = -1.0* DENOM * RHSTS (K)
+
+ SICE = SMC (K) - SH2O (K)
+ IF (ITAVG) THEN
+ CALL TMPAVG (TAVG,TBK,STC (K),TBK1,ZSOIL,NSOIL,K)
+! TSNSR = SNKSRC(TAVG,SMC(K),SH2O(K),ZSOIL,NSOIL,
+ IF ( (SICE > 0.) .OR. (STC (K) < T0) .OR. &
+ (TBK .lt. T0) .OR. (TBK1 .lt. T0) ) THEN
+ CALL SNKSRC (TSNSR,TAVG,SMC (K),SH2O (K),ZSOIL,NSOIL, &
+ SMCMAX,PSISAT,BEXP,DT,K,QTOT)
+ RHSTS (K) = RHSTS (K) - TSNSR / DENOM
+ END IF
+ ELSE
+! TSNSR = SNKSRC(STC(K),SMC(K),SH2O(K),ZSOIL,NSOIL,
+ IF ( (SICE > 0.) .OR. (STC (K) < T0) ) THEN
+ CALL SNKSRC (TSNSR,STC (K),SMC (K),SH2O (K),ZSOIL,NSOIL, &
+ SMCMAX,PSISAT,BEXP,DT,K,QTOT)
+ RHSTS (K) = RHSTS (K) - TSNSR / DENOM
+ END IF
+ END IF
+
+! ----------------------------------------------------------------------
+! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER.
+! ----------------------------------------------------------------------
+ AI (K) = - DF1K * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT)
+
+! ----------------------------------------------------------------------
+! RESET VALUES OF DF1, DTSDZ, DDZ, AND TBK FOR LOOP TO NEXT SOIL LAYER.
+! ----------------------------------------------------------------------
+ BI (K) = - (AI (K) + CI (K))
+ TBK = TBK1
+ DF1K = DF1N
+ DTSDZ = DTSDZ2
+ DDZ = DDZ2
+ END DO
+! ----------------------------------------------------------------------
+ END SUBROUTINE HRT
+! ----------------------------------------------------------------------
+
+ SUBROUTINE HRTICE (RHSTS,STC,TBOT,ICE,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE HRTICE
+! ----------------------------------------------------------------------
+! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL
+! THERMAL DIFFUSION EQUATION IN THE CASE OF SEA-ICE (ICE=1) OR GLACIAL
+! ICE (ICE=-1). COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE
+! TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME.
+!
+! (NOTE: THIS SUBROUTINE ONLY CALLED FOR SEA-ICE OR GLACIAL ICE, BUT
+! NOT FOR NON-GLACIAL LAND (ICE = 0).
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+
+ INTEGER, INTENT(IN) :: NSOIL
+ INTEGER :: K
+
+ REAL, INTENT(IN) :: DF1,YY,ZZ1
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT):: AI, BI,CI
+ REAL, DIMENSION(1:NSOIL), INTENT(IN) :: STC, ZSOIL
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT):: RHSTS
+ REAL, INTENT(IN) :: TBOT
+ INTEGER, INTENT(IN) :: ICE
+ REAL :: DDZ,DDZ2,DENOM,DTSDZ,DTSDZ2,SSOIL, &
+ ZBOT
+ REAL :: HCPCT
+ REAL :: DF1K
+ REAL :: DF1N
+ REAL :: ZMD
+
+! ----------------------------------------------------------------------
+! SET A NOMINAL UNIVERSAL VALUE OF THE SEA-ICE SPECIFIC HEAT CAPACITY,
+! HCPCT = 1880.0*917.0.
+! ----------------------------------------------------------------------
+ IF ( ICE == 1 ) THEN
+ ! Sea-ice values
+ HCPCT = 1.72396E+6
+ ELSEIF (ICE == -1) THEN
+! SET A NOMINAL UNIVERSAL VALUE OF GLACIAL-ICE SPECIFIC HEAT CAPACITY,
+! HCPCT = 2100.0*900.0 = 1.89000E+6 (SOURCE: BOB GRUMBINE, 2005)
+! TBOT PASSED IN AS ARGUMENT, VALUE FROM GLOBAL DATA SET
+ !
+ ! A least-squares fit for the four points provided by
+ ! Keith Hines for the Yen (1981) values for Antarctic
+ ! snow firn.
+ !
+ HCPCT = 1.E6 * (0.8194 - 0.1309*0.5*ZSOIL(1))
+ DF1K = DF1
+ ENDIF
+
+! ----------------------------------------------------------------------
+! THE INPUT ARGUMENT DF1 IS A UNIVERSALLY CONSTANT VALUE OF SEA-ICE
+! THERMAL DIFFUSIVITY, SET IN ROUTINE SNOPAC AS DF1 = 2.2.
+! ----------------------------------------------------------------------
+! SET ICE PACK DEPTH. USE TBOT AS ICE PACK LOWER BOUNDARY TEMPERATURE
+! (THAT OF UNFROZEN SEA WATER AT BOTTOM OF SEA ICE PACK). ASSUME ICE
+! PACK IS OF N=NSOIL LAYERS SPANNING A UNIFORM CONSTANT ICE PACK
+! THICKNESS AS DEFINED BY ZSOIL(NSOIL) IN ROUTINE SFLX.
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER
+! ----------------------------------------------------------------------
+ IF (ICE == 1) THEN
+ ZBOT = ZSOIL (NSOIL)
+ ELSE IF (ICE == -1) THEN
+ ZBOT = -25.0
+ ENDIF
+ DDZ = 1.0 / ( -0.5 * ZSOIL (2) )
+ AI (1) = 0.0
+ CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT)
+
+! ----------------------------------------------------------------------
+! CALC THE VERTICAL SOIL TEMP GRADIENT BTWN THE TOP AND 2ND SOIL LAYERS.
+! RECALC/ADJUST THE SOIL HEAT FLUX. USE THE GRADIENT AND FLUX TO CALC
+! RHSTS FOR THE TOP SOIL LAYER.
+! ----------------------------------------------------------------------
+ BI (1) = - CI (1) + DF1/ (0.5 * ZSOIL (1) * ZSOIL (1) * HCPCT * &
+ ZZ1)
+ DTSDZ = ( STC (1) - STC (2) ) / ( -0.5 * ZSOIL (2) )
+ SSOIL = DF1 * ( STC (1) - YY ) / ( 0.5 * ZSOIL (1) * ZZ1 )
+
+! ----------------------------------------------------------------------
+! INITIALIZE DDZ2
+! ----------------------------------------------------------------------
+ RHSTS (1) = ( DF1 * DTSDZ - SSOIL ) / ( ZSOIL (1) * HCPCT )
+
+! ----------------------------------------------------------------------
+! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS
+! ----------------------------------------------------------------------
+ DDZ2 = 0.0
+ DF1K = DF1
+ DF1N = DF1
+ DO K = 2,NSOIL
+
+ IF ( ICE == -1 ) THEN
+ ZMD = 0.5 * (ZSOIL(K)+ZSOIL(K-1))
+ ! For the land-ice case
+! kmh 09/03/2006 use Yen (1981)'s values for Antarctic snow firn
+! IF ( K .eq. 2 ) HCPCT = 0.855108E6
+! IF ( K .eq. 3 ) HCPCT = 0.922906E6
+! IF ( K .eq. 4 ) HCPCT = 1.009986E6
+
+ ! Least squares fit to the four points supplied by Keith Hines
+ ! from Yen (1981) for Antarctic snow firn. Not optimal, but
+ ! probably better than just a constant.
+ HCPCT = 1.E6 * ( 0.8194 - 0.1309*ZMD )
+
+! IF ( K .eq. 2 ) DF1N = 0.345356
+! IF ( K .eq. 3 ) DF1N = 0.398777
+! IF ( K .eq. 4 ) DF1N = 0.472653
+
+ ! Least squares fit to the three points supplied by Keith Hines
+ ! from Yen (1981) for Antarctic snow firn. Not optimal, but
+ ! probably better than just a constant.
+ DF1N = 0.32333 - ( 0.10073 * ZMD )
+ ENDIF
+! ----------------------------------------------------------------------
+! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER.
+! ----------------------------------------------------------------------
+ IF (K /= NSOIL) THEN
+ DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) )
+
+! ----------------------------------------------------------------------
+! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT.
+! ----------------------------------------------------------------------
+ DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM
+ DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1))
+ CI (K) = - DF1N * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K))*HCPCT)
+
+! ----------------------------------------------------------------------
+! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THE LOWEST LAYER.
+! ----------------------------------------------------------------------
+ ELSE
+
+! ----------------------------------------------------------------------
+! SET MATRIX COEF, CI TO ZERO.
+! ----------------------------------------------------------------------
+ DTSDZ2 = (STC (K) - TBOT)/ (.5 * (ZSOIL (K -1) + ZSOIL (K)) &
+ - ZBOT)
+ CI (K) = 0.
+! ----------------------------------------------------------------------
+! CALC RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT.
+! ----------------------------------------------------------------------
+ END IF
+ DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT
+
+! ----------------------------------------------------------------------
+! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER.
+! ----------------------------------------------------------------------
+ RHSTS (K) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM
+ AI (K) = - DF1K * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT)
+
+! ----------------------------------------------------------------------
+! RESET VALUES OF DTSDZ AND DDZ FOR LOOP TO NEXT SOIL LYR.
+! ----------------------------------------------------------------------
+ BI (K) = - (AI (K) + CI (K))
+ DF1K = DF1N
+ DTSDZ = DTSDZ2
+ DDZ = DDZ2
+ END DO
+! ----------------------------------------------------------------------
+ END SUBROUTINE HRTICE
+! ----------------------------------------------------------------------
+
+ SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE HSTEP
+! ----------------------------------------------------------------------
+! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: NSOIL
+ INTEGER :: K
+
+ REAL, DIMENSION(1:NSOIL), INTENT(IN):: STCIN
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT):: STCOUT
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: RHSTS
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: AI,BI,CI
+ REAL, DIMENSION(1:NSOIL) :: RHSTSin
+ REAL, DIMENSION(1:NSOIL) :: CIin
+ REAL :: DT
+
+! ----------------------------------------------------------------------
+! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE
+! ----------------------------------------------------------------------
+ DO K = 1,NSOIL
+ RHSTS (K) = RHSTS (K) * DT
+ AI (K) = AI (K) * DT
+ BI (K) = 1. + BI (K) * DT
+ CI (K) = CI (K) * DT
+ END DO
+! ----------------------------------------------------------------------
+! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12
+! ----------------------------------------------------------------------
+ DO K = 1,NSOIL
+ RHSTSin (K) = RHSTS (K)
+ END DO
+ DO K = 1,NSOIL
+ CIin (K) = CI (K)
+ END DO
+! ----------------------------------------------------------------------
+! SOLVE THE TRI-DIAGONAL MATRIX EQUATION
+! ----------------------------------------------------------------------
+ CALL ROSR12 (CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL)
+! ----------------------------------------------------------------------
+! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION
+! ----------------------------------------------------------------------
+ DO K = 1,NSOIL
+ STCOUT (K) = STCIN (K) + CI (K)
+ END DO
+! ----------------------------------------------------------------------
+ END SUBROUTINE HSTEP
+! ----------------------------------------------------------------------
+
+ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, &
+ SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT,SHDFAC, &
+ SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,EMISSI, &
+ SSOIL, &
+ STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, &
+ SH2O,SLOPE,KDT,FRZFACT,PSISAT,ZSOIL, &
+ DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, &
+ RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, &
+ QUARTZ,FXEXP,CSOIL, &
+ BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE NOPAC
+! ----------------------------------------------------------------------
+! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES AND UPDATE SOIL MOISTURE
+! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN NO SNOW PACK IS
+! PRESENT.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN) :: ICE, NROOT,NSOIL,VEGTYP
+ INTEGER, INTENT(IN) :: ISURBAN
+ INTEGER :: K
+
+ REAL, INTENT(IN) :: BEXP,CFACTR, CMCMAX,CSOIL,DKSAT,DT,DWSAT, &
+ EPSCA,ETP,FDOWN,F1,FXEXP,FRZFACT,KDT,PC, &
+ PRCP,PSISAT,Q2,QUARTZ,RCH,RR,SBETA,SFCTMP,&
+ SHDFAC,SLOPE,SMCDRY,SMCMAX,SMCREF,SMCWLT, &
+ T24,TBOT,TH2,ZBOT,EMISSI
+ REAL, INTENT(INOUT) :: CMC,BETA,T1
+ REAL, INTENT(OUT) :: DEW,DRIP,EC,EDIR,ETA,ETT,FLX1,FLX3, &
+ RUNOFF1,RUNOFF2,RUNOFF3,SSOIL
+ REAL, DIMENSION(1:NSOIL),INTENT(IN) :: RTDIS,ZSOIL
+ REAL, DIMENSION(1:NSOIL),INTENT(OUT) :: ET
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC,SH2O,STC
+ REAL, DIMENSION(1:NSOIL) :: ET1
+ REAL :: EC1,EDIR1,ETT1,DF1,ETA1,ETP1,PRCP1,YY, &
+ YYNUM,ZZ1
+
+! ----------------------------------------------------------------------
+! EXECUTABLE CODE BEGINS HERE:
+! CONVERT ETP Fnd PRCP FROM KG M-2 S-1 TO M S-1 AND INITIALIZE DEW.
+! ----------------------------------------------------------------------
+ PRCP1 = PRCP * 0.001
+ ETP1 = ETP * 0.001
+ DEW = 0.0
+! ----------------------------------------------------------------------
+! INITIALIZE EVAP TERMS.
+! ----------------------------------------------------------------------
+ EDIR = 0.
+ EDIR1 = 0.
+ EC1 = 0.
+ EC = 0.
+ DO K = 1,NSOIL
+ ET(K) = 0.
+ ET1(K) = 0.
+ END DO
+ ETT = 0.
+ ETT1 = 0.
+
+ IF (ETP > 0.0) THEN
+ CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, &
+ SH2O, &
+ SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, &
+ SMCREF,SHDFAC,CMCMAX, &
+ SMCDRY,CFACTR, &
+ EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP)
+ CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, &
+ SH2O,SLOPE,KDT,FRZFACT, &
+ SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, &
+ SHDFAC,CMCMAX, &
+ RUNOFF1,RUNOFF2,RUNOFF3, &
+ EDIR1,EC1,ET1, &
+ DRIP)
+
+! ----------------------------------------------------------------------
+! CONVERT MODELED EVAPOTRANSPIRATION FROM M S-1 TO KG M-2 S-1.
+! ----------------------------------------------------------------------
+
+ ETA = ETA1 * 1000.0
+
+! ----------------------------------------------------------------------
+! IF ETP < 0, ASSUME DEW FORMS (TRANSFORM ETP1 INTO DEW AND REINITIALIZE
+! ETP1 TO ZERO).
+! ----------------------------------------------------------------------
+ ELSE
+ DEW = - ETP1
+
+! ----------------------------------------------------------------------
+! CONVERT PRCP FROM 'KG M-2 S-1' TO 'M S-1' AND ADD DEW AMOUNT.
+! ----------------------------------------------------------------------
+
+ PRCP1 = PRCP1+ DEW
+ CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, &
+ SH2O,SLOPE,KDT,FRZFACT, &
+ SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, &
+ SHDFAC,CMCMAX, &
+ RUNOFF1,RUNOFF2,RUNOFF3, &
+ EDIR1,EC1,ET1, &
+ DRIP)
+
+! ----------------------------------------------------------------------
+! CONVERT MODELED EVAPOTRANSPIRATION FROM 'M S-1' TO 'KG M-2 S-1'.
+! ----------------------------------------------------------------------
+! ETA = ETA1 * 1000.0
+ END IF
+
+! ----------------------------------------------------------------------
+! BASED ON ETP AND E VALUES, DETERMINE BETA
+! ----------------------------------------------------------------------
+
+ IF ( ETP <= 0.0 ) THEN
+ BETA = 0.0
+ ETA = ETP
+ IF ( ETP < 0.0 ) THEN
+ BETA = 1.0
+ END IF
+ ELSE
+ BETA = ETA / ETP
+ END IF
+
+! ----------------------------------------------------------------------
+! CONVERT MODELED EVAPOTRANSPIRATION COMPONENTS 'M S-1' TO 'KG M-2 S-1'.
+! ----------------------------------------------------------------------
+ EDIR = EDIR1*1000.
+ EC = EC1*1000.
+ DO K = 1,NSOIL
+ ET(K) = ET1(K)*1000.
+ END DO
+ ETT = ETT1*1000.
+
+! ----------------------------------------------------------------------
+! GET SOIL THERMAL DIFFUXIVITY/CONDUCTIVITY FOR TOP SOIL LYR,
+! CALC. ADJUSTED TOP LYR SOIL TEMP AND ADJUSTED SOIL FLUX, THEN
+! CALL SHFLX TO COMPUTE/UPDATE SOIL HEAT FLUX AND SOIL TEMPS.
+! ----------------------------------------------------------------------
+
+ CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1))
+
+!urban
+ IF ( VEGTYP == ISURBAN ) DF1=3.24
+!
+
+! ----------------------------------------------------------------------
+! VEGETATION GREENNESS FRACTION REDUCTION IN SUBSURFACE HEAT FLUX
+! VIA REDUCTION FACTOR, WHICH IS CONVENIENT TO APPLY HERE TO THERMAL
+! DIFFUSIVITY THAT IS LATER USED IN HRT TO COMPUTE SUB SFC HEAT FLUX
+! (SEE ADDITIONAL COMMENTS ON VEG EFFECT SUB-SFC HEAT FLX IN
+! ROUTINE SFLX)
+! ----------------------------------------------------------------------
+ DF1 = DF1 * EXP (SBETA * SHDFAC)
+! ----------------------------------------------------------------------
+! COMPUTE INTERMEDIATE TERMS PASSED TO ROUTINE HRT (VIA ROUTINE
+! SHFLX BELOW) FOR USE IN COMPUTING SUBSURFACE HEAT FLUX IN HRT
+! ----------------------------------------------------------------------
+ YYNUM = FDOWN - EMISSI*SIGMA * T24
+ YY = SFCTMP + (YYNUM / RCH + TH2- SFCTMP - BETA * EPSCA) / RR
+
+ ZZ1 = DF1 / ( -0.5 * ZSOIL (1) * RCH * RR ) + 1.0
+
+!urban
+ CALL SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, &
+ TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, &
+ QUARTZ,CSOIL,VEGTYP,ISURBAN)
+
+! ----------------------------------------------------------------------
+! SET FLX1 AND FLX3 (SNOPACK PHASE CHANGE HEAT FLUXES) TO ZERO SINCE
+! THEY ARE NOT USED HERE IN SNOPAC. FLX2 (FREEZING RAIN HEAT FLUX) WAS
+! SIMILARLY INITIALIZED IN THE PENMAN ROUTINE.
+! ----------------------------------------------------------------------
+ FLX1 = CPH2O * PRCP * (T1- SFCTMP)
+ FLX3 = 0.0
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE NOPAC
+! ----------------------------------------------------------------------
+
+ SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, &
+ & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, &
+ & DQSDT2,FLX2,EMISSI_IN,SNEQV,T1,ICE,SNCOVR)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE PENMAN
+! ----------------------------------------------------------------------
+! CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT. VARIOUS
+! PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE
+! CALLING ROUTINE FOR LATER USE.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ LOGICAL, INTENT(IN) :: SNOWNG, FRZGRA
+ REAL, INTENT(IN) :: CH, DQSDT2,FDOWN,PRCP, &
+ Q2, Q2SAT,SSOIL, SFCPRS, SFCTMP, &
+ T2V, TH2,EMISSI_IN,SNEQV
+ REAL, INTENT(IN) :: T1 , SNCOVR
+!
+! kmh 09/13/2006
+ INTEGER, INTENT(IN) :: ICE
+! kmh 09/03/2006
+!
+ REAL, INTENT(OUT) :: EPSCA,ETP,FLX2,RCH,RR,T24
+ REAL :: A, DELTA, FNET,RAD,RHO,EMISSI,ELCP1,LVS
+
+ REAL, PARAMETER :: ELCP = 2.4888E+3, LSUBC = 2.501000E+6,CP = 1004.6
+ REAL, PARAMETER :: LSUBS = 2.83E+6
+
+! ----------------------------------------------------------------------
+! EXECUTABLE CODE BEGINS HERE:
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION.
+! ----------------------------------------------------------------------
+ EMISSI=EMISSI_IN
+ IF (ICE==0) THEN
+ ELCP1 = (1.0-SNCOVR)*ELCP + SNCOVR*ELCP*LSUBS/LSUBC
+ LVS = (1.0-SNCOVR)*LSUBC + SNCOVR*LSUBS
+ ELSE
+ IF ( T1 > 273.15 ) THEN
+ ELCP1=ELCP
+ LVS=LSUBC
+ ELSE
+ ELCP1 = ELCP*LSUBS/LSUBC
+ LVS = LSUBS
+ ENDIF
+ ENDIF
+
+ FLX2 = 0.0
+! DELTA = ELCP * DQSDT2
+ DELTA = ELCP1 * DQSDT2
+ T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP
+! RR = T24 * 6.48E-8 / (SFCPRS * CH) + 1.0
+ RR = EMISSI*T24 * 6.48E-8 / (SFCPRS * CH) + 1.0
+ RHO = SFCPRS / (RD * T2V)
+
+! ----------------------------------------------------------------------
+! ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT
+! EFFECTS CAUSED BY FALLING PRECIPITATION.
+! ----------------------------------------------------------------------
+ RCH = RHO * CP * CH
+ IF (.NOT. SNOWNG) THEN
+ IF (PRCP > 0.0) RR = RR + CPH2O * PRCP / RCH
+ ELSE
+ RR = RR + CPICE * PRCP / RCH
+ END IF
+
+! ----------------------------------------------------------------------
+! INCLUDE THE LATENT HEAT EFFECTS OF FRZNG RAIN CONVERTING TO ICE ON
+! IMPACT IN THE CALCULATION OF FLX2 AND FNET.
+! ----------------------------------------------------------------------
+! FNET = FDOWN - SIGMA * T24- SSOIL
+ FNET = FDOWN - EMISSI*SIGMA * T24- SSOIL
+ IF (FRZGRA) THEN
+ FLX2 = - LSUBF * PRCP
+ FNET = FNET - FLX2
+! ----------------------------------------------------------------------
+! FINISH PENMAN EQUATION CALCULATIONS.
+! ----------------------------------------------------------------------
+ END IF
+ RAD = FNET / RCH + TH2- SFCTMP
+! A = ELCP * (Q2SAT - Q2)
+ A = ELCP1 * (Q2SAT - Q2)
+ EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR)
+! ETP = EPSCA * RCH / LSUBC
+ ETP = EPSCA * RCH / LVS
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE PENMAN
+! ----------------------------------------------------------------------
+
+ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, &
+ TOPT, &
+ REFKDT,KDT,SBETA, SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX, &
+ PSISAT,SLOPE,SNUP,SALP,BEXP,DKSAT,DWSAT, &
+ SMCMAX,SMCWLT,SMCREF,SMCDRY,F1,QUARTZ,FXEXP, &
+ RTDIS,SLDPTH,ZSOIL, NROOT,NSOIL,CZIL, &
+ LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN, &
+ ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE, &
+ LSOIL, LOCAL,LVCOEF)
+
+ IMPLICIT NONE
+! ----------------------------------------------------------------------
+! Internally set (default valuess)
+! all soil and vegetation parameters required for the execusion oF
+! the Noah lsm are defined in VEGPARM.TBL, SOILPARM.TB, and GENPARM.TBL.
+! ----------------------------------------------------------------------
+! Vegetation parameters:
+! ALBBRD: SFC background snow-free albedo
+! CMXTBL: MAX CNPY Capacity
+! Z0BRD: Background roughness length
+! SHDFAC: Green vegetation fraction
+! NROOT: Rooting depth
+! RSMIN: Mimimum stomatal resistance
+! RSMAX: Max. stomatal resistance
+! RGL: Parameters used in radiation stress function
+! HS: Parameter used in vapor pressure deficit functio
+! TOPT: Optimum transpiration air temperature.
+! CMCMAX: Maximum canopy water capacity
+! CFACTR: Parameter used in the canopy inteception calculation
+! SNUP: Threshold snow depth (in water equivalent m) that
+! implies 100 percent snow cover
+! LAI: Leaf area index
+!
+! ----------------------------------------------------------------------
+! Soil parameters:
+! SMCMAX: MAX soil moisture content (porosity)
+! SMCREF: Reference soil moisture (field capacity)
+! SMCWLT: Wilting point soil moisture
+! SMCWLT: Air dry soil moist content limits
+! SSATPSI: SAT (saturation) soil potential
+! DKSAT: SAT soil conductivity
+! BEXP: B parameter
+! SSATDW: SAT soil diffusivity
+! F1: Soil thermal diffusivity/conductivity coef.
+! QUARTZ: Soil quartz content
+! Modified by F. Chen (12/22/97) to use the STATSGO soil map
+! Modified By F. Chen (01/22/00) to include PLaya, Lava, and White San
+! Modified By F. Chen (08/05/02) to include additional parameters for the Noah
+! NOTE: SATDW = BB*SATDK*(SATPSI/MAXSMC)
+! F11 = ALOG10(SATPSI) + BB*ALOG10(MAXSMC) + 2.0
+! REFSMC1=MAXSMC*(5.79E-9/SATDK)**(1/(2*BB+3)) 5.79E-9 m/s= 0.5 mm
+! REFSMC=REFSMC1+1./3.(MAXSMC-REFSMC1)
+! WLTSMC1=MAXSMC*(200./SATPSI)**(-1./BB) (Wetzel and Chang, 198
+! WLTSMC=WLTSMC1-0.5*WLTSMC1
+! Note: the values for playa is set for it to have a thermal conductivit
+! as sand and to have a hydrulic conductivity as clay
+!
+! ----------------------------------------------------------------------
+! Class parameter 'SLOPETYP' was included to estimate linear reservoir
+! coefficient 'SLOPE' to the baseflow runoff out of the bottom layer.
+! lowest class (slopetyp=0) means highest slope parameter = 1.
+! definition of slopetyp from 'zobler' slope type:
+! slope class percent slope
+! 1 0-8
+! 2 8-30
+! 3 > 30
+! 4 0-30
+! 5 0-8 & > 30
+! 6 8-30 & > 30
+! 7 0-8, 8-30, > 30
+! 9 GLACIAL ICE
+! BLANK OCEAN/SEA
+! SLOPE_DATA: linear reservoir coefficient
+! SBETA_DATA: parameter used to caluculate vegetation effect on soil heat
+! FXEXP_DAT: soil evaporation exponent used in DEVAP
+! CSOIL_DATA: soil heat capacity [J M-3 K-1]
+! SALP_DATA: shape parameter of distribution function of snow cover
+! REFDK_DATA and REFKDT_DATA: parameters in the surface runoff parameteriz
+! FRZK_DATA: frozen ground parameter
+! ZBOT_DATA: depth[M] of lower boundary soil temperature
+! CZIL_DATA: calculate roughness length of heat
+! SMLOW_DATA and MHIGH_DATA: two soil moisture wilt, soil moisture referen
+! parameters
+! Set maximum number of soil-, veg-, and slopetyp in data statement.
+! ----------------------------------------------------------------------
+ INTEGER, PARAMETER :: MAX_SLOPETYP=30,MAX_SOILTYP=30,MAX_VEGTYP=30
+ LOGICAL :: LOCAL
+ CHARACTER (LEN=256), INTENT(IN):: LLANDUSE, LSOIL
+
+! Veg parameters
+ INTEGER, INTENT(IN) :: VEGTYP
+ INTEGER, INTENT(OUT) :: NROOT
+ REAL, INTENT(OUT) :: HS,RSMIN,RGL,SHDFAC,SNUP, &
+ CMCMAX,RSMAX,TOPT, &
+ EMISSMIN, EMISSMAX, &
+ LAIMIN, LAIMAX, &
+ Z0MIN, Z0MAX, &
+ ALBEDOMIN, ALBEDOMAX
+! Soil parameters
+ INTEGER, INTENT(IN) :: SOILTYP
+ REAL, INTENT(OUT) :: BEXP,DKSAT,DWSAT,F1,QUARTZ,SMCDRY, &
+ SMCMAX,SMCREF,SMCWLT,PSISAT
+! General parameters
+ INTEGER, INTENT(IN) :: SLOPETYP,NSOIL
+ INTEGER :: I
+
+ REAL, INTENT(OUT) :: SLOPE,CZIL,SBETA,FXEXP, &
+ CSOIL,SALP,FRZX,KDT,CFACTR, &
+ ZBOT,REFKDT,PTU
+ REAL, INTENT(OUT) :: LVCOEF
+ REAL,DIMENSION(1:NSOIL),INTENT(IN) :: SLDPTH,ZSOIL
+ REAL,DIMENSION(1:NSOIL),INTENT(OUT):: RTDIS
+ REAL :: FRZFACT,FRZK,REFDK
+
+! SAVE
+! ----------------------------------------------------------------------
+!
+ IF (SOILTYP .gt. SLCATS) THEN
+! CALL wrf_error_fatal ( 'Warning: too many input soil types' )
+ END IF
+ IF (VEGTYP .gt. LUCATS) THEN
+! CALL wrf_error_fatal ( 'Warning: too many input landuse types' )
+ END IF
+ IF (SLOPETYP .gt. SLPCATS) THEN
+! CALL wrf_error_fatal ( 'Warning: too many input slope types' )
+ END IF
+
+! ----------------------------------------------------------------------
+! SET-UP SOIL PARAMETERS
+! ----------------------------------------------------------------------
+ CSOIL = CSOIL_DATA
+ BEXP = BB (SOILTYP)
+ DKSAT = SATDK (SOILTYP)
+ DWSAT = SATDW (SOILTYP)
+ F1 = F11 (SOILTYP)
+ PSISAT = SATPSI (SOILTYP)
+ QUARTZ = QTZ (SOILTYP)
+ SMCDRY = DRYSMC (SOILTYP)
+ SMCMAX = MAXSMC (SOILTYP)
+ SMCREF = REFSMC (SOILTYP)
+ SMCWLT = WLTSMC (SOILTYP)
+! ----------------------------------------------------------------------
+! Set-up universal parameters (not dependent on SOILTYP, VEGTYP or
+! SLOPETYP)
+! ----------------------------------------------------------------------
+ ZBOT = ZBOT_DATA
+ SALP = SALP_DATA
+ SBETA = SBETA_DATA
+ REFDK = REFDK_DATA
+ FRZK = FRZK_DATA
+ FXEXP = FXEXP_DATA
+ REFKDT = REFKDT_DATA
+ PTU = 0. ! (not used yet) to satisify intent(out)
+ KDT = REFKDT * DKSAT / REFDK
+ CZIL = CZIL_DATA
+ SLOPE = SLOPE_DATA (SLOPETYP)
+ LVCOEF = LVCOEF_DATA
+
+! ----------------------------------------------------------------------
+! TO ADJUST FRZK PARAMETER TO ACTUAL SOIL TYPE: FRZK * FRZFACT
+! ----------------------------------------------------------------------
+ FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468)
+ FRZX = FRZK * FRZFACT
+
+! ----------------------------------------------------------------------
+! SET-UP VEGETATION PARAMETERS
+! ----------------------------------------------------------------------
+ TOPT = TOPT_DATA
+ CMCMAX = CMCMAX_DATA
+ CFACTR = CFACTR_DATA
+ RSMAX = RSMAX_DATA
+ NROOT = NROTBL (VEGTYP)
+ SNUP = SNUPTBL (VEGTYP)
+ RSMIN = RSTBL (VEGTYP)
+ RGL = RGLTBL (VEGTYP)
+ HS = HSTBL (VEGTYP)
+ EMISSMIN = EMISSMINTBL (VEGTYP)
+ EMISSMAX = EMISSMAXTBL (VEGTYP)
+ LAIMIN = LAIMINTBL (VEGTYP)
+ LAIMAX = LAIMAXTBL (VEGTYP)
+ Z0MIN = Z0MINTBL (VEGTYP)
+ Z0MAX = Z0MAXTBL (VEGTYP)
+ ALBEDOMIN = ALBEDOMINTBL (VEGTYP)
+ ALBEDOMAX = ALBEDOMAXTBL (VEGTYP)
+
+ IF (VEGTYP .eq. BARE) SHDFAC = 0.0
+ IF (NROOT .gt. NSOIL) THEN
+ WRITE (err_message,*) 'Error: too many root layers ', &
+ NSOIL,NROOT
+! CALL wrf_error_fatal ( err_message )
+! ----------------------------------------------------------------------
+! CALCULATE ROOT DISTRIBUTION. PRESENT VERSION ASSUMES UNIFORM
+! DISTRIBUTION BASED ON SOIL LAYER DEPTHS.
+! ----------------------------------------------------------------------
+ END IF
+ DO I = 1,NROOT
+ RTDIS (I) = - SLDPTH (I)/ ZSOIL (NROOT)
+! ----------------------------------------------------------------------
+! SET-UP SLOPE PARAMETER
+! ----------------------------------------------------------------------
+ END DO
+
+! print*,'end of PRMRED'
+! print*,'VEGTYP',VEGTYP,'SOILTYP',SOILTYP,'SLOPETYP',SLOPETYP, &
+! & 'CFACTR',CFACTR,'CMCMAX',CMCMAX,'RSMAX',RSMAX,'TOPT',TOPT, &
+! & 'REFKDT',REFKDT,'KDT',KDT,'SBETA',SBETA, 'SHDFAC',SHDFAC, &
+! & 'RSMIN',RSMIN,'RGL',RGL,'HS',HS,'ZBOT',ZBOT,'FRZX',FRZX, &
+! & 'PSISAT',PSISAT,'SLOPE',SLOPE,'SNUP',SNUP,'SALP',SALP,'BEXP', &
+! & BEXP, &
+! & 'DKSAT',DKSAT,'DWSAT',DWSAT, &
+! & 'SMCMAX',SMCMAX,'SMCWLT',SMCWLT,'SMCREF',SMCREF,'SMCDRY',SMCDRY, &
+! & 'F1',F1,'QUARTZ',QUARTZ,'FXEXP',FXEXP, &
+! & 'RTDIS',RTDIS,'SLDPTH',SLDPTH,'ZSOIL',ZSOIL, 'NROOT',NROOT, &
+! & 'NSOIL',NSOIL,'Z0',Z0,'CZIL',CZIL,'LAI',LAI, &
+! & 'CSOIL',CSOIL,'PTU',PTU, &
+! & 'LOCAL', LOCAL
+
+ END SUBROUTINE REDPRM
+
+ SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NSOIL)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE ROSR12
+! ----------------------------------------------------------------------
+! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW:
+! ### ### ### ### ### ###
+! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # #
+! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # #
+! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) #
+! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) #
+! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) #
+! # . . # # . # = # . #
+! # . . # # . # # . #
+! # . . # # . # # . #
+! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)#
+! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)#
+! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) #
+! ### ### ### ### ### ###
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN) :: NSOIL
+ INTEGER :: K, KK
+
+ REAL, DIMENSION(1:NSOIL), INTENT(IN):: A, B, D
+ REAL, DIMENSION(1:NSOIL),INTENT(INOUT):: C,P,DELTA
+
+! ----------------------------------------------------------------------
+! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER
+! ----------------------------------------------------------------------
+ C (NSOIL) = 0.0
+ P (1) = - C (1) / B (1)
+! ----------------------------------------------------------------------
+! SOLVE THE COEFS FOR THE 1ST SOIL LAYER
+! ----------------------------------------------------------------------
+
+! ----------------------------------------------------------------------
+! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL
+! ----------------------------------------------------------------------
+ DELTA (1) = D (1) / B (1)
+ DO K = 2,NSOIL
+ P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) )
+ DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)&
+ * P (K -1)))
+ END DO
+! ----------------------------------------------------------------------
+! SET P TO DELTA FOR LOWEST SOIL LAYER
+! ----------------------------------------------------------------------
+ P (NSOIL) = DELTA (NSOIL)
+
+! ----------------------------------------------------------------------
+! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL
+! ----------------------------------------------------------------------
+ DO K = 2,NSOIL
+ KK = NSOIL - K + 1
+ P (KK) = P (KK) * P (KK +1) + DELTA (KK)
+ END DO
+! ----------------------------------------------------------------------
+ END SUBROUTINE ROSR12
+! ----------------------------------------------------------------------
+
+
+ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, &
+ TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, &
+ QUARTZ,CSOIL,VEGTYP,ISURBAN)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SHFLX
+! ----------------------------------------------------------------------
+! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL
+! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED
+! ON THE TEMPERATURE.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN) :: ICE, NSOIL, VEGTYP, ISURBAN
+ INTEGER :: I
+
+ REAL, INTENT(IN) :: BEXP,CSOIL,DF1,DT,F1,PSISAT,QUARTZ, &
+ SMCMAX, SMCWLT, TBOT,YY, ZBOT,ZZ1
+ REAL, INTENT(INOUT) :: T1
+ REAL, INTENT(OUT) :: SSOIL
+ REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC
+ REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS
+ REAL, PARAMETER :: T0 = 273.15
+
+! ----------------------------------------------------------------------
+! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN
+! ----------------------------------------------------------------------
+
+! ----------------------------------------------------------------------
+! SEA-ICE CASE, GLACIAL ICE CASE
+! ----------------------------------------------------------------------
+ IF ( ICE /= 0 ) THEN
+
+ CALL HRTICE (RHSTS,STC,TBOT,ICE,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI)
+
+ CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI)
+
+! ----------------------------------------------------------------------
+! LAND-MASS CASE
+! ----------------------------------------------------------------------
+ ELSE
+ CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, &
+ ZBOT,PSISAT,SH2O,DT, &
+ BEXP,F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN)
+
+ CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI)
+ END IF
+ DO I = 1,NSOIL
+ STC (I) = STCF (I)
+ END DO
+
+! ----------------------------------------------------------------------
+! IN THE NO SNOWPACK CASE (VIA ROUTINE NOPAC BRANCH,) UPDATE THE GRND
+! (SKIN) TEMPERATURE HERE IN RESPONSE TO THE UPDATED SOIL TEMPERATURE
+! PROFILE ABOVE. (NOTE: INSPECTION OF ROUTINE SNOPAC SHOWS THAT T1
+! BELOW IS A DUMMY VARIABLE ONLY, AS SKIN TEMPERATURE IS UPDATED
+! DIFFERENTLY IN ROUTINE SNOPAC)
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! CALCULATE SURFACE SOIL HEAT FLUX
+! ----------------------------------------------------------------------
+ T1 = (YY + (ZZ1- 1.0) * STC (1)) / ZZ1
+ SSOIL = DF1 * (STC (1) - T1) / (0.5 * ZSOIL (1))
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SHFLX
+! ----------------------------------------------------------------------
+
+ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, &
+ & SH2O,SLOPE,KDT,FRZFACT, &
+ & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, &
+ & SHDFAC,CMCMAX, &
+ & RUNOFF1,RUNOFF2,RUNOFF3, &
+ & EDIR,EC,ET, &
+ & DRIP)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SMFLX
+! ----------------------------------------------------------------------
+! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER
+! UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH
+! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED.
+! FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND
+! CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN) :: NSOIL
+ INTEGER :: I,K
+
+ REAL, INTENT(IN) :: BEXP, CMCMAX, DKSAT,DWSAT, DT, EC, EDIR, &
+ KDT, PRCP1, SHDFAC, SLOPE, SMCMAX, SMCWLT
+ REAL, INTENT(OUT) :: DRIP, RUNOFF1, RUNOFF2, RUNOFF3
+ REAL, INTENT(INOUT) :: CMC
+ REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET,ZSOIL
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SMC, SH2O
+ REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT, &
+ SICE, SH2OA, SH2OFG
+ REAL :: DUMMY, EXCESS,FRZFACT,PCPDRP,RHSCT,TRHSCT
+ REAL :: FAC2
+ REAL :: FLIMIT
+
+! ----------------------------------------------------------------------
+! EXECUTABLE CODE BEGINS HERE.
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! COMPUTE THE RIGHT HAND SIDE OF THE CANOPY EQN TERM ( RHSCT )
+! ----------------------------------------------------------------------
+ DUMMY = 0.
+
+! ----------------------------------------------------------------------
+! CONVERT RHSCT (A RATE) TO TRHSCT (AN AMOUNT) AND ADD IT TO EXISTING
+! CMC. IF RESULTING AMT EXCEEDS MAX CAPACITY, IT BECOMES DRIP AND WILL
+! FALL TO THE GRND.
+! ----------------------------------------------------------------------
+ RHSCT = SHDFAC * PRCP1- EC
+ DRIP = 0.
+ TRHSCT = DT * RHSCT
+ EXCESS = CMC + TRHSCT
+
+! ----------------------------------------------------------------------
+! PCPDRP IS THE COMBINED PRCP1 AND DRIP (FROM CMC) THAT GOES INTO THE
+! SOIL
+! ----------------------------------------------------------------------
+ IF (EXCESS > CMCMAX) DRIP = EXCESS - CMCMAX
+ PCPDRP = (1. - SHDFAC) * PRCP1+ DRIP / DT
+
+! ----------------------------------------------------------------------
+! STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT and SSTEP
+!
+ DO I = 1,NSOIL
+ SICE (I) = SMC (I) - SH2O (I)
+ END DO
+! ----------------------------------------------------------------------
+! CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE
+! TENDENCY EQUATIONS.
+! IF THE INFILTRATING PRECIP RATE IS NONTRIVIAL,
+! (WE CONSIDER NONTRIVIAL TO BE A PRECIP TOTAL OVER THE TIME STEP
+! EXCEEDING ONE ONE-THOUSANDTH OF THE WATER HOLDING CAPACITY OF
+! THE FIRST SOIL LAYER)
+! THEN CALL THE SRT/SSTEP SUBROUTINE PAIR TWICE IN THE MANNER OF
+! TIME SCHEME "F" (IMPLICIT STATE, AVERAGED COEFFICIENT)
+! OF SECTION 2 OF KALNAY AND KANAMITSU (1988, MWR, VOL 116,
+! PAGES 1945-1958)TO MINIMIZE 2-DELTA-T OSCILLATIONS IN THE
+! SOIL MOISTURE VALUE OF THE TOP SOIL LAYER THAT CAN ARISE BECAUSE
+! OF THE EXTREME NONLINEAR DEPENDENCE OF THE SOIL HYDRAULIC
+! DIFFUSIVITY COEFFICIENT AND THE HYDRAULIC CONDUCTIVITY ON THE
+! SOIL MOISTURE STATE
+! OTHERWISE CALL THE SRT/SSTEP SUBROUTINE PAIR ONCE IN THE MANNER OF
+! TIME SCHEME "D" (IMPLICIT STATE, EXPLICIT COEFFICIENT)
+! OF SECTION 2 OF KALNAY AND KANAMITSU
+! PCPDRP IS UNITS OF KG/M**2/S OR MM/S, ZSOIL IS NEGATIVE DEPTH IN M
+! ----------------------------------------------------------------------
+! According to Dr. Ken Mitchell's suggestion, add the second contraint
+! to remove numerical instability of runoff and soil moisture
+! FLIMIT is a limit value for FAC2
+ FAC2=0.0
+ DO I=1,NSOIL
+ FAC2=MAX(FAC2,SH2O(I)/SMCMAX)
+ ENDDO
+ CALL FAC2MIT(SMCMAX,FLIMIT)
+
+! ----------------------------------------------------------------------
+! FROZEN GROUND VERSION:
+! SMC STATES REPLACED BY SH2O STATES IN SRT SUBR. SH2O & SICE STATES
+! INC&UDED IN SSTEP SUBR. FROZEN GROUND CORRECTION FACTOR, FRZFACT
+! ADDED. ALL WATER BALANCE CALCULATIONS USING UNFROZEN WATER
+! ----------------------------------------------------------------------
+ IF ( ( (PCPDRP * DT) > (0.0001*1000.0* (- ZSOIL (1))* SMCMAX) ) &
+ .OR. (FAC2 > FLIMIT) ) THEN
+ CALL SRT (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, &
+ DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, &
+ RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI)
+ CALL SSTEP (SH2OFG,SH2O,DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX, &
+ CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI)
+ DO K = 1,NSOIL
+ SH2OA (K) = (SH2O (K) + SH2OFG (K)) * 0.5
+ END DO
+ CALL SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP,ZSOIL, &
+ DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, &
+ RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI)
+ CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, &
+ CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI)
+
+ ELSE
+ CALL SRT (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, &
+ DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, &
+ RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI)
+ CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, &
+ CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI)
+! RUNOF = RUNOFF
+
+ END IF
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SMFLX
+! ----------------------------------------------------------------------
+
+
+ SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SNFRAC
+! ----------------------------------------------------------------------
+! CALCULATE SNOW FRACTION (0 -> 1)
+! SNEQV SNOW WATER EQUIVALENT (M)
+! SNUP THRESHOLD SNEQV DEPTH ABOVE WHICH SNCOVR=1
+! SALP TUNING PARAMETER
+! SNCOVR FRACTIONAL SNOW COVER
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ REAL, INTENT(IN) :: SNEQV,SNUP,SALP,SNOWH
+ REAL, INTENT(OUT) :: SNCOVR
+ REAL :: RSNOW, Z0N
+
+! ----------------------------------------------------------------------
+! SNUP IS VEG-CLASS DEPENDENT SNOWDEPTH THRESHHOLD (SET IN ROUTINE
+! REDPRM) ABOVE WHICH SNOCVR=1.
+! ----------------------------------------------------------------------
+ IF (SNEQV < SNUP) THEN
+ RSNOW = SNEQV / SNUP
+ SNCOVR = 1. - ( EXP ( - SALP * RSNOW) - RSNOW * EXP ( - SALP))
+ ELSE
+ SNCOVR = 1.0
+ END IF
+
+! FORMULATION OF DICKINSON ET AL. 1986
+! Z0N = 0.035
+
+! SNCOVR=SNOWH/(SNOWH + 5*Z0N)
+
+! FORMULATION OF MARSHALL ET AL. 1994
+! SNCOVR=SNEQV/(SNEQV + 2*Z0N)
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SNFRAC
+! ----------------------------------------------------------------------
+
+ SUBROUTINE SNKSRC (TSNSR,TAVG,SMC,SH2O,ZSOIL,NSOIL, &
+ & SMCMAX,PSISAT,BEXP,DT,K,QTOT)
+! ----------------------------------------------------------------------
+! SUBROUTINE SNKSRC
+! ----------------------------------------------------------------------
+! CALCULATE SINK/SOURCE TERM OF THE TERMAL DIFFUSION EQUATION. (SH2O) IS
+! AVAILABLE LIQUED WATER.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN) :: K,NSOIL
+ REAL, INTENT(IN) :: BEXP, DT, PSISAT, QTOT, SMC, SMCMAX, &
+ TAVG
+ REAL, INTENT(INOUT) :: SH2O
+
+ REAL, DIMENSION(1:NSOIL), INTENT(IN):: ZSOIL
+
+ REAL :: DF, DZ, DZH, FREE, TSNSR, &
+ TDN, TM, TUP, TZ, X0, XDN, XH2O, XUP
+
+ REAL, PARAMETER :: DH2O = 1.0000E3, HLICE = 3.3350E5, &
+ T0 = 2.7315E2
+
+ IF (K == 1) THEN
+ DZ = - ZSOIL (1)
+ ELSE
+ DZ = ZSOIL (K -1) - ZSOIL (K)
+ END IF
+! ----------------------------------------------------------------------
+! VIA FUNCTION FRH2O, COMPUTE POTENTIAL OR 'EQUILIBRIUM' UNFROZEN
+! SUPERCOOLED FREE WATER FOR GIVEN SOIL TYPE AND SOIL LAYER TEMPERATURE.
+! FUNCTION FRH20 INVOKES EQN (17) FROM V. KOREN ET AL (1999, JGR, VOL.
+! 104, PG 19573). (ASIDE: LATTER EQN IN JOURNAL IN CENTIGRADE UNITS.
+! ROUTINE FRH2O USE FORM OF EQN IN KELVIN UNITS.)
+! ----------------------------------------------------------------------
+! FREE = FRH2O(TAVG,SMC,SH2O,SMCMAX,BEXP,PSISAT)
+
+! ----------------------------------------------------------------------
+! IN NEXT BLOCK OF CODE, INVOKE EQN 18 OF V. KOREN ET AL (1999, JGR,
+! VOL. 104, PG 19573.) THAT IS, FIRST ESTIMATE THE NEW AMOUNTOF LIQUID
+! WATER, 'XH2O', IMPLIED BY THE SUM OF (1) THE LIQUID WATER AT THE BEGIN
+! OF CURRENT TIME STEP, AND (2) THE FREEZE OF THAW CHANGE IN LIQUID
+! WATER IMPLIED BY THE HEAT FLUX 'QTOT' PASSED IN FROM ROUTINE HRT.
+! SECOND, DETERMINE IF XH2O NEEDS TO BE BOUNDED BY 'FREE' (EQUIL AMT) OR
+! IF 'FREE' NEEDS TO BE BOUNDED BY XH2O.
+! ----------------------------------------------------------------------
+ CALL FRH2O (FREE,TAVG,SMC,SH2O,SMCMAX,BEXP,PSISAT)
+
+! ----------------------------------------------------------------------
+! FIRST, IF FREEZING AND REMAINING LIQUID LESS THAN LOWER BOUND, THEN
+! REDUCE EXTENT OF FREEZING, THEREBY LETTING SOME OR ALL OF HEAT FLUX
+! QTOT COOL THE SOIL TEMP LATER IN ROUTINE HRT.
+! ----------------------------------------------------------------------
+ XH2O = SH2O + QTOT * DT / (DH2O * HLICE * DZ)
+ IF ( XH2O < SH2O .AND. XH2O < FREE) THEN
+ IF ( FREE > SH2O ) THEN
+ XH2O = SH2O
+ ELSE
+ XH2O = FREE
+ END IF
+ END IF
+! ----------------------------------------------------------------------
+! SECOND, IF THAWING AND THE INCREASE IN LIQUID WATER GREATER THAN UPPER
+! BOUND, THEN REDUCE EXTENT OF THAW, THEREBY LETTING SOME OR ALL OF HEAT
+! FLUX QTOT WARM THE SOIL TEMP LATER IN ROUTINE HRT.
+! ----------------------------------------------------------------------
+ IF ( XH2O > SH2O .AND. XH2O > FREE ) THEN
+ IF ( FREE < SH2O ) THEN
+ XH2O = SH2O
+ ELSE
+ XH2O = FREE
+ END IF
+ END IF
+
+! ----------------------------------------------------------------------
+! CALCULATE PHASE-CHANGE HEAT SOURCE/SINK TERM FOR USE IN ROUTINE HRT
+! AND UPDATE LIQUID WATER TO REFLCET FINAL FREEZE/THAW INCREMENT.
+! ----------------------------------------------------------------------
+! SNKSRC = -DH2O*HLICE*DZ*(XH2O-SH2O)/DT
+ IF (XH2O < 0.) XH2O = 0.
+ IF (XH2O > SMC) XH2O = SMC
+ TSNSR = - DH2O * HLICE * DZ * (XH2O - SH2O)/ DT
+ SH2O = XH2O
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SNKSRC
+! ----------------------------------------------------------------------
+
+ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, &
+ SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, &
+ SBETA,DF1, &
+ Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA,&
+ SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,ESD,SNDENS,&
+ SNOWH,SH2O,SLOPE,KDT,FRZFACT,PSISAT, &
+ ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, &
+ RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, &
+ ICE,RTDIS,QUARTZ,FXEXP,CSOIL, &
+ BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW,ETNS,EMISSI,&
+ RIBB,SOLDN, &
+ ISURBAN, &
+
+ VEGTYP)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SNOPAC
+! ----------------------------------------------------------------------
+! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE
+! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS
+! PRESENT.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN) :: ICE, NROOT, NSOIL,VEGTYP
+ INTEGER, INTENT(IN) :: ISURBAN
+ INTEGER :: K
+!
+! kmh 09/03/2006 add IT16 for surface temperature iteration
+!
+ INTEGER :: IT16
+ LOGICAL, INTENT(IN) :: SNOWNG
+ REAL, INTENT(IN) :: BEXP,CFACTR, CMCMAX,CSOIL,DF1,DKSAT, &
+ DT,DWSAT, EPSCA,FDOWN,F1,FXEXP, &
+ FRZFACT,KDT,PC, PRCP,PSISAT,Q2,QUARTZ, &
+ RCH,RR,SBETA,SFCPRS, SFCTMP, SHDFAC, &
+ SLOPE,SMCDRY,SMCMAX,SMCREF,SMCWLT, T24, &
+ TBOT,TH2,ZBOT,EMISSI,SOLDN
+ REAL, INTENT(INOUT) :: CMC, BETA, ESD,FLX2,PRCPF,SNOWH,SNCOVR, &
+ SNDENS, T1, RIBB, ETP
+ REAL, INTENT(OUT) :: DEW,DRIP,EC,EDIR, ETNS, ESNOW,ETT, &
+ FLX1,FLX3, RUNOFF1,RUNOFF2,RUNOFF3, &
+ SSOIL,SNOMLT
+ REAL, DIMENSION(1:NSOIL),INTENT(IN) :: RTDIS,ZSOIL
+ REAL, DIMENSION(1:NSOIL),INTENT(OUT) :: ET
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC,SH2O,STC
+ REAL, DIMENSION(1:NSOIL) :: ET1
+ REAL :: DENOM,DSOIL,DTOT,EC1,EDIR1,ESDFLX,ETA, &
+ ETT1, ESNOW1, ESNOW2, ETA1,ETP1,ETP2, &
+ ETP3, ETNS1, ETANRG, ETAX, EX, FLX3X, &
+ FRCSNO,FRCSOI, PRCP1, QSAT,RSNOW, SEH, &
+ SNCOND,SSOIL1, T11,T12, T12A, T12AX, &
+ T12B, T14, YY, ZZ1
+! T12B, T14, YY, ZZ1,EMISSI_S
+!
+! kmh 01/11/2007 add T15, T16, and DTOT2 for SFC T iteration and snow heat flux
+!
+ REAL :: T15, T16, DTOT2
+ REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, &
+ LSUBS = 2.83E+6, TFREEZ = 273.15, &
+ SNOEXP = 2.0
+
+! ----------------------------------------------------------------------
+! EXECUTABLE CODE BEGINS HERE:
+! ----------------------------------------------------------------------
+! IF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), SNOWCOVER FRACTION = 1.0,
+! AND SUBLIMATION IS AT THE POTENTIAL RATE.
+! FOR NON-GLACIAL LAND (ICE=0), IF SNOWCOVER FRACTION < 1.0, TOTAL
+! EVAPORATION < POTENTIAL DUE TO NON-POTENTIAL CONTRIBUTION FROM
+! NON-SNOW COVERED FRACTION.
+! ----------------------------------------------------------------------
+! INITIALIZE EVAP TERMS.
+! ----------------------------------------------------------------------
+! conversions:
+! ESNOW [KG M-2 S-1]
+! ESDFLX [KG M-2 S-1] .le. ESNOW
+! ESNOW1 [M S-1]
+! ESNOW2 [M]
+! ETP [KG M-2 S-1]
+! ETP1 [M S-1]
+! ETP2 [M]
+! ----------------------------------------------------------------------
+ DEW = 0.
+ EDIR = 0.
+ EDIR1 = 0.
+ EC1 = 0.
+ EC = 0.
+! EMISSI_S=0.95 ! For snow
+
+ DO K = 1,NSOIL
+ ET (K) = 0.
+ ET1 (K) = 0.
+ END DO
+ ETT = 0.
+ ETT1 = 0.
+ ETNS = 0.
+ ETNS1 = 0.
+ ESNOW = 0.
+ ESNOW1 = 0.
+ ESNOW2 = 0.
+
+! ----------------------------------------------------------------------
+! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO ETP1 IN M S-1
+! ----------------------------------------------------------------------
+ PRCP1 = PRCPF *0.001
+! ----------------------------------------------------------------------
+! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE).
+! ----------------------------------------------------------------------
+ BETA = 1.0
+ IF (ETP <= 0.0) THEN
+ IF ( ( RIBB >= 0.1 ) .AND. ( FDOWN > 150.0 ) ) THEN
+ ETP=(MIN(ETP*(1.0-RIBB),0.)*SNCOVR/0.980 + ETP*(0.980-SNCOVR))/0.980
+ ENDIF
+ IF(ETP == 0.) BETA = 0.0
+ ETP1 = ETP * 0.001
+ DEW = -ETP1
+ ESNOW2 = ETP1*DT
+ ETANRG = ETP*((1.-SNCOVR)*LSUBC + SNCOVR*LSUBS)
+ ELSE
+ ETP1 = ETP * 0.001
+ IF ( ICE /= 0 ) THEN
+ ! SEA-ICE AND GLACIAL-ICE CASE
+ ESNOW = ETP
+ ESNOW1 = ESNOW*0.001
+ ESNOW2 = ESNOW1*DT
+ ETANRG = ESNOW*LSUBS
+ ELSE IF ( ICE == 0) THEN
+ ! NON-GLACIAL LAND CASE
+ IF (SNCOVR < 1.) THEN
+ CALL EVAPO (ETNS1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, &
+ SH2O, &
+ SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, &
+ SMCREF,SHDFAC,CMCMAX, &
+ SMCDRY,CFACTR, &
+ EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS, &
+ FXEXP)
+! ----------------------------------------------------------------------------
+ EDIR1 = EDIR1* (1. - SNCOVR)
+ EC1 = EC1* (1. - SNCOVR)
+ DO K = 1,NSOIL
+ ET1 (K) = ET1 (K)* (1. - SNCOVR)
+ END DO
+ ETT1 = ETT1*(1.-SNCOVR)
+! ETNS1 = EDIR1+ EC1+ ETT1
+ ETNS1 = ETNS1*(1.-SNCOVR)
+! ----------------------------------------------------------------------------
+ EDIR = EDIR1*1000.
+ EC = EC1*1000.
+ DO K = 1,NSOIL
+ ET (K) = ET1 (K)*1000.
+ END DO
+ ETT = ETT1*1000.
+ ETNS = ETNS1*1000.
+! ----------------------------------------------------------------------
+
+! end IF (SNCOVR .lt. 1.)
+ END IF
+! end IF (ICE .ne. 1)
+ END IF
+ ESNOW = ETP*SNCOVR
+ ESNOW1 = ESNOW*0.001
+ ESNOW2 = ESNOW1*DT
+ ETANRG = ESNOW*LSUBS + ETNS*LSUBC
+! end IF (ETP .le. 0.0)
+ END IF
+
+! ----------------------------------------------------------------------
+! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY
+! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR
+! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE
+! SNOWFALL STRIKING THE GROUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP).
+! ----------------------------------------------------------------------
+ FLX1 = 0.0
+ IF (SNOWNG) THEN
+ FLX1 = CPICE * PRCP * (T1- SFCTMP)
+ ELSE
+ IF (PRCP > 0.0) FLX1 = CPH2O * PRCP * (T1- SFCTMP)
+! ----------------------------------------------------------------------
+! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES
+! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION.
+! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT)
+! FLUXES. FLX1 FROM ABOVE, FLX2 BROUGHT IN VIA COMMOM BLOCK RITE.
+! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN
+! PENMAN.
+! ----------------------------------------------------------------------
+ END IF
+ DSOIL = - (0.5 * ZSOIL (1))
+ DTOT = SNOWH + DSOIL
+ DENOM = 1.0+ DF1 / (DTOT * RR * RCH)
+! surface emissivity weighted by snow cover fraction
+! T12A = ( (FDOWN - FLX1 - FLX2 - &
+! & ((SNCOVR*EMISSI_S)+EMISSI*(1.0-SNCOVR))*SIGMA *T24)/RCH &
+! & + TH2 - SFCTMP - ETANRG/RCH ) / RR
+ T12A = ( (FDOWN - FLX1- FLX2- EMISSI * SIGMA * T24)/ RCH &
+ + TH2- SFCTMP - ETANRG / RCH ) / RR
+
+ T12B = DF1 * STC (1) / (DTOT * RR * RCH)
+
+! ----------------------------------------------------------------------
+! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW
+! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE
+! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK,
+! DEPENDING ON SIGN OF ETP.
+! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1)
+! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE'
+! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT
+! TO ZERO.
+! ----------------------------------------------------------------------
+! SUB-FREEZING BLOCK
+! ----------------------------------------------------------------------
+ T12 = (SFCTMP + T12A + T12B) / DENOM
+ IF (T12 <= TFREEZ) THEN
+ T1 = T12
+ SSOIL = DF1 * (T1- STC (1)) / DTOT
+! ESD = MAX (0.0, ESD- ETP2)
+ ESD = MAX(0.0, ESD-ESNOW2)
+ FLX3 = 0.0
+ EX = 0.0
+
+ SNOMLT = 0.0
+! ----------------------------------------------------------------------
+! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT
+! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE
+! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD
+! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT
+! RELEASED, FLX3. SET THE EFFECTIVE PRECIP, PRCP1 TO THE SNOW MELT RATE,
+! EX FOR USE IN SMFLX. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES.
+! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION
+! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING
+! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN
+! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP.
+! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1)
+! ----------------------------------------------------------------------
+! ABOVE FREEZING BLOCK
+! ----------------------------------------------------------------------
+ ELSE
+ T1 = TFREEZ * SNCOVR ** SNOEXP + T12 * (1.0- SNCOVR ** SNOEXP)
+ BETA = 1.0
+
+! ----------------------------------------------------------------------
+! IF POTENTIAL EVAP (SUBLIMATION) GREATER THAN DEPTH OF SNOWPACK.
+! BETA<1
+! SNOWPACK HAS SUBLIMATED AWAY, SET DEPTH TO ZERO.
+! ----------------------------------------------------------------------
+ IF ( ICE /= 0 ) then
+ ! kmh 12/15/2005 modify SSOIL
+ ! kmh 09/03/2006 modify DTOT
+ IF ( DTOT .GT. 2.0*DSOIL ) THEN
+ DTOT = 2.0*DSOIL
+ ENDIF
+ ENDIF
+ SSOIL = DF1 * (T1- STC (1)) / DTOT
+ IF (ESD-ESNOW2 <= ESDMIN) THEN
+ ESD = 0.0
+ EX = 0.0
+ SNOMLT = 0.0
+ FLX3 = 0.0
+! ----------------------------------------------------------------------
+! SUBLIMATION LESS THAN DEPTH OF SNOWPACK
+! SNOWPACK (ESD) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW)
+! ----------------------------------------------------------------------
+ ELSE
+ ESD = ESD-ESNOW2
+ ETP3 = ETP * LSUBC
+ SEH = RCH * (T1- TH2)
+ T14 = T1* T1
+ T14 = T14* T14
+! FLX3 = FDOWN - FLX1 - FLX2 - &
+! ((SNCOVR*EMISSI_S)+EMISSI*(1-SNCOVR))*SIGMA*T14 - &
+! SSOIL - SEH - ETANRG
+ FLX3 = FDOWN - FLX1- FLX2- EMISSI*SIGMA * T14- SSOIL - SEH - ETANRG
+ IF (FLX3 <= 0.0) FLX3 = 0.0
+! ----------------------------------------------------------------------
+! SNOWMELT REDUCTION DEPENDING ON SNOW COVER
+! ----------------------------------------------------------------------
+ EX = FLX3*0.001/ LSUBF
+
+! ----------------------------------------------------------------------
+! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE
+! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT.
+! ----------------------------------------------------------------------
+ SNOMLT = EX * DT
+ IF (ESD- SNOMLT >= ESDMIN) THEN
+ ESD = ESD- SNOMLT
+! ----------------------------------------------------------------------
+! SNOWMELT EXCEEDS SNOW DEPTH
+! ----------------------------------------------------------------------
+ ELSE
+ EX = ESD / DT
+ FLX3 = EX *1000.0* LSUBF
+ SNOMLT = ESD
+
+ ESD = 0.0
+! ----------------------------------------------------------------------
+! END OF 'ESD .LE. ETP2' IF-BLOCK
+! ----------------------------------------------------------------------
+ END IF
+ END IF
+
+! ----------------------------------------------------------------------
+! END OF 'T12 .LE. TFREEZ' IF-BLOCK
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! IF NON-GLACIAL LAND, ADD SNOWMELT RATE (EX) TO PRECIP RATE TO BE USED
+! IN SUBROUTINE SMFLX (SOIL MOISTURE EVOLUTION) VIA INFILTRATION.
+!
+! FOR SEA-ICE AND GLACIAL-ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE
+! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO
+! SUBROUTINE SNOPAC)
+! ----------------------------------------------------------------------
+ IF (ICE == 0) PRCP1 = PRCP1+ EX
+
+! ----------------------------------------------------------------------
+! SET THE EFFECTIVE POTNL EVAPOTRANSP (ETP1) TO ZERO SINCE THIS IS SNOW
+! CASE, SO SURFACE EVAP NOT CALCULATED FROM EDIR, EC, OR ETT IN SMFLX
+! (BELOW).
+! IF SEAICE (ICE==1) SKIP CALL TO SMFLX.
+! SMFLX RETURNS UPDATED SOIL MOISTURE VALUES FOR NON-GLACIAL LAND.
+! IF SEA-ICE (ICE==1) OR GLACIAL-ICE (ICE==-1), SKIP CALL TO SMFLX,
+! SINCE NO SOIL MEDIUM FOR SEA-ICE OR GLACIAL-ICE.
+! ----------------------------------------------------------------------
+ END IF
+ IF (ICE == 0) THEN
+ CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, &
+ SH2O,SLOPE,KDT,FRZFACT, &
+ SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, &
+ SHDFAC,CMCMAX, &
+ RUNOFF1,RUNOFF2,RUNOFF3, &
+ EDIR1,EC1,ET1, &
+ DRIP)
+! ----------------------------------------------------------------------
+! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO
+! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX
+! MATCHES THAT ALREADY COMPUTER FOR BELOW THE SNOWPACK, THUS THE SFC
+! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE
+! SNOW TOP SURFACE. T11 IS A DUMMY ARGUEMENT SO WE WILL NOT USE THE
+! SKIN TEMP VALUE AS REVISED BY SHFLX.
+! ----------------------------------------------------------------------
+ END IF
+ ZZ1 = 1.0
+ YY = STC (1) -0.5* SSOIL * ZSOIL (1)* ZZ1/ DF1
+
+! ----------------------------------------------------------------------
+! SHFLX WILL CALC/UPDATE THE SOIL TEMPS. NOTE: THE SUB-SFC HEAT FLUX
+! (SSOIL1) AND THE SKIN TEMP (T11) OUTPUT FROM THIS SHFLX CALL ARE NOT
+! USED IN ANY SUBSEQUENT CALCULATIONS. RATHER, THEY ARE DUMMY VARIABLES
+! HERE IN THE SNOPAC CASE, SINCE THE SKIN TEMP AND SUB-SFC HEAT FLUX ARE
+! UPDATED INSTEAD NEAR THE BEGINNING OF THE CALL TO SNOPAC.
+! ----------------------------------------------------------------------
+ T11 = T1
+ CALL SHFLX (SSOIL1,STC,SMC,SMCMAX,NSOIL,T11,DT,YY,ZZ1,ZSOIL, &
+ TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, &
+ QUARTZ,CSOIL,VEGTYP,ISURBAN)
+
+! ----------------------------------------------------------------------
+! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS
+! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN.
+! ----------------------------------------------------------------------
+ IF (ICE == 0) THEN
+ ! NON-GLACIAL LAND
+ IF (ESD > 0.) THEN
+ CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY)
+ ELSE
+ ESD = 0.
+ SNOWH = 0.
+ SNDENS = 0.
+ SNCOND = 1.
+ SNCOVR = 0.
+ END IF
+ ELSEIF (ICE == 1) THEN
+ ! SEA-ICE
+ IF (ESD .GE. 0.01) THEN
+ CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY)
+ ELSE
+ ESD = 0.01
+ SNOWH = 0.05
+ !KWM???? SNDENS =
+ !KWM???? SNCOND =
+ SNCOVR = 1.0
+ ENDIF
+ ELSEIF (ICE == -1) THEN
+ ! GLACIAL-ICE
+ IF (ESD .GE. 0.10) THEN
+ CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY)
+ ELSE
+ ESD = 0.10
+ SNOWH = 0.50
+ !KWM???? SNDENS =
+ !KWM???? SNCOND =
+ SNCOVR = 1.0
+ ENDIF
+ ENDIF
+! ----------------------------------------------------------------------
+ END SUBROUTINE SNOPAC
+! ----------------------------------------------------------------------
+
+
+ SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SNOWPACK
+! ----------------------------------------------------------------------
+! CALCULATE COMPACTION OF SNOWPACK UNDER CONDITIONS OF INCREASING SNOW
+! DENSITY, AS OBTAINED FROM AN APPROXIMATE SOLUTION OF E. ANDERSON'S
+! DIFFERENTIAL EQUATION (3.29), NOAA TECHNICAL REPORT NWS 19, BY VICTOR
+! KOREN, 03/25/95.
+! ----------------------------------------------------------------------
+! ESD WATER EQUIVALENT OF SNOW (M)
+! DTSEC TIME STEP (SEC)
+! SNOWH SNOW DEPTH (M)
+! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY)
+! TSNOW SNOW SURFACE TEMPERATURE (K)
+! TSOIL SOIL SURFACE TEMPERATURE (K)
+
+! SUBROUTINE WILL RETURN NEW VALUES OF SNOWH AND SNDENS
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER :: IPOL, J
+ REAL, INTENT(IN) :: ESD, DTSEC,TSNOW,TSOIL
+ REAL, INTENT(INOUT) :: SNOWH, SNDENS
+ REAL :: BFAC,DSX,DTHR,DW,SNOWHC,PEXP, &
+ TAVGC,TSNOWC,TSOILC,ESDC,ESDCX
+ REAL, PARAMETER :: C1 = 0.01, C2 = 21.0, G = 9.81, &
+ KN = 4000.0
+! ----------------------------------------------------------------------
+! CONVERSION INTO SIMULATION UNITS
+! ----------------------------------------------------------------------
+ SNOWHC = SNOWH *100.
+ ESDC = ESD *100.
+ DTHR = DTSEC /3600.
+ TSNOWC = TSNOW -273.15
+ TSOILC = TSOIL -273.15
+
+! ----------------------------------------------------------------------
+! CALCULATING OF AVERAGE TEMPERATURE OF SNOW PACK
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! CALCULATING OF SNOW DEPTH AND DENSITY AS A RESULT OF COMPACTION
+! SNDENS=DS0*(EXP(BFAC*ESD)-1.)/(BFAC*ESD)
+! BFAC=DTHR*C1*EXP(0.08*TAVGC-C2*DS0)
+! NOTE: BFAC*ESD IN SNDENS EQN ABOVE HAS TO BE CAREFULLY TREATED
+! NUMERICALLY BELOW:
+! C1 IS THE FRACTIONAL INCREASE IN DENSITY (1/(CM*HR))
+! C2 IS A CONSTANT (CM3/G) KOJIMA ESTIMATED AS 21 CMS/G
+! ----------------------------------------------------------------------
+ TAVGC = 0.5* (TSNOWC + TSOILC)
+ IF (ESDC > 1.E-2) THEN
+ ESDCX = ESDC
+ ELSE
+ ESDCX = 1.E-2
+ END IF
+
+! DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC))
+! ----------------------------------------------------------------------
+! THE FUNCTION OF THE FORM (e**x-1)/x IMBEDDED IN ABOVE EXPRESSION
+! FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x"
+! (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT
+! THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS
+! "x" APPROACHES ZERO), HENCE BELOW WE REPLACE THE (e**x-1)/x
+! EXPRESSION WITH AN EQUIVALENT, NUMERICALLY WELL-BEHAVED
+! POLYNOMIAL EXPANSION.
+
+! NUMBER OF TERMS OF POLYNOMIAL EXPANSION, AND HENCE ITS ACCURACY,
+! IS GOVERNED BY ITERATION LIMIT "IPOL".
+! IPOL GREATER THAN 9 ONLY MAKES A DIFFERENCE ON DOUBLE
+! PRECISION (RELATIVE ERRORS GIVEN IN PERCENT %).
+! IPOL=9, FOR REL.ERROR <~ 1.6 E-6 % (8 SIGNIFICANT DIGITS)
+! IPOL=8, FOR REL.ERROR <~ 1.8 E-5 % (7 SIGNIFICANT DIGITS)
+! IPOL=7, FOR REL.ERROR <~ 1.8 E-4 % ...
+! ----------------------------------------------------------------------
+ BFAC = DTHR * C1* EXP (0.08* TAVGC - C2* SNDENS)
+ IPOL = 4
+ PEXP = 0.
+! PEXP = (1. + PEXP)*BFAC*ESDC/REAL(J+1)
+ DO J = IPOL,1, -1
+ PEXP = (1. + PEXP)* BFAC * ESDCX / REAL (J +1)
+ END DO
+
+ PEXP = PEXP + 1.
+! ----------------------------------------------------------------------
+! ABOVE LINE ENDS POLYNOMIAL SUBSTITUTION
+! ----------------------------------------------------------------------
+! END OF KOREAN FORMULATION
+
+! BASE FORMULATION (COGLEY ET AL., 1990)
+! CONVERT DENSITY FROM G/CM3 TO KG/M3
+! DSM=SNDENS*1000.0
+
+! DSX=DSM+DTSEC*0.5*DSM*G*ESD/
+! & (1E7*EXP(-0.02*DSM+KN/(TAVGC+273.16)-14.643))
+
+! & CONVERT DENSITY FROM KG/M3 TO G/CM3
+! DSX=DSX/1000.0
+
+! END OF COGLEY ET AL. FORMULATION
+
+! ----------------------------------------------------------------------
+! SET UPPER/LOWER LIMIT ON SNOW DENSITY
+! ----------------------------------------------------------------------
+ DSX = SNDENS * (PEXP)
+ IF (DSX > 0.40) DSX = 0.40
+ IF (DSX < 0.05) DSX = 0.05
+! ----------------------------------------------------------------------
+! UPDATE OF SNOW DEPTH AND DENSITY DEPENDING ON LIQUID WATER DURING
+! SNOWMELT. ASSUMED THAT 13% OF LIQUID WATER CAN BE STORED IN SNOW PER
+! DAY DURING SNOWMELT TILL SNOW DENSITY 0.40.
+! ----------------------------------------------------------------------
+ SNDENS = DSX
+ IF (TSNOWC >= 0.) THEN
+ DW = 0.13* DTHR /24.
+ SNDENS = SNDENS * (1. - DW) + DW
+ IF (SNDENS >= 0.40) SNDENS = 0.40
+! ----------------------------------------------------------------------
+! CALCULATE SNOW DEPTH (CM) FROM SNOW WATER EQUIVALENT AND SNOW DENSITY.
+! CHANGE SNOW DEPTH UNITS TO METERS
+! ----------------------------------------------------------------------
+ END IF
+ SNOWHC = ESDC / SNDENS
+ SNOWH = SNOWHC *0.01
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SNOWPACK
+! ----------------------------------------------------------------------
+
+ SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD, SNOWH)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SNOWZ0
+! ----------------------------------------------------------------------
+! CALCULATE TOTAL ROUGHNESS LENGTH OVER SNOW
+! SNCOVR FRACTIONAL SNOW COVER
+! Z0 ROUGHNESS LENGTH (m)
+! Z0S SNOW ROUGHNESS LENGTH:=0.001 (m)
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ REAL, INTENT(IN) :: SNCOVR, Z0BRD
+ REAL, INTENT(OUT) :: Z0
+ REAL, PARAMETER :: Z0S=0.001
+ REAL, INTENT(IN) :: SNOWH
+ REAL :: BURIAL
+ REAL :: Z0EFF
+
+!m Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0S
+ BURIAL = 7.0*Z0BRD - SNOWH
+ IF(BURIAL.LE.0.0007) THEN
+ Z0EFF = Z0S
+ ELSE
+ Z0EFF = BURIAL/7.0
+ ENDIF
+
+ Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0EFF
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SNOWZ0
+! ----------------------------------------------------------------------
+
+
+ SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SNOW_NEW
+! ----------------------------------------------------------------------
+! CALCULATE SNOW DEPTH AND DENSITITY TO ACCOUNT FOR THE NEW SNOWFALL.
+! NEW VALUES OF SNOW DEPTH & DENSITY RETURNED.
+
+! TEMP AIR TEMPERATURE (K)
+! NEWSN NEW SNOWFALL (M)
+! SNOWH SNOW DEPTH (M)
+! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY)
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ REAL, INTENT(IN) :: NEWSN, TEMP
+ REAL, INTENT(INOUT) :: SNDENS, SNOWH
+ REAL :: DSNEW, HNEWC, SNOWHC,NEWSNC,TEMPC
+
+! ----------------------------------------------------------------------
+! CONVERSION INTO SIMULATION UNITS
+! ----------------------------------------------------------------------
+ SNOWHC = SNOWH *100.
+ NEWSNC = NEWSN *100.
+
+! ----------------------------------------------------------------------
+! CALCULATING NEW SNOWFALL DENSITY DEPENDING ON TEMPERATURE
+! EQUATION FROM GOTTLIB L. 'A GENERAL RUNOFF MODEL FOR SNOWCOVERED
+! AND GLACIERIZED BASIN', 6TH NORDIC HYDROLOGICAL CONFERENCE,
+! VEMADOLEN, SWEDEN, 1980, 172-177PP.
+!-----------------------------------------------------------------------
+ TEMPC = TEMP -273.15
+ IF (TEMPC <= -15.) THEN
+ DSNEW = 0.05
+ ELSE
+ DSNEW = 0.05+0.0017* (TEMPC +15.)**1.5
+ END IF
+! ----------------------------------------------------------------------
+! ADJUSTMENT OF SNOW DENSITY DEPENDING ON NEW SNOWFALL
+! ----------------------------------------------------------------------
+ HNEWC = NEWSNC / DSNEW
+ IF (SNOWHC + HNEWC .LT. 1.0E-3) THEN
+ SNDENS = MAX(DSNEW,SNDENS)
+ ELSE
+ SNDENS = (SNOWHC * SNDENS + HNEWC * DSNEW)/ (SNOWHC + HNEWC)
+ ENDIF
+ SNOWHC = SNOWHC + HNEWC
+ SNOWH = SNOWHC *0.01
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SNOW_NEW
+! ----------------------------------------------------------------------
+
+ SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, &
+ ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, &
+ RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SRT
+! ----------------------------------------------------------------------
+! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL
+! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX
+! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: NSOIL
+ INTEGER :: IALP1, IOHINF, J, JJ, K, KS
+ REAL, INTENT(IN) :: BEXP, DKSAT, DT, DWSAT, EDIR, FRZX, &
+ KDT, PCPDRP, SLOPE, SMCMAX, SMCWLT
+ REAL, INTENT(OUT) :: RUNOFF1, RUNOFF2
+ REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET, SH2O, SH2OA, SICE, &
+ ZSOIL
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI, CI
+ REAL, DIMENSION(1:NSOIL) :: DMAX
+ REAL :: ACRT, DD, DDT, DDZ, DDZ2, DENOM, &
+ DENOM2,DICE, DSMDZ, DSMDZ2, DT1, &
+ FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, &
+ PX, SICEMAX,SLOPX, SMCAV, SSTT, &
+ SUM, VAL, WCND, WCND2, WDF, WDF2
+ INTEGER, PARAMETER :: CVFRZ = 3
+
+! ----------------------------------------------------------------------
+! FROZEN GROUND VERSION:
+! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF
+! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV.
+! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED
+! ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE
+! TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS
+! WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}).
+! CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3
+! ----------------------------------------------------------------------
+
+! ----------------------------------------------------------------------
+! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE
+! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL.
+! MODIFIED BY Q DUAN
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL
+! LAYERS.
+! ----------------------------------------------------------------------
+ IOHINF = 1
+ SICEMAX = 0.0
+ DO KS = 1,NSOIL
+ IF (SICE (KS) > SICEMAX) SICEMAX = SICE (KS)
+! ----------------------------------------------------------------------
+! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF
+! ----------------------------------------------------------------------
+ END DO
+ PDDUM = PCPDRP
+ RUNOFF1 = 0.0
+
+! ----------------------------------------------------------------------
+! MODIFIED BY Q. DUAN, 5/16/94
+! ----------------------------------------------------------------------
+! IF (IOHINF == 1) THEN
+
+ IF (PCPDRP /= 0.0) THEN
+ DT1 = DT /86400.
+ SMCAV = SMCMAX - SMCWLT
+
+! ----------------------------------------------------------------------
+! FROZEN GROUND VERSION:
+! ----------------------------------------------------------------------
+ DMAX (1)= - ZSOIL (1)* SMCAV
+
+ DICE = - ZSOIL (1) * SICE (1)
+ DMAX (1)= DMAX (1)* (1.0- (SH2OA (1) + SICE (1) - SMCWLT)/ &
+ SMCAV)
+
+ DD = DMAX (1)
+
+! ----------------------------------------------------------------------
+! FROZEN GROUND VERSION:
+! ----------------------------------------------------------------------
+ DO KS = 2,NSOIL
+
+ DICE = DICE+ ( ZSOIL (KS -1) - ZSOIL (KS) ) * SICE (KS)
+ DMAX (KS) = (ZSOIL (KS -1) - ZSOIL (KS))* SMCAV
+ DMAX (KS) = DMAX (KS)* (1.0- (SH2OA (KS) + SICE (KS) &
+ - SMCWLT)/ SMCAV)
+ DD = DD+ DMAX (KS)
+! ----------------------------------------------------------------------
+! VAL = (1.-EXP(-KDT*SQRT(DT1)))
+! IN BELOW, REMOVE THE SQRT IN ABOVE
+! ----------------------------------------------------------------------
+ END DO
+ VAL = (1. - EXP ( - KDT * DT1))
+ DDT = DD * VAL
+ PX = PCPDRP * DT
+ IF (PX < 0.0) PX = 0.0
+
+! ----------------------------------------------------------------------
+! FROZEN GROUND VERSION:
+! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS
+! ----------------------------------------------------------------------
+ INFMAX = (PX * (DDT / (PX + DDT)))/ DT
+ FCR = 1.
+ IF (DICE > 1.E-2) THEN
+ ACRT = CVFRZ * FRZX / DICE
+ SUM = 1.
+ IALP1 = CVFRZ - 1
+ DO J = 1,IALP1
+ K = 1
+ DO JJ = J +1,IALP1
+ K = K * JJ
+ END DO
+ SUM = SUM + (ACRT ** ( CVFRZ - J)) / FLOAT (K)
+ END DO
+ FCR = 1. - EXP ( - ACRT) * SUM
+ END IF
+
+! ----------------------------------------------------------------------
+! CORRECTION OF INFILTRATION LIMITATION:
+! IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF
+! HYDROLIC CONDUCTIVITY
+! ----------------------------------------------------------------------
+! MXSMC = MAX ( SH2OA(1), SH2OA(2) )
+ INFMAX = INFMAX * FCR
+
+ MXSMC = SH2OA (1)
+ CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, &
+ SICEMAX)
+ INFMAX = MAX (INFMAX,WCND)
+
+ INFMAX = MIN (INFMAX,PX/DT)
+ IF (PCPDRP > INFMAX) THEN
+ RUNOFF1 = PCPDRP - INFMAX
+ PDDUM = INFMAX
+ END IF
+! ----------------------------------------------------------------------
+! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE
+! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE:
+! 'MXSMC = MAX(SH2OA(1), SH2OA(2))'
+! ----------------------------------------------------------------------
+ END IF
+
+ MXSMC = SH2OA (1)
+ CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, &
+ SICEMAX)
+! ----------------------------------------------------------------------
+! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER
+! ----------------------------------------------------------------------
+ DDZ = 1. / ( - .5 * ZSOIL (2) )
+ AI (1) = 0.0
+ BI (1) = WDF * DDZ / ( - ZSOIL (1) )
+
+! ----------------------------------------------------------------------
+! CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE
+! GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS.
+! ----------------------------------------------------------------------
+ CI (1) = - BI (1)
+ DSMDZ = ( SH2O (1) - SH2O (2) ) / ( - .5 * ZSOIL (2) )
+ RHSTT (1) = (WDF * DSMDZ + WCND- PDDUM + EDIR + ET (1))/ ZSOIL (1)
+
+! ----------------------------------------------------------------------
+! INITIALIZE DDZ2
+! ----------------------------------------------------------------------
+ SSTT = WDF * DSMDZ + WCND+ EDIR + ET (1)
+
+! ----------------------------------------------------------------------
+! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS
+! ----------------------------------------------------------------------
+ DDZ2 = 0.0
+ DO K = 2,NSOIL
+ DENOM2 = (ZSOIL (K -1) - ZSOIL (K))
+ IF (K /= NSOIL) THEN
+
+! ----------------------------------------------------------------------
+! AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN
+! LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE:
+! 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))'
+! ----------------------------------------------------------------------
+ SLOPX = 1.
+
+ MXSMC2 = SH2OA (K)
+ CALL WDFCND (WDF2,WCND2,MXSMC2,SMCMAX,BEXP,DKSAT,DWSAT, &
+ SICEMAX)
+! -----------------------------------------------------------------------
+! CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT
+! ----------------------------------------------------------------------
+ DENOM = (ZSOIL (K -1) - ZSOIL (K +1))
+
+! ----------------------------------------------------------------------
+! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT
+! ----------------------------------------------------------------------
+ DSMDZ2 = (SH2O (K) - SH2O (K +1)) / (DENOM * 0.5)
+ DDZ2 = 2.0 / DENOM
+ CI (K) = - WDF2 * DDZ2 / DENOM2
+
+ ELSE
+! ----------------------------------------------------------------------
+! SLOPE OF BOTTOM LAYER IS INTRODUCED
+! ----------------------------------------------------------------------
+
+! ----------------------------------------------------------------------
+! RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR
+! THIS LAYER
+! ----------------------------------------------------------------------
+ SLOPX = SLOPE
+ CALL WDFCND (WDF2,WCND2,SH2OA (NSOIL),SMCMAX,BEXP,DKSAT,DWSAT, &
+ SICEMAX)
+
+! ----------------------------------------------------------------------
+! CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT
+! ----------------------------------------------------------------------
+
+! ----------------------------------------------------------------------
+! SET MATRIX COEF CI TO ZERO
+! ----------------------------------------------------------------------
+ DSMDZ2 = 0.0
+ CI (K) = 0.0
+! ----------------------------------------------------------------------
+! CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR
+! ----------------------------------------------------------------------
+ END IF
+ NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2- (WDF * DSMDZ) &
+ - WCND+ ET (K)
+
+! ----------------------------------------------------------------------
+! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER
+! ----------------------------------------------------------------------
+ RHSTT (K) = NUMER / ( - DENOM2)
+ AI (K) = - WDF * DDZ / DENOM2
+
+! ----------------------------------------------------------------------
+! RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR
+! RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF
+! ----------------------------------------------------------------------
+ BI (K) = - ( AI (K) + CI (K) )
+ IF (K .eq. NSOIL) THEN
+ RUNOFF2 = SLOPX * WCND2
+ END IF
+ IF (K .ne. NSOIL) THEN
+ WDF = WDF2
+ WCND = WCND2
+ DSMDZ = DSMDZ2
+ DDZ = DDZ2
+ END IF
+ END DO
+! ----------------------------------------------------------------------
+ END SUBROUTINE SRT
+! ----------------------------------------------------------------------
+
+ SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, &
+ NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, &
+ AI,BI,CI)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SSTEP
+! ----------------------------------------------------------------------
+! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE
+! CONTENT VALUES.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: NSOIL
+ INTEGER :: I, K, KK11
+
+ REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX
+ REAL, INTENT(OUT) :: RUNOFF3
+ REAL, INTENT(INOUT) :: CMC
+ REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2OIN, SICE, ZSOIL
+ REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SH2OOUT
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT, SMC
+ REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI
+ REAL, DIMENSION(1:NSOIL) :: RHSTTin
+ REAL, DIMENSION(1:NSOIL) :: CIin
+ REAL :: DDZ, RHSCT, STOT, WPLUS
+
+! ----------------------------------------------------------------------
+! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE
+! TRI-DIAGONAL MATRIX ROUTINE.
+! ----------------------------------------------------------------------
+ DO K = 1,NSOIL
+ RHSTT (K) = RHSTT (K) * DT
+ AI (K) = AI (K) * DT
+ BI (K) = 1. + BI (K) * DT
+ CI (K) = CI (K) * DT
+ END DO
+! ----------------------------------------------------------------------
+! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12
+! ----------------------------------------------------------------------
+ DO K = 1,NSOIL
+ RHSTTin (K) = RHSTT (K)
+ END DO
+ DO K = 1,NSOIL
+ CIin (K) = CI (K)
+ END DO
+! ----------------------------------------------------------------------
+! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX
+! ----------------------------------------------------------------------
+ CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL)
+! ----------------------------------------------------------------------
+! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A
+! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02.
+! RUNOFF3: RUNOFF WITHIN SOIL LAYERS
+! ----------------------------------------------------------------------
+ WPLUS = 0.0
+ RUNOFF3 = 0.
+
+ DDZ = - ZSOIL (1)
+ DO K = 1,NSOIL
+ IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K)
+ SH2OOUT (K) = SH2OIN (K) + CI (K) + WPLUS / DDZ
+ STOT = SH2OOUT (K) + SICE (K)
+ IF (STOT > SMCMAX) THEN
+ IF (K .eq. 1) THEN
+ DDZ = - ZSOIL (1)
+ ELSE
+ KK11 = K - 1
+ DDZ = - ZSOIL (K) + ZSOIL (KK11)
+ END IF
+ WPLUS = (STOT - SMCMAX) * DDZ
+ ELSE
+ WPLUS = 0.
+ END IF
+ SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 )
+ SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0)
+ END DO
+
+! ----------------------------------------------------------------------
+! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO
+! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC.
+! ----------------------------------------------------------------------
+ RUNOFF3 = WPLUS
+ CMC = CMC + DT * RHSCT
+ IF (CMC < 1.E-20) CMC = 0.0
+ CMC = MIN (CMC,CMCMAX)
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE SSTEP
+! ----------------------------------------------------------------------
+
+ SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE TBND
+! ----------------------------------------------------------------------
+! CALCULATE TEMPERATURE ON THE BOUNDARY OF THE LAYER BY INTERPOLATION OF
+! THE MIDDLE LAYER TEMPERATURES
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: NSOIL
+ INTEGER :: K
+ REAL, INTENT(IN) :: TB, TU, ZBOT
+ REAL, INTENT(OUT) :: TBND1
+ REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL
+ REAL :: ZB, ZUP
+ REAL, PARAMETER :: T0 = 273.15
+
+! ----------------------------------------------------------------------
+! USE SURFACE TEMPERATURE ON THE TOP OF THE FIRST LAYER
+! ----------------------------------------------------------------------
+ IF (K == 1) THEN
+ ZUP = 0.
+ ELSE
+ ZUP = ZSOIL (K -1)
+ END IF
+! ----------------------------------------------------------------------
+! USE DEPTH OF THE CONSTANT BOTTOM TEMPERATURE WHEN INTERPOLATE
+! TEMPERATURE INTO THE LAST LAYER BOUNDARY
+! ----------------------------------------------------------------------
+ IF (K == NSOIL) THEN
+ ZB = 2.* ZBOT - ZSOIL (K)
+ ELSE
+ ZB = ZSOIL (K +1)
+ END IF
+! ----------------------------------------------------------------------
+! LINEAR INTERPOLATION BETWEEN THE AVERAGE LAYER TEMPERATURES
+! ----------------------------------------------------------------------
+
+ TBND1 = TU + (TB - TU)* (ZUP - ZSOIL (K))/ (ZUP - ZB)
+! ----------------------------------------------------------------------
+ END SUBROUTINE TBND
+! ----------------------------------------------------------------------
+
+
+ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE TDFCND
+! ----------------------------------------------------------------------
+! CALCULATE THERMAL DIFFUSIVITY AND CONDUCTIVITY OF THE SOIL FOR A GIVEN
+! POINT AND TIME.
+! ----------------------------------------------------------------------
+! PETERS-LIDARD APPROACH (PETERS-LIDARD et al., 1998)
+! June 2001 CHANGES: FROZEN SOIL CONDITION.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ REAL, INTENT(IN) :: QZ, SMC, SMCMAX, SH2O
+ REAL, INTENT(OUT) :: DF
+ REAL :: AKE, GAMMD, THKDRY, THKICE, THKO, &
+ THKQTZ,THKSAT,THKS,THKW,SATRATIO,XU, &
+ XUNFROZ
+
+! ----------------------------------------------------------------------
+! WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM):
+! DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52,
+! & 0.35, 0.60, 0.40, 0.82/
+! ----------------------------------------------------------------------
+! IF THE SOIL HAS ANY MOISTURE CONTENT COMPUTE A PARTIAL SUM/PRODUCT
+! OTHERWISE USE A CONSTANT VALUE WHICH WORKS WELL WITH MOST SOILS
+! ----------------------------------------------------------------------
+! THKW ......WATER THERMAL CONDUCTIVITY
+! THKQTZ ....THERMAL CONDUCTIVITY FOR QUARTZ
+! THKO ......THERMAL CONDUCTIVITY FOR OTHER SOIL COMPONENTS
+! THKS ......THERMAL CONDUCTIVITY FOR THE SOLIDS COMBINED(QUARTZ+OTHER)
+! THKICE ....ICE THERMAL CONDUCTIVITY
+! SMCMAX ....POROSITY (= SMCMAX)
+! QZ .........QUARTZ CONTENT (SOIL TYPE DEPENDENT)
+! ----------------------------------------------------------------------
+! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975).
+
+! PABLO GRUNMANN, 08/17/98
+! REFS.:
+! FAROUKI, O.T.,1986: THERMAL PROPERTIES OF SOILS. SERIES ON ROCK
+! AND SOIL MECHANICS, VOL. 11, TRANS TECH, 136 PP.
+! JOHANSEN, O., 1975: THERMAL CONDUCTIVITY OF SOILS. PH.D. THESIS,
+! UNIVERSITY OF TRONDHEIM,
+! PETERS-LIDARD, C. D., ET AL., 1998: THE EFFECT OF SOIL THERMAL
+! CONDUCTIVITY PARAMETERIZATION ON SURFACE ENERGY FLUXES
+! AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES,
+! VOL. 55, PP. 1209-1224.
+! ----------------------------------------------------------------------
+! NEEDS PARAMETERS
+! POROSITY(SOIL TYPE):
+! POROS = SMCMAX
+! SATURATION RATIO:
+! PARAMETERS W/(M.K)
+ SATRATIO = SMC / SMCMAX
+! ICE CONDUCTIVITY:
+ THKICE = 2.2
+! WATER CONDUCTIVITY:
+ THKW = 0.57
+! THERMAL CONDUCTIVITY OF "OTHER" SOIL COMPONENTS
+! IF (QZ .LE. 0.2) THKO = 3.0
+ THKO = 2.0
+! QUARTZ' CONDUCTIVITY
+ THKQTZ = 7.7
+! SOLIDS' CONDUCTIVITY
+ THKS = (THKQTZ ** QZ)* (THKO ** (1. - QZ))
+
+! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN))
+ XUNFROZ = SH2O / SMC
+! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ)
+ XU = XUNFROZ * SMCMAX
+
+! SATURATED THERMAL CONDUCTIVITY
+ THKSAT = THKS ** (1. - SMCMAX)* THKICE ** (SMCMAX - XU)* THKW ** &
+ (XU)
+
+! DRY DENSITY IN KG/M3
+ GAMMD = (1. - SMCMAX)*2700.
+
+! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1
+ THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD)
+! FROZEN
+ IF ( (SH2O + 0.0005) < SMC ) THEN
+ AKE = SATRATIO
+! UNFROZEN
+! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE)
+ ELSE
+
+! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT
+! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.)
+! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998).
+
+ IF ( SATRATIO > 0.1 ) THEN
+
+ AKE = LOG10 (SATRATIO) + 1.0
+
+! USE K = KDRY
+ ELSE
+
+ AKE = 0.0
+ END IF
+! THERMAL CONDUCTIVITY
+
+ END IF
+
+ DF = AKE * (THKSAT - THKDRY) + THKDRY
+! ----------------------------------------------------------------------
+ END SUBROUTINE TDFCND
+! ----------------------------------------------------------------------
+
+ SUBROUTINE TMPAVG (TAVG,TUP,TM,TDN,ZSOIL,NSOIL,K)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE TMPAVG
+! ----------------------------------------------------------------------
+! CALCULATE SOIL LAYER AVERAGE TEMPERATURE (TAVG) IN FREEZING/THAWING
+! LAYER USING UP, DOWN, AND MIDDLE LAYER TEMPERATURES (TUP, TDN, TM),
+! WHERE TUP IS AT TOP BOUNDARY OF LAYER, TDN IS AT BOTTOM BOUNDARY OF
+! LAYER. TM IS LAYER PROGNOSTIC STATE TEMPERATURE.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER K
+
+ INTEGER NSOIL
+ REAL DZ
+ REAL DZH
+ REAL T0
+ REAL TAVG
+ REAL TDN
+ REAL TM
+ REAL TUP
+ REAL X0
+ REAL XDN
+ REAL XUP
+
+ REAL ZSOIL (NSOIL)
+
+! ----------------------------------------------------------------------
+ PARAMETER (T0 = 2.7315E2)
+ IF (K .eq. 1) THEN
+ DZ = - ZSOIL (1)
+ ELSE
+ DZ = ZSOIL (K -1) - ZSOIL (K)
+ END IF
+
+ DZH = DZ *0.5
+ IF (TUP .lt. T0) THEN
+ IF (TM .lt. T0) THEN
+! ----------------------------------------------------------------------
+! TUP, TM, TDN < T0
+! ----------------------------------------------------------------------
+ IF (TDN .lt. T0) THEN
+ TAVG = (TUP + 2.0* TM + TDN)/ 4.0
+! ----------------------------------------------------------------------
+! TUP & TM < T0, TDN .ge. T0
+! ----------------------------------------------------------------------
+ ELSE
+ X0 = (T0- TM) * DZH / (TDN - TM)
+ TAVG = 0.5 * (TUP * DZH + TM * (DZH + X0) + T0* ( &
+ & 2.* DZH - X0)) / DZ
+ END IF
+ ELSE
+! ----------------------------------------------------------------------
+! TUP < T0, TM .ge. T0, TDN < T0
+! ----------------------------------------------------------------------
+ IF (TDN .lt. T0) THEN
+ XUP = (T0- TUP) * DZH / (TM - TUP)
+ XDN = DZH - (T0- TM) * DZH / (TDN - TM)
+ TAVG = 0.5 * (TUP * XUP + T0* (2.* DZ - XUP - XDN) &
+ & + TDN * XDN) / DZ
+! ----------------------------------------------------------------------
+! TUP < T0, TM .ge. T0, TDN .ge. T0
+! ----------------------------------------------------------------------
+ ELSE
+ XUP = (T0- TUP) * DZH / (TM - TUP)
+ TAVG = 0.5 * (TUP * XUP + T0* (2.* DZ - XUP)) / DZ
+ END IF
+ END IF
+ ELSE
+ IF (TM .lt. T0) THEN
+! ----------------------------------------------------------------------
+! TUP .ge. T0, TM < T0, TDN < T0
+! ----------------------------------------------------------------------
+ IF (TDN .lt. T0) THEN
+ XUP = DZH - (T0- TUP) * DZH / (TM - TUP)
+ TAVG = 0.5 * (T0* (DZ - XUP) + TM * (DZH + XUP) &
+ & + TDN * DZH) / DZ
+! ----------------------------------------------------------------------
+! TUP .ge. T0, TM < T0, TDN .ge. T0
+! ----------------------------------------------------------------------
+ ELSE
+ XUP = DZH - (T0- TUP) * DZH / (TM - TUP)
+ XDN = (T0- TM) * DZH / (TDN - TM)
+ TAVG = 0.5 * (T0* (2.* DZ - XUP - XDN) + TM * &
+ & (XUP + XDN)) / DZ
+ END IF
+ ELSE
+! ----------------------------------------------------------------------
+! TUP .ge. T0, TM .ge. T0, TDN < T0
+! ----------------------------------------------------------------------
+ IF (TDN .lt. T0) THEN
+ XDN = DZH - (T0- TM) * DZH / (TDN - TM)
+ TAVG = (T0* (DZ - XDN) +0.5* (T0+ TDN)* XDN) / DZ
+! ----------------------------------------------------------------------
+! TUP .ge. T0, TM .ge. T0, TDN .ge. T0
+! ----------------------------------------------------------------------
+ ELSE
+ TAVG = (TUP + 2.0* TM + TDN) / 4.0
+ END IF
+ END IF
+ END IF
+! ----------------------------------------------------------------------
+ END SUBROUTINE TMPAVG
+! ----------------------------------------------------------------------
+
+ SUBROUTINE TRANSP (ET,NSOIL,ETP1,SMC,CMC,ZSOIL,SHDFAC,SMCWLT, &
+ & CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT, &
+ & RTDIS)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE TRANSP
+! ----------------------------------------------------------------------
+! CALCULATE TRANSPIRATION FOR THE VEG CLASS.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER I
+ INTEGER K
+ INTEGER NSOIL
+
+ INTEGER NROOT
+ REAL CFACTR
+ REAL CMC
+ REAL CMCMAX
+ REAL DENOM
+ REAL ET (NSOIL)
+ REAL ETP1
+ REAL ETP1A
+!.....REAL PART(NSOIL)
+ REAL GX (NROOT)
+ REAL PC
+ REAL Q2
+ REAL RTDIS (NSOIL)
+ REAL RTX
+ REAL SFCTMP
+ REAL SGX
+ REAL SHDFAC
+ REAL SMC (NSOIL)
+ REAL SMCREF
+ REAL SMCWLT
+
+! ----------------------------------------------------------------------
+! INITIALIZE PLANT TRANSP TO ZERO FOR ALL SOIL LAYERS.
+! ----------------------------------------------------------------------
+ REAL ZSOIL (NSOIL)
+ DO K = 1,NSOIL
+ ET (K) = 0.
+! ----------------------------------------------------------------------
+! CALCULATE AN 'ADJUSTED' POTENTIAL TRANSPIRATION
+! IF STATEMENT BELOW TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO
+! NOTE: GX AND OTHER TERMS BELOW REDISTRIBUTE TRANSPIRATION BY LAYER,
+! ET(K), AS A FUNCTION OF SOIL MOISTURE AVAILABILITY, WHILE PRESERVING
+! TOTAL ETP1A.
+! ----------------------------------------------------------------------
+ END DO
+ IF (CMC .ne. 0.0) THEN
+ ETP1A = SHDFAC * PC * ETP1 * (1.0- (CMC / CMCMAX) ** CFACTR)
+ ELSE
+ ETP1A = SHDFAC * PC * ETP1
+ END IF
+ SGX = 0.0
+ DO I = 1,NROOT
+ GX (I) = ( SMC (I) - SMCWLT ) / ( SMCREF - SMCWLT )
+ GX (I) = MAX ( MIN ( GX (I), 1. ), 0. )
+ SGX = SGX + GX (I)
+ END DO
+
+ SGX = SGX / NROOT
+ DENOM = 0.
+ DO I = 1,NROOT
+ RTX = RTDIS (I) + GX (I) - SGX
+ GX (I) = GX (I) * MAX ( RTX, 0. )
+ DENOM = DENOM + GX (I)
+ END DO
+
+ IF (DENOM .le. 0.0) DENOM = 1.
+ DO I = 1,NROOT
+ ET (I) = ETP1A * GX (I) / DENOM
+! ----------------------------------------------------------------------
+! ABOVE CODE ASSUMES A VERTICALLY UNIFORM ROOT DISTRIBUTION
+! CODE BELOW TESTS A VARIABLE ROOT DISTRIBUTION
+! ----------------------------------------------------------------------
+! ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * GX * ETP1A
+! ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * ETP1A
+! ----------------------------------------------------------------------
+! USING ROOT DISTRIBUTION AS WEIGHTING FACTOR
+! ----------------------------------------------------------------------
+! ET(1) = RTDIS(1) * ETP1A
+! ET(1) = ETP1A * PART(1)
+! ----------------------------------------------------------------------
+! LOOP DOWN THRU THE SOIL LAYERS REPEATING THE OPERATION ABOVE,
+! BUT USING THE THICKNESS OF THE SOIL LAYER (RATHER THAN THE
+! ABSOLUTE DEPTH OF EACH LAYER) IN THE FINAL CALCULATION.
+! ----------------------------------------------------------------------
+! DO K = 2,NROOT
+! GX = ( SMC(K) - SMCWLT ) / ( SMCREF - SMCWLT )
+! GX = MAX ( MIN ( GX, 1. ), 0. )
+! TEST CANOPY RESISTANCE
+! GX = 1.0
+! ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*GX*ETP1A
+! ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*ETP1A
+! ----------------------------------------------------------------------
+! USING ROOT DISTRIBUTION AS WEIGHTING FACTOR
+! ----------------------------------------------------------------------
+! ET(K) = RTDIS(K) * ETP1A
+! ET(K) = ETP1A*PART(K)
+! END DO
+ END DO
+! ----------------------------------------------------------------------
+ END SUBROUTINE TRANSP
+! ----------------------------------------------------------------------
+
+ SUBROUTINE WDFCND (WDF,WCND,SMC,SMCMAX,BEXP,DKSAT,DWSAT, &
+ & SICEMAX)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE WDFCND
+! ----------------------------------------------------------------------
+! CALCULATE SOIL WATER DIFFUSIVITY AND SOIL HYDRAULIC CONDUCTIVITY.
+! ----------------------------------------------------------------------
+ IMPLICIT NONE
+ REAL BEXP
+ REAL DKSAT
+ REAL DWSAT
+ REAL EXPON
+ REAL FACTR1
+ REAL FACTR2
+ REAL SICEMAX
+ REAL SMC
+ REAL SMCMAX
+ REAL VKwgt
+ REAL WCND
+
+! ----------------------------------------------------------------------
+! CALC THE RATIO OF THE ACTUAL TO THE MAX PSBL SOIL H2O CONTENT
+! ----------------------------------------------------------------------
+ REAL WDF
+ FACTR1 = 0.05 / SMCMAX
+
+! ----------------------------------------------------------------------
+! PREP AN EXPNTL COEF AND CALC THE SOIL WATER DIFFUSIVITY
+! ----------------------------------------------------------------------
+ FACTR2 = SMC / SMCMAX
+ FACTR1 = MIN(FACTR1,FACTR2)
+ EXPON = BEXP + 2.0
+
+! ----------------------------------------------------------------------
+! FROZEN SOIL HYDRAULIC DIFFUSIVITY. VERY SENSITIVE TO THE VERTICAL
+! GRADIENT OF UNFROZEN WATER. THE LATTER GRADIENT CAN BECOME VERY
+! EXTREME IN FREEZING/THAWING SITUATIONS, AND GIVEN THE RELATIVELY
+! FEW AND THICK SOIL LAYERS, THIS GRADIENT SUFFERES SERIOUS
+! TRUNCTION ERRORS YIELDING ERRONEOUSLY HIGH VERTICAL TRANSPORTS OF
+! UNFROZEN WATER IN BOTH DIRECTIONS FROM HUGE HYDRAULIC DIFFUSIVITY.
+! THEREFORE, WE FOUND WE HAD TO ARBITRARILY CONSTRAIN WDF
+! --
+! VERSION D_10CM: ........ FACTR1 = 0.2/SMCMAX
+! WEIGHTED APPROACH...................... PABLO GRUNMANN, 28_SEP_1999.
+! ----------------------------------------------------------------------
+ WDF = DWSAT * FACTR2 ** EXPON
+ IF (SICEMAX .gt. 0.0) THEN
+ VKWGT = 1./ (1. + (500.* SICEMAX)**3.)
+ WDF = VKWGT * WDF + (1. - VKWGT)* DWSAT * FACTR1** EXPON
+! ----------------------------------------------------------------------
+! RESET THE EXPNTL COEF AND CALC THE HYDRAULIC CONDUCTIVITY
+! ----------------------------------------------------------------------
+ END IF
+ EXPON = (2.0 * BEXP) + 3.0
+ WCND = DKSAT * FACTR2 ** EXPON
+
+! ----------------------------------------------------------------------
+ END SUBROUTINE WDFCND
+! ----------------------------------------------------------------------
+
+ SUBROUTINE SFCDIF_off (ZLM,Z0,THZ0,THLM,SFCSPD,CZIL,AKMS,AKHS)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SFCDIF (renamed SFCDIF_off to avoid clash with Eta PBL)
+! ----------------------------------------------------------------------
+! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS.
+! SEE CHEN ET AL (1997, BLM)
+! ----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ REAL WWST, WWST2, G, VKRM, EXCM, BETA, BTG, ELFC, WOLD, WNEW
+ REAL PIHF, EPSU2, EPSUST, EPSIT, EPSA, ZTMIN, ZTMAX, HPBL, &
+ & SQVISC
+ REAL RIC, RRIC, FHNEU, RFC, RFAC, ZZ, PSLMU, PSLMS, PSLHU, &
+ & PSLHS
+ REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS, ZLM, Z0, THZ0, THLM
+ REAL SFCSPD, CZIL, AKMS, AKHS, ZILFC, ZU, ZT, RDZ, CXCH
+ REAL DTHV, DU2, BTGH, WSTAR2, USTAR, ZSLU, ZSLT, RLOGU, RLOGT
+ REAL RLMO, ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4
+!CC ......REAL ZTFC
+
+ REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, &
+ & RLMA
+
+ INTEGER ITRMX, ILECH, ITR
+ PARAMETER &
+ & (WWST = 1.2,WWST2 = WWST * WWST,G = 9.8,VKRM = 0.40, &
+ & EXCM = 0.001 &
+ & ,BETA = 1./270.,BTG = BETA * G,ELFC = VKRM * BTG &
+ & ,WOLD =.15,WNEW = 1. - WOLD,ITRMX = 05, &
+ & PIHF = 3.14159265/2.)
+ PARAMETER &
+ & (EPSU2 = 1.E-4,EPSUST = 0.07,EPSIT = 1.E-4,EPSA = 1.E-8 &
+ & ,ZTMIN = -5.,ZTMAX = 1.,HPBL = 1000.0 &
+ & ,SQVISC = 258.2)
+ PARAMETER &
+ & (RIC = 0.183,RRIC = 1.0/ RIC,FHNEU = 0.8,RFC = 0.191 &
+ & ,RFAC = RIC / (FHNEU * RFC * RFC))
+
+! ----------------------------------------------------------------------
+! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS
+! ----------------------------------------------------------------------
+! LECH'S SURFACE FUNCTIONS
+! ----------------------------------------------------------------------
+ PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ)
+ PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.))
+ PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ)
+
+! ----------------------------------------------------------------------
+! PAULSON'S SURFACE FUNCTIONS
+! ----------------------------------------------------------------------
+ PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.))
+ PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) &
+ & +2.* ATAN (XX) &
+ &- PIHF
+ PSPMS (YY)= 5.* YY
+ PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5)
+
+! ----------------------------------------------------------------------
+! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND
+! OVER SOLID SURFACE (LAND, SEA-ICE).
+! ----------------------------------------------------------------------
+ PSPHS (YY)= 5.* YY
+
+! ----------------------------------------------------------------------
+! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1
+! C......ZTFC=0.1
+! CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT
+! ----------------------------------------------------------------------
+ ILECH = 0
+
+! ----------------------------------------------------------------------
+ ZILFC = - CZIL * VKRM * SQVISC
+! C.......ZT=Z0*ZTFC
+ ZU = Z0
+ RDZ = 1./ ZLM
+ CXCH = EXCM * RDZ
+ DTHV = THLM - THZ0
+
+! ----------------------------------------------------------------------
+! BELJARS CORRECTION OF USTAR
+! ----------------------------------------------------------------------
+ DU2 = MAX (SFCSPD * SFCSPD,EPSU2)
+!cc If statements to avoid TANGENT LINEAR problems near zero
+ BTGH = BTG * HPBL
+ IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
+ WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.)
+ ELSE
+ WSTAR2 = 0.0
+ END IF
+
+! ----------------------------------------------------------------------
+! ZILITINKEVITCH APPROACH FOR ZT
+! ----------------------------------------------------------------------
+ USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
+
+! ----------------------------------------------------------------------
+ ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0
+ ZSLU = ZLM + ZU
+! PRINT*,'ZSLT=',ZSLT
+! PRINT*,'ZLM=',ZLM
+! PRINT*,'ZT=',ZT
+
+ ZSLT = ZLM + ZT
+ RLOGU = log (ZSLU / ZU)
+
+ RLOGT = log (ZSLT / ZT)
+! PRINT*,'RLMO=',RLMO
+! PRINT*,'ELFC=',ELFC
+! PRINT*,'AKHS=',AKHS
+! PRINT*,'DTHV=',DTHV
+! PRINT*,'USTAR=',USTAR
+
+ RLMO = ELFC * AKHS * DTHV / USTAR **3
+! ----------------------------------------------------------------------
+! 1./MONIN-OBUKKHOV LENGTH-SCALE
+! ----------------------------------------------------------------------
+ DO ITR = 1,ITRMX
+ ZETALT = MAX (ZSLT * RLMO,ZTMIN)
+ RLMO = ZETALT / ZSLT
+ ZETALU = ZSLU * RLMO
+ ZETAU = ZU * RLMO
+
+ ZETAT = ZT * RLMO
+ IF (ILECH .eq. 0) THEN
+ IF (RLMO .lt. 0.)THEN
+ XLU4 = 1. -16.* ZETALU
+ XLT4 = 1. -16.* ZETALT
+ XU4 = 1. -16.* ZETAU
+
+ XT4 = 1. -16.* ZETAT
+ XLU = SQRT (SQRT (XLU4))
+ XLT = SQRT (SQRT (XLT4))
+ XU = SQRT (SQRT (XU4))
+
+ XT = SQRT (SQRT (XT4))
+! PRINT*,'-----------1------------'
+! PRINT*,'PSMZ=',PSMZ
+! PRINT*,'PSPMU(ZETAU)=',PSPMU(ZETAU)
+! PRINT*,'XU=',XU
+! PRINT*,'------------------------'
+ PSMZ = PSPMU (XU)
+ SIMM = PSPMU (XLU) - PSMZ + RLOGU
+ PSHZ = PSPHU (XT)
+ SIMH = PSPHU (XLT) - PSHZ + RLOGT
+ ELSE
+ ZETALU = MIN (ZETALU,ZTMAX)
+ ZETALT = MIN (ZETALT,ZTMAX)
+! PRINT*,'-----------2------------'
+! PRINT*,'PSMZ=',PSMZ
+! PRINT*,'PSPMS(ZETAU)=',PSPMS(ZETAU)
+! PRINT*,'ZETAU=',ZETAU
+! PRINT*,'------------------------'
+ PSMZ = PSPMS (ZETAU)
+ SIMM = PSPMS (ZETALU) - PSMZ + RLOGU
+ PSHZ = PSPHS (ZETAT)
+ SIMH = PSPHS (ZETALT) - PSHZ + RLOGT
+ END IF
+! ----------------------------------------------------------------------
+! LECH'S FUNCTIONS
+! ----------------------------------------------------------------------
+ ELSE
+ IF (RLMO .lt. 0.)THEN
+! PRINT*,'-----------3------------'
+! PRINT*,'PSMZ=',PSMZ
+! PRINT*,'PSLMU(ZETAU)=',PSLMU(ZETAU)
+! PRINT*,'ZETAU=',ZETAU
+! PRINT*,'------------------------'
+ PSMZ = PSLMU (ZETAU)
+ SIMM = PSLMU (ZETALU) - PSMZ + RLOGU
+ PSHZ = PSLHU (ZETAT)
+ SIMH = PSLHU (ZETALT) - PSHZ + RLOGT
+ ELSE
+ ZETALU = MIN (ZETALU,ZTMAX)
+
+ ZETALT = MIN (ZETALT,ZTMAX)
+! PRINT*,'-----------4------------'
+! PRINT*,'PSMZ=',PSMZ
+! PRINT*,'PSLMS(ZETAU)=',PSLMS(ZETAU)
+! PRINT*,'ZETAU=',ZETAU
+! PRINT*,'------------------------'
+ PSMZ = PSLMS (ZETAU)
+ SIMM = PSLMS (ZETALU) - PSMZ + RLOGU
+ PSHZ = PSLHS (ZETAT)
+ SIMH = PSLHS (ZETALT) - PSHZ + RLOGT
+ END IF
+! ----------------------------------------------------------------------
+! BELJAARS CORRECTION FOR USTAR
+! ----------------------------------------------------------------------
+ END IF
+
+! ----------------------------------------------------------------------
+! ZILITINKEVITCH FIX FOR ZT
+! ----------------------------------------------------------------------
+ USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
+
+ ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0
+ ZSLT = ZLM + ZT
+!-----------------------------------------------------------------------
+ RLOGT = log (ZSLT / ZT)
+ USTARK = USTAR * VKRM
+ AKMS = MAX (USTARK / SIMM,CXCH)
+!-----------------------------------------------------------------------
+! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO
+!-----------------------------------------------------------------------
+ AKHS = MAX (USTARK / SIMH,CXCH)
+ IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
+ WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.)
+ ELSE
+ WSTAR2 = 0.0
+ END IF
+!-----------------------------------------------------------------------
+ RLMN = ELFC * AKHS * DTHV / USTAR **3
+!-----------------------------------------------------------------------
+! IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110
+!-----------------------------------------------------------------------
+ RLMA = RLMO * WOLD+ RLMN * WNEW
+!-----------------------------------------------------------------------
+ RLMO = RLMA
+! PRINT*,'----------------------------'
+! PRINT*,'SFCDIF OUTPUT ! ! ! ! ! ! ! ! ! ! ! !'
+
+! PRINT*,'ZLM=',ZLM
+! PRINT*,'Z0=',Z0
+! PRINT*,'THZ0=',THZ0
+! PRINT*,'THLM=',THLM
+! PRINT*,'SFCSPD=',SFCSPD
+! PRINT*,'CZIL=',CZIL
+! PRINT*,'AKMS=',AKMS
+! PRINT*,'AKHS=',AKHS
+! PRINT*,'----------------------------'
+
+ END DO
+! ----------------------------------------------------------------------
+ END SUBROUTINE SFCDIF_off
+! ----------------------------------------------------------------------
+
+END MODULE module_sf_noahlsm
Added: branches/atmos_physics/src/core_physics/physics_wrf/module_sf_urban.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_sf_urban.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_sf_urban.F 2011-01-13 23:29:23 UTC (rev 685)
@@ -0,0 +1,2421 @@
+MODULE module_sf_urban
+
+!===============================================================================
+! Single-Layer Urban Canopy Model for WRF Noah-LSM
+! Original Version: 2002/11/06 by Hiroyuki Kusaka
+! Last Update: 2006/08/24 by Fei Chen and Mukul Tewari (NCAR/RAL)
+!===============================================================================
+
+ CHARACTER(LEN=4) :: LU_DATA_TYPE
+
+ INTEGER :: ICATE
+
+ REAL, ALLOCATABLE, DIMENSION(:) :: ZR_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: Z0C_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: Z0HC_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: ZDC_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: SVF_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: R_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: RW_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: HGT_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: AH_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: BETR_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: BETB_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: BETG_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: FRC_URB_TBL
+
+ REAL, ALLOCATABLE, DIMENSION(:) :: COP_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: PWIN_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: BETA_TBL
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: SW_COND_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: TIME_ON_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: TIME_OFF_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: TARGTEMP_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: GAPTEMP_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: TARGHUM_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: GAPHUM_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: PERFLO_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: HSESF_TBL
+
+ REAL, ALLOCATABLE, DIMENSION(:) :: CAPR_TBL, CAPB_TBL, CAPG_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: AKSR_TBL, AKSB_TBL, AKSG_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: ALBR_TBL, ALBB_TBL, ALBG_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: EPSR_TBL, EPSB_TBL, EPSG_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: Z0R_TBL, Z0B_TBL, Z0G_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: SIGMA_ZED_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: Z0HB_TBL, Z0HG_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: TRLEND_TBL, TBLEND_TBL, TGLEND_TBL
+ REAL, ALLOCATABLE, DIMENSION(:) :: AKANDA_URBAN_TBL
+!for BEP
+
+ ! MAXDIRS :: The maximum number of street directions we're allowed to define
+ INTEGER, PARAMETER :: MAXDIRS = 3
+ ! MAXHGTS :: The maximum number of building height bins we're allowed to define
+ INTEGER, PARAMETER :: MAXHGTS = 50
+
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMDIR_TBL
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: STREET_DIRECTION_TBL
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: STREET_WIDTH_TBL
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: BUILDING_WIDTH_TBL
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMHGT_TBL
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: HEIGHT_BIN_TBL
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: HPERCENT_BIN_TBL
+!end BEP
+ INTEGER :: BOUNDR_DATA,BOUNDB_DATA,BOUNDG_DATA
+ INTEGER :: CH_SCHEME_DATA, TS_SCHEME_DATA
+ INTEGER :: ahoption ! Miao, 2007/01/17, cal. ah
+ REAL, DIMENSION(1:24) :: ahdiuprf ! ah diurnal profile, tloc: 1-24
+ REAL, DIMENSION(1:24) :: hsequip_tbl
+
+ INTEGER :: allocate_status
+
+! INTEGER :: num_roof_layers
+! INTEGER :: num_wall_layers
+! INTEGER :: num_road_layers
+
+ CONTAINS
+
+!===============================================================================
+!
+! Author:
+! Hiroyuki KUSAKA, PhD
+! University of Tsukuba, JAPAN
+! (CRIEPI, NCAR/MMM visiting scientist, 2002-2004)
+! kusaka@ccs.tsukuba.ac.jp
+!
+! Co-Researchers:
+! Fei CHEN, PhD
+! NCAR/RAP feichen@ucar.edu
+! Mukul TEWARI, PhD
+! NCAR/RAP mukul@ucar.edu
+!
+! Purpose:
+! Calculate surface temeprature, fluxes, canopy air temperature, and canopy wind
+!
+! Subroutines:
+! module_sf_urban
+! |- urban
+! |- read_param
+! |- mos or jurges
+! |- multi_layer or force_restore
+! |- urban_param_init <-- URBPARM.TBL
+! |- urban_var_init
+!
+! Input Data from WRF [MKS unit]:
+!
+! UTYPE [-] : Urban type. 1=Commercial/Industrial; 2=High-intensity residential;
+! : 3=low-intensity residential
+! TA [K] : Potential temperature at 1st wrf level (absolute temp)
+! QA [kg/kg] : Mixing ratio at 1st atmospheric level
+! UA [m/s] : Wind speed at 1st atmospheric level
+! SSG [W/m/m] : Short wave downward radiation at a flat surface
+! Note this is the total of direct and diffusive solar
+! downward radiation. If without two components, the
+! single solar downward can be used instead.
+! SSG = SSGD + SSGQ
+! LSOLAR [-] : Indicating the input type of solar downward radiation
+! True: both direct and diffusive solar radiation
+! are available
+! False: only total downward ridiation is available.
+! SSGD [W/m/m] : Direct solar radiation at a flat surface
+! if SSGD is not available, one can assume a ratio SRATIO
+! (e.g., 0.7), so that SSGD = SRATIO*SSG
+! SSGQ [W/m/m] : Diffuse solar radiation at a flat surface
+! If SSGQ is not available, SSGQ = SSG - SSGD
+! LLG [W/m/m] : Long wave downward radiation at a flat surface
+! RAIN [mm/h] : Precipitation
+! RHOO [kg/m/m/m] : Air density
+! ZA [m] : First atmospheric level
+! as a lowest boundary condition
+! DECLIN [rad] : solar declination
+! COSZ : = sin(fai)*sin(del)+cos(fai)*cos(del)*cos(omg)
+! OMG [rad] : solar hour angle
+! XLAT [deg] : latitude
+! DELT [sec] : Time step
+! ZNT [m] : Roughnes length
+!
+! Output Data to WRF [MKS unit]:
+!
+! TS [K] : Surface potential temperature (absolute temp)
+! QS [-] : Surface humidity
+!
+! SH [W/m/m/] : Sensible heat flux, = FLXTH*RHOO*CPP
+! LH [W/m/m] : Latent heat flux, = FLXHUM*RHOO*ELL
+! LH_INEMATIC [kg/m/m/sec]: Moisture Kinematic flux, = FLXHUM*RHOO
+! SW [W/m/m] : Upward shortwave radiation flux,
+! = SSG-SNET*697.7*60. (697.7*60.=100.*100.*4.186)
+! ALB [-] : Time-varying albedo
+! LW [W/m/m] : Upward longwave radiation flux,
+! = LNET*697.7*60.-LLG
+! G [W/m/m] : Heat Flux into the Ground
+! RN [W/m/m] : Net radiation
+!
+! PSIM [-] : Diagnostic similarity stability function for momentum
+! PSIH [-] : Diagnostic similarity stability function for heat
+!
+! TC [K] : Diagnostic canopy air temperature
+! QC [-] : Diagnostic canopy humidity
+!
+! TH2 [K] : Diagnostic potential temperature at 2 m
+! Q2 [-] : Diagnostic humidity at 2 m
+! U10 [m/s] : Diagnostic u wind component at 10 m
+! V10 [m/s] : Diagnostic v wind component at 10 m
+!
+! CHS, CHS2 [m/s] : CH*U at ZA, CH*U at 2 m (not used)
+!
+! Important parameters:
+!
+! Morphology of the urban canyon:
+! These parameters assigned in the URBPARM.TBL
+!
+! ZR [m] : roof level (building height)
+! SIGMA_ZED [m] : Standard Deviation of roof height
+! ROOF_WIDTH [m] : roof (i.e., building) width
+! ROAD_WIDTH [m] : road width
+!
+! Parameters derived from the morphological terms above.
+! These parameters are computed in the code.
+!
+! HGT [-] : normalized building height
+! SVF [-] : sky view factor
+! R [-] : Normalized roof width (a.k.a. "building coverage ratio")
+! RW [-] : = 1 - R
+! Z0C [m] : Roughness length above canyon for momentum (1/10 of ZR)
+! Z0HC [m] : Roughness length above canyon for heat (1/10 of Z0C)
+! ZDC [m] : Zero plane displacement height (1/5 of ZR)
+!
+! Following parameter are assigned in run/URBPARM.TBL
+!
+! AH [ W m{-2} ] : anthropogenic heat ( W m{-2} in the table, converted internally to cal cm{-2} )
+! CAPR[ J m{-3} K{-1} ] : heat capacity of roof ( units converted in code to [ cal cm{-3} deg{-1} ] )
+! CAPB[ J m{-3} K{-1} ] : heat capacity of building wall ( units converted in code to [ cal cm{-3} deg{-1} ] )
+! CAPG[ J m{-3} K{-1} ] : heat capacity of road ( units converted in code to [ cal cm{-3} deg{-1} ] )
+! AKSR [ J m{-1} s{-1} K{-1} ] : thermal conductivity of roof ( units converted in code to [ cal cm{-1} s{-1} deg{-1} ] )
+! AKSB [ J m{-1} s{-1} K{-1} ] : thermal conductivity of building wall ( units converted in code to [ cal cm{-1} s{-1} deg{-1} ] )
+! AKSG [ J m{-1} s{-1} K{-1} ] : thermal conductivity of road ( units converted in code to [ cal cm{-1} s{-1} deg{-1} ] )
+! ALBR [-] : surface albedo of roof
+! ALBB [-] : surface albedo of building wall
+! ALBG [-] : surface albedo of road
+! EPSR [-] : surface emissivity of roof
+! EPSB [-] : surface emissivity of building wall
+! EPSG [-] : surface emissivity of road
+! Z0B [m] : roughness length for momentum of building wall (only for CH_SCHEME = 1)
+! Z0G [m] : roughness length for momentum of road (only for CH_SCHEME = 1)
+! Z0HB [m] : roughness length for heat of building wall (only for CH_SCHEME = 1)
+! Z0HG [m] : roughness length for heat of road
+! num_roof_layers : number of layers within roof
+! num_wall_layers : number of layers within building walls
+! num_road_layers : number of layers within below road surface
+! NOTE: for now, these layers are defined as same as the number of soil layers in namelist.input
+! DZR [cm] : thickness of each roof layer
+! DZB [cm] : thickness of each building wall layer
+! DZG [cm] : thickness of each ground layer
+! BOUNDR [integer 1 or 2] : Boundary Condition for Roof Layer Temp [1: Zero-Flux, 2: T = Constant]
+! BOUNDB [integer 1 or 2] : Boundary Condition for Building Wall Layer Temp [1: Zero-Flux, 2: T = Constant]
+! BOUNDG [integer 1 or 2] : Boundary Condition for Road Layer Temp [1: Zero-Flux, 2: T = Constant]
+! TRLEND [K] : lower boundary condition of roof temperature
+! TBLEND [K] : lower boundary condition of building temperature
+! TGLEND [K] : lower boundary condition of ground temperature
+! CH_SCHEME [integer 1 or 2] : Sfc exchange scheme used for building wall and road
+! [1: M-O Similarity Theory, 2: Empirical Form (recommend)]
+! TS_SCHEME [integer 1 or 2] : Scheme for computing surface temperature (for roof, wall, and road)
+! [1: 4-layer model, 2: Force-Restore method]
+!
+!for BEP
+! numdir [ - ] : Number of street directions defined for a particular urban category
+! street_direction [ deg ] : Direction of streets for a particular urban category and a particular street direction
+! street_width [ m ] : Width of street for a particular urban category and a particular street direction
+! building_width [ m ] : Width of buildings for a particular urban category and a particular street direction
+! numhgt [ - ] : Number of building height levels defined for a particular urban category
+! height_bin [ m ] : Building height bins defined for a particular urban category.
+! hpercent_bin [ % ] : Percentage of a particular urban category populated by buildings of particular height bins
+!end BEP
+! Moved from URBPARM.TBL
+!
+! BETR [-] : minimum moisture availability of roof
+! BETB [-] : minimum moisture availability of building wall
+! BETG [-] : minimum moisture availability of road
+! Z0R [m] : roughness length for momentum of roof
+! Z0HB [m] : roughness length for heat of building wall (only for CH_SCHEME = 1)
+! Z0HG [m] : roughness length for heat of road
+! num_roof_layers : number of layers within roof
+! num_wall_layers : number of layers within building walls
+! num_road_layers : number of layers within below road surface
+! NOTE: for now, these layers are defined as same as the number of soil layers in namelist.input
+!
+! References:
+! Kusaka and Kimura (2004) J.Appl.Meteor., vol.43, p1899-1910
+! Kusaka and Kimura (2004) J.Meteor.Soc.Japan, vol.82, p45-65
+! Kusaka et al. (2001) Bound.-Layer Meteor., vol.101, p329-358
+!
+! History:
+! 2006/06 modified by H. Kusaka (Univ. Tsukuba), M. Tewari
+! 2005/10/26, modified by Fei Chen, Mukul Tewari
+! 2003/07/21 WRF , modified by H. Kusaka of CRIEPI (NCAR/MMM)
+! 2001/08/26 PhD , modified by H. Kusaka of CRIEPI (Univ.Tsukuba)
+! 1999/08/25 LCM , developed by H. Kusaka of CRIEPI (Univ.Tsukuba)
+!
+!===============================================================================
+!
+! subroutine urban:
+!
+!===============================================================================
+
+ SUBROUTINE urban(LSOLAR, & ! L
+ num_roof_layers,num_wall_layers,num_road_layers, & ! I
+ DZR,DZB,DZG, & ! I
+ UTYPE,TA,QA,UA,U1,V1,SSG,SSGD,SSGQ,LLG,RAIN,RHOO, & ! I
+ ZA,DECLIN,COSZ,OMG,XLAT,DELT,ZNT, & ! I
+ CHS, CHS2, & ! I
+ TR, TB, TG, TC, QC, UC, & ! H
+ TRL,TBL,TGL, & ! H
+ XXXR, XXXB, XXXG, XXXC, & ! H
+ TS,QS,SH,LH,LH_KINEMATIC, & ! O
+ SW,ALB,LW,G,RN,PSIM,PSIH, & ! O
+ GZ1OZ0, & ! O
+ CMR_URB,CHR_URB,CMC_URB,CHC_URB, & ! I/O
+ U10,V10,TH2,Q2,UST & ! O
+ )
+
+ IMPLICIT NONE
+
+ REAL, PARAMETER :: CP=0.24 ! heat capacity of dry air [cgs unit]
+ REAL, PARAMETER :: EL=583. ! latent heat of vaporation [cgs unit]
+ REAL, PARAMETER :: SIG=8.17E-11 ! stefun bolzman constant [cgs unit]
+ REAL, PARAMETER :: SIG_SI=5.67E-8 ! [MKS unit]
+ REAL, PARAMETER :: AK=0.4 ! kalman const. [-]
+ REAL, PARAMETER :: PI=3.14159 ! pi [-]
+ REAL, PARAMETER :: TETENA=7.5 ! const. of Tetens Equation [-]
+ REAL, PARAMETER :: TETENB=237.3 ! const. of Tetens Equation [-]
+ REAL, PARAMETER :: SRATIO=0.75 ! ratio between direct/total solar [-]
+
+ REAL, PARAMETER :: CPP=1004.5 ! heat capacity of dry air [J/K/kg]
+ REAL, PARAMETER :: ELL=2.442E+06 ! latent heat of vaporization [J/kg]
+ REAL, PARAMETER :: XKA=2.4E-5
+
+!-------------------------------------------------------------------------------
+! C: configuration variables
+!-------------------------------------------------------------------------------
+
+ LOGICAL, INTENT(IN) :: LSOLAR ! logical [true=both, false=SSG only]
+
+! The following variables are also model configuration variables, but are
+! defined in the URBAN.TBL and in the contains statement in the top of
+! the module_urban_init, so we should not declare them here.
+
+ INTEGER, INTENT(IN) :: num_roof_layers
+ INTEGER, INTENT(IN) :: num_wall_layers
+ INTEGER, INTENT(IN) :: num_road_layers
+
+
+ REAL, INTENT(IN), DIMENSION(1:num_roof_layers) :: DZR ! grid interval of roof layers [cm]
+ REAL, INTENT(IN), DIMENSION(1:num_wall_layers) :: DZB ! grid interval of wall layers [cm]
+ REAL, INTENT(IN), DIMENSION(1:num_road_layers) :: DZG ! grid interval of road layers [cm]
+
+!-------------------------------------------------------------------------------
+! I: input variables from LSM to Urban
+!-------------------------------------------------------------------------------
+
+ INTEGER, INTENT(IN) :: UTYPE ! urban type [1=Commercial/Industrial, 2=High-intensity residential,
+ ! 3=low-intensity residential]
+
+ REAL, INTENT(IN) :: TA ! potential temp at 1st atmospheric level [K]
+ REAL, INTENT(IN) :: QA ! mixing ratio at 1st atmospheric level [kg/kg]
+ REAL, INTENT(IN) :: UA ! wind speed at 1st atmospheric level [m/s]
+ REAL, INTENT(IN) :: U1 ! u at 1st atmospheric level [m/s]
+ REAL, INTENT(IN) :: V1 ! v at 1st atmospheric level [m/s]
+ REAL, INTENT(IN) :: SSG ! downward total short wave radiation [W/m/m]
+ REAL, INTENT(IN) :: LLG ! downward long wave radiation [W/m/m]
+ REAL, INTENT(IN) :: RAIN ! precipitation [mm/h]
+ REAL, INTENT(IN) :: RHOO ! air density [kg/m^3]
+ REAL, INTENT(IN) :: ZA ! first atmospheric level [m]
+ REAL, INTENT(IN) :: DECLIN ! solar declination [rad]
+ REAL, INTENT(IN) :: COSZ ! sin(fai)*sin(del)+cos(fai)*cos(del)*cos(omg)
+ REAL, INTENT(IN) :: OMG ! solar hour angle [rad]
+
+ REAL, INTENT(IN) :: XLAT ! latitude [deg]
+ REAL, INTENT(IN) :: DELT ! time step [s]
+ REAL, INTENT(IN) :: ZNT ! roughness length [m]
+ REAL, INTENT(IN) :: CHS,CHS2 ! CH*U at za and 2 m [m/s]
+
+ REAL, INTENT(INOUT) :: SSGD ! downward direct short wave radiation [W/m/m]
+ REAL, INTENT(INOUT) :: SSGQ ! downward diffuse short wave radiation [W/m/m]
+ REAL, INTENT(INOUT) :: CMR_URB
+ REAL, INTENT(INOUT) :: CHR_URB
+ REAL, INTENT(INOUT) :: CMC_URB
+ REAL, INTENT(INOUT) :: CHC_URB
+
+!-------------------------------------------------------------------------------
+! O: output variables from Urban to LSM
+!-------------------------------------------------------------------------------
+
+ REAL, INTENT(OUT) :: TS ! surface potential temperature [K]
+ REAL, INTENT(OUT) :: QS ! surface humidity [K]
+ REAL, INTENT(OUT) :: SH ! sensible heat flux [W/m/m]
+ REAL, INTENT(OUT) :: LH ! latent heat flux [W/m/m]
+ REAL, INTENT(OUT) :: LH_KINEMATIC ! latent heat, kinetic [kg/m/m/s]
+ REAL, INTENT(OUT) :: SW ! upward short wave radiation flux [W/m/m]
+ REAL, INTENT(OUT) :: ALB ! time-varying albedo [fraction]
+ REAL, INTENT(OUT) :: LW ! upward long wave radiation flux [W/m/m]
+ REAL, INTENT(OUT) :: G ! heat flux into the ground [W/m/m]
+ REAL, INTENT(OUT) :: RN ! net radition [W/m/m]
+ REAL, INTENT(OUT) :: PSIM ! similality stability shear function for momentum
+ REAL, INTENT(OUT) :: PSIH ! similality stability shear function for heat
+ REAL, INTENT(OUT) :: GZ1OZ0
+ REAL, INTENT(OUT) :: U10 ! u at 10m [m/s]
+ REAL, INTENT(OUT) :: V10 ! u at 10m [m/s]
+ REAL, INTENT(OUT) :: TH2 ! potential temperature at 2 m [K]
+ REAL, INTENT(OUT) :: Q2 ! humidity at 2 m [-]
+!m REAL, INTENT(OUT) :: CHS,CHS2 ! CH*U at za and 2 m [m/s]
+ REAL, INTENT(OUT) :: UST ! friction velocity [m/s]
+
+
+!-------------------------------------------------------------------------------
+! H: Historical (state) variables of Urban : LSM <--> Urban
+!-------------------------------------------------------------------------------
+
+! TR: roof temperature [K]; TRP: at previous time step [K]
+! TB: building wall temperature [K]; TBP: at previous time step [K]
+! TG: road temperature [K]; TGP: at previous time step [K]
+! TC: urban-canopy air temperature [K]; TCP: at previous time step [K]
+! (absolute temperature)
+! QC: urban-canopy air mixing ratio [kg/kg]; QCP: at previous time step [kg/kg]
+!
+! XXXR: Monin-Obkhov length for roof [dimensionless]
+! XXXB: Monin-Obkhov length for building wall [dimensionless]
+! XXXG: Monin-Obkhov length for road [dimensionless]
+! XXXC: Monin-Obkhov length for urban-canopy [dimensionless]
+!
+! TRL, TBL, TGL: layer temperature [K] (absolute temperature)
+
+ REAL, INTENT(INOUT):: TR, TB, TG, TC, QC, UC
+ REAL, INTENT(INOUT):: XXXR, XXXB, XXXG, XXXC
+
+ REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: TRL
+ REAL, DIMENSION(1:num_wall_layers), INTENT(INOUT) :: TBL
+ REAL, DIMENSION(1:num_road_layers), INTENT(INOUT) :: TGL
+
+!-------------------------------------------------------------------------------
+! L: Local variables from read_param
+!-------------------------------------------------------------------------------
+
+ REAL :: ZR, Z0C, Z0HC, ZDC, SVF, R, RW, HGT, AH
+ REAL :: SIGMA_ZED
+ REAL :: CAPR, CAPB, CAPG, AKSR, AKSB, AKSG, ALBR, ALBB, ALBG
+ REAL :: EPSR, EPSB, EPSG, Z0R, Z0B, Z0G, Z0HB, Z0HG
+ REAL :: TRLEND,TBLEND,TGLEND
+ REAL :: T1VR, T1VC,TH2V
+ REAL :: RLMO_URB
+ REAL :: AKANDA_URBAN
+
+ REAL :: TH2X !m
+
+ INTEGER :: BOUNDR, BOUNDB, BOUNDG
+ INTEGER :: CH_SCHEME, TS_SCHEME
+
+ LOGICAL :: SHADOW ! [true=consider svf and shadow effects, false=consider svf effect only]
+
+!for BEP
+ INTEGER :: NUMDIR
+ REAL, DIMENSION ( MAXDIRS ) :: STREET_DIRECTION
+ REAL, DIMENSION ( MAXDIRS ) :: STREET_WIDTH
+ REAL, DIMENSION ( MAXDIRS ) :: BUILDING_WIDTH
+ INTEGER :: NUMHGT
+ REAL, DIMENSION ( MAXHGTS ) :: HEIGHT_BIN
+ REAL, DIMENSION ( MAXHGTS ) :: HPERCENT_BIN
+!end BEP
+!-------------------------------------------------------------------------------
+! L: Local variables
+!-------------------------------------------------------------------------------
+
+ REAL :: BETR, BETB, BETG
+ REAL :: SX, SD, SQ, RX
+ REAL :: UR, ZC, XLB, BB
+ REAL :: Z, RIBB, RIBG, RIBC, BHR, BHB, BHG, BHC
+ REAL :: TSC, LNET, SNET, FLXUV, THG, FLXTH, FLXHUM, FLXG
+ REAL :: W, VFGS, VFGW, VFWG, VFWS, VFWW
+ REAL :: HOUI1, HOUI2, HOUI3, HOUI4, HOUI5, HOUI6, HOUI7, HOUI8
+ REAL :: SLX, SLX1, SLX2, SLX3, SLX4, SLX5, SLX6, SLX7, SLX8
+ REAL :: FLXTHR, FLXTHB, FLXTHG, FLXHUMR, FLXHUMB, FLXHUMG
+ REAL :: SR, SB, SG, RR, RB, RG
+ REAL :: SR1, SR2, SB1, SB2, SG1, SG2, RR1, RR2, RB1, RB2, RG1, RG2
+ REAL :: HR, HB, HG, ELER, ELEB, ELEG, G0R, G0B, G0G
+ REAL :: ALPHAC, ALPHAR, ALPHAB, ALPHAG
+ REAL :: CHC, CHR, CHB, CHG, CDC, CDR, CDB, CDG
+ REAL :: C1R, C1B, C1G, TE, TC1, TC2, QC1, QC2, QS0R, QS0B, QS0G,RHO,ES
+
+ REAL :: DESDT
+ REAL :: F
+ REAL :: DQS0RDTR
+ REAL :: DRRDTR, DHRDTR, DELERDTR, DG0RDTR
+ REAL :: DTR, DFDT
+ REAL :: FX, FY, GF, GX, GY
+ REAL :: DTCDTB, DTCDTG
+ REAL :: DQCDTB, DQCDTG
+ REAL :: DRBDTB1, DRBDTG1, DRBDTB2, DRBDTG2
+ REAL :: DRGDTB1, DRGDTG1, DRGDTB2, DRGDTG2
+ REAL :: DRBDTB, DRBDTG, DRGDTB, DRGDTG
+ REAL :: DHBDTB, DHBDTG, DHGDTB, DHGDTG
+ REAL :: DELEBDTB, DELEBDTG, DELEGDTG, DELEGDTB
+ REAL :: DG0BDTB, DG0BDTG, DG0GDTG, DG0GDTB
+ REAL :: DQS0BDTB, DQS0GDTG
+ REAL :: DTB, DTG, DTC
+
+ REAL :: THEATAZ ! Solar Zenith Angle [rad]
+ REAL :: THEATAS ! = PI/2. - THETAZ
+ REAL :: FAI ! Latitude [rad]
+ REAL :: CNT,SNT
+ REAL :: PS ! Surface Pressure [hPa]
+ REAL :: TAV ! Vertial Temperature [K]
+
+ REAL :: XXX, X, Z0, Z0H, CD, CH
+ REAL :: XXX2, PSIM2, PSIH2, XXX10, PSIM10, PSIH10
+ REAL :: PSIX, PSIT, PSIX2, PSIT2, PSIX10, PSIT10
+
+ REAL :: TRP, TBP, TGP, TCP, QCP, TST, QST
+
+ INTEGER :: iteration, K
+ INTEGER :: tloc
+
+!-------------------------------------------------------------------------------
+! Set parameters
+!-------------------------------------------------------------------------------
+
+! Miao, 2007/01/17, cal. ah
+ if(ahoption==1) then
+ tloc=mod(int(OMG/PI*180./15.+12.+0.5 ),24)
+ if(tloc==0) tloc=24
+ endif
+
+ CALL read_param(UTYPE,ZR,SIGMA_ZED,Z0C,Z0HC,ZDC,SVF,R,RW,HGT, &
+ AH,CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB, &
+ ALBG,EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG, &
+ BETR,BETB,BETG,TRLEND,TBLEND,TGLEND, &
+!for BEP
+ NUMDIR, STREET_DIRECTION, STREET_WIDTH, &
+ BUILDING_WIDTH, NUMHGT, HEIGHT_BIN, &
+ HPERCENT_BIN, &
+!end BEP
+ BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME, &
+ AKANDA_URBAN)
+
+! Miao, 2007/01/17, cal. ah
+ if(ahoption==1) AH=AH*ahdiuprf(tloc)
+
+ IF( ZDC+Z0C+2. >= ZA) THEN
+! CALL wrf_error_fatal ("ZDC + Z0C + 2m is larger than the 1st WRF level "// &
+! "Stop in subroutine urban - change ZDC and Z0C" )
+ END IF
+
+ IF(.NOT.LSOLAR) THEN
+ SSGD = SRATIO*SSG
+ SSGQ = SSG - SSGD
+ ENDIF
+ SSGD = SRATIO*SSG ! No radiation scheme has SSGD and SSGQ.
+ SSGQ = SSG - SSGD
+
+ W=2.*1.*HGT
+ VFGS=SVF
+ VFGW=1.-SVF
+ VFWG=(1.-SVF)*(1.-R)/W
+ VFWS=VFWG
+ VFWW=1.-2.*VFWG
+
+!-------------------------------------------------------------------------------
+! Convert unit from MKS to cgs
+! Renew surface and layer temperatures
+!-------------------------------------------------------------------------------
+
+ SX=(SSGD+SSGQ)/697.7/60. ! downward short wave radition [ly/min]
+ SD=SSGD/697.7/60. ! downward direct short wave radiation
+ SQ=SSGQ/697.7/60. ! downward diffuse short wave radiation
+ RX=LLG/697.7/60. ! downward long wave radiation
+ RHO=RHOO*0.001 ! air density at first atmospheric level
+
+ TRP=TR
+ TBP=TB
+ TGP=TG
+ TCP=TC
+ QCP=QC
+
+ TAV=TA*(1.+0.61*QA)
+ PS=RHOO*287.*TAV/100. ![hPa]
+
+!-------------------------------------------------------------------------------
+! Canopy wind
+!-------------------------------------------------------------------------------
+
+ IF ( ZR + 2. < ZA ) THEN
+ UR=UA*LOG((ZR-ZDC)/Z0C)/LOG((ZA-ZDC)/Z0C)
+ ZC=0.7*ZR
+ XLB=0.4*(ZR-ZDC)
+ ! BB formulation from Inoue (1963)
+ BB = 0.4 * ZR / ( XLB * alog( ( ZR - ZDC ) / Z0C ) )
+ UC=UR*EXP(-BB*(1.-ZC/ZR))
+ ELSE
+ ! PRINT *, 'Warning ZR + 2m is larger than the 1st WRF level'
+ ZC=ZA/2.
+ UC=UA/2.
+ END IF
+
+!-------------------------------------------------------------------------------
+! Net Short Wave Radiation at roof, wall, and road
+!-------------------------------------------------------------------------------
+
+ SHADOW = .false.
+! SHADOW = .true.
+
+ IF (SSG > 0.0) THEN
+
+ IF(.NOT.SHADOW) THEN ! no shadow effects model
+
+ SR1=SX*(1.-ALBR)
+ SG1=SX*VFGS*(1.-ALBG)
+ SB1=SX*VFWS*(1.-ALBB)
+ SG2=SB1*ALBB/(1.-ALBB)*VFGW*(1.-ALBG)
+ SB2=SG1*ALBG/(1.-ALBG)*VFWG*(1.-ALBB)
+
+ ELSE ! shadow effects model
+
+ FAI=XLAT*PI/180.
+
+ THEATAS=ABS(ASIN(COSZ))
+ THEATAZ=ABS(ACOS(COSZ))
+
+ SNT=COS(DECLIN)*SIN(OMG)/COS(THEATAS)
+ CNT=(COSZ*SIN(FAI)-SIN(DECLIN))/COS(THEATAS)/COS(FAI)
+
+ HOUI1=(SNT*COS(PI/8.) -CNT*SIN(PI/8.))
+ HOUI2=(SNT*COS(2.*PI/8.) -CNT*SIN(2.*PI/8.))
+ HOUI3=(SNT*COS(3.*PI/8.) -CNT*SIN(3.*PI/8.))
+ HOUI4=(SNT*COS(4.*PI/8.) -CNT*SIN(4.*PI/8.))
+ HOUI5=(SNT*COS(5.*PI/8.) -CNT*SIN(5.*PI/8.))
+ HOUI6=(SNT*COS(6.*PI/8.) -CNT*SIN(6.*PI/8.))
+ HOUI7=(SNT*COS(7.*PI/8.) -CNT*SIN(7.*PI/8.))
+ HOUI8=(SNT*COS(8.*PI/8.) -CNT*SIN(8.*PI/8.))
+
+ SLX1=HGT*ABS(TAN(THEATAZ))*ABS(HOUI1)
+ SLX2=HGT*ABS(TAN(THEATAZ))*ABS(HOUI2)
+ SLX3=HGT*ABS(TAN(THEATAZ))*ABS(HOUI3)
+ SLX4=HGT*ABS(TAN(THEATAZ))*ABS(HOUI4)
+ SLX5=HGT*ABS(TAN(THEATAZ))*ABS(HOUI5)
+ SLX6=HGT*ABS(TAN(THEATAZ))*ABS(HOUI6)
+ SLX7=HGT*ABS(TAN(THEATAZ))*ABS(HOUI7)
+ SLX8=HGT*ABS(TAN(THEATAZ))*ABS(HOUI8)
+
+ IF(SLX1 > RW) SLX1=RW
+ IF(SLX2 > RW) SLX2=RW
+ IF(SLX3 > RW) SLX3=RW
+ IF(SLX4 > RW) SLX4=RW
+ IF(SLX5 > RW) SLX5=RW
+ IF(SLX6 > RW) SLX6=RW
+ IF(SLX7 > RW) SLX7=RW
+ IF(SLX8 > RW) SLX8=RW
+
+ SLX=(SLX1+SLX2+SLX3+SLX4+SLX5+SLX6+SLX7+SLX8)/8.
+
+ SR1=SD*(1.-ALBR)+SQ*(1.-ALBR)
+ SG1=SD*(RW-SLX)/RW*(1.-ALBG)+SQ*VFGS*(1.-ALBG)
+ SB1=SD*SLX/W*(1.-ALBB)+SQ*VFWS*(1.-ALBB)
+ SG2=SB1*ALBB/(1.-ALBB)*VFGW*(1.-ALBG)
+ SB2=SG1*ALBG/(1.-ALBG)*VFWG*(1.-ALBB)
+
+ END IF
+
+ SR=SR1
+ SG=SG1+SG2
+ SB=SB1+SB2
+
+ SNET=R*SR+W*SB+RW*SG
+
+ ELSE
+
+ SR=0.
+ SG=0.
+ SB=0.
+ SNET=0.
+
+ END IF
+
+!-------------------------------------------------------------------------------
+! Roof
+!-------------------------------------------------------------------------------
+
+!-------------------------------------------------------------------------------
+! CHR, CDR, BETR
+!-------------------------------------------------------------------------------
+
+ ! Z=ZA-ZDC
+ ! BHR=LOG(Z0R/Z0HR)/0.4
+ ! RIBR=(9.8*2./(TA+TRP))*(TA-TRP)*(Z+Z0R)/(UA*UA)
+ ! CALL mos(XXXR,ALPHAR,CDR,BHR,RIBR,Z,Z0R,UA,TA,TRP,RHO)
+
+ ! Alternative option for MOST using SFCDIF routine from Noah
+ ! Virtual temperatures needed by SFCDIF
+ T1VR = TRP* (1.0+ 0.61 * QA)
+ TH2V = (TA + ( 0.0098 * ZA)) * (1.0+ 0.61 * QA)
+
+ ! note that CHR_URB contains UA (=CHR_MOS*UA)
+ RLMO_URB=0.0
+ CALL SFCDIF_URB (ZA,Z0R,T1VR,TH2V,UA,AKANDA_URBAN,CMR_URB,CHR_URB,RLMO_URB,CDR)
+ ALPHAR = RHO*CP*CHR_URB
+ CHR=ALPHAR/RHO/CP/UA
+
+ IF(RAIN > 1.) BETR=0.7
+
+ IF (TS_SCHEME == 1) THEN
+
+!-------------------------------------------------------------------------------
+! TR Solving Non-Linear Equation by Newton-Rapson
+! TRL Solving Heat Equation by Tri Diagonal Matrix Algorithm
+!-------------------------------------------------------------------------------
+! TSC=TRP-273.15
+! ES=EXP(19.482-4303.4/(TSC+243.5)) ! WMO
+! ES=6.11*10.**(TETENA*TSC/(TETENB+TSC)) ! Tetens
+! DESDT=( 6.1078*(2500.-2.4*TSC)/ & ! Tetens
+! (0.46151*(TSC+273.15)**2.) )*10.**(7.5*TSC/(237.3+TSC))
+! ES=6.11*EXP((2.5*10.**6./461.51)*(TRP-273.15)/(273.15*TRP) ) ! Clausius-Clapeyron
+! DESDT=(2.5*10.**6./461.51)*ES/(TRP**2.) ! Clausius-Clapeyron
+! QS0R=0.622*ES/(PS-0.378*ES)
+! DQS0RDTR = DESDT*0.622*PS/((PS-0.378*ES)**2.)
+! DQS0RDTR = 17.269*(273.15-35.86)/((TRP-35.86)**2.)*QS0R
+
+! TRP=350.
+
+ DO ITERATION=1,20
+
+ ES=6.11*EXP( (2.5*10.**6./461.51)*(TRP-273.15)/(273.15*TRP) )
+ DESDT=(2.5*10.**6./461.51)*ES/(TRP**2.)
+ QS0R=0.622*ES/(PS-0.378*ES)
+ DQS0RDTR = DESDT*0.622*PS/((PS-0.378*ES)**2.)
+
+ RR=EPSR*(RX-SIG*(TRP**4.)/60.)
+ HR=RHO*CP*CHR*UA*(TRP-TA)*100.
+ ELER=RHO*EL*CHR*UA*BETR*(QS0R-QA)*100.
+ G0R=AKSR*(TRP-TRL(1))/(DZR(1)/2.)
+
+ F = SR + RR - HR - ELER - G0R
+
+ DRRDTR = (-4.*EPSR*SIG*TRP**3.)/60.
+ DHRDTR = RHO*CP*CHR*UA*100.
+ DELERDTR = RHO*EL*CHR*UA*BETR*DQS0RDTR*100.
+ DG0RDTR = 2.*AKSR/DZR(1)
+
+ DFDT = DRRDTR - DHRDTR - DELERDTR - DG0RDTR
+ DTR = F/DFDT
+
+ TR = TRP - DTR
+ TRP = TR
+
+ IF( ABS(F) < 0.000001 .AND. ABS(DTR) < 0.000001 ) EXIT
+
+ END DO
+
+! multi-layer heat equation model
+
+ CALL multi_layer(num_roof_layers,BOUNDR,G0R,CAPR,AKSR,TRL,DZR,DELT,TRLEND)
+
+ ELSE
+
+ ES=6.11*EXP( (2.5*10.**6./461.51)*(TRP-273.15)/(273.15*TRP) )
+ QS0R=0.622*ES/(PS-0.378*ES)
+
+ RR=EPSR*(RX-SIG*(TRP**4.)/60.)
+ HR=RHO*CP*CHR*UA*(TRP-TA)*100.
+ ELER=RHO*EL*CHR*UA*BETR*(QS0R-QA)*100.
+ G0R=SR+RR-HR-ELER
+
+ CALL force_restore(CAPR,AKSR,DELT,SR,RR,HR,ELER,TRLEND,TRP,TR)
+
+ TRP=TR
+
+ END IF
+
+ FLXTHR=HR/RHO/CP/100.
+ FLXHUMR=ELER/RHO/EL/100.
+
+!-------------------------------------------------------------------------------
+! Wall and Road
+!-------------------------------------------------------------------------------
+
+!-------------------------------------------------------------------------------
+! CHC, CHB, CDB, BETB, CHG, CDG, BETG
+!-------------------------------------------------------------------------------
+
+ ! Z=ZA-ZDC
+ ! BHC=LOG(Z0C/Z0HC)/0.4
+ ! RIBC=(9.8*2./(TA+TCP))*(TA-TCP)*(Z+Z0C)/(UA*UA)
+ !
+ ! CALL mos(XXXC,ALPHAC,CDC,BHC,RIBC,Z,Z0C,UA,TA,TCP,RHO)
+ ! Virtual temperatures needed by SFCDIF routine from Noah
+
+ T1VC = TCP* (1.0+ 0.61 * QA)
+ RLMO_URB=0.0
+ CALL SFCDIF_URB(ZA,Z0C,T1VC,TH2V,UA,AKANDA_URBAN,CMC_URB,CHC_URB,RLMO_URB,CDC)
+ ALPHAC = RHO*CP*CHC_URB
+
+ IF (CH_SCHEME == 1) THEN
+
+ Z=ZDC
+ BHB=LOG(Z0B/Z0HB)/0.4
+ BHG=LOG(Z0G/Z0HG)/0.4
+ RIBB=(9.8*2./(TCP+TBP))*(TCP-TBP)*(Z+Z0B)/(UC*UC)
+ RIBG=(9.8*2./(TCP+TGP))*(TCP-TGP)*(Z+Z0G)/(UC*UC)
+
+ CALL mos(XXXB,ALPHAB,CDB,BHB,RIBB,Z,Z0B,UC,TCP,TBP,RHO)
+ CALL mos(XXXG,ALPHAG,CDG,BHG,RIBG,Z,Z0G,UC,TCP,TGP,RHO)
+
+ ELSE
+
+ ALPHAB=RHO*CP*(6.15+4.18*UC)/1200.
+ IF(UC > 5.) ALPHAB=RHO*CP*(7.51*UC**0.78)/1200.
+ ALPHAG=RHO*CP*(6.15+4.18*UC)/1200.
+ IF(UC > 5.) ALPHAG=RHO*CP*(7.51*UC**0.78)/1200.
+
+ END IF
+
+ CHC=ALPHAC/RHO/CP/UA
+ CHB=ALPHAB/RHO/CP/UC
+ CHG=ALPHAG/RHO/CP/UC
+
+ BETB=0.0
+ IF(RAIN > 1.) BETG=0.7
+
+ IF (TS_SCHEME == 1) THEN
+
+!-------------------------------------------------------------------------------
+! TB, TG Solving Non-Linear Simultaneous Equation by Newton-Rapson
+! TBL,TGL Solving Heat Equation by Tri Diagonal Matrix Algorithm
+!-------------------------------------------------------------------------------
+
+! TBP=350.
+! TGP=350.
+
+ DO ITERATION=1,20
+
+ ES=6.11*EXP( (2.5*10.**6./461.51)*(TBP-273.15)/(273.15*TBP) )
+ DESDT=(2.5*10.**6./461.51)*ES/(TBP**2.)
+ QS0B=0.622*ES/(PS-0.378*ES)
+ DQS0BDTB=DESDT*0.622*PS/((PS-0.378*ES)**2.)
+
+ ES=6.11*EXP( (2.5*10.**6./461.51)*(TGP-273.15)/(273.15*TGP) )
+ DESDT=(2.5*10.**6./461.51)*ES/(TGP**2.)
+ QS0G=0.622*ES/(PS-0.378*ES)
+ DQS0GDTG=DESDT*0.22*PS/((PS-0.378*ES)**2.)
+
+ RG1=EPSG*( RX*VFGS &
+ +EPSB*VFGW*SIG*TBP**4./60. &
+ -SIG*TGP**4./60. )
+
+ RB1=EPSB*( RX*VFWS &
+ +EPSG*VFWG*SIG*TGP**4./60. &
+ +EPSB*VFWW*SIG*TBP**4./60. &
+ -SIG*TBP**4./60. )
+
+ RG2=EPSG*( (1.-EPSB)*(1.-SVF)*VFWS*RX &
+ +(1.-EPSB)*(1.-SVF)*VFWG*EPSG*SIG*TGP**4./60. &
+ +EPSB*(1.-EPSB)*(1.-SVF)*(1.-2.*VFWS)*SIG*TBP**4./60. )
+
+ RB2=EPSB*( (1.-EPSG)*VFWG*VFGS*RX &
+ +(1.-EPSG)*EPSB*VFGW*VFWG*SIG*(TBP**4.)/60. &
+ +(1.-EPSB)*VFWS*(1.-2.*VFWS)*RX &
+ +(1.-EPSB)*VFWG*(1.-2.*VFWS)*EPSG*SIG*EPSG*TGP**4./60. &
+ +EPSB*(1.-EPSB)*(1.-2.*VFWS)*(1.-2.*VFWS)*SIG*TBP**4./60. )
+
+ RG=RG1+RG2
+ RB=RB1+RB2
+
+ DRBDTB1=EPSB*(4.*EPSB*SIG*TB**3.*VFWW-4.*SIG*TB**3.)/60.
+ DRBDTG1=EPSB*(4.*EPSG*SIG*TG**3.*VFWG)/60.
+ DRBDTB2=EPSB*(4.*(1.-EPSG)*EPSB*SIG*TB**3.*VFGW*VFWG &
+ +4.*EPSB*(1.-EPSB)*SIG*TB**3.*VFWW*VFWW)/60.
+ DRBDTG2=EPSB*(4.*(1.-EPSB)*EPSG*SIG*TG**3.*VFWG*VFWW)/60.
+
+ DRGDTB1=EPSG*(4.*EPSB*SIG*TB**3.*VFGW)/60.
+ DRGDTG1=EPSG*(-4.*SIG*TG**3.)/60.
+ DRGDTB2=EPSG*(4.*EPSB*(1.-EPSB)*SIG*TB**3.*VFWW*VFGW)/60.
+ DRGDTG2=EPSG*(4.*(1.-EPSB)*EPSG*SIG*TG**3.*VFWG*VFGW)/60.
+
+ DRBDTB=DRBDTB1+DRBDTB2
+ DRBDTG=DRBDTG1+DRBDTG2
+ DRGDTB=DRGDTB1+DRGDTB2
+ DRGDTG=DRGDTG1+DRGDTG2
+
+ HB=RHO*CP*CHB*UC*(TBP-TCP)*100.
+ HG=RHO*CP*CHG*UC*(TGP-TCP)*100.
+
+ DTCDTB=W*ALPHAB/(RW*ALPHAC+RW*ALPHAG+W*ALPHAB)
+ DTCDTG=RW*ALPHAG/(RW*ALPHAC+RW*ALPHAG+W*ALPHAB)
+
+ DHBDTB=RHO*CP*CHB*UC*(1.-DTCDTB)*100.
+ DHBDTG=RHO*CP*CHB*UC*(0.-DTCDTG)*100.
+ DHGDTG=RHO*CP*CHG*UC*(1.-DTCDTG)*100.
+ DHGDTB=RHO*CP*CHG*UC*(0.-DTCDTB)*100.
+
+ ELEB=RHO*EL*CHB*UC*BETB*(QS0B-QCP)*100.
+ ELEG=RHO*EL*CHG*UC*BETG*(QS0G-QCP)*100.
+
+ DQCDTB=W*ALPHAB*BETB*DQS0BDTB/(RW*ALPHAC+RW*ALPHAG*BETG+W*ALPHAB*BETB)
+ DQCDTG=RW*ALPHAG*BETG*DQS0GDTG/(RW*ALPHAC+RW*ALPHAG*BETG+W*ALPHAB*BETB)
+
+ DELEBDTB=RHO*EL*CHB*UC*BETB*(DQS0BDTB-DQCDTB)*100.
+ DELEBDTG=RHO*EL*CHB*UC*BETB*(0.-DQCDTG)*100.
+ DELEGDTG=RHO*EL*CHG*UC*BETG*(DQS0GDTG-DQCDTG)*100.
+ DELEGDTB=RHO*EL*CHG*UC*BETG*(0.-DQCDTB)*100.
+
+ G0B=AKSB*(TBP-TBL(1))/(DZB(1)/2.)
+ G0G=AKSG*(TGP-TGL(1))/(DZG(1)/2.)
+
+ DG0BDTB=2.*AKSB/DZB(1)
+ DG0BDTG=0.
+ DG0GDTG=2.*AKSG/DZG(1)
+ DG0GDTB=0.
+
+ F = SB + RB - HB - ELEB - G0B
+ FX = DRBDTB - DHBDTB - DELEBDTB - DG0BDTB
+ FY = DRBDTG - DHBDTG - DELEBDTG - DG0BDTG
+
+ GF = SG + RG - HG - ELEG - G0G
+ GX = DRGDTB - DHGDTB - DELEGDTB - DG0GDTB
+ GY = DRGDTG - DHGDTG - DELEGDTG - DG0GDTG
+
+ DTB = (GF*FY-F*GY)/(FX*GY-GX*FY)
+ DTG = -(GF+GX*DTB)/GY
+
+ TB = TBP + DTB
+ TG = TGP + DTG
+
+ TBP = TB
+ TGP = TG
+
+ TC1=RW*ALPHAC+RW*ALPHAG+W*ALPHAB
+ TC2=RW*ALPHAC*TA+RW*ALPHAG*TGP+W*ALPHAB*TBP
+ TC=TC2/TC1
+
+ QC1=RW*ALPHAC+RW*ALPHAG*BETG+W*ALPHAB*BETB
+ QC2=RW*ALPHAC*QA+RW*ALPHAG*BETG*QS0G+W*ALPHAB*BETB*QS0B
+ QC=QC2/QC1
+
+ DTC=TCP - TC
+ TCP=TC
+ QCP=QC
+
+ IF( ABS(F) < 0.000001 .AND. ABS(DTB) < 0.000001 &
+ .AND. ABS(GF) < 0.000001 .AND. ABS(DTG) < 0.000001 &
+ .AND. ABS(DTC) < 0.000001) EXIT
+
+ END DO
+
+ CALL multi_layer(num_wall_layers,BOUNDB,G0B,CAPB,AKSB,TBL,DZB,DELT,TBLEND)
+
+ CALL multi_layer(num_road_layers,BOUNDG,G0G,CAPG,AKSG,TGL,DZG,DELT,TGLEND)
+
+ ELSE
+
+!-------------------------------------------------------------------------------
+! TB, TG by Force-Restore Method
+!-------------------------------------------------------------------------------
+
+ ES=6.11*EXP((2.5*10.**6./461.51)*(TBP-273.15)/(273.15*TBP) )
+ QS0B=0.622*ES/(PS-0.378*ES)
+
+ ES=6.11*EXP((2.5*10.**6./461.51)*(TGP-273.15)/(273.15*TGP) )
+ QS0G=0.622*ES/(PS-0.378*ES)
+
+ RG1=EPSG*( RX*VFGS &
+ +EPSB*VFGW*SIG*TBP**4./60. &
+ -SIG*TGP**4./60. )
+
+ RB1=EPSB*( RX*VFWS &
+ +EPSG*VFWG*SIG*TGP**4./60. &
+ +EPSB*VFWW*SIG*TBP**4./60. &
+ -SIG*TBP**4./60. )
+
+ RG2=EPSG*( (1.-EPSB)*(1.-SVF)*VFWS*RX &
+ +(1.-EPSB)*(1.-SVF)*VFWG*EPSG*SIG*TGP**4./60. &
+ +EPSB*(1.-EPSB)*(1.-SVF)*(1.-2.*VFWS)*SIG*TBP**4./60. )
+
+ RB2=EPSB*( (1.-EPSG)*VFWG*VFGS*RX &
+ +(1.-EPSG)*EPSB*VFGW*VFWG*SIG*(TBP**4.)/60. &
+ +(1.-EPSB)*VFWS*(1.-2.*VFWS)*RX &
+ +(1.-EPSB)*VFWG*(1.-2.*VFWS)*EPSG*SIG*EPSG*TGP**4./60. &
+ +EPSB*(1.-EPSB)*(1.-2.*VFWS)*(1.-2.*VFWS)*SIG*TBP**4./60. )
+
+ RG=RG1+RG2
+ RB=RB1+RB2
+
+ HB=RHO*CP*CHB*UC*(TBP-TCP)*100.
+ ELEB=RHO*EL*CHB*UC*BETB*(QS0B-QCP)*100.
+ G0B=SB+RB-HB-ELEB
+
+ HG=RHO*CP*CHG*UC*(TGP-TCP)*100.
+ ELEG=RHO*EL*CHG*UC*BETG*(QS0G-QCP)*100.
+ G0G=SG+RG-HG-ELEG
+
+ CALL force_restore(CAPB,AKSB,DELT,SB,RB,HB,ELEB,TBLEND,TBP,TB)
+ CALL force_restore(CAPG,AKSG,DELT,SG,RG,HG,ELEG,TGLEND,TGP,TG)
+
+ TBP=TB
+ TGP=TG
+
+ TC1=RW*ALPHAC+RW*ALPHAG+W*ALPHAB
+ TC2=RW*ALPHAC*TA+RW*ALPHAG*TGP+W*ALPHAB*TBP
+ TC=TC2/TC1
+
+ QC1=RW*ALPHAC+RW*ALPHAG*BETG+W*ALPHAB*BETB
+ QC2=RW*ALPHAC*QA+RW*ALPHAG*BETG*QS0G+W*ALPHAB*BETB*QS0B
+ QC=QC2/QC1
+
+ TCP=TC
+ QCP=QC
+
+ END IF
+
+
+ FLXTHB=HB/RHO/CP/100.
+ FLXHUMB=ELEB/RHO/EL/100.
+ FLXTHG=HG/RHO/CP/100.
+ FLXHUMG=ELEG/RHO/EL/100.
+
+!-------------------------------------------------------------------------------
+! Total Fluxes from Urban Canopy
+!-------------------------------------------------------------------------------
+
+ FLXUV = ( R*CDR + RW*CDC )*UA*UA
+! Miao, 2007/01/17, cal. ah
+ if(ahoption==1) then
+ FLXTH = ( R*FLXTHR + W*FLXTHB + RW*FLXTHG ) + AH/RHOO/CPP
+ else
+ FLXTH = ( R*FLXTHR + W*FLXTHB + RW*FLXTHG )
+ endif
+ FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG )
+ FLXG = ( R*G0R + W*G0B + RW*G0G )
+ LNET = R*RR + W*RB + RW*RG
+
+!----------------------------------------------------------------------------
+! Convert Unit: FLUXES and u* T* q* --> WRF
+!----------------------------------------------------------------------------
+
+ SH = FLXTH * RHOO * CPP ! Sensible heat flux [W/m/m]
+ LH = FLXHUM * RHOO * ELL ! Latent heat flux [W/m/m]
+ LH_KINEMATIC = FLXHUM * RHOO ! Latent heat, Kinematic [kg/m/m/s]
+ LW = LLG - (LNET*697.7*60.) ! Upward longwave radiation [W/m/m]
+ SW = SSG - (SNET*697.7*60.) ! Upward shortwave radiation [W/m/m]
+ ALB = 0.
+ IF( ABS(SSG) > 0.0001) ALB = SW/SSG ! Effective albedo [-]
+ G = -FLXG*697.7*60. ! [W/m/m]
+ RN = (SNET+LNET)*697.7*60. ! Net radiation [W/m/m]
+
+ UST = SQRT(FLXUV) ! u* [m/s]
+ TST = -FLXTH/UST ! T* [K]
+ QST = -FLXHUM/UST ! q* [-]
+
+!------------------------------------------------------
+! diagnostic GRID AVERAGED PSIM PSIH TS QS --> WRF
+!------------------------------------------------------
+
+ Z0 = Z0C
+ Z0H = Z0HC
+ Z = ZA - ZDC
+
+ XXX = 0.4*9.81*Z*TST/TA/UST/UST
+
+ IF ( XXX >= 1. ) XXX = 1.
+ IF ( XXX <= -5. ) XXX = -5.
+
+ IF ( XXX > 0 ) THEN
+ PSIM = -5. * XXX
+ PSIH = -5. * XXX
+ ELSE
+ X = (1.-16.*XXX)**0.25
+ PSIM = 2.*ALOG((1.+X)/2.) + ALOG((1.+X*X)/2.) - 2.*ATAN(X) + PI/2.
+ PSIH = 2.*ALOG((1.+X*X)/2.)
+ END IF
+
+ GZ1OZ0 = ALOG(Z/Z0)
+ CD = 0.4**2./(ALOG(Z/Z0)-PSIM)**2.
+!
+!m CH = 0.4**2./(ALOG(Z/Z0)-PSIM)/(ALOG(Z/Z0H)-PSIH)
+!m CHS = 0.4*UST/(ALOG(Z/Z0H)-PSIH)
+!m TS = TA + FLXTH/CH/UA ! surface potential temp (flux temp)
+!m QS = QA + FLXHUM/CH/UA ! surface humidity
+!
+ TS = TA + FLXTH/CHS ! surface potential temp (flux temp)
+ QS = QA + FLXHUM/CHS ! surface humidity
+
+!-------------------------------------------------------
+! diagnostic GRID AVERAGED U10 V10 TH2 Q2 --> WRF
+!-------------------------------------------------------
+
+ XXX2 = (2./Z)*XXX
+ IF ( XXX2 >= 1. ) XXX2 = 1.
+ IF ( XXX2 <= -5. ) XXX2 = -5.
+
+ IF ( XXX2 > 0 ) THEN
+ PSIM2 = -5. * XXX2
+ PSIH2 = -5. * XXX2
+ ELSE
+ X = (1.-16.*XXX2)**0.25
+ PSIM2 = 2.*ALOG((1.+X)/2.) + ALOG((1.+X*X)/2.) - 2.*ATAN(X) + 2.*ATAN(1.)
+ PSIH2 = 2.*ALOG((1.+X*X)/2.)
+ END IF
+!
+!m CHS2 = 0.4*UST/(ALOG(2./Z0H)-PSIH2)
+!
+
+ XXX10 = (10./Z)*XXX
+ IF ( XXX10 >= 1. ) XXX10 = 1.
+ IF ( XXX10 <= -5. ) XXX10 = -5.
+
+ IF ( XXX10 > 0 ) THEN
+ PSIM10 = -5. * XXX10
+ PSIH10 = -5. * XXX10
+ ELSE
+ X = (1.-16.*XXX10)**0.25
+ PSIM10 = 2.*ALOG((1.+X)/2.) + ALOG((1.+X*X)/2.) - 2.*ATAN(X) + 2.*ATAN(1.)
+ PSIH10 = 2.*ALOG((1.+X*X)/2.)
+ END IF
+
+ PSIX = ALOG(Z/Z0) - PSIM
+ PSIT = ALOG(Z/Z0H) - PSIH
+
+ PSIX2 = ALOG(2./Z0) - PSIM2
+ PSIT2 = ALOG(2./Z0H) - PSIH2
+
+ PSIX10 = ALOG(10./Z0) - PSIM10
+ PSIT10 = ALOG(10./Z0H) - PSIH10
+
+ U10 = U1 * (PSIX10/PSIX) ! u at 10 m [m/s]
+ V10 = V1 * (PSIX10/PSIX) ! v at 10 m [m/s]
+
+! TH2 = TS + (TA-TS)*(PSIT2/PSIT) ! potential temp at 2 m [K]
+! TH2 = TS + (TA-TS)*(PSIT2/PSIT) ! Fei: this seems to be temp (not potential) at 2 m [K]
+!Fei: consistant with M-O theory
+ TH2 = TS + (TA-TS) *(CHS/CHS2)
+
+ Q2 = QS + (QA-QS)*(PSIT2/PSIT) ! humidity at 2 m [-]
+
+! TS = (LW/SIG_SI/0.88)**0.25 ! Radiative temperature [K]
+
+ END SUBROUTINE urban
+!===============================================================================
+!
+! mos
+!
+!===============================================================================
+ SUBROUTINE mos(XXX,ALPHA,CD,B1,RIB,Z,Z0,UA,TA,TSF,RHO)
+
+! XXX: z/L (requires iteration by Newton-Rapson method)
+! B1: Stanton number
+! PSIM: = PSIX of LSM
+! PSIH: = PSIT of LSM
+
+ IMPLICIT NONE
+
+ REAL, PARAMETER :: CP=0.24
+ REAL, INTENT(IN) :: B1, Z, Z0, UA, TA, TSF, RHO
+ REAL, INTENT(OUT) :: ALPHA, CD
+ REAL, INTENT(INOUT) :: XXX, RIB
+ REAL :: XXX0, X, X0, FAIH, DPSIM, DPSIH
+ REAL :: F, DF, XXXP, US, TS, AL, XKB, DD, PSIM, PSIH
+ INTEGER :: NEWT
+ INTEGER, PARAMETER :: NEWT_END=10
+
+ IF(RIB <= -15.) RIB=-15.
+
+ IF(RIB < 0.) THEN
+
+ DO NEWT=1,NEWT_END
+
+ IF(XXX >= 0.) XXX=-1.E-3
+
+ XXX0=XXX*Z0/(Z+Z0)
+
+ X=(1.-16.*XXX)**0.25
+ X0=(1.-16.*XXX0)**0.25
+
+ PSIM=ALOG((Z+Z0)/Z0) &
+ -ALOG((X+1.)**2.*(X**2.+1.)) &
+ +2.*ATAN(X) &
+ +ALOG((X+1.)**2.*(X0**2.+1.)) &
+ -2.*ATAN(X0)
+ FAIH=1./SQRT(1.-16.*XXX)
+ PSIH=ALOG((Z+Z0)/Z0)+0.4*B1 &
+ -2.*ALOG(SQRT(1.-16.*XXX)+1.) &
+ +2.*ALOG(SQRT(1.-16.*XXX0)+1.)
+
+ DPSIM=(1.-16.*XXX)**(-0.25)/XXX &
+ -(1.-16.*XXX0)**(-0.25)/XXX
+ DPSIH=1./SQRT(1.-16.*XXX)/XXX &
+ -1./SQRT(1.-16.*XXX0)/XXX
+
+ F=RIB*PSIM**2./PSIH-XXX
+
+ DF=RIB*(2.*DPSIM*PSIM*PSIH-DPSIH*PSIM**2.) &
+ /PSIH**2.-1.
+
+ XXXP=XXX
+ XXX=XXXP-F/DF
+ IF(XXX <= -10.) XXX=-10.
+
+ END DO
+
+ ELSE IF(RIB >= 0.142857) THEN
+
+ XXX=0.714
+ PSIM=ALOG((Z+Z0)/Z0)+7.*XXX
+ PSIH=PSIM+0.4*B1
+
+ ELSE
+
+ AL=ALOG((Z+Z0)/Z0)
+ XKB=0.4*B1
+ DD=-4.*RIB*7.*XKB*AL+(AL+XKB)**2.
+ IF(DD <= 0.) DD=0.
+ XXX=(AL+XKB-2.*RIB*7.*AL-SQRT(DD))/(2.*(RIB*7.**2-7.))
+ PSIM=ALOG((Z+Z0)/Z0)+7.*MIN(XXX,0.714)
+ PSIH=PSIM+0.4*B1
+
+ END IF
+
+ US=0.4*UA/PSIM ! u*
+ IF(US <= 0.01) US=0.01
+ TS=0.4*(TA-TSF)/PSIH ! T*
+
+ CD=US*US/UA**2. ! CD
+ ALPHA=RHO*CP*0.4*US/PSIH ! RHO*CP*CH*U
+
+ RETURN
+ END SUBROUTINE mos
+!===============================================================================
+!
+! louis79
+!
+!===============================================================================
+ SUBROUTINE louis79(ALPHA,CD,RIB,Z,Z0,UA,RHO)
+
+ IMPLICIT NONE
+
+ REAL, PARAMETER :: CP=0.24
+ REAL, INTENT(IN) :: Z, Z0, UA, RHO
+ REAL, INTENT(OUT) :: ALPHA, CD
+ REAL, INTENT(INOUT) :: RIB
+ REAL :: A2, XX, CH, CMB, CHB
+
+ A2=(0.4/ALOG(Z/Z0))**2.
+
+ IF(RIB <= -15.) RIB=-15.
+
+ IF(RIB >= 0.0) THEN
+ IF(RIB >= 0.142857) THEN
+ XX=0.714
+ ELSE
+ XX=RIB*LOG(Z/Z0)/(1.-7.*RIB)
+ END IF
+ CH=0.16/0.74/(LOG(Z/Z0)+7.*MIN(XX,0.714))**2.
+ CD=0.16/(LOG(Z/Z0)+7.*MIN(XX,0.714))**2.
+ ELSE
+ CMB=7.4*A2*9.4*SQRT(Z/Z0)
+ CHB=5.3*A2*9.4*SQRT(Z/Z0)
+ CH=A2/0.74*(1.-9.4*RIB/(1.+CHB*SQRT(-RIB)))
+ CD=A2*(1.-9.4*RIB/(1.+CHB*SQRT(-RIB)))
+ END IF
+
+ ALPHA=RHO*CP*CH*UA
+
+ RETURN
+ END SUBROUTINE louis79
+!===============================================================================
+!
+! louis82
+!
+!===============================================================================
+ SUBROUTINE louis82(ALPHA,CD,RIB,Z,Z0,UA,RHO)
+
+ IMPLICIT NONE
+
+ REAL, PARAMETER :: CP=0.24
+ REAL, INTENT(IN) :: Z, Z0, UA, RHO
+ REAL, INTENT(OUT) :: ALPHA, CD
+ REAL, INTENT(INOUT) :: RIB
+ REAL :: A2, FM, FH, CH, CHH
+
+ A2=(0.4/ALOG(Z/Z0))**2.
+
+ IF(RIB <= -15.) RIB=-15.
+
+ IF(RIB >= 0.0) THEN
+ FM=1./((1.+(2.*5.*RIB)/SQRT(1.+5.*RIB)))
+ FH=1./(1.+(3.*5.*RIB)*SQRT(1.+5.*RIB))
+ CH=A2*FH
+ CD=A2*FM
+ ELSE
+ CHH=5.*3.*5.*A2*SQRT(Z/Z0)
+ FM=1.-(2.*5.*RIB)/(1.+3.*5.*5.*A2*SQRT(Z/Z0+1.)*(-RIB))
+ FH=1.-(3.*5.*RIB)/(1.+CHH*SQRT(-RIB))
+ CH=A2*FH
+ CD=A2*FM
+ END IF
+
+ ALPHA=RHO*CP*CH*UA
+
+ RETURN
+ END SUBROUTINE louis82
+!===============================================================================
+!
+! multi_layer
+!
+!===============================================================================
+ SUBROUTINE multi_layer(KM,BOUND,G0,CAP,AKS,TSL,DZ,DELT,TSLEND)
+
+ IMPLICIT NONE
+
+ REAL, INTENT(IN) :: G0
+
+ REAL, INTENT(IN) :: CAP
+
+ REAL, INTENT(IN) :: AKS
+
+ REAL, INTENT(IN) :: DELT ! Time step [ s ]
+
+ REAL, INTENT(IN) :: TSLEND
+
+ INTEGER, INTENT(IN) :: KM
+
+ INTEGER, INTENT(IN) :: BOUND
+
+ REAL, DIMENSION(KM), INTENT(IN) :: DZ
+
+ REAL, DIMENSION(KM), INTENT(INOUT) :: TSL
+
+ REAL, DIMENSION(KM) :: A, B, C, D, X, P, Q
+
+ REAL :: DZEND
+
+ INTEGER :: K
+
+ DZEND=DZ(KM)
+
+ A(1) = 0.0
+
+ B(1) = CAP*DZ(1)/DELT &
+ +2.*AKS/(DZ(1)+DZ(2))
+ C(1) = -2.*AKS/(DZ(1)+DZ(2))
+ D(1) = CAP*DZ(1)/DELT*TSL(1) + G0
+
+ DO K=2,KM-1
+ A(K) = -2.*AKS/(DZ(K-1)+DZ(K))
+ B(K) = CAP*DZ(K)/DELT + 2.*AKS/(DZ(K-1)+DZ(K)) + 2.*AKS/(DZ(K)+DZ(K+1))
+ C(K) = -2.*AKS/(DZ(K)+DZ(K+1))
+ D(K) = CAP*DZ(K)/DELT*TSL(K)
+ END DO
+
+ IF(BOUND == 1) THEN ! Flux=0
+ A(KM) = -2.*AKS/(DZ(KM-1)+DZ(KM))
+ B(KM) = CAP*DZ(KM)/DELT + 2.*AKS/(DZ(KM-1)+DZ(KM))
+ C(KM) = 0.0
+ D(KM) = CAP*DZ(KM)/DELT*TSL(KM)
+ ELSE ! T=constant
+ A(KM) = -2.*AKS/(DZ(KM-1)+DZ(KM))
+ B(KM) = CAP*DZ(KM)/DELT + 2.*AKS/(DZ(KM-1)+DZ(KM)) + 2.*AKS/(DZ(KM)+DZEND)
+ C(KM) = 0.0
+ D(KM) = CAP*DZ(KM)/DELT*TSL(KM) + 2.*AKS*TSLEND/(DZ(KM)+DZEND)
+ END IF
+
+ P(1) = -C(1)/B(1)
+ Q(1) = D(1)/B(1)
+
+ DO K=2,KM
+ P(K) = -C(K)/(A(K)*P(K-1)+B(K))
+ Q(K) = (-A(K)*Q(K-1)+D(K))/(A(K)*P(K-1)+B(K))
+ END DO
+
+ X(KM) = Q(KM)
+
+ DO K=KM-1,1,-1
+ X(K) = P(K)*X(K+1)+Q(K)
+ END DO
+
+ DO K=1,KM
+ TSL(K) = X(K)
+ END DO
+
+ RETURN
+ END SUBROUTINE multi_layer
+!===============================================================================
+!
+! subroutine read_param
+!
+!===============================================================================
+ SUBROUTINE read_param(UTYPE, & ! in
+ ZR,SIGMA_ZED,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH, & ! out
+ CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & ! out
+ EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG, & ! out
+ BETR,BETB,BETG,TRLEND,TBLEND,TGLEND, & ! out
+!for BEP
+ NUMDIR, STREET_DIRECTION, STREET_WIDTH, & ! out
+ BUILDING_WIDTH, NUMHGT, HEIGHT_BIN, & ! out
+ HPERCENT_BIN, & ! out
+!end BEP
+ BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME, & ! out
+ AKANDA_URBAN) ! out
+
+ INTEGER, INTENT(IN) :: UTYPE
+
+ REAL, INTENT(OUT) :: ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH, &
+ CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, &
+ SIGMA_ZED, &
+ EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG, &
+ BETR,BETB,BETG,TRLEND,TBLEND,TGLEND
+ REAL, INTENT(OUT) :: AKANDA_URBAN
+!for BEP
+ INTEGER, INTENT(OUT) :: NUMDIR
+ REAL, DIMENSION(MAXDIRS), INTENT(OUT) :: STREET_DIRECTION
+ REAL, DIMENSION(MAXDIRS), INTENT(OUT) :: STREET_WIDTH
+ REAL, DIMENSION(MAXDIRS), INTENT(OUT) :: BUILDING_WIDTH
+ INTEGER, INTENT(OUT) :: NUMHGT
+ REAL, DIMENSION(MAXHGTS), INTENT(OUT) :: HEIGHT_BIN
+ REAL, DIMENSION(MAXHGTS), INTENT(OUT) :: HPERCENT_BIN
+
+!end BEP
+
+ INTEGER, INTENT(OUT) :: BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME
+
+ ZR = ZR_TBL(UTYPE)
+ SIGMA_ZED = SIGMA_ZED_TBL(UTYPE)
+ Z0C= Z0C_TBL(UTYPE)
+ Z0HC= Z0HC_TBL(UTYPE)
+ ZDC= ZDC_TBL(UTYPE)
+ SVF= SVF_TBL(UTYPE)
+ R= R_TBL(UTYPE)
+ RW= RW_TBL(UTYPE)
+ HGT= HGT_TBL(UTYPE)
+ AH= AH_TBL(UTYPE)
+ BETR= BETR_TBL(UTYPE)
+ BETB= BETB_TBL(UTYPE)
+ BETG= BETG_TBL(UTYPE)
+
+!m FRC_URB= FRC_URB_TBL(UTYPE)
+
+ CAPR= CAPR_TBL(UTYPE)
+ CAPB= CAPB_TBL(UTYPE)
+ CAPG= CAPG_TBL(UTYPE)
+ AKSR= AKSR_TBL(UTYPE)
+ AKSB= AKSB_TBL(UTYPE)
+ AKSG= AKSG_TBL(UTYPE)
+ ALBR= ALBR_TBL(UTYPE)
+ ALBB= ALBB_TBL(UTYPE)
+ ALBG= ALBG_TBL(UTYPE)
+ EPSR= EPSR_TBL(UTYPE)
+ EPSB= EPSB_TBL(UTYPE)
+ EPSG= EPSG_TBL(UTYPE)
+ Z0R= Z0R_TBL(UTYPE)
+ Z0B= Z0B_TBL(UTYPE)
+ Z0G= Z0G_TBL(UTYPE)
+ Z0HB= Z0HB_TBL(UTYPE)
+ Z0HG= Z0HG_TBL(UTYPE)
+ TRLEND= TRLEND_TBL(UTYPE)
+ TBLEND= TBLEND_TBL(UTYPE)
+ TGLEND= TGLEND_TBL(UTYPE)
+ BOUNDR= BOUNDR_DATA
+ BOUNDB= BOUNDB_DATA
+ BOUNDG= BOUNDG_DATA
+ CH_SCHEME = CH_SCHEME_DATA
+ TS_SCHEME = TS_SCHEME_DATA
+ AKANDA_URBAN = AKANDA_URBAN_TBL(UTYPE)
+
+!for BEP
+
+ STREET_DIRECTION = -1.E36
+ STREET_WIDTH = -1.E36
+ BUILDING_WIDTH = -1.E36
+ HEIGHT_BIN = -1.E36
+ HPERCENT_BIN = -1.E36
+
+ NUMDIR = NUMDIR_TBL ( UTYPE )
+ STREET_DIRECTION(1:NUMDIR) = STREET_DIRECTION_TBL( 1:NUMDIR, UTYPE )
+ STREET_WIDTH (1:NUMDIR) = STREET_WIDTH_TBL ( 1:NUMDIR, UTYPE )
+ BUILDING_WIDTH (1:NUMDIR) = BUILDING_WIDTH_TBL ( 1:NUMDIR, UTYPE )
+ NUMHGT = NUMHGT_TBL ( UTYPE )
+ HEIGHT_BIN (1:NUMHGT) = HEIGHT_BIN_TBL ( 1:NUMHGT , UTYPE )
+ HPERCENT_BIN (1:NUMHGT) = HPERCENT_BIN_TBL ( 1:NUMHGT , UTYPE )
+
+!end BEP
+ END SUBROUTINE read_param
+!===============================================================================
+!
+! subroutine urban_param_init: Read parameters from URBPARM.TBL
+!
+!===============================================================================
+ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, &
+ sf_urban_physics)
+! num_roof_layers,num_wall_layers,num_road_layers)
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN) :: num_soil_layers
+
+! REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: DZR
+! REAL, DIMENSION(1:num_wall_layers), INTENT(INOUT) :: DZB
+! REAL, DIMENSION(1:num_road_layers), INTENT(INOUT) :: DZG
+ REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZR
+ REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZB
+ REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZG
+ INTEGER, INTENT(IN) :: SF_URBAN_PHYSICS
+
+ INTEGER :: LC, K
+ INTEGER :: IOSTATUS, ALLOCATE_STATUS
+ INTEGER :: num_roof_layers
+ INTEGER :: num_wall_layers
+ INTEGER :: num_road_layers
+ INTEGER :: dummy
+ REAL :: DHGT, HGT, VFWS, VFGS
+
+ REAL, allocatable, dimension(:) :: ROOF_WIDTH
+ REAL, allocatable, dimension(:) :: ROAD_WIDTH
+
+ character(len=512) :: string
+ character(len=128) :: name
+ integer :: indx
+
+ real, parameter :: VonK = 0.4
+ real :: lambda_p
+ real :: lambda_f
+ real :: Cd
+ real :: alpha_macd
+ real :: beta_macd
+ real :: lambda_fr
+
+
+!for BEP
+ real :: dummy_hgt
+ real :: dummy_pct
+ real :: pctsum
+!end BEP
+ num_roof_layers = num_soil_layers
+ num_wall_layers = num_soil_layers
+ num_road_layers = num_soil_layers
+
+
+ ICATE=0
+
+ OPEN (UNIT=11, &
+ FILE='URBPARM.TBL', &
+ ACCESS='SEQUENTIAL', &
+ STATUS='OLD', &
+ ACTION='READ', &
+ POSITION='REWIND', &
+ IOSTAT=IOSTATUS)
+
+ IF (IOSTATUS > 0) THEN
+! CALL wrf_error_fatal('ERROR OPEN URBPARM.TBL')
+ ENDIF
+
+ READLOOP : do
+ read(11,'(A512)', iostat=iostatus) string
+ if (iostatus /= 0) exit READLOOP
+ if (string(1:1) == "#") cycle READLOOP
+ if (trim(string) == "") cycle READLOOP
+ indx = index(string,":")
+ if (indx <= 0) cycle READLOOP
+ name = trim(adjustl(string(1:indx-1)))
+
+ ! Here are the variables we expect to be defined in the URBPARM.TBL:
+ if (name == "Number of urban categories") then
+ read(string(indx+1:),*) icate
+ IF (.not. ALLOCATED(ZR_TBL)) then
+ ALLOCATE( ZR_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZR_TBL in urban_param_init')
+ ALLOCATE( SIGMA_ZED_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0)CALL wrf_error_fatal('Error allocating SIGMA_ZED_TBL in urban_param_init')
+ ALLOCATE( Z0C_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0C_TBL in urban_param_init')
+ ALLOCATE( Z0HC_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HC_TBL in urban_param_init')
+ ALLOCATE( ZDC_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZDC_TBL in urban_param_init')
+ ALLOCATE( SVF_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SVF_TBL in urban_param_init')
+ ALLOCATE( R_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating R_TBL in urban_param_init')
+ ALLOCATE( RW_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating RW_TBL in urban_param_init')
+ ALLOCATE( HGT_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HGT_TBL in urban_param_init')
+ ALLOCATE( AH_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AH_TBL in urban_param_init')
+ ALLOCATE( BETR_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETR_TBL in urban_param_init')
+ ALLOCATE( BETB_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETB_TBL in urban_param_init')
+ ALLOCATE( BETG_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETG_TBL in urban_param_init')
+ ALLOCATE( CAPR_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPR_TBL in urban_param_init')
+ ALLOCATE( CAPB_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPB_TBL in urban_param_init')
+ ALLOCATE( CAPG_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPG_TBL in urban_param_init')
+ ALLOCATE( AKSR_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSR_TBL in urban_param_init')
+ ALLOCATE( AKSB_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSB_TBL in urban_param_init')
+ ALLOCATE( AKSG_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSG_TBL in urban_param_init')
+ ALLOCATE( ALBR_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBR_TBL in urban_param_init')
+ ALLOCATE( ALBB_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBB_TBL in urban_param_init')
+ ALLOCATE( ALBG_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBG_TBL in urban_param_init')
+ ALLOCATE( EPSR_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSR_TBL in urban_param_init')
+ ALLOCATE( EPSB_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSB_TBL in urban_param_init')
+ ALLOCATE( EPSG_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSG_TBL in urban_param_init')
+ ALLOCATE( Z0R_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0R_TBL in urban_param_init')
+ ALLOCATE( Z0B_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0B_TBL in urban_param_init')
+ ALLOCATE( Z0G_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0G_TBL in urban_param_init')
+ ALLOCATE( AKANDA_URBAN_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKANDA_URBAN_TBL in urban_param_init')
+ ALLOCATE( Z0HB_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HB_TBL in urban_param_init')
+ ALLOCATE( Z0HG_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HG_TBL in urban_param_init')
+ ALLOCATE( TRLEND_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TRLEND_TBL in urban_param_init')
+ ALLOCATE( TBLEND_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TBLEND_TBL in urban_param_init')
+ ALLOCATE( TGLEND_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TGLEND_TBL in urban_param_init')
+ ALLOCATE( FRC_URB_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating FRC_URB_TBL in urban_param_init')
+ ! ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status )
+ ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init')
+ ! ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status )
+ ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init')
+ !for BEP
+ ALLOCATE( NUMDIR_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMDIR_TBL in urban_param_init')
+ ALLOCATE( STREET_DIRECTION_TBL(MAXDIRS , ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_DIRECTION_TBL in urban_param_init')
+ ALLOCATE( STREET_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_WIDTH_TBL in urban_param_init')
+ ALLOCATE( BUILDING_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BUILDING_WIDTH_TBL in urban_param_init')
+ ALLOCATE( NUMHGT_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMHGT_TBL in urban_param_init')
+ ALLOCATE( HEIGHT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HEIGHT_BIN_TBL in urban_param_init')
+ ALLOCATE( HPERCENT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HPERCENT_BIN_TBL in urban_param_init')
+ ALLOCATE( COP_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating COP_TBL in urban_param_init')
+ ALLOCATE( PWIN_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PWIN_TBL in urban_param_init')
+ ALLOCATE( BETA_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETA_TBL in urban_param_init')
+ ALLOCATE( SW_COND_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SW_COND_TBL in urban_param_init')
+ ALLOCATE( TIME_ON_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_ON_TBL in urban_param_init')
+ ALLOCATE( TIME_OFF_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_OFF_TBL in urban_param_init')
+ ALLOCATE( TARGTEMP_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGTEMP_TBL in urban_param_init')
+ ALLOCATE( GAPTEMP_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPTEMP_TBL in urban_param_init')
+ ALLOCATE( TARGHUM_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGHUM_TBL in urban_param_init')
+ ALLOCATE( GAPHUM_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPHUM_TBL in urban_param_init')
+ ALLOCATE( PERFLO_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PERFLO_TBL in urban_param_init')
+ ALLOCATE( HSESF_TBL(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HSESF_TBL in urban_param_init')
+ endif
+ numdir_tbl = 0
+ street_direction_tbl = -1.E36
+ street_width_tbl = 0
+ building_width_tbl = 0
+ numhgt_tbl = 0
+ height_bin_tbl = -1.E36
+ hpercent_bin_tbl = -1.E36
+!end BEP
+
+ else if (name == "ZR") then
+ read(string(indx+1:),*) zr_tbl(1:icate)
+ else if (name == "SIGMA_ZED") then
+ read(string(indx+1:),*) sigma_zed_tbl(1:icate)
+ else if (name == "ROOF_WIDTH") then
+ ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init')
+
+ read(string(indx+1:),*) roof_width(1:icate)
+ else if (name == "ROAD_WIDTH") then
+ ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status )
+! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init')
+ read(string(indx+1:),*) road_width(1:icate)
+ else if (name == "AH") then
+ read(string(indx+1:),*) ah_tbl(1:icate)
+ else if (name == "FRC_URB") then
+ read(string(indx+1:),*) frc_urb_tbl(1:icate)
+ else if (name == "CAPR") then
+ read(string(indx+1:),*) capr_tbl(1:icate)
+ ! Convert CAPR_TBL from J m{-3} K{-1} to cal cm{-3} deg{-1}
+ capr_tbl = capr_tbl * ( 1.0 / 4.1868 ) * 1.E-6
+ else if (name == "CAPB") then
+ read(string(indx+1:),*) capb_tbl(1:icate)
+ ! Convert CABR_TBL from J m{-3} K{-1} to cal cm{-3} deg{-1}
+ capb_tbl = capb_tbl * ( 1.0 / 4.1868 ) * 1.E-6
+ else if (name == "CAPG") then
+ read(string(indx+1:),*) capg_tbl(1:icate)
+ ! Convert CABG_TBL from J m{-3} K{-1} to cal cm{-3} deg{-1}
+ capg_tbl = capg_tbl * ( 1.0 / 4.1868 ) * 1.E-6
+ else if (name == "AKSR") then
+ read(string(indx+1:),*) aksr_tbl(1:icate)
+ ! Convert AKSR_TBL from J m{-1} s{-1} K{-1} to cal cm{-1} s{-1} deg{-1}
+ AKSR_TBL = AKSR_TBL * ( 1.0 / 4.1868 ) * 1.E-2
+ else if (name == "AKSB") then
+ read(string(indx+1:),*) aksb_tbl(1:icate)
+ ! Convert AKSB_TBL from J m{-1} s{-1} K{-1} to cal cm{-1} s{-1} deg{-1}
+ AKSB_TBL = AKSB_TBL * ( 1.0 / 4.1868 ) * 1.E-2
+ else if (name == "AKSG") then
+ read(string(indx+1:),*) aksg_tbl(1:icate)
+ ! Convert AKSG_TBL from J m{-1} s{-1} K{-1} to cal cm{-1} s{-1} deg{-1}
+ AKSG_TBL = AKSG_TBL * ( 1.0 / 4.1868 ) * 1.E-2
+ else if (name == "ALBR") then
+ read(string(indx+1:),*) albr_tbl(1:icate)
+ else if (name == "ALBB") then
+ read(string(indx+1:),*) albb_tbl(1:icate)
+ else if (name == "ALBG") then
+ read(string(indx+1:),*) albg_tbl(1:icate)
+ else if (name == "EPSR") then
+ read(string(indx+1:),*) epsr_tbl(1:icate)
+ else if (name == "EPSB") then
+ read(string(indx+1:),*) epsb_tbl(1:icate)
+ else if (name == "EPSG") then
+ read(string(indx+1:),*) epsg_tbl(1:icate)
+ else if (name == "AKANDA_URBAN") then
+ read(string(indx+1:),*) akanda_urban_tbl(1:icate)
+ else if (name == "Z0B") then
+ read(string(indx+1:),*) z0b_tbl(1:icate)
+ else if (name == "Z0G") then
+ read(string(indx+1:),*) z0g_tbl(1:icate)
+ else if (name == "DDZR") then
+ read(string(indx+1:),*) dzr(1:num_roof_layers)
+ ! Convert thicknesses from m to cm
+ dzr = dzr * 100.0
+ else if (name == "DDZB") then
+ read(string(indx+1:),*) dzb(1:num_wall_layers)
+ ! Convert thicknesses from m to cm
+ dzb = dzb * 100.0
+ else if (name == "DDZG") then
+ read(string(indx+1:),*) dzg(1:num_road_layers)
+ ! Convert thicknesses from m to cm
+ dzg = dzg * 100.0
+ else if (name == "BOUNDR") then
+ read(string(indx+1:),*) boundr_data
+ else if (name == "BOUNDB") then
+ read(string(indx+1:),*) boundb_data
+ else if (name == "BOUNDG") then
+ read(string(indx+1:),*) boundg_data
+ else if (name == "TRLEND") then
+ read(string(indx+1:),*) trlend_tbl(1:icate)
+ else if (name == "TBLEND") then
+ read(string(indx+1:),*) tblend_tbl(1:icate)
+ else if (name == "TGLEND") then
+ read(string(indx+1:),*) tglend_tbl(1:icate)
+ else if (name == "CH_SCHEME") then
+ read(string(indx+1:),*) ch_scheme_data
+ else if (name == "TS_SCHEME") then
+ read(string(indx+1:),*) ts_scheme_data
+ else if (name == "AHOPTION") then
+ read(string(indx+1:),*) ahoption
+ else if (name == "AHDIUPRF") then
+ read(string(indx+1:),*) ahdiuprf(1:24)
+!for BEP
+ else if (name == "STREET PARAMETERS") then
+
+ STREETLOOP : do
+ read(11,'(A512)', iostat=iostatus) string
+ if (string(1:1) == "#") cycle STREETLOOP
+ if (trim(string) == "") cycle STREETLOOP
+ if (string == "END STREET PARAMETERS") exit STREETLOOP
+ read(string, *) k ! , dirst, ws, bs
+ numdir_tbl(k) = numdir_tbl(k) + 1
+ read(string, *) k, street_direction_tbl(numdir_tbl(k),k), &
+ street_width_tbl(numdir_tbl(k),k), &
+ building_width_tbl(numdir_tbl(k),k)
+ enddo STREETLOOP
+
+ else if (name == "BUILDING HEIGHTS") then
+
+ read(string(indx+1:),*) k
+ HEIGHTLOOP : do
+ read(11,'(A512)', iostat=iostatus) string
+ if (string(1:1) == "#") cycle HEIGHTLOOP
+ if (trim(string) == "") cycle HEIGHTLOOP
+ if (string == "END BUILDING HEIGHTS") exit HEIGHTLOOP
+ read(string,*) dummy_hgt, dummy_pct
+ numhgt_tbl(k) = numhgt_tbl(k) + 1
+ height_bin_tbl(numhgt_tbl(k), k) = dummy_hgt
+ hpercent_bin_tbl(numhgt_tbl(k),k) = dummy_pct
+
+ enddo HEIGHTLOOP
+ pctsum = sum ( hpercent_bin_tbl(:,k) , mask=(hpercent_bin_tbl(:,k)>-1.E25 ) )
+ if ( pctsum /= 100.) then
+ write (*,'(//,"Building height percentages for category ", I2, " must sum to 100.0")') k
+ write (*,'("Currently, they sum to ", F6.2,/)') pctsum
+! CALL wrf_error_fatal('pctsum is not equal to 100.')
+ endif
+ else if ( name == "Z0R") then
+ read(string(indx+1:),*) Z0R_tbl(1:icate)
+ else if ( name == "COP") then
+ read(string(indx+1:),*) cop_tbl(1:icate)
+ else if ( name == "PWIN") then
+ read(string(indx+1:),*) pwin_tbl(1:icate)
+ else if ( name == "BETA") then
+ read(string(indx+1:),*) beta_tbl(1:icate)
+ else if ( name == "SW_COND") then
+ read(string(indx+1:),*) sw_cond_tbl(1:icate)
+ else if ( name == "TIME_ON") then
+ read(string(indx+1:),*) time_on_tbl(1:icate)
+ else if ( name == "TIME_OFF") then
+ read(string(indx+1:),*) time_off_tbl(1:icate)
+ else if ( name == "TARGTEMP") then
+ read(string(indx+1:),*) targtemp_tbl(1:icate)
+ else if ( name == "GAPTEMP") then
+ read(string(indx+1:),*) gaptemp_tbl(1:icate)
+ else if ( name == "TARGHUM") then
+ read(string(indx+1:),*) targhum_tbl(1:icate)
+ else if ( name == "GAPHUM") then
+ read(string(indx+1:),*) gaphum_tbl(1:icate)
+ else if ( name == "PERFLO") then
+ read(string(indx+1:),*) perflo_tbl(1:icate)
+ else if (name == "HSEQUIP") then
+ read(string(indx+1:),*) hsequip_tbl(1:24)
+ else if (name == "HSEQUIP_SCALE_FACTOR") then
+ read(string(indx+1:),*) hsesf_tbl(1:icate)
+!end BEP
+ else
+! CALL wrf_error_fatal('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT')
+ endif
+ enddo READLOOP
+
+ CLOSE(11)
+
+ ! Assign a few table values that do not need to come from URBPARM.TBL
+
+ Z0HB_TBL = 0.1 * Z0B_TBL
+ Z0HG_TBL = 0.1 * Z0G_TBL
+
+ DO LC = 1, ICATE
+
+ ! HGT: Normalized height
+ HGT_TBL(LC) = ZR_TBL(LC) / ( ROAD_WIDTH(LC) + ROOF_WIDTH(LC) )
+
+ ! R: Normalized Roof Width (a.k.a. "building coverage ratio")
+ R_TBL(LC) = ROOF_WIDTH(LC) / ( ROAD_WIDTH(LC) + ROOF_WIDTH(LC) )
+
+ RW_TBL(LC) = 1.0 - R_TBL(LC)
+ BETR_TBL(LC) = 0.0
+ BETB_TBL(LC) = 0.0
+ BETG_TBL(LC) = 0.0
+
+ ! The following urban canyon geometry parameters are following Macdonald's (1998) formulations
+
+ ! Lambda_P :: Plan areal fraction, which corresponds to R for a 2-d canyon.
+ ! Lambda_F :: Frontal area index, which corresponds to HGT for a 2-d canyon
+ ! Cd :: Drag coefficient ( 1.2 from Grimmond and Oke, 1998 )
+ ! Alpha_macd :: Emperical coefficient ( 4.43 from Macdonald et al., 1998 )
+ ! Beta_macd :: Correction factor for the drag coefficient ( 1.0 from Macdonald et al., 1998 )
+
+ Lambda_P = R_TBL(LC)
+ Lambda_F = HGT_TBL(LC)
+ Cd = 1.2
+ alpha_macd = 4.43
+ beta_macd = 1.0
+
+
+ ZDC_TBL(LC) = ZR_TBL(LC) * ( 1.0 + ( alpha_macd ** ( -Lambda_P ) ) * ( Lambda_P - 1.0 ) )
+
+ Z0C_TBL(LC) = ZR_TBL(LC) * ( 1.0 - ZDC_TBL(LC)/ZR_TBL(LC) ) * &
+ exp (-(0.5 * beta_macd * Cd / (VonK**2) * ( 1.0-ZDC_TBL(LC)/ZR_TBL(LC) ) * Lambda_F )**(-0.5))
+
+ IF (SF_URBAN_PHYSICS == 1) THEN
+ ! Include roof height variability in Macdonald
+ ! to parameterize Z0R as a function of ZR_SD (Standard Deviation)
+ Lambda_FR = SIGMA_ZED_TBL(LC) / ( ROAD_WIDTH(LC) + ROOF_WIDTH(LC) )
+ Z0R_TBL(LC) = ZR_TBL(LC) * ( 1.0 - ZDC_TBL(LC)/ZR_TBL(LC) ) &
+ * exp ( -(0.5 * beta_macd * Cd / (VonK**2) &
+ * ( 1.0-ZDC_TBL(LC)/ZR_TBL(LC) ) * Lambda_FR )**(-0.5))
+ ENDIF
+
+ !
+ ! Z0HC still one-tenth of Z0C, as before ?
+ !
+
+ Z0HC_TBL(LC) = 0.1 * Z0C_TBL(LC)
+
+ !
+ ! Calculate Sky View Factor:
+ !
+ DHGT=HGT_TBL(LC)/100.
+ HGT=0.
+ VFWS=0.
+ HGT=HGT_TBL(LC)-DHGT/2.
+ do k=1,99
+ HGT=HGT-DHGT
+ VFWS=VFWS+0.25*(1.-HGT/SQRT(HGT**2.+RW_TBL(LC)**2.))
+ end do
+
+ VFWS=VFWS/99.
+ VFWS=VFWS*2.
+
+ VFGS=1.-2.*VFWS*HGT_TBL(LC)/RW_TBL(LC)
+ SVF_TBL(LC)=VFGS
+ END DO
+
+ deallocate(roof_width)
+ deallocate(road_width)
+
+ END SUBROUTINE urban_param_init
+!===========================================================================
+!
+! subroutine urban_var_init: initialization of urban state variables
+!
+!===========================================================================
+ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, & ! in
+ ims,ime,jms,jme,kms,kme,num_soil_layers, & ! in
+! num_roof_layers,num_wall_layers,num_road_layers, & ! in
+ restart,sf_urban_physics, & !in
+ XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & ! inout
+ TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & ! inout
+ TRL_URB3D,TBL_URB3D,TGL_URB3D, & ! inout
+ SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, & ! inout
+ TS_URB2D, & ! inout
+ num_urban_layers, & ! in
+ TRB_URB4D,TW1_URB4D,TW2_URB4D,TGB_URB4D, & ! inout
+ TLEV_URB3D,QLEV_URB3D, & ! inout
+ TW1LEV_URB3D,TW2LEV_URB3D, & ! inout
+ TGLEV_URB3D,TFLEV_URB3D, & ! inout
+ SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D, & ! inout
+ SFVENT_URB3D,LFVENT_URB3D, & ! inout
+ SFWIN1_URB3D,SFWIN2_URB3D, & ! inout
+ SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D, & ! inout
+ A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & ! inout multi-layer urban
+ A_E_BEP,B_U_BEP,B_V_BEP, & ! inout multi-layer urban
+ B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP, & ! inout multi-layer urban
+ DL_U_BEP,SF_BEP,VL_BEP, & ! inout multi-layer urban
+ FRC_URB2D, UTYPE_URB2D) ! inout
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN) :: ISURBAN, sf_urban_physics
+ INTEGER, INTENT(IN) :: ims,ime,jms,jme,kms,kme,num_soil_layers
+ INTEGER, INTENT(IN) :: num_urban_layers !multi-layer urban
+! INTEGER, INTENT(IN) :: num_roof_layers, num_wall_layers, num_road_layers
+
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: TSURFACE0_URB
+ REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(IN) :: TLAYER0_URB
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: TDEEP0_URB
+ INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IVGTYP
+ LOGICAL , INTENT(IN) :: restart
+
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D
+
+! REAL, DIMENSION(ims:ime, 1:num_roof_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D
+! REAL, DIMENSION(ims:ime, 1:num_wall_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D
+! REAL, DIMENSION(ims:ime, 1:num_road_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D
+ REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D
+ REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D
+ REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D
+
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D
+
+! multi-layer UCM variables
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TRB_URB4D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW1_URB4D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW2_URB4D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TGB_URB4D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TLEV_URB3D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: QLEV_URB3D
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D
+ REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW1_URB3D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW2_URB3D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFR_URB3D
+ REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFG_URB3D
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_U_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_V_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_T_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_Q_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_E_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_U_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_V_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_T_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_Q_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_E_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: VL_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: DLG_BEP
+ REAL, DIMENSION(ims:ime, kms:kme,jms:jme),INTENT(INOUT) :: SF_BEP
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: DL_U_BEP
+!
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FRC_URB2D
+ INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UTYPE_URB2D
+ INTEGER :: UTYPE_URB
+
+ INTEGER :: I,J,K
+
+ DO I=ims,ime
+ DO J=jms,jme
+
+! XXXR_URB2D(I,J)=0.
+! XXXB_URB2D(I,J)=0.
+! XXXG_URB2D(I,J)=0.
+! XXXC_URB2D(I,J)=0.
+
+ SH_URB2D(I,J)=0.
+ LH_URB2D(I,J)=0.
+ G_URB2D(I,J)=0.
+ RN_URB2D(I,J)=0.
+
+!m
+ FRC_URB2D(I,J)=0.
+ UTYPE_URB2D(I,J)=0
+
+ IF( IVGTYP(I,J) == ISURBAN) THEN
+ UTYPE_URB2D(I,J) = 2 ! for default. high-intensity
+ UTYPE_URB = UTYPE_URB2D(I,J) ! for default. high-intensity
+ FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB)
+ ENDIF
+ IF( IVGTYP(I,J) == 31) THEN
+ UTYPE_URB2D(I,J) = 3 ! low-intensity residential
+ UTYPE_URB = UTYPE_URB2D(I,J) ! low-intensity residential
+ FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB)
+ ENDIF
+ IF( IVGTYP(I,J) == 32) THEN
+ UTYPE_URB2D(I,J) = 2 ! high-intensity
+ UTYPE_URB = UTYPE_URB2D(I,J) ! high-intensity
+ FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB)
+ ENDIF
+ IF( IVGTYP(I,J) == 33) THEN
+ UTYPE_URB2D(I,J) = 1 ! Commercial/Industrial/Transportation
+ UTYPE_URB = UTYPE_URB2D(I,J) ! Commercial/Industrial/Transportation
+ FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB)
+ ENDIF
+
+
+ QC_URB2D(I,J)=0.01
+
+ IF (.not.restart) THEN
+
+ XXXR_URB2D(I,J)=0.
+ XXXB_URB2D(I,J)=0.
+ XXXG_URB2D(I,J)=0.
+ XXXC_URB2D(I,J)=0.
+
+
+ TC_URB2D(I,J)=TSURFACE0_URB(I,J)+0.
+ TR_URB2D(I,J)=TSURFACE0_URB(I,J)+0.
+ TB_URB2D(I,J)=TSURFACE0_URB(I,J)+0.
+ TG_URB2D(I,J)=TSURFACE0_URB(I,J)+0.
+!
+ TS_URB2D(I,J)=TSURFACE0_URB(I,J)+0.
+
+! DO K=1,num_roof_layers
+! DO K=1,num_soil_layers
+! TRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0.
+! TRL_URB3D(I,2,J)=TLAYER0_URB(I,2,J)+0.
+! TRL_URB3D(I,3,J)=TLAYER0_URB(I,3,J)+0.
+! TRL_URB3D(I,4,J)=TLAYER0_URB(I,4,J)+0.
+
+ TRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0.
+ TRL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J))
+ TRL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0.
+ TRL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29
+! END DO
+
+! DO K=1,num_wall_layers
+! DO K=1,num_soil_layers
+!m TBL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0.
+!m TBL_URB3D(I,2,J)=TLAYER0_URB(I,2,J)+0.
+!m TBL_URB3D(I,3,J)=TLAYER0_URB(I,3,J)+0.
+!m TBL_URB3D(I,4,J)=TLAYER0_URB(I,4,J)+0.
+
+ TBL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0.
+ TBL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J))
+ TBL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0.
+ TBL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29
+
+! END DO
+
+! DO K=1,num_road_layers
+ DO K=1,num_soil_layers
+ TGL_URB3D(I,K,J)=TLAYER0_URB(I,K,J)+0.
+ END DO
+
+! multi-layer urban
+! IF( sf_urban_physics .EQ. 2)THEN
+ IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN
+ DO k=1,num_urban_layers
+! TRB_URB4D(I,k,J)=TSURFACE0_URB(I,J)
+! TW1_URB4D(I,k,J)=TSURFACE0_URB(I,J)
+! TW2_URB4D(I,k,J)=TSURFACE0_URB(I,J)
+! TGB_URB4D(I,k,J)=TSURFACE0_URB(I,J)
+!MT TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+!MT TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+!MT TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+ IF (UTYPE_URB2D(I,J) > 0) THEN
+ TRB_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J))
+ TW1_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J))
+ TW2_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J))
+ ELSE
+ TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+ TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+ TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+ ENDIF
+ TGB_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+ SFW1_URB3D(I,K,J)=0.
+ SFW2_URB3D(I,K,J)=0.
+ SFR_URB3D(I,K,J)=0.
+ SFG_URB3D(I,K,J)=0.
+ ENDDO
+
+ ENDIF
+
+ if (SF_URBAN_PHYSICS.EQ.3) then
+ LF_AC_URB3D(I,J)=0.
+ SF_AC_URB3D(I,J)=0.
+ CM_AC_URB3D(I,J)=0.
+ SFVENT_URB3D(I,J)=0.
+ LFVENT_URB3D(I,J)=0.
+
+ DO K=1,num_urban_layers
+ TLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+ TW1LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+ TW2LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+ TGLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+ TFLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+ QLEV_URB3D(I,K,J)=0.01
+ SFWIN1_URB3D(I,K,J)=0.
+ SFWIN2_URB3D(I,K,J)=0.
+!rm LF_AC_URB3D(I,J)=0.
+!rm SF_AC_URB3D(I,J)=0.
+!rm CM_AC_URB3D(I,J)=0.
+!rm SFVENT_URB3D(I,J)=0.
+!rm LFVENT_URB3D(I,J)=0.
+ ENDDO
+
+ endif
+
+! IF( sf_urban_physics .EQ. 2 )THEN
+ IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN
+ DO K= KMS,KME
+ SF_BEP(I,K,J)=1.
+ VL_BEP(I,K,J)=1.
+ A_U_BEP(I,K,J)=0.
+ A_V_BEP(I,K,J)=0.
+ A_T_BEP(I,K,J)=0.
+ A_E_BEP(I,K,J)=0.
+ A_Q_BEP(I,K,J)=0.
+ B_U_BEP(I,K,J)=0.
+ B_V_BEP(I,K,J)=0.
+ B_T_BEP(I,K,J)=0.
+ B_E_BEP(I,K,J)=0.
+ B_Q_BEP(I,K,J)=0.
+ DLG_BEP(I,K,J)=0.
+ DL_U_BEP(I,K,J)=0.
+ END DO
+ ENDIF !sf_urban_physics=2
+ ENDIF !restart
+ END DO
+ END DO
+ RETURN
+ END SUBROUTINE urban_var_init
+!===========================================================================
+!
+! force_restore
+!
+!===========================================================================
+ SUBROUTINE force_restore(CAP,AKS,DELT,S,R,H,LE,TSLEND,TSP,TS)
+
+ REAL, INTENT(IN) :: CAP,AKS,DELT,S,R,H,LE,TSLEND,TSP
+ REAL, INTENT(OUT) :: TS
+ REAL :: C1,C2
+
+ C2=24.*3600./2./3.14159
+ C1=SQRT(0.5*C2*CAP*AKS)
+
+ TS = TSP + DELT*( (S+R-H-LE)/C1 -(TSP-TSLEND)/C2 )
+
+ END SUBROUTINE force_restore
+!===========================================================================
+!
+! bisection (not used)
+!
+!==============================================================================
+ SUBROUTINE bisection(TSP,PS,S,EPS,RX,SIG,RHO,CP,CH,UA,QA,TA,EL,BET,AKS,TSL,DZ,TS)
+
+ REAL, INTENT(IN) :: TSP,PS,S,EPS,RX,SIG,RHO,CP,CH,UA,QA,TA,EL,BET,AKS,TSL,DZ
+ REAL, INTENT(OUT) :: TS
+ REAL :: ES,QS0,R,H,ELE,G0,F1,F
+
+ TS1 = TSP - 5.
+ TS2 = TSP + 5.
+
+ DO ITERATION = 1,22
+
+ ES=6.11*EXP( (2.5*10.**6./461.51)*(TS1-273.15)/(273.15*TS1) )
+ QS0=0.622*ES/(PS-0.378*ES)
+ R=EPS*(RX-SIG*(TS1**4.)/60.)
+ H=RHO*CP*CH*UA*(TS1-TA)*100.
+ ELE=RHO*EL*CH*UA*BET*(QS0-QA)*100.
+ G0=AKS*(TS1-TSL)/(DZ/2.)
+ F1= S + R - H - ELE - G0
+
+ TS=0.5*(TS1+TS2)
+
+ ES=6.11*EXP( (2.5*10.**6./461.51)*(TS-273.15)/(273.15*TS) )
+ QS0=0.622*ES/(PS-0.378*ES)
+ R=EPS*(RX-SIG*(TS**4.)/60.)
+ H=RHO*CP*CH*UA*(TS-TA)*100.
+ ELE=RHO*EL*CH*UA*BET*(QS0-QA)*100.
+ G0=AKS*(TS-TSL)/(DZ/2.)
+ F = S + R - H - ELE - G0
+
+ IF (F1*F > 0.0) THEN
+ TS1=TS
+ ELSE
+ TS2=TS
+ END IF
+
+ END DO
+
+ RETURN
+END SUBROUTINE bisection
+!===========================================================================
+
+SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SFCDIF_URB (Urban version of SFCDIF_off)
+! ----------------------------------------------------------------------
+! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS.
+! SEE CHEN ET AL (1997, BLM)
+! ----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ REAL WWST, WWST2, G, VKRM, EXCM, BETA, BTG, ELFC, WOLD, WNEW
+ REAL PIHF, EPSU2, EPSUST, EPSIT, EPSA, ZTMIN, ZTMAX, HPBL, &
+ & SQVISC
+ REAL RIC, RRIC, FHNEU, RFC,RLMO_THR, RFAC, ZZ, PSLMU, PSLMS, PSLHU, &
+ & PSLHS
+ REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS, ZLM, Z0, THZ0, THLM
+ REAL SFCSPD, AKANDA, AKMS, AKHS, ZU, ZT, RDZ, CXCH
+ REAL DTHV, DU2, BTGH, WSTAR2, USTAR, ZSLU, ZSLT, RLOGU, RLOGT
+ REAL RLMO, ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4
+!CC ......REAL ZTFC
+
+ REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, &
+ & RLMA
+
+ INTEGER ITRMX, ILECH, ITR
+ REAL, INTENT(OUT) :: CD
+ PARAMETER &
+ & (WWST = 1.2,WWST2 = WWST * WWST,G = 9.8,VKRM = 0.40, &
+ & EXCM = 0.001 &
+ & ,BETA = 1./270.,BTG = BETA * G,ELFC = VKRM * BTG &
+ & ,WOLD =.15,WNEW = 1. - WOLD,ITRMX = 05, &
+ & PIHF = 3.14159265/2.)
+ PARAMETER &
+ & (EPSU2 = 1.E-4,EPSUST = 0.07,EPSIT = 1.E-4,EPSA = 1.E-8 &
+ & ,ZTMIN = -5.,ZTMAX = 1.,HPBL = 1000.0 &
+ & ,SQVISC = 258.2)
+ PARAMETER &
+ & (RIC = 0.183,RRIC = 1.0/ RIC,FHNEU = 0.8,RFC = 0.191 &
+ & ,RLMO_THR = 0.001,RFAC = RIC / (FHNEU * RFC * RFC))
+
+! ----------------------------------------------------------------------
+! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS
+! ----------------------------------------------------------------------
+! LECH'S SURFACE FUNCTIONS
+! ----------------------------------------------------------------------
+ PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ)
+ PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.))
+ PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ)
+
+! ----------------------------------------------------------------------
+! PAULSON'S SURFACE FUNCTIONS
+! ----------------------------------------------------------------------
+ PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.))
+ PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) &
+ & +2.* ATAN (XX) &
+ &- PIHF
+ PSPMS (YY)= 5.* YY
+ PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5)
+
+! ----------------------------------------------------------------------
+! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND
+! OVER SOLID SURFACE (LAND, SEA-ICE).
+! ----------------------------------------------------------------------
+ PSPHS (YY)= 5.* YY
+
+! ----------------------------------------------------------------------
+! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1
+! C......ZTFC=0.1
+! CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT
+! ----------------------------------------------------------------------
+ ILECH = 0
+
+! ----------------------------------------------------------------------
+! ZILFC = - CZIL * VKRM * SQVISC
+! C.......ZT=Z0*ZTFC
+ ZU = Z0
+ RDZ = 1./ ZLM
+ CXCH = EXCM * RDZ
+ DTHV = THLM - THZ0
+
+! ----------------------------------------------------------------------
+! BELJARS CORRECTION OF USTAR
+! ----------------------------------------------------------------------
+ DU2 = MAX (SFCSPD * SFCSPD,EPSU2)
+!cc If statements to avoid TANGENT LINEAR problems near zero
+ BTGH = BTG * HPBL
+ IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
+ WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.)
+ ELSE
+ WSTAR2 = 0.0
+ END IF
+
+! ----------------------------------------------------------------------
+! ZILITINKEVITCH APPROACH FOR ZT
+! ----------------------------------------------------------------------
+ USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
+
+! ----------------------------------------------------------------------
+! KCL/TL Try Kanda approach instead (Kanda et al. 2007, JAMC)
+! ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0
+ ZT = EXP (2.0-AKANDA*(SQVISC**2 * USTAR * Z0)**0.25)* Z0
+
+ ZSLU = ZLM + ZU
+
+ ZSLT = ZLM + ZT
+ RLOGU = log (ZSLU / ZU)
+
+ RLOGT = log (ZSLT / ZT)
+
+ RLMO = ELFC * AKHS * DTHV / USTAR **3
+! ----------------------------------------------------------------------
+! 1./MONIN-OBUKKHOV LENGTH-SCALE
+! ----------------------------------------------------------------------
+ DO ITR = 1,ITRMX
+ ZETALT = MAX (ZSLT * RLMO,ZTMIN)
+ RLMO = ZETALT / ZSLT
+ ZETALU = ZSLU * RLMO
+ ZETAU = ZU * RLMO
+
+ ZETAT = ZT * RLMO
+ IF (ILECH .eq. 0) THEN
+ IF (RLMO .lt. 0.0)THEN
+ XLU4 = 1. -16.* ZETALU
+ XLT4 = 1. -16.* ZETALT
+ XU4 = 1. -16.* ZETAU
+
+ XT4 = 1. -16.* ZETAT
+ XLU = SQRT (SQRT (XLU4))
+ XLT = SQRT (SQRT (XLT4))
+ XU = SQRT (SQRT (XU4))
+
+ XT = SQRT (SQRT (XT4))
+
+ PSMZ = PSPMU (XU)
+ SIMM = PSPMU (XLU) - PSMZ + RLOGU
+ PSHZ = PSPHU (XT)
+ SIMH = PSPHU (XLT) - PSHZ + RLOGT
+ ELSE
+ ZETALU = MIN (ZETALU,ZTMAX)
+ ZETALT = MIN (ZETALT,ZTMAX)
+ PSMZ = PSPMS (ZETAU)
+ SIMM = PSPMS (ZETALU) - PSMZ + RLOGU
+ PSHZ = PSPHS (ZETAT)
+ SIMH = PSPHS (ZETALT) - PSHZ + RLOGT
+ END IF
+! ----------------------------------------------------------------------
+! LECH'S FUNCTIONS
+! ----------------------------------------------------------------------
+ ELSE
+ IF (RLMO .lt. 0.)THEN
+ PSMZ = PSLMU (ZETAU)
+ SIMM = PSLMU (ZETALU) - PSMZ + RLOGU
+ PSHZ = PSLHU (ZETAT)
+ SIMH = PSLHU (ZETALT) - PSHZ + RLOGT
+ ELSE
+ ZETALU = MIN (ZETALU,ZTMAX)
+ ZETALT = MIN (ZETALT,ZTMAX)
+ PSMZ = PSLMS (ZETAU)
+ SIMM = PSLMS (ZETALU) - PSMZ + RLOGU
+ PSHZ = PSLHS (ZETAT)
+ SIMH = PSLHS (ZETALT) - PSHZ + RLOGT
+ END IF
+! ----------------------------------------------------------------------
+! BELJAARS CORRECTION FOR USTAR
+! ----------------------------------------------------------------------
+ END IF
+ USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
+ !KCL/TL
+ !ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0
+ ZT = EXP (2.0-AKANDA*(SQVISC**2 * USTAR * Z0)**0.25)* Z0
+ ZSLT = ZLM + ZT
+ RLOGT = log (ZSLT / ZT)
+ USTARK = USTAR * VKRM
+ AKMS = MAX (USTARK / SIMM,CXCH)
+ AKHS = MAX (USTARK / SIMH,CXCH)
+!
+ IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
+ WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.)
+ ELSE
+ WSTAR2 = 0.0
+ END IF
+!-----------------------------------------------------------------------
+ RLMN = ELFC * AKHS * DTHV / USTAR **3
+!-----------------------------------------------------------------------
+! IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110
+!-----------------------------------------------------------------------
+ RLMA = RLMO * WOLD+ RLMN * WNEW
+!-----------------------------------------------------------------------
+ RLMO = RLMA
+
+ END DO
+
+ CD = USTAR*USTAR/SFCSPD**2
+! ----------------------------------------------------------------------
+ END SUBROUTINE SFCDIF_URB
+! ----------------------------------------------------------------------
+!===========================================================================
+END MODULE module_sf_urban
</font>
</pre>