Skip to content

Commit

Permalink
Update NCAR Reach routing for lakes
Browse files Browse the repository at this point in the history 
 * Add call to LEVELPOOL for NCAR Reach routing in the DRIVE_CHANNEL subroutine in module_channel_routing.F
 * Add update to DRIVE_CHANNEL interface to include RT_DOMAIN(did)%LAKEIDX for mapping links indices to lake indices
  • Loading branch information
@rcabell
rcabell committed Nov 20, 2019
1 parent 8466a7e commit 966df72
Show file tree
Hide file tree
Showing 2 changed files with 63 additions and 25 deletions.
14 changes: 7 additions & 7 deletions trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -985,16 +985,16 @@ subroutine driveChannelRouting(did)
RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, &
RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, &
RT_DOMAIN(did)%RETDEP_CHAN, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, &
RT_DOMAIN(did)%node_area &
RT_DOMAIN(did)%node_area, RT_DOMAIN(did)%LAKEIDX, &
#ifdef MPP_LAND
,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,&
RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,&
RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, &
RT_DOMAIN(did)%yw_mpp_nlinks &
, RT_DOMAIN(did)%LNLINKSL,RT_DOMAIN(did)%LLINKID &
, rt_domain(did)%gtoNode,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd &
RT_DOMAIN(did)%yw_mpp_nlinks, &
RT_DOMAIN(did)%LNLINKSL,RT_DOMAIN(did)%LLINKID, &
rt_domain(did)%gtoNode,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd, &
#endif
, rt_domain(did)%CH_LNKRT_SL &
,nlst_rt(did)%GwBaseSwCRT, gw2d(did)%ho, gw2d(did)%qgw_chanrt, &
rt_domain(did)%CH_LNKRT_SL, &
nlst_rt(did)%GwBaseSwCRT, gw2d(did)%ho, gw2d(did)%qgw_chanrt, &
nlst_rt(did)%gwChanCondSw, nlst_rt(did)%gwChanCondConstIn, &
nlst_rt(did)%gwChanCondConstOut,rt_domain(did)%velocity &
)
Expand Down
74 changes: 56 additions & 18 deletions trunk/NDHMS/Routing/module_channel_routing.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -699,7 +699,7 @@ Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, &
RESHT, HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, &
ORIFICEE, ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, &
dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN, &
NLINKSL, LINKID, node_area &
NLINKSL, LINKID, node_area, lake_lookup &
#ifdef MPP_LAND
, lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks &
, LNLINKSL, LLINKID &
Expand Down Expand Up @@ -792,8 +792,10 @@ Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, &
REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme
REAL*8, DIMENSION(NLAKES) :: QLLAKE8 !-- lateral inflow to lake in diffusion scheme
integer, intent(in), dimension(:) :: lake_lookup !-- inverse lake index for k->lake mapping
!-- Local Variables
INTEGER :: i,j,k,t,m,jj,kk,KRT,node
INTEGER :: i,j,k,t,m,jj,kk,KRT,node,l_idx
INTEGER :: DT_STEPS !-- number of timestep in routing
REAL :: Qup,Quc !--Q upstream Previous, Q Upstream Current, downstream Previous
REAL :: bo !--critical depth, bnd outflow just for testing
Expand All @@ -812,19 +814,28 @@ Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, &
real ywtmp(ixrt,jxrt)
integer LNLINKSL
integer, dimension(LNLINKSL) :: LLINKID
real*8, dimension(LNLINKSL) :: LQLateral
! real*4, dimension(LNLINKSL) :: LQLateral
real(kind=8), dimension(LNLINKSL) :: LQLateral
integer, dimension(:) :: toNodeInd
integer, dimension(:,:) :: gtoNode
integer :: nToNodeInd
real, dimension(nToNodeInd,2) :: gQLINK
real, allocatable,dimension(:) :: tmpQLAKEO, tmpQLAKEI, tmpRESHT
#else
real*8, dimension(NLINKS) :: LQLateral !--lateral flow
real(kind=8), dimension(NLINKS) :: LQLateral !--lateral flow
#endif
integer flag
integer :: n, kk2, nt, nsteps ! tmp
integer :: n, kk2, nt, nsteps ! tmp
#ifdef MPP_LAND
if(my_id == io_id) then
#endif
allocate(tmpQLAKEO(NLAKES))
allocate(tmpQLAKEI(NLAKES))
allocate(tmpRESHT(NLAKES))
#ifdef MPP_LAND
endif
#endif
QLAKEIP = 0
QLAKEI8 = 0
HLINKTMP = 0
Expand Down Expand Up @@ -932,6 +943,15 @@ Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, &
!---------- route other reaches, with upstream inflow
tmpQlink = 0.0
#ifdef MPP_LAND
if(my_id .eq. io_id) then
#endif
tmpQLAKEO = QLAKEO
tmpQLAKEI = QLAKEI
tmpRESHT = RESHT
#ifdef MPP_LAND
endif
#endif
do k = 1,NLINKSL
! if (ORDER(k) .gt. 1 ) then !-- exclude first order stream
Quc = 0.0
Expand Down Expand Up @@ -962,29 +982,41 @@ Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, &
end do ! do m
#endif
if(TYPEL(k) .eq. 1) then !--link is a reservoir
CALL LEVELPOOL(linkid(k),Quc, Qup, QLINK(k,1), &
QLateral(k), DT, RESHT(k), HRZAREA(k), WEIRH(k), LAKEMAXH(k), &
WEIRC(k), WEIRL(k), ORIFICEE(k), ORIFICEC(k), ORIFICEA(k))
elseif (channel_option .eq. 1) then !muskingum routing
if(TYPEL(k) == 1) then !--link is a reservoir
l_idx = lake_lookup(k)
if (l_idx >= 0) then !-- -999 if not a reservoir in the lookup table (belt-and-suspenders check)
print *, "CALL LEVELPOOL", l_idx,Quc, Qup, QLINK(k,2), QLateral(k), DT, &
RESHT(l_idx), HRZAREA(l_idx), WEIRH(l_idx), LAKEMAXH(l_idx), &
WEIRC(l_idx), WEIRL(l_idx), ORIFICEE(l_idx), ORIFICEC(l_idx), ORIFICEA(l_idx)
CALL LEVELPOOL(l_idx,Quc, Qup, QLINK(k,2), QLateral(k), DT, &
RESHT(l_idx), HRZAREA(l_idx), WEIRH(l_idx), LAKEMAXH(l_idx), &
WEIRC(l_idx), WEIRL(l_idx), ORIFICEE(l_idx), ORIFICEC(l_idx), ORIFICEA(l_idx))
QLAKEO(l_idx) = QLINK(k,2) !save outflow to lake
QLAKEI(l_idx) = Quc !save inflow to lake
end if
elseif (channel_option .eq. 1) then !muskingum routing
Km = MUSK(k)
X = MUSX(k)
tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plust lateral inflow
elseif (channel_option .eq. 2) then ! muskingum cunge
elseif (channel_option .eq. 2) then ! muskingum cunge
call SUBMUSKINGCUNGE(tmpQLINK(k,2), velocity(k), LINKID(k), &
Qup,Quc, QLINK(k,1), QLateral(k), DTRT_CH, So(k), &
CHANLEN(k), MannN(k), ChSSlp(k), Bw(k), Tw(k),Tw_CC(k), n_CC(k), HLINK(k) )
else
else
print *, "FATAL ERROR: no channel option selected"
call hydro_stop("In drive_CHANNEL() - no channel option selected")
endif
endif
! endif !!! order(1) .ne. 1
end do !--k links
#ifdef MPP_LAND
call updateLake_seq(RESHT,nlakes,tmpRESHT)
call updateLake_seq(QLAKEO,nlakes,tmpQLAKEO)
call updateLake_seq(QLAKEI,nlakes,tmpQLAKEI)
#endif
!yw check
! gQLINK = 0.0
! call ReachLS_write_io(tmpQLINK(:,2), gQLINK(:,2))
Expand All @@ -997,7 +1029,7 @@ Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, &
! endif
do k = 1, NLINKSL
if(TYPEL(k) .ne. 1) then
if(TYPEL(k) .ne. 2) then
QLINK(k,2) = tmpQLINK(k,2)
endif
QLINK(k,1) = QLINK(k,2) !assing link flow of current to be previous for next time step
Expand Down Expand Up @@ -1416,8 +1448,14 @@ Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, &
#endif
if (KT .eq. 1) KT = KT + 1
#ifdef MPP_LAND
if (my_id == io_id) then
if(allocated(tmpRESHT)) deallocate(tmpRESHT)
if(allocated(tmpQLAKEO)) deallocate(tmpQLAKEO)
if(allocated(tmpQLAKEI)) deallocate(tmpQLAKEI)
endif
#endif
end subroutine drive_CHANNEL
! ----------------------------------------------------------------
Expand Down

0 comments on commit 966df72

Please sign in to comment.