From 460e36c66716fd5f161a487dfd2ff8ecdf83466e Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Fri, 21 Jun 2019 13:40:50 -0600 Subject: [PATCH 01/47] Adding glacier code to NHM. Riparian code is made in duplicate executable at the moment. --- mizu/kwt_route.f90 | 17 +- prms/basin.f90 | 40 +- prms/basin_sum.f90 | 8 +- prms/basin_sumCopy.f90 | 911 ++++++++++ prms/climateflow.f90 | 38 +- prms/glacr_melt.f90 | 3068 ++++++++++++++++++++++++++++++++++ prms/ide_dist.f | 32 +- prms/mizuroute.f90 | 80 +- prms/mizurouteRip.f90 | 787 +++++++++ prms/muskingum_lake.f90 | 12 +- prms/muskingum_lakeCopy.f90 | 1471 ++++++++++++++++ prms/precip_1sta_laps.f90 | 23 +- prms/snowcomp.f90 | 735 +++++++- prms/soilzone.f90 | 75 +- prms/soltab.f90 | 8 +- prms/stream_tempCopy.f90 | 1839 ++++++++++++++++++++ prms/strmflow_in_outCopy.f90 | 108 ++ prms/temp_1sta_laps.f90 | 54 +- prms/temp_dist2.f90 | 10 +- prms/xyz_dist.f | 20 +- 20 files changed, 9143 insertions(+), 193 deletions(-) create mode 100644 prms/basin_sumCopy.f90 create mode 100644 prms/glacr_melt.f90 create mode 100644 prms/mizurouteRip.f90 create mode 100644 prms/muskingum_lakeCopy.f90 create mode 100644 prms/stream_tempCopy.f90 create mode 100644 prms/strmflow_in_outCopy.f90 diff --git a/mizu/kwt_route.f90 b/mizu/kwt_route.f90 index 109ac431..58b61f7e 100644 --- a/mizu/kwt_route.f90 +++ b/mizu/kwt_route.f90 @@ -471,17 +471,21 @@ SUBROUTINE QROUTE_RCH(IENS,JRCH, & ! input: array indices if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif ! check for negative flow IF (MINVAL(Q_JRCH).LT.0.0_dp) THEN - !ierr=20; message=trim(message)//'negative flow extracted from upstream reach'; return - NQ1 = SIZE(Q_JRCH) - DO n = 1, NQ1 - IF (Q_JRCH(n).LT.0.0_dp) Q_JRCH(n) = 1.d-100 - ENDDO + !ierr=20; message=trim(message)//'negative flow extracted from upstream reach'; return + NQ1 = SIZE(Q_JRCH) + DO n = 0,(NQ1-1) + IF (Q_JRCH(n).LT.0.0_dp) Q_JRCH(n) =1.d-100 + ENDDO ENDIF ! check if(JRCH==ixPrint) print*, 'JRCH, Q_JRCH = ', JRCH, Q_JRCH ELSE ! set flow in headwater reaches to modelled streamflow from time delay histogram RCHFLX(IENS,JRCH)%REACH_Q = RCHFLX(IENS,JRCH)%BASIN_QR(1) + IF (RCHFLX(IENS,JRCH)%REACH_Q.LT.0.0_dp) THEN + RCHFLX(IENS,JRCH)%REACH_Q = 1.d-100 + ENDIF + RCHFLX(IENS,JRCH)%REACH_Q = RCHFLX(IENS,JRCH)%BASIN_QR(1) RETURN ! no upstream reaches (routing for sub-basins done using time-delay histogram) ENDIF ! ---------------------------------------------------------------------------------------- @@ -902,7 +906,7 @@ SUBROUTINE QEXMUL_RCH(IENS,JRCH,T0,T1,& ! input if(ierr/=0)then; message=trim(message)//'problem allocating array QD and TD'; return; endif ! get reach index IR = NETOPO(JRCH)%UREACHI(1) - ! get flow in m2/s (scaled by with of downstream reach) + ! get flow in m2/s (scaled by width of downstream reach) QD(1) = RCHFLX(IENS,IR)%BASIN_QR(1)/RPARAM(JRCH)%R_WIDTH TD(1) = T1 if(JRCH == ixPrint) print*, 'special case: JRCH, IR = ', JRCH, IR @@ -1038,7 +1042,6 @@ SUBROUTINE QEXMUL_RCH(IENS,JRCH,T0,T1,& ! input ! check that we're not stuck in a continuous do loop IF (JUPS.EQ.JUPS_OLD .AND. ITIM(JUPS).EQ.ITIM_OLD) THEN ierr=20; message=trim(message)//'stuck in the continuous do-loop'; return - ! or have little flow HOW KNOW THAT FIX EXIT ENDIF ! save jups and itim(jups) to check that we don't get stuck in a continuous do-loop diff --git a/prms/basin.f90 b/prms/basin.f90 index 069d91cf..99489654 100644 --- a/prms/basin.f90 +++ b/prms/basin.f90 @@ -29,6 +29,8 @@ MODULE PRMS_BASIN REAL, SAVE, ALLOCATABLE :: Dprst_area_max(:) REAL, SAVE, ALLOCATABLE :: Hru_perv(:), Hru_imperv(:) REAL, SAVE, ALLOCATABLE :: Dprst_area_open_max(:), Dprst_area_clos_max(:) + REAL, SAVE, ALLOCATABLE :: Hru_elev_ts(:) + DOUBLE PRECISION, SAVE :: Basin_gl_cfs, Basin_gl_ice_cfs ! Declared Parameters INTEGER, SAVE :: Elev_units INTEGER, SAVE, ALLOCATABLE :: Hru_type(:), Cov_type(:) @@ -67,7 +69,8 @@ END FUNCTION basin INTEGER FUNCTION basdecl() USE PRMS_BASIN USE PRMS_MODULE, ONLY: Model, Nhru, Dprst_flag, Lake_route_flag, & - & Et_flag, Precip_flag, Nlake, Cascadegw_flag, Stream_temp_flag, PRMS4_flag + & Et_flag, Precip_flag, Nlake, Cascadegw_flag, Stream_temp_flag, & + & PRMS4_flag, Cascade_flag, Glacier_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declparam, declvar @@ -80,6 +83,21 @@ INTEGER FUNCTION basdecl() MODNAME = 'basin' ! Declared Variables + ALLOCATE ( Hru_elev_ts(Nhru) ) + IF ( Glacier_flag==1 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'hru_elev_ts', 'nhru', Nhru, 'real', & + & 'HRU elevation for timestep, which can change for glaciers', & + & 'elev_units', Hru_elev_ts)/=0 ) CALL read_error(3, 'hru_elev_ts') + + IF ( declvar(MODNAME, 'basin_gl_ice_cfs', 'one', 1, 'double', & + & 'Basin glacier ice (firn) melt leaving the basin through the stream network', & + & 'cfs', Basin_gl_ice_cfs)/=0 ) CALL read_error(3, 'basin_gl_ice_cfs') + + IF ( declvar(MODNAME, 'basin_gl_cfs', 'one', 1, 'double', & + & 'Basin glacier surface melt (rain, snow, ice) leaving the basin through the stream network', & + & 'cfs', Basin_gl_cfs)/=0 ) CALL read_error(3, 'basin_gl_cfs') + ENDIF + ALLOCATE ( Hru_imperv(Nhru) ) IF ( declvar(MODNAME, 'hru_imperv', 'nhru', Nhru, 'real', & & 'Area of HRU that is impervious', & @@ -186,8 +204,8 @@ INTEGER FUNCTION basdecl() ALLOCATE ( Hru_type(Nhru) ) IF ( declparam(MODNAME, 'hru_type', 'nhru', 'integer', & - & '1', '0', '3', & - & 'HRU type', 'Type of each HRU (0=inactive; 1=land; 2=lake; 3=swale)', & + & '1', '0', '4', & + & 'HRU type', 'Type of each HRU (0=inactive; 1=land; 2=lake; 3=swale; 4=glacier)', & & 'none')/=0 ) CALL read_error(1, 'hru_type') ALLOCATE ( Cov_type(Nhru) ) @@ -246,7 +264,8 @@ INTEGER FUNCTION basinit() USE PRMS_BASIN USE PRMS_MODULE, ONLY: Nhru, Nlake, Dprst_flag, PRMS4_flag, & & Print_debug, Model, PRMS_VERSION, Starttime, Endtime, & - & Lake_route_flag, Et_flag, Precip_flag, Cascadegw_flag, Parameter_check_flag, Stream_temp_flag + & Lake_route_flag, Et_flag, Precip_flag, Cascadegw_flag, Parameter_check_flag, & + & Stream_temp_flag, Frozen_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: getparam @@ -262,6 +281,7 @@ INTEGER FUNCTION basinit() IF ( getparam(MODNAME, 'hru_area', Nhru, 'real', Hru_area)/=0 ) CALL read_error(2, 'hru_area') IF ( getparam(MODNAME, 'hru_elev', Nhru, 'real', Hru_elev)/=0 ) CALL read_error(2, 'hru_elev') + Hru_elev_ts = Hru_elev IF ( getparam(MODNAME, 'hru_lat', Nhru, 'real', Hru_lat)/=0 ) CALL read_error(2, 'hru_lat') IF ( getparam(MODNAME, 'hru_type', Nhru, 'integer', Hru_type)/=0 ) CALL read_error(2, 'hru_type') IF ( getparam(MODNAME, 'cov_type', Nhru, 'integer', Cov_type)/=0 ) CALL read_error(2, 'cov_type') @@ -308,6 +328,8 @@ INTEGER FUNCTION basinit() Lake_hru_id = 0 ENDIF + Basin_gl_cfs = 0.0D0 + Basin_gl_ice_cfs = 0.0D0 IF ( Dprst_flag==1 ) THEN Dprst_frac_clos = 0.0 Dprst_area_open_max = 0.0 @@ -354,12 +376,20 @@ INTEGER FUNCTION basinit() Hru_imperv(i) = 0.0 Hru_perv(i) = harea ELSE - Land_area = Land_area + harea_dble ! swale or land + Land_area = Land_area + harea_dble ! swale or land or glacier IF ( Lake_hru_id(i)>0 ) THEN PRINT *, 'ERROR, HRU:', i, ' specifed to be a lake by lake_hru_id but hru_type not equal 2' basinit = 1 CYCLE ENDIF + IF ( Frozen_flag==1 ) THEN + IF ( Hru_type(i)==3 ) THEN + PRINT *, 'ERROR, a swale HRU cannot be frozen for CFGI, HRU:', i + basinit = 1 + CYCLE + ENDIF + ENDIF + ENDIF Basin_lat = Basin_lat + DBLE( Hru_lat(i)*harea ) diff --git a/prms/basin_sum.f90 b/prms/basin_sum.f90 index ff0309eb..6ccf8a46 100644 --- a/prms/basin_sum.f90 +++ b/prms/basin_sum.f90 @@ -445,6 +445,7 @@ INTEGER FUNCTION sumbinit() & Basin_gwstor + Basin_ssstor + Basin_pweqv + & & Basin_imperv_stor + Basin_lake_stor + & & Basin_dprst_volop + Basin_dprst_volcl +!glacier storage not known at start IF ( Print_freq/=0 ) THEN CALL header_print(Print_type) @@ -473,7 +474,7 @@ END FUNCTION sumbinit !*********************************************************************** INTEGER FUNCTION sumbrun() USE PRMS_BASINSUM - USE PRMS_MODULE, ONLY: Print_debug, Nobs, End_year, Strmflow_flag + USE PRMS_MODULE, ONLY: Print_debug, Nobs, End_year, Strmflow_flag, Glacier_flag USE PRMS_BASIN, ONLY: Active_area, Active_hrus, Hru_route_order USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_lakeevap, & & Basin_actet, Basin_perv_et, Basin_swale_et, Hru_actet, & @@ -484,6 +485,7 @@ INTEGER FUNCTION sumbrun() USE PRMS_GWFLOW, ONLY: Basin_gwflow, Basin_gwstor, Basin_gwsink, Basin_gwstor_minarea_wb USE PRMS_INTCP, ONLY: Basin_intcp_evap, Basin_intcp_stor, Basin_net_ppt USE PRMS_SNOW, ONLY: Basin_snowmelt, Basin_pweqv, Basin_snowevap + USE PRMS_GLACR, ONLY: Basin_gl_storage USE PRMS_SRUNOFF, ONLY: Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, & & Basin_dprst_evap, Basin_dprst_volcl, Basin_dprst_volop USE PRMS_ROUTING, ONLY: Basin_segment_storage @@ -511,6 +513,10 @@ INTEGER FUNCTION sumbrun() Basin_storage = Basin_soil_moist + Basin_intcp_stor + & & Basin_gwstor + Basin_ssstor + Basin_pweqv + & & Basin_imperv_stor + Basin_lake_stor + Basin_dprst_volop + Basin_dprst_volcl +! Basin_storage doesn't include any processes on glacier +! In glacier module, Basin_gl_storstart is an estimate for starting glacier volume, but only +! includes glaciers that have depth estimates and these are known to be iffy + IF ( Glacier_flag==1 ) Basin_storage = Basin_storage + Basin_gl_storage IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 ) Basin_storage = Basin_storage + Basin_segment_storage ! volume calculation for storage diff --git a/prms/basin_sumCopy.f90 b/prms/basin_sumCopy.f90 new file mode 100644 index 00000000..6ccf8a46 --- /dev/null +++ b/prms/basin_sumCopy.f90 @@ -0,0 +1,911 @@ +!*********************************************************************** +! Computes daily, monthly, yearly, and total flow summaries of volumes +! and flows for all HRUs +!*********************************************************************** + MODULE PRMS_BASINSUM + IMPLICIT NONE +! Local Variables + INTEGER, SAVE :: BALUNT, Totdays + CHARACTER(LEN=9), SAVE :: MODNAME + INTEGER, SAVE :: Header_prt, Endjday + CHARACTER(LEN=32) :: Buffer32 + CHARACTER(LEN=40) :: Buffer40 + CHARACTER(LEN=48) :: Buffer48 + CHARACTER(LEN=80) :: Buffer80 + CHARACTER(LEN=120) :: Buffer120 + CHARACTER(LEN=151) :: Buffer151 + CHARACTER(LEN=151), PARAMETER :: DASHS = ' --------------------------------------------------------'// & + & '----------------------------------------------------------------------------------------------' + CHARACTER(LEN=151), PARAMETER :: STARS = ' ********************************************************'// & + & '**********************************************************************************************' + CHARACTER(LEN=151), PARAMETER :: EQULS = ' ========================================================'// & + & '==============================================================================================' + LOGICAL, SAVE :: Dprt, Mprt, Yprt, Tprt + DOUBLE PRECISION, SAVE :: Basin_swrad_yr, Basin_swrad_tot, Basin_swrad_mo +! Declared Variables + DOUBLE PRECISION, SAVE :: Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot + DOUBLE PRECISION, SAVE :: Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot + DOUBLE PRECISION, SAVE :: Basin_net_ppt_yr, Basin_net_ppt_tot, Watbal_sum + DOUBLE PRECISION, SAVE :: Basin_max_temp_yr, Basin_max_temp_tot + DOUBLE PRECISION, SAVE :: Basin_min_temp_yr, Basin_min_temp_tot + DOUBLE PRECISION, SAVE :: Basin_potet_yr, Basin_potet_tot + DOUBLE PRECISION, SAVE :: Basin_actet_yr, Basin_actet_tot + DOUBLE PRECISION, SAVE :: Basin_snowmelt_yr, Basin_snowmelt_tot + DOUBLE PRECISION, SAVE :: Basin_gwflow_yr, Basin_gwflow_tot + DOUBLE PRECISION, SAVE :: Basin_ssflow_yr, Basin_ssflow_tot + DOUBLE PRECISION, SAVE :: Basin_sroff_yr, Basin_sroff_tot + DOUBLE PRECISION, SAVE :: Basin_stflow_yr, Basin_stflow_tot + DOUBLE PRECISION, SAVE :: Basin_ppt_yr, Basin_ppt_tot, Last_basin_stor + DOUBLE PRECISION, SAVE :: Basin_intcp_evap_yr, Basin_intcp_evap_tot, Basin_lakeevap_yr + DOUBLE PRECISION, SAVE :: Obsq_inches_yr, Obsq_inches_tot + DOUBLE PRECISION, SAVE :: Basin_net_ppt_mo, Obsq_inches_mo + DOUBLE PRECISION, SAVE :: Basin_max_temp_mo, Basin_min_temp_mo + DOUBLE PRECISION, SAVE :: Basin_actet_mo + DOUBLE PRECISION, SAVE :: Basin_snowmelt_mo, Basin_gwflow_mo + DOUBLE PRECISION, SAVE :: Basin_sroff_mo, Basin_stflow_mo + DOUBLE PRECISION, SAVE :: Basin_intcp_evap_mo, Basin_storage + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_et_yr(:) + DOUBLE PRECISION, SAVE :: Basin_storvol, Basin_potet_mo + DOUBLE PRECISION, SAVE :: Basin_ssflow_mo, Basin_ppt_mo + DOUBLE PRECISION, SAVE :: Obsq_inches + DOUBLE PRECISION, SAVE :: Basin_runoff_ratio, Basin_runoff_ratio_mo + DOUBLE PRECISION, SAVE :: Basin_lakeevap_mo +! Declared Parameters + INTEGER, SAVE :: Print_type, Print_freq, Outlet_sta + END MODULE PRMS_BASINSUM + +!*********************************************************************** +! Main basin_sum routine +!*********************************************************************** + INTEGER FUNCTION basin_sum() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: sumbdecl, sumbinit, sumbrun + EXTERNAL :: basin_sum_restart +!*********************************************************************** + basin_sum = 0 + + IF ( Process(:3)=='run' ) THEN + basin_sum = sumbrun() + ELSEIF ( Process(:4)=='decl' ) THEN + basin_sum = sumbdecl() + ELSEIF ( Process(:4)=='init' ) THEN + basin_sum = sumbinit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL basin_sum_restart(0) + ENDIF + + END FUNCTION basin_sum + +!*********************************************************************** +! sumbdecl - set up basin summary parameters +! Declared Parameters +! print_type, print_freq, outlet_sta +!*********************************************************************** + INTEGER FUNCTION sumbdecl() + USE PRMS_BASINSUM + USE PRMS_MODULE, ONLY: Model, Nhru, Nobs + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_basin_sum +!*********************************************************************** + sumbdecl = 0 + + Version_basin_sum = 'basin_sum.f90 2017-10-21 14:18:00Z' + CALL print_module(Version_basin_sum, 'Summary ', 90) + MODNAME = 'basin_sum' + + IF ( declvar(MODNAME, 'last_basin_stor', 'one', 1, 'double', & + & 'Basin area-weighted average storage in all water storage reservoirs from previous time step', & + & 'inches', Last_basin_stor)/=0 ) CALL read_error(3, 'last_basin_stor') + IF ( declvar(MODNAME, 'watbal_sum', 'one', 1, 'double', & + & 'Water balance aggregate', & + & 'inches', Watbal_sum)/=0 ) CALL read_error(3, 'watbal_sum') + IF ( declvar(MODNAME, 'obs_runoff_mo', 'one', 1, 'double', & + & 'Monthly measured streamflow at basin outlet', & + & 'cfs', Obs_runoff_mo)/=0 ) CALL read_error(3, 'obs_runoff_mo') + IF ( declvar(MODNAME, 'basin_cfs_mo', 'one', 1, 'double', & + & 'Monthly total streamflow to stream network', & + & 'cfs', Basin_cfs_mo)/=0 ) CALL read_error(3, 'basin_cfs_mo') + IF ( declvar(MODNAME, 'obs_runoff_yr', 'one', 1, 'double', & + & 'Yearly measured streamflow at basin outlet', & + & 'cfs', Obs_runoff_yr)/=0 ) CALL read_error(3, 'obs_runoff_yr') + IF ( declvar(MODNAME, 'basin_cfs_yr', 'one', 1, 'double', & + & 'Yearly total streamflow to stream network', & + & 'cfs', Basin_cfs_yr)/=0 ) CALL read_error(3, 'basin_cfs_yr') + IF ( declvar(MODNAME, 'basin_net_ppt_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average net precipitation', & + & 'inches', Basin_net_ppt_yr)/=0 ) CALL read_error(3, 'basin_net_ppt_yr') + IF ( declvar(MODNAME, 'basin_max_temp_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average maximum temperature', & + & 'temp_units', Basin_max_temp_yr)/=0) CALL read_error(3,'basin_max_temp_yr') + IF ( declvar(MODNAME, 'basin_min_temp_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average minimum temperature', & + & 'temp_units', Basin_min_temp_yr)/=0) CALL read_error(3,'basin_min_temp_yr') + IF ( declvar(MODNAME, 'basin_potet_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average potential ET', & + & 'temp_units', Basin_potet_yr)/=0 ) CALL read_error(3, 'basin_potet_yr') + IF ( declvar(MODNAME, 'basin_actet_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average actual ET', & + & 'inches', Basin_actet_yr)/=0 ) CALL read_error(3, 'basin_actet_yr') + IF ( declvar(MODNAME, 'basin_snowmelt_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average snowmelt', & + & 'inches', Basin_snowmelt_yr)/=0) CALL read_error(3,'basin_snowmelt_yr') + IF ( declvar(MODNAME, 'basin_gwflow_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average groundwater discharge', & + & 'inches', Basin_gwflow_yr)/=0 ) CALL read_error(3, 'basin_gwflow_yr') + IF ( declvar(MODNAME, 'basin_ssflow_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average interflow', & + & 'inches', Basin_ssflow_yr)/=0 ) CALL read_error(3, 'basin_ssflow_yr') + IF ( declvar(MODNAME, 'basin_sroff_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average overland runoff', & + & 'inches', Basin_sroff_yr)/=0 ) CALL read_error(3, 'basin_sroff_yr') + IF ( declvar(MODNAME, 'basin_ppt_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average precipitation', & + & 'inches', Basin_ppt_yr)/=0 ) CALL read_error(3, 'basin_ppt_yr') + IF ( declvar(MODNAME, 'basin_stflow_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average streamflow', & + & 'inches', Basin_stflow_yr)/=0 ) CALL read_error(3, 'basin_stflow_yr') + IF ( declvar(MODNAME, 'obsq_inches_yr', 'one', 1, 'double', & + & 'Yearly measured streamflow at specified outlet station', & + & 'inches', Obsq_inches_yr)/=0 ) CALL read_error(3, 'obsq_inches_yr') + IF ( declvar(MODNAME, 'basin_intcp_evap_yr', 'one', 1, 'double', & + & 'Yearly basin area-weighted average canopy evaporation', & + & 'inches', Basin_intcp_evap_yr)/=0 ) CALL read_error(3, 'basin_intcp_evap_yr') + IF ( declvar(MODNAME, 'obs_runoff_tot', 'one', 1, 'double', & + & 'Total simulation measured streamflow at basin outlet', & + & 'cfs', Obs_runoff_tot)/=0 ) CALL read_error(3, 'obs_runoff_tot') + IF ( declvar(MODNAME, 'basin_cfs_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average streamflow', & + & 'inches', Basin_cfs_tot)/=0 ) CALL read_error(3, 'basin_cfs_tot') + IF ( declvar(MODNAME, 'basin_ppt_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average precipitation', & + & 'inches', Basin_ppt_tot)/=0 ) CALL read_error(3, 'basin_ppt_tot') + IF ( declvar(MODNAME, 'basin_max_temp_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average maximum temperature', & + & 'temp_units', Basin_max_temp_tot)/=0 ) CALL read_error(3, 'basin_max_temp_tot') + IF ( declvar(MODNAME, 'basin_min_temp_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average minimum temperature', & + & 'temp_units', Basin_min_temp_tot)/=0 ) CALL read_error(3, 'basin_min_temp_tot') + IF ( declvar(MODNAME, 'basin_potet_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average potential ET', & + & 'inches', Basin_potet_tot)/=0 ) CALL read_error(3, 'basin_potet_tot') + IF ( declvar(MODNAME, 'basin_actet_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average actual ET', & + & 'inches', Basin_actet_tot)/=0 ) CALL read_error(3, 'basin_actet_tot') + IF ( declvar(MODNAME, 'basin_snowmelt_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average snowmelt', & + & 'inches', Basin_snowmelt_tot)/=0 ) CALL read_error(3, 'basin_snowmelt_tot') + IF ( declvar(MODNAME, 'basin_gwflow_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average groundwater discharge' , & + & 'inches', Basin_gwflow_tot)/=0 ) CALL read_error(3, 'basin_gwflow_tot') + IF ( declvar(MODNAME, 'basin_ssflow_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average interflow', & + & 'inches', Basin_ssflow_tot)/=0 ) CALL read_error(3, 'basin_ssflow_tot') + IF ( declvar(MODNAME, 'basin_sroff_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average overland flow', & + & 'inches', Basin_sroff_tot)/=0 ) CALL read_error(3, 'basin_sroff_tot') + IF ( declvar(MODNAME, 'basin_stflow_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average streamflow', & + & 'inches', Basin_stflow_tot)/=0 ) CALL read_error(3, 'basin_stflow_tot') + IF ( declvar(MODNAME, 'obsq_inches_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average measured streamflow at specified outlet station', & + & 'inches', Obsq_inches_tot)/=0 ) CALL read_error(3, 'obsq_inches_tot') + IF ( declvar(MODNAME, 'basin_intcp_evap_tot', 'one', 1, 'double', & + & 'Total simulation basin area-weighted average canopy evaporation', & + & 'inches', Basin_intcp_evap_tot)/=0 ) CALL read_error(3, 'basin_intcp_evap_tot') + +! declare parameters + IF ( Nobs>0 .OR. Model==99 ) THEN + IF ( declparam(MODNAME, 'outlet_sta', 'one', 'integer', & + & '0', 'bounded', 'nobs', & + & 'Index of measurement station to use for basin outlet', & + & 'Index of measured streamflow station corresponding to the basin outlet', & + & 'none')/=0 ) CALL read_error(1, 'outlet_sta') + ENDIF + + IF ( declparam(MODNAME, 'print_type', 'one', 'integer', & + & '1', '0', '2', & + & 'Type of output written to output file', & + & 'Flag to select the type of results written to the output'// & + & ' file (0=measured and simulated flow only;'// & + & ' 1=water balance table; 2=detailed output)', & + & 'none')/=0 ) CALL read_error(1, 'print_type') + + IF ( declparam(MODNAME, 'print_freq', 'one', 'integer', & + & '3', '0', '15', & + & 'Frequency for the output frequency', & + & 'Flag to select the output frequency; for combinations,'// & + & ' add index numbers, e.g., daily plus yearly = 10;'// & + & ' yearly plus total = 3 (0=none; 1=run totals; 2=yearly;'// & + & ' 4=monthly; 8=daily; or additive combinations)', & + & 'none')/=0 ) CALL read_error(1, 'print_freq') + + IF ( declvar(MODNAME, 'basin_intcp_evap_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average interception evaporation', & + & 'inches', Basin_intcp_evap_mo)/=0 ) CALL read_error(3, 'basin_intcp_evap_mo') + + IF ( declvar(MODNAME, 'basin_storage', 'one', 1, 'double', & + & 'Basin area-weighted average storage in all water storage reservoirs', & + & 'inches', Basin_storage)/=0 ) CALL read_error(3, 'basin_storage') + +!******************basin_storage volume: + IF ( declvar(MODNAME, 'basin_storvol', 'one', 1, 'double', & + & 'Basin area-weighted average storage volume in all water storage reservoirs', & + & 'acre-inches', Basin_storvol)/=0 ) CALL read_error(3, 'basin_storvol') + + IF ( declvar(MODNAME, 'obsq_inches', 'one', 1, 'double', & + & 'Measured streamflow at specified outlet station', & + & 'inches', Obsq_inches)/=0 ) CALL read_error(3, 'obsq_inches') + + IF ( declvar(MODNAME, 'basin_ppt_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average precipitation', & + & 'inches', Basin_ppt_mo)/=0 ) CALL read_error(3, 'basin_ppt_mo') + + IF ( declvar(MODNAME, 'basin_net_ppt_mo', 'one', 1, 'double', & + & 'Monthly area-weighted average net precipitation', & + & 'inches', Basin_net_ppt_mo)/=0 ) CALL read_error(3, 'basin_net_ppt_mo') + + IF ( declvar(MODNAME, 'basin_max_temp_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average maximum air temperature', & + & 'temp_units', Basin_max_temp_mo)/=0 ) CALL read_error(3, 'basin_max_temp_mo') + + IF ( declvar(MODNAME, 'basin_min_temp_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average minimum air temperature', & + & 'temp_units', Basin_min_temp_mo)/=0 ) CALL read_error(3, 'basin_min_temp_mo') + + IF ( declvar(MODNAME, 'basin_potet_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average potential ET', & + & 'inches', Basin_potet_mo)/=0 ) CALL read_error(3, 'basin_potet_mo') + + IF ( declvar(MODNAME, 'basin_actet_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average actual ET', & + & 'inches', Basin_actet_mo)/=0 ) CALL read_error(3, 'basin_actet_mo') + + IF ( declvar(MODNAME, 'basin_snowmelt_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average snowmelt', & + & 'inches', Basin_snowmelt_mo)/=0 ) CALL read_error(3, 'basin_snowmelt_mo') + + IF ( declvar(MODNAME, 'basin_gwflow_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average groundwater discharge', & + & 'inches', Basin_gwflow_mo)/=0 ) CALL read_error(3, 'basin_gwflow_mo') + + IF ( declvar(MODNAME, 'basin_ssflow_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average interflow', & + & 'inches', Basin_ssflow_mo)/=0 ) CALL read_error(3, 'basin_ssflow_mo') + + IF ( declvar(MODNAME, 'basin_sroff_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average surface runoff', & + & 'inches', Basin_sroff_mo)/=0 ) CALL read_error(3, 'basin_sroff_mo') + + IF ( declvar(MODNAME, 'basin_stflow_mo', 'one', 1, 'double', & + & 'Monthly basin area-weighted average simulated streamflow', & + & 'inches', Basin_stflow_mo)/=0 ) CALL read_error(3, 'basin_stflow_mo') + + IF ( declvar(MODNAME, 'obsq_inches_mo', 'one', 1, 'double', & + & 'Monthly measured streamflow at specified outlet station', & + & 'inches', Obsq_inches_mo)/=0 ) CALL read_error(3, 'obsq_inches_mo') + + ALLOCATE ( Hru_et_yr(Nhru) ) + IF ( declvar(MODNAME, 'hru_et_yr', 'nhru', Nhru, 'double', & + & 'Yearly area-weighted average actual ET for each HRU', & + & 'inches', Hru_et_yr)/=0 ) CALL read_error(3, 'hru_et_yr') + + IF ( declvar(MODNAME, 'basin_runoff_ratio_mo', 'one', 1, 'double', & + & 'Monthly area-weighted average discharge/precipitation', & + & 'decimal fraction', Basin_runoff_ratio_mo)/=0 ) CALL read_error(3, 'basin_runoff_ratio_mo') + + IF ( declvar(MODNAME, 'basin_runoff_ratio', 'one', 1, 'double', & + & 'Basin area-weighted average discharge/precipitation', & + & 'decimal fraction', Basin_runoff_ratio)/=0 ) CALL read_error(3, 'basin_runoff_ratio') + + END FUNCTION sumbdecl + +!*********************************************************************** +! sumbinit - Initialize basinsum module - get parameter values +!*********************************************************************** + INTEGER FUNCTION sumbinit() + USE PRMS_BASINSUM + USE PRMS_MODULE, ONLY: Print_debug, Nobs, Init_vars_from_file + USE PRMS_FLOWVARS, ONLY: Basin_soil_moist, Basin_ssstor, Basin_lake_stor + USE PRMS_INTCP, ONLY: Basin_intcp_stor + USE PRMS_SNOW, ONLY: Basin_pweqv + USE PRMS_SRUNOFF, ONLY: Basin_imperv_stor, Basin_dprst_volcl, Basin_dprst_volop + USE PRMS_GWFLOW, ONLY: Basin_gwstor + IMPLICIT NONE + INTRINSIC MAX, MOD + INTEGER, EXTERNAL :: getparam, julian_day + EXTERNAL :: header_print, read_error, write_outfile, basin_sum_restart, PRMS_open_module_file +! Local Variables + INTEGER :: pftemp +!*********************************************************************** + sumbinit = 0 + + IF ( Nobs>0 ) THEN + IF ( getparam(MODNAME, 'outlet_sta', 1, 'integer', Outlet_sta) & + & /=0 ) CALL read_error(2, 'outlet_sta') + IF ( Outlet_sta==0 ) Outlet_sta = 1 + ENDIF + + IF ( getparam(MODNAME, 'print_type', 1, 'integer', Print_type) & + & /=0 ) CALL read_error(2, 'print_type') + + IF ( getparam(MODNAME, 'print_freq', 1, 'integer', Print_freq) & + & /=0 ) CALL read_error(2, 'print_freq') + + IF ( Init_vars_from_file>0 ) THEN + CALL basin_sum_restart(1) + ELSE +! Zero stuff out when Timestep = 0 + Watbal_sum = 0.0D0 + + Obs_runoff_mo = 0.0D0 + Basin_cfs_mo = 0.0D0 + Basin_ppt_mo = 0.0D0 + Basin_net_ppt_mo = 0.0D0 + Basin_swrad_mo = 0.0D0 + Basin_max_temp_mo = 0.0D0 + Basin_min_temp_mo = 0.0D0 + Basin_intcp_evap_mo = 0.0D0 + Basin_potet_mo = 0.0D0 + Basin_actet_mo = 0.0D0 + Basin_snowmelt_mo = 0.0D0 + Basin_gwflow_mo = 0.0D0 + Basin_ssflow_mo = 0.0D0 + Basin_sroff_mo = 0.0D0 + Basin_stflow_mo = 0.0D0 + Obsq_inches_mo = 0.0D0 + Basin_runoff_ratio = 0.0D0 + Basin_runoff_ratio_mo = 0.0D0 + Basin_lakeevap_mo = 0.0D0 + + Obs_runoff_yr = 0.0D0 + Basin_cfs_yr = 0.0D0 + Basin_ppt_yr = 0.0D0 + Basin_net_ppt_yr = 0.0D0 + Basin_swrad_yr = 0.0D0 + Basin_max_temp_yr = 0.0D0 + Basin_min_temp_yr = 0.0D0 + Basin_intcp_evap_yr = 0.0D0 + Basin_lakeevap_yr = 0.0D0 + Basin_potet_yr = 0.0D0 + Basin_actet_yr = 0.0D0 + Basin_snowmelt_yr = 0.0D0 + Basin_gwflow_yr = 0.0D0 + Basin_ssflow_yr = 0.0D0 + Basin_sroff_yr = 0.0D0 + Basin_stflow_yr = 0.0D0 + Obsq_inches_yr = 0.0D0 + + Obs_runoff_tot = 0.0D0 + Basin_cfs_tot = 0.0D0 + Basin_ppt_tot = 0.0D0 + Basin_net_ppt_tot = 0.0D0 + Basin_swrad_tot = 0.0D0 + Basin_max_temp_tot = 0.0D0 + Basin_min_temp_tot = 0.0D0 + Basin_intcp_evap_tot = 0.0D0 + Basin_potet_tot = 0.0D0 + Basin_actet_tot = 0.0D0 + Basin_snowmelt_tot = 0.0D0 + Basin_gwflow_tot = 0.0D0 + Basin_ssflow_tot = 0.0D0 + Basin_sroff_tot = 0.0D0 + Basin_stflow_tot = 0.0D0 + Obsq_inches_tot = 0.0D0 + Hru_et_yr = 0.0D0 + Totdays = 0 + Obsq_inches = 0.0D0 + Basin_storage = 0.0D0 + Basin_storvol = 0.0D0 + ENDIF + +!******Set daily print switch + IF ( Print_freq>7 ) THEN + Dprt = .TRUE. + ELSE + Dprt = .FALSE. + ENDIF + +!******Set monthly print switch + IF ( Print_freq>3 .AND. (Print_freq<8 .OR. Print_freq>11) ) THEN + Mprt = .TRUE. + ELSE + Mprt = .FALSE. + ENDIF + +!******Set yearly print switch + IF ( Print_freq==2 .OR. Print_freq==3 .OR. Print_freq==6 .OR. Print_freq==7 .OR. & + & Print_freq==10.OR.Print_freq==11.OR.Print_freq==14.OR.Print_freq==15 ) THEN + Yprt = .TRUE. + ELSE + Yprt = .FALSE. + ENDIF + +!******Set total print switch + pftemp = MOD( Print_freq, 2 ) + IF ( pftemp==1 ) THEN + Tprt = .TRUE. + ELSE + Tprt = .FALSE. + ENDIF + +!******Set header print switch (1 prints a new header after every month +!****** summary, 2 prints a new header after every year summary) + Header_prt = 0 + IF ( Print_freq==6 .OR. Print_freq==7 .OR. Print_freq==10 .OR. Print_freq==11 ) Header_prt = 1 + IF ( Print_freq>=12 ) Header_prt = 2 + IF ( .NOT.Dprt .AND. Print_type==1 ) Header_prt = 3 + + Basin_storage = Basin_soil_moist + Basin_intcp_stor + & + & Basin_gwstor + Basin_ssstor + Basin_pweqv + & + & Basin_imperv_stor + Basin_lake_stor + & + & Basin_dprst_volop + Basin_dprst_volcl +!glacier storage not known at start + + IF ( Print_freq/=0 ) THEN + CALL header_print(Print_type) +! Print span dashes and initial storage + IF ( Print_type==1 ) THEN + WRITE (Buffer48, "(' initial', 27X,F9.3)") Basin_storage + CALL write_outfile(Buffer48(:44)) + + ELSEIF ( Print_type==2 ) THEN + WRITE (Buffer120, 9001) Basin_intcp_stor, & + & Basin_soil_moist, Basin_pweqv, Basin_gwstor, Basin_ssstor + CALL write_outfile(Buffer120(:98)) + ENDIF + ENDIF + + Endjday = julian_day('end', 'calendar') + + IF ( Print_debug==4 ) CALL PRMS_open_module_file(BALUNT, 'basin_sum.dbg') + + 9001 FORMAT (' initial', 33X, F6.2, 20X, 2F6.2, F13.2, F6.2) + + END FUNCTION sumbinit + +!*********************************************************************** +! sumbrun - Computes summary values +!*********************************************************************** + INTEGER FUNCTION sumbrun() + USE PRMS_BASINSUM + USE PRMS_MODULE, ONLY: Print_debug, Nobs, End_year, Strmflow_flag, Glacier_flag + USE PRMS_BASIN, ONLY: Active_area, Active_hrus, Hru_route_order + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_lakeevap, & + & Basin_actet, Basin_perv_et, Basin_swale_et, Hru_actet, & + & Basin_ssstor, Basin_soil_moist, Basin_cfs, Basin_stflow_out, Basin_lake_stor + USE PRMS_CLIMATEVARS, ONLY: Basin_swrad, Basin_ppt, Basin_potet, Basin_tmax, Basin_tmin + USE PRMS_SET_TIME, ONLY: Jday, Modays, Yrdays, Julwater, Nowyear, Nowmonth, Nowday, Cfs2inches + USE PRMS_OBS, ONLY: Streamflow_cfs + USE PRMS_GWFLOW, ONLY: Basin_gwflow, Basin_gwstor, Basin_gwsink, Basin_gwstor_minarea_wb + USE PRMS_INTCP, ONLY: Basin_intcp_evap, Basin_intcp_stor, Basin_net_ppt + USE PRMS_SNOW, ONLY: Basin_snowmelt, Basin_pweqv, Basin_snowevap + USE PRMS_GLACR, ONLY: Basin_gl_storage + USE PRMS_SRUNOFF, ONLY: Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, & + & Basin_dprst_evap, Basin_dprst_volcl, Basin_dprst_volop + USE PRMS_ROUTING, ONLY: Basin_segment_storage + IMPLICIT NONE +! Functions + INTRINSIC SNGL, ABS, ALOG, DBLE + EXTERNAL :: header_print, write_outfile +! Local variables + INTEGER :: i, j, wyday, endrun, monthdays + DOUBLE PRECISION :: wat_bal, obsrunoff +!*********************************************************************** + sumbrun = 0 + + wyday = Julwater + + IF ( Nowyear==End_year .AND. Jday==Endjday ) THEN + endrun = 1 + ELSE + endrun = 0 + ENDIF + +!*****Compute aggregated values + + Last_basin_stor = Basin_storage + Basin_storage = Basin_soil_moist + Basin_intcp_stor + & + & Basin_gwstor + Basin_ssstor + Basin_pweqv + & + & Basin_imperv_stor + Basin_lake_stor + Basin_dprst_volop + Basin_dprst_volcl +! Basin_storage doesn't include any processes on glacier +! In glacier module, Basin_gl_storstart is an estimate for starting glacier volume, but only +! includes glaciers that have depth estimates and these are known to be iffy + IF ( Glacier_flag==1 ) Basin_storage = Basin_storage + Basin_gl_storage + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 ) Basin_storage = Basin_storage + Basin_segment_storage + +! volume calculation for storage + Basin_storvol = Basin_storage*Active_area + + obsrunoff = 0.0D0 + IF ( Nobs>0 ) obsrunoff = Streamflow_cfs(Outlet_sta) + Obsq_inches = obsrunoff*Cfs2inches + + wat_bal = Last_basin_stor - Basin_storage + Basin_ppt + Basin_gwstor_minarea_wb & + & - Basin_actet - Basin_stflow_out - Basin_gwsink + + IF ( Basin_stflow_out>0.0 ) THEN + Basin_runoff_ratio = Basin_ppt/Basin_stflow_out + ELSE + Basin_runoff_ratio = 0.0 + ENDIF + + IF ( Print_debug==4 ) THEN + WRITE ( BALUNT, "(A,2I4,7F8.4)" ) ' bsto-sm-in-gw-ss-sn-iv ', & + & Nowmonth, Nowday, Basin_storage, Basin_soil_moist, & + & Basin_intcp_stor, Basin_gwstor, Basin_ssstor, & + & Basin_pweqv, Basin_imperv_stor + + WRITE ( BALUNT, "(A,I6,8F8.4)" )' bet-pv-iv-in-sn-lk-sw-dp', Nowday, & + & Basin_actet, Basin_perv_et, Basin_imperv_evap, & + & Basin_intcp_evap, Basin_snowevap, Basin_lakeevap, & + & Basin_swale_et, Basin_dprst_evap + + WRITE ( BALUNT, "(A,I6,7F8.4,/)" ) ' bal-pp-et-st-ls-bs-gs ', & + & Nowday, wat_bal, Basin_ppt, Basin_actet, Basin_stflow_out, & + & Last_basin_stor, Basin_storage, Basin_gwsink + ENDIF + + Watbal_sum = Watbal_sum + wat_bal + +!******Check for daily print + + IF ( Dprt ) THEN + IF ( Print_type==0 ) THEN + WRITE ( Buffer40, "(I7,2I5,F11.2,F12.2)" ) Nowyear, & + & Nowmonth, Nowday, obsrunoff, Basin_cfs + CALL write_outfile(Buffer40) + + ELSEIF ( Print_type==1 ) THEN + WRITE ( Buffer80, "(I7,2I5,7F9.3)" ) Nowyear, & + & Nowmonth, Nowday, Basin_ppt, Basin_actet, Basin_storage, & + & Basin_stflow_out, Obsq_inches, wat_bal, Watbal_sum + CALL write_outfile(Buffer80) + + ELSEIF ( Print_type==2 ) THEN + WRITE ( Buffer151, 9001 ) Nowyear, Nowmonth, Nowday, Basin_swrad, & + & Basin_tmax, Basin_tmin, Basin_ppt, Basin_net_ppt, & + & Basin_intcp_stor, Basin_intcp_evap, Basin_potet, & + & Basin_actet, Basin_soil_moist, Basin_pweqv, & + & Basin_snowmelt, Basin_gwstor, Basin_ssstor, & + & Basin_gwflow, Basin_ssflow, Basin_sroff, & + & Basin_stflow_out, Basin_cfs, obsrunoff, Basin_lakeevap + CALL write_outfile(Buffer151) + + ENDIF + ENDIF + IF ( Print_debug==4 ) WRITE ( BALUNT, * ) 'wat_bal =', wat_bal, & + & ' watbal_sum=', Watbal_sum + +!******Compute monthly values + IF ( Nowday==1 ) THEN + Obs_runoff_mo = 0.0D0 + Basin_cfs_mo = 0.0D0 + Basin_ppt_mo = 0.0D0 + Basin_net_ppt_mo = 0.0D0 + Basin_swrad_mo = 0.0D0 + Basin_max_temp_mo = 0.0D0 + Basin_min_temp_mo = 0.0D0 + Basin_intcp_evap_mo = 0.0D0 + Basin_potet_mo = 0.0D0 + Basin_actet_mo = 0.0D0 + Basin_snowmelt_mo = 0.0D0 + Basin_gwflow_mo = 0.0D0 + Basin_ssflow_mo = 0.0D0 + Basin_sroff_mo = 0.0D0 + Basin_stflow_mo = 0.0D0 + Obsq_inches_mo = 0.0D0 + Basin_lakeevap_mo = 0.0D0 + ENDIF + + Obs_runoff_mo = Obs_runoff_mo + obsrunoff + Obsq_inches_mo = Obsq_inches_mo + obsrunoff*Cfs2inches + Basin_cfs_mo = Basin_cfs_mo + Basin_cfs + Basin_ppt_mo = Basin_ppt_mo + Basin_ppt + Basin_net_ppt_mo = Basin_net_ppt_mo + Basin_net_ppt + Basin_swrad_mo = Basin_swrad_mo + Basin_swrad + Basin_max_temp_mo = Basin_max_temp_mo + Basin_tmax + Basin_min_temp_mo = Basin_min_temp_mo + Basin_tmin + Basin_intcp_evap_mo = Basin_intcp_evap_mo + Basin_intcp_evap + Basin_potet_mo = Basin_potet_mo + Basin_potet + Basin_actet_mo = Basin_actet_mo + Basin_actet + Basin_snowmelt_mo = Basin_snowmelt_mo + Basin_snowmelt + Basin_gwflow_mo = Basin_gwflow_mo + Basin_gwflow + Basin_ssflow_mo = Basin_ssflow_mo + Basin_ssflow + Basin_sroff_mo = Basin_sroff_mo + Basin_sroff + Basin_stflow_mo = Basin_stflow_mo + Basin_stflow_out + Basin_lakeevap_mo = Basin_lakeevap_mo + Basin_lakeevap + + IF ( Nowday==Modays(Nowmonth) ) THEN + monthdays = Modays(Nowmonth) + Basin_swrad_mo = Basin_swrad_mo/monthdays + Basin_max_temp_mo = Basin_max_temp_mo/monthdays + Basin_min_temp_mo = Basin_min_temp_mo/monthdays + Obs_runoff_mo = Obs_runoff_mo/monthdays + Basin_cfs_mo = Basin_cfs_mo/monthdays + Basin_runoff_ratio_mo = Basin_ppt_mo/monthdays/Basin_stflow_mo + Basin_lakeevap_mo = Basin_lakeevap_mo/monthdays + + IF ( Mprt ) THEN + IF ( Print_type==0 ) THEN + IF ( Dprt ) CALL write_outfile(DASHS(:40)) + WRITE ( Buffer40, "(I7,I5,F16.2,F12.2)" ) Nowyear, Nowmonth, Obs_runoff_mo, Basin_cfs_mo + CALL write_outfile(Buffer40) + IF ( Dprt ) CALL write_outfile(DASHS(:40)) + + ELSEIF ( Print_type==1 ) THEN + IF ( Dprt ) CALL write_outfile(DASHS(:62)) + WRITE ( Buffer80, "(I7,I5,5X,5F9.3)" ) Nowyear, & + & Nowmonth, Basin_ppt_mo, Basin_actet_mo, Basin_storage, & + & Basin_stflow_mo, Obsq_inches_mo + CALL write_outfile(Buffer80(:62)) + IF ( Dprt ) CALL write_outfile(DASHS(:62)) + + ELSEIF ( Print_type==2 ) THEN + IF ( Dprt ) CALL write_outfile(DASHS) + WRITE ( Buffer151, 9006 ) Nowyear, Nowmonth, Basin_swrad_mo, Basin_max_temp_mo, & + & Basin_min_temp_mo, Basin_ppt_mo, Basin_net_ppt_mo, & + & Basin_intcp_evap_mo, Basin_potet_mo, Basin_actet_mo, & + & Basin_soil_moist, Basin_pweqv, Basin_snowmelt_mo, & + & Basin_gwstor, Basin_ssstor, Basin_gwflow_mo, & + & Basin_ssflow_mo, Basin_sroff_mo, Basin_stflow_mo, & + & Basin_cfs_mo, Obs_runoff_mo, Basin_lakeevap_mo + CALL write_outfile(Buffer151) + IF ( Dprt ) CALL write_outfile(DASHS) + ENDIF + + ENDIF + ENDIF + +!******Check for year print + + IF ( Yprt ) THEN + Obs_runoff_yr = Obs_runoff_yr + obsrunoff + Obsq_inches_yr = Obsq_inches_yr + obsrunoff*Cfs2inches + Basin_cfs_yr = Basin_cfs_yr + Basin_cfs + Basin_ppt_yr = Basin_ppt_yr + Basin_ppt + Basin_net_ppt_yr = Basin_net_ppt_yr + Basin_net_ppt + Basin_swrad_yr = Basin_swrad_yr + Basin_swrad + Basin_max_temp_yr = Basin_max_temp_yr + Basin_tmax + Basin_min_temp_yr = Basin_min_temp_yr + Basin_tmin + Basin_intcp_evap_yr = Basin_intcp_evap_yr + Basin_intcp_evap + Basin_lakeevap_yr = Basin_lakeevap_yr + Basin_lakeevap + Basin_potet_yr = Basin_potet_yr + Basin_potet + Basin_actet_yr = Basin_actet_yr + Basin_actet + Basin_snowmelt_yr = Basin_snowmelt_yr + Basin_snowmelt + Basin_gwflow_yr = Basin_gwflow_yr + Basin_gwflow + Basin_ssflow_yr = Basin_ssflow_yr + Basin_ssflow + Basin_sroff_yr = Basin_sroff_yr + Basin_sroff + Basin_stflow_yr = Basin_stflow_yr + Basin_stflow_out + DO j = 1, Active_hrus + i = Hru_route_order(j) + Hru_et_yr(i) = Hru_et_yr(i) + DBLE( Hru_actet(i) ) + ENDDO + + IF ( wyday==Yrdays ) THEN + IF ( Print_type==0 ) THEN + + Obs_runoff_yr = Obs_runoff_yr/Yrdays + Basin_cfs_yr = Basin_cfs_yr/Yrdays + IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:40)) + WRITE ( Buffer40, "(I7,F21.2,F12.2)" ) Nowyear, Obs_runoff_yr, Basin_cfs_yr + CALL write_outfile(Buffer40) + IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:40)) + +! ****annual summary here + ELSEIF ( Print_type==1 ) THEN + IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:62)) + WRITE ( Buffer80, "(I7,10X,5F9.3)" ) Nowyear, Basin_ppt_yr, & + & Basin_actet_yr, Basin_storage, Basin_stflow_yr, Obsq_inches_yr + CALL write_outfile(Buffer80(:62)) + IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:62)) + + ELSEIF ( Print_type==2 ) THEN + Basin_swrad_yr = Basin_swrad_yr/Yrdays + Basin_max_temp_yr = Basin_max_temp_yr/Yrdays + Basin_min_temp_yr = Basin_min_temp_yr/Yrdays + Obs_runoff_yr = Obs_runoff_yr/Yrdays + Basin_cfs_yr = Basin_cfs_yr/Yrdays + IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS) + WRITE ( Buffer151, 9007 ) Nowyear, Basin_swrad_yr, Basin_max_temp_yr, & + & Basin_min_temp_yr, Basin_ppt_yr, Basin_net_ppt_yr, & + & Basin_intcp_stor, Basin_intcp_evap_yr, Basin_potet_yr, Basin_actet_yr, & + & Basin_soil_moist, Basin_pweqv, Basin_snowmelt_yr, & + & Basin_gwstor, Basin_ssstor, Basin_gwflow_yr, & + & Basin_ssflow_yr, Basin_sroff_yr, Basin_stflow_yr, & + & Basin_cfs_yr, Obs_runoff_yr, Basin_lakeevap_yr + CALL write_outfile(Buffer151) + IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS) + ENDIF + + Obs_runoff_yr = 0.0D0 + Basin_cfs_yr = 0.0D0 + Basin_ppt_yr = 0.0D0 + Basin_net_ppt_yr = 0.0D0 + Basin_swrad_yr = 0.0D0 + Basin_max_temp_yr = 0.0D0 + Basin_min_temp_yr = 0.0D0 + Basin_intcp_evap_yr = 0.0D0 + Basin_lakeevap_yr = 0.0D0 + Basin_potet_yr = 0.0D0 + Basin_actet_yr = 0.0D0 + Basin_snowmelt_yr = 0.0D0 + Basin_gwflow_yr = 0.0D0 + Basin_ssflow_yr = 0.0D0 + Basin_sroff_yr = 0.0D0 + Basin_stflow_yr = 0.0D0 + Obsq_inches_yr = 0.0D0 + Hru_et_yr = 0.0D0 + + ENDIF + ENDIF + +!******Check for total print + + IF ( Tprt ) THEN +!******Print heading if needed +! IF ( endrun==1 ) THEN +! CALL write_outfile(' ') +! IF ( .NOT.Dprt .OR. .NOT.Mprt .OR. .NOT.Yprt ) CALL header_print(Print_type) +! ENDIF + + Totdays = Totdays + 1 + Obs_runoff_tot = Obs_runoff_tot + obsrunoff + Obsq_inches_tot = Obsq_inches_tot + obsrunoff*Cfs2inches + Basin_cfs_tot = Basin_cfs_tot + Basin_cfs + Basin_ppt_tot = Basin_ppt_tot + Basin_ppt + Basin_net_ppt_tot = Basin_net_ppt_tot + Basin_net_ppt + Basin_swrad_tot = Basin_swrad_tot + Basin_swrad + Basin_max_temp_tot = Basin_max_temp_tot + Basin_tmax + Basin_min_temp_tot = Basin_min_temp_tot + Basin_tmin + Basin_intcp_evap_tot = Basin_intcp_evap_tot + Basin_intcp_evap + Basin_potet_tot = Basin_potet_tot + Basin_potet + Basin_actet_tot = Basin_actet_tot + Basin_actet + Basin_snowmelt_tot = Basin_snowmelt_tot + Basin_snowmelt + Basin_gwflow_tot = Basin_gwflow_tot + Basin_gwflow + Basin_ssflow_tot = Basin_ssflow_tot + Basin_ssflow + Basin_sroff_tot = Basin_sroff_tot + Basin_sroff + Basin_stflow_tot = Basin_stflow_tot + Basin_stflow_out + + IF ( endrun==1 ) THEN + + IF ( Print_type==0 ) THEN + Obs_runoff_tot = Obs_runoff_tot/Totdays + Basin_cfs_tot = Basin_cfs_tot/Totdays + CALL write_outfile(STARS(:40)) + WRITE ( Buffer48, "(A,F14.2,F12.2)" ) ' Total for run', Obs_runoff_tot, Basin_cfs_tot + CALL write_outfile(Buffer48(:40)) + CALL write_outfile(STARS(:40)) + + ELSEIF ( Print_type==1 ) THEN + CALL write_outfile(STARS(:62)) + WRITE ( Buffer80, 9005 ) ' Total for run', Basin_ppt_tot, & + & Basin_actet_tot, Basin_storage, Basin_stflow_tot, Obsq_inches_tot + CALL write_outfile(Buffer80(:62)) + CALL write_outfile(STARS(:62)) + + ELSEIF ( Print_type==2 ) THEN + Obs_runoff_tot = Obs_runoff_tot/Totdays + Basin_cfs_tot = Basin_cfs_tot/Totdays + CALL write_outfile(STARS) + WRITE ( Buffer151, 9004 ) ' Total for run', Basin_ppt_tot, & + & Basin_net_ppt_tot, Basin_intcp_evap_tot, & + & Basin_potet_tot, Basin_actet_tot, Basin_soil_moist, & + & Basin_pweqv, Basin_snowmelt_tot, Basin_gwstor, & + & Basin_ssstor, Basin_gwflow_tot, Basin_ssflow_tot, & + & Basin_sroff_tot, Basin_stflow_tot, Basin_cfs_tot, Obs_runoff_tot, Basin_lakeevap_yr + CALL write_outfile(Buffer151) + CALL write_outfile(STARS) + ENDIF + ENDIF + ENDIF + + 9001 FORMAT (I6, 2I3, F5.0, 2F5.1, 2F7.2, 2F6.2, 2F7.2, F6.2, F6.3, F7.3, 2F6.3, 3F7.2, F7.4, F9.1, F9.2, F7.2) + 9004 FORMAT (A, 13X, 2F7.2, F12.1, 2F7.2, 2F6.2, F7.2, 2F6.2, 4F7.2, F9.1, F9.2, F7.2) + 9005 FORMAT (A, 3X, 6F9.3) + 9006 FORMAT (I6, I3, 3X, 3F5.1, 2F7.2, F12.1, 2F7.2, 2F6.2, F7.2, 2F6.2, 3F7.2, F9.1, F9.2, 2F7.2) + 9007 FORMAT (I6, 6X, 3F5.1, 2F7.2, 2F6.2, 2F7.2, 2F6.2, F7.2, 2F6.2, 3F7.2, F9.2, F9.2, 2F7.2) + + END FUNCTION sumbrun + +!*********************************************************************** +! Print headers for tables +! This writes the measured and simulated table header. +!*********************************************************************** + SUBROUTINE header_print(Print_type) + USE PRMS_BASINSUM, ONLY: DASHS, Buffer80, Print_freq, Header_prt + IMPLICIT NONE + EXTERNAL write_outfile +! Arguments + INTEGER, INTENT(IN) :: Print_type +!*********************************************************************** + CALL write_outfile(' ') +! This writes the water balance table header. + IF ( Header_prt==3 ) THEN + CALL write_outfile(' Year Month Day Precip ET Storage S-Runoff M-Runoff') + WRITE (Buffer80, 9002) + CALL write_outfile(Buffer80(:62)) + CALL write_outfile(DASHS(:62)) + + ELSEIF ( Print_type==0 ) THEN + IF ( Print_freq==1 ) THEN + CALL write_outfile(' Measured Simulated') + ELSE + CALL write_outfile(' Year Month Day Measured Simulated') + ENDIF + CALL write_outfile(' (cfs) (cfs)') + CALL write_outfile(DASHS(:40)) + +! This writes the water balance table header. + ELSEIF ( Print_type==1 ) THEN + CALL write_outfile(' Year Month Day Precip ET Storage S-Runoff M-Runoff Watbal WBalSum') + WRITE (Buffer80, 9001) + CALL write_outfile(Buffer80) + CALL write_outfile(DASHS(:80)) + +! This writes the detailed table header. + ELSEIF ( Print_type==2 ) THEN + CALL write_outfile(' Year mo day srad tmx tmn ppt n-ppt ints intl potet'// & + & ' actet smav pweqv melt gwsto sssto gwflow ssflow sroff tot-fl sim meas lkevap') + CALL write_outfile(' (ly) (F/C)(F/C) (in) (in) (in) (in) (in)'// & + & ' (in) (in) (in) (in) (in) (in) (in) (in) (in) (in) (cfs) (cfs) (in)') + CALL write_outfile(DASHS) + + ENDIF + + 9001 FORMAT (17X, 7(' (inches)')) + 9002 FORMAT (17X, 5(' (inches)')) + + END SUBROUTINE header_print + +!*********************************************************************** +! Write or read restart file +!*********************************************************************** + SUBROUTINE basin_sum_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_BASINSUM + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variable + CHARACTER(LEN=9) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Totdays, Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot, Watbal_sum + WRITE ( Restart_outunit ) Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot, Basin_net_ppt_yr, Basin_net_ppt_tot + WRITE ( Restart_outunit ) Basin_max_temp_yr, Basin_max_temp_tot, Basin_min_temp_yr, Basin_min_temp_tot + WRITE ( Restart_outunit ) Basin_potet_yr, Basin_potet_tot, Basin_actet_yr, Basin_actet_tot + WRITE ( Restart_outunit ) Last_basin_stor, Basin_snowmelt_yr, Basin_snowmelt_tot, Basin_gwflow_yr, Basin_gwflow_tot + WRITE ( Restart_outunit ) Basin_ssflow_yr, Basin_ssflow_tot, Basin_sroff_yr, Basin_sroff_tot + WRITE ( Restart_outunit ) Basin_stflow_yr, Basin_stflow_tot, Basin_ppt_yr, Basin_ppt_tot + WRITE ( Restart_outunit ) Basin_intcp_evap_yr, Basin_intcp_evap_tot, Obsq_inches_yr, Obsq_inches_tot, Basin_lakeevap_yr + WRITE ( Restart_outunit ) Basin_net_ppt_mo, Obsq_inches_mo, Basin_max_temp_mo, Basin_min_temp_mo, Basin_actet_mo + WRITE ( Restart_outunit ) Basin_snowmelt_mo, Basin_gwflow_mo, Basin_sroff_mo, Basin_stflow_mo + WRITE ( Restart_outunit ) Basin_intcp_evap_mo, Basin_storage, Basin_storvol, Basin_potet_mo + WRITE ( Restart_outunit ) Basin_ssflow_mo, Basin_ppt_mo, Obsq_inches, Basin_runoff_ratio, Basin_runoff_ratio_mo + WRITE ( Restart_outunit ) Hru_et_yr + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Totdays, Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot, Watbal_sum + READ ( Restart_inunit ) Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot, Basin_net_ppt_yr, Basin_net_ppt_tot + READ ( Restart_inunit ) Basin_max_temp_yr, Basin_max_temp_tot, Basin_min_temp_yr, Basin_min_temp_tot + READ ( Restart_inunit ) Basin_potet_yr, Basin_potet_tot, Basin_actet_yr, Basin_actet_tot + READ ( Restart_inunit ) Last_basin_stor, Basin_snowmelt_yr, Basin_snowmelt_tot, Basin_gwflow_yr, Basin_gwflow_tot + READ ( Restart_inunit ) Basin_ssflow_yr, Basin_ssflow_tot, Basin_sroff_yr, Basin_sroff_tot + READ ( Restart_inunit ) Basin_stflow_yr, Basin_stflow_tot, Basin_ppt_yr, Basin_ppt_tot + READ ( Restart_inunit ) Basin_intcp_evap_yr, Basin_intcp_evap_tot, Obsq_inches_yr, Obsq_inches_tot, Basin_lakeevap_yr + READ ( Restart_inunit ) Basin_net_ppt_mo, Obsq_inches_mo, Basin_max_temp_mo, Basin_min_temp_mo, Basin_actet_mo + READ ( Restart_inunit ) Basin_snowmelt_mo, Basin_gwflow_mo, Basin_sroff_mo, Basin_stflow_mo + READ ( Restart_inunit ) Basin_intcp_evap_mo, Basin_storage, Basin_storvol, Basin_potet_mo + READ ( Restart_inunit ) Basin_ssflow_mo, Basin_ppt_mo, Obsq_inches, Basin_runoff_ratio, Basin_runoff_ratio_mo + READ ( Restart_inunit ) Hru_et_yr + ENDIF + END SUBROUTINE basin_sum_restart diff --git a/prms/climateflow.f90 b/prms/climateflow.f90 index dd43528f..b018f69b 100644 --- a/prms/climateflow.f90 +++ b/prms/climateflow.f90 @@ -83,6 +83,8 @@ MODULE PRMS_FLOWVARS DOUBLE PRECISION, SAVE :: Basin_stflow_in, Basin_gwflow_cfs, Basin_stflow_out, Flow_out DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seg_upstream_inflow(:), Seg_lateral_inflow(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seg_outflow(:), Seg_inflow(:) + ! glacr + REAL, SAVE, ALLOCATABLE :: Glacier_frac(:), Alt_above_ela(:), Snowfld_frac(:) ! Declared Parameters REAL, SAVE, ALLOCATABLE :: Soil_moist_max(:), Soil_rechr_max(:), Sat_threshold(:) REAL, SAVE, ALLOCATABLE :: Snowinfil_max(:), Imperv_stor_max(:) @@ -122,7 +124,8 @@ INTEGER FUNCTION climateflow_decl() USE PRMS_MODULE, ONLY: Temp_flag, Precip_flag, Model, Nhru, Nssr, Nevap, Nlake, & & Nsegment, Strmflow_module, Temp_module, Ntemp, Stream_order_flag, GSFLOW_flag, & & Precip_module, Solrad_module, Transp_module, Et_module, Init_vars_from_file, PRMS4_flag, & - & Soilzone_module, Srunoff_module, Nrain, Nsol, Call_cascade, Et_flag, Dprst_flag, Solrad_flag + & Soilzone_module, Srunoff_module, Nrain, Nsol, Call_cascade, Et_flag, Dprst_flag, & + & Solrad_flag, Glacier_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declvar, declparam @@ -535,6 +538,24 @@ INTEGER FUNCTION climateflow_decl() & 'Snowpack water equivalent on each HRU', & & 'inches', Pkwater_equiv)/=0 ) CALL read_error(3, 'pkwater_equiv') +! glacier variables + IF ( Glacier_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Glacier_frac(Nhru) ) + IF ( declvar(MODNAME, 'glacier_frac', 'nhru', Nhru, 'real', & + 'Fraction of glaciation (0=none; 1=100%)', & + 'decimal fraction', Glacier_frac)/=0 ) CALL read_error(3, 'glacier_frac') + + ALLOCATE ( Snowfld_frac(Nhru) ) + IF ( declvar(MODNAME, 'snowfld_frac', 'nhru', Nhru, 'real', & + 'Fraction of snow field (too small for glacier dynamics)', & + 'decimal fraction', Snowfld_frac)/=0 ) CALL read_error(3, 'snowfld_frac') + + ALLOCATE ( Alt_above_ela(Nhru) ) + IF ( declvar(MODNAME, 'alt_above_ela', 'nhru', Nhru, 'real', & + 'Altitude above equilibrium line altitude (ELA)', & + 'elev_units', Alt_above_ela)/=0 ) CALL read_error(3, 'alt_above_ela') + ENDIF + ! Allocate local variables IF ( Temp_flag<7 .OR. Model==99 ) ALLOCATE ( Tsta_elev_meters(Ntemp), Tsta_elev_feet(Ntemp) ) IF ( Precip_flag==2 .OR. Precip_flag==6 .OR. Precip_flag==5 .OR. Model==99 ) & @@ -824,7 +845,7 @@ INTEGER FUNCTION climateflow_init() USE PRMS_MODULE, ONLY: Temp_flag, Precip_flag, Nhru, Nssr, Temp_module, Precip_module, Parameter_check_flag, & & Solrad_module, Soilzone_module, Srunoff_module, Stream_order_flag, Ntemp, Nrain, Nsol, Nevap, & & Init_vars_from_file, Inputerror_flag, Dprst_flag, Solrad_flag, Et_flag, Nlake, Et_module, Humidity_cbh_flag, & - & PRMS4_flag, Print_debug, GSFLOW_flag + & PRMS4_flag, Print_debug, GSFLOW_flag USE PRMS_BASIN, ONLY: Elev_units, FEET2METERS, METERS2FEET, Active_hrus, Hru_route_order, Hru_type IMPLICIT NONE ! Functions @@ -1333,7 +1354,8 @@ END SUBROUTINE precip_form ! Write or read restart file !*********************************************************************** SUBROUTINE climateflow_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Stream_order_flag, Dprst_flag, Nlake, GSFLOW_flag + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Stream_order_flag, Dprst_flag, & + & Nlake, GSFLOW_flag, Glacier_flag USE PRMS_CLIMATEVARS USE PRMS_FLOWVARS IMPLICIT NONE @@ -1353,6 +1375,11 @@ SUBROUTINE climateflow_restart(In_out) & Basin_swale_et, Basin_perv_et, Basin_soil_moist, Basin_ssstor, Basin_lakeevap, Basin_lake_stor WRITE ( Restart_outunit ) Transp_on WRITE ( Restart_outunit ) Pkwater_equiv + IF ( Glacier_flag==1 ) THEN + WRITE ( Restart_outunit) Glacier_frac + WRITE ( Restart_outunit) Snowfld_frac + WRITE ( Restart_outunit) Alt_above_ela + ENDIF WRITE ( Restart_outunit ) Soil_moist WRITE ( Restart_outunit ) Slow_stor WRITE ( Restart_outunit ) Ssres_stor @@ -1379,6 +1406,11 @@ SUBROUTINE climateflow_restart(In_out) & Basin_swale_et, Basin_perv_et, Basin_soil_moist, Basin_ssstor, Basin_lakeevap, Basin_lake_stor READ ( Restart_inunit ) Transp_on READ ( Restart_inunit ) Pkwater_equiv + IF ( Glacier_flag==1 ) THEN + READ ( Restart_inunit) Glacier_frac + READ ( Restart_inunit) Snowfld_frac + READ ( Restart_inunit) Alt_above_ela + ENDIF READ ( Restart_inunit ) Soil_moist READ ( Restart_inunit ) Slow_stor READ ( Restart_inunit ) Ssres_stor diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 new file mode 100644 index 00000000..93b13f20 --- /dev/null +++ b/prms/glacr_melt.f90 @@ -0,0 +1,3068 @@ +!********************************************************************** +! Computes glacier runoff for each glacier using three +! linear reservoirs (snow, firn, ice) with time lapses and ability +! to advance or retreat according to Bahr(1997) volume-area scaling. +! This theory has been advanced according to Arendt and others(2006) for +! the scaling constants and Luthi(2009). +! +! ELAs are computed yearly, as well as mass balance, maximum/winter and +! minimum/summer. These can be used for calibration. Note that the calculation +! of these is only appropriate for the northern hemisphere and the code +! needs to be modified if applied in the southern hemisphere. BUT, snow model would +! also be wrong with reset dates for WY Oct 1 resets. +! +! Permafrost/frozen ground calculations should be turned on with glaciers. But they +! can also be turned on without glaciers. +! +! Hru_elev_ts, Hru_elev_feet, Hru_elev_meters, and Hru_slope for glaciers are +! adjusted each timestep. Hru_aspect is not very realistic, since the glacier HRUs +! are not 2-plane and thus have widely different facing areas (they are convex when +! glacierized and concave when deglacierized). An improvement might be to make +! the glaciers 2-planed, but the code would have to be changed vastly to +! reflect this, since there would be two termini HRUs and would want to +! change the glacier_frac value the same with the two termini. For now, +! it makes sense to keep Hru_aspect constant through time as the way the +! glacier predominately faces. +! +! HRUs with glaciers must have parameter glacier_frac(i)=1, unless they +! are at the terminus of the glacier (in which case they can have +! glacier_frac(i)<1). Code assumes there is at least one glacier at the start, but may +! disappear to nothing or just snowfields. +! +! HRUs containing insubstantial (relative to basin) glaciers have their glaciated +! fraction as snowfld_frac(i)>0 (but <1) +! +! NOTE: Multiple branches are possible in the melt generation, but basal topography +!calculations will be mathematically unsound as each branch will be considered a different +! glacier. +! +! modified June 2012 by Steve Regan +! modified Jan 2017 by AE Van Beusekom +! dedicated calibration variables removed 2019 +! +!*********************************************************************** + + MODULE PRMS_GLACR + + IMPLICIT NONE + !**************************************************************** + ! Local Variables + + ! Ngl - Number of glaciers counted by termini + ! Ntp - Number of tops of glaciers, so max glaciers that could ever split in two + ! Nhrugl - Number of at least partially glacierized hrus at initiation +!#of cells=Nhrugl,#of streams=Ntp,#of cells/stream<=Ntp, #of glaciers<=Nhru + INTEGER, SAVE :: Nglres, Ngl, Ntp, Nhrugl, MbInit_flag, Output_unit, Fraw_unit, All_unit + INTEGER, SAVE :: Seven, Four + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_area_inch2(:) + REAL, PARAMETER :: Gravity = 9.8 ! m/s2 + REAL, PARAMETER :: Aflow = 1.e-25 ! Pa^-3/s, Farinotti 2009 could be 2.4e-24, could be 1e-26 see Patterson 2010 + REAL, PARAMETER :: Density = 917.0 ! kg/m3 + DOUBLE PRECISION, PARAMETER :: Acre_inch2 = 43560.0D0*12.0D0*12.0D0 + CHARACTER(LEN=5), SAVE :: MODNAME + + !**************************************************************** + ! Declared Variables + + REAL, SAVE, ALLOCATABLE :: Hru_glres_melt(:), Snowfld_melt(:), Gl_ice_melt(:), Glacr_elev_init(:) + REAL, SAVE, ALLOCATABLE :: Basal_elev(:), Basal_slope(:), Keep_gl(:,:), Prev_outi(:, :), Prev_out(:, :) + REAL, SAVE, ALLOCATABLE :: Ode_glacrva_coef(:), Av_basal_slope(:), Av_fgrad(:), Hru_slope_ts(:) + REAL, SAVE, ALLOCATABLE :: Hru_mb_yrend(:), Glacr_flow(:), Glacr_slope_init(:), Gl_top_melt(:) + INTEGER, SAVE, ALLOCATABLE :: Top(:), Term(:), Top_tag(:), Ela(:), Order_flowline(:) + INTEGER, SAVE, ALLOCATABLE :: Glacr_tag(:), Ikeep_gl(:,:), Tohru(:) + DOUBLE PRECISION, SAVE :: Basin_gl_ice_melt, Basin_gl_area, Basin_gl_top_melt + DOUBLE PRECISION, SAVE :: Basin_gl_top_gain, Basin_gl_storvol, Basin_gl_storage + DOUBLE PRECISION, SAVE :: Basin_gl_storstart + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_mb_yrcumul(:), Delta_volyr(:), Prev_vol(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Prev_area(:), Gl_mb_yrcumul(:), Gl_area(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Gl_mb_cumul(:), Glnet_ar_delta(:) + + !**************************************************************** + ! Declared Parameters + + REAL, SAVE :: Max_gldepth + REAL, SAVE, ALLOCATABLE :: Glacrva_coef(:), Glacrva_exp(:), Hru_length(:), Hru_width(:) + REAL, SAVE, ALLOCATABLE :: Stor_ice(:,:), Stor_snow(:,:), Stor_firn(:,:) + REAL, SAVE, ALLOCATABLE :: Hru_slope(:), Abl_elev_range(:) + + END MODULE PRMS_GLACR + +!*********************************************************************** +! Main glacr routine +!*********************************************************************** + INTEGER FUNCTION glacr() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: glacrdecl, glacrinit, glacrrun, glacrsetdims + EXTERNAL :: glacr_restart +!*********************************************************************** + glacr = 0 + + IF ( Process(:3)=='run' ) THEN + glacr = glacrrun() + ELSEIF ( Process(:7)=='setdims' ) THEN + glacr = glacrsetdims() + ELSEIF ( Process(:4)=='decl' ) THEN + glacr = glacrdecl() + ELSEIF ( Process(:4)=='init' ) THEN + glacr = glacrinit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL glacr_restart(0) + ENDIF + + END FUNCTION GLACR + +!*********************************************************************** +! glacrsetdims - declares glacier module specific dimensions +!*********************************************************************** + INTEGER FUNCTION glacrsetdims() + USE PRMS_GLACR, ONLY: Nglres, Seven, Four, MbInit_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declfix, control_integer + EXTERNAL read_error +!*********************************************************************** + glacrsetdims = 0 + + IF ( declfix('nglres', 3, 3, 'Number of reservoirs in a glacier')/=0 ) CALL read_error(7, 'nglres') + Nglres = 3 + IF ( declfix('seven', 7, 7, 'Need for keeping glacier variable real array ')/=0 ) CALL read_error(7, 'seven') + Seven = 7 + IF ( declfix('four',4, 4, 'Need for keeping glacier variable integer array')/=0 ) CALL read_error(7, 'four') + Four = 4 + + IF ( control_integer(MbInit_flag, 'mbInit_flag')/=0 ) MbInit_flag = 0 + + END FUNCTION glacrsetdims + +!*********************************************************************** +! glacrdecl - declare parameters and variables for glacier runoff +!*********************************************************************** + INTEGER FUNCTION glacrdecl() + USE PRMS_GLACR + USE PRMS_MODULE, ONLY: Nhru, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80) :: Version_glacr +!*********************************************************************** + glacrdecl = 0 + + Version_glacr = 'glacr_melt.f90 2019-06-19 17:14:45Z' + CALL print_module(Version_glacr, 'Glacier Dynamics ', 90) + MODNAME = 'glacr' + + IF ( declvar(MODNAME, 'nhrugl', 'one', 1, 'integer', & + 'Number of at least partially glacierized HRUs at initiation', & + 'none', Nhrugl)/=0 ) CALL read_error(3, 'nhrugl') + +! declare variables + ALLOCATE ( Hru_slope_ts(Nhru) ) + IF ( declvar(MODNAME, 'hru_slope_ts', 'nhru', Nhru, 'real', & + & 'HRU slope for timestep, which can change for glaciers', & + & 'decimal fraction', Hru_slope_ts)/=0 ) CALL read_error(3, 'hru_slope_ts') + + IF ( declvar(MODNAME, 'basin_gl_top_melt', 'one', 1, 'double', & + & 'Basin area-weighted glacier surface melt (snow, ice and rain) coming out of termini of all glaciers and snowflds', & + & 'inches', Basin_gl_top_melt)/=0 ) CALL read_error(3, 'basin_gl_top_melt') + + IF ( declvar(MODNAME, 'basin_gl_top_gain', 'one', 1, 'double', & + & 'Basin area-weighted glacier surface gain (snow and rain minus evap) for all glaciers and snowflds', & + & 'inches', Basin_gl_top_gain)/=0 ) CALL read_error(3, 'basin_gl_top_gain') + + IF ( declvar(MODNAME, 'basin_gl_ice_melt', 'one', 1, 'double', & + & 'Basin area-weighted glacier ice (firn) melt coming out of termini of all glaciers and snowflds', & + & 'inches', Basin_gl_ice_melt)/=0 ) CALL read_error(3, 'basin_gl_ice_melt') + + ALLOCATE ( Gl_mb_yrcumul(Nhru) ) + IF ( declvar(MODNAME, 'gl_mb_yrcumul', 'nhru', Nhru, 'double', & + & 'Yearly mass balance for each glacier, indexed by Glacr_tag', & + & 'inches', Gl_mb_yrcumul)/=0 ) CALL read_error(3, 'gl_mb_yrcumul') + + ALLOCATE ( Glmax_mb_yrcumul(Nhru) ) + IF ( declvar(MODNAME, 'glmax_mb_yrcumul', 'nhru', Nhru, 'double', & + & 'Finds max year mass balance for each glacier, indexed by Glacr_tag', & + & 'inches', Glmax_mb_yrcumul)/=0 ) CALL read_error(3, 'glmax_mb_yrcumul') + + IF ( declvar(MODNAME, 'basin_gl_area', 'one', 1, 'double', & + & 'Basin area-weighted average glacier-covered area', & + & 'decimal fraction', Basin_gl_area)/=0 ) CALL read_error(3, 'basin_gl_area') + + ALLOCATE ( Gl_area(Nhru) ) + IF ( declvar(MODNAME, 'gl_area', 'nhru', Nhru, 'double', & + & 'Area of each glacier, indexed by Glacr_tag', & + & 'acres', Gl_area)/=0 ) CALL read_error(3, 'gl_area') + + ALLOCATE ( Glnet_ar_delta(Nhru) ) + IF ( declvar(MODNAME, 'glnet_ar_delta', 'nhru', Nhru, 'double', & + & 'Sum of area change of each glacier since start year, indexed by Glacr_tag', & + & 'acres', Glnet_ar_delta)/=0 ) CALL read_error(3, 'glnet_ar_delta') + + ALLOCATE ( Glacr_flow(Nhru) ) + IF ( declvar(MODNAME, 'glacr_flow', 'nhru', Nhru, 'real', & + & 'Glacier melt and rain from HRU to stream network, only nonzero at termini HRUs and snowfield HRUs', & + & 'inches cubed', Glacr_flow)/=0 ) CALL read_error(3, 'glacr_flow') + + ALLOCATE ( Delta_volyr(Nhru) ) + IF ( declvar(MODNAME, 'delta_volyr', 'nhru', Nhru, 'double', & + & 'Year total volume change for each glacier, indexed by Glacr_tag', & + & 'inches cubed', Delta_volyr)/=0 ) CALL read_error(3, 'delta_volyr') + + ALLOCATE ( Hru_mb_yrcumul(Nhru) ) + IF ( declvar(MODNAME, 'hru_mb_yrcumul', 'nhru', Nhru, 'double', & + & 'Mass balance for a glacier HRU, cumulative for year', & + & 'inches', Hru_mb_yrcumul)/=0 ) CALL read_error(3, 'hru_mb_yrcumul') + + ALLOCATE ( Top_tag(Nhru) ) + IF ( declvar(MODNAME, 'top_tag', 'nhru', Nhru, 'integer', & + & 'Identifies which glacier top this HRU is fed by. If =-1, then has multiple feeders', & + & 'none', Top_tag)/=0 ) CALL read_error(3, 'top_tag') + + ALLOCATE ( Glacr_tag(Nhru) ) + IF ( declvar(MODNAME, 'glacr_tag', 'nhru', Nhru, 'integer', & + & 'Identifies which glacier this HRU belongs to', & + & 'none', Glacr_tag)/=0 ) CALL read_error(3, 'glacr_tag') + + ALLOCATE ( Prev_area(Nhru) ) + IF ( declvar(MODNAME, 'prev_area', 'nhru', Nhru, 'double', & + & 'Previous year glacier-covered area above this HRU where all branches of the glacier are included', & + & 'inches squared', Prev_area)/=0 ) CALL read_error(3, 'prev_area') + + ALLOCATE ( Prev_vol(Nhru) ) + IF ( declvar(MODNAME, 'prev_vol', 'nhru', Nhru, 'double', & + & 'Previous volume of each glacier, indexed by Glacr_tag', & + & 'inches cubed', Prev_vol)/=0 ) CALL read_error(3, 'prev_vol') + + ALLOCATE ( Prev_out(Nhru,Nglres) ) + IF ( declvar(MODNAME, 'prev_out', 'nhru,nglres', Nhru*Nglres, 'real', & + & 'Antecedent outflow of the 3 reservoirs in each glacier, indexed by Glacr_tag',& + & 'inches cubed', Prev_out)/=0 ) CALL read_error(3, 'prev_out') + + ALLOCATE ( Prev_outi(Nhru,Nglres) ) + IF ( declvar(MODNAME, 'prev_outi', 'nhru,nglres', Nhru*Nglres, 'real', & + & 'Antecedent outflow of the 3 reservoirs in each glacier for only ice (firn) melt, indexed by Glacr_tag',& + & 'inches cubed', Prev_outi)/=0 ) CALL read_error(3, 'prev_outi') + + ALLOCATE ( Order_flowline(Nhru) ) + IF ( declvar(MODNAME, 'order_flowline', 'nhru', Nhru, 'integer', & + & 'Order flowlines belong together as glaciers, Ntp of these', & + & 'none', Order_flowline)/=0 ) CALL read_error(3, 'order_flowline') + + ALLOCATE ( Ode_glacrva_coef(Nhru) ) + IF ( declvar(MODNAME, 'ode_glacrva_coef', 'nhru', Nhru, 'real', & + & 'Estimate of glacrva_coef from ODE basal topography of each glacier, indexed by Glacr_tag', & + & 'm**(3-2*glacrva_exp)', Ode_glacrva_coef)/=0 ) CALL read_error(3, 'ode_glacrva_coef') + + ALLOCATE ( Ela(Nhru) ) + IF ( declvar(MODNAME, 'ela', 'nhru', Nhru, 'integer', & + & 'HRU number at ELA corresponding to each top in each glacier, Ntp of these', & + & 'none', Ela)/=0 ) CALL read_error(3, 'ela') + + ALLOCATE ( Top(Nhru) ) + IF ( declvar(MODNAME, 'top', 'nhru', Nhru, 'integer', & + & 'HRU number at tops of each glacier, Ntp of these', & + & 'none', Top)/=0 ) CALL read_error(3, 'top') + + ALLOCATE ( Term(Nhru) ) + IF ( declvar(MODNAME, 'term', 'nhru', Nhru, 'integer', & + & 'HRU number at terminus of each glacier, Ngl of these',& + & 'none', Term)/=0 ) CALL read_error(3, 'term') + + ALLOCATE ( Hru_mb_yrend(Nhru) ) + IF ( declvar(MODNAME, 'hru_mb_yrend', 'nhru', Nhru, 'real', & + & 'Glacier HRU mass balance at end of previous hydrological year', & + & 'inches', Hru_mb_yrend)/=0 ) CALL read_error(3, 'hru_mb_yrend') + + ALLOCATE ( Av_fgrad(Nhru) ) + IF ( declvar(MODNAME, 'av_fgrad', 'nhru', Nhru, 'real', & + & 'Glacier average HRU mass balance gradient with elevation at flowline at end of each hydrological year, Ngl of these',& + & 'decimal fraction', Av_fgrad)/=0 ) CALL read_error(3, 'av_fgrad') + + ALLOCATE ( Hru_glres_melt(Nhru) ) + IF ( declvar(MODNAME, 'hru_glres_melt', 'nhru', Nhru, 'real', & + & 'Amount of glacier surface melt (snow, ice, rain) from an HRU that goes into reservoirs', & + & 'inches', Hru_glres_melt)/=0 ) CALL read_error(3, 'hru_glres_melt') + + ALLOCATE ( Snowfld_melt(Nhru) ) + IF ( declvar(MODNAME, 'snowfld_melt', 'nhru', Nhru, 'real', & + & 'Amount of snow field surface melt (snow, ice, rain) from an HRU', & + & 'inches', Snowfld_melt)/=0 ) CALL read_error(3, 'snowfld_melt') + + ALLOCATE ( Gl_top_melt(Nhru) ) + IF ( declvar(MODNAME, 'gl_top_melt', 'nhru', Nhru, 'real', & + & 'Amount of glacier surface melt (snow, ice, rain) coming out of terminus of glacier, indexed by Glacr_tag', & + & 'inches', Gl_top_melt)/=0 ) CALL read_error(3, 'gl_top_melt') + + ALLOCATE ( Gl_ice_melt(Nhru) ) + IF ( declvar(MODNAME, 'gl_ice_melt', 'nhru', Nhru, 'real', & + & 'Amount of glacier ice (firn) melt coming out of terminus of glacier, indexed by Glacr_tag', & + & 'inches', Gl_ice_melt)/=0 ) CALL read_error(3, 'gl_ice_melt') + + ALLOCATE ( Basal_elev(Nhru) ) + IF ( declvar(MODNAME, 'basal_elev', 'nhru', Nhru, 'real', & + & 'Glacier basal elevation mean over HRU', & + & 'elev_units', Basal_elev)/=0 ) CALL read_error(3, 'basal_elev') + + ALLOCATE ( Keep_gl(Nhru,Seven) ) + IF ( declvar(MODNAME, 'keep_gl', 'nhru,seven', Nhru*Seven, 'real', & + & 'Glacier real variables keeping from first year', & + & 'none', Keep_gl)/=0 ) CALL read_error(3, 'keep_gl') + + ALLOCATE ( Ikeep_gl(Nhru,Four) ) + IF ( declvar(MODNAME, 'ikeep_gl', 'nhru,four', Nhru*Four, 'real', & + & 'Glacier integer variables keeping from first year', & + & 'none', Ikeep_gl)/=0 ) CALL read_error(3, 'ikeep_gl') + + ALLOCATE ( Basal_slope(Nhru) ) + IF ( declvar(MODNAME, 'basal_slope', 'nhru', Nhru, 'real', & + & 'Glacier basal slope down flowline mean over HRU', & + & 'decimal fraction', Basal_slope)/=0 ) CALL read_error(3, 'basal_slope') + + ALLOCATE ( Av_basal_slope(Nhru) ) + IF ( declvar(MODNAME, 'av_basal_slope', 'nhru', Nhru, 'real', & + & 'Glacier average basal slope at flowline location, indexed by Glacr_tag', & + & 'decimal fraction', Av_basal_slope)/=0 ) CALL read_error(3, 'av_basal_slope') + + IF ( declvar(MODNAME, 'basin_gl_storage', 'one', 1, 'double', & + & 'Basin area-weighted average storage change in glacier reservoirs', & + & 'inches', Basin_gl_storage)/=0 ) CALL read_error(3, 'basin_gl_storage') + + IF ( declvar(MODNAME, 'basin_gl_storstart', 'one', 1, 'double', & + & 'Basin area-weighted average storage estimated start in glacier reservoirs', & + & 'inches', Basin_gl_storstart)/=0 ) CALL read_error(3, 'basin_gl_storstart') + + + IF ( declvar(MODNAME, 'basin_gl_storvol', 'one', 1, 'double', & + & 'Basin storage volume in glacier storage reservoirs', & + & 'acre-inches', Basin_gl_storvol)/=0 ) CALL read_error(3, 'basin_gl_storvol') + + IF ( Init_vars_from_file==0 ) THEN + ALLOCATE ( Glacr_elev_init(Nhru) ) + IF ( declvar(MODNAME, 'glacr_elev_init', 'nhru', Nhru, 'real', & + & 'Glacier surface elevation mean over HRU at initiation extrapolating to 100% glacierized HRU', & + & 'elev_units', Glacr_elev_init)/=0 ) CALL read_error(3, 'glacr_elev_init') + + ALLOCATE ( Glacr_slope_init(Nhru) ) + IF ( declvar(MODNAME, 'glacr_slope_init', 'nhru', Nhru, 'real', & + & 'Glacier surface slope mean over HRU at initiation extrapolating to 100% glacierized HRU', & + & 'elev_units', Glacr_slope_init)/=0 ) CALL read_error(3, 'glacr_slope_init') + ENDIF + + ! local arrays + ALLOCATE ( Hru_area_inch2(Nhru)) + +! declare parameters + ALLOCATE ( Tohru(Nhru) ) + IF ( declparam(MODNAME, 'tohru', 'nhru', 'integer', & + & '0', 'bounded', 'nhru', & + & 'The index of the down-flowline HRU for a glacier', & + & 'Index of down-flowline HRU to which the HRU'// & + & ' glacier melt flows, for non-glacier HRUs that do not flow to another HRU enter 0', & + & 'none')/=0 ) CALL read_error(1, 'tohru') + + ALLOCATE ( Hru_slope(Nhru) ) + IF ( declparam(MODNAME, 'hru_slope', 'nhru', 'real', & + & '0.0', '0.0', '10.0', & + & 'HRU slope', & + & 'Slope of each HRU, specified as change in vertical length divided by change in horizontal length', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'hru_slope') + + IF ( declparam(MODNAME, 'max_gldepth', 'one', 'real', & + '1.5', '0.1', '3.0', & + 'Upper bound on glacier thickness, thickest glacier measured is Taku at 1.5 km, ice sheet 3 km', & + 'Upper bound on glacier thickness, thickest glacier measured is Taku at 1.5 km, ice sheet 3 km', & + 'km')/=0 ) CALL read_error(1, 'max_gldepth') + + ALLOCATE ( Glacrva_coef(Nhru) ) + IF ( declparam(MODNAME, 'glacrva_coef', 'nhru', 'real', & + '0.28', '0.01', '2.0', & + 'Volume area scaling coefficient for glaciers with Luthi 2009', & + 'Volume area scaling coefficient for glaciers make average by region', & + 'm**(3-2*glacrva_exp)')/=0 ) CALL read_error(1, 'glacrva_coef') + + ALLOCATE ( Glacrva_exp(Nhru) ) + IF ( declparam(MODNAME, 'glacrva_exp', 'nhru', 'real', & + '1.375', '1.0', '2.0', & + 'Volume area exponential coefficient for glaciers', & + 'Volume area exponential coefficient for glaciers make average by region', & + 'none')/=0 ) CALL read_error(1, 'glacrva_exp') + + ALLOCATE ( Stor_ice(Nhru,12) ) + IF ( declparam(MODNAME, 'stor_ice', 'nhru,nmonths', 'real', & + '10.0', '5.0', '29.0', & + 'Monthly Storage coefficient for ice melt on glaciers', & + 'Monthly (January to December) Storage coefficient for ice melt on glaciers', & + 'hours')/=0 ) CALL read_error(1, 'stor_ice') + + ALLOCATE ( Stor_snow(Nhru,12) ) + IF ( declparam(MODNAME, 'stor_snow', 'nhru,nmonths', 'real', & + '80.0', '30.0', '149.0', & + 'Monthly Storage coefficient for snow melt on glaciers', & + 'Monthly (January to December) Storage coefficient for snow melt on glaciers', & + 'hours')/=0 ) CALL read_error(1, 'stor_snow') + + ALLOCATE ( Stor_firn(Nhru,12) ) + IF ( declparam(MODNAME, 'stor_firn', 'nhru,nmonths', 'real', & + '400.0', '150.0', '1000.0', & + 'Monthly Storage coefficient for firn melt on glaciers', & + 'Monthly (January to December) Storage coefficient for firn melt on glaciers', & + 'hours')/=0 ) CALL read_error(1, 'stor_firn') + + ALLOCATE ( Hru_length(Nhru) ) + IF ( declparam(MODNAME, 'hru_length', 'nhru', 'real', & + '0.0', '0.0', '10000.0', & + 'Length of segment covering all of glacier-possible HRU', & + 'Length of segment covering all of glacier-possible HRU', & + 'km')/=0 ) CALL read_error(1, 'hru_length') + + ALLOCATE ( Hru_width(Nhru) ) + IF ( declparam(MODNAME, 'hru_width', 'nhru', 'real', & + '0.0', '0.0', '10000.0', & + 'Width of glacier-possible HRU', & + 'Width of glacier-possible HRU', & + 'km')/=0 ) CALL read_error(1, 'hru_width') + + ALLOCATE ( Abl_elev_range(Nhru) ) + IF ( declparam(MODNAME, 'abl_elev_range', 'nhru', 'real', & + '1000.0', '0.0', '17000.0', & + 'Average HRU snowfield ablation zones elevation range', & + 'Average HRU snowfield ablation zones elevation range or ~ median-min elev', & + 'elev_units')/=0 ) CALL read_error(1, 'abl_elev_range') + + END FUNCTION glacrdecl + +!*********************************************************************** +! glacrinit - Initialize glacr module - get parameter values +!*********************************************************************** + INTEGER FUNCTION glacrinit() + USE PRMS_GLACR + USE PRMS_MODULE, ONLY: Nhru, Init_vars_from_file + USE PRMS_BASIN, ONLY: Hru_area, Hru_elev_ts, Active_hrus, Hru_route_order, & + & Hru_type, Basin_area_inv, Hru_elev_meters + USE PRMS_FLOWVARS, ONLY: Glacier_frac, Alt_above_ela, Snowfld_frac + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: getparam, get_ftnunit, compute_ela_aar + INTRINSIC ABS, SQRT, SNGL, REAL + EXTERNAL read_error, tag_count, sort5 +! Local Variables + INTEGER :: i, j, ii, jj, o, p, hru_flowline(Nhru), toflowline(Nhru), doela, termh, len_str + INTEGER :: iwksp(Nhru), is(Nhru), ie(Nhru), n_inline(Nhru), cell_id(Nhru), str_id(Nhru), prev + INTEGER :: count, prev0 + REAL :: hru_dcum(Nhru), uraw0(Nhru), xraw0(Nhru), xrawterm(Nhru), urawterm(Nhru), slu + REAL :: fraw0(Nhru), urawt(Nhru), xrawt(Nhru), hrawt(Nhru), divu, wksp(Nhru), urawm(Nhru+2) + REAL :: rc(Nhru), rd(Nhru), re(Nhru), ra(Nhru), rb(Nhru), ll(Nhru), u2dd(Nhru) + REAL :: xrawm(Nhru+2), flowsurf_slope(Nhru), urawtop(Nhru), cell_idm(Nhru), str_idm(Nhru) + REAL :: glacier_frac_use(Nhru) + DOUBLE PRECISION :: curr_area(Nhru), add_area(Nhru) +! +!*********************************************************************** + glacrinit = 0 + + IF ( Init_vars_from_file>0 ) CALL glacr_restart(1) + + IF ( getparam(MODNAME, 'max_gldepth', 1, 'real', Max_gldepth)/=0 ) CALL read_error(2, 'max_gldepth') + IF ( getparam(MODNAME, 'glacrva_coef', Nhru, 'real', Glacrva_coef)/=0 ) CALL read_error(2, 'glacrva_coef') + IF ( getparam(MODNAME, 'glacrva_exp', Nhru, 'real', Glacrva_exp)/=0 ) CALL read_error(2, 'glacrva_exp') + IF ( getparam(MODNAME, 'stor_ice', Nhru*12, 'real', Stor_ice)/=0 ) CALL read_error(2, 'stor_ice') + IF ( getparam(MODNAME, 'stor_snow', Nhru*12, 'real', Stor_snow)/=0 ) CALL read_error(2, 'stor_snow') + IF ( getparam(MODNAME, 'stor_firn', Nhru*12, 'real', Stor_firn)/=0 ) CALL read_error(2, 'stor_firn') + IF ( getparam(MODNAME, 'hru_length', Nhru, 'real', Hru_length)/=0 ) CALL read_error(2, 'hru_length') + IF ( getparam(MODNAME, 'hru_width', Nhru, 'real', Hru_width)/=0 ) CALL read_error(2, 'hru_width') + IF ( getparam(MODNAME, 'abl_elev_range', Nhru, 'real', Abl_elev_range)/=0 ) CALL read_error(2, 'abl_elev_range') + IF ( getparam(MODNAME, 'tohru', Nhru, 'integer', Tohru)/=0 ) CALL read_error(2, 'tohru') + IF ( getparam(MODNAME, 'hru_slope', Nhru, 'real', Hru_slope)/=0 ) CALL read_error(2, 'hru_slope') + IF ( Init_vars_from_file==0 ) THEN + Alt_above_ela = 0.0 + Prev_out = 0.0 + Prev_outi = 0.0 + Prev_area = 0.0D0 + Hru_glres_melt = 0.0 + Gl_top_melt = 0.0 + Glacr_flow = 0.0 + Gl_ice_melt = 0.0 + Hru_mb_yrend = 0.0 + Top = 0 + Term = 0 + Ela = 0 + Order_flowline = 0 + Ode_glacrva_coef = 0.0 + Hru_mb_yrcumul = 0.0D0 + Delta_volyr = 0.0D0 + Gl_mb_yrcumul = 0.0D0 + Gl_mb_cumul = 0.0D0 + Hru_slope_ts = Hru_slope + Basal_elev = Hru_elev_ts ! Hru_elev_ts always set in basin, need in case of restart + Basal_slope = Hru_slope_ts + Av_basal_slope = 0.0 + Glacr_elev_init = Hru_elev_ts + Glacr_slope_init = Hru_slope_ts + Av_fgrad = 0.0 + Basin_gl_top_melt = 0.0D0 + Basin_gl_top_gain = 0.0D0 + Basin_gl_ice_melt = 0.0D0 + Glnet_ar_delta = 0.0D0 + Ikeep_gl = 0 + Keep_gl = 0.0 + Basin_gl_storage = 0.0D0 + Basin_gl_storstart = 0.0D0 + Basin_gl_storvol = 0.0D0 + ENDIF + hru_flowline = 0 + toflowline = 0 + str_idm = 1.0E15 + cell_idm = 1.0E15 + uraw0 = 1.0E15 + xraw0 = 1.0E15 + fraw0 = 1.0E15 + hrawt = 1.0E15 + ra = 1.0E15 + rb = 1.0E15 + rc = 1.0E15 + rd = 1.0E15 + re = 1.0E15 + divu = 1.0E3 !in meters + glacier_frac_use = 0.0 + count = 0 + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + ! fill all glacier capable hrus to get variables calculated for all possible glaciers with correct branching + IF ( Hru_type(j)==4 ) THEN + count = 1 !has at least one glacier + glacier_frac_use(j) = 1.0 + !should be end of extensions or branches-- will fail if Weasel doesn't set up this way and then should go off area of branch + IF ( Tohru(j)/=j-1 ) THEN + glacier_frac_use(j) = 0.999 + ENDIF + ENDIF + ENDDO + IF ( count>0 ) THEN + ! Number the glaciers and tags parts that belong together + CALL tag_count(1, hru_flowline, toflowline, glacier_frac_use) + hru_dcum = 0.0 + DO i = 1, Ntp !do for all glacier capable hrus + ! will add self and everything above so cumulative dist from top of flowline + hru_dcum(Top(i)) = Hru_length(Top(i)) + prev = Top(i) + DO WHILE ( Tohru(prev)>0 ) + IF ( hru_flowline(Tohru(prev))==hru_flowline(Top(i)) ) & + & hru_dcum(Tohru(prev)) = Hru_length(Tohru(prev)) + hru_dcum(prev) !in km + prev = Tohru(prev) + ENDDO + ENDDO + ! Read input from GIS and compute depths + Nhrugl = 0 + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + IF ( Hru_type(j)==4 ) THEN + Nhrugl = Nhrugl + 1 + cell_idm(Nhrugl) = REAL(j) + str_idm(Nhrugl) = REAL(hru_flowline(j)) + uraw0(Nhrugl) = Hru_elev_meters(j) !inital Hru_elev in meters + xraw0(Nhrugl) = hru_dcum(j) - Hru_length(j)*0.5 !in km, put it at middle + hrawt(Nhrugl) = Hru_width(j) !in km + ENDIF + ENDDO + ! sort in ascending order by str_id + CALL sort5(Nhrugl, str_idm(1:Nhrugl), cell_idm(1:Nhrugl), uraw0(1:Nhrugl), xraw0(1:Nhrugl), & + & hrawt(1:Nhrugl), wksp(1:Nhrugl), iwksp(1:Nhrugl)) + is(1) = 1 + DO j = 1, Ntp - 1 + n_inline(j) = 0 + DO jj = is(j), Nhrugl + IF ( str_idm(jj)==j ) THEN + n_inline(j) = n_inline(j) + 1 + ELSEIF ( str_idm(jj)==j+1 ) THEN !got to end of string + ie(j) = jj - 1 !end of string + DO i = is(j), ie(j) !divide up + ra(i-is(j)+1) = xraw0(i) + rb(i-is(j)+1) = REAL(str_idm(i)) + rc(i-is(j)+1) = REAL(cell_idm(i)) + rd(i-is(j)+1) = uraw0(i) + re(i-is(j)+1) = hrawt(i) + ENDDO + ! sort in ascending order by xraw0 + CALL sort5(n_inline(j), ra(1:n_inline(j)), rb(1:n_inline(j)), rc(1:n_inline(j)), & + & rd(1:n_inline(j)), re(1:n_inline(j)), wksp(1:n_inline(j)), iwksp(1:n_inline(j))) + DO i = is(j), ie(j) !put back in + xraw0(i) = ra(i-is(j)+1) + str_id(i) = INT(rb(i-is(j)+1)) + cell_id(i) = INT(rc(i-is(j)+1)) + uraw0(i) = rd(i-is(j)+1) + hrawt(i) = re(i-is(j)+1) + ENDDO + is(j+1) = jj !start of next string + EXIT !go to next + ENDIF + ENDDO + ENDDO + ! + IF (Ntp>1) n_inline(Ntp) = Nhrugl - ie(Ntp-1) + IF (Ntp==1) n_inline(Ntp) = Nhrugl + ie(Ntp) = Nhrugl + DO i = is(Ntp), ie(Ntp) !divide up + ra(i-is(Ntp)+1) = xraw0(i) + rb(i-is(Ntp)+1) = REAL(str_idm(i)) + rc(i-is(Ntp)+1) = REAL(cell_idm(i)) + rd(i-is(Ntp)+1) = uraw0(i) + re(i-is(Ntp)+1) = hrawt(i) + ENDDO + ! sort in ascending order by xraw0 + CALL sort5(n_inline(Ntp), ra(1:n_inline(Ntp)), rb(1:n_inline(Ntp)), rc(1:n_inline(Ntp)), & + & rd(1:n_inline(Ntp)), re(1:n_inline(Ntp)), wksp(1:n_inline(Ntp)), iwksp(1:n_inline(Ntp))) + DO i = is(Ntp), ie(Ntp) !put back in + xraw0(i) = ra(i-is(Ntp)+1) + str_id(i) = INT(rb(i-is(Ntp)+1)) + cell_id(i) = INT(rc(i-is(Ntp)+1)) + uraw0(i) = rd(i-is(Ntp)+1) + hrawt(i) = re(i-is(Ntp)+1) + ENDDO + ! make terminus and top xraw and uraw + ! if Glacier_frac(termh) <1, then essentially flattening terminus of glacier + ! Hru_elev_meters determined off glacierized and non-glacierized area and no way + ! of saying how high above bare ground glacier is, so have to flatten + DO j = 1, Ntp + IF ( toflowline(j)==0 ) THEN !terminus is end of last Hru + xrawterm(j) = xraw0(ie(j))+Hru_length(cell_id(ie(j)))*0.5 !in km + slu = (uraw0(ie(j))-uraw0(ie(j)-1))/(xraw0(ie(j))-xraw0(ie(j)-1)) !always at least two Hrus in glacier + urawterm(j) = (uraw0(ie(j)) + slu*Hru_length(cell_id(ie(j)))*0.5)/divu !in km + ELSE !terminus is middle of next Hru, 2 segments away and this is a side branch + termh = Tohru(cell_id(ie(j))) + urawterm(j) = Hru_elev_meters(termh)/divu !in km + xrawterm(j) = xraw0(ie(j)) + Hru_length(cell_id(ie(j)))*0.5 + Hru_width(termh)*0.5 !in km + ENDIF + ENDDO + ! normalize xflow, keep H in km (width with xflow) + DO i = 1, Nhrugl + DO j = 1, Ntp + IF ( i>=is(j) .AND. i<=ie(j) ) THEN + ll(j) = xrawterm(j)*divu ! in m + xrawt(i) = xraw0(i)*divu/ll(j) + urawt(i) = uraw0(i)/divu-urawterm(j) !in km + ENDIF + ENDDO + ENDDO + ! normalize urawTop, u scaled at term is always 0, x scaled at top is always 0. + DO j = 1, Ntp + slu = (urawt(is(j)+1)-urawt(is(j)))/(xrawt(is(j)+1)-xrawt(is(j))) !always at least two Hrus in glacier + urawtop(j) = urawt(is(j)) - slu*xrawt(is(j)) !in km + ENDDO + ! recalculate hru_slope same way as basal_slope, won't agree with GIS slope + DO j = 1, Ntp + len_str = ie(j) - is(j) + 1 + DO i = 1, len_str + urawm(i) = uraw0(is(j)+i-1)! unscaled in m + xrawm(i) = xraw0(is(j)+i-1)*divu! unscaled in m + ENDDO + xrawm(len_str+2) = 0.0 + xrawm(len_str+1) = ll(j) + urawm(len_str+2) = (urawtop(j)+urawterm(j))*divu !in m, unscaled + urawm(len_str+1) = urawterm(j)*divu !in m + u2dd(1)= (urawm(2)-urawm(len_str+2))/(xrawm(2)-xrawm(len_str+2)) + flowSurf_slope(is(j)) = u2dd(1) + DO i = 2, len_str + u2dd(i)= (urawm(i+1)-urawm(i-1))/(xrawm(i+1)-xrawm(i-1)) + flowSurf_slope(is(j)+i-1) = u2dd(i) + ENDDO + ENDDO + DO i = 1, Nhrugl + Keep_gl(i,4) = flowsurf_slope(i) !initiate, if don't do bottom calculations will stay here + Hru_slope_ts(cell_id(i)) = ABS(flowsurf_slope(i)) !always positive by definition + ENDDO + Glacr_slope_init = Hru_slope_ts + Basal_slope = Hru_slope_ts + ! Keep stuff + DO i = 1, Nhrugl + Keep_gl(i,1) = urawt(i) + Keep_gl(i,2) = xrawt(i) + Keep_gl(i,3) = hrawt(i) + Ikeep_gl(i,1) = cell_id(i) + Ikeep_gl(i,2) = str_id(i) + ENDDO + DO i = 1, Ntp + Keep_gl(i,5) = urawtop(i) + Keep_gl(i,6) = urawterm(i) + Keep_gl(i,7) = xrawterm(i) + Ikeep_gl(i,3) = is(i) + Ikeep_gl(i,4) = ie(i) + ENDDO + glacier_frac_use = 0.0 + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + Hru_area_inch2(j) = Hru_area(j)*Acre_inch2 + IF ( Hru_type(j)==4 ) THEN + glacier_frac_use(j)= Glacier_frac(j) + !should be end of extensions or branches-- will fail if Weasel doesn't set up this way and then should go off area of branch + ! making it so has no connected branches because branching bottom calculations don't work + IF ( Tohru(j)/=j-1 .AND. glacier_frac_use(j)==1.0) glacier_frac_use(j) = 0.999 + ENDIF + ENDDO + CALL tag_count(0, hru_flowline, toflowline, glacier_frac_use) + !CALL tag_count(1, hru_flowline, toflowline, Glacier_frac) + ! compute area at start + curr_area = 0.0D0 + add_area = 0.0D0 + DO i = 1, Ntp !do for all glacier capable hrus + ! will add self and everything above so cumulative area from top of flowline + curr_area(Top(i)) = DBLE(Glacier_frac(Top(i)))*Hru_area_inch2(Top(i)) + prev = Top(i) + DO WHILE ( Tohru(prev)>0 ) + IF ( Glacr_tag(Tohru(prev))==Glacr_tag(Top(i)) ) THEN + !should be end of extensions or branches-- will fail if Weasel doesn't set up this way, + ! and then should go off area of branch + ! making it so has no connected branches because branching bottom calculations don't work + IF ( Tohru(prev)==prev-1 ) THEN + curr_area(Tohru(prev)) = DBLE(Glacier_frac(Tohru(prev)))*Hru_area_inch2(Tohru(prev)) & + & + curr_area(prev) + prev = Tohru(prev) + ELSE !a branch join + prev0 = prev + DO WHILE ( Tohru(prev)>0 ) + IF ( Glacr_tag(Tohru(prev))==Glacr_tag(Top(i)) ) THEN + add_area(Tohru(prev)) = curr_area(prev0) + prev = Tohru(prev) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ELSE + EXIT + ENDIF + ENDDO + ENDDO + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + IF ( Hru_type(j)==4 ) THEN + curr_area(j) = curr_area(j) + add_area(j) + Prev_area(j) = curr_area(j) !need this for ela calcs, actually is current area + ENDIF + ENDDO + !DO j = 1,Nhru + ! write(9,*) j,',',Glacr_tag(j) + !ENDDO + Gl_area = 0.D0 + Basin_gl_area = 0.D0 + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag + Basin_gl_area = Basin_gl_area + curr_area(Term(o)) + Gl_area(p) = curr_area(Term(o))/Acre_inch2 + !print*, 'Glacr_tag', p, ', area acres branches=', Gl_area(p), ', terminus HRU=', Term(o) + ENDDO + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==1 ) Basin_gl_area = Basin_gl_area + DBLE(Snowfld_frac(j))*Hru_area_inch2(j) + ENDDO + ! + doela = compute_ela_aar() !no previous years MB, get ELA from AAR ratio, need Prev_area + DO ii = 1, Ntp + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==4 ) THEN + IF ( Top_tag(j)==Top_tag(Top(ii)) ) Alt_above_ela(j) = Hru_elev_ts(j)- Hru_elev_ts(Ela(ii)) + ENDIF + ENDDO + ENDDO + !******Compute basin weighted averages + ! Basin_area_inv is in 1/acres, Basin_gl_area in inches squared + Basin_gl_area = (Basin_gl_area/Acre_inch2)*Basin_area_inv + !print*, 'Basin area acres=', 1.0/Basin_area_inv + ENDIF ! skip all if no glaciers +! + END FUNCTION glacrinit + +!*********************************************************************** +! glacrrun - Computes surface runoff using contributing area +! computations +!*********************************************************************** + INTEGER FUNCTION glacrrun() + USE PRMS_GLACR + USE PRMS_BASIN, ONLY: Hru_elev_ts, Active_hrus, Hru_route_order, Hru_type, NEARZERO, & + & Elev_units, Hru_elev_feet, Hru_elev_meters, FEET2METERS, METERS2FEET + USE PRMS_FLOWVARS, ONLY: Alt_above_ela, Snowfld_frac + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: comp_glsurf, recompute_soltab +! Local Variables + INTEGER :: dosol, i, j, count +!*********************************************************************** + glacrrun = 0 + count = 0 +! + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_type(i)==1 ) THEN + IF (Snowfld_frac(j)>NEARZERO) THEN + count=1 !has at least one snowfield + EXIT + ENDIF + ENDIF + ENDDO + IF( Ngl==0 ) THEN !no more glaciers, will first happen at 10/1 when size changes + Gl_area = 0.D0 + Glnet_ar_delta = 0.0D0 + Hru_glres_melt = 0.0 + Gl_top_melt = 0.0 + Gl_ice_melt = 0.0 + Hru_mb_yrend = 0.0 + Hru_mb_yrcumul = 0.0D0 + Delta_volyr = 0.0D0 + Gl_mb_yrcumul = 0.0D0 + Gl_mb_cumul = 0.0D0 + Av_basal_slope = 0.0 + Av_fgrad = 0.0 + Hru_slope_ts = Basal_slope + Alt_above_ela = 0.0 ! doesn't matter if no glaciers + dosol = recompute_soltab() ! change soltab tables for Hru_slope_ts + IF (count==0) THEN + Glacr_flow = 0.0 + Basin_gl_area = 0.D0 !no snowfields either + Basin_gl_top_melt = 0.0D0 + Basin_gl_top_gain = 0.0D0 + Basin_gl_ice_melt = 0.0D0 + Basin_gl_storage = 0.0D0 + Basin_gl_storstart = 0.0D0 + Basin_gl_storvol = 0.0D0 + ENDIF + glacrrun = comp_glsurf(0,count) !call with no glaciers + ELSE ! have glaciers + glacrrun = comp_glsurf(1,count) + ENDIF + + ! reset hru_elev variables for glacier HRUs + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_type(i)==4 ) THEN + IF ( Ngl==0 ) Hru_elev_ts(i) = Basal_elev(i) + IF ( Elev_units==0 ) THEN + Hru_elev_feet(i) = Hru_elev_ts(i) + Hru_elev_meters(i) = Hru_elev_ts(i)*FEET2METERS + ELSE + Hru_elev_meters(i) = Hru_elev_ts(i) + Hru_elev_feet(i) = Hru_elev_ts(i)*METERS2FEET + ENDIF + ENDIF + ENDDO +! + END FUNCTION glacrrun + +!*********************************************************************** +! function comp_glsurf - Computes surface runoff using contributing area +! computations +!*********************************************************************** + INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) + USE PRMS_GLACR + USE PRMS_MODULE, ONLY: Nhru, Starttime + USE PRMS_BASIN, ONLY: Hru_type, Hru_elev_ts, Basin_area_inv, Active_hrus, & + & Hru_route_order, NEARZERO, DNEARZERO, Elev_units, FEET2METERS, METERS2FEET, Hru_elev + USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday, Julwater, Modays + USE PRMS_INTCP, ONLY: Net_rain, Net_snow + USE PRMS_SNOW, ONLY: Snowcov_area, Snowmelt, Glacrmelt, Glacr_air_deltemp, Glacr_delsnow, & + & Snowfld_frac_init, Snowcov_area, Basin_snowicecov, Snow_evap, Glacr_evap, Basin_glacrb_melt + USE PRMS_FLOWVARS, ONLY: Glacier_frac, Alt_above_ela, Snowfld_frac + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: get_ftnunit, compute_ela_mb, compute_ela_aar, recompute_soltab + INTRINSIC ABS, EXP, SUM, SQRT, ISNAN, SNGL, DBLE + EXTERNAL tag_count, bottom +! Local Variables + INTEGER :: i, j, ii, jj, o, p, stact_hrus, endact_hrus, next, curr, keep, doela, dosol + INTEGER :: thecase(Nhru), toflowline(Nhru), count_delta(Nhru), lowpt(Nhru), lowest(Nhru) + INTEGER :: cell_id(Nhru), gl_top(Nhru), hru_flowline(Nhru), gln, topn, count_delta2(Nhru) + INTEGER :: done, gt(Nhru), oldlow, prev, prev0, dobot, botwrite + REAL :: stor, remain, gl_snow, glacrold, ca, ode_area(Nhru), av_elev(Nhru), gl_evap + REAL :: fraw0(Nhru), ela_elevt(Nhru), volm(Nhru), aream(Nhru), frawt(Nhru), divu + REAL :: slope(Nhru), ode_vol(Nhru), flow_slope(Nhru), glacier_frac_use(Nhru), glacier_fracp(Nhru) + DOUBLE PRECISION :: gl_total(Nhru), tot_reserv(3), delta_vol(Nhru), extra_vol, gl_gain(Nhru) + DOUBLE PRECISION :: delta_areayr(Nhru), curr_area(Nhru), volresv, volresv_ice, add_areap(Nhru) + DOUBLE PRECISION :: in_top_melt_tot(3), in_top_melt(3, Nhru), tot_delta_mb(Nhru), add_area(Nhru) + DOUBLE PRECISION :: tot_reservi(3),in_top_melt_itot(3), in_top_melt_ice(3, Nhru), curr_areap(Nhru) +! Arguments + INTEGER, INTENT(IN) :: glacr_exist, snowfld_exist +!*********************************************************************** + comp_glsurf = 1 + dobot = 1 ! 1 calls bottom calcs, 0 doesn't: Set to 0 for calibrating, then run one extra step with it on + ! Should change so that saves the basal elevations (or reads in as parameter) and then recalibrating does not change + botwrite = 0 ! 1 writes bottom calcs, 0 doesn't: Set to 0 for calibrating +! initialize + ela_elevt = 0.0 + gt = 0 + gl_top = 0 + lowest = 0 + count_delta = 0 + count_delta2 = 0 + delta_areayr = 0.0 + delta_vol = 0.0D0 + lowpt = 0 + stact_hrus = 0 + endact_hrus = 0 + av_elev = 0.0 + flow_slope = 0.0 + ode_area = 0.0 + ode_vol = 0.0 + slope = 0.0 + volm = 0.0 + aream = 0.0 + divu = 1.0E3 !in meters + Basin_gl_top_melt = 0.0D0 + Basin_gl_top_gain = 0.0D0 + Basin_gl_ice_melt = 0.0D0 + Hru_glres_melt = 0.0 + Snowfld_melt = 0.0 + Gl_top_melt = 0.0 + Gl_ice_melt = 0.0 + Glacr_flow = 0.0 + Gmbc_bsicm = 0.D0 + Gmbc_bsicm_sego = 0.0D0 + Basin_snowicecov = Basin_snowicecov*Acre_inch2/Basin_area_inv + gl_gain = 0.D0 +! +! Start of year calculations after have a year of data + IF ( Julwater==1 .AND. Nowyear>=Starttime(1)+1) THEN + IF (glacr_exist==1 ) THEN !have glaciers +! Save year ending values from previous year + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + IF ( Hru_type(j)==4 ) THEN + IF ( Glacier_frac(j)>NEARZERO ) THEN + Hru_mb_yrend(j) = SNGL(Hru_mb_yrcumul(j)) + ENDIF + ENDIF + ENDDO +! ELA calculations + IF ( MBinit_flag==2 ) THEN + doela = compute_ela_aar() !want steady state ELA estimation for fraw calc + DO j = 1, Ntp + ela_elevt(j)=Hru_elev(Ela(j)) !will scale inside subroutine, want initial one without _ts + IF (elev_units==0) ela_elevt(j) = ela_elevt(j)*FEET2METERS !put in meters + ENDDO + ENDIF + doela = compute_ela_mb() !Regular ELA estimation for daily reservoir calcs + DO i = 1, Nhrugl + cell_id(i) = Ikeep_gl(i,1) + fraw0(i) = Hru_mb_yrend(cell_id(i))/39.37 !inches to m + frawt(i) = fraw0(i)/divu !in km + ENDDO +! Have a year of mass balance, compute bottom so can do Hru_elev_ts + IF ( Nowyear==Starttime(1)+1) THEN ! do bottom calcs and get ca + ALL_unit = get_ftnunit(735) + Output_unit = get_ftnunit(All_unit) + IF (botwrite==1) OPEN ( Output_unit, FILE='output.dat' ) +! get flowline info + glacier_frac_use = 0.0 + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + IF ( Hru_type(j)==4 ) THEN + glacier_frac_use(j)= Glacier_frac(j) + !should be end of extensions or branches-- will fail if Weasel doesn't set up this way, + ! and then should go off area of branch + ! making it so has no connected branches because branching bottom calculations don't work + IF ( Tohru(j)/=j-1 .AND. glacier_frac_use(j)==1.0) glacier_frac_use(j) = 0.999 + ENDIF + ENDDO + CALL tag_count(0, hru_flowline, toflowline, glacier_frac_use) +! order flowline parts of each glacier + gln = 0 !initalize, end value is Ngl for this timestep + DO j = 1, Ntp + IF ( toflowline(j)==0 ) THEN + gln = gln + 1 + gt(j) = gln + ELSE + gt(j) = 0 + ENDIF + ENDDO + DO j = 1, Ntp + IF ( gt(j)/=0 ) THEN !should be gln of these + done = 0 + DO i = 1, Ntp + IF ( toflowline(i)==j .AND. gt(i)==0 ) THEN + gt(i) = gt(j) + ELSEIF ( gt(i)/=0 ) THEN !how many to go + done = done + 1 + ENDIF + ENDDO + ENDIF + ENDDO + topn = 0 !initalize, end value is Ntp for this timestep + DO j = 1, Ntp + DO i = 1, Ntp + IF ( j==toflowline(i) ) EXIT !j is not a top stream + ENDDO + IF ( i-1==Ntp ) THEN !got to end, j is a top stream + topn = topn + 1 + gl_top(topn) = j + ENDIF + ENDDO +!Find depths and sort these out too, to get av_elev and flow_slope, write stuff for plotting + IF (dobot ==1) THEN + CALL bottom(fraw0(1:Nhrugl), gln, gt(1:Ntp), topn, gl_top(1:Ntp), av_elev(1:Nhrugl), & + & ela_elevt(1:Ntp), flow_slope(1:Nhrugl), toflowline(1:Ntp), slope(1:Nhrugl), & + & ode_area(1:Nhrugl), ode_vol(1:Nhrugl), botwrite) + + IF (botwrite==1) WRITE ( Output_unit, '(A5,6A13)' ) 'HRU', 'Basal_elev', 'Glacr_elev_i','Hru_elev', & + & 'Basal_slope', 'Hru_slpe_ts', 'Glacr_slpe_i' + Basin_gl_storstart = 0.D0 + DO i = 1, Nhrugl + Keep_gl(i,4) = slope(i) !likely negative, assuming glacier HRU downhill + IF ( Elev_units==0 ) THEN + Basal_elev(cell_id(i)) = av_elev(i)/FEET2METERS !'av_elev in meters, want in elev_units + ELSE + Basal_elev(cell_id(i)) = av_elev(i) + ENDIF + Basal_slope(cell_id(i)) = flow_slope(i) !always positive by definition + volm(cell_id(i)) = ode_vol(i) !indexed by terminus HRU + aream(cell_id(i)) = ode_area(i) !indexed by terminus HRU + Basin_gl_storstart = Basin_gl_storstart+ ode_vol(i) !in km^3 + ENDDO + Basin_gl_storstart = (Basin_gl_storstart*(39370.1**3.0)/Acre_inch2)*Basin_area_inv + ELSE + DO i = 1, Nhrugl + volm(cell_id(i)) = 0.0 !indexed by terminus HRU + aream(cell_id(i)) = 0.0 !indexed by terminus HRU + ENDDO + ENDIF + DO i = 1, Nhrugl +! Need to do this so that Hru_elev_ts is actually the same as Hru_elev before melt in terminus + IF ( Glacier_frac(cell_id(i))>NEARZERO) THEN !only effects terminus + Glacr_elev_init(cell_id(i)) = (Hru_elev(cell_id(i)) - (1.0-Glacier_frac(cell_id(i))) & + & *Basal_elev((cell_id(i))))/Glacier_frac(cell_id(i)) + Glacr_slope_init(cell_id(i)) = (Hru_slope_ts(cell_id(i)) - (1.0-Glacier_frac(cell_id(i))) & + & *Basal_slope((cell_id(i))))/Glacier_frac(cell_id(i)) + ENDIF + IF (botwrite==1) WRITE ( Output_unit, '(I5,6F13.5)' ) cell_id(i), Basal_elev(cell_id(i)), & + & Glacr_elev_init(cell_id(i)), Hru_elev(cell_id(i)), Basal_slope(cell_id(i)), Hru_slope_ts(cell_id(i)), & + & Glacr_slope_init(cell_id(i)) + ENDDO + ENDIF +! +! Do for all years + CALL yearly_ca_coef(frawt(1:Nhrugl), ela_elevt(1:Ntp)) +! +!After first year estimate Glacrva_coef based on ODE volume and area, ca = Vol/(Area**Glacrva_exp) +! ca = (Glacrva_coef*39.37**(3.0-2.0*Glacrva_exp))*(Av_fgrad(p)**(0.2))*(Av_basal_slope(p)**(-0.4)) + IF ( Nowyear==Starttime(1)+1) THEN ! do bottom calcs and get ca + IF (botwrite==1) WRITE ( Output_unit, '(A6,A11,A15)' ) 'Glacr', 'Term_HRU_i', 'Gl_area_init' + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag + Ode_glacrva_coef(p) = (volm(Term(o))/(aream(Term(o))**Glacrva_exp(Term(o))))* & + & (1000.0**(3.0-2.0*Glacrva_exp(Term(o))))/(Av_fgrad(p)**(0.2))/(Av_basal_slope(p)**(-0.4)) + !Note, this is based off the flowline depth, not the average depth, thus the volume overestimated + ! so it is an upper estimate of the coefficient + IF (botwrite==1) WRITE ( Output_unit, '(I6,I10,F15.6)' ) p, Term(o), Gl_area(p) + ENDDO + CLOSE ( Output_unit ) + ! Set back to real flowlines without dividing branches + CALL tag_count(0, hru_flowline, toflowline, Glacier_frac) +! compute area at start + curr_area = 0.0D0 + add_area = 0.0D0 + DO i = 1, Ntp !do for all glacier capable hrus + ! will add self and everything above so cumulative area from top of flowline + curr_area(Top(i)) = DBLE(Glacier_frac(Top(i)))*Hru_area_inch2(Top(i)) + prev = Top(i) + DO WHILE ( Tohru(prev)>0 ) + IF ( Glacr_tag(Tohru(prev))==Glacr_tag(Top(i)) ) THEN + !should be end of extensions or branches-- will fail if Weasel doesn't set up this way, + ! and then should go off area of branch + ! making it so has no connected branches because branching bottom calculations don't work + IF ( Tohru(prev)==prev-1 ) THEN + curr_area(Tohru(prev)) = DBLE(Glacier_frac(Tohru(prev)))*Hru_area_inch2(Tohru(prev)) & + & + curr_area(prev) + prev = Tohru(prev) + ELSE !a branch join + prev0 = prev + DO WHILE ( Tohru(prev)>0 ) + IF ( Glacr_tag(Tohru(prev))==Glacr_tag(Top(i)) ) THEN + add_area(Tohru(prev)) = curr_area(prev0) + prev = Tohru(prev) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ELSE + EXIT + ENDIF + ENDDO + ENDDO + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + IF ( Hru_type(j)==4 ) THEN + curr_area(j) = curr_area(j) + add_area(j) + ENDIF + ENDDO + Gl_area = 0.D0 + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag + Gl_area(p) = curr_area(Term(o))/Acre_inch2 + !IF (Term(o)== 1) print*,'Calibrate to Glacr_tag', p, 'of' ,Ngl + !print*, 'Glacr_tag', p, 'of', Ngl,', area acres initial=', Gl_area(p), ', terminus HRU=', Term(o) + ENDDO + Glnet_ar_delta=0.D0 !start at beginning + ENDIF + +! +! Do retreat/advance on whole glacier at end of year +! last year's area/volume is previous area + Prev_area = 0.D0 + add_area = 0.0D0 + DO i = 1, Ntp !do for all glacier capable hrus + ! will add self and everything above so cumulative area from top of flowline + Prev_area(Top(i)) = DBLE(Glacier_frac(Top(i)))*Hru_area_inch2(Top(i)) + prev = Top(i) + DO WHILE ( Tohru(prev)>0 ) + IF ( Glacr_tag(Tohru(prev))==Glacr_tag(Top(i)) ) THEN + !should be end of extensions or branches-- will fail if Weasel doesn't set up this way, + ! and then should go off area of branch + ! making it so has no connected branches because branching bottom calculations don't work + IF ( Tohru(prev)==prev-1 ) THEN + Prev_area(Tohru(prev)) = DBLE(Glacier_frac(Tohru(prev)))*Hru_area_inch2(Tohru(prev)) & + & + Prev_area(prev) + prev = Tohru(prev) + ELSE !a branch join + prev0 = prev + DO WHILE ( Tohru(prev)>0 ) + IF ( Glacr_tag(Tohru(prev))==Glacr_tag(Top(i)) ) THEN + add_area(Tohru(prev)) = add_area(Tohru(prev))+Prev_area(prev0) + prev = Tohru(prev) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ELSE + EXIT + ENDIF + ENDDO + ENDDO + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + IF ( Hru_type(j)==4 ) THEN + Prev_area(j) = Prev_area(j) + add_area(j) + ENDIF + ENDDO + glacier_fracp = Glacier_frac !save before recalculate + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag + !from Luthi 09, varying every year may cause trouble as shrinks + !global average=0.28*39.37**(3-2*1.375)=.70 in^.25 from Arendt 2006 + ca = (Glacrva_coef(Term(o))*39.37**(3.0-2.0*Glacrva_exp(Term(o))))*(Av_fgrad(p)**(0.2))*(Av_basal_slope(p)**(-0.4)) + Prev_vol(p) = DBLE(ca)*(Prev_area(Term(o)))**DBLE(Glacrva_exp(Term(o))) + IF ( Prev_vol(p)+Delta_volyr(p)0.0 ) +! in advancing glacier, get rid of total snow till furthest possible +! terminus of glacier (not letting the glaciers combine) THIS WILL BE DICTATED BY THE HRU MAP + glacrold = Glacier_frac(curr) + Glacier_frac(curr) = (Glacier_frac(curr)*SNGL(Hru_area_inch2(curr))+remain) & + & /SNGL(Hru_area_inch2(curr)) !all in inches + IF ( Glacier_frac(curr)>1.0 ) THEN !glacier can't be more than full, look for next to advance in to + Glacier_frac(curr) = 1.0 + next = Tohru(curr) !find next to expand in to, could be another glacier then will go to its terminus + IF ( next==0 ) THEN + ! can't advance anymore + remain = remain - (1.0-glacrold)*SNGL(Hru_area_inch2(curr)) + IF ( remain/Hru_area_inch2(curr)<=NEARZERO ) remain = 0.0 + extra_vol = Prev_vol(Term(o)) + Delta_volyr(p) - & + & DBLE(ca)*(Prev_area(Term(o))+delta_areayr(o)-DBLE(remain))**DBLE(Glacrva_exp(Term(o))) + !amount not added to area that should, use to thicken later + EXIT + ENDIF + ENDIF + remain = remain - (Glacier_frac(curr)-glacrold)*SNGL(Hru_area_inch2(curr)) + IF ( remain/Hru_area_inch2(curr)<=NEARZERO ) THEN !limit of accuracy for reals + remain = 0.0 + ENDIF + curr = next + ENDDO +! + IF ( Delta_volyr(p)-NEARZERO ) THEN !limit of accuracy for reals + remain = 0.0 + ENDIF + ENDDO + ENDDO !get out of the loop over all the glaciers +! clean up and compute area before start of year + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==4 ) THEN + IF ( Glacier_frac(j)1.0-NEARZERO ) Glacier_frac(j)=1.0 + ELSE + Glacier_frac(j)=0.0 + ENDIF + ENDDO +! Have to renumber the glaciers and tags incase lost some + CALL tag_count(0, hru_flowline, toflowline, Glacier_frac) + ! compute new area + curr_area = 0.0D0 + add_area = 0.0D0 + curr_areap = 0.0D0 + add_areap = 0.0D0 + DO i = 1, Ntp !do for all glacier capable hrus + ! will add self and everything above so cumulative area from top of flowline + curr_area(Top(i)) = DBLE(Glacier_frac(Top(i)))*Hru_area_inch2(Top(i)) + curr_areap(Top(i)) = DBLE(glacier_fracp(Top(i)))*Hru_area_inch2(Top(i)) + prev = Top(i) + DO WHILE ( Tohru(prev)>0 ) + IF ( Glacr_tag(Tohru(prev))==Glacr_tag(Top(i)) ) THEN + !should be end of extensions or branches-- will fail if Weasel doesn't set up this way, + ! and then should go off area of branch + ! making it so has no connected branches because branching bottom calculations don't work + IF ( Tohru(prev)==prev-1 ) THEN + curr_area(Tohru(prev)) = DBLE(Glacier_frac(Tohru(prev)))*Hru_area_inch2(Tohru(prev)) & + & + curr_area(prev) + curr_areap(Tohru(prev)) = DBLE(glacier_fracp(Tohru(prev)))*Hru_area_inch2(Tohru(prev)) & + & + curr_areap(prev) + prev = Tohru(prev) + ELSE !a branch join + prev0 = prev + DO WHILE ( Tohru(prev)>0 ) + IF ( Glacr_tag(Tohru(prev))==Glacr_tag(Top(i)) ) THEN + add_area(Tohru(prev)) = add_area(Tohru(prev))+curr_area(prev0) + add_areap(Tohru(prev)) = add_areap(Tohru(prev))+curr_areap(prev0) + prev = Tohru(prev) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ELSE + EXIT + ENDIF + ENDDO + ENDDO + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + IF ( Hru_type(j)==4 ) THEN + curr_area(j) = curr_area(j) + add_area(j) + curr_areap(j) = curr_areap(j) + add_areap(j) + ENDIF + ENDDO + Gl_area = 0.D0 + Basin_gl_area = 0.D0 + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag + Glnet_ar_delta(p) = Glnet_ar_delta(p) + ( curr_area(Term(o)) - curr_areap(Term(o)) )/Acre_inch2 + Gl_area(p) = curr_area(Term(o))/Acre_inch2 + Basin_gl_area = Basin_gl_area + curr_area(Term(o)) + !print*, 'Glacr_tag', p, ', area acres', Nowyear,' =', Gl_area(p), ', terminus HRU=', Term(o) + ENDDO +! have bottom, compute Hru_elev_ts related stuff + DO ii = 1, Ntp + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==4 ) THEN + IF ( Top_tag(j)==Top_tag(Top(ii)) ) Alt_above_ela(j) = Hru_elev_ts(j)- Hru_elev_ts(Ela(ii)) + Hru_elev_ts(j) = Glacier_frac(j)*Glacr_elev_init(j) + (1.0-Glacier_frac(j))*Basal_elev(j) + Hru_slope_ts(j) = Glacier_frac(j)*Glacr_slope_init(j) + (1.0-Glacier_frac(j))*Basal_slope(j) + ENDIF + ENDDO + ENDDO + dosol = recompute_soltab() ! change soltab tables for Hru_slope_ts +! Beginning of year zero out + Hru_mb_yrcumul = 0.0D0 + Delta_volyr = 0.0D0 +! Clean stuff if gone + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==4 ) THEN + IF ( Glacier_frac(j)==0.0 ) THEN + Hru_mb_yrend(j) = 0.0 + Hru_mb_yrcumul(j) = 0.0D0 + Alt_above_ela(j) = 0.0 + ENDIF + ENDIF + ENDDO + DO p = 1, Nhru !because could be left over more than Ngl of these + IF ( Gl_area(p)==0.D0 ) THEN + Glnet_ar_delta(p) = 0.0D0 + Delta_volyr(p) = 0.0D0 + Gl_mb_yrcumul(p) = 0.0D0 + Gl_mb_cumul(p) = 0.0D0 + Av_basal_slope(p) = 0.0 + Av_fgrad(p) = 0.0 + ENDIF + ENDDO + ENDIF +!Snowfield area change uses Baumann and Winkler 2010 to change area every 10 years; +! technically each snowfield should have own ablation elevation range. + IF (snowfld_exist==1) THEN !have snowfields, + IF ( MOD(Nowyear-Starttime(1),10)==0 ) THEN !change them + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==1 .AND. Snowfld_frac(j)>NEARZERO) THEN + IF ( Elev_units==0 ) Snowfld_frac(j) = ( METERS2FEET*(45.7*Glacr_air_deltemp(j) & + & -12.0*Glacr_delsnow(j))/Abl_elev_range(j) +1.0 )*Snowfld_frac_init(j) + IF ( Elev_units==1 ) Snowfld_frac(j) = ( (45.7*Glacr_air_deltemp(j) & + & -12.0*Glacr_delsnow(j))/Abl_elev_range(j) +1.0 )*Snowfld_frac_init(j) + IF ( Snowfld_frac(j)<0.0 ) Snowfld_frac(j)=0.0 + IF ( Snowfld_frac(j)>1.0 ) Snowfld_frac(j)=1.0 + ENDIF + ENDDO + ENDIF + DO i = 1, Active_hrus !every year + j = Hru_route_order(i) + Basin_gl_area = Basin_gl_area + DBLE(Snowfld_frac(j))*Hru_area_inch2(j) !keep in inches + ENDDO + ENDIF + +! +!******Compute basin weighted averages (to units of fraction area) +! Basin_area_inv is in 1/acres, Basin_area_inv is in 1/acres, Basin_gl_area in inches squared + Basin_gl_area = (Basin_gl_area/Acre_inch2)*Basin_area_inv + ENDIF !get out of start-of-year computations + +! +! Melt runoff calculations, every day + DO i = 1, Active_hrus + j = Hru_route_order(i) + Hru_glres_melt(j) = 0.0 + gl_total(j) = 0.0D0 + IF ( Hru_type(j)==4 ) THEN + !melting ice + melting snow (energy model), *area = volume + IF ( Glacier_frac(j)>NEARZERO ) THEN + Hru_glres_melt(j) = Glacier_frac(j)*(Snowmelt(j) + Glacrmelt(j)/Glacier_frac(j)) + Snowmelt(j) = (1.0 - Glacier_frac(j))*Snowmelt(j) ! this is the snowmelt that is not routed through glacier + ! all excess rain is included in melt so glacier melt is ( glacier_frac*(snowmelt+net_rain)+ glacrmelt )*hru_area + gl_snow = Glacier_frac(j)*(Net_rain(j)+Net_Snow(j)) !Pk_precip is zero if no snow, so don't use + gl_evap = Glacier_frac(j)*(Snow_evap(j) + Glacr_evap(j)/Glacier_frac(j)) + gl_gain(j) = DBLE(gl_snow - gl_evap) + gl_total(j) = -Hru_glres_melt(j) + gl_gain(j) + !this is daily mass balance on glacier part of HRU in inches, divide by glacier_frac so averaged over glaciated part of HRU only + Hru_mb_yrcumul(j) = Hru_mb_yrcumul(j) + gl_total(j)/Glacier_frac(j) + Basin_gl_top_gain = Basin_gl_top_gain + gl_gain(j)*Hru_area_inch2(j) + !postive indicates snow, negative indicates melt + ENDIF + ENDIF + IF ( Hru_type(j)==1 ) THEN + Snowfld_melt(j) = 0.0 + !melting ice + melting snow (energy model), *area = volume + IF ( Snowfld_frac(j)>NEARZERO ) THEN + Snowfld_melt(j) = Snowfld_frac(j)*(Snowmelt(j) + Glacrmelt(j)/Snowfld_frac(j)) + Snowmelt(j) = (1.0 - Snowfld_frac(j))*Snowmelt(j) ! this is the snowmelt that is not included in Snow field melt + gl_snow = Snowfld_frac(j)*(Net_rain(j)+Net_Snow(j)) !Pk_precip is zero if no snow, so don't use + gl_evap = Snowfld_frac(j)*(Snow_evap(j) + Glacr_evap(j)/Snowfld_frac(j)) + gl_gain(j) = DBLE(gl_snow - gl_evap) + ENDIF + ENDIF + ENDDO + + in_top_melt = 0.0D0 !initialize + in_top_melt_ice = 0.0D0 !initialize + IF (glacr_exist==1) THEN + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag +! This code will force at least top of each branch to be above or at ELA + DO ii = 1, Ntp + thecase(ii) = 0 + ! find a branch in glacier + IF ( Glacr_tag(Top(ii))/=p ) CYCLE + keep = Top(ii) + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==4 ) THEN + !find lowest in branch + IF ( Glacr_tag(j)==p .AND. & + & (Top_tag(j)==Top_tag(Top(ii)) .OR. (Top_tag(j)==-1.AND.count_delta2(j)==0)) ) THEN + count_delta2(j) = 1 !for ones that are end of two branches, will be made part of first branch + IF ( Hru_elev_ts(j)NEARZERO ) THEN !no branch abl.zone + thecase(ii) = 2 + ENDIF + +! Now find reservoirs in each branch: three-- firn, snow, and ice + DO jj = 1, 3 !firn, snow, ice + IF ( jj==1 ) THEN !accumulation zone + IF ( Top(ii)==Ela(ii) .AND. thecase(ii)/=1 ) CYCLE !has no acc. zone + stact_hrus = Top(ii) + keep = Top(ii) + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==4 ) THEN + !find lowest in branch above ELA-- there will be one + IF ( Top_tag(j)==Top_tag(Top(ii)) .AND. & + & Hru_elev_ts(j)Hru_elev_ts(Ela(ii)) ) keep = j + ENDIF + ENDDO + endact_hrus = keep + IF ( thecase(ii)==1 ) endact_hrus = lowest(ii) + ELSEIF ( jj==2 ) THEN !middle zone + stact_hrus = Ela(ii) + keep = Ela(ii) + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==4 ) THEN + !find lowest in branch with snow cover below ELA + IF ( Top_tag(j)==Top_tag(Top(ii)) .AND. & + & Snowcov_area(j)>NEARZERO .AND. & + & Hru_elev_ts(j)Hru_elev_ts(keep) .AND. & + & Hru_elev_ts(j)=Hru_elev_ts(endact_hrus) .AND. & + & (Top_tag(j)==Top_tag(stact_hrus) .OR. & + & (Top_tag(j)==-1.AND.count_delta(j)==0)) ) THEN + count_delta(j) = 1 + volresv = DBLE(Hru_glres_melt(j))*Hru_area_inch2(j) + IF ( volresv>DNEARZERO ) in_top_melt(jj, ii) = in_top_melt(jj, ii)+ volresv + ! all excess rain is included in melt, rain on ice goes into reservoirs + ! should be true unless Glacrmelt==0 + IF ( Glacrmelt(j)-Net_rain(j)*Glacier_frac(j)>NEARZERO ) & + & volresv_ice = DBLE(Glacrmelt(j)-Net_rain(j)*Glacier_frac(j))*Hru_area_inch2(j) + IF ( volresv_ice>DNEARZERO ) in_top_melt_ice(jj, ii) = in_top_melt_ice(jj, ii)+ volresv_ice + delta_vol(o) = delta_vol(o) + gl_total(j)*Hru_area_inch2(j)/0.917 + ! divide by density ratio to get in volume, if were all converted to ice (by end of year) + ENDIF + ENDIF + ENDDO +! skip some reservoirs if glacier branch is too small + IF ( jj==1 .AND. thecase(ii)==1 ) EXIT + ENDDO !collected all 3 reservoirs (jj) for this top ii + ENDDO !collected all branches in glacier + DO jj = 1, 3 + in_top_melt_tot(jj) = 0.0D0 + in_top_melt_itot(jj) = 0.0D0 + tot_reserv(jj) = 0.0D0 + tot_reservi(jj) = 0.0D0 + IF ( jj==1 ) THEN + stor = Stor_firn(Term(o),Nowmonth)/24.0 !days + ELSEIF ( jj==2 ) THEN + stor = Stor_snow(Term(o),Nowmonth)/24.0 !days + ELSEIF ( jj==3 ) THEN + stor = Stor_ice(Term(o),Nowmonth)/24.0 !days + ENDIF + DO ii = 1, Ntp + ! find a branch in glacier + IF ( Glacr_tag(Top(ii))/=p ) CYCLE + in_top_melt_tot(jj) = in_top_melt_tot(jj) + in_top_melt(jj, ii) + in_top_melt_itot(jj) = in_top_melt_itot(jj) + in_top_melt_ice(jj, ii) + IF ( jj==1 .AND. thecase(ii)==1 ) stor = Stor_snow(Term(o),Nowmonth)/24.0 !days + IF ( jj==2 .AND. thecase(ii)==2 ) stor = Stor_ice(Term(o),Nowmonth)/24.0 !days + ENDDO + tot_reserv(jj) = Prev_out(p, jj)*EXP(-1.0/stor) + in_top_melt_tot(jj)*(1.0-EXP(-1.0/stor)) + tot_reservi(jj) = Prev_outi(p, jj)*EXP(-1.0/stor) + in_top_melt_itot(jj)*(1.0-EXP(-1.0/stor)) + Gl_ice_melt(p) = Gl_ice_melt(p) + SNGL(tot_reservi(jj)) + Gl_top_melt(p) = Gl_top_melt(p) + SNGL(tot_reserv(jj)) + Prev_out(p, jj) = SNGL(in_top_melt_tot(jj)) + Prev_outi(p, jj) = SNGL(in_top_melt_itot(jj)) +! On last jj, will be at the terminus and have all out of glacier +! THIS IS THE TOTAL RUNOFF OUT THE ALL THE GLACIERS in inches cubed + Basin_gl_ice_melt = Basin_gl_ice_melt + tot_reservi(jj) + Basin_gl_top_melt = Basin_gl_top_melt + tot_reserv(jj) + ENDDO + Delta_volyr(p) = Delta_volyr(p) + delta_vol(o) +! only terminus HRUs will have glacier flow, like a flow from a gw reservoir + Glacr_flow(Term(o)) = Gl_top_melt(p) + ENDDO +! +! Calculated cumulative mass balance in inches of glaciers to compare to data +! Do off area changed after last day of previous hydrological year + tot_delta_mb = 0.D0 + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + IF ( Hru_type(j)==4 ) THEN + DO ii = 1, Active_hrus + i = Hru_route_order(ii) + IF ( Hru_type(i)==4 ) THEN !find a i in glacier + IF ( Glacr_tag(i)==Glacr_tag(j) .AND. Hru_elev_ts(i)>=Hru_elev_ts(j) ) THEN + !will add self (i=j) and everything above + tot_delta_mb(j) = tot_delta_mb(j) + Hru_mb_yrcumul(i)*Glacier_frac(i)*Hru_area_inch2(i) + ENDIF + ENDIF + ENDDO + Basin_snowicecov = Basin_snowicecov + DBLE(( 1.-Snowcov_area(j) )*Glacier_frac(j))*Hru_area_inch2(j) + ENDIF + ENDDO + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag + Gl_mb_yrcumul(p) = tot_delta_mb(Term(o))/(Gl_area(p)*Acre_inch2) !if glaciers combine or split will jump to new area and terminus + ENDDO + ENDIF +! + IF (snowfld_exist==1) THEN + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)==1 .AND. Snowfld_frac(j)>NEARZERO) THEN + ! all excess rain is included in melt, should be true unless Glacrmelt==0 + IF ( Glacrmelt(j)-Net_rain(j)*Snowfld_frac(j)>NEARZERO ) & + & Basin_gl_ice_melt = Basin_gl_ice_melt + DBLE(Glacrmelt(j)-Net_rain(j)*Snowfld_frac(j))*Hru_area_inch2(j) + Basin_gl_top_melt = Basin_gl_top_melt + DBLE(Snowfld_melt(j))*Hru_area_inch2(j) + Basin_gl_top_gain = Basin_gl_top_gain + DBLE(gl_gain(j))*Hru_area_inch2(j) + Basin_snowicecov = Basin_snowicecov + DBLE(( 1.-Snowcov_area(j) )*Snowfld_frac(j))*Hru_area_inch2(j) + Glacr_flow(j) = REAL(Snowfld_melt(j)*Hru_area_inch2(j)) + ENDIF + ENDDO + ENDIF +! +!******Compute basin weighted averages (to units of inches/dt) +! Basin_area_inv is in 1/acres, Basin_gl_top_* is in inches cubed over all area +! want in inches over all area + Basin_gl_ice_melt = (Basin_gl_ice_melt/Acre_inch2)*Basin_area_inv !this will be too small by the amount of rain soaked up by ice + Basin_gl_top_melt = (Basin_gl_top_melt/Acre_inch2)*Basin_area_inv + Basin_gl_top_gain = (Basin_gl_top_gain/Acre_inch2)*Basin_area_inv + Basin_snowicecov = (Basin_snowicecov/Acre_inch2)*Basin_area_inv +! these will be zero when glaciers are gone and negative while receding glaciers +! at zero point could back track it so gl_storage went from postive to zero + Basin_gl_storage = Basin_gl_storage + Basin_gl_top_gain - Basin_glacrb_melt - Basin_gl_top_melt + Basin_gl_storvol = Basin_gl_storage/Basin_area_inv +! + comp_glsurf = 0 +! + END FUNCTION comp_glsurf + +!*********************************************************************** +! function compute_ela_mb - Identifies ELA Hru closest to 0 from +! last years MB, won't work first year +!*********************************************************************** + INTEGER FUNCTION compute_ela_mb() + USE PRMS_GLACR, ONLY: Ntp, Ngl, Glacr_tag, Term, Top, Top_tag, Hru_mb_yrend, Ela + USE PRMS_MODULE, ONLY: Nhru + USE PRMS_BASIN, ONLY: Hru_type, Active_hrus, Hru_route_order + IMPLICIT NONE +! Functions + INTRINSIC ABS +! Local Variables + INTEGER :: i, j, ii, o, p, ela2(Nhru) + REAL :: elamin0(Nhru), elamin20(Nhru), elamin(Nhru), elamin2(Nhru) +!*********************************************************************** + compute_ela_mb = 1 +! initialize + ela2 = 0 + elamin0 = 1.0E15 + elamin20 = 1.0E15 + elamin = 1.0E15 + elamin2 = 1.0E15 + + DO o = 1, Ngl + !find the ELA hru + p = Glacr_tag(Term(o)) !index by Glacr_tag + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)/=4 ) CYCLE + ! find a j in glacier + IF ( Glacr_tag(j)/=p ) CYCLE + DO ii = 1, Ntp + IF ( Top_tag(j)==Top_tag(Top(ii)) ) THEN + !same glacier branch + elamin(j) = ABS(Hru_mb_yrend(j)) + IF ( elamin(j)=4.0*Convert_units ) aar = 0.64 + !for glaciers area >4km^2 + elaarea = SNGL(Prev_area(Term(o)))*aar +!aar is percentage of area from top down, from Kern and Laszlo 2010 +!for most glaciers will be 0.64 above ELA, 1 above terminus, 0 above top +!this assumes glacier at steady state + !find the ELA hru + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(j)/=4 ) CYCLE + ! find a j in glacier + IF ( Glacr_tag(j)/=p ) CYCLE + DO ii = 1, Ntp + IF ( Top_tag(j)==Top_tag(Top(ii)) ) THEN + !same glacier branch + elamin(j) = ABS(elaarea-SNGL(Prev_area(j))) + IF ( elamin(j)0.0 ) THEN ! in glacier HRU that is glacierized + IF (glacier_frac_use(j)==1.0) THEN + IF ( Tohru(j)==0 ) THEN !nowhere else to extend to + Ngl = Ngl + 1 + Term(Ngl) = j !only one terminus per glacier + ELSEIF ( glacier_frac_use(Tohru(j))==0.0 ) THEN ! next HRU empty of glacier but could extend + Ngl = Ngl + 1 + Term(Ngl) = j !only one terminus per glacier + ENDIF + ELSE ! glacier_frac_use(j)<1.0 but not 0, so at end, but next HRU could be another glacier + Ngl = Ngl + 1 + Term(Ngl) = j !only one terminus per glacier + ENDIF + DO jj = 1, Active_hrus + i = Hru_route_order(jj) + IF ( Hru_type(i)==4 ) THEN + IF ( glacier_frac_use(i)==1.0 .AND. Tohru(i)==j ) THEN + !segment with a glacier does feed to j + count = count + 1 + ENDIF + ENDIF + ENDDO + IF ( count==0 ) THEN !j is a top + IF (do_init==1) THEN + Ntp = Ntp + 1 + Top(Ntp) = j + ENDIF + ELSE !number that feed into j + numup(j) = count !j not a top + ENDIF + ENDIF + ENDIF + ENDDO +! + ! zero it all as a switch + hru_flowline = 0 + Glacr_tag = 0 + Top_tag = 0 + label = 1 + ii = 1 + +100 DO WHILE ( ii<=Ntp ) + hru_flowline(Top(ii)) = label + Glacr_tag(Top(ii)) = label + Top_tag(Top(ii)) = label + curr = Top(ii) + DO j = 1, Ngl + IF ( curr==Term(j) ) THEN + label = label + 1 !so each term has a label + ii = ii + 1 + GOTO 100 !end of glacier, go to next top + ENDIF + ENDDO + next = Tohru(curr) + IF (next==0) THEN !got to end of glacier + label = label + 1 !so each term has a label + ii = ii + 1 + GOTO 100 !end of glacier, go to next top + ENDIF + DO + IF ( Glacr_tag(next)==0 ) hru_flowline(next) = label + IF ( Glacr_tag(next)/=0 .AND. numup(next)>0 ) THEN + !already been assigned and at confluence + gltag0 = Glacr_tag(next) + DO jj = 1, Active_hrus + i = Hru_route_order(jj) + !give all glaciers the same tag + IF ( Hru_type(i)==4 .AND. Glacr_tag(i)==gltag0 ) Glacr_tag(i) = label + ENDDO + Top_tag(next) = -1 + toflowline(label) = hru_flowline(next) + !if single top glacier, will never have a negative part + ELSE + Top_tag(next) = label + ENDIF + Glacr_tag(next) = label + curr = next + DO j = 1, Ngl + IF ( curr==Term(j) ) THEN + label = label + 1 !so each term has a label + ii = ii + 1 + GOTO 100 !end of glacier, go to next top + ENDIF + ENDDO + next = Tohru(curr) + IF (next==0) THEN !got to end of glacier that no longer exists + label = label + 1 !so each term has a label + ii = ii + 1 + GOTO 100 !end of glacier, go to next top + ENDIF + ENDDO + ENDDO + + END SUBROUTINE tag_count + + +!*********************************************************************** +! subroutine bottom - calculates bottom topo using Salamatin and Mazo +! equations (1985) without optimization for steady state, instead +! needs a proxy for steady state mass balance. Can do this from mass +! balance calculation with climate data first year (MbInit_flag=1) +! or use max and min balance above and below Ela, respectively and assume +! constant mass balance gradient above and below Ela; e.g. Farinotti (MbInit_flag=2) +! All mass balances are adjust to put glacier in steady state. +! +! The method of Salamatin and Mazo is from conservation of mass, +! solving k*(u-z)*F1(sig)+(u-z)**2*F2(sig)+A(x)=0 +! sig=(u-z)*du/dx, u(1)=z(1) (the terminus has height 0) +! F1 =@(sig) sig.^((nn+1)/2); %Kamb law for sliding ice +! F2 =@(sig) (sig.^nn)/(nn+2); %polynomial rheological dependence for +! ice which is sliding + creeping + mass balance distribution =0 +!-- out+in=bal +!#of cells=Nhrugl,#of streams=Ntp,#of cells/stream<=Ntp, +!#of glaciers<=Nhru +!*********************************************************************** + SUBROUTINE bottom(Frawt, Gln, Gt, Topn, Gl_top, Av_elev, Ela_elevt, Flow_slope, & + & Toflowline, Slope, Ode_area, Ode_vol,Botwrite) + USE PRMS_GLACR, ONLY: Ntp, Nhrugl, All_unit, Output_unit, Density, Gravity, Aflow, & + & Order_flowline, Max_gldepth, Keep_gl, Ikeep_gl, Hru_length, Hru_slope_ts + USE PRMS_BASIN, ONLY: NEARZERO + USE PRMS_FLOWVARS, ONLY: Glacier_frac + IMPLICIT NONE + INTEGER, PARAMETER :: N = 101 +! Functions + EXTERNAL cumtrapzv, spline, splint, solve_poly + INTRINSIC MIN, MAX, ISNAN, SQRT +! Arguments + INTEGER, INTENT(IN) :: Gln, Topn, Gl_top(Ntp), Gt(Ntp), Toflowline(Ntp), Botwrite + REAL, INTENT(IN) :: Ela_elevt(Ntp), Frawt(Nhrugl) + REAL, INTENT(OUT) :: Av_elev(Nhrugl), Flow_slope(Nhrugl), Slope(Nhrugl) + REAL, INTENT(OUT) :: Ode_area(Nhrugl), Ode_vol(Nhrugl) +! Local Variables + INTEGER :: i, j, ii, jj, flag, next_do(Ntp), order(Ntp, 2), dothis0, dothis, done + INTEGER :: thestr, inda, indb, nextstr, ibot, itop, dont, len_str, spg(Nhrugl) + INTEGER :: str_done(Ntp), len_str_true, cell_id(Nhrugl), str_id(Nhrugl) + INTEGER :: is(Nhrugl), ie(Nhrugl), iem(Nhrugl) + REAL :: k, h, hvec(Nhrugl+1), balt(Nhrugl), uraw(Nhrugl), slp, setmax, ela_elev + REAL :: xraw(Nhrugl), hraw(Nhrugl), fraw(Nhrugl), araw0(Nhrugl), araw(Nhrugl) + REAL :: sa(Nhrugl+1), arawe0(Nhrugl+1), hvecn(N-1), zv(N), hv(N), xv(N), uv(N) + REAL :: upv(N), balraw(Nhrugl), add, balv(N), s(N),bal, amt, amt2, bot, top, zpv(N) + REAL :: hvecn2(N-1), intf3(N), yd, dv(N), dv0(N),dpv(N), dxh(N), areag, volg + REAL :: alld(N, Ntp), area(Gln), vol(Gln), y2d(N), zraw(Nhrugl+2), plinetop + REAL :: reparea, repvol, intf5(N), sina, stress, balx, pline(Nhrugl), draw(Nhrugl) + REAL :: rline(Nhrugl), y2a(Nhrugl), y2b(Nhrugl), y2c(Nhrugl), y2dd0(Nhrugl) + REAL :: allx(N, Ntp), zraw_av(Nhrugl+2), y2dd(Nhrugl), xrawe(2), xrawm(Nhrugl+2) + REAL :: balrawe(2), urawe(2), hrawe(2), arawe(2), frawe(2), junk(2), nn, divu, kappa + REAL :: sh(Nhrugl+2), shf(Nhrugl+2), hf(Nhrugl+2), hraw2(Nhrugl+2), fd(Nhrugl) + REAL :: kk(Ntp), ll(Ntp), xrawterm(Ntp), urawterm(Ntp), urawtop(Ntp), minterm + REAL :: allu(N, Ntp), last_frac, check_amt, flowc, dv1k +!*********************************************************************** + divu = 1.E3 + kappa = 0.04 !from Mazo 1995, value after all scaling + junk(1) = 1.0E36 + junk(2) = 1.0E36 + sa = 1.0E15 + sh = 1.0E15 + shf = 1.0E15 + s = 1.0E15 + area = 0.0 !area of glacier + vol = 0.0 !vol of glacier + spg = 0 !streams per glacier + balt = 0.0 !initialize + hvec = 0.0 + DO j = 1, Ntp + next_do(j) = Ntp + 10000 + ENDDO + DO i = 1, Nhrugl + cell_id(i) = Ikeep_gl(i,1) + str_id(i) = Ikeep_gl(i,2) + ENDDO + nn = 3.0 ! coefficient of creep, Farinotti used 3, Mazo used 2.2, smaller value makes glacier thicker + minterm = 1.0E15 + DO j = 1, Ntp + is(j) = Ikeep_gl(j,3) + ie(j) = Ikeep_gl(j,4) + urawtop(j) = Keep_gl(j,5) ! in km, -terminus + urawterm(j) = Keep_gl(j,6) ! in km, + IF (urawterm(j)< minterm) minterm = urawterm(j) ! lowest terminus in system + xrawterm(j) = Keep_gl(j,7) ! in km + ll(j) = xrawterm(j)*divu !m + flowc = 1/(2*Aflow*3.154E7) ! make Pa^nn yr + !PRINT *,flowc, "1/2A Pa^3/yr", Aflow*3.154E7, "A Pa^-3/yr" !might want to see these + kk(j) = (( flowc*(ll(j)**(nn+1)) ) /( ((Density*Gravity)**nn) ))**(1.0/(2.0*nn+2)) ! scaling + len_str = ie(j) - is(j) + 1 + len_str_true = len_str + DO i = 1, len_str + IF (Glacier_frac(cell_id(is(j)+i-1)) > 0.0 ) len_str_true = i + !will write over till end where glacier ends, id = cell_id(is(thestr)+len_str_true-1,1) + ENDDO + iem(j) = is(j)+len_str_true -1 !need for all strings before start + ENDDO! + IF (Botwrite==1) OPEN ( All_unit, FILE='all.dat' ) !save solutions together + done = 0 + nextstr = 1 + inda = 1 +!start computations with top streams + dothis = 0 +50 DO ii = 1, Topn + thestr = Gl_top(ii) + IF ( dothis/=0 ) thestr = dothis !done top streams, not in loop + k = kappa + ela_elev=(Ela_elevt(thestr)-urawterm(thestr)*divu)/kk(thestr) !want this to be from from steady state method of ELA (from compute_ela_aar) + len_str = ie(thestr) - is(thestr) + 1 + len_str_true = iem(thestr) - is(thestr) + 1 + DO i = 1, len_str_true + uraw(i) = (Keep_gl(is(thestr)+i-1,1)*divu)/kk(thestr) !in - terminus height and fraction of kk(thestr), so O(1) and for scaling + xraw(i) = Keep_gl(is(thestr)+i-1,2) !in fraction of length ll(thestr), so O(1) + hraw(i) = Keep_gl(is(thestr)+i-1,3) !in km, so O(1) + balraw(i) = balt(is(thestr)+i-1)/hraw(i) !need to spread it out + hraw2(i+1) = hraw(i) + fraw(i) = Frawt(is(thestr)+i-1) !in m, so O(1) + IF ( i>1 ) hvec(i) = xraw(i) - xraw(i-1) + ENDDO + hvec(1) = xraw(1) + xrawe(1) = 0.0 + urawe(1) = (urawtop(thestr)*divu)/kk(thestr) + last_frac = Glacier_frac(cell_id(iem(thestr))) + xrawe(2) = xraw(len_str_true) + Hru_length(cell_id(iem(thestr)))*last_frac*0.5/xrawterm(thestr) !scale + hvec(len_str_true+1) = xrawe(2)-xraw(len_str_true) + urawe(2) = (uraw(len_str_true)*kk(thestr)/divu - Hru_slope_ts(cell_id(iem(thestr)))* & + & Hru_length(cell_id(iem(thestr)))*last_frac*0.5)*divu/kk(thestr) !because slope is set positive but is negative + ! extrapolate these + IF (len_str_true>1) THEN + hrawe(1) = hraw(1) - (hraw(2)-hraw(1))/hvec(2)*hvec(1) + IF (hrawe(1)<=0.0) hrawe(1) = hraw(1)/10.0 !arbitrary + hrawe(2) = hraw(len_str_true) + (hraw(len_str_true)-hraw(len_str_true-1)) & + & /hvec(len_str_true)*hvec(len_str_true+1) + IF (hrawe(2)<=0.0) hrawe(2) = hraw(2)/10.0 !arbitrary + ELSE !make square glacier + hrawe(1) = hraw(1) + hrawe(2) = hraw(1) + ENDIF + hraw2(1) = hrawe(1) + hraw2(len_str_true+2) = hrawe(2) +! need frawe and fraw depending on Mbinit_flag + CALL cumtrapzv(hraw2(1:len_str_true+2), len_str_true+2, hvec(1:len_str_true+1), sh) !sh is cumulative area + CALL getf_fgrad(ela_elev,len_str_true,sh,urawe,uraw,xraw,hvec,frawe,fraw,fd) +! + !need to adjust fraw to be steady state, so shift up so int((f(z)+a)*area(z))dz= 0 + ! then add(x)=-int(f(z(x))*area(z(x)))dz/int(area(z(x)))dz + ! if add is constant in z, then constant in x because no matter what z is, same add + !If only one Hru on glacier, fraw will all be 0 to be in steady state + ! add would be zero if did the full integral with Mbinit_flag==2, but wrong at the moment + hf(1) = hrawe(1)*frawe(1) + DO i = 2, len_str_true+1 + hf(i) = hraw(i-1)*fraw(i-1) + ENDDO + hf(len_str_true+2) = hrawe(2)*frawe(2) + CALL cumtrapzv(hf(1:len_str_true+2), len_str_true+2, hvec(1:len_str_true+1), shf) + add = -shf(len_str_true+2)/sh(len_str_true+2) !should be close to 0 if picked Mbinit_flag=2 because adjusted + DO i = 1, len_str_true + araw0(i) = hraw(i)*(fraw(i)+add) + arawe0(i+1) = araw0(i) + ENDDO + arawe(2) = 0.0 !boundary condition + arawe0(1) = hrawe(1)*(frawe(1) + add) + CALL cumtrapzv(arawe0(1:len_str_true+1), len_str_true+1, hvec(1:len_str_true), sa) + arawe(1) = (1.0/hrawe(1))*sa(1) + IF (Botwrite==1) WRITE ( Output_unit,* ) xrawe(1),urawe(1),arawe(1),hrawe(1),frawe(1)+add,frawe(1), len_str_true + DO i = 1, len_str_true + araw(i) = (1.0/hraw(i))*sa(i+1) + IF ( araw(i)<0.0 ) THEN + ! If A is negative, then won't be able to converge. + ! Shouldn't happen if MB is steady and glacier gets more negative MB as decrease elevation + !PRINT *, 'Zeroed integral A (=',araw(i),') at x =',xraw(i)*ll(thestr)/1.0E3,'scaled x =',xraw(i) + IF (i>1) araw(i) = araw(i-1)!1.0E-5 + IF (i==1) araw(i) = 1.0E-5 + ENDIF + IF (Botwrite==1) WRITE ( Output_unit,* ) xraw(i),uraw(i),araw(i),hraw(i),fraw(i)+add,fraw(i) + ENDDO + IF (Botwrite==1) WRITE ( Output_unit, * ) xrawe(2),urawe(2),arawe(2),hrawe(2),frawe(2)+add,frawe(2),len_str_true, & + & xrawterm(thestr), 0, kk(thestr)/divu, urawterm(thestr) + CALL spline(xraw(1:len_str_true), uraw(1:len_str_true), xrawe, urawe, len_str_true, 1.0E31, 1.0E31, y2a) + CALL spline(xraw(1:len_str_true), hraw(1:len_str_true), xrawe, hrawe, len_str_true, 1.0E31, 1.0E31, y2b) + IF ( dothis/=0 ) THEN + balrawe(1) = 0.0 + balrawe(2) = 0.0 + CALL spline(xraw(1:len_str_true), balraw(1:len_str_true), xrawe, balrawe, len_str_true, 1.0E31, 1.0E31, y2c) + ENDIF + h = xrawe(2)/(N-1) + DO i = 1, N + xv(i) = (i-1)*h + CALL splint(xraw(1:len_str_true), uraw(1:len_str_true), xrawe, urawe, y2a(1:len_str_true), & + & len_str_true, xv(i), uv(i), yd) + CALL splint(xraw(1:len_str_true), hraw(1:len_str_true), xrawe, hrawe, y2b(1:len_str_true), & + & len_str_true, xv(i), hv(i), yd) + balv(i) = 0.0 !once isn't a top stream will be a value + IF ( i1 .AND. dv(i)<0.0 ) dv(i)=dv(i-1) + IF ( dv(1)<0.0 ) dv(1)=0.0 + zv(i) = uv(i) - dv(i) + IF (zv(i) < -2*uv(1)) dont = 1 ! below terminus elevation by twice height elevation,something wrong + IF (len_str_true==1) dont = 1 !SHOULD MAKE THIS IN WEASEL SO CAN'T HAPPEN only one HRU glacierized + ENDDO + IF (dont==1) THEN ! use Li 2012 method with an estimated stress, since having issues with ODE solve + stress = 78800 !average of Li 2012 Pascal values + DO i = 1, N + slp = upv(i)*kk(thestr)/ll(thestr) + sina = -1.0*slp/SQRT( slp**2.0 + 1.0 ) + dv(i) = (stress/(Density*Gravity*sina))/(1 - (stress/(Density*Gravity*sina))/(0.45*hv(i)*divu)) + dv(i) = dv(i)/kk(thestr) + zv(i) = uv(i) - dv(i) + ENDDO + ENDIF + DO j = 1, Ntp + IF ( j/=thestr ) CYCLE + nextstr = Toflowline(j) !can only be one + reparea = 0.0 + repvol = 0.0 + IF ( nextstr==0 ) THEN + indb = N + 1 !make bigger than any string + GOTO 200 !skip bal stuff + ENDIF + amt = 1.0E10 + DO jj = is(nextstr), iem(nextstr) !Keep_gl(,1) is uraw, looking for closest HRU in elevation + check_amt = ABS(Keep_gl(jj,1)*divu+urawterm(nextstr)*divu - & + & Keep_gl(iem(thestr),1)*divu-urawterm(thestr)*divu) + IF ( amt>=check_amt ) THEN + amt = check_amt + inda = jj + ENDIF + ENDDO + ENDDO + balx = Keep_gl(iem(thestr),2)*ll(thestr) - Keep_gl(inda,2)*0.5*ll(nextstr) !Keep_gl(,2) is xraw in km + amt = 1.0E10 + indb = N !default + DO j = 1, N - 1 !can't be terminus, looking for closest HRU in x distance + check_amt = ABS(xv(j)*ll(thestr)-balx) + IF ( amt>=check_amt ) THEN + amt = check_amt + indb = j + ENDIF + ENDDO + DO j = 1, N - indb + 1 + intf3(j) = (uv(j+indb-1)-zv(j+indb-1))*hv(j+indb-1)!cross section area + intf5(j) = hv(j+indb-1) !width + IF ( j=check_amt ) THEN + amt = check_amt + ibot = j + ENDIF !Keep_gl(,2) is xraw, look for closest x to top + check_amt = ABS(Keep_gl(j,2)*ll(nextstr)-top) + IF ( amt2>=check_amt ) THEN + amt2 = check_amt + itop = j + ENDIF + ENDDO + DO j = ibot, itop + balt(j) = balt(j) + bal/(itop-ibot+1) + ENDDO +! +! save solutions together + 200 done = done + 1 + DO i = 1, N + zv(i) = uv(i) - dv(i) + IF (Botwrite==1) WRITE ( All_unit, '(4F13.5)' ) xv(i), uv(i), zv(i), hv(i) + dxh(i) = dv(i)*hv(i) !in km2 + alld(i, thestr) = dv(i) + allx(i, thestr) = xv(i) + allu(i, thestr) = uv(i) + ENDDO + CALL cumtrapzv(hv, N, hvecn, s) !get area, to put in km2 + areag = s(N)*ll(thestr)/divu - reparea !cut part that will do again + area(Gt(thestr)) = area(Gt(thestr)) + areag + CALL cumtrapzv(dxh, N, hvecn, s) !get vol, to put in km3 + volg = s(N)*ll(thestr)*kk(thestr)/divu - repvol !cut part that will do again + vol(Gt(thestr)) = vol(Gt(thestr)) + volg +! N points, first line string, glacier, area + IF (Botwrite==1) WRITE (All_unit, '(2I5, 2F13.5)') thestr, Gt(thestr), areag, volg + spg(Gt(thestr)) = spg(Gt(thestr)) + 1 + order(done, 1) = thestr + order(done, 2) = Gt(thestr) + str_done(done) = thestr + next_do(done) = nextstr +! + IF ( dothis/=0 ) EXIT !done top streams, not in loop +! + ENDDO !end top streams if in loop +! +!if have done all that feed into nextstr then can do nextstr +! this following part is spagetti code. all it is doing is finding the +! streams the top streams feed into, and running them through the +! inverse code next after all feeders are done +!all glaciers have a top stream, so since have all those done, will +! account for all glaciers + Q1:DO i = 1, done + IF ( next_do(i)/=0 ) THEN !have more to do after top strings + DO ii = 1, done + IF ( str_done(ii)==next_do(i) ) THEN !did it + IF ( i<=done-1 ) GOTO 300 + IF ( i==done ) GOTO 400 !checked all + ENDIF + ENDDO !got here, found a not done string, or all done + dothis0 = next_do(i) + DO + Q2:DO j = 1, Ntp !check that did feeders + IF ( Toflowline(j)==dothis0 ) THEN + Q3:DO jj = 1, done + IF ( j==str_done(jj) ) THEN !did it + IF ( j<=Ntp-1 ) GOTO 210 + IF ( j==Ntp ) EXIT Q3 !checked all + ELSE !didn't do it + dothis0 = j + GOTO 220 !so check feeders, back at j=1 + ENDIF + ENDDO Q3 + ENDIF !got here, found next string to do + dothis = dothis0 + GOTO 50 !the start of the inverse problem for depths + 210 ENDDO Q2 + EXIT + 220 ENDDO + ENDIF + 300 ENDDO Q1 + 400 CLOSE ( All_unit ) +!Try to calulate steady surface cross-glacier-profile at every x point +! So want depth function cross-profile (changes with every x), call this d. +! d along the flow line is u-z, =dflow +!Suppose H(x,d)=P(x)*d^R(x) gives a profile for unknown P and R +! d along the flow line is u(x)-z(x), =dflow a function of x +! then H(x)=P(x)*dflow^R(x) +! We know H(x)-- solved for it, rearrange: P(x)=H(x)/dflow^R(x) +! Cross section area S(x) by integrating H(x,d) over depth from 0 to dmax=dflow +! S(x)=(1/(R(x)+1))*P(x)*dflow^(R(x)+1) +! + DO i = 1, Ntp + DO j = 1, Ntp + Order_flowline(j) = order(j, 1) + IF ( str_id(is(i))==Order_flowline(j) ) THEN !do this in order + thestr = Order_flowline(j) + len_str = ie(thestr) - is(thestr) + 1 + len_str_true = iem(thestr) - is(thestr) + 1 + areag = area(order(j, 2)) !per glacier all in km2 + volg = vol(order(j, 2)) !per glacier all in km3 + Ode_area(iem(thestr)) = areag !store in terminus HRU + Ode_vol(iem(thestr)) = volg !store in terminus HRU +! this is generous volume because not off average depth, off flowline depth + DO ii = 1, N + dv(ii) = alld(ii, thestr) !in per kk + xv(ii) = allx(ii, thestr) !in km/xterm + uv(ii) = allu(ii, thestr) !in per kk - uterm*divu/kk + ENDDO +! uv and zpv is currently not used for anything, but might want to calculate more accurate basal slope + zpv(1)=(zv(2)-zv(1))/(xv(2)-xv(1)) + DO ii = 2, N-1 + zpv(ii)= (zv(ii+1)-zv(ii-1))/(xv(ii+1)-xv(ii-1)) ! units in per kk + ENDDO + zpv(N)= (zv(N)-zv(N-1))/(xv(N)-xv(N-1)) + DO ii = 1, len_str + uraw(ii) = Keep_gl(is(thestr)+ii-1,1)! in km get whole thing + xraw(ii) = Keep_gl(is(thestr)+ii-1,2)! scaled get whole thing + xrawm(ii) = ll(thestr)*xraw(ii) !unscaled in m + hraw(ii) = Keep_gl(is(thestr)+ii-1,3) !in km + ENDDO + xrawm(len_str+2) = 0.0 + xrawm(len_str+1) = ll(thestr) + CALL spline(xv, dv, junk, junk, N, 1.0E31, 1.0E31, y2d) + draw = 0.0 + DO ii = 1, len_str_true +! make R constant =r0, have to because only have one equation for unknown +! rline denominator from 1.5 at top of each glacier to 2.1 at lowest extent glacier + rline(ii) = 1.0/(2.1+.6*(uraw(ii)+urawterm(thestr)-minterm)/ & + & (minterm-urawtop(thestr)-urawterm(thestr))) + CALL splint(xv, dv, junk, junk, y2d, N, xraw(ii), draw(ii), yd) + IF ( draw(ii)<0.0 ) draw(ii)=0.0 !splint might make some slightly negative + draw(ii) = draw(ii)*kk(thestr)/divu !make in km + IF ( draw(ii)==0.0 ) THEN + pline(ii) = 0.0 + ELSE + pline(ii) = hraw(ii)/(draw(ii)**rline(ii)) + ENDIF +! +! units of integer,integer,km,km,km, and pline,rline equation will give H in km +! a bottom width for each depth-- center it on flowline +! +! Basal hru_elev +!Calulate average unscaled elevation of bottom and store (zraw_av) +!uraw - average depth= uraw - cross section area divided by H max + zraw_av(ii) =( uraw(ii) - ( pline(ii)/(rline(ii)+1.0)*draw(ii)**(rline(ii)+1.0) )& + & /hraw(ii) + urawterm(thestr))*divu !in m + zraw(ii) = ( uraw(ii) - draw(ii) + urawterm(thestr))*divu !in m + Av_elev(is(thestr)+ii-1) = zraw_av(ii) + ENDDO + IF ( len_str/=len_str_true) THEN + DO ii = len_str_true+1, len_str !set all to hru_elev if not glacierized at start + zraw_av(ii) = (uraw(ii) + urawterm(thestr))*divu !in m + zraw(ii) = (uraw(ii) + urawterm(thestr))*divu !in m + Av_elev(is(thestr)+ii-1) = zraw_av(ii) + ENDDO + ENDIF +! Basal hru_slope +! Calulate a version of average slope with zraw_av, going down the flowline, scale it and store +! make endpoints at u elevation-- make compatable with way calculate on unglacierized HRUs +! Also calculate centerline slope with zraw. Could more accurately do this by integrating zv over xv +! but then would change when got off glacier +! Top and bottom of glacier affected by steep negative slope and steep positive slope respectively, may want to exclude + dv1k = dv(1)*kk(thestr)/divu !in km + plinetop = hraw(1)/(dv1k**(1.0/2.1)) + IF ( dv1k==0.0 ) plinetop = 0.0 + zraw_av(len_str+2) = ((urawtop(thestr)- ( plinetop/(rline(1)+1.0)*dv1k**(rline(1)+1.0) )/hraw(1)) & + & + urawterm(thestr))*divu + zraw_av(len_str+1) = urawterm(thestr)*divu + zraw(len_str+2) = ((urawtop(thestr)-dv1k)+urawterm(thestr))*divu + zraw(len_str+1) = urawterm(thestr)*divu + y2dd(1)= (zraw_av(2)-zraw_av(len_str+2))/(xrawm(2)-xrawm(len_str+2)) + y2dd0(1)= (zraw(2)-zraw(len_str+2))/(xrawm(2)-xrawm(len_str+2)) + Flow_slope(is(thestr)) = ABS(y2dd(1)) + Slope(is(thestr)) = y2dd0(1) + DO ii = 2, len_str + y2dd(ii)= (zraw_av(ii+1)-zraw_av(ii-1))/(xrawm(ii+1)-xrawm(ii-1)) + y2dd0(ii)= (zraw(ii+1)-zraw(ii-1))/(xrawm(ii+1)-xrawm(ii-1)) + Flow_slope(is(thestr)+ii-1) = ABS(y2dd(ii)) !Basal_slope + Slope(is(thestr)+ii-1) = y2dd0(ii) + ENDDO +! Basal hru_aspect: assume aspect the same on surface and base of glacier + ENDIF + ENDDO + ENDDO +! + END SUBROUTINE bottom + +!*********************************************************************** +! subroutine getf_fgrad - extrapolates f and computes fgrad +!*********************************************************************** + SUBROUTINE getf_fgrad(ela_elev,len_str,sh,urawe,uraw,xraw,hvec,frawe,fraw,fd) + USE PRMS_GLACR, ONLY: Mbinit_flag, Nhrugl + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: len_str + REAL, INTENT(IN) :: urawe(2), uraw(Nhrugl), xraw(Nhrugl), hvec(Nhrugl), ela_elev + REAL, INTENT(IN) :: sh(Nhrugl+2) + REAL, INTENT(INOUT) :: fraw(Nhrugl) + REAL, INTENT(OUT) :: fd(Nhrugl), frawe(2) +! Local Variables + INTEGER :: i, ela_i + REAL :: ela_x, high, low, add0, cons, aarA, sl_acc, sl_abl, frawm(Nhrugl+2) + REAL :: urawm(Nhrugl+2) +!*********************************************************************** + ela_i = 0 + ela_x = 0.0 + fd = 0.0 + IF (Mbinit_flag==1) THEN !use climate data for mass balance + IF (len_str>1) THEN + frawe(1) = fraw(1)- (fraw(2)-fraw(1))/hvec(2)*hvec(1) + frawe(2) = fraw(len_str) + (fraw(len_str)-fraw(len_str-1))/hvec(len_str)*(1-xraw(len_str)) + ELSE + frawe(1) = fraw(1) + frawe(2) = fraw(1) + ENDIF + ELSEIF (Mbinit_flag==2) THEN !Farinotti method, using ela_x + DO i = 1, len_str + IF (ela_elev-uraw(i)<0.0001) THEN !has rounding errors + ela_x=xraw(i) + ela_i=i + ENDIF + ENDDO + high =-1.0E7 + low = 1.0E7 + DO i = 1, len_str + IF (i<=ela_i) high = MAX(high,fraw(i)) + IF (i>=ela_i) low = MIN(low,fraw(i)) + ENDDO + ! say representative of steady state slopes + ! solve for accumulation and ablation slopes (sl_acc and sl_abl) with integrated f above and below ela_x same + ! could use 1.8*sl_acc= sl_abl from Furbish 1984 + ! is not quite right since width should be function of altitude + aarA = sh(ela_i+1)/sh(len_str+2) !aar with this ela_x + cons = (ela_elev)*(1.0 - aarA)/(urawe(1) - ela_elev)/aarA + add0 = (-cons*low - high)/(1.0 + cons) ! f value at ela, make it the 0 point for steady state + frawe(1) = high + add0 + frawe(2) = low + add0 + sl_acc = frawe(1)/(urawe(1) - ela_elev) + sl_abl = -frawe(2)/ela_elev + DO i = 1, ela_i + fraw(i) = sl_acc*(uraw(i)- ela_elev) + ENDDO + ! fraw(ela_i) is done twice, both times should be = 0 + DO i = ela_i, len_str + fraw(i) = frawe(2) + sl_abl*uraw(i) + ENDDO + ENDIF + DO i = 1, len_str + frawm(i) = fraw(i) + urawm(i) = uraw(i) + ENDDO + frawm(len_str+2) = frawe(1) + frawm(len_str+1) = frawe(2) + urawm(len_str+2) = urawe(1) + urawm(len_str+1) = urawe(2) + ! both scaled by divu (except in bottom routine, but don't use fd there) so slope unscaled + fd(1)= ( (frawm(2)-frawm(1))/(urawm(2)-urawm(1)) + & + & (frawm(1)-frawm(len_str+2))/(urawm(1)-urawm(len_str+2)) )/2.0 + DO i = 2, len_str + fd(i) = ( (frawm(i+1)-frawm(i))/(urawm(i+1)-urawm(i)) + & + & (frawm(i)-frawm(i-1))/(urawm(i)-urawm(i-1)) )/2.0 + ENDDO + END SUBROUTINE getf_fgrad + +!*********************************************************************** +! subroutine yearly_ca_coef - calculates average basal slope at +! center (deepest part of glacier) and average mass balance gradient at +! center for the year (and yearly extent) +! NOTE: The calculations only use the HRUs that are initially glacierized, +! so if glacier grows, will be neglecting extension. MIGHT WANT TO CHANGE +! This wouldn't make a huge difference since extension can't be that long. +! Don't have basal slope calculated there so would need to use something else. +!*********************************************************************** + SUBROUTINE yearly_ca_coef(Frawt, Ela_elevt) + USE PRMS_GLACR, ONLY: Ntp, Nhrugl, Ngl, Order_flowline, Keep_gl, Ikeep_gl, & + & Hru_length, Av_basal_slope, Av_fgrad, Glacr_tag, Term, Glacr_slope_init, Hru_length + USE PRMS_MODULE, ONLY: Nhru + USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_type + USE PRMS_FLOWVARS, ONLY: Glacier_frac + IMPLICIT NONE +! Functions + INTRINSIC ISNAN + EXTERNAL cumtrapzv, getf_fgrad +! Arguments + REAL, INTENT(IN) :: Frawt(Nhrugl), Ela_elevt(Ntp) +! Local Variables + INTEGER :: i, j, ii, o, p, thestr, len_str, str_id(Nhrugl), cell_id(Nhrugl), len_str_true + INTEGER :: is(Ntp), ie(Ntp) + REAL :: ela_elev, hvec(Nhrugl+1), uraw(Nhrugl), xraw(Nhrugl), hraw(Nhrugl) + REAL :: xrawe(2), urawe(2), hrawe(2), frawe(2), fd(Nhrugl), tot_fgrad, tot_length + REAL :: sh(Nhrugl+2), hraw2(Nhrugl+2), fgrad(Nhrugl), fgradm(Nhru), tot_slope + REAL :: fraw(Nhrugl), slopem(Nhru), divu +!*********************************************************************** + sh = 1.0E15 !initialize + hvec = 0.0 + divu = 1.0E3 !in meters + slopem = 0.0 + fgrad = 0.0 + fgradm = 0.0 + DO i = 1, Nhrugl + cell_id(i) = Ikeep_gl(i,1) + str_id(i) = Ikeep_gl(i,2) + slopem(cell_id(i)) = Keep_gl(i,4) !basal centerline slope + ENDDO + DO ii = 1, Ntp + is(ii) = Ikeep_gl(ii,3) + ie(ii) = Ikeep_gl(ii,4) + DO j = 1, Ntp + IF ( str_id(is(ii))==Order_flowline(j)) THEN !do this in order + thestr = Order_flowline(j) + len_str = ie(thestr) - is(thestr) + 1 + !want this to be from from steady state method of ELA (from compute_ela_aar) + ela_elev=(Ela_elevt(thestr)-Keep_gl(thestr,6)*divu)/divu !subtract urawterm + len_str_true = len_str + DO i = 1, len_str + IF (Glacier_frac(cell_id(is(thestr)+i-1)) > 0.0 ) len_str_true = i + !will write over till end where glacier ends, id = cell_id(is(thestr)+len_str_true-1,1) + ENDDO + DO i = 1, len_str_true + uraw(i) = Keep_gl(is(thestr)+i-1,1) + xraw(i) = Keep_gl(is(thestr)+i-1,2) + hraw(i) = Keep_gl(is(thestr)+i-1,3) + hraw2(i+1) = hraw(i) + fraw(i) = Frawt(is(thestr)+i-1) + IF ( i>1 ) hvec(i) = xraw(i) - xraw(i-1) + ENDDO + hvec(1) = xraw(1) + xrawe(1) = 0.0 + urawe(1) = Keep_gl(thestr,5) !urawtop(thestr) in km + IF ( len_str==len_str_true) THEN + hvec(len_str+1) = 1.0-xraw(len_str) + xrawe(2) = 1.0 + urawe(2) = 0.0 + ELSE + xrawe(2) = xraw(len_str_true) + Hru_length(cell_id(is(thestr)+len_str_true-1))*0.5/Keep_gl(thestr,7) !scale + hvec(len_str_true+1) = xrawe(2)-xraw(len_str_true) + urawe(2) = uraw(len_str_true) - Glacr_slope_init(cell_id(is(thestr)+len_str_true-1))* & + & Hru_length(cell_id(is(thestr)+len_str_true-1))*0.5 !because slope is set positive but is negative + ENDIF + ! extrapolate these + IF (len_str_true>1) THEN + hrawe(1) = hraw(1) - (hraw(2)-hraw(1))/hvec(2)*hvec(1) + IF (hrawe(1)<=0.0) hrawe(1) = hraw(1)/10.0 !arbitrary + hrawe(2) = hraw(len_str_true) + (hraw(len_str_true)-hraw(len_str_true-1)) & + & /hvec(len_str_true)*hvec(len_str_true+1) + IF (hrawe(2)<=0.0) hrawe(2) = hraw(2)/10.0 !arbitrary + ELSE !make square glacier + hrawe(1) = hraw(1) + hrawe(2) = hraw(1) + ENDIF + hraw2(1) = hrawe(1) + hraw2(len_str_true+2) = hrawe(2) + CALL cumtrapzv(hraw2(1:len_str_true+2), len_str_true+2, hvec(1:len_str_true+1), sh) !sh is cumulative area + CALL getf_fgrad(ela_elev,len_str_true,sh,urawe,uraw,xraw,hvec,frawe,fraw,fd) + DO i = 1, len_str_true + fgrad(is(thestr)+i-1) = fd(i) + ENDDO + ENDIF + ENDDO + ENDDO + DO i = 1, Nhrugl + fgradm(cell_id(i)) = fgrad(i) + ENDDO + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag + tot_slope = 0.0 + tot_fgrad = 0.0 + tot_length = 0.0 + DO i = 1, Active_hrus + j = Hru_route_order(i) + IF ( Hru_type(i)==4 .AND. Glacr_tag(j)==p ) THEN + tot_slope = tot_slope + slopem(j)*Glacier_frac(j)*Hru_length(j) + tot_fgrad = tot_fgrad + fgradm(j)*Glacier_frac(j)*Hru_length(j) + tot_length = tot_length + Glacier_frac(j)*Hru_length(j) + ENDIF + ENDDO + Av_basal_slope(p) = -tot_slope/tot_length !needs to be the positive version + Av_fgrad(p) = tot_fgrad/tot_length + IF (Av_fgrad(p) <= 0.0) Av_fgrad(p) = 0.006 !from Luthi 09 + ENDDO + END SUBROUTINE yearly_ca_coef + +!*********************************************************************** +! subroutine solve_poly - finds roots of polynomial using driver of +! subroutine rtn +!*********************************************************************** + SUBROUTINE solve_poly(Dv, Dpv, Flag, Xraw, Araw, Arawe, Xrawe, Xv, Upv, Balv, K, Nn, Len_str, Setmax) + IMPLICIT NONE + INTEGER, PARAMETER :: N = 101 +! Arguments + INTEGER, INTENT(IN) :: Len_str + INTEGER, INTENT(INOUT) :: Flag + REAL, INTENT(IN) :: Xraw(Len_str), Araw(Len_str), Xv(N), Upv(N), Balv(N) + REAL, INTENT(IN) :: Arawe(2), Xrawe(2), K, Nn, Setmax + REAL, INTENT(OUT) :: Dv(N), Dpv(N) +! Functions + EXTERNAL spline, splint, rtn +! Local Variables + INTEGER i + REAL h, dip1, di, upfunciph, xip1, afunciph, bfunciph, yd, xi, xiph + REAL tol, d(N-1), dp(N-1), rtnewt, y2a(N), y2b(Len_str+2), y2c(N), junk(2) +!*********************************************************************** + h = Xrawe(2)/(N-1) + DO i = 1, N - 1 + d(i) = 0.0 + dp(i) = 0.0 + ENDDO + junk(1) = 1.0E36 + junk(2) = 1.0E36 + CALL spline(Xv, Upv, junk, junk, N, 1.0E31, 1.0E31, y2a) + CALL spline(Xraw(1:Len_str), Araw(1:Len_str), Xrawe, Arawe, Len_str, 1.0E31, 1.0E31, y2b) + CALL spline(Xv, Balv, junk, junk, N, 1.0E31, 1.0E31, y2c) + DO i = 0, N - 2 + xip1 = Xrawe(2) - (i+1)*h + xi = Xrawe(2) - i*h + xiph = Xrawe(2) - (i+0.5)*h + CALL splint(Xv, Upv, junk, junk, y2a, N, xiph, upfunciph, yd) + CALL splint(Xraw(1:Len_str), Araw(1:Len_str), Xrawe, Arawe, y2b(1:Len_str), Len_str, xiph, afunciph, yd) + CALL splint(Xv, Balv, junk, junk, y2c, N, xiph, bfunciph, yd) + IF ( i>=1 ) THEN + di = d(i) !from last iteration + ELSE !y at x=1 at initial point + di = 0 !u0, =z at x=1 + Dv(N) = 0 + ENDIF + tol = 1.0E-2 +!find dip1 root of funcd between [0,Setmax], + CALL rtn(di, upfunciph, afunciph, bfunciph, 0.0, Setmax, tol, rtnewt, Flag, K, Nn) + dip1 = rtnewt + d(i+1) = dip1 + dp(i+1) = (-dip1+di)/h !dD/dx + ENDDO + DO i = 1, N - 1 !could have saved these in earlier do loop + Dv(i) = d(N-1-i+1) + Dpv(i) = dp(N-1-i+1) + ENDDO + Dpv(N) = Dpv(N-1) !don't really know it here, end of interval +! + END SUBROUTINE solve_poly + +!*********************************************************************** +! subroutine funcd - defines function +!*********************************************************************** + SUBROUTINE funcd(Dip1, Di, Upfunciph, Afunciph, Bfunciph, F1, Df, K, Nn) + IMPLICIT NONE + INTRINSIC ABS +! Arguments + REAL, INTENT(IN) :: Dip1, Di, Upfunciph, Afunciph, Bfunciph, K, Nn + REAL, INTENT(OUT) :: F1, Df +! Local Variables + REAL sigiph, ds +!*********************************************************************** + sigiph = 0.5*(Dip1+Di)*ABS(Upfunciph) + ds = 0.5*ABS(Upfunciph) + F1 = -( K*0.5*(Dip1+Di)*(sigiph**((Nn+1.0)/2.0)) & + & + ((0.5*(Dip1+Di))**2.0)*(sigiph**Nn)/(Nn+2.0) ) & + & + Afunciph + Bfunciph + + Df = -( K*0.5*(sigiph**((Nn+1)/2.0)) & + & + K*0.5*(Dip1+Di)*(Nn+1)*0.5*(sigiph**((Nn-1.0)/2.0))*ds & + & + .5*(Dip1+Di)*(sigiph**Nn)/(Nn+2.0) & + & + ((0.5*(Dip1+Di))**2.0)*Nn*(sigiph**(Nn-1.0))*ds/(Nn+2.0) ) + + END SUBROUTINE FUNCD + +!*********************************************************************** +! subroutine rtn - Using the Newton-Raphson method, and the root of +!a function known to lie in the interval [x1; x2]. The root rtnewt will +!be refined until its accuracy is known within xacc. funcd is a +!user-supplied subroutine that returns both the function value and the +!first derivative of the function at the point x. +!*********************************************************************** + SUBROUTINE rtn(Di, Upfunciph, Afunciph, Bfunciph, X1, X2, Xacc, Rtnewt, Flag, K, Nn) + IMPLICIT NONE + INTEGER, PARAMETER :: JMAX = 1000 !Set to maximum number of iterations. +! Arguments + INTEGER, INTENT(OUT) :: Flag + REAL, INTENT(IN) :: Di, Upfunciph, Afunciph, K, Nn, Bfunciph, X1, X2, Xacc + REAL, INTENT(OUT) :: Rtnewt +! Functions + EXTERNAL funcd +! Local Variables + INTEGER j + REAL df, dx, f +!*********************************************************************** + Flag = 0 + Rtnewt = 0.5*(X1+X2) !Initial guess. +! Rtnewt = 1.0 !??? + DO j = 1, JMAX + CALL funcd(Rtnewt, Di, Upfunciph, Afunciph, Bfunciph, f, df, K, Nn) + dx = f/df + Rtnewt = Rtnewt - dx +! PRINT*, 'Rtnewt jumped out of brackets, Rtnewt =', Rtnewt + IF ( RtnewtX2 ) Rtnewt = X2 + IF ( ABS(dx)1.0E35) +!ex2 the left endpoint of x0 (contained in array if >1.0E35), +!and given the array y2a(1:n), which is the output from spline, +!and given a value of x, this routine returns a +!cubic-spline interpolated value y and its derivative yd. +!*********************************************************************** + SUBROUTINE splint(Xa0, Ya0, Ex, Ey, Y2a, N, X, Y, Yd) + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: N + REAL, INTENT(IN) :: Xa0(N), Ya0(N), Y2a(N), X, Ex(2), Ey(2) + REAL, INTENT(INOUT) :: Yd, Y +! Local Variables + INTEGER i, k, khi, klo + REAL xa(N), ya(N), a, b, h +!*********************************************************************** + IF ( Ex(1)>0.99E35 ) THEN + DO i = 1, N - 1 + xa(i) = Xa0(i) + ENDDO + ELSE + xa(1) = Ex(1) + DO i = 1, N - 2 + xa(i+1) = Xa0(i) + ENDDO + ENDIF + IF ( Ex(2)>0.99E35 ) THEN + xa(N) = Xa0(N) + ELSE + xa(N) = Ex(2) + ENDIF + IF ( Ey(1)>0.99E35 ) THEN + DO i = 1, N - 1 + ya(i) = Ya0(i) + ENDDO + ELSE + ya(1) = Ey(1) + DO i = 1, N - 2 + ya(i+1) = Ya0(i) + ENDDO + ENDIF + IF ( Ey(2)>0.99E35 ) THEN + ya(N) = Ya0(N) + ELSE + ya(N) = Ey(2) + ENDIF + +!We will find the right place in the table by means of bisection. +!This is optimal if sequential calls to this routine are at random +!values of x. If sequential calls are in order, and closely +!spaced, one would do better to store previous values of +!klo and khi and test if they remain appropriate on the next call. +! + klo = 1 + khi = N + DO WHILE ( khi-klo>1 ) + k = (khi+klo)/2 + IF ( xa(k)>X ) THEN + khi = k + ELSE + klo = k + ENDIF + ENDDO + !klo and khi now bracket the input value of x. + h = xa(khi) - xa(klo) + IF ( h==0.0 ) PRINT *, 'Bad xa input in splint.' + !The xa's must be distinct. + a = (xa(khi)-X)/h !Cubic spline polynomial is now evaluated. + b = (X-xa(klo))/h + Y = a*ya(klo) + b*ya(khi) + ((a**3-a)*Y2a(klo)+(b**3-b)*Y2a(khi))*(h**2)/6.0 + Yd = -ya(klo) + ya(khi) + (-(a**2-1.0/3.0)*Y2a(klo)+(b**2-1.0/3.0)*Y2a(khi))*(h**2)/2.0 +! + END SUBROUTINE splint + +!*********************************************************************** +! subroutine indexx - indexes an array Arr(1:n), i.e., +!outputs the array Indx(1:n) such that +!Arr(Indx(j))is in ascending order for j = 1, 2, . . . ,N. The input +!quantities N and Arr are not changed. +!*********************************************************************** + SUBROUTINE indexx(N, Arr, Indx) + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(OUT) :: Indx(N) + REAL, INTENT(IN) :: Arr(N) +! Local Variables + INTEGER, PARAMETER :: M = 7, NSTACK = 100 + INTEGER i, indxt, ir, itemp, j, jstack, k, l, istack(NSTACK), ind + REAL a +!*********************************************************************** + DO j = 1, N + Indx(j) = j + ENDDO + jstack = 0 + l = 1 + ir = N + DO + IF ( ir-lArr(Indx(ir)) ) THEN + itemp = Indx(l) + Indx(l) = Indx(ir) + Indx(ir) = itemp + ENDIF + IF ( Arr(Indx(l+1))>Arr(Indx(ir)) ) THEN + itemp = Indx(l+1) + Indx(l+1) = Indx(ir) + Indx(ir) = itemp + ENDIF + IF ( Arr(Indx(l))>Arr(Indx(l+1)) ) THEN + itemp = Indx(l) + Indx(l) = Indx(l+1) + Indx(l+1) = itemp + ENDIF + i = l + 1 + j = ir + indxt = Indx(l+1) + a = Arr(indxt) + DO + i = i + 1 + IF ( Arr(Indx(i))a ) CYCLE + IF ( jNSTACK ) PRINT *, 'NSTACK too small in indexx.' + IF ( ir-i+1>=j-l ) THEN + istack(jstack) = ir + istack(jstack-1) = i + ir = j - 1 + ELSE + istack(jstack) = j - 1 + istack(jstack-1) = l + l = i + ENDIF + GOTO 100 + ELSE + itemp = Indx(i) + Indx(i) = Indx(j) + Indx(j) = itemp + EXIT + ENDIF + ENDDO + ENDDO + ENDIF + 100 ENDDO + END SUBROUTINE indexx + +!*********************************************************************** +! subroutine sort5 - sorts an array ra(1:n) into +!ascending numerical order while making the +!corresponding rearrangements of the other arrays rb to re. An +!index table is constructed via the routine indexx. +!*********************************************************************** + SUBROUTINE sort5(N, Ra, Rb, Rc, Rd, Re, Wksp, Iwksp) + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(OUT) :: Iwksp(N) + REAL, INTENT(INOUT) :: Ra(N), Rb(N), Rc(N), Rd(N), Re(N) + REAL, INTENT(OUT) :: Wksp(N) +! Functions + EXTERNAL indexx +! Local Variables + INTEGER j +!*********************************************************************** + CALL indexx(N, Ra, Iwksp) !Make the index table. + DO j = 1, N !Save the array ra. + Wksp(j) = Ra(j) + ENDDO + DO j = 1, N !Copy it back in the rearranged order. + Ra(j) = Wksp(Iwksp(j)) + ENDDO + DO j = 1, N !Ditto rb. + Wksp(j) = Rb(j) + ENDDO + DO j = 1, N + Rb(j) = Wksp(Iwksp(j)) + ENDDO + DO j = 1, N !Ditto rc. + Wksp(j) = Rc(j) + ENDDO + DO j = 1, N + Rc(j) = Wksp(Iwksp(j)) + ENDDO + DO j = 1, N !Ditto rd. + Wksp(j) = Rd(j) + ENDDO + DO j = 1, N + Rd(j) = Wksp(Iwksp(j)) + ENDDO + DO j = 1, N !Ditto re. + Wksp(j) = Re(j) + ENDDO + DO j = 1, N + Re(j) = Wksp(Iwksp(j)) + ENDDO + END SUBROUTINE sort5 + +!*********************************************************************** +! glacr_restart- write or read glacrrestart file +!*********************************************************************** + SUBROUTINE glacr_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_GLACR + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variable + CHARACTER(LEN=5) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Nhrugl, Basin_gl_top_melt, Gl_mb_yrcumul + WRITE ( Restart_outunit ) Gl_mb_cumul, Glnet_ar_delta + WRITE ( Restart_outunit ) Basin_gl_top_gain + WRITE ( Restart_outunit ) Basin_gl_area, Gl_area, Basin_gl_ice_melt + WRITE ( Restart_outunit ) Hru_glres_melt, Basin_gl_storstart + WRITE ( Restart_outunit ) Gl_top_melt, Basin_gl_storage, Basin_gl_storvol + WRITE ( Restart_outunit ) Basal_elev + WRITE ( Restart_outunit ) Keep_gl + WRITE ( Restart_outunit ) Ikeep_gl + WRITE ( Restart_outunit ) Basal_slope + WRITE ( Restart_outunit ) Av_basal_slope + WRITE ( Restart_outunit ) Av_fgrad + WRITE ( Restart_outunit ) Prev_out, Prev_outi + WRITE ( Restart_outunit ) Hru_mb_yrend + WRITE ( Restart_outunit ) Glacr_flow + WRITE ( Restart_outunit ) Gl_ice_melt + WRITE ( Restart_outunit ) Top + WRITE ( Restart_outunit ) Term + WRITE ( Restart_outunit ) Ela + WRITE ( Restart_outunit ) Order_flowline + WRITE ( Restart_outunit ) Ode_glacrva_coef + WRITE ( Restart_outunit ) Top_tag + WRITE ( Restart_outunit ) Glacr_tag + WRITE ( Restart_outunit ) Delta_volyr + WRITE ( Restart_outunit ) Hru_mb_yrcumul + WRITE ( Restart_outunit ) Hru_slope_ts + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Nhrugl, Basin_gl_top_melt, Gl_mb_yrcumul + READ ( Restart_inunit ) Gl_mb_cumul, Glnet_ar_delta + READ ( Restart_inunit ) Basin_gl_top_gain + READ ( Restart_inunit ) Basin_gl_area, Gl_area, Basin_gl_ice_melt + READ ( Restart_inunit ) Hru_glres_melt, Basin_gl_storstart + READ ( Restart_inunit ) Gl_top_melt, Basin_gl_storage, Basin_gl_storvol + READ ( Restart_inunit ) Basal_elev + READ ( Restart_inunit ) Keep_gl + READ ( Restart_inunit ) Ikeep_gl + READ ( Restart_inunit ) Basal_slope + READ ( Restart_inunit ) Av_basal_slope + READ ( Restart_inunit ) Av_fgrad + READ ( Restart_inunit ) Prev_out, Prev_outi + READ ( Restart_inunit ) Hru_mb_yrend + READ ( Restart_inunit ) Glacr_flow + READ ( Restart_inunit ) Gl_ice_melt + READ ( Restart_inunit ) Top + READ ( Restart_inunit ) Term + READ ( Restart_inunit ) Ela + READ ( Restart_inunit ) Order_flowline + READ ( Restart_inunit ) Ode_glacrva_coef + READ ( Restart_inunit ) Top_tag + READ ( Restart_inunit ) Glacr_tag + READ ( Restart_inunit ) Delta_volyr + READ ( Restart_inunit ) Hru_mb_yrcumul + READ ( Restart_inunit ) Hru_slope_ts + ENDIF + END SUBROUTINE glacr_restart diff --git a/prms/ide_dist.f b/prms/ide_dist.f index ef195a1d..8297c8be 100644 --- a/prms/ide_dist.f +++ b/prms/ide_dist.f @@ -95,7 +95,7 @@ INTEGER FUNCTION idedecl() ! declare parameters ALLOCATE ( Adjust_snow(Nrain,12) ) IF ( declparam(MODNAME, 'adjust_snow', 'nrain,nmonths', 'real', - + '-0.4', '-0.6', '0.6', + + '-0.4', '-0.5', '2.0', + 'Monthly (January to December) snow downscaling adjustment'// + ' factor for each precipitation measurement station', + 'Monthly (January to December) snow downscaling adjustment'// @@ -104,7 +104,7 @@ INTEGER FUNCTION idedecl() ALLOCATE ( Adjust_rain(Nrain,12) ) IF ( declparam(MODNAME, 'adjust_rain', 'nrain,nmonths', 'real', - + '-0.4', '-0.6', '0.6', + + '-0.4', '-0.5', '2.0', + 'Monthly (January to December) rain downscaling adjustment'// + ' factor for each precipitation measurement station', + 'Monthly (January to December) rain downscaling adjustment'// @@ -341,9 +341,9 @@ INTEGER FUNCTION ideinit() Basin_centroid_y = 0.0D0 DO ii = 1, Active_hrus i = Hru_route_order(ii) - Basin_centroid_x = Basin_centroid_x + + Basin_centroid_x = Basin_centroid_x + + DBLE( (Hru_area(i)*Hru_x(i)) ) - Basin_centroid_y = Basin_centroid_y + + Basin_centroid_y = Basin_centroid_y + + DBLE( (Hru_area(i)*Hru_y(i)) ) ENDDO Basin_centroid_x = Basin_centroid_x*Basin_area_inv @@ -426,7 +426,8 @@ INTEGER FUNCTION ide_temp_run(Temp_wght_dist, Temp_wght_elev) + Psta_x, Psta_y, Basin_centroid_x, Basin_centroid_y, Ndist_tsta USE PRMS_MODULE, ONLY: Nrain, Ntemp USE PRMS_BASIN, ONLY: Basin_area_inv, Hru_area, Active_hrus, - + Hru_route_order, Hru_elev_meters + + Hru_route_order, Hru_elev_meters, Hru_elev_ts, Hru_type, + + FEET2METERS, Elev_units USE PRMS_CLIMATEVARS, ONLY: Solrad_tmax, Solrad_tmin, Basin_temp, + Basin_tmax, Basin_tmin, Tmaxf, Tminf, Tminc, Tmaxc, Tavgf, + Tavgc, Tmin_aspect_adjust, Tmax_aspect_adjust, @@ -467,7 +468,13 @@ INTEGER FUNCTION ide_temp_run(Temp_wght_dist, Temp_wght_elev) dat_dist = 0.0 x = Hru_x(n) y = Hru_y(n) - z = Hru_elev_meters(n) + IF ( Hru_type(n)/=4 ) THEN + z = Hru_elev_meters(n) + ELSEIF ( Elev_units==0 ) THEN + z = Hru_elev_ts(n)*FEET2METERS + ELSE + z = Hru_elev_ts(n) + ENDIF IF ( Temp_wght_dist.GT.0.0 ) + CALL compute_inv(Ntemp, Temp_nsta, Temp_nuse, Tsta_x, x, + Tsta_y, y, Tmax, dat_dist, Ndist_tsta, Dist_exp) @@ -596,7 +603,8 @@ INTEGER FUNCTION ide_rain_run(Prcp_wght_dist, Prcp_wght_elev) + Adjust_snow, Adjust_rain, Tmax_allsnow_sta, Tmax_allrain_sta USE PRMS_MODULE, ONLY: Nrain USE PRMS_BASIN, ONLY: Hru_area, Basin_area_inv, Active_hrus, - + Hru_route_order, MM2INCH, Hru_elev_meters + + Hru_route_order, MM2INCH, Hru_elev_meters, + + FEET2METERS, Hru_elev_ts, Hru_type, Elev_units USE PRMS_CLIMATEVARS, ONLY: Tmaxf, Tminf, Newsnow, Pptmix, + Hru_ppt, Hru_rain, Hru_snow, Basin_rain, + Basin_ppt, Prmx, Basin_snow, Psta_elev_meters, Basin_obs_ppt, @@ -677,7 +685,13 @@ INTEGER FUNCTION ide_rain_run(Prcp_wght_dist, Prcp_wght_elev) dat_dist = 0.0 x = Hru_x(n) y = Hru_y(n) - z = Hru_elev_meters(n) + IF ( Hru_type(n)/=4 ) THEN + z = Hru_elev_meters(n) + ELSEIF ( Elev_units==0 ) THEN + z = Hru_elev_ts(n)*FEET2METERS + ELSE + z = Hru_elev_ts(n) + ENDIF IF ( Prcp_wght_dist>0.0 ) + CALL compute_inv(Nrain, Rain_nsta, Rain_nuse, Psta_x, x, + Psta_y, y, Precip_ide, dat_dist, Ndist_psta, Dist_exp) @@ -965,7 +979,7 @@ SUBROUTINE compute_elv(Imax, Nsta, Nuse, Sta_z, Z, Datin, ! !============================================================= END SUBROUTINE compute_elv - + !*********************************************************************** !*********************************************************************** SUBROUTINE SORT2(Imax, N, Ra, Rb) diff --git a/prms/mizuroute.f90 b/prms/mizuroute.f90 index 95ba0582..a1b3fedd 100644 --- a/prms/mizuroute.f90 +++ b/prms/mizuroute.f90 @@ -58,8 +58,6 @@ MODULE PRMS_MIZUROUTE double precision :: T1 ! end of the time step (seconds) integer :: LAKEFLAG ! >0 if processing lakes CHARACTER(LEN=9), SAVE :: MODNAME -! Declared Parameters - REAL, SAVE, ALLOCATABLE :: Segment_flow_init(:) END MODULE PRMS_MIZUROUTE !*********************************************************************** @@ -94,7 +92,6 @@ END FUNCTION mizuroute !*********************************************************************** INTEGER FUNCTION mizuroute_decl() USE PRMS_MIZUROUTE - USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declparam, declvar @@ -108,15 +105,6 @@ INTEGER FUNCTION mizuroute_decl() CALL print_module(Version_mizuroute, 'Streamflow Routing ', 90) MODNAME = 'mizuroute' - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN - ALLOCATE ( Segment_flow_init(Nsegment) ) - IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Initial flow in each stream segment', & - & 'Initial flow in each stream segment', & - & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') - ENDIF - END FUNCTION mizuroute_decl !*********************************************************************** @@ -124,9 +112,9 @@ END FUNCTION mizuroute_decl !*********************************************************************** INTEGER FUNCTION mizuroute_init() USE PRMS_MIZUROUTE - USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file - USE PRMS_BASIN, ONLY: Basin_area_inv,FT2_PER_ACRE, FEET2METERS - USE PRMS_FLOWVARS, ONLY: Seg_inflow, Seg_outflow + USE PRMS_MODULE, ONLY: Nsegment + USE PRMS_BASIN, ONLY: Basin_area_inv, FT2_PER_ACRE, FEET2METERS + USE PRMS_FLOWVARS, ONLY: Seg_outflow USE PRMS_SET_TIME, ONLY: Cfs_conv USE PRMS_ROUTING, ONLY: Basin_segment_storage, Tosegment, Segment_hruarea, & & Segment_order, Obsin_segment, Obsout_segment, Seg_length, Seg_slope @@ -153,18 +141,12 @@ INTEGER FUNCTION mizuroute_init() !*********************************************************************** mizuroute_init = 0 - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN - IF ( getparam(MODNAME, 'segment_flow_init', Nsegment, 'real', Segment_flow_init)/=0 ) & - & CALL read_error(2,'segment_flow_init') - DO i = 1, Nsegment - Seg_outflow(i) = Segment_flow_init(i) - ENDDO - DEALLOCATE ( Segment_flow_init ) - ENDIF - - IF ( Init_vars_from_file==0 ) THEN - Seg_inflow = 0.0D0 - ENDIF + !Seg_outflow will have been initialized to Segment_flow_init in PRMS_ROUTING + Basin_segment_storage = 0.0D0 + DO i = 1, Nsegment + Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) + ENDDO + Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv DO i = 1, Nsegment IF ( Tosegment(i)==0 ) iSegOut = i @@ -386,8 +368,6 @@ INTEGER FUNCTION mizuroute_init() nSegRoute => nSeg endif ! outlet segment choice - - if (doKWTroute) then ! define processing order of the reaches call reachorder(nSegRoute, ierr, cmessage); call handle_err(ierr, cmessage) @@ -442,12 +422,6 @@ INTEGER FUNCTION mizuroute_init() ! initialize the routed elements RCHFLX(:,:)%BASIN_QR(1) = 0.D0 - Basin_segment_storage = 0.0D0 - DO i = 1, Nsegment - Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) - ENDDO - Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv - END FUNCTION mizuroute_init !*********************************************************************** @@ -455,17 +429,18 @@ END FUNCTION mizuroute_init !*********************************************************************** INTEGER FUNCTION mizuroute_run() USE PRMS_MIZUROUTE - USE PRMS_MODULE, ONLY: Nsegment - USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, METERS2FEET + USE PRMS_MODULE, ONLY: Nsegment, Glacier_flag + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, METERS2FEET, Basin_gl_cfs, Basin_gl_ice_cfs USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & - & Seg_lateral_inflow, Flow_out + & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out USE PRMS_OBS, ONLY: Streamflow_cfs USE PRMS_SET_TIME, ONLY: Cfs_conv, Timestep_seconds USE PRMS_ROUTING, ONLY: Mann_n, Seg_Width, Obsin_segment, Tosegment, Obsout_segment, & & Segment_delta_flow, Segment_type, Basin_segment_storage, Flow_in_great_lakes, & & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Flow_terminus, & & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater + USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt USE PRMS_SRUNOFF, ONLY: Basin_sroff USE PRMS_GWFLOW, ONLY: Basin_gwflow ! mizuroute specific modules @@ -481,7 +456,7 @@ INTEGER FUNCTION mizuroute_run() ! Functions INTRINSIC MOD ! Local Variables - INTEGER :: i, segtype, ilake + INTEGER :: i, segtype, ilake, toseg DOUBLE PRECISION :: area_fac, segout !*********************************************************************** mizuroute_run = 0 @@ -557,11 +532,6 @@ INTEGER FUNCTION mizuroute_run() LAKFLX(iens,ilake)%LAKE_Q = DBLE(Streamflow_cfs(Obsout_segment(NETOPO(iSeg)%REACHID))*CFS2CMS_CONV) ENDIF ENDDO - ! write routed runoff (m3/s) into cfs -! FIX this should be routed, is it?, should be all going in, including the lateral flow -! muskingum has Seg_upstream_inflow that is the hourly upstream, do I need this? - Seg_inflow(NETOPO(:)%REACHID) = (METERS2FEET**3.)*RCHFLX(iens,:)%UPSBASIN_QR - !Seg_upstream_inflow(NETOPO(:)%REACHID) = (METERS2FEET**3.)*RCHFLX(iens,:)%UPSBASIN_QR !daily, not hourly, FIX?? ! ***** ! Compute total instantaneous runoff from all upstream basins... @@ -593,6 +563,9 @@ INTEGER FUNCTION mizuroute_run() ! ***** ! Route streamflow through the river network... ! ************************************************** + Seg_inflow = 0.0D0 + Seg_outflow = 0.0D0 + Seg_upstream_inflow = 0.0D0 if (doKWTroute) then RPARAM(:)%R_WIDTH = DBLE(Seg_width) ! channel width (m) RPARAM(:)%R_MAN_N = DBLE(Mann_n) ! Manning's "n" paramater (unitless) @@ -602,7 +575,6 @@ INTEGER FUNCTION mizuroute_run() ! identify reach to process irch = NETOPO(iSeg)%RHORDER !print*, 'irch, ixDesire = ', irch, ixDesire - ! route kinematic waves through the river network CALL QROUTE_RCH(IENS,irch, & ! input: array indices ixDesire, & ! input: index of the outlet reach @@ -615,12 +587,19 @@ INTEGER FUNCTION mizuroute_run() end do ! (looping through stream segments) ! write routed runoff (m3/s) into cfs - Seg_outflow(NETOPO(:)%REACHID)= (METERS2FEET**3.)*RCHFLX(iens,:)%REACH_Q - end if + Seg_outflow(NETOPO(:)%REACHID)= RCHFLX(iens,:)%REACH_Q/CFS2CMS_CONV + DO iSeg=1,nSegRoute + irch = NETOPO(iSeg)%RHORDER + toseg = Tosegment(irch) + IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Seg_outflow(irch) + ENDDO + Seg_inflow(NETOPO(:)%REACHID) = Seg_lateral_inflow(NETOPO(:)%REACHID) + & + & Seg_upstream_inflow(NETOPO(:)%REACHID) + end if end do ! (looping through ensemble members) - T0 = T1 + T0 = T1 Basin_segment_storage = 0.0D0 Flow_out = 0.0D0 @@ -675,6 +654,11 @@ INTEGER FUNCTION mizuroute_run() Basin_cfs = Flow_out Basin_stflow_out = Basin_cfs / area_fac Basin_cms = Basin_cfs*CFS2CMS_CONV + IF ( Glacier_flag==1 ) THEN + Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt + Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac + Basin_gl_cfs = Basin_gl_top_melt*area_fac + ENDIF Basin_sroff_cfs = Basin_sroff*area_fac Basin_ssflow_cfs = Basin_ssflow*area_fac Basin_gwflow_cfs = Basin_gwflow*area_fac diff --git a/prms/mizurouteRip.f90 b/prms/mizurouteRip.f90 new file mode 100644 index 00000000..8b6b0121 --- /dev/null +++ b/prms/mizurouteRip.f90 @@ -0,0 +1,787 @@ +!*********************************************************************** +! Defines stream and lake routing parameters and variables +!*********************************************************************** + MODULE PRMS_MIZUROUTE + IMPLICIT NONE +! Local Variables +! index for printing (set to negative to supress printing + integer,parameter :: ixPrint = -9999 ! index for printing +! useful constants + logical,parameter :: doKWTroute=.True. !.True. if switch off will do KWT + double precision,parameter :: verySmall=tiny(1.0D0) ! a very small number +! general guff + integer,parameter :: strLen=256 ! length of character string + integer :: ierr ! error code + character(len=strLen) :: cmessage ! error message of downwind routine + integer :: iTime ! loop through time + character(len=strLen) :: str ! miscellaneous string +! define stream segment information + integer,target :: nSeg ! number of all the stream segments + integer,pointer :: nSegRoute ! number of stream segments to be routed + integer :: nUpstream ! number of reaches upstream of each stream segment + integer :: iSeg ! index of stream segment + integer :: jSeg ! index of stream segment + integer :: iSegOut ! index of outlet stream segment + integer :: iSelect(1) ! index of desired stream segment (iSegOut) from the minloc operation + integer :: iSegDesire ! index of desired stream segment -- de-vectorized version of iSelect(1) + integer :: iUps ! index of upstream stream segment added by NM + integer :: iStart ! start index of the ragged array + integer,dimension(1) :: iDesire ! index of stream segment with maximum upstream area (vector) + integer :: ixDesire ! index of stream segment with maximum upstream area (scalar) +! define stream network information + integer,allocatable :: REACHIDGV(:) + integer,allocatable :: RCHIXLIST(:) + integer :: nTotal ! total number of upstream segments for all stream segments + integer :: iRchStart + integer :: iRchStart1 + integer,target :: nRchCount + integer :: nRchCount1 + integer :: iUpRchStart + integer :: nUpRchCount + integer,allocatable :: upStrmRchList(:) +! define metadata from model output file + integer :: iRch ! index in reach structures +! interpolate simulated runoff data to the basins + integer :: ibas ! index of the basins + integer :: iHRU ! index of the HRUs associated to the basin + integer :: nDrain ! number of HRUs that drain into a given stream segment + integer :: ix ! index of the HRU assigned to a given basin +! route delaied runoff through river network with St.Venant UH + integer :: nUH_DATA_MAX ! maximum number of elements in the UH data among all the upstreamfs for a segment +! compute total instantaneous runoff upstream of each reach + integer,allocatable :: iUpstream(:) ! indices for all reaches upstream + double precision,allocatable :: qUpstream(:) ! streamflow for all reaches upstream +! route kinematic waves through the river network + integer, parameter :: nens=1 ! number of ensemble members + integer :: iens ! index of ensemble member + double precision, save :: T0 ! start of the time step (seconds) + double precision :: T1 ! end of the time step (seconds) + integer :: LAKEFLAG ! >0 if processing lakes + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:) + CHARACTER(LEN=9), SAVE :: MODNAME + END MODULE PRMS_MIZUROUTE + +!*********************************************************************** +! Main mizuroute routine +!*********************************************************************** + INTEGER FUNCTION mizuroute() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: mizuroute_decl, mizuroute_init, mizuroute_run + EXTERNAL :: mizuroute_restart +!*********************************************************************** + mizuroute = 0 + + IF ( Process(:3)=='run' ) THEN + mizuroute = mizuroute_run() + ELSEIF ( Process(:4)=='decl' ) THEN + mizuroute = mizuroute_decl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL mizuroute_restart(1) + mizuroute = mizuroute_init() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL mizuroute_restart(0) + ENDIF + + END FUNCTION mizuroute + +!*********************************************************************** +! mizuroute_decl - Declare parameters and variables and allocate arrays +! Declared Parameters +! tosegment, hru_segment, obsin_segment, K_coef, x_coef +!*********************************************************************** + INTEGER FUNCTION mizuroute_decl() + USE PRMS_MIZUROUTE + USE PRMS_MODULE, ONLY: Nsegment + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_mizuroute +!*********************************************************************** + mizuroute_decl = 0 + + Version_mizuroute = 'mizuroute.f90 2017-10-06 11:04:00Z' + CALL print_module(Version_mizuroute, 'Streamflow Routing ', 90) + MODNAME = 'mizuroute' + + ALLOCATE ( Outflow_ts(Nsegment) ) + + END FUNCTION mizuroute_decl + +!*********************************************************************** +! mizuroute_init - Get and check parameter values and initialize variables +!*********************************************************************** + INTEGER FUNCTION mizuroute_init() + USE PRMS_MIZUROUTE + USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file + USE PRMS_BASIN, ONLY: Basin_area_inv, FT2_PER_ACRE, FEET2METERS + USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_ROUTING, ONLY: Basin_segment_storage, Tosegment, Segment_hruarea, & + & Segment_order, Obsin_segment, Obsout_segment, Seg_length, Seg_slope +! mizuroute specific modules + USE nrtype ! variable types, etc. + USE reachparam ! reach parameters + USE reachstate ! reach states + USE reach_flux ! fluxes in each reach + USE nrutil,only:arth ! use to build vectors with regular increments + USE lake_param ! lake parameters + USE lakes_flux ! fluxes in each lake +! **** + USE kwt_route,only:reachorder ! define the processing order for the stream segments + IMPLICIT NONE +! Functions + EXTERNAL :: read_error + INTEGER, EXTERNAL :: getparam +! Local Variables + INTEGER :: i, j, k, jj, toseg, iorder, reachStart(Nsegment), reachCount(Nsegment) + INTEGER :: upReachStart(Nsegment), upReachCount(Nsegment),reachListMat(Nsegment,Nsegment) + INTEGER :: reachList(Nsegment*Nsegment),upReachIndex(Nsegment*Nsegment), seg_id(Nsegment) + INTEGER :: upReachIndMat(Nsegment,Nsegment), ilake + DOUBLE PRECISION :: totalArea(Nsegment) +!*********************************************************************** + mizuroute_init = 0 + + IF ( Init_vars_from_file==0 ) THEN + Outflow_ts = 0.0D0 + ENDIF + + !Seg_outflow will have been initialized to Segment_flow_init in PRMS_ROUTING + Basin_segment_storage = 0.0D0 + DO i = 1, Nsegment + Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) + ENDDO + Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv + + DO i = 1, Nsegment + IF ( Tosegment(i)==0 ) iSegOut = i + seg_id(i) = i + ENDDO + + T0 = 0.D0 + nSeg = Nsegment + +! Calculate network topology information... + reachStart = 0 + reachCount = 1 + upReachStart = -9999 + upReachCount = 0 + reachListMat = 0 + reachList = 0 + upReachIndMat = 0 + upReachIndex = 0 + DO i = 1, Nsegment + iorder = Segment_order(i) + toseg = Tosegment(iorder) + reachListMat(iorder,iorder) = 1 + IF ( toseg>0 ) THEN + reachListMat(toseg,1:Nsegment) = reachListMat(toseg,1:Nsegment)+reachListMat(iorder,1:Nsegment) + upReachIndMat(toseg,iorder) = 1 + ENDIF + ENDDO + !Note, size of upReachIndex sUps = SUM(upReachIndex) + !Note, size of reachList sAll = SUM(reachListMat) + DO i = 1, Nsegment + reachCount(i) = SUM(reachListMat(i,1:Nsegment)) + upReachCount(i) = SUM(upReachIndMat(i,1:Nsegment)) + ENDDO + DO i = 1, Nsegment + reachStart(i) = SUM(reachCount(1:i)) - reachCount(i) + 1 + IF ( upReachCount(i)>0 ) upReachStart(i) = SUM(upReachCount(1:i)) - upReachCount(i) + 1 + j = reachStart(i) + jj = upReachStart(i) + DO k = 1,Nsegment + IF (reachListMat(i,k) == 1) THEN + reachList(j) = k + j = j+1 + ENDIF + IF (jj>0 .AND. upReachIndMat(i,k) == 1) THEN + upReachIndex(jj) = k + jj = jj+1 + ENDIF + ENDDO + iRchStart = reachStart(i) + nRchCount = reachCount(i) + totalArea(i) = DBLE(SUM(Segment_hruarea(reachList(iRchStart:(iRchStart+nRchCount-1))))) + totalArea(i) = totalArea(i)*FT2_PER_ACRE*(FEET2METERS**2.) + ENDDO + +! Read global reach id, allocate + allocate(REACHIDGV(Nsegment), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for REACHIDGV') + REACHIDGV = seg_id + if ( iSegOut /= -9999 ) then + !print*, 'Outlet segment = ', iSegOut +! Identify index of the desired stream segment from reachID vector (dimension size: Nsegment) + iSelect = minloc(abs(REACHIDGV - iSegOut)) + iSegDesire = iSelect(1) ! de-vectorize the desired stream segment + if(REACHIDGV(iSegDesire) /= iSegOut)& + call handle_err(20,'unable to find desired stream segment') + +! Start index and the count for lagged array - all the upstream segments, immediate upstream segment, immediate upstream HRUs + iRchStart = reachStart(iSegDesire) + nRchCount = reachCount(iSegDesire) + !print*,'iRchStart = ',iRchStart + !print*,'Number of upstream segment from outlet segment (nRchCount): ',nRchCount + +! Read reach list of index from global segments (all the upstream reachs for each segment) + allocate(upStrmRchList(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for upStrmRchList') + upStrmRchList = reachList(iRchStart:(iRchStart+nRchCount-1)) + +! Reach upstream segment and associated HRU infor from non-ragged vector + allocate(NETOPO(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO') + allocate(RPARAM(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RPARAM') + +! Create REACH index for local segments + NETOPO(:)%REACHIX=arth(1,1,nRchCount) + do iSeg=1,nRchCount + ! Reach reach topology and parameters (integer) + NETOPO(iSeg)%REACHID = seg_id(upStrmRchList(iSeg)) + NETOPO(iSeg)%DREACHK = Tosegment(upStrmRchList(iSeg)) + ! Reach reach topology and parameters (double precision precision) + RPARAM(iSeg)%R_SLOPE = DBLE(Seg_slope(upStrmRchList(iSeg))) + RPARAM(iSeg)%RLENGTH = DBLE(Seg_length(upStrmRchList(iSeg))) + RPARAM(iSeg)%TOTAREA = totalArea(upStrmRchList(iSeg)) + enddo + + ! Recompute downstream segment index as local segment list, NETOPO(:)%REACHID + do iSeg=1,nRchCount + ! Assign downstream segment ID = 0 at desired outlet segment + if (NETOPO(iSeg)%REACHID == iSegOut) then + NETOPO(iSeg)%DREACHK = 0 + else + ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) + iSelect = minloc(abs(NETOPO(:)%REACHID - NETOPO(iSeg)%DREACHK)) + NETOPO(iSeg)%DREACHI = iSelect(1) ! de-vectorize the desired stream segment + if (NETOPO(NETOPO(iSeg)%DREACHI)%REACHID /= NETOPO(iSeg)%DREACHK) then + !print*,'iSeg = ', iSeg + !print*,'NETOPO(iSeg)%DREACHK = ', NETOPO(iSeg)%DREACHK + !print*,'NETOPO(NETOPO(iSeg)%DREACHI)%REACHID = ', NETOPO(NETOPO(iSeg)%DREACHI)%REACHID + call handle_err(20,'unable to find desired downstream segment') + endif + endif + enddo + +! Reach upstream segment and associated HRU infor from ragged vector + nTotal=0 + do iSeg=1,nRchCount + ! sAll dimension + iRchStart1 = reachStart(upStrmRchList(iSeg)) + nRchCount1 = reachCount(upStrmRchList(iSeg)) + allocate(NETOPO(iSeg)%RCHLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%RCHLIST') + allocate(RCHIXLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RCHIXLIST(nRchCount)') + RCHIXLIST = reachList(iRchStart1:(iRchStart1+nRchCount1-1)) + + ! Recompute all the upstream segment indices as local segment list = NETOPO(:)%REACHID + nTotal = nTotal + nRchCount1 + do jSeg=1,nRchCount1 + ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) + iSelect = minloc( abs( NETOPO(:)%REACHID - REACHIDGV(RCHIXLIST(jSeg)) ) ) + NETOPO(iSeg)%RCHLIST(jSeg) = iSelect(1) ! de-vectorize the desired stream segment + enddo + !print*,'NETOPO(iSeg)%RCHLIST(:) = ',NETOPO(iSeg)%RCHLIST(:) + deallocate(RCHIXLIST, stat=ierr) + + ! sUps dimension + iUpRchStart = upReachStart(upStrmRchList(iSeg)) + nUpRchCount = upReachCount(upStrmRchList(iSeg)) + allocate(NETOPO(iSeg)%UREACHI(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHI') + allocate(NETOPO(iSeg)%UREACHK(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHK') + allocate(NETOPO(iSeg)%goodBas(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%goodBas') + if (nUpRchCount > 0) then + + NETOPO(iSeg)%UREACHK(:) = seg_id(upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1))) + do jSeg=1,nUpRchCount + ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) + iSelect = minloc(abs(NETOPO(:)%REACHID - NETOPO(iSeg)%UREACHK(jSeg))) + NETOPO(iSeg)%UREACHI(jSeg) = iSelect(1) ! de-vectorize the desired stream segment + ! check that we identify the correct upstream reach + if (NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID /= NETOPO(iSeg)%UREACHK(jSeg)) then + !print*,'iSeg = ', iSeg + !print*,'NETOPO(iSeg)%UREACHK(jSeg) = ', NETOPO(iSeg)%UREACHK(jSeg) + !print*,'NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID = ', NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID + call handle_err(20,'unable to find desired immediate upstream segment') + endif + + ! check that the upstream reach has a basin area > 0 + if(RPARAM(NETOPO(iSeg)%UREACHI(jSeg))%TOTAREA > verySmall)then + NETOPO(iSeg)%goodBas(jSeg) = .true. + else + NETOPO(iSeg)%goodBas(jSeg) = .false. + endif + + enddo ! looping through the immediate upstream reaches + endif ! if not a headwater + enddo ! looping through the stream segments within the model domain + nSegRoute => nRchCount + + else ! if the entire river network routing is selected + !print*, 'Route all the segments included in network topology' + ! Populate sSeg dimensioned variable + allocate(NETOPO(nSeg), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO') + allocate(RPARAM(nSeg), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RPARAM') + do iSeg=1,Nsegment + ! Reach reach topology and parameters (integer) + NETOPO(iSeg)%REACHIX = iSeg + NETOPO(iSeg)%REACHID = seg_id(iSeg) != to iSeg + NETOPO(iSeg)%DREACHI = Tosegment(iSeg) + NETOPO(iSeg)%DREACHK = Tosegment(iSeg) + ! Reach reach topology and parameters (double precision precision) + RPARAM(iSeg)%R_SLOPE = DBLE(Seg_slope(iSeg)) + RPARAM(iSeg)%RLENGTH = DBLE(Seg_length(iSeg)) + RPARAM(iSeg)%TOTAREA = totalArea(iSeg) + enddo + ! Populate sAll dimensioned variable + ! NETOPO%RCHLIST - upstream reach list + nTotal=0 + do iSeg=1,Nsegment + iRchStart1 = reachStart(iSeg) + nRchCount1 = reachCount(iSeg) + allocate(NETOPO(iSeg)%UPSLENG(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UPSLENG') + allocate(NETOPO(iSeg)%RCHLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%RCHLIST') + NETOPO(iSeg)%RCHLIST(:) = reachList(iRchStart1:(iRchStart1+nRchCount1-1)) + nTotal = nTotal + nRchCount1 + enddo + ! Populate sUps dimensioned variable + ! NETOPO%UREACHI - Immediate upstream reach index list + ! NETOPO%UREACHK - Immediate upstream reach ID list + do iSeg=1,Nsegment + iUpRchStart = upReachStart(iSeg) + nUpRchCount = upReachCount(iSeg) + allocate(NETOPO(iSeg)%UREACHI(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHI') + allocate(NETOPO(iSeg)%UREACHK(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHK') + allocate(NETOPO(iSeg)%goodBas(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%goodBas') + if (nUpRchCount > 0) then + NETOPO(iSeg)%UREACHK(:) = seg_id(upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1))) + NETOPO(iSeg)%UREACHI(:) = upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1)) + do jSeg=1,nUpRchCount + ! check that we identify the correct upstream reach + if (NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID /= NETOPO(iSeg)%UREACHK(jSeg)) then + !print*,'iSeg = ', iSeg + !print*,'NETOPO(iSeg)%UREACHK(jSeg) = ', NETOPO(iSeg)%UREACHK(jSeg) + !print*,'NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID = ', NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID + call handle_err(20,'unable to find desired immediate upstream segment') + endif + ! check that the upstream reach has a basin area > 0 + if(RPARAM(NETOPO(iSeg)%UREACHI(jSeg))%TOTAREA > verySmall)then + NETOPO(iSeg)%goodBas(jSeg) = .true. + else + NETOPO(iSeg)%goodBas(jSeg) = .false. + endif + enddo ! looping through the immediate upstream reaches + endif ! if not a headwater + enddo + nSegRoute => nSeg + endif ! outlet segment choice + + if (doKWTroute) then + ! define processing order of the reaches + call reachorder(nSegRoute, ierr, cmessage); call handle_err(ierr, cmessage) + end if + + ! identify the stream segment with the largest upstream area + iDesire = maxLoc(RPARAM(:)%TOTAREA) + ixDesire= iDesire(1) + !print*, 'maximum upstream area = ', RPARAM(ixDesire)%TOTAREA, size(NETOPO(ixDesire)%RCHLIST) + + ! set the downstream index of the outlet reach to negative (the outlet reach does not flow into anything) + NETOPO(ixDesire)%DREACHI = -9999 + + ! allocate space for the simulated runoff at reaches + allocate(RCHFLX(nens,nSegRoute), KROUTE(nens,nSegRoute), stat=ierr) + if(ierr/=0) call handle_err(ierr,'problem allocating space for simulated runoff at the basins') + + + ! setup streamflow replacement at segments if needed + ! using as fake lakes for now, FIX? + ! ************************************************** + ilake = 0 + DO i = iSeg, nSegRoute + IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) ilake = ilake+1 + IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) ilake = ilake+1 + ENDDO + NETOPO(:)%LAKE_IX = 0 + NETOPO(:)%LAKINLT = .FALSE. + allocate(LKTOPO(ilake), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for LKTOPO') + LKTOPO(:)%DREACHI = 0 + ! allocate space for the simulated flux at lakes + allocate(LAKFLX(nens,ilake), stat=ierr) + if(ierr/=0) call handle_err(ierr,'problem allocating space for simulated fluxes at the lakes') + LAKFLX(:,:)%LAKE_Q = 0.D0 + IF (ilake>0) THEN + LAKEFLAG = 1 + ilake = 0 + DO i = 1, nSegRoute + IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is outlet of lake with known 'lake' flow coming into reach + ilake= ilake+1 + NETOPO(iSeg)%LAKE_IX = ilake + LKTOPO(ilake)%DREACHI = NETOPO(iSeg)%REACHIX + ENDIF + IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach a lake with known 'lake' flow coming out reach and not routed in the reach + ilake= ilake+1 + NETOPO(iSeg)%LAKE_IX = ilake + LKTOPO(ilake)%DREACHI = NETOPO(iSeg)%REACHIX + RPARAM(iSeg)%RLENGTH = 0.D0 ! FIX: NOT SURE I CAN HAVE 0 LENGTH + ENDIF + ENDDO + ENDIF + ! initialize the routed elements + RCHFLX(:,:)%BASIN_QR(1) = 0.D0 + + END FUNCTION mizuroute_init + +!*********************************************************************** +! mizuroute_run - Compute routing summary values +!*********************************************************************** + INTEGER FUNCTION mizuroute_run() + USE PRMS_MIZUROUTE + USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, METERS2FEET, Active_hrus, Hru_route_order, & + & Basin_gl_cfs, Basin_gl_ice_cfs + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & + & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & + & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out + USE PRMS_OBS, ONLY: Streamflow_cfs + USE PRMS_SET_TIME, ONLY: Cfs_conv, Timestep_seconds + USE PRMS_ROUTING, ONLY: Mann_n, Seg_Width, Obsin_segment, Tosegment, Obsout_segment, & + & Segment_delta_flow, Segment_type, Basin_segment_storage, Flow_in_great_lakes, & + & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Flow_terminus, & + & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, & + & Stage_ts, Stage_ante, Seg_bankflow, Seg_slope, Basin_bankflow, Bankst_seep_rate, & + & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, Basin_ripflow, & + & Basin_bankst_seep_rate, Basin_bankflow, Basin_bankst_seep, Basin_bankst_vol, & + & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_seep, Basin_ripst_evap, & + & Basin_ripst_vol, Bankst_seep_rate + USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt + USE PRMS_SRUNOFF, ONLY: Basin_sroff + USE PRMS_GWFLOW, ONLY: Basin_gwflow +! mizuroute specific modules + USE nrtype ! variable types, etc. + USE reachparam ! reach parameters + USE reachstate ! reach states + USE reach_flux ! fluxes in each reach + USE lake_param ! lake parameters + USE lakes_flux ! fluxes in each lake + USE kwt_route,only:qroute_rch ! route kinematic waves through the river network + + IMPLICIT NONE +! Functions + INTRINSIC MOD + EXTERNAL comp_bank_storage, drain_the_swamp +! Local Variables + INTEGER :: i, j, segtype, ilake, toseg + DOUBLE PRECISION :: area_fac, segout +!*********************************************************************** + mizuroute_run = 0 + +! compute the time-delay histogram (to route runoff within basins) + allocate(FRAC_FUTURE(1), stat=ierr) + FRAC_FUTURE(1) = 0.d0 + !call qtimedelay(dt, fshape, tscale, ierr, cmessage) + !call handle_err(ierr, cmessage) + +! ***** +! Prepare for the routing simulations... +! ******************************************* +! allocate space for the simulated runoff at the HRUs + + ! initialize the time-delay histogram + do iens=1,nens + do ibas=1,nSegRoute + ! allocate space for the delayed runoff + allocate(RCHFLX(iens,ibas)%QFUTURE(size(FRAC_FUTURE)), stat=ierr) + call handle_err(ierr, 'problem allocating space for QFUTURE element') + ! initialize to zeroes + RCHFLX(iens,ibas)%QFUTURE(:) = 0.D0 + end do + end do + + + ! define flags + !LAKEFLAG=0 ! no lakes in the river network, but putting in fake ones to add in observed streamflow + ! FIX: HOW DO WE DEAL WITH LAKES HERE, USE MUSKINGUM?? + + ! define time + T1 = T0+Timestep_seconds + +! ***** +! Perform the routing... +! ************************** + iTime=1 + + ! loop through ensemble members + do iens=1,nens + ! Interpolate simulated runoff to local basins... + do ibas=1,nSegRoute + RCHFLX(iens,ibas)%BASIN_QI = DBLE(Seg_lateral_inflow(NETOPO(ibas)%REACHID)*CFS2CMS_CONV) + end do ! (looping through basins) + !print*,'RCHFLX(iens,:)%BASIN_QI = ',RCHFLX(iens,:)%BASIN_QI! + + ! ***** + ! FIX ZERO OUT Delay runoff within local basins... IS THIS RIGHT?? + ! **************************************** + ! route streamflow through the basin + do ibas=1,nSegRoute ! place a fraction of runoff in future time steps + RCHFLX(iens,ibas)%QFUTURE(1) = RCHFLX(iens,ibas)%BASIN_QI + ! save the routed runoff + RCHFLX(iens,ibas)%BASIN_QR(0) = RCHFLX(iens,ibas)%BASIN_QR(1) ! (save the runoff from the previous time step) !CUT? + RCHFLX(iens,ibas)%BASIN_QR(1) = RCHFLX(iens,ibas)%QFUTURE(1) + RCHFLX(iens,ibas)%QFUTURE(1) = 0.D0 + end do ! (looping through basins) + + ! ***** + ! Replace streamflow at segments if needed + ! water-use removed/added in routing module + ! FIX DEAL WITH GAINING STREAMS will happen in depression storage type module + ! ************************************************** + ilake = 0 + DO iSeg = 1, nSegRoute + IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is outlet of lake with known 'lake' flow coming into reach + ilake= ilake+1 + LAKFLX(iens,ilake)%LAKE_Q = DBLE((Streamflow_cfs(Obsin_segment(NETOPO(iSeg)%REACHID))+Seg_lateral_inflow(NETOPO(iSeg)%REACHID))*CFS2CMS_CONV) + ENDIF + IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is inlet of lake with known 'lake' flow coming into reach + ilake= ilake+1 + LAKFLX(iens,ilake)%LAKE_Q = DBLE(Streamflow_cfs(Obsout_segment(NETOPO(iSeg)%REACHID))*CFS2CMS_CONV) + ENDIF + ENDDO + + ! ***** + ! Compute total instantaneous runoff from all upstream basins... + ! ******************************************************************* + ! compute the sum of all upstream runoff at each point in the river network + do iSeg=1,nSegRoute + ! identify how many reaches are upstream + nUpstream = size(NETOPO(iSeg)%RCHLIST) + ! allocate space for upstream vectors + allocate(iUpstream(nUpstream), qUpstream(nUpstream), stat=ierr) + if(ierr/=0) call handle_err(ierr,'problem allocating vectors for all upstream basins') + ! get indices for all reaches upstream + iUpstream = NETOPO(iSeg)%RCHLIST(1:nUpstream) + ! get streamflow for all reaches upstream + qUpstream = RCHFLX(iens,iUpstream(1:nUpstream))%BASIN_QR(1) + ! get mean streamflow + RCHFLX(IENS,iSeg)%UPSTREAM_QI = sum(qUpstream) + ! test + if(NETOPO(iSeg)%REACHID == ixPrint)then + print*, 'ixUpstream = ', NETOPO(iUpstream(1:nUpstream))%REACHIX + print*, 'idUpstream = ', NETOPO(iUpstream(1:nUpstream))%REACHID + print*, 'qUpstream = ', qUpstream + endif + ! deallocate space for upstream vectors + deallocate(iUpstream,qUpstream, stat=ierr) + if(ierr/=0) call handle_err(ierr,'problem deallocating vectors for all upstream basins') + end do ! looping through stream segments + + ! ***** + ! Route streamflow through the river network... + ! ************************************************** + Seg_inflow = 0.0D0 + Seg_outflow = 0.0D0 + Seg_upstream_inflow = 0.0D0 + IF ( Ripst_flag==1 ) Stage_ante =Stage_ts + if (doKWTroute) then + RPARAM(:)%R_WIDTH = DBLE(Seg_width) ! channel width (m) + RPARAM(:)%R_MAN_N = DBLE(Mann_n) ! Manning's "n" paramater (unitless) + + ! route streamflow through the river network + do iSeg=1,nSegRoute + ! identify reach to process + irch = NETOPO(iSeg)%RHORDER + !print*, 'irch, ixDesire = ', irch, ixDesire + ! route kinematic waves through the river network + CALL QROUTE_RCH(IENS,irch, & ! input: array indices + ixDesire, & ! input: index of the outlet reach + T0,T1, & ! input: start and end of the time step + LAKEFLAG, & ! input: flag if lakes are to be processed + ierr,cmessage) ! output: error control + call handle_err(ierr,cmessage) + !if(iRch==5) pause 'finished stream segment' + end do ! (looping through stream segments) + Seg_outflow(NETOPO(:)%REACHID)= RCHFLX(iens,:)%REACH_Q/CFS2CMS_CONV + + DO iSeg=1,nSegRoute + irch = NETOPO(iSeg)%RHORDER + toseg = Tosegment(irch) + IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Seg_outflow(irch) + ENDDO + Seg_inflow(NETOPO(:)%REACHID) = Seg_lateral_inflow(NETOPO(:)%REACHID) + & + & Seg_upstream_inflow(NETOPO(:)%REACHID) + + + Outflow_ts(NETOPO(:)%REACHID)= RCHFLX(iens,:)%REACH_Q/CFS2CMS_CONV + end if + end do ! (looping through ensemble members) + + ! for stage estimate + IF ( Ripst_flag==1 ) THEN + Basin_bankst_seep = 0.D0 + Basin_bankst_seep_rate = 0.0D0 + Basin_bankst_head = 0.0D0 + Basin_bankst_vol = 0.0D0 + Basin_ripst_area = 0.0D0 + Basin_ripst_seep = 0.0D0 + Basin_ripst_evap = 0.0D0 + Basin_ripst_vol = 0.0D0 + Bankst_seep_rate = 0.0 !collect by segment that HRUs go to + Seg_bankflow = 0.0D0 !collect by segment that HRUs go to + DO i = 1, Nsegment + Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & + & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + IF (Stage_ts(i)>250.) Stage_ts(i) = 250. + ENDDO + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) & + & CALL comp_bank_storage(i) +! ******Compute the bank storage component +! transfers water between separate bank storage and stream depending on seepage + ENDDO + Basin_bankst_seep = Basin_bankst_seep*Basin_area_inv + Basin_bankst_head = Basin_bankst_head*Basin_area_inv + Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv + DO i = 1, Nsegment + Basin_bankst_seep_rate = Basin_bankst_seep_rate + Bankst_seep_rate(i) & + & *Seg_length(i)/SUM(Seg_length) !m2/day per stream ft length + Seg_outflow(i) = Seg_outflow(i)+Seg_bankflow(i) + IF (Seg_bankflow(i) < 0.0) THEN ! only could go negative because of bankflow if is negative + IF (Seg_outflow(i) < 0.0) THEN ! took out more than streamflow, this could also be a water_use problem + Seg_bankflow(i) = Seg_bankflow(i) - Seg_outflow(i) + Seg_outflow(i) = 0.0 + ENDIF + ENDIF + ENDDO + Bankst_seep_rate = 0.0 !collect by segment that HRUs go to + Seg_ripflow = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_segment(i)>0 .AND. Ripst_areafr_max(i)>0.0) & + & CALL drain_the_swamp(i) +! ******Compute the overbank riparian storage component +! transfers water between separate riparian storage and stream depending on seepage + ENDDO + Basin_ripst_seep = Basin_ripst_seep*Basin_area_inv + Basin_ripst_evap = Basin_ripst_evap*Basin_area_inv + Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv + DO i = 1, Nsegment + Seg_outflow(i) = Seg_outflow(i)+Seg_ripflow(i) ! cannot go negative by design + Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & + & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + IF (Stage_ts(i)>250.) Stage_ts(i) = 250. + ENDDO + ENDIF + + T0 = T1 + + Basin_segment_storage = 0.0D0 + Basin_bankflow = 0.0D0 + Basin_ripflow = 0.0D0 + Flow_out = 0.0D0 + Flow_to_lakes = 0.0D0 + Flow_to_ocean = 0.0D0 + Flow_to_great_lakes = 0.0D0 + Flow_out_region = 0.0D0 + Flow_out_NHM = 0.0D0 + Flow_in_region = 0.0D0 + Flow_terminus = 0.0D0 + Flow_in_nation = 0.0D0 + Flow_headwater = 0.0D0 + Flow_in_great_lakes = 0.0D0 + Flow_replacement = 0.0D0 + DO i = 1, Nsegment + segtype = Segment_type(i) + segout = Seg_outflow(i) +! Flow_out is the total flow out of the basin, which allows for multiple outlets +! includes closed basins (tosegment=0) + IF ( segtype==1 ) THEN + Flow_headwater = Flow_headwater + segout + ELSEIF ( segtype==2 ) THEN + Flow_to_lakes = Flow_to_lakes + segout + ELSEIF ( segtype==3 ) THEN + Flow_replacement = Flow_replacement + segout + ELSEIF ( segtype==4 ) THEN + Flow_in_nation = Flow_in_nation + segout + ELSEIF ( segtype==5 ) THEN + Flow_out_NHM = Flow_out_NHM + segout + ELSEIF ( segtype==6 ) THEN + Flow_in_region = Flow_in_region + segout + ELSEIF ( segtype==7 ) THEN + Flow_out_region = Flow_out_region + segout + ELSEIF ( segtype==8 ) THEN + Flow_to_ocean = Flow_to_ocean + segout + ELSEIF ( segtype==9 ) THEN + Flow_terminus = Flow_terminus + segout + ELSEIF ( segtype==10 ) THEN + Flow_in_great_lakes = Flow_in_great_lakes + segout + ELSEIF ( segtype==11 ) THEN + Flow_to_great_lakes = Flow_to_great_lakes + segout + ENDIF + IF ( Tosegment(i)==0 ) Flow_out = Flow_out + segout + + Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout +! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) + Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) + IF ( Ripst_flag==1 ) THEN + Basin_bankflow = Basin_bankflow + Seg_bankflow(i) + Basin_ripflow = Basin_ripflow + Seg_ripflow(i) + ENDIF + ENDDO + + area_fac = Cfs_conv/Basin_area_inv + Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows + Basin_cfs = Flow_out + Basin_stflow_out = Basin_cfs / area_fac + Basin_cms = Basin_cfs*CFS2CMS_CONV + IF ( Glacier_flag==1 ) THEN + Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt + Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac + Basin_gl_cfs = Basin_gl_top_melt*area_fac + ENDIF + Basin_sroff_cfs = Basin_sroff*area_fac + Basin_ssflow_cfs = Basin_ssflow*area_fac + Basin_gwflow_cfs = Basin_gwflow*area_fac + Basin_segment_storage = Basin_segment_storage/area_fac + IF ( Ripst_flag==1 ) THEN + Basin_bankflow = Basin_bankflow/area_fac + Basin_ripflow = Basin_ripflow/area_fac + ENDIF + + END FUNCTION mizuroute_run + +!*********************************************************************** + subroutine handle_err(err,message) + ! handle error codes + implicit none + integer,intent(in)::err ! error code + character(*),intent(in)::message ! error message + if(err/=0)then + print*,'FATAL ERROR: '//trim(message) + stop + endif + end subroutine handle_err + +!*********************************************************************** +! mizuroute_restart - write or read restart file +!*********************************************************************** + SUBROUTINE mizuroute_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_MIZUROUTE + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + ! Function + EXTERNAL :: check_restart + ! Local Variable + CHARACTER(LEN=9) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Outflow_ts + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Outflow_ts + ENDIF + END SUBROUTINE mizuroute_restart diff --git a/prms/muskingum_lake.f90 b/prms/muskingum_lake.f90 index 5ad391eb..119ce789 100644 --- a/prms/muskingum_lake.f90 +++ b/prms/muskingum_lake.f90 @@ -7,7 +7,7 @@ ! problem ! ! nlake_hrus set to nlake for version 5.0.0, nlake_hrus to be added in 5.0.1 -! in future this module may be used for muskingum only, so would need to +! in future this module may be used for muskingum only, so would need to ! check lake_route_flag = 1 in a bunch of places ! ! The Muskingum equation is described in 'Hydrology for Engineers', 3rd ed. @@ -893,10 +893,10 @@ END FUNCTION muskingum_lake_init !*********************************************************************** INTEGER FUNCTION muskingum_lake_run() USE PRMS_MUSKINGUM_LAKE - USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag, Nlake + USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag, Nlake, Glacier_flag USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, & & Lake_area, Lake_type, Hru_area_dble, Lake_hru_id, Hru_type, Weir_gate_flag, & - & Hru_route_order, Active_hrus + & Hru_route_order, Active_hrus, Basin_gl_cfs, Basin_gl_ice_cfs USE PRMS_CLIMATEVARS, ONLY: Hru_ppt USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & @@ -907,6 +907,7 @@ INTEGER FUNCTION muskingum_lake_run() & Obsin_segment, Segment_order, Tosegment, C0, C1, C2, Ts, Ts_i, Obsout_segment, & & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Segment_type, Flow_terminus, & & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes + USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt USE PRMS_SRUNOFF, ONLY: Basin_sroff, Hortonian_lakes USE PRMS_SOILZONE, ONLY: Upslope_dunnianflow, Upslope_interflow USE PRMS_GWFLOW, ONLY: Basin_gwflow, Lake_seepage, Gw_seep_lakein, Gw_upslope @@ -1145,6 +1146,11 @@ INTEGER FUNCTION muskingum_lake_run() Basin_cfs = Flow_out Basin_stflow_out = Basin_cfs / area_fac Basin_cms = Basin_cfs*CFS2CMS_CONV + IF ( Glacier_flag==1 ) THEN + Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt + Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac + Basin_gl_cfs = Basin_gl_top_melt*area_fac + ENDIF Basin_sroff_cfs = Basin_sroff*area_fac Basin_ssflow_cfs = Basin_ssflow*area_fac Basin_gwflow_cfs = Basin_gwflow*area_fac diff --git a/prms/muskingum_lakeCopy.f90 b/prms/muskingum_lakeCopy.f90 new file mode 100644 index 00000000..119ce789 --- /dev/null +++ b/prms/muskingum_lakeCopy.f90 @@ -0,0 +1,1471 @@ +!*********************************************************************** +! Routes water between segments and lakes in the stream network; +! using Muskingum routing for stream segments and 5 lake routing methods +! +! gwflow goes to GWR instead of to the lake unless specified as +! going to stream segment associated with the lake, which would be a +! problem +! +! nlake_hrus set to nlake for version 5.0.0, nlake_hrus to be added in 5.0.1 +! in future this module may be used for muskingum only, so would need to +! check lake_route_flag = 1 in a bunch of places +! +! The Muskingum equation is described in 'Hydrology for Engineers', 3rd ed. +! by Linsley, R.K, Kohler, M.A., and Paulhus, J.L.H., 1982 p. 275 and in +! 'Water in Environmental Planning' by Dunne, T., and Leopold, L.B. 1978 +! p. 357. +! +! Note that the Muskingum equation assumes a linear relation of storage +! to the inflow/outflow relation and therefore the relation is the same +! throughout the range of the hydrograph. The route_time parameter in +! the fixroute module is replaced by two new parameters, K_coef and +! x_coef, which are described below: +! +! The Muskingum method is based on the equation: S = K[xI + (1 - x)O] +! where S is storage, K is the storage coefficient, x is a coefficient +! between 0 and .5, I is inflow, and O is outflow. +! +! Solving for the outflow at day 2,O2; and knowing the inflow at day 1, +! I1; the inflow at day 2,I2; and the outflow at day 1, O1; the storage +! equation can be written as follows: +! +! O2 = czero*I2 + cone*I1 + ctwo*O1 +! +! where czero = -((Kx - 12) / (K - Kx + 12)) +! cone = (Kx + 12) / (K - Kx + 12) +! ctwo = (K - Kx - 12) / (K - Kx + 12) +! +! assuming a time step of one day and K is in units of hours +! +! This module is based on the "musroute.f" module. It differs in three +! basic ways: +! +! 1. This module uses an internal routing time step of one hour. +! The old muskingum module ran on the same daily time step as +! the rest of PRMS. The problem with this is that there is no +! ability to distinguish where the flood wave (front of the flow +! change) within the segment. For example, if there is a series +! of 4 1-day long segments, a flood wave will make it to the bottom +! of these in 1 day. If the same system is modeled as 1 4-day long +! segment, it will take 4 days. +! +! 2. The X parameter has been removed as a specified input and is now computed. To +! my knowledge, no modeler had ever set this to anything other than the default +! value (0.2) anyway. Always using the default value can lead to problems +! with the C coffecients which can result in mass balance problems or negative +! flow values. +! +! To solve this problem, I assume that the C coefficients must +! always be between 0 and 1. By setting the C coefficients equal to 0 and 1, +! various limits on the time step (ts), X, and K can be determined. There are +! two of these limits which are of interest: +! +! When C0 = 0: +! ts +! K = ----- +! 2X +! +! When C2 = 0: +! ts +! K = ----- +! 2(1-X) +! +! Determining a value of K half way between these two limits (by averaging) +! and solving for X using the quadratic formula results in: +! +! 1-sqrt(1-(ts/K)) +! X = ------------------ +! 2 +! +! So when ts is fixed at one hour and K is fixed as the average (or expected) +! travel time corresponding to the segment (for each segment in the stream +! network), a value of X can be computed (for each segment in the stream +! network) which will result in both conservation of mass and non-negative +! flows. Another benefit is that only one input parameter (K) needs to be +! input to the module. +! +! 3. If the travel time of a segment is less than or equal to the routing +! time step (one hour), then the outflow of the segment is set to the +! value of the inflow. +! +!*********************************************************************** + MODULE PRMS_MUSKINGUM_LAKE + IMPLICIT NONE +! Local Variables + DOUBLE PRECISION, PARAMETER :: ONE_24TH = 1.0D0 / 24.0D0 + INTEGER, SAVE :: Obs_flag, Linear_flag, Weir_flag, Gate_flag, Puls_flag + INTEGER, SAVE :: Secondoutflow_flag + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Currinsum(:), Pastin(:), Pastout(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:), Inflow_ts(:) + CHARACTER(LEN=14), SAVE :: MODNAME + DOUBLE PRECISION, SAVE, ALLOCATABLE :: C24(:, :), S24(:, :), Wvd(:, :) +! Dimensions + INTEGER, SAVE :: Mxnsos, Ngate, Nstage, Ngate2, Nstage2, Ngate3, Nstage3, Ngate4, Nstage4 +! Declared Variables + DOUBLE PRECISION, SAVE :: Basin_2ndstflow + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Din1(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_outcfs(:), Lake_outcms(:), Lake_outvol(:), Lake_invol(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_sto(:), Lake_inflow(:), Lake_outflow(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_stream_in(:), Lake_lateral_inflow(:), Lake_gwflow(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_precip(:), Lake_sroff(:), Lake_interflow(:), Lake_outvol_ts(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_seep_in(:), Lake_evap(:), Lake_2gw(:), Lake_outq2(:) +! Declared Parameters + REAL, SAVE, ALLOCATABLE :: Segment_flow_init(:) + ! lake_segment_id only required if cascades are active, otherwise use hru_segment + INTEGER, SAVE, ALLOCATABLE :: Obsout_lake(:), Lake_out2(:), Nsos(:), Ratetbl_lake(:), Lake_segment_id(:) + REAL, SAVE, ALLOCATABLE :: Lake_qro(:), Lake_coef(:), Elev_outflow(:), Weir_coef(:), Weir_len(:) + REAL, SAVE, ALLOCATABLE :: Lake_out2_a(:), Lake_out2_b(:), O2(:, :), S2(:, :) + REAL, SAVE, ALLOCATABLE :: Lake_din1(:), Lake_init(:), Lake_vol_init(:) + REAL, SAVE, ALLOCATABLE :: Rate_table(:, :), Rate_table2(:, :), Rate_table3(:, :), Rate_table4(:, :) + REAL, SAVE, ALLOCATABLE :: Tbl_stage(:), Tbl_gate(:), Tbl_stage2(:), Tbl_gate2(:) + REAL, SAVE, ALLOCATABLE :: Tbl_stage3(:), Tbl_gate3(:), Tbl_stage4(:), Tbl_gate4(:) + END MODULE PRMS_MUSKINGUM_LAKE + +!*********************************************************************** +! Main muskingum_lake routine +!*********************************************************************** + INTEGER FUNCTION muskingum_lake() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: muskingum_lake_decl, muskingum_lake_init, muskingum_lake_run, muskingum_lake_setdims + EXTERNAL :: muskingum_lake_restart +!*********************************************************************** + muskingum_lake = 0 + + IF ( Process(:3)=='run' ) THEN + muskingum_lake = muskingum_lake_run() + ELSEIF ( Process(:7)=='setdims' ) THEN + muskingum_lake = muskingum_lake_setdims() + ELSEIF ( Process(:4)=='decl' ) THEN + muskingum_lake = muskingum_lake_decl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL muskingum_lake_restart(1) + muskingum_lake = muskingum_lake_init() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL muskingum_lake_restart(0) + ENDIF + + END FUNCTION muskingum_lake + +!*********************************************************************** +! declares Lake routing specific dimensions +!*********************************************************************** + INTEGER FUNCTION muskingum_lake_setdims() + USE PRMS_MODULE, ONLY: MAXDIM + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: decldim + EXTERNAL read_error +!*********************************************************************** + muskingum_lake_setdims = 0 + + IF ( decldim('ngate', 0, MAXDIM, & + & 'Maximum number of reservoir gate-opening values (columns) for lake rating table 1')/=0 ) & + & CALL read_error(7, 'ngate') + IF ( decldim('nstage', 0, MAXDIM, & + & 'Maximum number of lake elevations values (rows) for lake rating table 1')/=0 ) CALL read_error(7, 'nstage') + + IF ( decldim('ngate2', 0, MAXDIM, & + & 'Maximum number of reservoir gate-opening values (columns) for lake rating table 2')/=0 ) & + & CALL read_error(7, 'ngate2') + IF ( decldim('nstage2', 0, MAXDIM, & + & 'Maximum number of lake elevations values (rows) for lake rating table 2')/=0 ) CALL read_error(7, 'nstage2') + + IF ( decldim('ngate3', 0, MAXDIM, & + & 'Maximum number of reservoir gate-opening values (columns) for lake rating table 3')/=0 ) & + & CALL read_error(7, 'ngate3') + IF ( decldim('nstage3', 0, MAXDIM, & + & 'Maximum number of lake elevations values (rows) for lake rating table 3')/=0 ) CALL read_error(7, 'nstage3') + + IF ( decldim('ngate4', 0, MAXDIM, & + & 'Maximum number of reservoir gate-opening values (columns) for lake rating table 4')/=0 ) & + & CALL read_error(7, 'ngate4') + IF ( decldim('nstage4', 0, MAXDIM, & + & 'Maximum number of lake elevations values (rows) for lake rating table 4')/=0 ) CALL read_error(7, 'nstage4') + + IF ( decldim('mxnsos', 0, MAXDIM, & + & 'Maximum number of storage/outflow table values for storage-detention reservoirs and lakes connected to'// & + & ' the stream network using Puls routing')/=0 ) CALL read_error(7, 'mxnsos') + + END FUNCTION muskingum_lake_setdims + +!*********************************************************************** +! muskingum_lake_decl - Declare parameters and variables and allocate arrays +! Declared Parameters +! tosegment, hru_segment, obsin_segment, K_coef, x_coef, segment_type +! lake_type, lake_init, lake_qro, lake_din1, lake_coef, o2, s2, nsos, hru_area, lake_segment_id +! tbl_stage, tbl_gate, lake_vol_init, rate_table, weir_coef, weir_len, elev_outflow, elevlake_init +! lake_out2, lake_out2_a, lake_out2_b +!*********************************************************************** + INTEGER FUNCTION muskingum_lake_decl() + USE PRMS_MUSKINGUM_LAKE + USE PRMS_MODULE, ONLY: Model, Nsegment, Init_vars_from_file, Nratetbl, Cascade_flag, Nlake + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar, getdim + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_muskingum_lake +!*********************************************************************** + muskingum_lake_decl = 0 + + Version_muskingum_lake = 'muskingum_lake.f90 2018-04-25 17:00:00Z' + CALL print_module(Version_muskingum_lake, 'Streamflow Routing ', 90) + MODNAME = 'muskingum_lake' + + ! Dimension for Puls routing + Mxnsos = getdim('mxnsos') + IF ( Mxnsos==-1 ) CALL read_error(1, 'mxnsos') + IF ( Model==99 .AND. Mxnsos<1 ) Mxnsos = 1 + +! Nlake_hrus set to nlake in call_modules for 5.0.0, dimension nlake_hrus will be in 5.0.1 +! 5.0.0 assumes lakes are 1 HRU + IF ( Mxnsos>0 ) ALLOCATE ( Wvd(Mxnsos, Nlake), S24(Mxnsos, Nlake), C24(Mxnsos, Nlake) ) + + Ngate = 0 + Nstage = 0 + Ngate2 = 0 + Nstage2 = 0 + Ngate3 = 0 + Nstage3 = 0 + Ngate4 = 0 + Nstage4 = 0 + IF ( Model==99 ) Nratetbl = 4 + IF ( Nratetbl>4 ) THEN + PRINT *, 'ERROR, lake routing allows maximum of 4 rating tables' + PRINT *, 'nratetbl specified as:', Nratetbl + STOP + ENDIF + IF ( Nratetbl>0 ) THEN + Ngate = getdim('ngate') + IF ( Ngate==-1 ) CALL read_error(6, 'ngate') + Nstage = getdim('nstage') + IF ( Nstage==-1 ) CALL read_error(6, 'nstage') + IF ( Nratetbl>1 ) THEN + Ngate2 = getdim('ngate2') + IF ( Ngate2==-1 ) CALL read_error(6, 'ngate2') + Nstage2 = getdim('nstage2') + IF ( Nstage2==-1 ) CALL read_error(6, 'nstage2') + IF ( Nratetbl>2 ) THEN + Ngate3 = getdim('ngate3') + IF ( Ngate3==-1 ) CALL read_error(6, 'ngate3') + Nstage3 = getdim('nstage3') + IF ( Nstage3==-1 ) CALL read_error(6, 'nstage3') + IF ( Nratetbl==4 ) THEN + Ngate4 = getdim('ngate4') + IF ( Ngate4==-1 ) CALL read_error(6, 'ngate4') + Nstage4 = getdim('nstage4') + IF ( Nstage4==-1 ) CALL read_error(6, 'nstage4') + ENDIF + ENDIF + ENDIF + IF ( Model==99 ) THEN + IF ( Nstage==0 ) Nstage = 1 + IF ( Ngate==0 ) Ngate = 1 + IF ( Nstage2==0 ) Nstage2 = 1 + IF ( Ngate2==0 ) Ngate2 = 1 + IF ( Nstage3==0 ) Nstage3 = 1 + IF ( Ngate3==0 ) Ngate3 = 1 + IF ( Nstage4==0 ) Nstage4 = 1 + IF ( Ngate4==0 ) Ngate4 = 1 + ELSE + IF ( Nstage<1 .OR. Ngate<1 ) STOP 'ERROR, nratetbl>0 and nstage or ngate = 0' + ENDIF + IF ( Nratetbl>1 ) THEN + IF ( Nstage2<1.OR.Ngate2<1 ) STOP 'ERROR, nratetbl>1 and nstage2 or ngate2 = 0' + ENDIF + IF ( Nratetbl>2 ) THEN + IF ( Nstage3<1 .OR. Ngate3<1 ) STOP 'ERROR, nratetbl>2 and nstage3 or ngate3 = 0' + ENDIF + IF ( Nratetbl>3 ) THEN + IF ( Nstage4<1 .OR. Ngate4<1 ) STOP 'ERROR, nratetbl>3 and nstage4 or ngate4 = 0' + ENDIF + ENDIF + + ALLOCATE ( Currinsum(Nsegment) ) + ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) ) + ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) ) + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN + ALLOCATE ( Segment_flow_init(Nsegment) ) + IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & + & '0.0', '0.0', '1.0E7', & + & 'Initial flow in each stream segment', & + & 'Initial flow in each stream segment', & + & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') + ENDIF + + ! Lake declared variables + ALLOCATE ( Lake_inflow(Nlake) ) + IF ( declvar(MODNAME, 'lake_inflow', 'nlake', Nlake, 'double', & + & 'Total inflow to each lake', & + & 'cfs', Lake_inflow)/=0 ) CALL read_error(3, 'lake_inflow') + + ALLOCATE ( Lake_outflow(Nlake) ) + IF ( declvar(MODNAME, 'lake_outflow', 'nlake', Nlake, 'double', & + & 'Evaporation and seepage from each lake', & + & 'cfs', Lake_outflow)/=0 ) CALL read_error(3, 'lake_outflow') + + ALLOCATE ( Lake_outcfs(Nlake) ) + IF ( declvar(MODNAME, 'lake_outcfs', 'nlake', Nlake, 'double', & + & 'Streamflow leaving each lake, includes any second outlet flow', & + & 'cfs', Lake_outcfs)/=0 ) CALL read_error(3, 'lake_outcfs') + + ALLOCATE ( Lake_outcms(Nlake) ) + IF ( declvar(MODNAME, 'lake_outcms', 'nlake', Nlake, 'double', & + & 'Streamflow leaving each lake, includes any second outlet flow', & + & 'cms', Lake_outcms)/=0 ) CALL read_error(3, 'lake_outcms') + +! Declared Variables for Puls or linear routing + ALLOCATE ( Lake_sto(Nlake) ) + IF ( declvar(MODNAME, 'lake_sto', 'nlake', Nlake, 'double', & + & 'Storage in each lake using Puls or linear storage routing', & + & 'cfs-days', Lake_sto)/=0 ) CALL read_error(3, 'lake_sto') + + ALLOCATE ( Din1(Nlake) ) + IF ( declvar(MODNAME, 'din1', 'nlake', Nlake, 'double', & + & 'Inflow from the previous time step to each lake using Puls or linear storage routing', & + & 'cfs', Din1)/=0 ) CALL read_error(3, 'din1') + + ALLOCATE ( Lake_stream_in(Nlake) ) + IF ( declvar(MODNAME, 'lake_stream_in', 'nlake', Nlake, 'double', & + & 'Total streamflow into each lake', & + & 'cfs', Lake_stream_in)/=0 ) CALL read_error(3, 'lake_stream_in') + + ALLOCATE ( Lake_precip(Nlake) ) + IF ( declvar(MODNAME, 'lake_precip', 'nlake', Nlake, 'double', & + & 'Total precipitation into each lake', & + & 'cfs', Lake_precip)/=0 ) CALL read_error(3, 'lake_precip') + + IF ( Cascade_flag>0 .OR. Model==99 ) THEN + ALLOCATE ( Lake_lateral_inflow(Nlake) ) + IF ( declvar(MODNAME, 'lake_lateral_inflow', 'nlake', Nlake, 'double', & + & 'Lateral inflow to each lake', & + & 'cfs', Lake_lateral_inflow)/=0 ) CALL read_error(3, 'lake_lateral_inflow') + ALLOCATE ( Lake_sroff(Nlake) ) + IF ( declvar(MODNAME, 'lake_sroff', 'nlake', Nlake, 'double', & + & 'Total surface runoff into each lake', & + & 'cfs', Lake_sroff)/=0 ) CALL read_error(3, 'lake_sroff') + ALLOCATE ( Lake_interflow(Nlake) ) + IF ( declvar(MODNAME, 'lake_interflow', 'nlake', Nlake,'double', & + & 'Total interflow into each lake', & + & 'cfs', Lake_interflow)/=0 ) CALL read_error(3, 'lake_interflow') + ALLOCATE ( Lake_gwflow(Nlake) ) + IF ( declvar(MODNAME, 'lake_gwflow', 'nlake', Nlake,'double', & + & 'Total groundflow into each lake', & + & 'cfs', Lake_gwflow)/=0 ) CALL read_error(3, 'lake_gwflow') + ENDIF + + ALLOCATE ( Lake_evap(Nlake) ) + IF ( declvar(MODNAME, 'lake_evap', 'nlake', Nlake, 'double', & + & 'Total evaporation from each lake', & + & 'cfs', Lake_evap)/=0 ) CALL read_error(3, 'lake_evap') + +! Declared Variables for broad-crested weir or gate opening routing + ALLOCATE ( Lake_2gw(Nlake) ) + IF ( declvar(MODNAME, 'lake_2gw', 'nlake', Nlake, 'double', & + & 'Total seepage from each lake using broad-crested weir or gate opening routing', & + & 'cfs', Lake_2gw)/=0 ) CALL read_error(3, 'lake_2gw') + + ALLOCATE ( Lake_seep_in(Nlake) ) + IF ( declvar(MODNAME, 'lake_seep_in', 'nlake', Nlake, 'double', & + & 'Total seepage into each lake using broad-crested weir or gate opening routing', & + & 'cfs', Lake_seep_in)/=0 ) CALL read_error(3, 'lake_seep_in') + + ALLOCATE ( Lake_invol(Nlake) ) + IF ( declvar(MODNAME, 'lake_invol', 'nlake', Nlake, 'double', & + & 'Inflow to each lake using broad-crested weir or gate opening routing', & + & 'acre-feet', Lake_invol)/=0 ) CALL read_error(3, 'lake_invol') + +! Declared Variables for gate opening routing + ALLOCATE ( Lake_outvol(Nlake) ) + IF ( declvar(MODNAME, 'lake_outvol', 'nlake', Nlake, 'double', & + & 'Outflow from each lake using broad-crested weir or gate opening routing', & + & 'acre-inches', Lake_outvol)/=0 ) CALL read_error(3, 'lake_outvol') + + ALLOCATE ( Lake_outvol_ts(Nlake) ) + IF ( declvar(MODNAME, 'lake_outvol_ts', 'nlake', Nlake, 'double', & + & 'Outflow from each lake using broad-crested weir or gate opening routing for the time step', & + & 'acre-inches', Lake_outvol_ts)/=0 ) CALL read_error(3, 'lake_outvol_ts') + +! Declared Variables for lakes with a second outlet and gate opening routing + IF ( Nratetbl>0 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'basin_2ndstflow', 'one', 1, 'double', & + & 'Basin volume-weighted average streamflow from each lake with a second outlet', & + & 'inches', Basin_2ndstflow)/=0 ) CALL read_error(3, 'basin_2ndstflow') + ALLOCATE ( Lake_outq2(Nlake) ) + IF ( declvar(MODNAME, 'lake_outq2', 'nlake', Nlake, 'double', & + & 'Streamflow from second outlet for each lake with a second outlet', & + & 'cfs', Lake_outq2)/=0 ) CALL read_error(3, 'lake_outq2') + ENDIF + +! Declared Parameters + ALLOCATE ( Lake_segment_id(Nsegment) ) + IF ( Cascade_flag>0 ) THEN + IF ( declparam(MODNAME, 'lake_segment_id', 'nsegment', 'integer', & + & '0', 'bounded', 'nlake', & + & 'Index of lake associated with a segment', & + & 'Index of lake associated with a segment', & + & 'none')/=0 ) CALL read_error(1, 'lake_segment_id') + ENDIF + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN + ALLOCATE ( Lake_qro(Nlake) ) + IF ( declparam(MODNAME, 'lake_qro', 'nlake', 'real', & + & '0.1', '0.0', '1.0E7', & + & 'Initial daily mean outflow from each lake', & + & 'Initial daily mean outflow from each lake', & + & 'cfs')/=0 ) CALL read_error(1, 'lake_qro') + +! Declared Parameters for Puls or linear routing + ALLOCATE ( Lake_init(Nlake) ) + IF ( declparam(MODNAME, 'lake_init', 'nlake', 'real', & + & '0.0', '0.0', '1.0E7', & + & 'Initial storage in each lake', & + & 'Initial storage in each lake using Puls or linear storage routing', & + & 'cfs-days')/=0 ) CALL read_error(1, 'lake_init') + + ALLOCATE ( Lake_din1(Nlake) ) + IF ( declparam(MODNAME, 'lake_din1', 'nlake', 'real', & + & '0.1', '0.0', '1.0E7', & + & 'Initial inflow to each lake', & + & 'Initial inflow to each lake using Puls or linear storage routing', & + & 'cfs')/=0 ) CALL read_error(1, 'lake_din1') + ENDIF + +! Declared Parameters for linear routing + ALLOCATE ( Lake_coef(Nlake) ) + IF ( declparam(MODNAME, 'lake_coef', 'nlake', 'real', & + & '0.1', '0.0001', '1.0', & + & 'Linear lake routing coefficient', & + & 'Coefficient in equation to route storage to streamflow for each lake using linear routing', & + & 'fraction/day')/=0 ) CALL read_error(1, 'lake_coef') + +! Declared Parameters for Puls routing + IF ( Mxnsos>0 ) THEN + ALLOCATE ( O2(Mxnsos, Nlake) ) + IF ( declparam(MODNAME, 'o2', 'mxnsos,nlake', 'real', & + & '0.0', '0.0', '1.0E7', & + & 'Outflow values in outflow/storage tables for Puls routing', & + & 'Outflow values in outflow/storage tables for each lake using Puls routing', & + & 'cfs')/=0 ) CALL read_error(1, 'o2') + + ALLOCATE ( S2(Mxnsos, Nlake) ) + IF ( declparam(MODNAME, 's2', 'mxnsos,nlake', 'real', & + & '0.0', '0.0', '1.0E7', & + & 'Storage values in outflow/storage tables for Puls routing', & + & 'Storage values in outflow/storage table for each lake using Puls routing', & + & 'cfs-days')/=0 ) CALL read_error(1, 's2') + + ALLOCATE ( Nsos(Nlake) ) + IF ( declparam(MODNAME, 'nsos', 'nlake', 'integer', & + & '0', 'bounded', 'mxnsos', & + & 'Number of storage/outflow values in table for Puls routing', & + & 'Number of storage/outflow values in table for each lake using Puls routing', & + & 'none')/=0 ) CALL read_error(1, 'nsos') + ENDIF + +! Declared Parameters for broad-crested weir or gate opening routing + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN + ALLOCATE ( Lake_vol_init(Nlake) ) + IF ( declparam(MODNAME, 'lake_vol_init', 'nlake', 'real', & + & '0.0', '0.0', '1.0E7', & + & 'Initial lake volume', & + & 'Initial lake volume for each lake using broad-crested weir or gate opening routing', & + & 'acre-feet')/=0 ) CALL read_error(1, 'lake_vol_init') + ENDIF + +! Declared Parameters for broad-crested weir routing + ALLOCATE ( Weir_coef(Nlake) ) + IF ( declparam(MODNAME, 'weir_coef', 'nlake', 'real', & + & '2.7', '2.0', '3.0', & + & 'Broad-crested weir coefficent', & + & 'Coefficient for lakes using broad-crested weir routing', & + & 'none')/=0 ) CALL read_error(1, 'weir_coef') + + ALLOCATE ( Weir_len(Nlake) ) + IF ( declparam(MODNAME, 'weir_len', 'nlake', 'real', & + & '5.0', '1.0', '1000.0', & + & 'Broad-crested weir length', & + & 'Weir length for lakes using broad-crested weir routing', & + & 'feet')/=0 ) CALL read_error(1, 'weir_len') + + ALLOCATE ( Elev_outflow(Nlake) ) + IF ( declparam(MODNAME, 'elev_outflow', 'nlake', 'real', & + & '0.0', '-300.0', '10000.0', & + & 'Elevation of the main outflow point', & + & 'Elevation of the main outflow point for each lake using broad-crested weir routing', & + & 'feet')/=0 ) CALL read_error(1, 'elev_outflow') + +! Declared Parameters for gate opening routing + IF ( Nratetbl>0 ) THEN + ALLOCATE ( Ratetbl_lake(Nratetbl), Rate_table(Nstage,Ngate), Tbl_stage(Nstage), Tbl_gate(Ngate) ) + IF ( declparam(MODNAME, 'ratetbl_lake', 'nratetbl', 'integer', & + & '0', 'bounded', 'nlake', & + & 'Index of lake associated with each rating table', & + & 'Index of lake associated with each rating table for'// & + & ' each lake using gate opening routing', & + & 'none')/=0 ) CALL read_error(1, 'ratetbl_lake') + IF ( declparam(MODNAME, 'rate_table', 'nstage,ngate', 'real', & + & '5.0', '-100.0', '1000.0', & + & 'Rating table 1 with stage (rows) and gate opening (cols)', & + & 'Rating table with stage (rows) and gate opening'// & + & ' (cols) for rating table 1 for lakes using gate opening routing and nratetbl>0', & + & 'cfs')/=0 ) CALL read_error(1, 'rate_table') + IF ( declparam(MODNAME, 'tbl_stage', 'nstage', 'real', & + & '5.0', '-100.0', '1000.0', & + & 'Stage values for each row of rating table 1', & + & 'Stage values for each row for rating table 1 for lakes using gate opening routing and nratetbl>0', & + & 'feet')/=0 ) CALL read_error(1, 'tbl_stage') + IF ( declparam(MODNAME, 'tbl_gate', 'ngate', 'real', & + & '0.0', '0.0', '20.0', & + & 'Gate openings for each column of rating table 1', & + & 'Gate openings for each column for rating table 1 for lakes using gate opening routing and nratetbl>0', & + & 'inches')/=0 ) CALL read_error(1, 'tbl_gate') + + IF ( Nratetbl>1 ) THEN + ALLOCATE ( Rate_table2(Nstage2,Ngate2), Tbl_stage2(Nstage2), Tbl_gate2(Ngate2) ) + IF ( declparam(MODNAME, 'rate_table2', 'nstage2,ngate2', 'real', & + & '5.0', '-100.0', '1000.0', & + & 'Rating table 2 with stage (rows) and gate opening (cols)', & + & 'Rating table with stage (rows) and gate opening'// & + & ' (cols) for rating table 2 for lakes using gate opening routing and nratetbl>1', & + & 'cfs')/=0 ) CALL read_error(1, 'rate_table2') + IF ( declparam(MODNAME, 'tbl_stage2', 'nstage2', 'real', & + & '5.0', '-100.0', '1000.0', & + & 'Stage values for each row of rating table 2', & + & 'Stage values for each row for rating table 2 for lakes using gate opening routing and nratetbl>1', & + & 'feet')/=0 ) CALL read_error(1, 'tbl_stage2') + IF ( declparam(MODNAME, 'tbl_gate2', 'ngate2', 'real', & + & '0.0', '0.0', '20.0', & + & 'Gate openings for each column of rating table 2', & + & 'Gate openings for each column for rating table 2 for lakes using gate opening routing and nratetbl>1', & + & 'inches')/=0 ) CALL read_error(1, 'tbl_gate2') + + IF ( Nratetbl>2 ) THEN + ALLOCATE ( Rate_table3(Nstage3,Ngate3), Tbl_stage3(Nstage3), Tbl_gate3(Ngate3) ) + IF ( declparam(MODNAME, 'rate_table3', 'nstage3,ngate3', 'real', & + & '5.0', '-100.0', '1000.0', & + & 'Rating table 3 with stage (rows) and gate opening (cols)', & + & 'Rating table with stage (rows) and gate opening'// & + & ' (cols) for rating table 3 for lakes using gate opening routing and nratetbl>2', & + & 'cfs')/=0 ) CALL read_error(1, 'rate_table3') + IF ( declparam(MODNAME, 'tbl_stage3', 'nstage3', 'real', & + & '5.0', '-100.0', '1000.0', & + & 'Stage values for each row of rating table 3', & + & 'Stage values for each row for rating table 3 for lakes using gate opening routing and nratetbl>2', & + & 'feet')/=0 ) CALL read_error(1, 'tbl_stage3') + IF ( declparam(MODNAME, 'tbl_gate3', 'ngate3', 'real', & + & '0.0', '0.0', '20.0', & + & 'Gate openings for each column of rating table 3', & + & 'Gate openings for each column for rating table 3 for lakes using gate opening routing and nratetbl>2', & + & 'inches')/=0 ) CALL read_error(1, 'tbl_gate3') + + IF ( Nratetbl>3 ) THEN + ALLOCATE ( Rate_table4(Nstage4,Ngate4), Tbl_stage4(Nstage4), Tbl_gate4(Ngate4) ) + IF ( declparam(MODNAME, 'rate_table4', 'nstage4,ngate4', 'real', & + & '5.0', '-100.0', '1000.0', & + & 'Rating table 4 with stage (rows) and gate opening (cols)', & + & 'Rating table with stage (rows) and gate opening'// & + & ' (cols) for rating table 4 for lakes using gate opening routing and nratetbl>3', & + & 'cfs')/=0 ) CALL read_error(1, 'rate_table4') + IF ( declparam(MODNAME, 'tbl_stage4', 'nstage4', 'real', & + & '5.0', '-100.0', '1000.0', & + & 'Stage values for each row of rating table 4', & + & 'Stage values for each row for rating table 4 for lakes using gate opening routing and nratetbl>3', & + & 'feet')/=0 ) CALL read_error(1, 'tbl_stage4') + IF ( declparam(MODNAME, 'tbl_gate4', 'ngate4', 'real', & + & '0.0', '0.0', '20.0', & + & 'Gate openings for each column of rating table 4', & + & 'Gate openings for each column for rating table 4 for lakes using gate opening routing and nratetbl>3', & + & 'inches')/=0 ) CALL read_error(1, 'tbl_gate4') + ENDIF + ENDIF + ENDIF + ENDIF + +! Declared Parameters for lakes with lake outflow set to measured streamflow + ALLOCATE ( Obsout_lake(Nlake) ) + IF ( declparam(MODNAME, 'obsout_lake', 'nlake', 'integer', & + & '0', 'bounded', 'nobs', & + & 'Index of streamflow measurement station that specifies outflow from a lake', & + & 'Index of streamflow measurement station that specifies outflow from each lake using measured flow replacement', & + & 'none')/=0 ) CALL read_error(1, 'obsout_lake') + + IF ( Nratetbl>0 ) THEN +! Declared Parameters for lakes with a second outlet and gate opening routing + ALLOCATE ( Lake_out2(Nlake) ) + IF ( declparam(MODNAME, 'lake_out2', 'nlake', 'integer', & + & '0', '0', '1', & + & 'Switch to specify a second outlet from a lake', & + & 'Switch to specify a second outlet from each lake using gate opening routing (0=no; 1=yes)', & + & 'none')/=0 ) CALL read_error(1, 'lake_out2') + + ALLOCATE ( Lake_out2_a(Nlake) ) + IF ( declparam(MODNAME, 'lake_out2_a', 'nlake', 'real', & + & '1.0', '0.0', '10000.0', & + & 'Outflow coefficient A for each lake with second outlet', & + & 'Coefficient A in outflow equation for each lake with a second outlet using gate opening routing', & + & 'cfs/ft')/=0 ) CALL read_error(1, 'lake_out2_a') + + ALLOCATE ( Lake_out2_b(Nlake) ) + IF ( declparam(MODNAME, 'lake_out2_b', 'nlake', 'real', & + & '100.0', '0.0', '10000.0', & + & 'Outflow coefficient A for each lake with second outlet', & + & 'Coefficient B in outflow equation for each lake with a second outlet using gate opening routing', & + & 'cfs')/=0 ) CALL read_error(1, 'lake_out2_b') + ENDIF + + END FUNCTION muskingum_lake_decl + +!*********************************************************************** +! muskingum_lake_init - Get and check parameter values and initialize variables +!*********************************************************************** + INTEGER FUNCTION muskingum_lake_init() + USE PRMS_MUSKINGUM_LAKE + USE PRMS_MODULE, ONLY: Nsegment, Inputerror_flag, Init_vars_from_file, Nratetbl, Nhru, Cascade_flag, Nlake + USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, DNEARZERO, Active_hrus, Hru_route_order, Gwr_type, & + & CFS2CMS_CONV, Lake_hru_id, Weir_gate_flag, Lake_type, Puls_lin_flag + USE PRMS_FLOWVARS, ONLY: Seg_outflow, Basin_lake_stor, Lake_vol + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_ROUTING, ONLY: Basin_segment_storage, Segment_type, Hru_segment + IMPLICIT NONE +! Functions + INTRINSIC ABS, NINT, DBLE, DABS + EXTERNAL :: read_error + INTEGER, EXTERNAL :: getparam +! Local Variables + INTEGER :: i, ierr, j, jj, kk, ii, jjj + DOUBLE PRECISION :: tmp +!*********************************************************************** + muskingum_lake_init = 0 + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN + IF ( getparam(MODNAME, 'segment_flow_init', Nsegment, 'real', Segment_flow_init)/=0 ) & + & CALL read_error(2,'segment_flow_init') + DO i = 1, Nsegment + Seg_outflow(i) = Segment_flow_init(i) + ENDDO + DEALLOCATE ( Segment_flow_init ) + ENDIF + IF ( Init_vars_from_file==0 ) Outflow_ts = 0.0D0 + + Basin_segment_storage = 0.0D0 + DO i = 1, Nsegment + Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) + ENDDO + Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv + +! Weir_gate_flag and Puls_lin_flag set in basin as needed for restart and gwflow module + Obs_flag = 0 + Linear_flag = 0 + Weir_flag = 0 + Gate_flag = 0 + Puls_flag = 0 + DO i = 1, Nlake + IF ( Lake_type(i)==1 ) THEN + Puls_flag = 1 + ELSEIF ( Lake_type(i)==2 ) THEN + Linear_flag = 1 + ELSEIF ( Lake_type(i)==4 ) THEN + Weir_flag = 1 + ELSEIF ( Lake_type(i)==5 ) THEN + Gate_flag = 1 + ELSEIF ( Lake_type(i)==6 ) THEN + Obs_flag = 1 + ELSEIF ( Lake_type(i)/=3 ) THEN + PRINT *, 'ERROR, invalid lake_type for lake:', i, Lake_type(i) + Inputerror_flag = 1 + ENDIF + ENDDO + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN + IF ( getparam(MODNAME, 'lake_qro', Nlake, 'real', Lake_qro)/=0 ) CALL read_error(2, 'lake_qro') + DO j = 1, Nlake + Lake_outcfs(j) = Lake_qro(j) + Lake_outcms(j) = Lake_qro(j)*CFS2CMS_CONV + ENDDO + ENDIF + + Lake_outvol = 0.0D0 + Lake_outvol_ts = 0.0D0 + Lake_invol = 0.0D0 + Lake_precip = 0.0D0 + Lake_seep_in = 0.0D0 + Lake_evap = 0.0D0 + Lake_2gw = 0.0D0 + Lake_inflow = 0.0D0 + Lake_outflow = 0.0D0 + IF ( Gate_flag==1 ) Lake_outq2 = 0.0D0 + Basin_2ndstflow = 0.0D0 + Lake_stream_in = 0.0D0 + Basin_lake_stor = 0.0D0 + IF ( Cascade_flag>0 ) THEN + Lake_lateral_inflow = 0.0D0 + Lake_sroff = 0.0D0 + Lake_interflow = 0.0D0 + Lake_gwflow = 0.0D0 + ENDIF + + IF ( Cascade_flag==0 .OR. Cascade_flag==2 ) THEN ! when cascades are active, hru_segment is not used + Lake_segment_id = 0 + DO jjj = 1, Active_hrus + j = Hru_route_order(jjj) + i = Hru_segment(j) + IF ( i>0 ) THEN + IF ( Segment_type(i)==2 ) Lake_segment_id(i) = Lake_hru_id(j) + ENDIF + ENDDO + ELSE + ! if cascades are active, must input new parameter lake_segment_id + IF ( getparam(MODNAME, 'lake_segment_id', Nsegment, 'integer', Lake_segment_id)/=0 ) CALL read_error(2, 'lake_segment_id') + ENDIF + DO j = 1, Nsegment + IF ( Lake_segment_id(j)>0 .AND. Segment_type(j)/=2 ) THEN + PRINT *, 'ERROR, segment_type not equal to 2 when the segment is associated with a lake' + PRINT *, ' segment:', j, ' lake:', Lake_segment_id(j) + Inputerror_flag = 1 + ENDIF + IF ( Lake_segment_id(j)==0 .AND. Segment_type(j)==2 ) THEN + PRINT *, 'ERROR, segment_type equals 2 when the segment is not associated with a lake' + PRINT *, ' segment:', j, ' lake:', Lake_segment_id(j) + Inputerror_flag = 1 + ENDIF + ENDDO + + Secondoutflow_flag = 0 + IF ( Gate_flag==1 ) THEN + IF ( Nratetbl<1 ) STOP 'ERROR, nratetbl = 0 and gate opening routing requested' + IF ( getparam(MODNAME, 'rate_table', Nstage*Ngate, 'real', Rate_table)/=0 ) CALL read_error(2, 'rate_table') + IF ( getparam(MODNAME, 'tbl_stage', Nstage, 'real', Tbl_stage)/=0 ) CALL read_error(2, 'tbl_stage') + IF ( getparam(MODNAME, 'tbl_gate', Ngate, 'real', Tbl_gate)/=0 ) CALL read_error(2, 'tbl_gate') + IF ( getparam(MODNAME, 'ratetbl_lake', Nratetbl, 'integer', Ratetbl_lake)/=0 ) CALL read_error(2, 'ratetbl_lake') + IF ( Gate_flag==1 ) THEN + IF ( getparam(MODNAME, 'lake_out2', Nlake, 'integer', Lake_out2)/=0 ) CALL read_error(2, 'lake_out2') + DO j = 1, Nlake + IF ( Lake_out2(j)==1 ) Secondoutflow_flag = 1 + ENDDO + IF ( Secondoutflow_flag==1 ) THEN + IF ( getparam(MODNAME, 'lake_out2_a', Nlake, 'real', Lake_out2_a)/=0 ) CALL read_error(2, 'lake_out2_a') + IF ( getparam(MODNAME, 'lake_out2_b', Nlake, 'real', Lake_out2_b)/=0 ) CALL read_error(2, 'lake_out2_b') + ENDIF + ENDIF + + IF ( Nratetbl>1 ) THEN + IF ( getparam(MODNAME, 'rate_table2', Nstage2*Ngate2, 'real', Rate_table2)/=0 ) CALL read_error(2, 'rate_table2') + IF ( getparam(MODNAME, 'tbl_stage2', Nstage2, 'real', Tbl_stage2)/=0 ) CALL read_error(2, 'tbl_stage2') + IF ( getparam(MODNAME, 'tbl_gate2', Ngate2, 'real', Tbl_gate2)/=0 ) CALL read_error(2, 'tbl_gate2') + + IF ( Nratetbl>2 ) THEN + IF ( getparam(MODNAME, 'rate_table3', Nstage3*Ngate3, 'real', Rate_table3)/=0 ) & + & CALL read_error(2, 'rate_table3') + IF ( getparam(MODNAME, 'tbl_stage3', Nstage3, 'real', Tbl_stage3)/=0 ) CALL read_error(2, 'tbl_stage3') + IF ( getparam(MODNAME, 'tbl_gate3', Ngate3, 'real', Tbl_gate3)/=0 ) CALL read_error(2, 'tbl_gate3') + + IF ( Nratetbl>3 ) THEN + IF ( getparam(MODNAME, 'rate_table4', Nstage4*Ngate4, 'real', Rate_table4)/=0 ) & + & CALL read_error(2, 'rate_table4') + IF ( getparam(MODNAME, 'tbl_stage4', Nstage4, 'real', Tbl_stage4)/=0 ) CALL read_error(2, 'tbl_stage4') + IF ( getparam(MODNAME, 'tbl_gate4', Ngate4, 'real', Tbl_gate4)/=0 ) CALL read_error(2, 'tbl_gate4') + ENDIF + ENDIF + ENDIF + ENDIF + + IF ( Puls_lin_flag==1 ) THEN + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN + IF ( getparam(MODNAME, 'lake_init', Nlake, 'real', Lake_init)/=0 ) CALL read_error(2, 'lake_init') + IF ( getparam(MODNAME, 'lake_din1', Nlake, 'real', Lake_din1)/=0 ) CALL read_error(2, 'lake_din1') + DO i = 1, Nlake + Lake_sto(i) = DBLE( Lake_init(i) ) + Din1(i) = DBLE( Lake_din1(i) ) + ENDDO + ENDIF + DO i = 1, Nlake + IF ( Lake_type(i)==1 ) THEN + kk = Nsos(i) + IF ( kk<1 ) THEN + PRINT *, 'ERROR, lake_type = 1, but, nsos<1, lake:', i, ' nsos:', kk, ' mxnsos:', Mxnsos + Inputerror_flag = 1 + ENDIF + ENDIF + ENDDO + ENDIF + + IF ( Puls_flag==1 ) THEN + IF ( Mxnsos==0 ) STOP 'ERROR, dimension mxnsos = 0 and Puls routing requested' + IF ( getparam(MODNAME, 'o2', Mxnsos*Nlake, 'real', O2)/=0 ) CALL read_error(2, 'o2') + IF ( getparam(MODNAME, 's2', Mxnsos*Nlake, 'real', S2)/=0 ) CALL read_error(2, 's2') + IF ( getparam(MODNAME, 'nsos', Nlake, 'integer', Nsos)/=0 ) CALL read_error(2, 'nsos') + ENDIF + + IF ( Linear_flag==1 ) THEN + IF ( getparam(MODNAME, 'lake_coef', Nlake, 'real', Lake_coef)/=0 ) CALL read_error(2, 'lake_coef') + ENDIF + + IF ( Weir_gate_flag==1 ) THEN + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN + IF ( getparam(MODNAME, 'lake_vol_init', Nlake, 'real', Lake_vol_init)/=0 ) CALL read_error(2, 'lake_vol_init') + DO i = 1, Nlake + Lake_vol(i) = DBLE( Lake_vol_init(i) ) + ENDDO + ENDIF + ENDIF + DO j = 1, Nhru + IF ( Gwr_type(j)==2 ) THEN + jjj = Lake_hru_id(j) + IF ( jjj==0 ) THEN + PRINT *, 'ERROR, GWR specified as a lake but lake_hru_id value = 0, GWR:', j + Inputerror_flag = 1 + ENDIF + ENDIF + IF ( Lake_hru_id(j)>0 .AND. Gwr_type(j)/=2 ) THEN + PRINT *, 'ERROR, GWR specified as associated with a lake but gwr_type = 0, GWR:', j + Inputerror_flag = 1 + ENDIF + ENDDO + + IF ( Weir_flag==1 ) THEN + IF ( getparam(MODNAME, 'weir_coef', Nlake, 'real', Weir_coef)/=0 ) CALL read_error(2, 'weir_coef') + IF ( getparam(MODNAME, 'weir_len', Nlake, 'real', Weir_len)/=0 ) CALL read_error(2, 'weir_len') + IF ( getparam(MODNAME, 'elev_outflow', Nlake, 'real', Elev_outflow)/=0 ) CALL read_error(2, 'elev_outflow') + ENDIF + + IF ( Obs_flag==1 ) THEN + IF ( getparam(MODNAME, 'obsout_lake', Nlake, 'integer', Obsout_lake)/=0 ) CALL read_error(2, 'obsout_lake') + ELSE + Obsout_lake = 1 + ENDIF + + DO j = 1, Nlake + ierr = 0 + IF ( Lake_type(j)==1 .OR. Lake_type(j)==2 ) THEN + IF ( Lake_type(j)==1 ) THEN + kk = Nsos(j) + IF ( kk<1 ) THEN + PRINT *, 'ERROR, lake_type = 1, but, nsos<1, lake:', j, ' nsos:', kk, ' mxnsos:', Mxnsos + ierr = 1 + ENDIF + ENDIF +! ELSEIF ( Weir_gate_flag==1 ) THEN +! IF ( Lake_type(j)==4 ) THEN +! IF ( Elev_outflow(j)<0.0 ) THEN +! PRINT *, 'ERROR, elev_outflow < 0.0 for lake:', j, Elev_outflow(j) +! ierr = 1 +! ENDIF +! ENDIF + ELSEIF ( Lake_type(j)==6 ) THEN + IF ( Obsout_lake(j)==0 ) THEN + PRINT *, 'ERROR, obsout_lake value = 0 for lake:', j, Obsout_lake(j) + ierr = 1 + ENDIF + ENDIF + IF ( ierr==1 ) THEN + Inputerror_flag = 1 + CYCLE + ENDIF + IF ( Lake_type(j)==1 ) THEN + kk = Nsos(j) + DO ii = 1, kk + Wvd(ii, j) = DBLE( S2(ii, j) + O2(ii, j)*0.5 ) + ENDDO + DO jj = 2, kk + tmp = Wvd(jj, j) - Wvd(jj-1, j) + IF ( DABS(tmp)0 ) DEALLOCATE ( O2, S2 ) + + END FUNCTION muskingum_lake_init + +!*********************************************************************** +! muskingum_lake_run - Compute routing summary values +!*********************************************************************** + INTEGER FUNCTION muskingum_lake_run() + USE PRMS_MUSKINGUM_LAKE + USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag, Nlake, Glacier_flag + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, & + & Lake_area, Lake_type, Hru_area_dble, Lake_hru_id, Hru_type, Weir_gate_flag, & + & Hru_route_order, Active_hrus, Basin_gl_cfs, Basin_gl_ice_cfs + USE PRMS_CLIMATEVARS, ONLY: Hru_ppt + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & + & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & + & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out, Basin_lake_stor, Hru_actet, Lake_vol + USE PRMS_OBS, ONLY: Streamflow_cfs + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_ROUTING, ONLY: Use_transfer_segment, Segment_delta_flow, Basin_segment_storage, & + & Obsin_segment, Segment_order, Tosegment, C0, C1, C2, Ts, Ts_i, Obsout_segment, & + & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Segment_type, Flow_terminus, & + & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes + USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt + USE PRMS_SRUNOFF, ONLY: Basin_sroff, Hortonian_lakes + USE PRMS_SOILZONE, ONLY: Upslope_dunnianflow, Upslope_interflow + USE PRMS_GWFLOW, ONLY: Basin_gwflow, Lake_seepage, Gw_seep_lakein, Gw_upslope + IMPLICIT NONE +! Functions + INTRINSIC MOD, DBLE + EXTERNAL route_lake +! Local Variables + INTEGER :: i, j, iorder, toseg, imod, tspd, segtype, lakeid, k, jj + DOUBLE PRECISION :: area_fac, segout, currin, tocfs, lake_in_ts +!*********************************************************************** + muskingum_lake_run = 0 + +! SET yesterdays inflows and outflows into temp (past arrays) +! values may be 0.0 as intial, > 0.0 for runtime and dynamic +! initial condtions. Then set outlfow and inflow for this time +! step to 0.0 +! +! upstream_inflow and outflow will vary by hour +! lateral_inflow and everything else will vary by day +! +! Compute surface runoff, ssflow, and gwflow going to each segment +! This is todays "seg_inflow" before additional water is routed to +! a new (if any is routed) +! +! For each HRU if the lateral flow for this HRU goes to the +! segment being evaluated (segment i) then sum flows +! +! Do these calculations once for the current day, before the hourly +! routing starts. +! +! Out2 = In2*C0 + In1*C1 + Out1*C2 +! Seg_outflow = Seg_inflow*Czero + Pastinflow*Cone + Pastoutflow*Ctwo +! C0, C1, and C2: initialized in the "init" part of this module +! + Pastin = Seg_inflow + Pastout = Seg_outflow + Seg_inflow = 0.0D0 + Seg_outflow = 0.0D0 + Inflow_ts = 0.0D0 + Currinsum = 0.0D0 + + IF ( Secondoutflow_flag==1 ) THEN + Basin_2ndstflow = 0.0D0 + Lake_outq2 = 0.0D0 + ENDIF + Basin_lake_stor = 0.0D0 + Lake_inflow = 0.0D0 + Lake_outflow = 0.0D0 + Lake_stream_in = 0.0D0 + Lake_precip = 0.0D0 + IF ( Cascade_flag>0 ) THEN + Lake_lateral_inflow = 0.0D0 + Lake_sroff = 0.0D0 + Lake_interflow = 0.0D0 + Lake_gwflow = 0.0D0 + ENDIF + IF ( Weir_gate_flag==1 ) THEN + Lake_seep_in = 0.0D0 + Lake_2gw = 0.0D0 + ENDIF + Lake_evap = 0.0D0 + ! shouldn't have snowpack, all precipitation should be added directly to lake + ! units of lake_inflow = cfs + DO jj = 1, Active_hrus + k = Hru_route_order(jj) + IF ( Hru_type(k)/=2 ) CYCLE + tocfs = Hru_area_dble(k)*Cfs_conv + lakeid = Lake_hru_id(k) + Lake_precip(lakeid) = Lake_precip(lakeid) + tocfs*DBLE(Hru_ppt(k)) + IF ( Cascade_flag>0 ) THEN + Lake_sroff(lakeid) = Lake_sroff(lakeid) + tocfs*(Hortonian_lakes(k)+Upslope_dunnianflow(k)) + Lake_interflow(lakeid) = Lake_interflow(lakeid) + tocfs*Upslope_interflow(k) + Lake_gwflow(lakeid) = Lake_gwflow(lakeid) + tocfs*Gw_upslope(k) + ENDIF + Lake_evap(lakeid) = Lake_evap(lakeid) + tocfs*Hru_actet(k) + ENDDO + DO lakeid = 1, Nlake + Lake_inflow(lakeid) = Lake_precip(lakeid) + IF ( Cascade_flag>0 ) THEN + Lake_lateral_inflow(lakeid) = Lake_sroff(lakeid) + Lake_interflow(lakeid) + Lake_gwflow(lakeid) + Lake_inflow(lakeid) = Lake_inflow(lakeid) + Lake_lateral_inflow(lakeid) + ENDIF + Lake_outflow(lakeid) = Lake_evap(lakeid) + IF ( Weir_gate_flag==1 ) THEN + tocfs = Lake_area(lakeid)*Cfs_conv + Lake_seep_in(lakeid) = tocfs*Gw_seep_lakein(lakeid) + Lake_2gw(lakeid) = tocfs*Lake_seepage(lakeid) + Lake_inflow(lakeid) = Lake_inflow(lakeid) + Lake_seep_in(lakeid) + Lake_outflow(lakeid) = Lake_outflow(lakeid) + Lake_2gw(lakeid) + ENDIF + ENDDO + +! 24 hourly timesteps per day + DO j = 1, 24 + + Seg_upstream_inflow = 0.0D0 + DO i = 1, Nsegment + iorder = Segment_order(i) + +! current inflow to the segment is the time weighted average of the outflow +! of the upstream segments plus the lateral HRU inflow plus any gains. + currin = Seg_lateral_inflow(iorder) + IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) + currin = currin + Seg_upstream_inflow(iorder) + Seg_inflow(iorder) = Seg_inflow(iorder) + currin + Inflow_ts(iorder) = Inflow_ts(iorder) + currin + Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder) + + ! Check to see if this segment is to be routed on this time step + tspd = Ts_i(iorder) + imod = MOD( j, tspd ) + IF ( imod==0 ) THEN + Inflow_ts(iorder) = (Inflow_ts(iorder) / Ts(iorder)) + IF ( Segment_type(iorder)==2 ) THEN ! TS must equal 24 + lakeid = Lake_segment_id(iorder) + lake_in_ts = Lake_inflow(lakeid) + currin +! what about water use? + CALL route_lake(lakeid, Lake_type(lakeid), Lake_area(lakeid), lake_in_ts, & + & Lake_outvol_ts(lakeid), Lake_vol(lakeid)) + Outflow_ts(iorder) = Lake_outcfs(lakeid) + Seg_outflow(iorder) = Lake_outcfs(lakeid) + Lake_stream_in(lakeid) = Seg_upstream_inflow(iorder) + ELSE +! Compute routed streamflow + IF ( Ts_i(iorder)>0 ) THEN +! Muskingum routing equation + Outflow_ts(iorder) = Inflow_ts(iorder)*C0(iorder) + Pastin(iorder)*C1(iorder) + Outflow_ts(iorder)*C2(iorder) + ELSE +! If travel time (K_coef paremter) is less than or equal to +! time step (one hour), then the outflow is equal to the inflow +! Outflow_ts is the value from last hour + Outflow_ts(iorder) = Inflow_ts(iorder) + ENDIF + ENDIF + + ! pastin is equal to the Inflow_ts on the previous routed timestep + Pastin(iorder) = Inflow_ts(iorder) + +! because the upstream inflow from streams is used, reset it to zero so new average +! can be computed next routing timestep. + Inflow_ts(iorder) = 0.0D0 + ENDIF + + IF ( Obsout_segment(iorder)>0 ) Outflow_ts(iorder) = Streamflow_cfs(Obsout_segment(iorder)) + + ! water-use removed/added in routing module + ! check for negative flow + IF ( Outflow_ts(iorder)<0.0 ) THEN + IF ( Use_transfer_segment==1 ) THEN + PRINT *, 'ERROR, transfer(s) from stream segment:', iorder, ' causes outflow to be negative' + PRINT *, ' outflow =', Outflow_ts(iorder), ' must fix water-use stream segment transfer file' + ELSE + PRINT *, 'ERROR, outflow from segment:', iorder, ' is negative:', Outflow_ts(iorder) + PRINT *, ' routing parameters may be invalid' + ENDIF + STOP + ENDIF + + IF ( Segment_type(iorder)/=2 ) THEN + ! Seg_outflow (the mean daily flow rate for each segment) will be the average of the hourly values. + Seg_outflow(iorder) = Seg_outflow(iorder) + Outflow_ts(iorder) + ! pastout is equal to the Inflow_ts on the previous routed timestep + Pastout(iorder) = Outflow_ts(iorder) + ENDIF + +! Add current timestep's flow rate to sum the upstream flow rates. +! This can be thought of as a volume because it is a volumetric rate +! (cubic feet per second) over a time step of an hour. Down below when +! this value is used, it will be divided by the number of hours in the +! segment's simulation time step, giving the mean flow rate over that +! period of time. + toseg = Tosegment(iorder) + IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Outflow_ts(iorder) + + ENDDO ! segment + + ENDDO ! timestep + + Basin_segment_storage = 0.0D0 + Flow_out = 0.0D0 + Flow_to_lakes = 0.0D0 + Flow_to_ocean = 0.0D0 + Flow_to_great_lakes = 0.0D0 + Flow_out_region = 0.0D0 + Flow_out_NHM = 0.0D0 + Flow_in_region = 0.0D0 + Flow_terminus = 0.0D0 + Flow_in_nation = 0.0D0 + Flow_headwater = 0.0D0 + Flow_in_great_lakes = 0.0D0 + Flow_replacement = 0.0D0 + ! add water balance check + DO i = 1, Nsegment + segtype = Segment_type(i) + IF ( segtype/=2 ) Seg_outflow(i) = Seg_outflow(i) * ONE_24TH ! lake values set above + segout = Seg_outflow(i) + Seg_inflow(i) = Seg_inflow(i) * ONE_24TH + Seg_upstream_inflow(i) = Currinsum(i) * ONE_24TH +! Flow_out is the total flow out of the basin, which allows for multiple outlets +! includes closed basins (tosegment=0) + IF ( segtype==1 ) THEN + Flow_headwater = Flow_headwater + segout + ELSEIF ( segtype==2 ) THEN + Flow_to_lakes = Flow_to_lakes + segout + lakeid = Lake_segment_id(i) + Lake_outcms(lakeid) = Lake_outcfs(lakeid)*CFS2CMS_CONV + Basin_lake_stor = Basin_lake_stor + Lake_vol(Lakeid)*12.0D0 + ELSEIF ( segtype==3 ) THEN + Flow_replacement = Flow_replacement + segout + ELSEIF ( segtype==4 ) THEN + Flow_in_nation = Flow_in_nation + segout + ELSEIF ( segtype==5 ) THEN + Flow_out_NHM = Flow_out_NHM + segout + ELSEIF ( segtype==6 ) THEN + Flow_in_region = Flow_in_region + segout + ELSEIF ( segtype==7 ) THEN + Flow_out_region = Flow_out_region + segout + ELSEIF ( segtype==8 ) THEN + Flow_to_ocean = Flow_to_ocean + segout + ELSEIF ( segtype==9 ) THEN + Flow_terminus = Flow_terminus + segout + ELSEIF ( segtype==10 ) THEN + Flow_in_great_lakes = Flow_in_great_lakes + segout + ELSEIF ( segtype==11 ) THEN + Flow_to_great_lakes = Flow_to_great_lakes + segout + ENDIF + IF ( Tosegment(i)==0 ) Flow_out = Flow_out + segout + Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout +! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) + Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) + ENDDO + + area_fac = Cfs_conv/Basin_area_inv + Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows + Basin_cfs = Flow_out + Basin_stflow_out = Basin_cfs / area_fac + Basin_cms = Basin_cfs*CFS2CMS_CONV + IF ( Glacier_flag==1 ) THEN + Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt + Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac + Basin_gl_cfs = Basin_gl_top_melt*area_fac + ENDIF + Basin_sroff_cfs = Basin_sroff*area_fac + Basin_ssflow_cfs = Basin_ssflow*area_fac + Basin_gwflow_cfs = Basin_gwflow*area_fac + Basin_segment_storage = Basin_segment_storage/area_fac + Basin_2ndstflow = Basin_2ndstflow*Basin_area_inv + Basin_lake_stor = Basin_lake_stor*Basin_area_inv + +! write(77,'(10f11.3)') lake_vol, lake_outflow, lake_stream_in, lake_outcfs, elevlake + END FUNCTION muskingum_lake_run + +! *********************************** +! * Route Lake +! *********************************** + SUBROUTINE route_lake(Lakeid, Laketype, Lake_area, Lake_in_ts, Lake_outvol_ts, Lake_vol) + USE PRMS_MUSKINGUM_LAKE, ONLY: Lake_sto, Lake_outcfs, Lake_inflow, Din1, Lake_outflow, & + & Wvd, Nsos, S24, C24, Lake_coef, Lake_invol, Weir_coef, Weir_len, Elev_outflow, & + & Tbl_gate, Tbl_stage, Rate_table, Tbl_gate2, Tbl_stage2, Rate_table2, & + & Tbl_gate3, Tbl_stage3, Rate_table3, Tbl_gate4, Tbl_stage4, Rate_table4, & + & Obsout_lake, Ratetbl_lake, Ngate, Nstage, Ngate2, Nstage2, Ngate3, Nstage3, Ngate4, Nstage4, & + & Secondoutflow_flag, Lake_out2, Lake_out2_a, Lake_out2_b, Lake_outq2, Basin_2ndstflow + USE PRMS_MODULE, ONLY: Nratetbl, Print_debug + USE PRMS_OBS, ONLY: Gate_ht, Streamflow_cfs + USE PRMS_ROUTING, ONLY: Cfs2acft + USE PRMS_GWFLOW, ONLY: Elevlake + IMPLICIT NONE +! Functions + INTRINSIC EXP, DBLE, SNGL, DABS + EXTERNAL table_comp +! Arguments + INTEGER, INTENT(IN) :: Lakeid, Laketype + DOUBLE PRECISION, INTENT(IN) :: Lake_area, Lake_in_ts + DOUBLE PRECISION, INTENT(INOUT) :: Lake_outvol_ts, Lake_vol ! acft +! Local Variables + INTEGER :: n, jjj, i + REAL :: q1, q3, elevold, head, new_elevlake, head2, scnd_cfs1, scnd_cfs2 + DOUBLE PRECISION :: avin, s2o2, q2, lake_out, diff_vol, lake_out1 + DOUBLE PRECISION :: xkt, coef2, lake_storage +!*********************************************************************** + !!! ? adjust storage at end of time step ?? + ! q2 = lake out in cfs + q2 = 0.0D0 + lake_storage = 0.0D0 + IF ( Laketype==1 .OR. Laketype==2 ) THEN + lake_storage = Lake_sto(Lakeid) + ELSE + Lake_outcfs(Lakeid) = 0.0D0 + ENDIF +! Compute outflow using Puls routing method + IF ( Laketype==1 ) THEN + !rsr, why half of current in and last in??? + avin = (Lake_inflow(Lakeid)+Din1(Lakeid))*0.5D0 + s2o2 = lake_storage - (Lake_outflow(Lakeid)+Lake_outcfs(Lakeid))*0.5D0 + s2o2 = s2o2 + avin + Din1(Lakeid) = Lake_inflow(Lakeid) + n = Nsos(Lakeid) + DO jjj = 2, n + IF ( s2o2-1 ) THEN + PRINT *, 'WARNING: specified observed runoff value for outflow from lake < 0:', Lakeid, ' value:', q2 + PRINT *, 'runoff id:', Obsout_lake(Lakeid), ' outflow set to 0.0' + ENDIF + q2 = 0.0D0 + ENDIF + + ELSE ! 4 or 5; broad-crested weir or gate opening + elevold = Elevlake(Lakeid) + + ! units lake_invol = acft + Lake_invol(Lakeid) = Lake_in_ts * Cfs2acft + + ! units lake_out = acft + lake_out = Lake_outflow(Lakeid) * Cfs2acft ! evap and seepage + diff_vol = Lake_invol(Lakeid) - lake_out + q1 = 0.0 + q3 = 0.0 + +! Compute using lake surface elevation and broad crested weir + IF ( Laketype==4 ) THEN + head = elevold - Elev_outflow(Lakeid) + IF ( head<0.0 ) head = 0.0 + q1 = (head**1.5) * Weir_coef(Lakeid) * Weir_len(Lakeid) + lake_out1 = DBLE(q1)*Cfs2acft + + ! new_elevlake has units of feet + new_elevlake = elevold + SNGL( (diff_vol-lake_out1)/Lake_area ) + + head2 = (new_elevlake+elevold)*0.5 - Elev_outflow(Lakeid) + IF ( head2<0.0 ) head2 = 0.0 + q3 = (head2**1.5) * Weir_coef(Lakeid) * Weir_len(Lakeid) + +! Compute using a rating table of lake surface elevation & gate opening + ELSE ! type = 5 + DO i = 1, Nratetbl + IF ( Lakeid==Ratetbl_lake(i) ) THEN + IF ( i==1 ) THEN + CALL table_comp(Ngate, Nstage, Tbl_gate, Tbl_stage, & + & Rate_table, elevold, Gate_ht(i), q1, Lake_area) + ELSEIF ( i==2 ) THEN + CALL table_comp(Ngate2, Nstage2, Tbl_gate2, Tbl_stage2, & + & Rate_table2, elevold, Gate_ht(i), q1, Lake_area) + ELSEIF ( i==3 ) THEN + CALL table_comp(Ngate3, Nstage3, Tbl_gate3, Tbl_stage3, & + & Rate_table3, elevold, Gate_ht(i), q1, Lake_area) + ELSEIF ( i==4 ) THEN + CALL table_comp(Ngate4, Nstage4, Tbl_gate4, Tbl_stage4, & + & Rate_table4, elevold, Gate_ht(i), q1, Lake_area) + ENDIF + ENDIF + ENDDO + scnd_cfs1 = 0.0D0 + IF ( Secondoutflow_flag==1 ) THEN +! if lake has a second outlet then outflow in cfs is computed by +! Q = Lake_out2_a*Elevlake - Lake_out2_b +! (as per Rob Dudley email 7 Sep 2006) + IF ( Lake_out2(Lakeid)==1 ) scnd_cfs1 = (Lake_out2_a(Lakeid)*elevold) - Lake_out2_b(Lakeid) + ENDIF + + lake_out1 = DBLE(q1+scnd_cfs1)*Cfs2acft + + ! new_elevlake has units of feet + new_elevlake = elevold + SNGL( (diff_vol-lake_out1)/Lake_area ) + + DO i = 1, Nratetbl + IF ( Lakeid==Ratetbl_lake(i) ) THEN + IF ( i==1 ) THEN + CALL table_comp(Ngate, Nstage, Tbl_gate, Tbl_stage, Rate_table, & + & new_elevlake, Gate_ht(i), q3, Lake_area) + ELSEIF ( i==2 ) THEN + CALL table_comp(Ngate2, Nstage2, Tbl_gate2, Tbl_stage2, Rate_table2, & + & new_elevlake, Gate_ht(i), q3, Lake_area) + ELSEIF ( i==3 ) THEN + CALL table_comp(Ngate3, Nstage3, Tbl_gate3, Tbl_stage3, Rate_table3, & + & new_elevlake, Gate_ht(i), q3, Lake_area) + ELSEIF ( i==4 ) THEN + CALL table_comp(Ngate4, Nstage4, Tbl_gate4, Tbl_stage4, Rate_table4, & + & new_elevlake, Gate_ht(i), q3, Lake_area) + ENDIF + ENDIF + ENDDO + + IF ( Secondoutflow_flag==1 ) THEN + IF ( Lake_out2(lakeid)==1 ) THEN + scnd_cfs2 = (Lake_out2_a(Lakeid)*new_elevlake) - Lake_out2_b(Lakeid) + ELSE + scnd_cfs2 = 0.0D0 + ENDIF + Lake_outq2(Lakeid) = (scnd_cfs1+scnd_cfs2)*0.5D0 + Basin_2ndstflow = Basin_2ndstflow + Lake_outq2(Lakeid)*Cfs2acft*12.0D0 + ENDIF + ENDIF + + q2 = DBLE( (q1+q3)*0.5 ) +! !sanity check, rsr + IF ( q2<0.0D0 ) PRINT *, 'q2<0', q2, ' lake:', Lakeid + IF ( Secondoutflow_flag==1 ) q2 = q2 + Lake_outq2(Lakeid) + + Lake_outvol_ts = q2*Cfs2acft + lake_out + Lake_vol = Lake_vol + Lake_invol(Lakeid) - Lake_outvol_ts + IF ( Lake_vol<0.0D0 ) THEN + Lake_outvol_ts = DABS(Lake_vol) + Lake_vol = 0.0D0 + ELSE + ! adjust lake elevation with stream and lateral inflows + ! and streamflow, any second outlet, GWR, and evaporation outflows + Elevlake(Lakeid) = Elevlake(Lakeid) + SNGL( (Lake_invol(Lakeid)-Lake_outvol_ts)/Lake_area ) + ENDIF + ENDIF + IF ( lake_storage<0.0D0 ) THEN + PRINT *, 'ERROR: lake storage < 0 lake:', Lakeid, '; storage:', lake_storage + STOP + ENDIF + + Lake_outcfs(Lakeid) = q2 + + END SUBROUTINE route_lake + +!===================================================================== +! Rating table computation +!===================================================================== + SUBROUTINE table_comp(Ngate, Nstage, Tbl_gate, Tbl_stage, Rate_table, Elevlake, Gate_ht, Q2, Lake_area) + USE PRMS_MODULE, ONLY: Print_debug + USE PRMS_ROUTING, ONLY: Cfs2acft + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Ngate, Nstage + REAL, INTENT(IN) :: Tbl_gate(Ngate), Tbl_stage(Nstage), Rate_table(Nstage, Ngate), Gate_ht, Elevlake + DOUBLE PRECISION, INTENT(IN) :: Lake_area + REAL, INTENT(OUT) :: Q2 +! Functions + INTRINSIC SNGL +! Local Variables + INTEGER m, mm, stg1, stg2, gate1, gate2 + REAL :: diff_q_stg1, diff_q_stg2, ratiog, ratios, q_stg1, q_stg2, diffq +!*********************************************************************** + IF ( ElevlakeTbl_stage(1) ) THEN + ! lake elevation is > maximum stage, spill all water + Q2 = (Elevlake-Tbl_stage(1))*SNGL(Lake_area/Cfs2acft) + IF ( Print_debug>-1 ) THEN + PRINT *, 'WARNING, lake elevation > maximum stage in rating table all water above rating table spills' + PRINT *, 'Lake elevation:', Elevlake, ' Rating table stage:', Tbl_stage(1), ' discharge to stream:', Q2 + ENDIF + ELSE + stg2 = 1 + stg1 = 0 + DO m = 1, Nstage + IF ( Elevlake>Tbl_stage(m) ) THEN + IF ( m==1 ) THEN + stg2 = 1 + stg1 = 1 + ELSE + stg2 = m + stg1 = m - 1 + ENDIF + EXIT + ENDIF + ENDDO + + gate2 = Ngate + gate1 = Ngate - 1 + IF ( Gate_ht<=Tbl_gate(Ngate) ) THEN + DO mm = 1, Ngate + IF ( Tbl_gate(mm)>Gate_ht ) THEN + IF ( mm==1 ) THEN + gate2 = 1 + gate1 = 1 + ELSE + gate2 = mm + gate1 = mm - 1 + ENDIF + EXIT + ENDIF + ENDDO + ENDIF + + IF ( stg1==0 ) THEN + Q2 = Rate_table(1, gate2) + + ELSE + diff_q_stg2 = Rate_table(stg2, gate2) - Rate_table(stg2, gate1) + diff_q_stg1 = Rate_table(stg1, gate2) - Rate_table(stg1, gate1) + + !rsr, possible divide by 0.0??? + ratiog = (Gate_ht-Tbl_gate(gate1))/(Tbl_gate(gate2)-Tbl_gate(gate1)) + q_stg2 = (ratiog*diff_q_stg2) + Rate_table(stg2, gate1) + q_stg1 = (ratiog*diff_q_stg1) + Rate_table(stg1, gate1) + + !rsr, possible divide by 0.0??? + ratios = (Elevlake-Tbl_stage(stg2))/(Tbl_stage(stg1)-Tbl_stage(stg2)) + diffq = q_stg1 - q_stg2 + Q2 = q_stg2 + (ratios*diffq) + ENDIF + ENDIF + + END SUBROUTINE table_comp + +!*********************************************************************** +! muskingum_lake_restart - write or read restart file +!*********************************************************************** + SUBROUTINE muskingum_lake_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_BASIN, ONLY: Puls_lin_flag + USE PRMS_MUSKINGUM_LAKE + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + ! Function + EXTERNAL :: check_restart + ! Local Variable + CHARACTER(LEN=14) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Outflow_ts + IF ( Puls_lin_flag==1 ) THEN + WRITE ( Restart_outunit ) Din1 + WRITE ( Restart_outunit ) Lake_sto + ENDIF + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Outflow_ts + IF ( Puls_lin_flag==1 ) THEN + READ ( Restart_inunit ) Din1 + READ ( Restart_inunit ) Lake_sto + ENDIF + ENDIF + END SUBROUTINE muskingum_lake_restart diff --git a/prms/precip_1sta_laps.f90 b/prms/precip_1sta_laps.f90 index 22b30215..c6f8fa68 100644 --- a/prms/precip_1sta_laps.f90 +++ b/prms/precip_1sta_laps.f90 @@ -3,7 +3,7 @@ ! to each HRU from one or more stations HRU using monthly correction ! factors to account for differences in altitude, spatial variation, ! topography, and measurement gage efficiency (precip_1sta) -! or by computing a daily lapse rate using elevation data and using +! or by computing a daily lapse rate using elevation data and using ! specified adjustment factors for precipitation from two measurement ! stations(precip_laps) ! Declared Parameters @@ -31,8 +31,10 @@ END MODULE PRMS_PRECIP_1STA_LAPS INTEGER FUNCTION precip_1sta_laps() USE PRMS_PRECIP_1STA_LAPS - USE PRMS_MODULE, ONLY: Process, Nhru, Nrain, Inputerror_flag, Precip_flag, Model, Print_debug - USE PRMS_BASIN, ONLY: Active_hrus, Hru_area, Hru_route_order, Basin_area_inv, Hru_elev, MM2INCH + USE PRMS_MODULE, ONLY: Process, Nhru, Nrain, Inputerror_flag, & + & Precip_flag, Model, Print_debug, Glacier_flag + USE PRMS_BASIN, ONLY: Active_hrus, Hru_area, Hru_route_order, Basin_area_inv, & + & Hru_elev_ts, MM2INCH, Hru_type USE PRMS_CLIMATEVARS, ONLY: Newsnow, Pptmix, Prmx, Basin_ppt, & & Basin_rain, Basin_snow, Hru_ppt, Hru_rain, Hru_snow, & & Basin_obs_ppt, Tmaxf, Tminf, Tmax_allrain_f, Tmax_allsnow_f, & @@ -83,6 +85,12 @@ INTEGER FUNCTION precip_1sta_laps() Newsnow(i) = 0 Pptmix(i) = 0 ppt = Precip_local(Hru_psta(i)) + IF ( Glacier_flag==1 ) THEN + IF ( Hru_type(i)==4 ) THEN + ! Hru_elev_ts is the antecedent glacier elevation + IF ( Precip_flag==2 ) CALL compute_precip_laps(i, Hru_plaps(i), Hru_psta(i), Hru_elev_ts(i)) + ENDIF + ENDIF IF ( ppt>0.0 ) & & CALL precip_form(ppt, Hru_ppt(i), Hru_rain(i), Hru_snow(i), Tmaxf(i), & & Tminf(i), Pptmix(i), Newsnow(i), Prmx(i), & @@ -109,7 +117,7 @@ INTEGER FUNCTION precip_1sta_laps() ! Declare parameters ALLOCATE ( Hru_psta(Nhru) ) IF ( declparam(MODNAME, 'hru_psta', 'nhru', 'integer', & - & '0', 'bounded', 'nrain', & + & '1', 'bounded', 'nrain', & & 'Index of base precipitation station for HRU', & & 'Index of the base precipitation station used for lapse'// & & ' rate calculations for each HRU', & @@ -118,7 +126,7 @@ INTEGER FUNCTION precip_1sta_laps() ALLOCATE ( Rain_adj_lapse(Nhru, 12), Snow_adj_lapse(Nhru, 12) ) IF ( Precip_flag==1 .OR. Model==99 ) THEN IF ( declparam(MODNAME, 'rain_adj', 'nhru,nmonths', 'real', & - & '1.0', '0.5', '2.5', & + & '1.0', '0.5', '10.0', & & 'Monthly rain adjustment factor for each HRU', & & 'Monthly (January to December) factor to adjust measured'// & & ' precipitation on each HRU to account for'// & @@ -202,7 +210,8 @@ INTEGER FUNCTION precip_1sta_laps() ierr = 0 CALL checkdim_param_limits(i, 'hru_plaps', 'nrain', Hru_plaps(i), 1, Nrain, ierr) IF ( ierr==0 ) THEN - CALL compute_precip_laps(i, Hru_plaps(i), Hru_psta(i), Hru_elev(i)) + ! Hru_elev_ts is the current elevation, either hru_elev or for restart Hru_elev_ts + CALL compute_precip_laps(i, Hru_plaps(i), Hru_psta(i), Hru_elev_ts(i)) ELSE Inputerror_flag = 1 ENDIF @@ -242,7 +251,7 @@ SUBROUTINE compute_precip_laps(Ihru, Hru_plaps, Hru_psta, Hru_elev) adj_p = (pmo_rate*elh_diff)/Pmn_mo(Hru_psta, j) IF ( Padj_sn(Hru_psta, j)>=0.0 ) THEN Snow_adj_lapse(Ihru, j) = 1.0 + Padj_sn(Hru_psta, j)*adj_p - ELSE + ELSE Snow_adj_lapse(Ihru, j) = -Padj_sn(Hru_psta, j) ENDIF IF ( Padj_rn(Hru_psta,j)<0.0 ) THEN diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index 92554ebe..a6d7fb66 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -1,6 +1,9 @@ !*********************************************************************** ! Initiates development of a snowpack and simulates snow accumulation ! and depletion processes using an energy-budget approach +! +! Modified glacier melt and glacier basal melt +! These modifications includes albedo info for saving between runs 2/00 !*********************************************************************** ! PRMS_SNOW module for defining stateful variables @@ -16,6 +19,8 @@ MODULE PRMS_SNOW !**************************************************************** ! Local Variables + REAL, PARAMETER :: PI = 3.1415927 + INTEGER, SAVE :: Active_glacier INTEGER, SAVE, ALLOCATABLE :: Int_alb(:) DOUBLE PRECISION, SAVE :: Deninv, Denmaxinv, Settle_const_dble ! REAL, SAVE :: Setden, Set1 @@ -28,18 +33,26 @@ MODULE PRMS_SNOW !**************************************************************** ! Declared Variables + INTEGER :: Yrdays5 INTEGER, SAVE, ALLOCATABLE :: Pptmix_nopack(:), Lst(:) INTEGER, SAVE, ALLOCATABLE :: Iasw(:), Iso(:), Mso(:), Lso(:) - DOUBLE PRECISION, SAVE :: Basin_snowmelt, Basin_pweqv, Basin_tcal - DOUBLE PRECISION, SAVE :: Basin_snowcov, Basin_snowevap - DOUBLE PRECISION, SAVE :: Basin_snowdepth, Basin_pk_precip + DOUBLE PRECISION, SAVE :: Basin_snowmelt, Basin_pweqv, Basin_tcal, Basin_glacrevap + DOUBLE PRECISION, SAVE :: Basin_snowcov, Basin_snowevap, Basin_snowicecov + DOUBLE PRECISION, SAVE :: Basin_snowdepth, Basin_pk_precip, Basin_glacrb_melt REAL, SAVE, ALLOCATABLE :: Snowmelt(:), Snow_evap(:) REAL, SAVE, ALLOCATABLE :: Albedo(:), Pk_temp(:), Pk_den(:) REAL, SAVE, ALLOCATABLE :: Pk_def(:), Pk_ice(:), Freeh2o(:) REAL, SAVE, ALLOCATABLE :: Snowcov_area(:), Tcal(:) REAL, SAVE, ALLOCATABLE :: Snsv(:), Pk_precip(:) - REAL, SAVE, ALLOCATABLE :: Frac_swe(:) + REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_capm(:), Frac_swe(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Pk_depth(:), Pkwater_ante(:), Ai(:) + REAL, SAVE, ALLOCATABLE :: Glacrmelt(:), Glacr_evap(:), Glacr_albedo(:), Glacr_pk_den(:) + REAL, SAVE, ALLOCATABLE :: Glacr_pk_ice(:), Glacr_freeh2o(:), Glacrcov_area(:), Glacr_tcal(:) + REAL, SAVE, ALLOCATABLE :: Glacrb_melt(:), Glacr_pk_def(:), Glacr_pk_temp(:), Glacr_air_avtemp(:) + REAL, SAVE, ALLOCATABLE :: Glacr_air_5avtemp1(:), Glacr_air_deltemp(:), Glacr_air_5avtemp(:) + REAL, SAVE, ALLOCATABLE :: Glacr_5avsnow1(:), Glacr_5avsnow(:),Glacr_delsnow(:), + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pkwater_ante(:), Glacr_pkwater_equiv(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pk_depth(:), Glacr_pss(:), Glacr_pst(:) !**************************************************************** ! Declared Parameters @@ -50,6 +63,8 @@ MODULE PRMS_SNOW REAL, SAVE :: Den_init, Settle_const, Den_max REAL, SAVE, ALLOCATABLE :: Rad_trncf(:), Snarea_thresh(:), Snowpack_init(:) REAL, SAVE, ALLOCATABLE :: Snarea_curve(:, :) + REAL, SAVE, ALLOCATABLE :: Glacr_layer(:), Albedo_coef(:), Albedo_ice(:) + REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_cap(:), Glacier_frac_init(:), Snowfld_frac_init(:) END MODULE PRMS_SNOW @@ -85,10 +100,11 @@ END FUNCTION snowcomp ! albset_rnm, albset_rna, albset_snm, albset_sna, potet_sublim ! emis_noppt, cecn_coef, freeh2o_cap, tstorm_mo, tmax_allsnow ! hru_area, cov_type, covden_win +! glacr_freeh2o_cap, glacr_layer !*********************************************************************** INTEGER FUNCTION snodecl() USE PRMS_SNOW - USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file + USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declparam, declvar @@ -135,6 +151,170 @@ INTEGER FUNCTION snodecl() & 'Flag to indicate (1: accumulation season curve; 2: use of the melt season curve)', & & 'none', Int_alb)/=0 ) CALL read_error(3, 'int_alb') +! Glacier declares + IF ( Glacier_flag==1 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'yrdays5', 'one', 1, 'integer', & + & 'Number of days since last 5 year mark', & + & 'none', Yrdays5)/=0 ) CALL read_error(3, 'yrdays5') + + ALLOCATE ( Glacr_freeh2o_capm(Nhru) ) + IF ( declvar(MODNAME, 'glacr_freeh2o_capm', 'nhru', Nhru, 'real', & + & 'Free-water holding capacity of glacier ice, changes to 0 if active layer melts', & + & 'decimal fraction', Glacr_freeh2o_capm)/=0 ) CALL read_error(3, 'glacr_freeh2o_capm') + + ALLOCATE ( Glacrb_melt(Nhru) ) + IF ( declvar(MODNAME, 'glacrb_melt', 'nhru', Nhru, 'real', & + 'Glacier basal melt, goes to soil', & + 'inches/day', Glacrb_melt)/=0 ) CALL read_error(3, 'glacrb_melt') + + ALLOCATE ( Glacr_air_avtemp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_avtemp', 'nhru', Nhru, 'real', & + & 'Current average year air temperature over glacier or snowfld HRU', & + & 'degrees Celsius', Glacr_air_avtemp)/=0 ) CALL read_error(3, 'glacr_air_avtemp') + + ALLOCATE ( Glacr_air_5avtemp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_5avtemp', 'nhru', Nhru, 'real', & + & 'Current 5-yr average summer (June July Aug) air temperature over glacier or snowfld HRU', & + & 'degrees Celsius', Glacr_air_5avtemp)/=0 ) CALL read_error(3, 'glacr_air_5avtemp') + + ALLOCATE ( Glacr_air_5avtemp1(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_5avtemp1', 'nhru', Nhru, 'real', & + & 'First 5-yr average summer temperature over glacier or snowfld HRU', & + & 'degrees Celsius', Glacr_air_5avtemp1)/=0 ) CALL read_error(3, 'glacr_air_5avtemp1') + + ALLOCATE ( Glacr_air_deltemp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_deltemp', 'nhru', Nhru, 'real', & + & 'Change in 5-yr average air temperature over glacier or snowfld HRU from first', & + & 'degrees Celsius', Glacr_air_deltemp)/=0 ) CALL read_error(3, 'glacr_air_deltemp') + + ALLOCATE ( Glacr_5avsnow(Nhru) ) + IF ( declvar(MODNAME, 'glacr_5avsnow', 'nhru', Nhru, 'real', & + & 'Current 5-yr average snow over glacier or snowfld HRU', & + & 'inches/yr', Glacr_5avsnow)/=0 ) CALL read_error(3, 'glacr_5avsnow') + + ALLOCATE ( Glacr_5avsnow1(Nhru) ) + IF ( declvar(MODNAME, 'glacr_5avsnow1', 'nhru', Nhru, 'real', & + & 'First 5-yr average snow over glacier or snowfld HRU', & + & 'inches/yr', Glacr_5avsnow1)/=0 ) CALL read_error(3, 'glacr_5avsnow1') + + ALLOCATE ( Glacr_delsnow(Nhru) ) + IF ( declvar(MODNAME, 'glacr_delsnow', 'nhru', Nhru, 'real', & + & 'Change in 5-yr average snow over glacier or snowfld HRU from first', & + & 'inches/yr', Glacr_delsnow)/=0 ) CALL read_error(3, 'glacr_delsnow') + + ALLOCATE ( Glacr_pk_temp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_temp', 'nhru', Nhru, 'real', & + & 'Temperature of the glacier on each HRU', & + & 'degrees Celsius', Glacr_pk_temp)/=0 ) CALL read_error(3, 'glacr_pk_temp') + + ALLOCATE ( Glacr_pk_def(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_def', 'nhru', Nhru, 'real', & + & 'Heat deficit, amount of heat necessary to make the glacier snowpack isothermal at 0 degrees Celsius', & + & 'Langleys', Glacr_pk_def)/=0 ) CALL read_error(3, 'glacr_pk_def') + + ALLOCATE ( Glacr_pk_den(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_den', 'nhru', Nhru, 'real', & + & 'Density of the icepack on each glacier HRU, hard-coded to equal 0.917', & + & 'gm/cm3', Glacr_pk_den)/=0 ) CALL read_error(3, 'glacr_pk_den') + + ALLOCATE ( Glacr_tcal(Nhru) ) + IF ( declvar(MODNAME, 'glacr_tcal', 'nhru', Nhru, 'real', & + & 'Net icepack energy balance on each glacier HRU', & + & 'Langleys', Glacr_tcal)/=0 ) CALL read_error(3, 'glacr_tcal') + + ALLOCATE ( Glacr_albedo(Nhru) ) + IF ( declvar(MODNAME, 'glacr_albedo', 'nhru', Nhru, 'real', & + & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier HRU', & + & 'decimal fraction', Glacr_albedo)/=0 ) CALL read_error(3, 'glacr_albedo') + + ALLOCATE ( Glacr_evap(Nhru) ) + IF ( declvar(MODNAME, 'glacr_evap', 'nhru', Nhru, 'real', & + & 'Evaporation and sublimation from icepack on each glacier HRU', & + & 'inches', Glacr_evap)/=0 ) CALL read_error(3, 'glacr_evap') + + ALLOCATE ( Glacrmelt(Nhru) ) + IF ( declvar(MODNAME, 'glacrmelt', 'nhru', Nhru, 'real', & + & 'Melt from icepack on each glacier HRU, includes rain water that does not absorb', & + & 'inches', Glacrmelt)/=0 ) CALL read_error(3, 'glacrmelt') + + ALLOCATE ( Glacr_pkwater_equiv(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pkwater_equiv', 'nhru', Nhru, 'double', & + & 'Icepack water equivalent on each glacier HRU', & + & 'inches', Glacr_pkwater_equiv)/=0 ) CALL read_error(3, 'glacr_pkwater_equiv') + + ALLOCATE ( Glacr_pkwater_ante(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pkwater_ante', 'nhru', Nhru, 'double', & + & 'Antecedent icepack water equivalent on each glacier HRU', & + & 'inches', Glacr_pkwater_ante)/=0 ) CALL read_error(3, 'glacr_pkwater_ante') + + ALLOCATE ( Glacrcov_area(Nhru) ) + IF ( declvar(MODNAME, 'glacrcov_area', 'nhru', Nhru, 'real', & + & 'Ice-covered area on each glacier HRU or HRU with snow field at start of step', & + & 'decimal fraction', Glacrcov_area)/=0 ) CALL read_error(3, 'glacrcov_area') + + ALLOCATE ( Glacr_pk_ice(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_ice', 'nhru', Nhru, 'real', & + & 'Storage of frozen water in the icepack on each glacier HRU', & + & 'inches', Glacr_pk_ice)/=0 ) CALL read_error(3, 'glacr_pk_ice') + + ALLOCATE ( Glacr_freeh2o(Nhru) ) + IF ( declvar(MODNAME, 'glacr_freeh2o', 'nhru', Nhru, 'real', & + & 'Storage of free liquid water in the icepack on each glacier HRU', & + & 'inches', Glacr_freeh2o)/=0 ) CALL read_error(3, 'glacr_freeh2o') + + ALLOCATE ( Glacr_pk_depth(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_depth', 'nhru', Nhru, 'double', & + & 'Depth of icepack on each glacier HRU, make essentially infinite', & + & 'inches', Glacr_pk_depth)/=0 ) CALL read_error(3, 'glacr_pk_depth') + + ALLOCATE ( Glacr_pss(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pss', 'nhru', Nhru, 'double', & + & 'Previous glacier pack water equivalent plus new ice', & + & 'inches', Glacr_pss)/=0 ) CALL read_error(3, 'glacr_pss') + + ALLOCATE ( Glacr_pst(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pst', 'nhru', Nhru, 'double', & + & 'While a icepack exists, glacr_pst tracks the maximum ice water equivalent of that icepack', & + & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') + + IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & + & 'Basin area-weighted average snow and glacier and snowfld covered area', & + & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') + + ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) + IF ( declparam(MODNAME, 'glacr_freeh2o_cap', 'nhru', 'real', & + & '0.002', '0.0', '0.01', & + & 'Free-water holding capacity of glacier ice', & + & 'Free-water holding capacity of glacier ice expressed as a' // & + & ' decimal fraction of the frozen water content of the glacier ice (glacr_pk_ice)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacr_freeh2o_cap') + + ALLOCATE ( Glacr_layer(Nhru) ) + IF ( declparam(MODNAME, 'glacr_layer', 'nhru', 'real', & + & '3.94', '0.0', '590.6', & + & 'Active layer on glacier', & + & 'Active layer is 0 to 15 m (590.6 inches) thick at start of year, when' // & + & ' melts will set daily glacr_pk_temp to 0', & + & 'inches')/=0 ) CALL read_error(1, 'glacr_layer') + + IF ( Init_vars_from_file==0 ) THEN + ALLOCATE ( Glacier_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') + + ALLOCATE ( Snowfld_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'snowfld_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Initial fraction of snow field (too small for glacier dynamics)', & + & 'Initial fraction of snow field (too small for glacier dynamics)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'snowfld_frac_init') + + ENDIF + ENDIF + IF ( declvar(MODNAME, 'basin_snowdepth', 'one', 1, 'double', & & 'Basin area-weighted average snow depth', & & 'inches', Basin_snowdepth)/=0 ) CALL read_error(3, 'basin_snowdepth') @@ -180,15 +360,15 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Snowmelt(Nhru) ) IF ( declvar(MODNAME, 'snowmelt', 'nhru', Nhru, 'real', & - & 'Snowmelt from snowpack on each HRU', & + & 'Snowmelt from snowpack on each HRU (not including snow on glacier)', & & 'inches', Snowmelt)/=0 ) CALL read_error(3, 'snowmelt') IF ( declvar(MODNAME, 'basin_snowmelt', 'one', 1, 'double', & - & 'Basin area-weighted average snowmelt', & + & 'Basin area-weighted average snowmelt (not on including snow on glacier)', & & 'inches', Basin_snowmelt)/=0 ) CALL read_error(3, 'basin_snowmelt') IF ( declvar(MODNAME, 'basin_pweqv', 'one', 1, 'double', & - & 'Basin area-weighted average snowpack water equivalent', & + & 'Basin area-weighted average snowpack water equivalent not including glacier', & & 'inches', Basin_pweqv)/=0 ) CALL read_error(3, 'basin_pweqv') ALLOCATE ( Pkwater_ante(Nhru) ) @@ -202,13 +382,21 @@ INTEGER FUNCTION snodecl() & 'decimal fraction', Snowcov_area)/=0 ) CALL read_error(3, 'snowcov_area') IF ( declvar(MODNAME, 'basin_snowevap', 'one', 1, 'double', & - & 'Basin area-weighted average evaporation and sublimation from snowpack', & + & 'Basin area-weighted average evaporation and sublimation not including glacier', & & 'inches', Basin_snowevap)/=0 ) CALL read_error(3, 'basin_snowevap') IF ( declvar(MODNAME, 'basin_snowcov', 'one', 1, 'double', & & 'Basin area-weighted average snow-covered area', & & 'decimal fraction', Basin_snowcov)/=0 ) CALL read_error(3, 'basin_snowcov') + IF ( declvar(MODNAME, 'basin_glacrb_melt', 'one', 1, 'double', & + & 'Basin area-weighted average basal melt of glacier, goes to soil', & + & 'inches', Basin_glacrb_melt)/=0 ) CALL read_error(3, 'basin_glacrb_melt') + + IF ( declvar(MODNAME, 'basin_glacrevap', 'one', 1, 'double', & + & 'Basin area-weighted average glacier ice evaporation and sublimation', & + & 'inches', Basin_glacrevap)/=0 ) CALL read_error(3, 'basin_glacrevap') + !rpayn commented ALLOCATE ( Pptmix_nopack(Nhru) ) IF ( declvar(MODNAME, 'pptmix_nopack', 'nhru', Nhru, 'integer', & @@ -309,6 +497,22 @@ INTEGER FUNCTION snodecl() & 'decimal fraction', Frac_swe)/=0 ) CALL read_error(3, 'frac_swe') ! declare parameters + IF ( Glacier_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Albedo_coef(Nhru) ) + IF ( declparam(MODNAME, 'albedo_coef', 'nhru', 'real', & + & '0.137', '0.1', '0.3', & + & 'Coefficient in calculation of ice albedo', & + & 'Coefficient in calculation of ice albedo', & + & 'none')/=0 ) CALL read_error(1, 'albedo_coef') + + ALLOCATE ( Albedo_ice(Nhru) ) + IF ( declparam(MODNAME, 'albedo_ice', 'nhru', 'real', & + & '0.344', '0.2', '0.6', & + & 'Ice albedo 300 meters below ELA', & + & 'Ice albedo 300 meters below ELA', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo_ice') + ENDIF + IF ( declparam(MODNAME, 'den_init', 'one', 'real', & & '0.10', '0.01', '0.5', & & 'Initial density of new-fallen snow', & @@ -453,16 +657,19 @@ END FUNCTION snodecl !*********************************************************************** INTEGER FUNCTION snoinit() USE PRMS_SNOW - USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file - USE PRMS_BASIN, ONLY: Basin_area_inv, Hru_route_order, Active_hrus, Hru_area_dble - USE PRMS_FLOWVARS, ONLY: Pkwater_equiv + USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag + USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_route_order, Active_hrus, Hru_area_dble, & + & FEET2METERS, Elev_units, Hru_type +! USE PRMS_BASIN, ONLY: Hru_elev_feet + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Snowfld_frac, Alt_above_ela IMPLICIT NONE ! Functions - INTRINSIC :: DBLE, SNGL + INTRINSIC :: DBLE, ATAN, SNGL INTEGER, EXTERNAL :: getparam EXTERNAL :: read_error, snowcomp_restart, sca_deplcrv ! Local Variables INTEGER :: i, j + REAL :: reduce ! Save Variables REAL, SAVE :: acum_init(MAXALB), amlt_init(MAXALB) DATA acum_init/.80, .77, .75, .72, .70, .69, .68, .67, .66, .65, .64, .63, .62, .61, .60/ @@ -472,6 +679,14 @@ INTEGER FUNCTION snoinit() IF ( Init_vars_from_file>0 ) CALL snowcomp_restart(1) + IF ( Glacier_flag==1 ) THEN + IF ( getparam(MODNAME, 'glacr_freeh2o_cap', Nhru, 'real', Glacr_freeh2o_cap)/=0 ) CALL read_error(2, 'glacr_freeh2o_cap') + IF ( getparam(MODNAME, 'albedo_ice', Nhru, 'real', Albedo_ice)/=0 ) CALL read_error(2, 'albedo_ice') + IF ( getparam(MODNAME, 'albedo_coef', Nhru, 'real', Albedo_coef)/=0 ) CALL read_error(2, 'albedo_coef') + IF ( getparam(MODNAME, 'glacr_layer', Nhru, 'real', Glacr_layer)/=0 ) CALL read_error(2, 'glacr_layer') + + ENDIF + IF ( getparam(MODNAME, 'den_init', 1, 'real', Den_init)/=0 ) CALL read_error(2, 'den_init') Deninv = 1.0D0/DBLE(Den_init) IF ( getparam(MODNAME, 'den_max', 1, 'real', Den_max)/=0 ) CALL read_error(2, 'den_max') @@ -518,6 +733,7 @@ INTEGER FUNCTION snoinit() Basin_pweqv = 0.0D0 Basin_snowdepth = 0.0D0 Basin_snowcov = 0.0D0 + Basin_snowicecov = 0.0D0 DO j = 1, Active_hrus i = Hru_route_order(j) Pkwater_equiv(i) = DBLE( Snowpack_init(i) ) @@ -542,7 +758,42 @@ INTEGER FUNCTION snoinit() Pkwater_ante = Pkwater_equiv Pss = Pkwater_equiv Pst = Pkwater_equiv + + IF ( Glacier_flag==1 ) THEN ! do here when not a restart simulation + IF ( getparam(MODNAME, 'glacier_frac_init', Nhru, 'real', Glacier_frac_init)/=0 ) CALL read_error(2, 'glacier_frac_init') + Glacr_albedo = 0.0 + Glacier_frac = Glacier_frac_init + IF ( getparam(MODNAME, 'snowfld_frac_init', Nhru, 'real', Snowfld_frac_init)/=0 ) CALL read_error(2, 'snowfld_frac_init') + Snowfld_frac = Snowfld_frac_init + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Glacier_frac(i)>0.0 ) THEN + IF ( Hru_type(i)==4 ) THEN + IF ( Elev_units==0 ) THEN !from Oerlemans 1992 + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)*FEET2METERS+300.0)/200.0 ) + ELSE + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) + ENDIF + ELSE + PRINT *, 'Warning, glacier_frac > 0, but hru_type not equal to 4, glacier_frac set to 0' + PRINT *, 'in HRU ', i, 'glacier_frac_init = ',Glacier_frac_init(i) + Glacier_frac(i) = 0.0 + ENDIF + ENDIF + IF ( Snowfld_frac(i)>0.0 ) THEN + IF ( Hru_type(i)==1 ) THEN + Glacr_albedo(i) = Albedo_ice(i) + ELSE + PRINT *, 'Warning, snowfld_frac > 0, but hru_type not equal to 1, snowfld_frac set to 0' + PRINT *, 'in HRU ', i, 'snowfld_frac_init = ',Snowfld_frac_init(i) + Snowfld_frac(i) = 0.0 + ENDIF + ENDIF + ENDDO + DEALLOCATE ( Glacier_frac_init ) + ENDIF ENDIF + IF ( Init_vars_from_file>0 ) RETURN Basin_tcal = 0.0D0 Iasw = 0 @@ -564,6 +815,52 @@ INTEGER FUNCTION snoinit() Basin_snowevap = 0.0D0 Basin_pk_precip = 0.0D0 + Yrdays5 = 0 + Basin_glacrb_melt = 0.0D0 + Basin_glacrevap = 0.0D0 + IF ( Glacier_flag==1 ) THEN + Alt_above_ela = 0.0 + Glacr_air_avtemp = 0.0 + Glacr_air_5avtemp = 0.0 + Glacr_air_5avtemp1 = 0.0 + Glacr_air_deltemp = 0.0 + Glacr_5avsnow = 0.0 + Glacr_5avsnow1 = 0.0 + Glacr_delsnow = 0.0 + Glacrb_melt = 0.0 + Glacrmelt = 0.0 + Glacr_tcal = 0.0 + Glacr_pk_den = 0.917 + Glacr_pk_temp = 0.0 + Glacr_pk_def = 0.0 + Glacr_pkwater_equiv = 0.0D0 + Glacr_evap = 0.0 + Glacr_freeh2o = 0.0 + Glacr_pk_depth = 0.0D0 + Glacr_pst = 0.0D0 + Glacr_pss = 0.0D0 + Glacrcov_area = 0.0 + Glacr_freeh2o_capm = Glacr_freeh2o_cap + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Glacier_frac(i)>0.0 ) THEN + IF ( Hru_type(i)==4 ) THEN + Glacr_pk_depth(i) = DBLE(Glacr_layer(i)) + reduce = 0.8 !if start Glacr_pk_ice too close to Glacr_pk_depth can't grow with energy loss to free water gain + IF ( Glacr_layer(i)==0.0 ) THEN + Glacr_pk_depth(i) = 1.0D5 + Glacr_freeh2o_capm(i) = 0.0 + reduce = 1.0 + ENDIF + Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) + ENDIF + ENDIF + Glacr_pk_ice(i) = reduce*(SNGL(Glacr_pkwater_equiv(i)) - Glacr_freeh2o(i))/0.9340 !density of pure ice + ENDDO + Glacr_pkwater_ante = Glacr_pkwater_equiv + Glacr_pss = Glacr_pkwater_equiv + ENDIF + END FUNCTION snoinit !*********************************************************************** @@ -571,21 +868,22 @@ END FUNCTION snoinit !*********************************************************************** INTEGER FUNCTION snorun() USE PRMS_SNOW - USE PRMS_MODULE, ONLY: Nhru, Print_debug + USE PRMS_MODULE, ONLY: Nhru, Print_debug, Glacier_flag, Starttime USE PRMS_BASIN, ONLY: DNEARZERO, Hru_area, Active_hrus, Hru_type, & - & Basin_area_inv, Hru_route_order, Cov_type + & Basin_area_inv, Hru_route_order, Cov_type, INCH2M, FEET2METERS, Elev_units USE PRMS_CLIMATEVARS, ONLY: Newsnow, Pptmix, Orad, Basin_horad, Potet_sublim, & & Hru_ppt, Prmx, Tmaxc, Tminc, Tavgc, Swrad, Potet, Transp_on, Tmax_allsnow_c - USE PRMS_FLOWVARS, ONLY: Pkwater_equiv - USE PRMS_SET_TIME, ONLY: Jday, Nowmonth, Julwater + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Snowfld_frac, Alt_above_ela + USE PRMS_SET_TIME, ONLY: Jday, Nowmonth, Julwater, Nowyear USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Canopy_covden, Hru_intcpevap IMPLICIT NONE ! Functions - EXTERNAL ppt_to_pack, snowcov, snalbedo, snowbal, snowevap - INTRINSIC ABS, SQRT, DBLE, SNGL + EXTERNAL ppt_to_pack, snowcov, snalbedo, snowbal, snowevap, glacr_states_to_zero + INTRINSIC ABS, SQRT, DBLE, SNGL, EXP, DABS, MOD, ATAN ! Local Variables - INTEGER :: i, j, k, niteda + INTEGER :: i, j, k, niteda, isglacier REAL :: trd, sw, effk, cst, temp, cals, emis, esv, swn, cec + REAL :: ieffk, icst, icals, isw, iswn, frac DOUBLE PRECISION :: dpt1, dpt_before_settle !*********************************************************************** snorun = 0 @@ -596,13 +894,19 @@ INTEGER FUNCTION snorun() Basin_pweqv = 0.0D0 Basin_snowevap = 0.0D0 Basin_snowcov = 0.0D0 + Basin_snowicecov = 0.0D0 Basin_pk_precip = 0.0D0 Basin_snowdepth = 0.0D0 Basin_tcal = 0.0D0 + IF ( Glacier_flag==1 ) THEN + Basin_glacrb_melt = 0.0D0 + Basin_glacrevap = 0.0D0 + ENDIF ! Calculate the ratio of measured radiation to potential radiation ! (used as a cumulative indicator of cloud cover) trd = Orad/SNGL(Basin_horad) ! [dimensionless ratio] + IF ( Julwater==1 .AND. MOD(Nowyear-Starttime(1),5)==0 ) Yrdays5 = 0 ! Loop through all the active HRUs, in routing order DO j = 1, Active_hrus @@ -611,6 +915,42 @@ INTEGER FUNCTION snorun() ! Skip the HRU if it is a lake IF ( Hru_type(i)==2 ) CYCLE + Active_glacier = 0 + isglacier = 0 + IF ( Hru_type(i)==4 .OR. Hru_type(i)==1 ) THEN + IF ( Glacier_flag==1 ) THEN + Glacrmelt(i) = 0.0 ! [inches] + Glacrb_melt(i) = 0.0 ! [inches] + Glacr_evap(i) = 0.0 ! [inches] + Glacr_pkwater_ante(i) = Glacr_pkwater_equiv(i) + IF ( Glacier_frac(i)>0.0 .OR. Snowfld_frac(i)>0.0 ) THEN + IF (Glacier_frac(i)>0.0) Active_glacier = 1 + IF (Snowfld_frac(i)>0.0) Active_glacier = 2 + Glacr_pk_den(i) = 0.917 + ! if melted whole active layer make 0 deg and no holding capacity + IF ( Glacr_layer(i)==0.0 .OR. Glacr_pk_depth(i)>1.0D3 ) THEN + Glacr_pk_def(i) = 0.0 + Glacr_pk_temp(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + ENDIF + ELSE !zero out states for glacier if gone (glacier state changes in glacier module, not here) + Glacr_pkwater_equiv(i) = 0.D0 + Glacrcov_area(i) = 0.0 + Glacr_pk_def(i) = 0.0 + Glacr_pk_temp(i) = 0.0 + Glacr_pk_ice(i) = 0.0 + Glacr_freeh2o(i) = 0.0 + Glacr_pk_depth(i) = 0.D0 + Glacr_pss = 0.0D0 + Glacr_pst(i) = 0.0D0 + Glacr_pk_den(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + Glacr_albedo(i) = 0.0 + ENDIF + isglacier = 1 + ENDIF + ENDIF + ! If it's the first julian day of the water year, several ! variables need to be reset ! - reset the previous snow water eqivalent plus new snow to 0 @@ -622,6 +962,60 @@ INTEGER FUNCTION snorun() Iso(i) = 1 ! [flag] Mso(i) = 1 ! [flag] Lso(i) = 0 ! [counter] + + + IF ( Active_glacier>=1 ) CALL glacr_states_to_zero(i) !all snow on glacier becomes firn, + IF ( Active_glacier==1 ) THEN !do not zero out snowpack for snowfields because a lot is off glacier + ! snow will melt more than should on snowfields if include a lot of low elevation + ! if terminus glacier, and has snow will disappear off glacier but that is likely anyhow + Pkwater_equiv(i) = 0.0 + Pk_depth(i) = 0.0D0 + Pss(i) = 0.0D0 + Snsv(i) = 0.0 + Lst(i) = 0 + Pst(i) = 0.0D0 + Iasw(i) = 0 + Pk_den(i) = 0.0 + Snowcov_area(i) = 0.0 + Pk_def(i) = 0.0 + Pk_temp(i) = 0.0 + Pk_ice(i) = 0.0 + Freeh2o(i) = 0.0 + Snowcov_areasv(i) = 0.0 ! rsr, not in original code + Ai(i) = 0.0D0 + Frac_swe(i) = 0.0 + IF ( Elev_units==0 ) THEN !from Oerlemans 1992 + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)*FEET2METERS+300.0)/200.0 ) + ELSE + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) + ENDIF + ENDIF + IF ( Active_glacier==2 ) Glacr_albedo(i) = Albedo_ice(i) !glacr_albedo doesn't change if snow field but could get zeroed out + IF ( Nowyear >= Starttime(1)+10 .AND. MOD(Nowyear-Starttime(1),5)==0 ) THEN + Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 10 years of data + Glacr_delsnow(i) = 10.0*(Glacr_5avsnow1(i) - Glacr_5avsnow(i))/Glacr_5avsnow1(i) !number of 10 percent (*100.0/10.0) changes + ENDIF + !keep before restart + IF ( MOD(Nowyear-Starttime(1),5)==0 ) THEN + IF ( Nowyear-Starttime(1)==5 ) THEN + Glacr_air_5avtemp1(i) = Glacr_air_5avtemp(i) + Glacr_5avsnow1(i) = Glacr_5avsnow(i) + ENDIF + Glacr_air_5avtemp(i) = 0.0 !zero out for new year restart + Glacr_5avsnow(i) = 0.0 !zero out for new year restart + ENDIF + Glacr_air_avtemp(i) = 0.0 !zero out for new year restart + ENDIF !end start of year calculations + +! Do for summer + IF ( isglacier==1 .AND. Julwater>151 .AND. Julwater<244) THEN ! Now following McGrath et al 2017, temp June-August, 92 days + Yrdays5 = Yrdays5 + 1 + Glacr_air_5avtemp(i) = ( Glacr_air_5avtemp(i)*(Yrdays5-1)+ (Tminc(i)+Tavgc(i))*0.5 )/Yrdays5 + ENDIF +! Do for every time step + IF ( isglacier==1) THEN + Glacr_air_avtemp(i) = ( Glacr_air_avtemp(i)*(Julwater-1)+ (Tminc(i)+Tavgc(i))*0.5 )/Julwater + Glacr_5avsnow(i) = Glacr_5avsnow(i) + Net_snow(i)/5.0 ENDIF ! HRU SET-UP - SET DEFAULT VALUES AND/OR BASE @@ -661,8 +1055,8 @@ INTEGER FUNCTION snorun() IF ( Jday==Melt_look(i) ) Mso(i) = 2 ! [flag] !rsr10 ENDIF - ! Skip the HRU if there is no snowpack and no new snow - IF ( Pkwater_equiv(i)=1 ) THEN + IF ( Glacrcov_area(i)>0.0.AND.Glacr_pkwater_ante(i)>0.0D0.AND.Net_ppt(i)>0.0 & + & .AND.Pptmix(i)==0.AND.Net_snow(i)==0.0 ) THEN + CALL ppt_to_pack(0, Iasw(i), Tmaxc(i), Tminc(i), & + & Tavgc(i), Glacr_Pkwater_equiv(i), Net_rain(i), Glacr_pk_def(i), & + & Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), Glacrcov_area(i), & + & Glacrmelt(i), Glacr_pk_depth(i), Glacr_pss(i), Glacr_pst(i), 0.0, & + & Glacr_pk_den(i), Pptmix_nopack(i), Pk_precip(i), Tmax_allsnow_c(i,Nowmonth), Glacr_freeh2o_capm(i), i) + ENDIF + ENDIF + +! FOLLOWING does basal melt on glacier +!Paterson 2010 says 12 mm/yr for friction and geothermal heating + IF ( Active_glacier==1 ) Glacrb_melt(i) = 12.0*0.03937/365.242*Glacier_frac(i) + IF ( Active_glacier==2 ) Glacrb_melt(i) = 12.0*0.03937/365.242*Snowfld_frac(i) !since not moving much, maybe =0 ! If there is still a snowpack IF ( Pkwater_equiv(i)>0.0D0 ) THEN @@ -706,6 +1117,17 @@ INTEGER FUNCTION snorun() & Prmx(i), Pptmix(i), Albset_rnm, Net_snow(i), & & Albset_snm, Albset_rna, Albset_sna, Albedo(i), & & Int_alb(i), Salb(i), Slst(i)) + ENDIF + + IF ( Active_glacier>=1 ) THEN +! Albedo so transition snow to ice smooothly, see Oerlemans 1992, this is albedo if snowcovered ice too + Albedo(i) = Albedo(i) - (Albedo(i)-Glacr_albedo(i))*EXP(-5.0*SNGL(Pkwater_equiv(i))*INCH2M) + IF ( Albedo(i)<0.08 ) Albedo(i)=0.08 !See Brock 2000 + IF ( Albedo(i)>0.92 ) Albedo(i)=0.92 !See Brock 2000 + ENDIF + + ! If there is still a snowpack or glacier + IF ( Pkwater_equiv(i)>0.0D0 .OR. Active_glacier>=1 ) THEN ! HRU STEP 4 - DETERMINE RADIATION FLUXES AND SNOWPACK ! STATES NECESSARY FOR ENERGY BALANCE @@ -715,8 +1137,6 @@ INTEGER FUNCTION snorun() ! is no precipitation emis = Emis_noppt(i) ! [fraction of radiation] ! Could use equation from Swinbank 63 using Temp, a is -13.638, b is 6.148 - ! temparature is halfway between the minimum and average temperature for the day - !temp = (Tminc(i)+Tavgc(i))*0.5 !emis = ((temp+273.16)**(Emis_coefb-4.0))*(10.0**(Emis_coefa+1.0))/5.670373E−8 ! /by Stefan Boltzmann in SI units ! If there is any precipitation in the HRU, reset the ! emissivity to 1 @@ -747,7 +1167,7 @@ INTEGER FUNCTION snorun() ! dpt1 = Pk_depth(i) + (Net_snow(i)*Deninv) + & ! Settle_const * ((Pss(i)*Denmaxinv) - Pk_depth(i)) ! dpt1 = ((Net_snow(i)*Deninv)+ (Setden*Pss(i))+Pk_depth(i))*Set1 ! [inches] - ! RAPCOMMENT - CHANGED TO THE APPROPRIATE FINITE DIFFERENCE + ! RAPCOMMENT - CHANGED TO THE APPROPRIATE FINITE DIFFERENCE ! APPROXIMATION OF SNOW DEPTH Pk_depth(i) = dpt1 ! [inches] @@ -832,10 +1252,52 @@ INTEGER FUNCTION snorun() & Canopy_covden(i), cec, Pkwater_equiv(i), & & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & - & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i)) + & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) ! track total heat flux from both night and day periods Tcal(i) = cals ! [cal/cm^2] or [Langleys] + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0 ) THEN + iswn = Swrad(i)*(1.0-Glacr_albedo(i))*Rad_trncf(i) ! [cal/cm^2] !want bare ice albedo + ! or [Langleys] + ! Calculate the Glacier icepack density + ! + ! The effective thermal conductivity is approximated + ! (empirically) as 0.0077 times (snowpack density)^2 cal/(cm sec degC) + ! from Oke 1987 + ! ice is 2.1 W/(m degC) = 0.021 W/(cm deg C) = 0.00502 cal/(cm sec degC) + ! = 0.00597 times (0.917**2), + ! firn (old snow density .5) is closer to 0.0042 W/(cm deg C) = 0.00401 times (0.5**2) + ! Therefore, the effective + ! conductivity term (inside the square root) in the + ! equation for conductive heat exchange can be + ! calculated as follows (0.0597*pk_den^2)/(pk_den*0.5) + ! where 0.5 is the specific heat of ice [cal / (g degC)] + ! this simplifies to the following + ! might want to use 0.005*2 = 0.01 half way between if doing mix of firn and ice + ieffk = 0.01194*Glacr_pk_den(i) ! [unitless] + icst = Glacr_pk_den(i)*(SQRT(ieffk*13751.0)) ! [cal/(cm^2 degC)] + ! or [Langleys / degC] + isw = 0.0 ! [cal / cm^2] or [Langleys] + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Glacr_pkwater_equiv(i), & + & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & + & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & + & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) + ! track total heat flux from both night and day periods + IF ( Glacr_pk_depth(i)<=0.0D0 ) THEN ! make infinite and 0 deg and no freewater capacity + ! should be just 0.0 but just in case + Glacr_pk_depth(i) = 1.0D5 + Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) + Glacr_pk_ice(i) = SNGL(Glacr_pkwater_equiv(i)-Glacr_freeh2o(i))/0.9340 !density of pure ice + Glacr_pk_temp(i) = 0.0 + Glacr_pk_def(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + ENDIF + ENDIF + ENDIF + ! Compute energy balance for day period (if the snowpack ! still exists) IF ( Pkwater_equiv(i)>0.0D0 ) THEN @@ -851,10 +1313,35 @@ INTEGER FUNCTION snorun() & Canopy_covden(i), cec, Pkwater_equiv(i), & & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & - & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i)) + & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) ! track total heat flux from both night and day periods Tcal(i) = Tcal(i) + cals ! [cal/cm^2] or [Langleys] ENDIF + ! Compute energy balance for day period (if glacier exists) + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0 ) THEN + ! set shortwave radiation as calculated earlier + isw = iswn ! [cal/cm^2] or [Langleys] + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Glacr_pkwater_equiv(i), & + & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & + & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & + & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) + ! track total heat flux from both night and day periods + if(isnan(Glacrmelt(i)).OR. abs(Glacrmelt(i))>1.e15) & + Glacr_tcal(i) = Glacr_tcal(i) + icals ! [cal/cm^2] or [Langleys] + IF ( Glacr_pk_depth(i)<=0.0D0 ) THEN ! make infinite and 0 deg and no freewater capacity + ! should be just 0.0 but just in case + Glacr_pk_depth(i) = 1.0D5 + Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) + Glacr_pk_ice(i) = SNGL(Glacr_pkwater_equiv(i))*0.9340 !density of pure ice + Glacr_pk_temp(i) = 0.0 + Glacr_pk_def(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + ENDIF + ENDIF + ENDIF ! HRU STEP 5 - CALCULATE SNOWPACK LOSS TO EVAPORATION !******************************************************** @@ -878,6 +1365,12 @@ INTEGER FUNCTION snorun() ENDIF Pkwater_equiv(i) = 0.0D0 ! just to be sure negative values are ignored ENDIF + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>NEARZERO ) & + & CALL snowevap(Potet_sublim(i), Potet(i), Glacrcov_area(i), & + & Glacr_evap(i), Glacr_pkwater_equiv(i), Glacr_pk_ice(i), & + & Glacr_pk_def(i), Glacr_freeh2o(i), Glacr_pk_temp(i), Hru_intcpevap(i)) + ENDIF ! HRU CLEAN-UP - ADJUST FINAL HRU SNOWPACK STATES AND ! INCREMENT THE BASIN TOTALS @@ -935,15 +1428,34 @@ INTEGER FUNCTION snorun() Ai(i) = 0.0D0 Frac_swe(i) = 0.0 ENDIF + IF ( Active_glacier>=1 ) THEN + IF ( Glacr_pkwater_equiv(i)>0.0D0 ) THEN + Glacr_pk_depth(i) = Glacr_pkwater_equiv(i)/DBLE(Glacr_pk_den(i)) + ELSE + Glacr_pk_depth(i) = 1.0D5 + Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) + Glacr_pk_ice(i) = SNGL(Glacr_pkwater_equiv(i)-Glacr_freeh2o(i))/0.9340 !density of pure ice + Glacr_pk_temp(i) = 0.0 + Glacr_pk_def(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + ENDIF + ENDIF + frac = 1.0 + IF ( Active_glacier==1 ) frac = (1.0 - Glacier_frac(i)) + IF ( Active_glacier==2 ) frac = (1.0 - Snowfld_frac(i)) ! Sum volumes for basin totals - Basin_snowmelt = Basin_snowmelt + DBLE( Snowmelt(i)*Hru_area(i) ) - Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*DBLE(Hru_area(i)) - Basin_snowevap = Basin_snowevap + DBLE( Snow_evap(i)*Hru_area(i) ) + Basin_snowmelt = Basin_snowmelt + DBLE( Snowmelt(i)*Hru_area(i)*frac ) !don't include stuff melting into glacier + Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*DBLE( Hru_area(i)*frac ) !don't include stuff melting into glacier + Basin_snowevap = Basin_snowevap + DBLE( Snow_evap(i)*Hru_area(i)*frac ) !don't include stuff melting into glacier Basin_snowcov = Basin_snowcov + DBLE( Snowcov_area(i)*Hru_area(i) ) Basin_pk_precip = Basin_pk_precip + DBLE( Pk_precip(i)*Hru_area(i) ) Basin_snowdepth = Basin_snowdepth + Pk_depth(i)*DBLE(Hru_area(i)) Basin_tcal = Basin_tcal + DBLE( Tcal(i)*Hru_area(i) ) + IF ( Active_glacier>=1 ) THEN + Basin_glacrb_melt = Basin_glacrb_melt + Glacrb_melt(i)*Hru_area(i) + Basin_glacrevap = Basin_glacrevap + Glacr_evap(i)*Hru_area(i) + ENDIF ENDDO @@ -952,9 +1464,15 @@ INTEGER FUNCTION snorun() Basin_pweqv = Basin_pweqv*Basin_area_inv Basin_snowevap = Basin_snowevap*Basin_area_inv Basin_snowcov = Basin_snowcov*Basin_area_inv + Basin_snowicecov = Basin_snowcov Basin_pk_precip = Basin_pk_precip*Basin_area_inv Basin_snowdepth = Basin_snowdepth*Basin_area_inv Basin_tcal = Basin_tcal*Basin_area_inv + IF ( Glacier_flag==1 ) THEN + Basin_glacrb_melt = Basin_glacrb_melt*Basin_area_inv + Basin_glacrevap = Basin_glacrevap*Basin_area_inv + ENDIF + IF ( Print_debug==9 ) THEN PRINT 9001, Jday, (Net_rain(i), i=1, Nhru) @@ -972,14 +1490,14 @@ END FUNCTION snorun SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & & Pkwater_equiv, Net_rain, Pk_def, Pk_temp, Pk_ice, & & Freeh2o, Snowcov_area, Snowmelt, Pk_depth, Pss, Pst, & - & Net_snow, Pk_den, Pptmix_nopack, Pk_precip, Tmax_allsnow_c, Freeh2o_cap) + & Net_snow, Pk_den, Pptmix_nopack, Pk_precip, Tmax_allsnow_c, Freeh2o_cap, Ihru_gl) USE PRMS_BASIN, ONLY: CLOSEZERO, INCH2CM !, DNEARZERO IMPLICIT NONE REAL, EXTERNAL :: f_to_c EXTERNAL calin INTRINSIC ABS, DBLE, SNGL ! Arguments - INTEGER, INTENT(IN) :: Pptmix + INTEGER, INTENT(IN) :: Pptmix, Ihru_gl INTEGER, INTENT(INOUT) :: Iasw, Pptmix_nopack REAL, INTENT(IN) :: Tmaxc, Tminc, Tavgc, Net_rain, Net_snow REAL, INTENT(IN) :: Freeh2o_cap, Tmax_allsnow_c @@ -1020,7 +1538,7 @@ SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & ENDIF ! (2) If precipitation is all snow or all rain... - ELSE + ELSE ! on glacier ice goes in here only ! If there is any rain, the rain temperature is the average ! temperature train = Tavgc ! [degrees C] @@ -1047,7 +1565,7 @@ SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & ! (1) If there is net rain on an existing snowpack... IF ( Pkwater_equiv>0.0D0 ) THEN - IF ( Net_rain>0.0 ) THEN + IF ( Net_rain>0.0 ) THEN ! on glacier ice goes in here only ! Add rain water to pack (rain on snow) and increment the ! precipitation on the snowpack by the rain water Pkwater_equiv = Pkwater_equiv + DBLE(Net_rain) ! [inches] @@ -1131,11 +1649,12 @@ SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & ! pack ice when the water cools to 0 degC) CALL calin(calpr, Pkwater_equiv, Pk_def, Pk_temp, & & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & - & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap) + & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) ENDIF ! (1.2) Rain on snowpack that is isothermal ! at 0 degC (no heat deficit)... + ! on glacier ice not active_layer goes in here only, as Pk_def, pndz = 0, ELSE ! All net rain is added to free water in the snowpack Freeh2o = Freeh2o + Net_rain @@ -1147,7 +1666,7 @@ SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & ! the water cools to 0 degC) CALL calin(calpr, Pkwater_equiv, Pk_def, Pk_temp, & & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & - & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap) + & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) ENDIF ENDIF @@ -1199,7 +1718,7 @@ SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & ! (2.1) if there is free water in the pack ! (at least some of it is going to freeze)... IF ( Freeh2o>0.0 ) THEN - CALL caloss(calps, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o) + CALL caloss(calps, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) ! (2.2) if there is no free water (snow pack has a ! heat deficit greater than or equal to 0)... @@ -1219,14 +1738,17 @@ END SUBROUTINE ppt_to_pack ! Subroutine to compute change in snowpack when a net loss in ! heat energy has occurred. !*********************************************************************** - SUBROUTINE caloss(Cal, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o) + SUBROUTINE caloss(Cal, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) USE PRMS_BASIN, ONLY: CLOSEZERO !, DNEARZERO IMPLICIT NONE INTRINSIC SNGL ! Arguments + INTEGER, INTENT(IN) :: Ihru_gl REAL, INTENT(IN) :: Cal DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv REAL, INTENT(INOUT) :: Pk_def, Pk_ice, Freeh2o, Pk_temp +! Functions + EXTERNAL glacr_states_to_zero ! Local Variables REAL :: calnd, dif !*********************************************************************** @@ -1284,6 +1806,9 @@ SUBROUTINE caloss(Cal, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o) ! IF ( Pkwater_equiv<-DNEARZERO ) & ! & PRINT *, 'snowpack issue 4, negative pkwater_equiv', Pkwater_equiv Pkwater_equiv = 0.0D0 + ! Snowpack or glacr layer has been completely depleted, reset all states to no-snowpack values + ! If melting glacier can still be snow, Ihru_gl >0 signifies glacier caloss + If (Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl) ENDIF END SUBROUTINE caloss @@ -1294,12 +1819,13 @@ END SUBROUTINE caloss !*********************************************************************** SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & - & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap) - USE PRMS_SNOW, ONLY: Denmaxinv, Den_max + & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) + USE PRMS_SNOW, ONLY: Denmaxinv, Den_max, Active_glacier USE PRMS_MODULE, ONLY: Print_debug + USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO IMPLICIT NONE ! Arguments - INTEGER, INTENT(INOUT) :: Iasw + INTEGER, INTENT(IN) :: Iasw, Ihru_gl REAL, INTENT(IN) :: Cal, Freeh2o_cap, Snowcov_area REAL, INTENT(INOUT) :: Freeh2o DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv @@ -1307,7 +1833,7 @@ SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & DOUBLE PRECISION, INTENT(INOUT) :: Pss, Pst, Pk_depth ! Functions INTRINSIC SNGL, DBLE - EXTERNAL :: print_date + EXTERNAL :: print_date, glacr_states_to_zero ! Local Variables REAL :: dif, pmlt, apmlt, apk_ice, pwcap DOUBLE PRECISION :: dif_dble @@ -1367,8 +1893,17 @@ SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & ! 2 options below (if-then, else) ! (3.1) Heat applied to snow covered area is sufficient - ! to melt all the ice in that snow pack - IF ( pmlt>apk_ice ) THEN + ! to melt all the ice in that snow pack... + ! if on snow over glacier or active_layer and have excess energy from day over + ! depth can melt from layer thickness, add depth to that layer + IF ( pmlt>apk_ice .AND. Active_glacier>=1 ) THEN + apk_ice = pmlt + Pk_ice = apk_ice*Snowcov_area + Pkwater_equiv = Freeh2o + apmlt - Freeh2o_cap*(Pk_ice - apmlt) + Pk_depth = 0.0D0 + ENDIF + + IF ( pmlt>apk_ice ) THEN ! will not happen if Active_glacier>=1 because of above ! All pack water equivalent becomes meltwater Snowmelt = Snowmelt + SNGL( Pkwater_equiv ) ! [inches] Pkwater_equiv = 0.0D0 ! [inches] @@ -1384,7 +1919,7 @@ SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & Pst = 0.0D0 ! [inches] Pk_den = 0.0 ! [fraction of depth] - ! (3.2) Heat only melts part of the ice in the snow pack + ! (3.2) Heat only melts part of the ice in the snow pack... ELSE ! Remove actual melt from frozen water and add melt to ! free water @@ -1417,7 +1952,7 @@ SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & PRINT *, 'snow density problem', Pk_depth, Pk_den, Pss, Pkwater_equiv CALL print_date(1) ENDIF - Pk_den = Den_max + IF ( Active_glacier==0 ) Pk_den = Den_max Pk_depth = Pkwater_equiv*Denmaxinv ! [inches] ENDIF @@ -1434,6 +1969,8 @@ SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & Pk_temp = 0.0 ! [degrees C] Pk_def = 0.0 ! [cal/cm^2] ENDIF + IF ( Pkwater_equiv<=0.0D0 .AND. Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl) + ! Snowpack on glacier has been completely depleted, reset all states to no-snowpack values END SUBROUTINE calin @@ -1705,13 +2242,13 @@ END SUBROUTINE snalbedo SUBROUTINE snowbal(Niteda, Tstorm_mo, Iasw, Temp, Esv, Hru_ppt, & & Trd, Emis_noppt, Canopy_covden, Cec, Pkwater_equiv, & & Pk_def, Pk_temp, Pk_ice, Freeh2o, Snowcov_area, & - & Snowmelt, Pk_depth, Pss, Pst, Pk_den, Cst, Cal, Sw, Freeh2o_cap) + & Snowmelt, Pk_depth, Pss, Pst, Pk_den, Cst, Cal, Sw, Freeh2o_cap, Ihru_gl) USE PRMS_BASIN, ONLY: CLOSEZERO IMPLICIT NONE INTRINSIC SNGL EXTERNAL calin, caloss ! Arguments - INTEGER, INTENT(IN) :: Niteda, Tstorm_mo + INTEGER, INTENT(IN) :: Niteda, Tstorm_mo, Ihru_gl INTEGER, INTENT(INOUT) :: Iasw REAL, INTENT(IN) :: Temp, Esv, Trd, Cec, Cst, Canopy_covden REAL, INTENT(IN) :: Emis_noppt, Sw, Freeh2o_cap @@ -1823,7 +2360,7 @@ SUBROUTINE snowbal(Niteda, Tstorm_mo, Iasw, Temp, Esv, Hru_ppt, & IF ( Cal>0.0 ) THEN CALL calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & - & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap) + & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) RETURN ENDIF ENDIF @@ -1864,7 +2401,7 @@ SUBROUTINE snowbal(Niteda, Tstorm_mo, Iasw, Temp, Esv, Hru_ppt, & Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] ELSE ! remove heat from the snowpack - CALL caloss(qcond, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o) + CALL caloss(qcond, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) ENDIF ! Even though Cal is not applied to the snowpack under this ! condition, it maintains its value and the referencing code @@ -1886,7 +2423,7 @@ SUBROUTINE snowbal(Niteda, Tstorm_mo, Iasw, Temp, Esv, Hru_ppt, & ! will have terminated IF ( Cal>0.0 ) CALL calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & & Pk_ice, Freeh2o, Snowcov_area, & - & Snowmelt, Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap) + & Snowmelt, Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) ENDIF ! (3) conduction is from the surface to the snowpack and the @@ -1954,7 +2491,8 @@ END SUBROUTINE snowbal ! Subroutine to compute evaporation from snowpack !*********************************************************************** SUBROUTINE snowevap(Potet_sublim, Potet, Snowcov_area, Snow_evap, & - & Pkwater_equiv, Pk_ice, Pk_def, Freeh2o, Pk_temp, Hru_intcpevap) + & Pkwater_equiv, Pk_ice, Freeh2o, Pk_def, Pk_temp, Hru_intcpevap) + USE PRMS_SNOW, ONLY: Active_glacier USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO USE PRMS_MODULE, ONLY: Print_debug IMPLICIT NONE @@ -1963,7 +2501,7 @@ SUBROUTINE snowevap(Potet_sublim, Potet, Snowcov_area, Snow_evap, & REAL, INTENT(IN) :: Potet_sublim, Potet, Snowcov_area, Hru_intcpevap REAL, INTENT(INOUT) :: Pk_ice, Pk_def, Pk_temp DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv - REAL, INTENT(OUT) :: Snow_evap, Freeh2o + REAL, INTENT(OUT) :: Snow_evap ! Local Variables REAL :: avail_et, cal, ez !*********************************************************************** @@ -1978,6 +2516,9 @@ SUBROUTINE snowevap(Potet_sublim, Potet, Snowcov_area, Snow_evap, & ! 3 options below (if-then, elseif, else) ! (1) There is no potential for evaporation... + ! if on snow over glacier or active_layer and have excess energy from day over + ! depth can evap from layer thickness, add depth to that layer + IF ( ez>Pkwater_equiv .AND. Active_glacier>=1 ) Pkwater_equiv = DBLE(ez) IF ( ez 0.0) Glacr_pk_temp(Ihru) = 0.0 + IF ( Glacr_layer(Ihru)==0.0 ) THEN + Glacr_pk_depth(Ihru) = 1.0D5 + Glacr_pk_temp(Ihru) = 0.0 + Glacr_pk_def(Ihru) = 0.0 + Glacr_freeh2o_capm(Ihru) = 0.0 + reduce = 1.0 + ENDIF + Glacr_pkwater_equiv(Ihru) = Glacr_pk_den(Ihru)*Glacr_pk_depth(Ihru) + Glacr_pkwater_ante(Ihru) = Glacr_pkwater_equiv(Ihru) + Glacr_pk_ice(Ihru) = reduce*SNGL(Glacr_pkwater_equiv(Ihru)-Glacr_freeh2o(Ihru))/0.9340 !density of pure ice + Glacr_pss(Ihru) = Glacr_pkwater_equiv(Ihru) + + END SUBROUTINE glacr_states_to_zero + !*********************************************************************** ! snowcomp_restart - write or read snowcomp restart file !*********************************************************************** SUBROUTINE snowcomp_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Glacier_flag USE PRMS_SNOW IMPLICIT NONE ! Argument @@ -2300,7 +2875,8 @@ SUBROUTINE snowcomp_restart(In_out) IF ( In_out==0 ) THEN WRITE ( Restart_outunit ) MODNAME WRITE ( Restart_outunit ) Deninv, Denmaxinv, Basin_snowmelt, Basin_pweqv, Basin_snowcov, & - & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal + & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal, Basin_glacrb_melt, & + & Basin_snowicecov, Basin_glacrevap WRITE ( Restart_outunit ) Int_alb WRITE ( Restart_outunit ) Scrv WRITE ( Restart_outunit ) Pksv @@ -2324,11 +2900,34 @@ SUBROUTINE snowcomp_restart(In_out) WRITE ( Restart_outunit ) Snsv WRITE ( Restart_outunit ) Pk_depth WRITE ( Restart_outunit ) Pkwater_ante + IF ( Glacier_flag==1 ) THEN + WRITE ( Restart_outunit ) Glacrmelt + WRITE ( Restart_outunit ) Glacr_evap + WRITE ( Restart_outunit ) Glacr_albedo + WRITE ( Restart_outunit ) Glacr_pk_den + WRITE ( Restart_outunit ) Glacr_pk_ice + WRITE ( Restart_outunit ) Glacr_freeh2o + WRITE ( Restart_outunit ) Glacrcov_area + WRITE ( Restart_outunit ) Glacr_tcal + WRITE ( Restart_outunit ) Glacr_pss + WRITE ( Restart_outunit ) Glacr_pst + WRITE ( Restart_outunit ) Glacr_pk_depth + WRITE ( Restart_outunit ) Glacr_pkwater_equiv + WRITE ( Restart_outunit ) Glacr_pkwater_ante + WRITE ( Restart_outunit ) Glacr_pk_temp + WRITE ( Restart_outunit ) Glacr_air_avtemp, Yrdays5 + WRITE ( Restart_outunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp + WRITE ( Restart_outunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow + WRITE ( Restart_outunit ) Glacr_pk_def + WRITE ( Restart_outunit ) Glacrb_melt + WRITE ( Restart_outunit ) Glacr_freeh2o_capm + ENDIF ELSE READ ( Restart_inunit ) module_name CALL check_restart(MODNAME, module_name) READ ( Restart_inunit ) Deninv, Denmaxinv, Basin_snowmelt, Basin_pweqv, Basin_snowcov, & - & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal + & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal, Basin_glacrb_melt, & + & Basin_snowicecov, Basin_glacrevap READ ( Restart_inunit ) Int_alb READ ( Restart_inunit ) Scrv READ ( Restart_inunit ) Pksv @@ -2352,5 +2951,27 @@ SUBROUTINE snowcomp_restart(In_out) READ ( Restart_inunit ) Snsv READ ( Restart_inunit ) Pk_depth READ ( Restart_inunit ) Pkwater_ante + IF ( Glacier_flag==1 ) THEN + READ ( Restart_inunit ) Glacrmelt + READ ( Restart_inunit ) Glacr_evap + READ ( Restart_inunit ) Glacr_albedo + READ ( Restart_inunit ) Glacr_pk_den + READ ( Restart_inunit ) Glacr_pk_ice + READ ( Restart_inunit ) Glacr_freeh2o + READ ( Restart_inunit ) Glacrcov_area + READ ( Restart_inunit ) Glacr_tcal + READ ( Restart_inunit ) Glacr_pss + READ ( Restart_inunit ) Glacr_pst + READ ( Restart_inunit ) Glacr_pk_depth + READ ( Restart_inunit ) Glacr_pkwater_equiv + READ ( Restart_inunit ) Glacr_pkwater_ante + READ ( Restart_inunit ) Glacr_pk_temp + READ ( Restart_inunit ) Glacr_air_avtemp, Yrdays5 + READ ( Restart_inunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp + READ ( Restart_inunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow + READ ( Restart_inunit ) Glacr_pk_def + READ ( Restart_inunit ) Glacrb_melt + READ ( Restart_inunit ) Glacr_freeh2o_capm + ENDIF ENDIF END SUBROUTINE snowcomp_restart diff --git a/prms/soilzone.f90 b/prms/soilzone.f90 index 76e1eb8e..a77f519d 100644 --- a/prms/soilzone.f90 +++ b/prms/soilzone.f90 @@ -18,7 +18,7 @@ MODULE PRMS_SOILZONE ! Local Variables INTEGER, SAVE :: DBGUNT CHARACTER(LEN=8), SAVE :: MODNAME - INTEGER, SAVE :: Max_gvrs, Et_type, Pref_flag + INTEGER, SAVE :: Max_gvrs, Et_type, Pref_flag, Is_land INTEGER, SAVE, ALLOCATABLE :: Soil2gw(:), Pref_flow_flag(:) REAL, SAVE, ALLOCATABLE :: Gvr2pfr(:), Swale_limit(:) REAL, SAVE, ALLOCATABLE :: Soil_lower_stor_max(:) @@ -59,7 +59,7 @@ MODULE PRMS_SOILZONE REAL, SAVE, ALLOCATABLE :: Pref_flow_infil(:), Pref_flow_in(:) REAL, SAVE, ALLOCATABLE :: Hru_sz_cascadeflow(:), Swale_actet(:) REAL, SAVE, ALLOCATABLE :: Pref_flow_max(:), Snow_free(:) - REAL, SAVE, ALLOCATABLE :: Cap_waterin(:), Soil_lower(:), Soil_zone_max(:) + REAL, SAVE, ALLOCATABLE :: Cap_waterin(:), Soil_lower(:), Soil_zone_max(:) REAL, SAVE, ALLOCATABLE :: Potet_lower(:), Potet_rechr(:), Soil_lower_ratio(:) REAL, SAVE, ALLOCATABLE :: Unused_potet(:) ! REAL, SAVE, ALLOCATABLE :: Cascade_interflow(:), Cascade_dunnianflow(:), Interflow_max(:) @@ -700,7 +700,7 @@ INTEGER FUNCTION szinit() Pref_flow_stor(i) = Ssres_stor(i) - Slow_stor(i) ENDIF IF ( Soil2gw_max(i)>0.0 ) Soil2gw(i) = 1 - IF ( Hru_type(i)==1 ) THEN ! interflow coefficient values don't matter unless land HRU + IF ( Hru_type(i)==1 .OR. Hru_type(i)==4 ) THEN ! interflow coefficient values don't matter unless land HRU IF ( Pref_flow_den(i)>0.0 ) THEN Pref_flow_flag(i) = 1 Pref_flag = 1 @@ -845,7 +845,7 @@ END FUNCTION szinit INTEGER FUNCTION szrun() USE PRMS_SOILZONE USE PRMS_MODULE, ONLY: Dprst_flag, Print_debug, Kkiter, & - & GSFLOW_flag, Nlake, Cascade_flag, Dprst_flag + & GSFLOW_flag, Nlake, Cascade_flag, Dprst_flag, Frozen_flag USE PRMS_BASIN, ONLY: Hru_type, Hru_perv, Hru_frac_perv, & & Hru_route_order, Active_hrus, Basin_area_inv, Hru_area, & & NEARZERO, Lake_hru_id, Cov_type, Numlake_hrus, Hru_area_dble @@ -861,7 +861,7 @@ INTEGER FUNCTION szrun() USE PRMS_SET_TIME, ONLY: Nowmonth !, Nowday USE PRMS_INTCP, ONLY: Hru_intcpevap USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap - USE PRMS_SRUNOFF, ONLY: Basin_sroff, Hru_impervevap, Strm_seg_in, Dprst_evap_hru, Dprst_seep_hru + USE PRMS_SRUNOFF, ONLY: Basin_sroff, Hru_impervevap, Strm_seg_in, Dprst_evap_hru, Dprst_seep_hru, Frozen IMPLICIT NONE ! Functions INTRINSIC MIN, ABS, MAX, SNGL, DBLE @@ -876,6 +876,7 @@ INTEGER FUNCTION szrun() REAL :: perv_frac, capacity, capwater_maxin, ssresin REAL :: cap_upflow_max, unsatisfied_et, pervactet, prefflow DOUBLE PRECISION :: gwin + INTEGER :: cfgi_frozen_hru !*********************************************************************** szrun = 0 @@ -991,7 +992,9 @@ INTEGER FUNCTION szrun() IF ( avail_potet<0.0 ) avail_potet = 0.0 ! Snowevap_aet_frac(i) = 0.0 - !Hru_type can be 1 (land) or 3 (swale) + !Hru_type can be 1 (land) or 3 (swale) or 4 (glacier) + Is_land = 0 + IF ( Hru_type(i)==1 .OR. Hru_type(i)==4 ) Is_land = 1 !******Add infiltration to soil and compute excess ! note, perv_area has to be > 0.0 @@ -1013,6 +1016,20 @@ INTEGER FUNCTION szrun() ! perv_frac has to be > 0.001 ! infil for pervious portion of HRU capwater_maxin = Infil(i) + + cfgi_frozen_hru = 0 + !Frozen is HRU variable that says if frozen gravity reservoir + ! For CFGI all inflow is assumed to be Dunnian Flow when frozen + IF ( Frozen_flag==1 ) THEN + IF ( Frozen(i)==1 ) THEN + IF ( Hru_type(i)==3 ) THEN + PRINT *, 'ERROR, a swale HRU cannot be frozen for CFGI, HRU:', i + STOP + ENDIF + cfgi_frozen_hru = 1 + ENDIF + ENDIF + ! compute preferential flow and storage, and any dunnian flow prefflow = 0.0 IF ( Pref_flow_flag(i)==1 ) THEN @@ -1022,17 +1039,22 @@ INTEGER FUNCTION szrun() pref_flow_maxin = capwater_maxin*Pref_flow_den(i) capwater_maxin = capwater_maxin - pref_flow_maxin pref_flow_maxin = pref_flow_maxin*perv_frac - ! compute contribution to preferential-flow reservoir storage - Pref_flow_stor(i) = Pref_flow_stor(i) + pref_flow_maxin - dunnianflw_pfr = MAX( 0.0, Pref_flow_stor(i)-Pref_flow_max(i) ) - IF ( dunnianflw_pfr>0.0 ) THEN + IF ( cfgi_frozen_hru==1 ) THEN + dunnianflw_pfr = pref_flow_maxin Basin_dunnian_pfr = Basin_dunnian_pfr + dunnianflw_pfr*harea - Pref_flow_stor(i) = Pref_flow_max(i) + ELSE + ! compute contribution to preferential-flow reservoir storage + Pref_flow_stor(i) = Pref_flow_stor(i) + pref_flow_maxin + dunnianflw_pfr = MAX( 0.0, Pref_flow_stor(i)-Pref_flow_max(i) ) + IF ( dunnianflw_pfr>0.0 ) THEN + Basin_dunnian_pfr = Basin_dunnian_pfr + dunnianflw_pfr*harea + Pref_flow_stor(i) = Pref_flow_max(i) + ENDIF + Pref_flow_infil(i) = pref_flow_maxin - dunnianflw_pfr + Basin_pref_flow_infil = Basin_pref_flow_infil + Pref_flow_infil(i)*harea ENDIF - Pref_flow_infil(i) = pref_flow_maxin - dunnianflw_pfr - Basin_pref_flow_infil = Basin_pref_flow_infil + Pref_flow_infil(i)*harea + Pfr_dunnian_flow(i) = dunnianflw_pfr ENDIF - Pfr_dunnian_flow(i) = dunnianflw_pfr ENDIF IF ( Cascade_flag>0 ) THEN @@ -1049,16 +1071,17 @@ INTEGER FUNCTION szrun() !******Add infiltration to soil and compute excess gvr_maxin = 0.0 Cap_waterin(i) = capwater_maxin - - ! call even if capwater_maxin = 0, just in case soil_moist now > Soil_moist_max - IF ( capwater_maxin+Soil_moist(i)>0.0 ) THEN - CALL compute_soilmoist(Cap_waterin(i), Soil_moist_max(i), & - & Soil_rechr_max(i), Soil2gw_max(i), gvr_maxin, & - & Soil_moist(i), Soil_rechr(i), Soil_to_gw(i), Soil2gw(i), perv_frac) - Cap_waterin(i) = Cap_waterin(i)*perv_frac - Basin_capwaterin = Basin_capwaterin + DBLE( Cap_waterin(i)*harea ) - Basin_soil_to_gw = Basin_soil_to_gw + DBLE( Soil_to_gw(i)*harea ) - Basin_sm2gvr_max = Basin_sm2gvr_max + DBLE( gvr_maxin*harea ) + IF ( cfgi_frozen_hru==0 ) THEN + ! call even if capwate_maxin = 0, just in cast soil_moist now > Soil_moist_max + IF ( capwater_maxin+Soil_moist(i)>0.0 ) THEN + CALL compute_soilmoist(Cap_waterin(i), Soil_moist_max(i), & + & Soil_rechr_max(i), Soil2gw_max(i), gvr_maxin, & + & Soil_moist(i), Soil_rechr(i), Soil_to_gw(i), Soil2gw(i), perv_frac) + Cap_waterin(i) = Cap_waterin(i)*perv_frac + Basin_capwaterin = Basin_capwaterin + DBLE( Cap_waterin(i)*harea ) + Basin_soil_to_gw = Basin_soil_to_gw + DBLE( Soil_to_gw(i)*harea ) + Basin_sm2gvr_max = Basin_sm2gvr_max + DBLE( gvr_maxin*harea ) + ENDIF ENDIF ! Soil_to_ssr for whole HRU Soil_to_ssr(i) = gvr_maxin @@ -1139,7 +1162,7 @@ INTEGER FUNCTION szrun() Potet_rechr(i) = 0.0 Potet_lower(i) = 0.0 pervactet = 0.0 - IF ( Soil_moist(i)>0.0 ) THEN + IF ( Soil_moist(i)>0.0 .AND. cfgi_frozen_hru==0 ) THEN CALL compute_szactet(Soil_moist_max(i), Soil_rechr_max(i), Transp_on(i), Cov_type(i), & & Soil_type(i), Soil_moist(i), Soil_rechr(i), pervactet, & & avail_potet, Snow_free(i), Potet_rechr(i), Potet_lower(i)) @@ -1191,7 +1214,7 @@ INTEGER FUNCTION szrun() ! if HRU cascades, ! compute interflow and excess flow to each HRU or stream - IF ( Hru_type(i)==1 ) THEN + IF ( Is_land==1 ) THEN interflow = Slow_flow(i) + prefflow ! Interflow_max(i) = interflow Basin_interflow_max = Basin_interflow_max + interflow*harea diff --git a/prms/soltab.f90 b/prms/soltab.f90 index a7280c6f..7165eb95 100644 --- a/prms/soltab.f90 +++ b/prms/soltab.f90 @@ -8,7 +8,7 @@ ! ! Lee, R., 1963, Evaluation of solar beam irradiation as a climatic parameter ! of mountain watersheds, Colorado State University Hydrology Papers, 2, -! 50 pp. +! 50 pp. !*********************************************************************** MODULE PRMS_SOLTAB IMPLICIT NONE @@ -210,7 +210,7 @@ INTEGER FUNCTION sthinit() & Solar_declination(80), Solar_declination(94), Solar_declination(109), & & Solar_declination(123), Solar_declination(138), Solar_declination(152), & & Solar_declination(173) - CLOSE ( file_unit) + CLOSE ( file_unit) ! from original soltab ! data obliquity/2.06699,2.06317,2.05582,2.04520,2.03243,2.01706,2.00080, ! +1.98553,1.96990,1.95714,1.94689,1.94005,1.93616/ @@ -221,7 +221,7 @@ INTEGER FUNCTION sthinit() ! data jday/356,10,23,38,51,66,80,94,109,123,138,152,173/ ENDIF - DEALLOCATE ( Hru_slope, Hru_aspect ) +! DEALLOCATE ( Hru_slope, Hru_aspect ) !can't deallocate if have glaciers because call after init END FUNCTION sthinit @@ -387,7 +387,7 @@ SUBROUTINE compute_t(Lat, Solar_declination, T) ! This is the sunrise equation ! Lat is the latitude ! Solar_declination is the declination of the sun on a day -! T is the angle hour from the local meridian (local solar noon) to the +! T is the angle hour from the local meridian (local solar noon) to the ! sunrise (negative) or sunset (positive). The Earth rotates at the angular ! speed of 15 degrees/hour (2 pi / 24 hour in radians) and, therefore, T/15 degress (T*24/pi ! in radians) gives the time of sunrise as the number of hours before the local diff --git a/prms/stream_tempCopy.f90 b/prms/stream_tempCopy.f90 new file mode 100644 index 00000000..0978f824 --- /dev/null +++ b/prms/stream_tempCopy.f90 @@ -0,0 +1,1839 @@ +!*********************************************************************** +! stream temperature module +!*********************************************************************** + MODULE PRMS_STRMTEMP + IMPLICIT NONE +! Local Variables + CHARACTER(LEN=11), SAVE :: MODNAME + INTEGER, SAVE, ALLOCATABLE :: Seg_hru_count(:), Seg_close(:) + REAL, SAVE, ALLOCATABLE :: seg_tave_ss(:), Seg_carea_inv(:), seg_tave_sroff(:), seg_tave_lat(:) + REAL, SAVE, ALLOCATABLE :: seg_tave_gw(:), Flowsum(:) + + ! next variables only needed if strm_temp_shade_flag = 0 + REAL, SAVE, ALLOCATABLE :: Shade_jday(:, :), Svi_jday(:, :) + REAL, SAVE, ALLOCATABLE :: Seg_lat(:), Seg_elev(:) + REAL, SAVE, ALLOCATABLE :: Press(:) + REAL, SAVE, ALLOCATABLE :: Cos_seg_lat(:), Sin_seg_lat(:), Horizontal_hour_angle(:, :), Total_shade(:, :) + REAL, SAVE, ALLOCATABLE :: Sin_declination(:, :), Sin_lat_decl(:, :), Cos_lat_decl(:, :), Sin_alrs(:, :) + REAL, SAVE, ALLOCATABLE :: Max_solar_altitude(:, :), Level_sunset_azimuth(:, :) + REAL, SAVE, ALLOCATABLE :: Local_sunset_hour_angle(:, :), Local_sunrise_hour_angle(:, :) + REAL, SAVE, ALLOCATABLE :: gw_sum(:), ss_sum(:) + REAL, SAVE, ALLOCATABLE :: gw_silo(:,:), ss_silo(:,:) + REAL, SAVE, ALLOCATABLE :: hru_area_sum(:) + INTEGER, SAVE :: gw_index, ss_index + +! Declared Variables + REAL, SAVE, ALLOCATABLE :: Seg_tave_water(:), seg_tave_upstream(:), Seg_daylight(:) + REAL, SAVE, ALLOCATABLE :: Seg_humid(:), Seg_width(:), Seg_ccov(:), seg_shade(:) + REAL, SAVE, ALLOCATABLE :: Seg_tave_air(:), Seg_melt(:), Seg_rain(:) + DOUBLE PRECISION, ALLOCATABLE :: Seg_potet(:) +! Segment Parameters + REAL, SAVE, ALLOCATABLE :: Seg_length(:) !, Mann_n(:) + REAL, SAVE, ALLOCATABLE :: Seg_slope(:), Width_values(:, :) + REAL, SAVE, ALLOCATABLE :: width_alpha(:), width_m(:) + INTEGER, SAVE:: Width_dim, Maxiter_sntemp + REAL, SAVE, ALLOCATABLE :: Seg_humidity(:, :) + REAL, SAVE, ALLOCATABLE :: lat_temp_adj(:, :) + INTEGER, SAVE, ALLOCATABLE :: Seg_humidity_sta(:) +! Shade Parameters needed if stream_temp_shade_flag = 0 + REAL, SAVE, ALLOCATABLE :: Azrh(:), Alte(:), Altw(:), Vce(:) + REAL, SAVE, ALLOCATABLE :: Vdemx(:), Vhe(:), Voe(:), Vcw(:), Vdwmx(:), Vhw(:), Vow(:) + REAL, SAVE, ALLOCATABLE :: Vdemn(:), Vdwmn(:) + INTEGER, SAVE :: Spring_jday, Summer_jday, Autumn_jday, Winter_jday +! Shade Parameters needed if stream_temp_shade_flag = 2 + REAL, SAVE, ALLOCATABLE :: Segshade_sum(:), Segshade_win(:) + REAL, SAVE:: Albedo, Melt_temp + ! INTEGER, SAVE :: Shadeflg, now using stream_temp_shade_flag + INTEGER, SAVE, ALLOCATABLE :: Ss_tau(:), Gw_tau(:) +! Control parameters + INTEGER, SAVE :: Stream_temp_shade_flag +! Conversions + INTRINSIC :: ACOS + REAL, PARAMETER :: HALF_PI = ACOS(0.0), ZERO_C = 273.16 + REAL, PARAMETER :: PI = ACOS(-1.0) + REAL, PARAMETER :: DEG_TO_RAD = PI / 180.0, DAYSYR = 365.242 + DOUBLE PRECISION :: MPS_CONVERT = 2.93981481D-07 + END MODULE PRMS_STRMTEMP + +!*********************************************************************** +! Main stream temperature routine +!*********************************************************************** + INTEGER FUNCTION stream_temp() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: stream_temp_decl, stream_temp_init, stream_temp_run, stream_temp_setdims + EXTERNAL :: stream_temp_restart +!*********************************************************************** + stream_temp = 0 + + IF ( Process(:3)=='run' ) THEN + stream_temp = stream_temp_run() + ELSEIF ( Process(:4)=='decl' ) THEN + stream_temp = stream_temp_decl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL stream_temp_restart(1) + stream_temp = stream_temp_init() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL stream_temp_restart(0) + ENDIF + + END FUNCTION stream_temp + +!*********************************************************************** +! stream_temp_decl - set up parameters and storage +! Declared Parameters +!*********************************************************************** + INTEGER FUNCTION stream_temp_decl() + USE PRMS_STRMTEMP + USE PRMS_MODULE, ONLY: Nsegment, Strmtemp_humidity_flag, Model + IMPLICIT NONE +! Functions + INTRINSIC INDEX + INTEGER, EXTERNAL :: declparam, declvar, getdim, control_integer + EXTERNAL :: read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_stream_temp +!*********************************************************************** + stream_temp_decl = 0 + + Version_stream_temp = 'stream_temp.f90 2018-04-18 16:18:00Z' + CALL print_module(Version_stream_temp, 'Stream Temperature ', 90) + MODNAME = 'stream_temp' + + ! 0 = compute shade; 1 = specified constant + IF ( control_integer(Stream_temp_shade_flag, 'stream_temp_shade_flag')/=0 ) Stream_temp_shade_flag = 0 + +! Declared Variables + ALLOCATE ( Seg_width(Nsegment) ) + IF ( declvar( MODNAME, 'seg_width', 'nsegment', Nsegment, 'real', & + & 'Width of each segment', & + & 'meters', Seg_width)/=0 ) CALL read_error(3, 'seg_width') + + ALLOCATE (Seg_tave_water(Nsegment) ) ! previous ?? + IF ( declvar( MODNAME, 'seg_tave_water', 'nsegment', Nsegment, 'real', & + & 'Computed daily mean stream temperature for each segment', & + & 'degrees Celsius', Seg_tave_water)/=0 ) CALL read_error(3, 'seg_tave_water') + + ALLOCATE ( seg_tave_upstream(Nsegment) ) + IF ( declvar( MODNAME, 'seg_tave_upstream', 'nsegment', Nsegment, 'real', & + & 'Temperature of streamflow entering each segment', & + & 'degrees Celsius', seg_tave_upstream)/=0 ) CALL read_error(3,'seg_tave_upstream') + + ALLOCATE ( Seg_humid(Nsegment) ) + IF ( declvar( MODNAME, 'seg_humid', 'nsegment', Nsegment, 'real', & + & 'Area-weighted average relative humidity for each segment from HRUs contributing flow to the segment', & + & 'decimal fraction', Seg_humid)/=0 ) CALL read_error(3,'seg_humid') + + ALLOCATE ( Seg_melt(Nsegment) ) + IF ( declvar( MODNAME, 'seg_melt', 'nsegment', Nsegment, 'real', & + & 'Area-weighted average snowmelt for each segment from HRUs contributing flow to the segment', & + & 'inches', Seg_melt)/=0 ) CALL read_error(3, 'seg_melt') + + ALLOCATE ( Seg_rain(Nsegment) ) + IF ( declvar( MODNAME, 'seg_rain', 'nsegment', Nsegment, 'real', & + & 'Area-weighted average rainfall for each segment from HRUs contributing flow to the segment', & + & 'inches', Seg_rain)/=0 ) CALL read_error(3, 'seg_rain') + + ALLOCATE ( Seg_tave_air(Nsegment) ) + IF ( declvar( MODNAME, 'seg_tave_air', 'nsegment', Nsegment, 'real', & + & 'Area-weighted average air temperature for each segment from HRUs contributing flow to the segment', & + & 'degrees Celsius', Seg_tave_air)/=0 ) CALL read_error(3, 'seg_tave_air') + + ALLOCATE ( Seg_potet(Nsegment) ) + IF ( declvar( MODNAME, 'seg_potet', 'nsegment', Nsegment, 'double', & + & 'HRU area-weighted average potential ET for each segment', & + & 'inches', Seg_potet)/=0 ) CALL read_error(3, 'seg_potet') + + ALLOCATE ( Seg_ccov(Nsegment) ) + IF ( declvar( MODNAME, 'seg_ccov', 'nsegment', Nsegment, 'real', & + & 'Area-weighted average cloud cover fraction for each segment from HRUs contributing flow to the segment', & + & 'decimal fraction', Seg_ccov )/=0 ) CALL read_error(3, 'seg_ccov') + + ALLOCATE(Seg_shade(Nsegment)) + IF (declvar(MODNAME, 'seg_shade', 'nsegment', Nsegment, 'real', & + & 'Area-weighted average shade fraction for each segment', & + & 'decimal fraction', seg_shade)/=0 ) CALL read_error(3, 'seg_shade') + + ALLOCATE ( Seg_daylight(Nsegment) ) + IF ( declvar( MODNAME, 'seg_daylight', 'nsegment', Nsegment, 'real', & + & 'Hours of daylight', & + & 'hours', Seg_daylight)/=0 ) CALL read_error(3,'seg_daylight') + + ALLOCATE(seg_tave_gw(Nsegment)) + IF ( declvar( MODNAME, 'seg_tave_gw', 'nsegment', Nsegment, 'real', & + & 'groundwater temperature', & + & 'degrees Celsius', seg_tave_gw)/=0 ) CALL read_error(3,'seg_tave_gw') + + ALLOCATE(seg_tave_ss(Nsegment)) + IF ( declvar( MODNAME, 'seg_tave_ss', 'nsegment', Nsegment, 'real', & + & 'subsurface temperature', & + & 'degrees Celsius', seg_tave_ss)/=0 ) CALL read_error(3,'seg_tave_ss') + + ALLOCATE(seg_tave_sroff(Nsegment)) + IF ( declvar( MODNAME, 'seg_tave_sroff', 'nsegment', Nsegment, 'real', & + & 'surface runoff temperature', & + & 'degrees Celsius', seg_tave_sroff)/=0 ) CALL read_error(3,'seg_tave_sroff') + + ALLOCATE(seg_tave_lat(Nsegment)) + IF ( declvar( MODNAME, 'seg_tave_lat', 'nsegment', Nsegment, 'real', & + & 'lateral flow temperature', & + & 'degrees Celsius', seg_tave_lat)/=0 ) CALL read_error(3,'seg_tave_lat') + + ALLOCATE (Press(Nsegment) ) + ALLOCATE ( Seg_hru_count(Nsegment) ) + ALLOCATE (Seg_carea_inv(Nsegment) ) + ALLOCATE ( Seg_close(Nsegment) ) + ALLOCATE (gw_sum(Nsegment), ss_sum(Nsegment)) + ALLOCATE (gw_silo(nsegment,365), ss_silo(nsegment,365)) + ALLOCATE (hru_area_sum(nsegment)) + + IF ( declparam( MODNAME, 'albedo', 'one', 'real', & + & '0.10', '0.0', '1.0', & + & 'Short-wave solar radiation reflected by streams', & + & 'Short-wave solar radiation reflected by streams', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo') + + ALLOCATE(lat_temp_adj(Nsegment,12)) + IF ( declparam( MODNAME, 'lat_temp_adj', 'nsegment,nmonths', 'real', & + & '0.0', '-5.0', '5.0', & + & 'Correction factor to adjust the bias of the temperature of the lateral inflow', & + & 'Correction factor to adjust the bias of the temperature of the lateral inflow', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'lat_temp_adj') + + ALLOCATE ( Seg_length(Nsegment) ) + IF ( declparam( MODNAME, 'seg_length', 'nsegment', 'real', & + & '1000.0', '1.0', '100000.0', & + & 'Length of each segment', & + & 'Length of each segment', & + & 'meters')/=0 ) CALL read_error(1, 'seg_length') + + ALLOCATE ( Seg_slope(Nsegment) ) + IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & + & '0.015', '0.0001', '2.0', & + & 'Bed slope of each segment', & + & 'Bed slope of each segment', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'seg_slope') + + ALLOCATE (width_alpha(Nsegment) ) + IF ( declparam( MODNAME, 'width_alpha', 'nsegment', 'real', & + & '0.015', '0.0001', '2.0', & + & 'Alpha coefficient in power function for width calculation', & + & 'Alpha coefficient in power function for width calculation', & + & 'unknown')/=0 ) CALL read_error(1, 'width_alpha') + + ALLOCATE (width_m(Nsegment) ) + IF ( declparam( MODNAME, 'width_m', 'nsegment', 'real', & + & '0.015', '0.0001', '2.0', & + & 'M value in power function for width calculation', & + & 'M value in power function for width calculation', & + & 'unknown')/=0 ) CALL read_error(1, 'width_m') + + IF ( Stream_temp_shade_flag==0 .OR. Model==99 ) THEN + ALLOCATE ( Azrh(Nsegment) ) + IF ( declparam( MODNAME, 'azrh', 'nsegment', 'real', & + & '0.0', '-1.5708', '1.5708', & + & 'Azimuth angle of each segment', & + & 'Azimuth angle of each segment', & + & 'radians')/=0 ) CALL read_error(1, 'azrh') + + ALLOCATE ( Alte(Nsegment) ) + IF ( declparam( MODNAME, 'alte', 'nsegment', 'real', & + & '0.0', '0.0','1.57079633', & + & 'East bank topographic altitude', & + & 'East bank topographic altitude of each segment', & + & 'radians')/=0 ) CALL read_error(1, 'alte') + + ALLOCATE ( Altw(Nsegment) ) + IF ( declparam( MODNAME, 'altw', 'nsegment', 'real', & + & '0.0', '0.0', '1.57079633', & + & 'West bank topographic altitude', & + & 'West bank topographic altitude of each segment', & + & 'radians')/=0 ) CALL read_error(1, 'altw') + + ALLOCATE ( Vce(Nsegment) ) + IF ( declparam( MODNAME, 'vce', 'nsegment', 'real', & + & '0.0', '0.0', '15.0', & + & 'East bank average vegetation crown width', & + & 'East bank average vegetation crown width for each segment', & + & 'meters')/=0 ) CALL read_error(1, 'vce') + + ALLOCATE ( Vdemx(Nsegment) ) + IF ( declparam( MODNAME, 'vdemx', 'nsegment', 'real', & + & '0.0', '0.0', '1.0', & + & 'Maximum east bank vegetation density', & + & 'Maximum east bank vegetation density for each segment', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'vdemx') + + ALLOCATE ( Vdemn(Nsegment) ) + IF ( declparam( MODNAME, 'vdemn', 'nsegment', 'real', & + & '0.0', '0.0', '1.0', & + & 'Minimum east bank vegetation density', & + & 'Minimum east bank vegetation density for each segment', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'vdemn') + + ALLOCATE ( Vhe(Nsegment) ) + IF ( declparam( MODNAME, 'vhe', 'nsegment', 'real', & + & '0.0', '0.0', '30.0', & + & 'East bank vegetation height', & + & 'East bank average vegetation height for each segment', & + & 'meters')/=0 ) CALL read_error(1, 'vhe') + + ALLOCATE ( Voe(Nsegment) ) + IF ( declparam( MODNAME, 'voe', 'nsegment', 'real', & + & '0.0', '0.0', '100.0',& + & 'East bank vegetation offset', & + & 'East bank vegetation offset for each segment', & + & 'meters')/=0 ) CALL read_error(1, 'voe') + + ALLOCATE ( Vcw(Nsegment) ) + IF ( declparam( MODNAME, 'vcw', 'nsegment', 'real', & + & '0.0', '0.0', '15.0', & + & 'West bank vegetation crown width', & + & 'West bank average vegetation crown width for each segment', & + & 'meters')/=0 ) CALL read_error(1, 'vcw') + + ALLOCATE ( Vdwmx(Nsegment) ) + IF ( declparam( MODNAME, 'vdwmx', 'nsegment', 'real', & + & '0.0', '0.0', '1.0', & + & 'Maximum west bank vegetation density', & + & 'Maximum west bank vegetation density for each segment', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'vdwmx') + + ALLOCATE ( Vdwmn(Nsegment) ) + IF ( declparam( MODNAME, 'vdwmn', 'nsegment', 'real', & + & '0.0', '0.0', '1.0', & + & 'Minimum west bank vegetation density', & + & 'Minimum west bank vegetation density for each segment', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'vdwmn') + + ALLOCATE ( Vhw(Nsegment) ) + IF ( declparam( MODNAME, 'vhw', 'nsegment', 'real', & + & '0.0', '0.0', '30.0', & + & 'West bank vegetation height', & + & 'West bank average vegetation height for each segment', & + & 'meters')/=0 ) CALL read_error(1, 'vhw') + + ALLOCATE ( Vow(Nsegment) ) + IF ( declparam( MODNAME, 'vow', 'nsegment', 'real', & + & '0.0', '0.0', '100.0', & + & 'West bank vegetation offset', & + & 'West bank vegetation offset for each segment', & + & 'meters')/=0 ) CALL read_error(1, 'vow') + ENDIF + + IF ( Stream_temp_shade_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Segshade_sum(Nsegment) ) + IF ( declparam( MODNAME, 'segshade_sum', 'nsegment', 'real', & + & '0.0', '0.0', '1.0.', & + & 'Total shade fraction for summer vegetation', & + & 'Total shade fraction for summer vegetation; required when stream_temp_flag=1', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'segshade_sum') + + ALLOCATE ( Segshade_win(Nsegment) ) + IF ( declparam( MODNAME, 'segshade_win', 'nsegment', 'real', & + & '0.0', '0.0', '1.0.', & + & 'Total shade fraction for winter vegetation', & + & 'Total shade fraction for winter vegetation; required when stream_temp_flag=1', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'segshade_win') + ENDIF + + ALLOCATE (ss_tau(Nsegment) ) + IF ( declparam( MODNAME, 'ss_tau', 'nsegment', 'integer', & + & '30', '1', '365', & + & 'Average residence time of subsurface interflow', & + & 'Average residence time of subsurface interflow', & + & 'days')/=0 ) CALL read_error(1, 'ss_tau') + + ALLOCATE (gw_tau(Nsegment) ) + IF ( declparam( MODNAME, 'gw_tau', 'nsegment', 'integer', & + & '365', '1', '365', & + & 'Average residence time in groundwater flow', & + & 'Average residence time in groundwater flow', & + & 'days')/=0 ) CALL read_error(1, 'gw_tau') + + IF ( declparam( MODNAME, 'melt_temp', 'one', 'real', & + & '1.5', '0.0', '10.0', & + & 'Temperature at which snowmelt enters a stream', & + & 'Temperature at which snowmelt enters a stream', & + & 'degrees Celsius')/=0 ) CALL read_error(1, 'melt_temp') + + IF ( declparam( MODNAME, 'maxiter_sntemp', 'one', 'integer', & + & '1000', '10', '2000', & + & 'Maximum number of Newton-Raphson iterations to compute stream temperature', & + & 'Maximum number of Newton-Raphson iterations to compute stream temperature', & + & 'none')/=0 ) CALL read_error(1, 'maxiter_sntemp') + + IF ( Strmtemp_humidity_flag==1 .OR. Model==99 ) THEN ! specified constant + ALLOCATE ( Seg_humidity(Nsegment, 12) ) + IF ( declparam( MODNAME, 'seg_humidity', 'nsegment,nmonths', 'real', & + & '0.7', '0.0', '1.0', & + & 'Mean monthly humidity for each segment', & + & 'Mean monthly humidity for each segment, used when values not input in CBH File', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'seg_humidity') + ELSEIF ( Strmtemp_humidity_flag==2 .OR. Model==99 ) THEN ! use station data + ALLOCATE ( Seg_humidity_sta(Nsegment) ) + IF ( declparam(MODNAME, 'seg_humidity_sta', 'nsegment', 'integer', & + & '0', 'bounded', 'nhumid', & + & 'Index of humidity measurement station for each stream segment', & + & 'Index of humidity measurement station for each stream segment', & + & 'none')/=0 ) CALL read_error(1, 'seg_humidity_sta') + ENDIF + + ALLOCATE (seg_lat(nsegment)) + IF ( declparam( MODNAME, 'seg_lat', 'nsegment', 'real', & + & '40.0', '-90.0', '90.0', & + & 'Segment latitude', & + & 'Latitiude of each segment', & + & 'degrees North')/=0 ) CALL read_error(1, 'seg_lat') + + ALLOCATE (seg_elev(nsegment)) + IF (declparam(MODNAME, 'seg_elev', 'nsegment', 'real', & + & '0.0', '-1000.0', '30000.0', & + & 'Segment elevation at midpoint', 'Segment elevation at midpoint', & + & 'meters')/=0 ) CALL read_error(1, 'seg_elev') + + END FUNCTION stream_temp_decl + +!*********************************************************************** +! stream_temp_init - Initialize module - get parameter values +!*********************************************************************** + INTEGER FUNCTION stream_temp_init() + USE PRMS_STRMTEMP + USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file, Inputerror_flag, Strmtemp_humidity_flag + USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, NEARZERO + USE PRMS_OBS, ONLY: Nhumid + USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Segment_up + IMPLICIT NONE +! Functions + INTRINSIC :: COS, SIN, ABS, SIGN, ASIN + INTEGER, EXTERNAL :: getparam + REAL, EXTERNAL :: solalt + EXTERNAL :: read_error, checkdim_param_limits +! Local Variables + INTEGER :: i, j, k, iseg, ierr, ii, this_seg + REAL :: tan_d, tano, sinhro, temp, decl, cos_d, tanod, alrs +!*********************************************************************** + stream_temp_init = 0 + + IF ( getparam( MODNAME, 'albedo', 1, 'real', Albedo)/=0 ) CALL read_error(2, 'albedo') + IF ( getparam( MODNAME, 'lat_temp_adj', Nsegment*12, 'real', lat_temp_adj)/=0 ) CALL read_error(2, 'lat_temp_adj') + IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') + + IF (getparam(MODNAME, 'seg_lat', Nsegment, 'real', Seg_lat)/=0 ) CALL read_error(2, 'seg_lat') +! Convert latitude from degrees to radians + seg_lat = seg_lat * DEG_TO_RAD + + IF (getparam(MODNAME, 'seg_elev', Nsegment, 'real', Seg_elev)/=0 ) CALL read_error(2, 'seg_elev') + +! convert stream length in meters to km + Seg_length = Seg_length / 1000.0 + + IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') + IF ( getparam( MODNAME, 'width_alpha', Nsegment, 'real', width_alpha)/=0 ) CALL read_error(2, 'width_alpha') + IF ( getparam( MODNAME, 'width_m', Nsegment, 'real', width_m)/=0 ) CALL read_error(2, 'width_m') + + IF ( Stream_temp_shade_flag==0 ) THEN + IF ( getparam( MODNAME, 'azrh', Nsegment, 'real', Azrh)/=0 ) CALL read_error(2, 'azrh') + IF ( getparam( MODNAME, 'alte', Nsegment, 'real', Alte)/=0 ) CALL read_error(2, 'alte') + IF ( getparam( MODNAME, 'altw', Nsegment, 'real', Altw)/=0 ) CALL read_error(2, 'altw') + IF ( getparam( MODNAME, 'vce', Nsegment, 'real', Vce)/=0 ) CALL read_error(2, 'vce') + IF ( getparam( MODNAME, 'vdemx', Nsegment, 'real', Vdemx)/=0 ) CALL read_error(2, 'vdemx') + IF ( getparam( MODNAME, 'vdemn', Nsegment, 'real', Vdemn)/=0 ) CALL read_error(2, 'vdemn') + IF ( getparam( MODNAME, 'vhe', Nsegment, 'real', Vhe)/=0 ) CALL read_error(2, 'vhe') + IF ( getparam( MODNAME, 'voe', Nsegment, 'real', Voe)/=0 ) CALL read_error(2, 'voe') + IF ( getparam( MODNAME, 'vcw', Nsegment, 'real', Vcw)/=0 ) CALL read_error(2, 'vcw') + IF ( getparam( MODNAME, 'vdwmx', Nsegment, 'real', Vdwmx)/=0 ) CALL read_error(2, 'vdwmx') + IF ( getparam( MODNAME, 'vdwmn', Nsegment, 'real', Vdwmn)/=0 ) CALL read_error(2, 'vdwmn') + IF ( getparam( MODNAME, 'vhw', Nsegment, 'real', Vhw)/=0 ) CALL read_error(2, 'vhw') + IF ( getparam( MODNAME, 'vow', Nsegment, 'real', Vow)/=0 ) CALL read_error(2, 'vow') + ELSE + IF ( getparam( MODNAME, 'segshade_sum', Nsegment, 'real', Segshade_sum)/=0 ) CALL read_error(2, 'segshade_sum') + IF ( getparam( MODNAME, 'segshade_win', Nsegment, 'real', Segshade_win)/=0 ) CALL read_error(2, 'segshade_win') + ENDIF + + IF ( getparam( MODNAME, 'ss_tau', Nsegment, 'integer', Ss_tau)/=0 ) CALL read_error(2, 'ss_tau') + IF ( getparam( MODNAME, 'gw_tau', Nsegment, 'integer', Gw_tau)/=0 ) CALL read_error(2, 'Gw_tau') + IF ( getparam( MODNAME, 'melt_temp', 1, 'real', Melt_temp)/=0 ) CALL read_error(2, 'melt_temp') + IF ( getparam( MODNAME, 'maxiter_sntemp', 1, 'real', Maxiter_sntemp)/=0 ) CALL read_error(2, 'maxiter_sntemp') + + ierr = 0 + IF ( Strmtemp_humidity_flag==1 ) THEN + IF ( getparam( MODNAME, 'seg_humidity', Nsegment*12, 'real', Seg_humidity)/=0 ) & + & CALL read_error(2, 'seg_humidity') + ELSEIF ( Strmtemp_humidity_flag==2 ) THEN ! use station data + IF ( getparam(MODNAME, 'seg_humidity_sta', Nsegment, 'integer', Seg_humidity_sta)/=0 ) & + & CALL read_error(2, 'seg_humidity_sta') + DO i = 1, Nsegment + CALL checkdim_param_limits(i, 'seg_humidity_sta', 'nhumid', Seg_humidity_sta(i), 1, Nhumid, ierr) + ENDDO + ENDIF + +! Initialize declared variables + seg_tave_upstream = 0.0 + Seg_potet = 0.0D0 + Seg_humid = 0.0 + Seg_width = 0.0 + Seg_ccov = 0.0 + Seg_tave_air = 0.0 + seg_tave_gw = 0.0 + seg_tave_ss = 0.0 + seg_tave_sroff = 0.0 + + IF ( Init_vars_from_file == 0 ) THEN + Seg_tave_water = 0.0 + gw_silo = 0.0 + ss_silo = 0.0 + gw_sum = 0.0 + ss_sum = 0.0 +! these are set to zero because they will be incremented to 1 down in the run function + gw_index = 0 + ss_index = 0 + ENDIF + + Seg_daylight = 12.0 + IF ( Stream_temp_shade_flag==0 ) THEN + ALLOCATE ( Cos_seg_lat(Nsegment), Sin_seg_lat(Nsegment), Horizontal_hour_angle(366,Nsegment) ) + ALLOCATE ( Total_shade(366,Nsegment), Sin_declination(366,Nsegment), Sin_alrs(366,Nsegment) ) + ALLOCATE ( Sin_lat_decl(366,Nsegment), Cos_lat_decl(366,Nsegment) ) + ALLOCATE ( Max_solar_altitude(366,Nsegment), Level_sunset_azimuth(366,Nsegment) ) + ALLOCATE ( Local_sunset_hour_angle(366,Nsegment), Local_sunrise_hour_angle(366,Nsegment) ) + ALLOCATE ( Shade_jday(Nsegment, 366), Svi_jday(Nsegment, 366) ) + Shade_jday = 0.0 + Svi_jday = 0.0 + Seg_lat = 0.0 + ENDIF + +! Figure out how many HRUs are connected to each segment + Seg_hru_count = 0 + DO k = 1, Active_hrus + j = Hru_route_order(k) + i = Hru_segment(j) + IF ( i==0 ) CYCLE + Seg_hru_count(i) = Seg_hru_count(i) + 1 + ENDDO + +! find segments that are too short and print them out as they are found + DO i = 1, Nsegment + IF ( Seg_length(i)0 ) THEN ! assign downstream values + Seg_close(i) = Tosegment(i) ! don't have a value yet, need to fix + ELSE ! no upstream or downstream segment + IF ( j>1 ) THEN + Seg_close(i) = Segment_order(j-1) ! set to previous segment id + ELSE + Seg_close(i) = Segment_order(j+1) ! assume at least 2 segments + ENDIF + ENDIF + ENDIF + IF ( Seg_elev(Seg_close(i))==30000.0 ) THEN ! need different segment + iseg = -1 + DO k = j+1, Nsegment ! find first segment with valid values + ii = Segment_order(k) + IF ( Seg_hru_count(ii)>0 ) THEN + Seg_close(i) = ii + EXIT + ENDIF + ENDDO + IF ( iseg==-1 ) THEN + IF ( j>1 ) THEN + Seg_close(i) = Segment_order(j-1) ! set to previous segment id + ELSE ! this is a problem, shouldn't happen + STOP 'ERROR, segments do not have associated HRUs' + ! Seg_close(i) = Segment_order(1) ! set to first segment id + ENDIF + ENDIF + ENDIF + ENDIF + + ! Compute atmospheric pressure based on segment elevation. + Press(i) = 1013.0 - (0.1055 * Seg_elev(i)) + + IF ( Stream_temp_shade_flag==0 ) THEN +! LATITUDE TRIGONOMETRIC PARAMETERS + Cos_seg_lat(i) = COS(Seg_lat(i)) ! coso + IF ( Cos_seg_lat(i) < NEARZERO ) Cos_Seg_lat(i) = NEARZERO + Sin_seg_lat(i) = SIN(Seg_lat(i)) ! sino + tano = Sin_seg_lat(i) / Cos_seg_lat(i) + DO k = 1, 366 +! DECLINATION TRIGONOMETRIC PARAMETERS + decl = 0.40928 * COS(((2.0 * PI) / 365.25) * (172.0 - k)) + cos_d = COS(decl) + Sin_declination(k, i) = SIN(decl) ! sin_d + IF ( cos_d < NEARZERO ) cos_d = NEARZERO + tan_d = Sin_declination(k, i) / cos_d +! +! JOINT LATITUDE & DECLINATION TRIGONOMETRIC PARAMETERS + Cos_lat_decl(k, i) = Cos_seg_lat(i) * cos_d ! cosod + Sin_lat_decl(k, i) = Sin_seg_lat(i) * Sin_declination(k, i) ! sinod + tanod = tano * tan_d + IF ( ABS(tanod) > 1.0 ) tanod = SIGN(1.0,tanod) + +! LEVEL-PLAIN SUNRISE/SET HOUR ANGLE + Horizontal_hour_angle(k, i) = ACOS(-tanod) ! hrso + sinhro = SIN(Horizontal_hour_angle(k, i)) +! +! LEVEL-PLAIN SOLAR AZIMUTH + temp = -Sin_declination(k, i)/Cos_Seg_lat(i) + IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0,temp) + Level_sunset_azimuth(k, i) = ACOS(temp) ! azso +! +! MAXIMUM POSSIBLE SOLAR ALTITUDE + Max_solar_altitude(k, i) = ASIN( Sin_lat_decl(k,i) + Cos_lat_decl(k,i) ) ! alsmx +! +! TOTAL POTENTIAL SHADE ON LEVEL-PLAIN ! totsh + Total_shade(k, i) = 2.0 * ((Horizontal_hour_angle(k, i) * Sin_lat_decl(k, i)) + (sinhro * Cos_lat_decl(k, i))) + IF ( Total_shade(k, i) < NEARZERO ) Total_shade(k, i) = NEARZERO +! +! CHECK FOR REACH AZIMUTH LESS THAN SUNRISE + IF ( Azrh(i) <= (-Level_sunset_azimuth(k, i)) ) THEN + alrs = 0.0 +! +! CHECK FOR REACH AZIMUTH GREATER THAN SUNSET + ELSEIF ( Azrh(i) >= Level_sunset_azimuth(k, i) ) THEN + alrs = 0.0 +! +! REACH AZIMUTH IS BETWEEN SUNRISE & SUNSET + ELSEIF ( Azrh(i) == 0.0 ) THEN + alrs = Max_Solar_altitude(k, i) + ELSE + alrs = solalt(Cos_seg_lat(i), Sin_seg_lat(i), Sin_declination(k,i), Azrh(i), 0.0, Max_Solar_altitude(k,i)) + Sin_alrs(k, i) = SIN(alrs) +! +! END REACH & SOLAR AZIMUTH CHECK + ENDIF + ENDDO + ENDIF + ENDDO + +! There may be headwater segments that do not have any HRUs and do not have any upstream segments to produce +! streamflow. These segments will never have any streamflow, and consequently never be able to simulate +! stream temperature. This block finds these and sets the stream temperature value to -99.9. Subsequent code +! should be able to check if the temperature value is less than -99.0 and know that it doesn't need to do +! any stream temperature calculation because there will never be any water in the segment. +! +! This code is similar to the code above that computes latitude and elevation, but is different because it +! must always look upstream because the downstream computations will not have been done when the current +! segment is being calculated. + Seg_tave_water = 0.0 + do j = 1, nsegment + this_seg = segment_order(j) + +! Check if this segment has any HRUs, keep moving up stream if not. + do + if (seg_hru_count(this_seg) .eq. 0) then + ! Hit the headwater segment without finding any HRUs (i.e. sources of streamflow) + ! Set the stream temp to -99.9 for this segment because there will never be any flow in this segment + if (segment_up(this_seg) .eq. 0) then + Seg_tave_water(segment_order(j)) = -99.9 + exit + endif + + ! There is an upstream segment, check that segment for HRUs + this_seg = segment_up(this_seg) + else + ! This segment has HRUs so there will be no streamflow + exit + endif + enddo + enddo + END FUNCTION stream_temp_init + + +!*********************************************************************** +! stream_temp_run - Computes stream temperatures +!*********************************************************************** + INTEGER FUNCTION stream_temp_run() + USE PRMS_STRMTEMP + USE PRMS_MODULE, ONLY: Nsegment, Strmtemp_humidity_flag + USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_area, NEARZERO, CFS2CMS_CONV + USE PRMS_SET_TIME, ONLY: Summer_flag, Nowmonth + USE PRMS_CLIMATEVARS, ONLY: Tavgc, Potet, Hru_rain, Swrad + USE PRMS_CLIMATE_HRU, ONLY: Humidity_hru + USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_SNOW, ONLY: Snowmelt + USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Seginc_swrad + USE PRMS_OBS, ONLY: Humidity + USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday, Jday + USE PRMS_SOLTAB, ONLY: Soltab_potsw, Hru_cossl + + IMPLICIT NONE +! Functions + INTRINSIC :: DBLE + REAL, EXTERNAL :: twavg, twmax, get_segwidth + EXTERNAL :: equilb, lat_inflow, shday +! Local Variables + REAL :: harea, svi, fs + INTEGER :: i, j, k, iseg + REAL :: te, ak1, ak2, ccov + DOUBLE PRECISION :: qlat + REAL :: t_o, up_temp +!*********************************************************************** + stream_temp_run = 0 + Seg_tave_air = 0.0 + +! Humidity info come from parameter file when Strmtemp_humidity_flag==1 +! Otherwise it comes as daily values per HRU from CBH. Code for this is +! down in the HRU loop. + IF ( Strmtemp_humidity_flag==1 ) THEN + DO i = 1, Nsegment + Seg_humid(i) = Seg_humidity(i, Nowmonth) + ENDDO + ELSEIF ( Strmtemp_humidity_flag==2 ) THEN ! use station data + DO i = 1, Nsegment + Seg_humid(i) = Humidity(Seg_humidity_sta(i)) + ENDDO + ELSE + Seg_humid = 0.0 + ENDIF + + Seg_potet = 0.0D0 + Seg_ccov = 0.0 + Seg_melt = 0.0 + Seg_rain = 0.0 + hru_area_sum = 0.0 + + ! Compute segment lateral inflow temperatures and segment meteorological values + DO k = 1, Active_hrus + j = Hru_route_order(k) + ccov = 1.0 - (Swrad(j) / sngl(Soltab_potsw(jday, j)) * sngl(Hru_cossl(j))) + IF ( ccov1.0 ) THEN + ccov = 1.0 + ENDIF + + harea = Hru_area(j) + i = Hru_segment(j) + IF ( i==0 ) CYCLE + +! Compute temperature of surface runoff here for HRU and stream segments + Seg_tave_air(i) = Seg_tave_air(i) + Tavgc(j)*harea + hru_area_sum(i) = hru_area_sum(i) + harea + +! Compute segment humidity if info is specified in CBH as timeseries by HRU + IF ( Strmtemp_humidity_flag==0 ) then + Seg_humid(i) = Seg_humid(i) + Humidity_hru(j)*harea + endif + +! Figure out the contributions of the HRUs to each segment for these drivers. + Seg_ccov(i) = Seg_ccov(i) + ccov*harea + Seg_potet(i) = Seg_potet(i) + DBLE( Potet(j)*harea ) + Seg_melt(i) = Seg_melt(i) + Snowmelt(j)*harea + Seg_rain(i) = Seg_rain(i) + Hru_rain(j)*harea + ENDDO + + + DO j = 1, Nsegment + i = Segment_order(j) + IF ( Seg_hru_count(i)>0 ) THEN +! carea = Seg_carea_inv(i) + Seg_ccov(i) = Seg_ccov(i) / hru_area_sum(i) + Seg_potet(i) = Seg_potet(i) / dble(hru_area_sum(i)) + Seg_tave_air(i) = Seg_tave_air(i) / hru_area_sum(i) + Seg_melt(i) = Seg_melt(i) / hru_area_sum(i) + Seg_rain(i) = Seg_rain(i) / hru_area_sum(i) + IF ( Strmtemp_humidity_flag==0 ) then + Seg_humid(i) = Seg_humid(i) / hru_area_sum(i) + +! DANGER potential hack here: Should CBH humidity data be converted to decimal fraction in +! the CBH file? Probably so. For now, convert it here. +! Humidity coming from CBH is in percent, not decimal fraction + Seg_humid(i) = Seg_humid(i) * 0.01 + endif + ELSE +! This block for segments that don't have contributing HRUs + iseg = Seg_close(i) ! doesn't work if upstream segment + Seg_tave_air(i) = Seg_tave_air(iseg) + Seg_ccov(i) = Seg_ccov(iseg) + Seg_potet(i) = Seg_potet(iseg) + Seg_melt(i) = Seg_melt(iseg) + Seg_rain(i) = Seg_rain(iseg) + IF ( Strmtemp_humidity_flag==0 ) then + Seg_humid(i) = Seg_humid(iseg)*Seg_carea_inv(iseg) ! ?? +! DANGER Humidity coming from CBH is in percent, not decimal fraction +! Same as comment in above block + Seg_humid(i) = Seg_humid(i) * 0.01 + endif + ENDIF + ENDDO + +! Compute the running averages for groundwater and subsurface temperatures. + if (gw_index >= gw_tau(i)) then + gw_index = 1 + else + gw_index = gw_index + 1 + endif + + if (ss_index >= ss_tau(i)) then + ss_index = 1 + else + ss_index = ss_index + 1 + endif + + ! Mark all of the upstream segment temperatures as not having been computed yet. + ! If the value is something other than -100.0, then I know that it has been computed. + ! Trying to get at the differece between computed bad values and segments that have not been + ! computed yet. + seg_tave_upstream(i) = -100.0 + +! Big do loop + DO j = 1, Nsegment + i = Segment_order(j) + + ! !! LOOP BREAKS HERE !! + ! + ! If the seg_tave_water value has been set to -99.9 (in init), then this is a segment that will + ! never have streamflow because it does not have any HRUs connected to it and none of the + ! upstream segments (if there are any) have HRUs connected. Because there can never be any + ! flow, the temperature calculation will always fail, so don't bother with it. + if (Seg_tave_water(i) < -99.0) then + cycle + endif + + ! !! LOOP BREAKS HERE !! + ! + ! If the seginc_swrad value has been set to -99.9 (route_run), then this segment will + ! never have solar radiation because it does not have any HRUs connected to it and none of the + ! upstream or downstream segments have HRUs connected. + if (seginc_swrad(i) < -99.0) then + Seg_tave_water(i) = -99.9 + cycle + endif + +! GW moving average + gw_sum(i) = gw_sum(i) - gw_silo(i, gw_index) + gw_silo(i, gw_index) = Seg_tave_air(i) + gw_sum(i) = gw_sum(i) + gw_silo(i, gw_index) + seg_tave_gw(i) = gw_sum(i) / gw_tau(i) + +! SS moving average + ss_sum(i) = ss_sum(i) - ss_silo(i, ss_index) + ss_silo(i, ss_index) = Seg_tave_air(i) + ss_sum(i) = ss_sum(i) + ss_silo(i, ss_index) + seg_tave_ss(i) = ss_sum(i) / ss_tau(i) + +! Find upstream intitial inflow temperature for segment i +! i is the current segment +! k is the upstream segment + fs = 0.0 + up_temp = 0.0 + DO k = 1, Nsegment + IF ( Tosegment(k)==i ) THEN + if (Seg_tave_water(k) > -1.0) then + up_temp = up_temp + (Seg_tave_water(k) * SNGL(Seg_outflow(k))) + fs = fs + SNGL(Seg_outflow(k)) + endif + ENDIF + ENDDO + + ! Finish computing seg_tave_upstream + IF ( fs > NEARZERO) THEN + seg_tave_upstream(i) = up_temp / fs + ELSE + ! -98.9 is the code for no flow on this timestep + seg_tave_upstream(i) = -98.9 + ENDIF + +! debug + if (seg_tave_upstream(i) > 100.0) then + write(*,*) "upstream_temp: i = ", i, " seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", & + & fs, " seg_tave_water = ", Seg_tave_water(i), " troff = " , Seg_tave_air(i), " up_temp = ", up_temp + endif + + ! Compute flow-dependent water-in-segment width value + if (seg_outflow(i) > NEARZERO) then + Seg_width(i) = width_alpha(i) * sngl(Seg_outflow(i)) ** width_m(i) + else + Seg_width(i) = 0.0 + if (Seg_tave_water(i) > -99.0) then + ! This segment has upstream HRUs somewhere, but the current day's flow is zero + Seg_tave_water(i) = -98.9 + endif + endif + + ! Compute the shade on the segment. Either set by value in the parameter file or computed + IF ( Stream_temp_shade_flag==1 ) THEN + IF ( Summer_flag==0 ) THEN + seg_shade(i) = Segshade_win(i) + ELSE + seg_shade(i) = Segshade_sum(i) + ENDIF + + ! Svi = RIPARIAN VEGETATION SHADE + svi = 0.0 + ELSE + CALL shday(i, seg_shade(i), svi) + ENDIF + + ! Start working towards the computation of the equilibrium temperature + qlat = 0.0D0 + seg_tave_lat(i) = 0.0 + ak1 = 0.0 + ak2 = 0.0 + + ! Inputs: seg_tave_gw, Seg_tave_air, seg_tave_ss, seg_tave_upstream, Seg_melt, Seg_rain + ! Outputs: qlat (in CMS), seg_tave_lat + CALL lat_inflow(qlat, seg_tave_lat(i), i, seg_tave_gw(i), Seg_tave_air(i), seg_tave_ss(i), & + & Seg_melt(i), Seg_rain(i)) + + + ! This code does not handle thermodynamics of ice, so temperatures below 0 are not allowed. + ! The question is when to set temperatures below 0 to 0. If, after computing the running averages + ! and mixing the different sources of lateral flow, the temperature is less than 0, set the lateral + ! flow temperature to 0 here. + if (seg_tave_lat(i) .lt. NEARZERO) then + seg_tave_lat(i) = 0.0 + endif + +! Compute t_o +! t_o is the temperature of the water at the beginning of the time step (this is To in equation 32) + if (Seg_tave_water(i) < -99.0) then +! No flow in this segment and there never will be becuase there are no upstream HRUs. + t_o = Seg_tave_water(i) + + elseif (Seg_tave_water(i) < -98.0) then +! No flow in this segment on this time step, but could be on future time step + t_o = Seg_tave_water(i) + + elseif ((fs .le. NEARZERO) .and. (qlat .le. NEARZERO)) then + ! If there is no flow, set the temperature to -98.9 + ! -99.9 means that the segment never has any flow (determined up in init). + ! -98.9 means that this a segment that could have flow, but doesn't + Seg_tave_water(i) = -98.9 + t_o = Seg_tave_water(i) + + elseif (fs .le. NEARZERO) then + ! if this is true, then there is no flow from upstream, but there is lateral inflow + t_o = seg_tave_lat(i) + lat_temp_adj(i,Nowmonth) + + elseif (qlat .le. NEARZERO) then + ! if this is true, then there is no lateral flow, but there is flow from upstream + t_o = seg_tave_upstream(i) + + else + ! if this is true, then there is both lateral flow and flow from upstream + ! qlat is in CMS so fs needs to be converted + t_o = sngl((seg_tave_upstream(i) * fs * CFS2CMS_CONV) + & + & (sngl(qlat) * (seg_tave_lat(i) + lat_temp_adj(i,Nowmonth)))) / & + & sngl((fs * CFS2CMS_CONV) + sngl(qlat)) + endif + +! debug + if (t_o .ne. t_o) then + write(*,*) "t_o is Nan, seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & + & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) + continue + endif + +! debug + if (t_o .gt. 100.0) then + write(*,*) "this is the place: t_o = ", t_o, " ted = ", te, " seg_id = ", i + write(*,*) " seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & + & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) + write(*,*) " width = ", Seg_width(i), Nowyear, Nowmonth, Nowday + continue + exit + endif + +! Need a good value of t_o + if (t_o .gt. -98.0) then +! This block computes the value for seg_tave_water + +! Compute the equilibrium temerature + ! Out: te, ak1, ak2 + ! In: seg_shade, svi, i, t_o + CALL equilb(te, ak1, ak2, seg_shade(i), svi, i, t_o) + +! Compute the daily mean water temperature + ! In: t_o, qlat, seg_tave_lat(i), te, ak1, ak2, i, seg_width, seg_length + Seg_tave_water(i) = twavg(fs, t_o, qlat, seg_tave_lat(i), te, ak1, ak2, seg_width(i), seg_length(i)) + + else + ! bad t_o value + Seg_tave_water(i) = -98.9 + endif + ENDDO + END FUNCTION stream_temp_run +! +!********************************************************************************* +! Compute the flow-weighted average temperature and a total sum of lateral inflows +!********************************************************************************* + SUBROUTINE lat_inflow(Qlat, Tl_avg, id, tave_gw, tave_air, tave_ss, melt, rain) + USE PRMS_STRMTEMP, ONLY: Melt_temp + USE PRMS_BASIN, ONLY: CFS2CMS_CONV + USE PRMS_BASIN, ONLY: NEARZERO + USE PRMS_FLOWVARS, ONLY: Seg_lateral_inflow + USE PRMS_ROUTING, ONLY: Seginc_sroff, Seginc_ssflow, Seginc_gwflow + IMPLICIT NONE +! Functions + INTRINSIC SNGL +! Arguments + INTEGER, INTENT(IN) :: id + REAL, INTENT(IN) :: tave_gw, tave_air, tave_ss, melt, rain + REAL, INTENT(OUT) :: Tl_avg + DOUBLE PRECISION, INTENT(OUT) :: Qlat +! Local Variables + REAL :: weight_roff, weight_ss, weight_gw, melt_wt, rain_wt, troff, tss + INTRINSIC ABS +!***************************************************************************** + + Qlat = Seg_lateral_inflow(id) * CFS2CMS_CONV + Tl_avg = 0.0 + IF ( Qlat>0.0D0 ) THEN ! weights do not include water-use if active, not sure it works for cascades + weight_roff = SNGL( (Seginc_sroff(id) / Qlat) * CFS2CMS_CONV ) + weight_ss = SNGL( (Seginc_ssflow(id) / Qlat) * CFS2CMS_CONV ) + weight_gw = SNGL( (Seginc_gwflow(id) / Qlat) * CFS2CMS_CONV ) + ELSE + weight_roff = 0.0 + weight_ss = 0.0 + weight_gw = 0.0 + ENDIF + + IF (melt > 0.0) THEN + melt_wt = melt/(melt + rain) + IF (melt_wt < 0.0) melt_wt = 0.0 + IF (melt_wt > 1.0) melt_wt = 1.0 + rain_wt = 1.0 - melt_wt + IF (rain == 0.0) THEN + troff = Melt_temp + tss = Melt_temp + ELSE + troff = Melt_temp * melt_wt + tave_air * rain_wt + tss = Melt_temp * melt_wt + tave_ss * rain_wt + ENDIF + ELSE + troff = tave_air + tss = tave_ss + ENDIF + + Tl_avg = weight_roff * troff + weight_ss * tss + weight_gw * tave_gw + + END SUBROUTINE lat_inflow + +!*********************************************************************************************** + REAL FUNCTION twavg(qup, T0, Qlat, Tl_avg, Te, Ak1, Ak2, width, length) +! +! PURPOSE: +! 1. TO PREDICT THE AVERAGE DAILY WATER TEMPERATURE USING A SECOND-ORDER +! CLOSED-FORM SOLUTION TO THE STEADY-STATE HEAT TRANSPORT EQUATION. + USE PRMS_BASIN, ONLY: NEARZERO, CFS2CMS_CONV + IMPLICIT NONE +! Functions + INTRINSIC ABS, EXP, ALOG, SNGL, SIGN +! Arguments + REAL, INTENT(IN) :: T0, Tl_avg, Te, Ak1, Ak2, width, length, qup + DOUBLE PRECISION, INTENT(IN) :: Qlat +! Local Variables + REAL :: tep, b, r, rexp, tw, delt, q_init, denom, Ql +!*************************************************************************************************** +! DETERMINE EQUATION PARAMETERS + q_init = sngl(qup * CFS2CMS_CONV) + Ql = SNGL( Qlat ) + +! This is confused logic coment out here and compute the terms as needed below +! b = (Ql / Seg_length) + ((Ak1 * Seg_width) / 4182.0E03) +! IF ( b < NEARZERO ) b = NEARZERO ! rsr, don't know what value this should be to avoid divide by 0 +! r = 1.0 + (Ql / q_init) +! IF ( r < NEARZERO ) r = NEARZERO + + IF (Ql <= NEARZERO ) THEN +! +! ZERO LATERAL FLOW + tep = Te + b = (Ak1 * width) / 4182.0E03 + rexp = -1.0*(b * length) / q_init + r = EXP(rexp) + +! LOSING STREAM +! No such thing as losing streams in PRMS + ELSEIF ( Ql < 0.0 ) THEN + write(*,*) "twavg: losing stream!!! Should be no such thing in PRMS!" + tep = Te + b = (Ql / length) + ((Ak1 * width) / 4182.0E03) + rexp = (Ql - (b * length)) / Ql + r = 1.0 + (Ql / q_init) + r = r**rexp +! +! This is a headwaters (i.e. no streamflow from above, but lateral flow from HRUs. +! Treat the lateral flow as upstream flow to avoid divide by zero + ELSEIF ( Ql > NEARZERO .and. q_init <= NEARZERO ) THEN + tep = Te + b = (Ak1 * width) / 4182.0E03 +! rexp = -1.0*(b * length) / q_init + rexp = -1.0*(b * length) / Ql + r = EXP(rexp) +! +! GAINING STREAM (ie both ql and q_init have > zero values) + ELSE + b = (Ql / length) + ((Ak1 * width) / 4182.0E03) + tep = (((Ql / length) * Tl_avg) + (((Ak1 * width) / (4182.0E03)) * Te)) / b + +! shouldn't need to do this because Ql will always be greater than 0 if in here. + IF ( Ql > 0.0 ) THEN + rexp = -b / (Ql / length) + ELSE + rexp = 0.0 + ENDIF + +! DANGER -- replaced this potential divide by zero with the logic below +! r = 1.0 + (Ql / q_init) + if (q_init < NEARZERO) then + r = 2.0 + else + r = 1.0 + (Ql / q_init) + endif + r = r**rexp + +! END LATERAL FLOW TERM LOGIC + ENDIF +! +! DETERMINE WATER TEMPERATURE + delt = tep - T0 + denom = (1.0 + (Ak2 / Ak1) * delt * (1.0 - r)) + IF ( ABS(denom) < NEARZERO ) denom = SIGN(NEARZERO, denom) + tw = tep - (delt * r / denom) + IF ( tw < 0.0 ) tw = 0.0 + + twavg = tw + END FUNCTION twavg +! +!******************************************************************************* +! "equilb" +!******************************************************************************* + SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) +! +! PURPOSE: +! 1. DETERMINE THE AVERAGE DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS +! 2. DETERMINE THE MAXIMUM DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS + + USE PRMS_STRMTEMP, ONLY: ZERO_C, Seg_width, Seg_humid, Press, MPS_CONVERT, & + & Seg_ccov, Seg_slope, Seg_potet, Albedo, seg_tave_gw + USE PRMS_BASIN, ONLY: NEARZERO, CFS2CMS_CONV + USE PRMS_FLOWVARS, ONLY: Seg_inflow + USE PRMS_ROUTING, ONLY: Seginc_swrad + IMPLICIT NONE +! Functions + INTRINSIC EXP, SQRT, ABS, SNGL, DBLE + EXTERNAL :: teak1 + REAL, EXTERNAL :: sat_vapor_press_poly +! Arguments: + REAL, INTENT(OUT) :: Ted + REAL, INTENT(OUT) :: Ak1d, Ak2d + REAL, INTENT(IN) :: Sh, Svi + INTEGER, INTENT(IN) :: Seg_id + REAL, INTENT(IN) :: t_o +! Local Variables: !RSR, maybe declare enegry balance fluxes + DOUBLE PRECISION :: ha, hv, taabs + REAL :: hf, hs, b, c, d, delt, del_ht, ltnt_ht, bow_coeff + REAL :: hnet, vp_sat, sw_power, evap, q_init + REAL, PARAMETER :: AKZ = 1.65, A = 5.40E-8, RAD_CONVERT = 41840.0/86400.0 + REAL :: foo +! ******************************************************************************* + + taabs = DBLE( t_o + ZERO_C ) + vp_sat = 6.108 * EXP(17.26939 * t_o/(t_o + 237.3)) + +! +! Convert units and set up parameters + q_init = SNGL( Seg_inflow(Seg_id) * CFS2CMS_CONV ) + IF ( q_init < NEARZERO ) q_init = NEARZERO + + ! sw_power should be in watts / m2 + ! seginc_swrad is in langly / day + ! Used to use RAD_CONVERT, the conversion I'm using now is a slightly different number. + sw_power = 11.63 / 24.0 * sngl(seginc_swrad(seg_id)) + + del_ht = 2.36E06 ! could multiple by 10E6 for this and other terms later to reduce round-off + ltnt_ht = 2495.0E06 + +! If humidity is 1.0, there is a divide by zero below. + if (Seg_humid(Seg_id) > 0.99) then + foo = 0.99 + else + foo = Seg_humid(Seg_id) + endif + + bow_coeff = (0.00061 * Press(Seg_id))/(vp_sat * (1.0 - foo)) + evap = SNGL( Seg_potet(Seg_id) * MPS_CONVERT ) +! +! HEAT FLUX COMPONENTS + ! document - ha = (1-rl)(1-sh)(1+0.17Cl**2)(0.61+0.05*SQRT(vp_sat)*stefan(Ta+273.16)**4 + + ha = ( (3.354939D-8 + 2.74995D-9 * DBLE(SQRT(Seg_humid(Seg_id) * vp_sat))) * DBLE((1.0 - Sh) & + & * (1.0 + (0.17*(Seg_ccov(Seg_id)**2)))) ) * (taabs**4) + +! hf is heat from stream friction. See eqn. 14. q_init is in CMS + hf = 9805.0 * (q_init/Seg_width(Seg_id)) * Seg_slope(Seg_id) + hs = (1.0 - sh) * sw_power * (1.0 - Albedo) + hv = 5.24D-8 * DBLE(Svi) * (taabs**4) + +! Stefan-Boltzmann constant = 5.670373D-08; emissivity of water = 0.9526, times each other: 5.4016D-08 +! hw = water-emitted longwave radiation +! hw = 5.4016D-08 * (taabs**4) hw is include in other computations +! +! DETERMINE EQUILIBIRIUM COEFFICIENTS + b = bow_coeff * evap * (ltnt_ht + (del_ht * t_o)) + AKZ - (del_ht * evap) + c = bow_coeff * del_ht * evap + d = (SNGL(ha + hv) + hf + hs) + (ltnt_ht * evap * ((bow_coeff * t_o) - 1.0) + (seg_tave_gw(Seg_id) * AKZ)) + +! +! DETERMINE EQUILIBRIUM TEMPERATURE & 1ST ORDER THERMAL EXCHANGE COEF. + Ted = t_o + + CALL teak1(A, b, c, d, Ted, Ak1d) + +! +! DETERMINE 2ND ORDER THERMAL EXCHANGE COEFFICIENT + hnet = (A * ((t_o + ZERO_C)**4)) + (b * t_o) - (c * (t_o**2.0)) - d + delt = t_o - Ted + + IF ( ABS(delt) < NEARZERO) THEN + Ak2d = 0.0 + ELSE + Ak2d = ((delt * Ak1d) - hnet) / (delt**2) + ENDIF +! +! RETURN TO STREAMTEMP FUNCTION + END SUBROUTINE equilb + +!********************************************************************************** +! "teak1" +!********************************************************************************** + SUBROUTINE teak1(A, B, C, D, Teq, Ak1c) +! PURPOSE: +! 1. TO DETERMINE THE EQUILIBRIUM WATER TEMPERATURE FROM THE ENERGY BALANCE +! EQUATION BY ITERATING NEWTON'S METHOD +! 2. TO DETERMINE THE 1ST THERMAL EXCHANGE COEFFICIENT. + USE PRMS_STRMTEMP, ONLY: ZERO_C, Maxiter_sntemp + USE PRMS_BASIN, ONLY: NEARZERO +! USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday + IMPLICIT NONE + INTRINSIC ABS +! Arguments + REAL, INTENT(IN) :: A, B, C, D + REAL, INTENT(INOUT) :: Teq + REAL, INTENT(OUT) :: Ak1c +! Local variables + REAL :: teabs, fte, fpte, delte + INTEGER :: kount +! Parameters + ! SOLUTION CONVERGENCE TOLERANCE + REAL, PARAMETER :: TOLRN = 1.0E-4 +!********************************************************************************** + fte = 99999.0 ! rsr, fte was not set + delte = 99999.0 ! rsr, delte was not set + kount = 0 + +! BEGIN NEWTON ITERATION SOLUTION FOR TE + DO kount = 1, Maxiter_sntemp + IF ( ABS(fte) < TOLRN ) EXIT + IF ( ABS(delte) < TOLRN ) EXIT + teabs = Teq + ZERO_C + fte = (A * (teabs**4.0)) + (B * Teq) - (C * (Teq**2.0)) - D + fpte = (4.0 * A * (teabs**3.0)) + B - (2.0 * C * Teq) + delte = fte / fpte + Teq = Teq - delte + ENDDO + +! DETERMINE 1ST THERMAL EXCHANGE COEFFICIENT + Ak1c = (4.0 * A * ((Teq + ZERO_C)**3.0)) + B - (2.0 * C * Teq) +! +! RETURN TO 'EQUILB' SUBROUTINE + END SUBROUTINE teak1 + +! "shday" *********************************************************** + SUBROUTINE shday(Seg_id, Shade, Svi) +! +! THIS SUBPROGRAM IS TO CALCULATE THE TOTAL DAILY SHADE FOR A +! GIVEN REACH. BOTH TOPOGRAPHIC AND RIPARIAN VEGETATION SHADE +! IS INCLUDED. +! +! VARIABLE NAME LIST +! +! Als = CURRENT SOLAR ALTITUDE +! Alrs = SOLAR ALTITUDE WHEN SOLAR & REACH AZIMUTHS ARE EQUAL +! Alsmx = MAXIMUM POSSIBLE SOLAR ALTITUDE +! Alsr = LOCAL SUNRISE SOLAR ALTITUDE ! rsr, not used +! Alss = LOCAL SUNSET SOLAR ALTITUDE ! rsr, not used +! Alt = CURRENT TOPOGRAPHIC ALTITUDE +! Alte = EAST SIDE MAXIMUM TOPOGRAPHIC ALTITUDE +! Altmx = CURRENT MAXIMUM TOPOGRAPHIC ALTITUDE LIMIT +! Altop = CURRENT TOPOGRAPHIC ALTITUDE +! Altw = WEST SIDE MAXIMUM TOPOGRAPHIC ALTITUDE +! Azrh = STREAM REACH AZIMUTH +! Azs = CURRENT SOLAR AZIMUTH +! Azsr = LOCAL SUNRISE SOLAR AZIMUTH ! rsr, not used +! Azss = LOCAL SUNSET SOLAR AZIMUTH ! rsr, not used +! Azso = LEVEL-PLAIN SUNSET AZIMUTH +! Bavg = AVERAGE STREAM WIDTH +! Bs = SHADED PART OF STREAM WIDTH +! Cosas = COS(AS) +! Cosd = COS(DECL) +! Coshs = COS(HS) +! Coso = COS(XLAT) +! Cosod = COS(XLAT)*COS(DECL) +! Dayrad = CONVERSION RATIO FOR JULIAN DAYS TO RADIANS +! Decl = CURRENT SOLAR DECLINATION +! Delhsr = SUNRISE SIDE HOUR ANGLE INCREMENT +! Delhss = SUNSET SIDE HOUR ANGLE INCREMENT +! Hrrs = REACH HOUR ANGLE WHEN SOLAR & REACH AZIMUTHS ARE EQUAL +! Hrs = CURRENT SOLAR HOUR ANGLE +! Hrsr = LOCAL SUNRISE SOLAR HOUR ANGLE +! Hrss = LOCAL SUNSET SOLAR HOUR ANGLE +! Hrso = LEVEL-PLAIN SUNRISE/SET SOLAR HOUR ANGLE +! Nbhs = NUMBER OF SUNRISE/SET HOUR ANGLE INCREMENTS +! Shday = TOTAL DAILY SHADE +! Sinal = SIN(Al) +! Sinar = SIN(Ar) +! Sin_d = SIN(DECL) +! Sinhsr = SIN(Hrsr) +! Sinhss = SIN(Hrss) +! Sinhro = SIN(Hrso) +! Sino = SIN(XLAT) +! Sinod = SIN(XLAT)*SIN(DECL) +! Snflag = SOLAR NOON LIMIT FLAG +! Sti = TOPOGRAPHIC SHADE +! Svi = RIPARIAN VEGETATION SHADE +! Svri = SUNRISE VEGETATIVE SHADE +! Svsi = SUNSET VEGETATIVE SHADE +! Tanasr = TAN(Alsr) +! Tanass = TAN(Alss) +! Tanalt = TAN(Alt) +! Tano = TAN(XLAT) +! Tanod = TAN(XLAT)*TAN(DECL) +! Totsh = LEVEL-PLAIN TOTAL SHADE POTENTIAL +! Tolrn = CONVERGENCE TOLERANCE CRITERIA +! Flgrs = SUNRISE FLAG; TRUE IF SUNRISE, FALSE IF SUNSET +! Flgst = SUNSET FLAG; TRUE IF SUNSET, FALSE IF SUNRISE +! Vc = CROWN DIAMETER, CURRENT VEGETATION +! Vce = CROWN DIAMETER, EAST SIDE VEGETATION +! Vco = CURRENT VEGETATION OVERHANG +! Vcw = CROWN DIAMETER, WEST SIDE VEGETATION +! Vd = DENSITY, CURRENT VEGETATION +! Vde = DENSITY, EAST SIDE VEGETATION +! Vdw = DENSITY, WEST SIDE VEGETATION +! Vh = HEIGHT, CURRENT VEGETATION +! Vhe = HEIGHT, EAST SIDE VEGETATION +! Vhw = HEIGHT, WEST SIDE VEGETATION +! Vo = OFFSET, CURRENT VEGETATION +! Voe = OFFSET, EAST SIDE VEGETATION +! Vow = OFFSET, WEST SIDE VEGETATION +! + USE PRMS_SET_TIME, ONLY: Jday + USE PRMS_STRMTEMP, ONLY: Azrh, Alte, Altw, Seg_daylight, Seg_width, & + & PI, HALF_PI, Cos_seg_lat, Sin_seg_lat, Cos_lat_decl, Horizontal_hour_angle, & + & Level_sunset_azimuth, Max_solar_altitude, Sin_alrs, Sin_declination, Sin_lat_decl, Total_shade + USE PRMS_BASIN, ONLY: CFS2CMS_CONV + IMPLICIT NONE +! Functions + INTRINSIC COS, SIN, TAN, ACOS, ASIN, ATAN, ABS, MAX, SNGL + REAL, EXTERNAL:: solalt, rprnvg + EXTERNAL snr_sst +! Arguments + INTEGER, INTENT(IN) :: Seg_id + REAL, INTENT(OUT):: Shade, Svi +! Local Variables + REAL :: coso, cosod, sin_d, sino, sinod + REAL :: altmx, alsmx, als, almn, almx + REAL :: azso, azmn, azmx, azs, hrrs, hrsr, hrss, hrso, hrs, hrrh + REAL :: temp, totsh, sti + REAL :: altop(3), aztop(3) +! PARAMETER + REAL, PARAMETER :: RADTOHOUR = 24.0/(2.0 * PI) +!********************************************************************************* + +! LATITUDE TRIGONOMETRIC PARAMETERS + coso = Cos_seg_lat(Seg_id) + sino = Sin_seg_lat(Seg_id) + sin_d = Sin_declination(Jday, Seg_id) + sinod = Sin_lat_decl(Jday, Seg_id) + cosod = Cos_lat_decl(Jday, Seg_id) +! +! INITIALIZE LOCAL SUNRISE/SET SOLAR PARAMETERS + hrsr = 0.0 + hrss = 0.0 +! +! MAXIMUM POSSIBLE SOLAR ALTITUDE + alsmx = Max_solar_altitude(Jday, Seg_id) +! +! LEVEL-PLAIN SUNRISE/SET HOUR ANGLE + hrso = Horizontal_hour_angle(Jday, Seg_id) +! +! LEVEL-PLAIN SOLAR AZIMUTH + azso = Level_sunset_azimuth(Jday, Seg_id) +! +! TOTAL POTENTIAL SHADE ON LEVEL-PLAIN + totsh = Total_shade(Jday, Seg_id) +! +! CHECK FOR REACH AZIMUTH LESS THAN SUNRISE + IF ( Azrh(Seg_id) <= (-azso) ) THEN + hrrs = -hrso +! +! CHECK FOR REACH AZIMUTH GREATER THAN SUNSET + ELSEIF ( Azrh(Seg_id) >= azso ) THEN + hrrs = hrso +! +! REACH AZIMUTH IS BETWEEN SUNRISE & SUNSET + ELSEIF ( Azrh(Seg_id) == 0.0 ) THEN + hrrs = 0.0 + ELSE + temp = (Sin_alrs(Jday, Seg_id) - sinod) / cosod + IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0,temp) + hrrs = SIGN(ACOS(temp), Azrh(Seg_id)) +! +! END REACH & SOLAR AZIMUTH CHECK + ENDIF +! +! CHECK IF LEVEL-PLAIN + IF ( (Alte(Seg_id) == 0.0 ) .AND. (Altw(Seg_id) == 0.0) ) THEN +! azsr = -azso + hrsr = -hrso +! azss = azso + hrss = hrso + sti = 0.0 + Svi = (rprnvg(hrsr, hrrs, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width(Seg_id) * totsh) + + ELSE +! INITIALIZE SHADE VALUES +! +! INSERT STARTING TOPOGRAPHIC AZIMUTH VALUES BETWEEN LEVEL PLAIN SUNRISE AND SUNSET + aztop = 0.0 +! +! DETERMINE SUNRISE HOUR ANGLE. + altop = 0.0 + IF ( -azso <= Azrh(Seg_id) ) THEN + altop(1) = Alte(Seg_id) + aztop(1) = azso*(Alte(Seg_id)/HALF_PI) - azso + ELSE + altop(1) = Altw(Seg_id) + aztop(1) = azso*(Altw(Seg_id)/HALF_PI) - azso + ENDIF +! LEVEL PLAIN + IF (altop(1) == 0.0) THEN + hrsr = -hrso +! NOT + ELSE +! LOOK FOR SOLUTION BETWEEN LIMITS OF LEVEL PLAIN SUNRISE AND NOON + azmn = -azso + azmx = 0.0 + azs = aztop(1) + altmx = altop(1) + almn = 0.0 + almx = 1.5708 + als = solalt(coso, sino, sin_d, azs, almn, almx) + CALL snr_sst(coso, sino, sin_d, altmx, almn, almx, azmn, azmx, azs, als, hrs, Seg_id) +! azsr = azs +! alsr = als + hrsr = hrs +! altr = altmx + ENDIF +! +! DETERMINE SUNSET HOUR ANGLE. + IF ( azso <= Azrh(Seg_id) )THEN + altop(2) = Alte(Seg_id) + aztop(2) = azso - azso*(Alte(Seg_id)/HALF_PI) + ELSE + altop(2) = Altw(Seg_id) + aztop(2) = azso - azso*(Altw(Seg_id)/HALF_PI) + ENDIF +! LEVEL PLAIN + IF (altop(2) == 0.0) THEN + hrss = hrso +! NOT + ELSE +! LOOK FOR SOLUTION BETWEEN LIMITS OF NOON AND LEVEL PLAIN SUNSET + azmn = 0.0 + azmx = azso + azs = aztop(2) + altmx = altop(2) + almn = 0.0 + almx = 1.5708 + als = solalt(coso, sino, sin_d, azs, almn, almx) + CALL snr_sst(coso, sino, sin_d, altmx, almn, almx, azmn, azmx, azs, als, hrs, Seg_id) +! azss = azs +! alss = als + hrss = hrs +! alts = altmx + ENDIF +! +! SOLVE FOR SHADE INCREMENTS THIS SEGMENT + IF ( hrrs < hrsr ) THEN + hrrh = hrsr + ELSEIF ( hrrs > hrss ) THEN + hrrh = hrss + ELSE + hrrh = hrrs + ENDIF + + Seg_daylight(Seg_id) = (hrss - hrsr) * RADTOHOUR + sti = 1.0 - ((((hrss - hrsr) * sinod) + ((SIN(hrss) - SIN(hrsr)) * cosod)) / (totsh)) + Svi = ((rprnvg(hrsr, hrrh, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width(Seg_id)*totsh)) +! +! END SUNRISE/SUNSET CALCULATION + ENDIF +! +! CHECK FOR ROUNDOFF ERRORS + IF ( sti < 0.0 ) sti = 0.0 + IF ( sti > 1.0 ) sti = 1.0 + IF ( Svi < 0.0 ) Svi = 0.0 + IF ( Svi > 1.0 ) Svi = 1.0 +! +! RECORD TOTAL SHADE + Shade = sti + Svi + + END SUBROUTINE shday +! +!********************************************************************************************************** +! "snr_sst" + SUBROUTINE snr_sst (Coso, Sino, Sin_d, Alt, Almn, Almx, Azmn, Azmx, Azs, Als, Hrs, Seg_id) +! +! THIS SUBPROGRAM DETERMINES THE LOCAL SOLAR SUNRISE/SET +! AZIMUTH, ALTITUDE, AND HOUR ANGLE +! + USE PRMS_STRMTEMP, ONLY: Azrh, PI, Maxiter_sntemp + USE PRMS_BASIN, ONLY: NEARZERO + IMPLICIT NONE +! Functions + INTRINSIC TAN, SIN, COS, ACOS, ASIN, ABS +! Arguments + INTEGER, INTENT(IN):: Seg_id + REAL, INTENT(IN):: Coso, Sino, Sin_d, Alt, Almn, Almx, Azmn, Azmx + REAL, INTENT(INOUT):: Azs, Als + REAL, INTENT(OUT):: Hrs +! Local Variables + REAL :: cosazs, sinazs, sinazr, cosazr, cosals, f, g, fazs, fals, gazs, gals, xjacob + REAL :: sinals, tanalt, tano, tanals, temp, delazs, delals + INTEGER :: count +!*********************************************************************************************************** +! TRIG FUNCTION FOR LOCAL ALTITUDE + tanalt = TAN(Alt) + tano = Sino / Coso + f = 999999.0 !rsr, these need values + delazs = 9999999.0 + g = 99999999.0 + delals = 99999999.0 + +! BEGIN NEWTON-RAPHSON SOLUTION + DO count = 1, Maxiter_sntemp + IF ( ABS(delazs) < NEARZERO ) EXIT + IF ( ABS(delals) < NEARZERO ) EXIT + IF ( ABS(f) < NEARZERO ) EXIT + IF ( ABS(g) < NEARZERO ) EXIT + + cosazs = COS(Azs) + sinazs = SIN(Azs) + + sinazr = ABS(SIN(Azs - Azrh(Seg_id))) + IF ( (((Azs-Azrh(Seg_id)) <= 0.0 ) .AND. ((Azs-Azrh(Seg_id)) <= (-PI))) .OR. & + & (((Azs-Azrh(Seg_id)) > 0.0 ) .AND. ((Azs-Azrh(Seg_id)) <= PI)) ) THEN + cosazr = COS(Azs-Azrh(Seg_id)) + ELSE + cosazr = -COS(Azs-Azrh(Seg_id)) + ENDIF + + cosals = COS(Als) + IF ( cosals < NEARZERO ) cosals = NEARZERO + sinals = SIN(Als) + tanals = sinals / cosals +! FUNCTIONS OF AZS & ALS + f = cosazs- (((Sino * sinals) - Sin_d) / (Coso * cosals)) + g = tanals - (tanalt * sinazr) +! FIRST PARTIALS DERIVATIVES OF F & G + fazs = -sinazs + fals = ((tanals * (Sin_d / Coso)) - (tano / cosals)) / cosals + gazs = -tanalt * cosazr + gals = 1.0 / (cosals * cosals) +! JACOBIAN + xjacob = (fals * gazs) - (fazs * gals) +! DELTA CORRECTIONS + delazs = ((f * gals) - (g * fals)) / xjacob + delals = ((g * fazs) - (f * gazs)) / xjacob +! NEW VALUES OF AZS & ALS + Azs = Azs + delazs + Als = Als + delals +! CHECK FOR LIMITS + IF ( Azs < (Azmn + NEARZERO) ) Azs = (Azmn + NEARZERO) + IF ( Azs > (Azmx - NEARZERO) ) Azs = (Azmx - NEARZERO) + IF ( Als < (Almn + NEARZERO) ) Als = (Almn + NEARZERO) + IF ( Als > (Almx - NEARZERO) ) Als = (Almx - NEARZERO) + ENDDO +! +! ENSURE AZIMUTH REMAINS BETWEEN -PI & PI + IF ( Azs < (-PI) ) THEN + Azs = Azs + PI + ELSEIF ( Azs > PI) THEN + Azs = Azs - PI + ENDIF +! +! DETERMINE LOCAL SUNRISE/SET HOUR ANGLE + sinals = SIN(Als) + temp = (sinals - (Sino * Sin_d)) / (Coso * COS(ASIN(Sin_d))) + IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0,temp) + Hrs = SIGN(ACOS(temp), Azs) + + END SUBROUTINE snr_sst + +!***************************************************************************** +! "solalt" + REAL FUNCTION solalt (Coso, Sino, Sin_d, Az, Almn, Almx) +! +! THIS SUBPROGRAM IS TO DETERMINE THE SOLAR ALTITUDE WHEN THE +! TRIGONOMETRIC PARAMETERS FOR LATITUDE, DECLINATION, AND AZIMUTH +! ARE GIVEN. +! +! VARIABLE NAME LIST +! +! Al = TRIAL SOLAR ALTITUDE +! AZ = SOLAR AZIMUTH +! COSAL = COS(AL) +! COSAZ = COS(AZ) +! Coso = COS(XLAT) +! DELAL = INCREMENTAL CORRECTION TO AL +! FAL = FUNCTION OF AL +! FPAL = FIRST DERIVATIVE OF FAL +! FPPAL = SECOND DERIVATIVE OF FAL +! Sin_d = SIN(DECL) +! Sino = SIN(XLAT) + USE PRMS_STRMTEMP, ONLY: HALF_PI, Maxiter_sntemp + USE PRMS_BASIN, ONLY: NEARZERO + IMPLICIT NONE +! Functions + INTRINSIC ASIN, ABS, COS, SIN +! Arguments + REAL, INTENT(IN):: Coso, Sino, Sin_d, Az, Almn, Almx +! Local Variables + REAL :: cosal, sinal, fal, fpal, fppal, al, alold, delal, a, b, cosaz, temp + INTEGER :: kount +!************************************************************************************* +! +! CHECK COS(AZ) EQUAL TO 0 + IF ( ABS(ABS(Az) - HALF_PI) < NEARZERO ) THEN + temp = ABS(Sin_d / Sino) + IF ( temp > 1.0 ) temp = 1.0 + Al = ASIN(temp) + ELSE +! +! DETERMINE SOLAR ALTITUDE FUNCTION COEFFICIENTS + cosaz = COS(Az) + a = Sino / (cosaz * Coso) + b = Sin_d / (cosaz * Coso) +! +! INITIALIZE + al = (Almn + Almx) / 2.0 + kount = 0 + fal = COS(al) - (a * SIN(al)) + b + delal = fal/(-SIN(al) - (a * COS(al))) +! +! BEGIN NEWTON SECOND-ORDER SOLUTION + DO kount = 1, Maxiter_sntemp + IF ( ABS(fal) < NEARZERO ) EXIT + IF ( ABS(delal) < NEARZERO ) EXIT + alold = al + cosal = COS(al) + sinal = SIN(al) + fal = cosal - (a * sinal) + b + fpal = -sinal - (a * cosal) + IF ( kount <= 3 ) THEN + delal = fal / fpal + ELSE + fppal = b - fal + delal = (2.0 * fal * fpal) / ((2.0 * fpal * fpal) - (fal * fppal)) + ENDIF + al = al - delal + IF (al < Almn) al = (alold + Almn) / 2.0 + IF (al > Almx) al = (alold + Almx) / 2.0 + ENDDO + ENDIF +! +! SOLUTION OBTAINED + solalt = al + + END FUNCTION solalt + +!*********************************************************************** + REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) +! +! THIS SUBPROGRAM IS TO COMPUTE THE RIPARIAN VEGETATION SHADE +! SEGMENT BETWEEN THE TWO HOUR ANGLES HRSR & HRSS. +! + USE PRMS_STRMTEMP, ONLY: Azrh, Vce, Vdemx, Vhe, Voe, Vcw, Vdwmx, Vhw, Vow, Seg_width, & + & Vdemn, Vdwmn, HALF_PI + USE PRMS_BASIN, ONLY: NEARZERO + USE PRMS_SET_TIME, ONLY: Summer_flag + IMPLICIT NONE +! Functions + INTRINSIC COS, SIN, ASIN, ACOS, ABS +! Arguments + REAL, INTENT(IN) :: Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod + INTEGER, INTENT(IN):: Seg_id +! Local Variables + REAL :: svri, svsi, hrs, vco, delhsr, coshrs + REAL :: sinhrs, temp, als, cosals, sinals, azs, bs, delhss + INTEGER :: n +! Parameters + INTEGER, PARAMETER :: NBHS = 15 + DOUBLE PRECISION, SAVE :: Epslon(15), Weight(15) + DATA Epslon / .006003741, .031363304, .075896109, .137791135, .214513914, & + & .302924330, .399402954, .500000000, .600597047, .697075674, & + & .785486087, .862208866, .924103292, .968636696, .993996259 / + DATA Weight / .015376621, .035183024, .053579610, .069785339, .083134603, & + & .093080500, .099215743, .101289120, .099215743, .093080500, & + & .083134603, .069785339, .053579610, .035183024, .015376621 / +!****************************************************************************** +! ****************** Determine seasonal shade +! +! CKECK FOR NO SUNRISE + IF ( Hrsr == Hrss ) THEN + svri = 0.0 + svsi = 0.0 + + ELSE +! +! VEGETATIVE SHADE BETWEEN SUNRISE & REACH HOUR ANGLES + svri = 0.0 + IF ( Hrsr < Hrrs ) THEN + vco = ( Vce(Seg_id)/2.0 ) - Voe(Seg_id) +! +! DETERMINE SUNRISE SIDE HOUR ANGLE INCREMENT PARAMETERS + delhsr = Hrrs - Hrsr +! +! PERFORM NUMERICAL INTEGRATION + DO n = 1, NBHS +! CURRENT SOLAR HOUR ANGLE + hrs = SNGL(Hrsr + (Epslon(n) * delhsr)) + coshrs = COS(hrs) + sinhrs = SIN(hrs) +! CURRENT SOLAR ALTITUDE + temp = Sinod + (Cosod * coshrs) + IF ( temp > 1.0 ) temp = 1.0 + als = ASIN(temp) + cosals = COS(als) + sinals = SIN(als) + IF ( sinals == 0.0 ) sinals = NEARZERO +! CURRENT SOLAR AZIMUTH + temp = ((Sino * sinals) - Sin_d) / (Coso * cosals) + IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0, temp) + azs = ACOS(temp) + IF ( azs < 0.0 ) azs = HALF_PI - azs + IF ( hrs < 0.0 ) azs = -azs +! DETERMINE AMOUNT OF STREAM WIDTH SHADED + bs = ((Vhe(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco + IF ( bs < 0.0 ) bs = 0.0 + IF ( bs > Seg_width(Seg_id) ) bs = Seg_width(Seg_id) +! INCREMENT SUNRISE SIDE VEGETATIVE SHADE + IF ( Summer_flag == 1 ) THEN ! put back spring and autumn + svri = svri + SNGL(Vdemx(Seg_id) * bs * sinals * Weight(n)) + ELSE + svri = svri + SNGL(Vdemn(Seg_id) * bs * sinals * Weight(n)) + ENDIF + ENDDO +! + svri = svri * delhsr + ENDIF +! +! VEGETATIVE SHADE BETWEEN REACH & SUNSET HOUR ANGLES + svsi = 0.0 + IF ( Hrss > Hrrs ) THEN + vco = (Vcw(Seg_id)/2.0 ) - Vow(Seg_id) +! +! DETERMINE SUNSET SIDE HOUR ANGLE INCREMENT PARAMETERS + delhss = Hrss - Hrrs +! +! PERFORM NUMERICAL INTEGRATION + DO n = 1, Nbhs +! CURRENT SOLAR HOUR ANGLE + hrs = SNGL(Hrrs + (Epslon(n) * delhss)) + coshrs = COS(hrs) + sinhrs = SIN(hrs) +! CURRENT SOLAR ALTITUDE + temp = Sinod + (Cosod * coshrs) + IF ( temp > 1.0 ) temp = 1.0 + als = ASIN(temp) + cosals = COS(als) + sinals = SIN(als) + IF ( sinals == 0.0 ) sinals = NEARZERO +! CURRENT SOLAR AZIMUTH + temp = ((Sino * sinals) - Sin_d) / (Coso * cosals) + IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0, temp) + azs = ACOS(temp) + IF ( azs < 0.0 ) azs = HALF_PI - azs + IF ( hrs < 0.0 ) azs = -azs +! DETERMINE AMOUNT OF STREAM WIDTH SHADED + bs = ((Vhw(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco + IF ( bs < 0.0 ) bs = 0.0 + IF ( bs > Seg_width(Seg_id) ) bs = Seg_width(Seg_id) +! INCREMENT SUNSET SIDE VEGETATIVE SHADE + IF ( Summer_flag == 1 ) THEN ! fix for seasons + svsi = SNGL(svsi + (Vdwmx(Seg_id) * bs * sinals * Weight(n))) + ELSE + svsi = SNGL(svsi + (Vdwmn(Seg_id) * bs * sinals * Weight(n))) + ENDIF + ENDDO + svsi = svsi * delhss + ENDIF + ENDIF + +! COMBINE SUNRISE/SET VEGETATIVE SHADE VALUES + rprnvg = svri + svsi + + END FUNCTION rprnvg + +!*********************************************************************** +! stream_temp_restart - write or read stream_temp restart file +!*********************************************************************** + SUBROUTINE stream_temp_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_STRMTEMP + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variable + CHARACTER(LEN=11) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Seg_tave_water + WRITE ( Restart_outunit ) gw_silo + WRITE ( Restart_outunit ) ss_silo + WRITE ( Restart_outunit ) gw_sum + WRITE ( Restart_outunit ) ss_sum + WRITE ( Restart_outunit ) gw_index + WRITE ( Restart_outunit ) ss_index + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Seg_tave_water + READ ( Restart_inunit ) gw_silo + READ ( Restart_inunit ) ss_silo + READ ( Restart_inunit ) gw_sum + READ ( Restart_inunit ) ss_sum + READ ( Restart_inunit ) gw_index + READ ( Restart_inunit ) ss_index + ENDIF + END SUBROUTINE stream_temp_restart diff --git a/prms/strmflow_in_outCopy.f90 b/prms/strmflow_in_outCopy.f90 new file mode 100644 index 00000000..93a1ebe9 --- /dev/null +++ b/prms/strmflow_in_outCopy.f90 @@ -0,0 +1,108 @@ +!*********************************************************************** +! Routes water between segments in the system as inflow equals outflow +!*********************************************************************** + INTEGER FUNCTION strmflow_in_out() + USE PRMS_MODULE, ONLY: Process, Nsegment, Print_debug + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_BASIN, ONLY: Active_area, CFS2CMS_CONV + USE PRMS_GWFLOW, ONLY: Basin_gwflow + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cfs, Basin_cms, Basin_stflow_in, & + & Basin_sroff_cfs, Basin_ssflow_cfs, Basin_gwflow_cfs, Basin_stflow_out, & + & Seg_inflow, Seg_outflow, Seg_upstream_inflow, Seg_lateral_inflow, Flow_out + USE PRMS_ROUTING, ONLY: Obsin_segment, Segment_order, Tosegment, Obsout_segment, Segment_type, & + & Flow_to_lakes, Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_replacement, & + & Flow_out_NHM, Flow_terminus, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes + USE PRMS_SRUNOFF, ONLY: Basin_sroff + USE PRMS_OBS, ONLY: Streamflow_cfs + IMPLICIT NONE +! Functions + EXTERNAL :: print_module +! Local Variables + INTEGER :: i, iorder, toseg, segtype + DOUBLE PRECISION :: area_fac, segout + CHARACTER(LEN=80), SAVE :: Version_strmflow +!*********************************************************************** + strmflow_in_out = 0 + + IF ( Process(:3)=='run' ) THEN + Seg_inflow = 0.0D0 + Seg_outflow = 0.0D0 + Seg_upstream_inflow = 0.0D0 + Flow_out = 0.0D0 + Flow_to_lakes = 0.0D0 + Flow_to_ocean = 0.0D0 + Flow_to_great_lakes = 0.0D0 + Flow_out_region = 0.0D0 + Flow_out_NHM = 0.0D0 + Flow_in_region = 0.0D0 + Flow_terminus = 0.0D0 + Flow_in_nation = 0.0D0 + Flow_headwater = 0.0D0 + Flow_in_great_lakes = 0.0D0 + Flow_replacement = 0.0D0 + DO i = 1, Nsegment + iorder = Segment_order(i) + toseg = Tosegment(iorder) + segtype = Segment_type(iorder) + IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) + Seg_inflow(iorder) = Seg_upstream_inflow(iorder) + Seg_lateral_inflow(iorder) + IF ( Obsout_segment(iorder)>0 ) THEN + Seg_outflow(iorder) = Streamflow_cfs(Obsout_segment(iorder)) + ELSE + Seg_outflow(iorder) = Seg_inflow(iorder) + ENDIF + + IF ( Seg_outflow(iorder) < 0.0 ) THEN + IF ( Print_debug>-1 ) THEN + PRINT *, 'WARNING, negative flow from segment:', iorder, ' flow:', Seg_outflow(iorder) + PRINT *, ' likely a water-use specification or replacement flow issue' + ENDIF + ENDIF + + segout = Seg_outflow(iorder) +! Flow_out is the total flow out of the basin, which allows for multiple outlets +! includes closed basins (tosegment=0) + IF ( segtype==1 ) THEN + Flow_headwater = Flow_headwater + segout + ELSEIF ( segtype==2 ) THEN + Flow_to_lakes = Flow_to_lakes + segout + ELSEIF ( segtype==3 ) THEN + Flow_replacement = Flow_replacement + segout + ELSEIF ( segtype==4 ) THEN + Flow_in_nation = Flow_in_nation + segout + ELSEIF ( segtype==5 ) THEN + Flow_out_NHM = Flow_out_NHM + segout + ELSEIF ( segtype==6 ) THEN + Flow_in_region = Flow_in_region + segout + ELSEIF ( segtype==7 ) THEN + Flow_out_region = Flow_out_region + segout + ELSEIF ( segtype==8 ) THEN + Flow_to_ocean = Flow_to_ocean + segout + ELSEIF ( segtype==9 ) THEN + Flow_terminus = Flow_terminus + segout + ELSEIF ( segtype==10 ) THEN + Flow_in_great_lakes = Flow_in_great_lakes + segout + ELSEIF ( segtype==11 ) THEN + Flow_to_great_lakes = Flow_to_great_lakes + segout + ENDIF + IF ( toseg==0 ) THEN + Flow_out = Flow_out + segout + ELSE + Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + segout + ENDIF + ENDDO + + area_fac = Cfs_conv*Active_area + Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows + Basin_cfs = Flow_out + Basin_stflow_out = Basin_cfs/area_fac + Basin_cms = Basin_cfs*CFS2CMS_CONV + Basin_sroff_cfs = Basin_sroff*area_fac + Basin_ssflow_cfs = Basin_ssflow*area_fac + Basin_gwflow_cfs = Basin_gwflow*area_fac + ELSEIF ( Process(:4)=='decl' ) THEN + Version_strmflow = 'strmflow_in_out.f90 2017-03-20 16:41:00Z' + CALL print_module(Version_strmflow, 'Streamflow Routing ', 90) + ENDIF + + END FUNCTION strmflow_in_out diff --git a/prms/temp_1sta_laps.f90 b/prms/temp_1sta_laps.f90 index 7ebcac0a..75b226a9 100644 --- a/prms/temp_1sta_laps.f90 +++ b/prms/temp_1sta_laps.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! Distributes maximum, minimum, and average temperatures to each HRU ! using temperature data measured at one station and an estimated monthly -! lapse rate (temp_1sta) or by computing a daily lapse rate based on +! lapse rate (temp_1sta) or by computing a daily lapse rate based on ! elevations with temperature data measured at two stations (temp_laps) ! ! Variables needed from DATA FILE: tmax, tmin @@ -31,9 +31,10 @@ END MODULE PRMS_TEMP_1STA_LAPS INTEGER FUNCTION temp_1sta_laps() USE PRMS_TEMP_1STA_LAPS USE PRMS_MODULE, ONLY: Process, Nhru, Ntemp, Save_vars_to_file, & - & Inputerror_flag, Temp_flag, Init_vars_from_file, Model, Start_month, Print_debug - USE PRMS_BASIN, ONLY: Hru_elev, Hru_area, MAXTEMP, MINTEMP, & - & Active_hrus, Hru_route_order, Basin_area_inv, NEARZERO + & Inputerror_flag, Temp_flag, Init_vars_from_file, Model, Start_month, Print_debug, & + & Glacier_flag + USE PRMS_BASIN, ONLY: Hru_elev_ts, Hru_area, MAXTEMP, MINTEMP, & + & Active_hrus, Hru_route_order, Basin_area_inv, NEARZERO, Hru_type USE PRMS_CLIMATEVARS, ONLY: Tmax_aspect_adjust, Tmin_aspect_adjust, Tsta_elev, & & Hru_tsta, Solrad_tmax, Solrad_tmin, Basin_temp, Basin_tmax, & & Basin_tmin, Tmaxf, Tminf, Tminc, Tmaxc, Tavgf, Tavgc, Basin_tsta, Tmax_allrain @@ -44,9 +45,10 @@ INTEGER FUNCTION temp_1sta_laps() INTRINSIC INDEX, ABS INTEGER, EXTERNAL :: declparam, getparam EXTERNAL read_error, temp_set, print_module, temp_1sta_laps_restart, print_date, checkdim_param_limits + EXTERNAL compute_temp_laps ! Local Variables INTEGER :: j, k, jj, i, kk, kkk, l, ierr - REAL :: tmx, tmn, tdiff + REAL :: tmx, tmn CHARACTER(LEN=80), SAVE :: Version_temp !*********************************************************************** temp_1sta_laps = 0 @@ -106,6 +108,10 @@ INTEGER FUNCTION temp_1sta_laps() j = Hru_route_order(jj) k = Hru_tsta(j) IF ( Nowday==1 ) THEN + IF ( Glacier_flag==1 ) THEN + ! Hru_elev_ts is the antecedent glacier elevation + IF ( Hru_type(j)==4 ) Elfac(j) = (Hru_elev_ts(j) - Tsta_elev(k))/1000.0 + ENDIF Tcrx(j) = Tmax_lapse(j, Nowmonth)*Elfac(j) - Tmax_aspect_adjust(j, Nowmonth) Tcrn(j) = Tmin_lapse(j, Nowmonth)*Elfac(j) - Tmin_aspect_adjust(j, Nowmonth) ENDIF @@ -119,6 +125,10 @@ INTEGER FUNCTION temp_1sta_laps() j = Hru_route_order(jj) k = Hru_tsta(j) l = Hru_tlaps(j) + IF ( Glacier_flag==1 ) THEN + ! Hru_elev_ts is the antecedent glacier elevation + IF ( Hru_type(j)==4 ) CALL compute_temp_laps(Elfac(j), Hru_elev_ts(j), Tsta_elev(l), Tsta_elev(k)) + ENDIF tmx = Tmax(k) + (Tmax(l) - Tmax(k))*Elfac(j) + Tmax_aspect_adjust(j, Nowmonth) tmn = Tmin(k) + (Tmin(l) - Tmin(k))*Elfac(j) + Tmin_aspect_adjust(j, Nowmonth) CALL temp_set(j, tmx, tmn, Tmaxf(j), Tminf(j), Tavgf(j), & @@ -177,7 +187,7 @@ INTEGER FUNCTION temp_1sta_laps() ALLOCATE ( Tcrn(Nhru), Tcrx(Nhru) ) ALLOCATE ( Tmax_lapse(Nhru, 12) ) IF ( declparam(MODNAME, 'tmax_lapse', 'nhru,nmonths', 'real', & - & '3.0', '-20.0', '20.0', & + & '17.64', '-20.0', '20.0', & & 'Monthly maximum temperature lapse rate for each HRU', & & 'Monthly (January to December) values representing the change in maximum air temperature per 1000 elev_units of'// & & ' elevation change for each HRU', & @@ -186,7 +196,7 @@ INTEGER FUNCTION temp_1sta_laps() ALLOCATE ( Tmin_lapse(Nhru, 12) ) IF ( declparam(MODNAME, 'tmin_lapse', 'nhru,nmonths', 'real', & - & '3.0', '-20.0', '20.0', & + & '17.64', '-20.0', '20.0', & & 'Monthly minimum temperature lapse rate for each HRU', & & 'Monthly (January to December) values representing the change in minimum air temperture per 1000 elev_units of'// & & ' elevation change for each HRU', & @@ -219,7 +229,7 @@ INTEGER FUNCTION temp_1sta_laps() IF ( getparam(MODNAME, 'tmin_lapse', Nhru*12, 'real', Tmin_lapse)/=0 ) CALL read_error(2, 'tmin_lapse') IF ( getparam(MODNAME, 'tmax_lapse', Nhru*12, 'real', Tmax_lapse)/=0 ) CALL read_error(2, 'tmax_lapse') ELSEIF ( Temp_flag==2 ) THEN - IF ( getparam(MODNAME, 'hru_tlaps', Nhru, 'integer', Hru_tlaps)/=0 ) CALL read_error(2, 'hru_tlaps') + IF ( getparam(MODNAME, 'hru_tlaps', Nhru, 'integer', Hru_tlaps)/=0 ) CALL read_error(2, 'hru_tlaps') ENDIF IF ( getparam(MODNAME, 'max_missing', 1, 'integer', Max_missing)/=0 ) CALL read_error(2, 'max_missing') Max_missing = Max_missing + 1 @@ -233,7 +243,8 @@ INTEGER FUNCTION temp_1sta_laps() j = Hru_route_order(i) k = Hru_tsta(j) Nuse_tsta(k) = 1 - Elfac(j) = (Hru_elev(j)-Tsta_elev(k))/1000.0 + ! Hru_elev_ts is the current elevation, either hru_elev or for restart Hru_elev_ts + Elfac(j) = (Hru_elev_ts(j)-Tsta_elev(k))/1000.0 Tcrx(j) = Tmax_lapse(j, Start_month)*Elfac(j) - Tmax_aspect_adjust(j, Start_month) Tcrn(j) = Tmin_lapse(j, Start_month)*Elfac(j) - Tmin_aspect_adjust(j, Start_month) ENDDO @@ -245,9 +256,9 @@ INTEGER FUNCTION temp_1sta_laps() IF ( ierr==1 ) CYCLE ! if one error found no need to compute values k = Hru_tsta(j) Nuse_tsta(k) = 1 - tdiff = Tsta_elev(Hru_tlaps(j)) - Tsta_elev(k) - IF ( ABS(tdiff) Date: Fri, 21 Jun 2019 23:17:16 -0600 Subject: [PATCH 02/47] Rest of merge modules. --- prms/call_modules.f90 | 13 +- prms/call_modulesRip.f90 | 1315 ++++++++++++++++++++++++++++++++ prms/muskingum.f90 | 36 +- prms/muskingumRip.f90 | 477 ++++++++++++ prms/routing.f90 | 33 +- prms/routingRip.f90 | 1556 ++++++++++++++++++++++++++++++++++++++ prms/srunoff.f90 | 205 ++++- prms/water_balance.f90 | 32 +- 8 files changed, 3584 insertions(+), 83 deletions(-) create mode 100644 prms/call_modulesRip.f90 create mode 100644 prms/muskingumRip.f90 create mode 100644 prms/routingRip.f90 diff --git a/prms/call_modules.f90 b/prms/call_modules.f90 index 3221f5c7..0f12ebb4 100644 --- a/prms/call_modules.f90 +++ b/prms/call_modules.f90 @@ -48,6 +48,7 @@ MODULE PRMS_MODULE INTEGER, SAVE :: Dyn_snareathresh_flag, Dyn_transp_on_flag INTEGER, SAVE :: Dyn_sro2dprst_perv_flag, Dyn_sro2dprst_imperv_flag, Dyn_fallfrost_flag, Dyn_springfrost_flag INTEGER, SAVE :: Gwr_transferON_OFF, External_transferON_OFF, Segment_transferON_OFF, Lake_transferON_OFF + INTEGER, SAVE :: Frozen_flag, Glacier_flag END MODULE PRMS_MODULE !*********************************************************************** @@ -75,6 +76,7 @@ INTEGER FUNCTION call_modules(Arg) EXTERNAL :: module_error, print_module, PRMS_open_output_file EXTERNAL :: call_modules_restart, water_balance, basin_summary, nsegment_summary EXTERNAL :: prms_summary, nhru_summary, module_doc, convert_params, read_error, nsub_summary + INTEGER, EXTERNAL :: glacr ! Local Variables INTEGER :: i, iret, nc !*********************************************************************** @@ -116,7 +118,7 @@ INTEGER FUNCTION call_modules(Arg) & ' Potential ET: potet_hamon, potet_jh, potet_pan, climate_hru,', /, & & ' potet_hs, potet_pt, potet_pm, potet_pm_sta', /, & & ' Interception: intcp', /, & - & ' Snow Dynamics: snowcomp', /, & + & 'Snow & Glacr Dynam: snowcomp, glacr', /, & & ' Surface Runoff: srunoff_smidx, srunoff_carea', /, & & ' Soil Zone: soilzone', /, & & ' Groundwater: gwflow', /, & @@ -326,6 +328,11 @@ INTEGER FUNCTION call_modules(Arg) call_modules = snowcomp() IF ( call_modules/=0 ) CALL module_error('snowcomp', Arg, call_modules) + IF ( Glacier_flag==1 ) THEN + call_modules = glacr() + IF ( call_modules/=0 ) CALL module_error('glacr', Arg, call_modules) + ENDIF + call_modules = srunoff() IF ( call_modules/=0 ) CALL module_error(Srunoff_module, Arg, call_modules) @@ -726,6 +733,8 @@ INTEGER FUNCTION setdims() IF ( decldim('ngwcell', 0, MAXDIM, & & 'Number of spatial units in the target map for mapped results')/=0 ) CALL read_error(7, 'ngwcell') + IF ( control_integer(Glacier_flag, 'glacier_flag')/=0 ) Glacier_flag = 0 + IF ( control_integer(Frozen_flag, 'frozen_flag')/=0 ) Frozen_flag = 0 IF ( control_integer(Dyn_imperv_flag, 'dyn_imperv_flag')/=0 ) Dyn_imperv_flag = 0 IF ( control_integer(Dyn_intcp_flag, 'dyn_intcp_flag')/=0 ) Dyn_intcp_flag = 0 IF ( control_integer(Dyn_covden_flag, 'dyn_covden_flag')/=0 ) Dyn_covden_flag = 0 @@ -1052,6 +1061,7 @@ SUBROUTINE module_doc() INTEGER, EXTERNAL :: stream_temp EXTERNAL :: nhru_summary, prms_summary, water_balance, nsub_summary, basin_summary, nsegment_summary INTEGER, EXTERNAL :: dynamic_param_read, water_use_read, setup, potet_pm_sta + INTEGER, EXTERNAL :: glacr ! Local variable INTEGER :: test !********************************************************************** @@ -1087,6 +1097,7 @@ SUBROUTINE module_doc() test = intcp() test = snowcomp() test = srunoff() + test = glacr() test = soilzone() test = gwflow() test = routing() diff --git a/prms/call_modulesRip.f90 b/prms/call_modulesRip.f90 new file mode 100644 index 00000000..8face3a7 --- /dev/null +++ b/prms/call_modulesRip.f90 @@ -0,0 +1,1315 @@ +!*********************************************************************** +! Defines the computational sequence, valid modules, and dimensions +!*********************************************************************** + MODULE PRMS_MODULE + IMPLICIT NONE + INTEGER, PARAMETER :: MAXFILE_LENGTH = 256, MAXCONTROL_LENGTH = 32 + INTEGER, PARAMETER :: MAXDIM = 500 + CHARACTER(LEN=68), PARAMETER :: & + & EQULS = '====================================================================' + CHARACTER(LEN=12), PARAMETER :: MODNAME = 'call_modules' + CHARACTER(LEN=24), PARAMETER :: PRMS_VERSION = 'Version 5.0.1 06/20/2019' + CHARACTER(LEN=8), SAVE :: Process + CHARACTER(LEN=80), SAVE :: PRMS_versn + INTEGER, SAVE :: Model, Process_flag, Call_cascade, Ncascade, Ncascdgw + INTEGER, SAVE :: Nhru, Nssr, Ngw, Nsub, Nhrucell, Nlake, Ngwcell, Nlake_hrus + INTEGER, SAVE :: Ntemp, Nrain, Nsol, Nsegment, Ndepl, Nobs, Nevap, Ndeplval + INTEGER, SAVE :: Starttime(6), Endtime(6) + INTEGER, SAVE :: Start_year, Start_month, Start_day, End_year, End_month, End_day + INTEGER, SAVE :: Transp_flag, Sroff_flag, Solrad_flag, Et_flag + INTEGER, SAVE :: Climate_temp_flag, Climate_precip_flag, Climate_potet_flag, Climate_transp_flag + INTEGER, SAVE :: Lake_route_flag, Nratetbl, Strmflow_flag, Stream_order_flag + INTEGER, SAVE :: Temp_flag, Precip_flag, Climate_hru_flag, Climate_swrad_flag, Ripst_flag + INTEGER, SAVE :: Precip_combined_flag, Temp_combined_flag, Muskingum_flag + INTEGER, SAVE :: Inputerror_flag, Timestep + INTEGER, SAVE :: Humidity_cbh_flag, Windspeed_cbh_flag + INTEGER, SAVE :: Stream_temp_flag, Strmtemp_humidity_flag, PRMS4_flag + INTEGER, SAVE :: Grid_flag, Logunt + INTEGER, SAVE :: PRMS_flag, GSFLOW_flag + INTEGER, SAVE :: PRMS_output_unit, Restart_inunit, Restart_outunit + INTEGER, SAVE :: Dynamic_flag, Water_use_flag, Nwateruse, Nexternal, Nconsumed, Npoigages, Prms_warmup + INTEGER, SAVE :: Elapsed_time_start(8), Elapsed_time_end(8), Elapsed_time_minutes + REAL, SAVE :: Execution_time_start, Execution_time_end, Elapsed_time + INTEGER, SAVE :: Kkiter +! Precip_flag (1=precip_1sta; 2=precip_laps; 3=precip_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru +! Temp_flag (1=temp_1sta; 2=temp_laps; 3=temp_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru; 8=temp_sta +! Control parameters + INTEGER, SAVE :: Print_debug, MapOutON_OFF, CsvON_OFF, Dprst_flag, Subbasin_flag, Parameter_check_flag + INTEGER, SAVE :: Init_vars_from_file, Save_vars_to_file, Orad_flag, Cascade_flag, Cascadegw_flag + INTEGER, SAVE :: NhruOutON_OFF, Gwr_swale_flag, NsubOutON_OFF, BasinOutON_OFF, NsegmentOutON_OFF + CHARACTER(LEN=MAXFILE_LENGTH), SAVE :: Model_output_file, Var_init_file, Var_save_file + CHARACTER(LEN=MAXFILE_LENGTH), SAVE :: Csv_output_file, Model_control_file, Param_file + CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Temp_module, Srunoff_module, Et_module + CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Strmflow_module, Transp_module + CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Model_mode, Precip_module, Solrad_module + CHARACTER(LEN=8), SAVE :: Soilzone_module + INTEGER, SAVE :: Dyn_imperv_flag, Dyn_intcp_flag, Dyn_covden_flag, Dyn_covtype_flag, Dyn_transp_flag, Dyn_potet_flag + INTEGER, SAVE :: Dyn_soil_flag, Dyn_radtrncf_flag, Dyn_dprst_flag, Dprst_transferON_OFF + INTEGER, SAVE :: Dyn_snareathresh_flag, Dyn_transp_on_flag + INTEGER, SAVE :: Dyn_sro2dprst_perv_flag, Dyn_sro2dprst_imperv_flag, Dyn_fallfrost_flag, Dyn_springfrost_flag + INTEGER, SAVE :: Gwr_transferON_OFF, External_transferON_OFF, Segment_transferON_OFF, Lake_transferON_OFF + INTEGER, SAVE :: Frozen_flag, Glacier_flag + END MODULE PRMS_MODULE + +!*********************************************************************** + INTEGER FUNCTION call_modules(Arg) + USE PRMS_MODULE + IMPLICIT NONE +! Arguments + CHARACTER(LEN=*), INTENT(IN) :: Arg +! Functions + INTRINSIC :: DATE_AND_TIME, INT + INTEGER, EXTERNAL :: check_dims, basin, climateflow, prms_time, setup + INTEGER, EXTERNAL :: cascade, obs, soltab, transp_tindex + INTEGER, EXTERNAL :: transp_frost, frost_date, routing + INTEGER, EXTERNAL :: temp_1sta_laps, temp_dist2 + INTEGER, EXTERNAL :: precip_1sta_laps, climate_hru + INTEGER, EXTERNAL :: precip_dist2, xyz_dist, ide_dist + INTEGER, EXTERNAL :: ddsolrad, ccsolrad + INTEGER, EXTERNAL :: potet_pan, potet_jh, potet_hamon, potet_hs, potet_pt, potet_pm + INTEGER, EXTERNAL :: intcp, snowcomp, gwflow + INTEGER, EXTERNAL :: srunoff, soilzone, mizuroute + INTEGER, EXTERNAL :: strmflow, subbasin, basin_sum, map_results, write_climate_hru + INTEGER, EXTERNAL :: strmflow_in_out, muskingum, muskingum_lake, numchars + INTEGER, EXTERNAL :: water_use_read, dynamic_param_read, potet_pm_sta + INTEGER, EXTERNAL :: stream_temp + EXTERNAL :: module_error, print_module, PRMS_open_output_file + EXTERNAL :: call_modules_restart, water_balance, basin_summary, nsegment_summary + EXTERNAL :: prms_summary, nhru_summary, module_doc, convert_params, read_error, nsub_summary + INTEGER, EXTERNAL :: glacr +! Local Variables + INTEGER :: i, iret, nc +!*********************************************************************** + call_modules = 1 + + Process = Arg + + IF ( Process(:3)=='run' ) THEN + Process_flag = 0 !(0=run, 1=declare, 2=init, 3=clean, 4=setdims) + + ELSEIF ( Process(:4)=='decl' ) THEN + CALL DATE_AND_TIME(VALUES=Elapsed_time_start) + Execution_time_start = Elapsed_time_start(5)*3600 + Elapsed_time_start(6)*60 + & + & Elapsed_time_start(7) + Elapsed_time_start(8)*0.001 + + Process_flag = 1 + + PRMS_versn = 'call_modules.f90 2019-06-20 15:33:00Z' + + IF ( check_dims()/=0 ) STOP + + IF ( Print_debug>-2 ) THEN + PRINT 10, PRMS_VERSION + WRITE ( PRMS_output_unit, 10 ) PRMS_VERSION + ENDIF + 10 FORMAT (///, 25X, 'U.S. Geological Survey', /, 15X, & + & 'Precipitation-Runoff Modeling System (PRMS)', /, 24X, A) + 15 FORMAT (/, 8X, 'Process', 12X, 'Available Modules', /, 68('-'), /, & + & ' Basin Definition: basin', /, & + & ' Cascading Flow: cascade', /, & + & ' Time Series Data: obs, water_use_read, dynamic_param_read', /, & + & ' Potet Solar Rad: soltab', /, & + & ' Temperature Dist: temp_1sta, temp_laps, temp_dist2, climate_hru', /, & + & ' Precip Dist: precip_1sta, precip_laps, precip_dist2,', /, & + & ' climate_hru', /, & + & 'Temp & Precip Dist: xyz_dist, ide_dist', /, & + & ' Solar Rad Dist: ccsolrad, ddsolrad, climate_hru', /, & + & 'Transpiration Dist: transp_tindex, climate_hru, transp_frost', /, & + & ' Potential ET: potet_hamon, potet_jh, potet_pan, climate_hru,', /, & + & ' potet_hs, potet_pt, potet_pm, potet_pm_sta', /, & + & ' Interception: intcp', /, & + & 'Snow & Glacr Dynam: snowcomp, glacr', /, & + & ' Surface Runoff: srunoff_smidx, srunoff_carea', /, & + & ' Soil Zone: soilzone', /, & + & ' Groundwater: gwflow', /, & + & 'Streamflow Routing: strmflow, strmflow_in_out, muskingum,', /, & + & ' muskingum_lake, muskingum_mann, mizuroute,', /, & + & 'Stream Temperature: stream_temp', /, & + & ' Output Summary: basin_sum, subbasin, map_results, prms_summary,', /, & + & ' nhru_summary, nsub_summary, water_balance', /, & + & ' basin_summary, nsegment_summary', /, & + & ' Preprocessing: write_climate_hru, frost_date', /, 68('-')) + 16 FORMAT (//, 4X, 'Active modules listed in the order in which they are called', //, 8X, 'Process', 19X, & + & 'Module', 16X, 'Version Date', /, A) + IF ( Print_debug>-2 ) THEN + PRINT 15 + PRINT 9002 + WRITE ( PRMS_output_unit, 15 ) + PRINT 16, EQULS + WRITE ( PRMS_output_unit, 16 ) EQULS + ENDIF + CALL print_module(PRMS_versn, 'Computation Order ', 90) + + Kkiter = 1 ! set for PRMS-only mode + + Timestep = 0 + IF ( Init_vars_from_file>0 ) CALL call_modules_restart(1) + + ELSEIF ( Process(:4)=='init' ) THEN + Process_flag = 2 + + Grid_flag = 0 + IF ( Nhru==Nhrucell ) Grid_flag = 1 + + nc = numchars(Model_control_file) + IF ( Print_debug>-1 ) PRINT 9004, 'Using Control File: ', Model_control_file(:nc) + IF ( Print_debug>-2 ) WRITE ( PRMS_output_unit, 9004 ) 'Using Control File: ', Model_control_file(:nc) + + nc = numchars(Param_file) + IF ( Print_debug>-1 ) PRINT 9004, 'Using Parameter File: ', Param_file(:nc) + IF ( Print_debug>-2 ) WRITE ( PRMS_output_unit, 9004 ) 'Using Parameter File: ', Param_file(:nc) + + IF ( Init_vars_from_file>0 ) THEN + nc = numchars(Var_init_file) + IF ( Print_debug>-1 ) PRINT 9004, 'Using var_init_file: ', Var_init_file(:nc) + ENDIF + IF ( Save_vars_to_file==1 ) THEN + nc = numchars(Var_save_file) + IF ( Print_debug>-1 ) PRINT 9004, 'Using var_save_file: ', Var_save_file(:nc) + ENDIF + + IF ( Print_debug>-2 ) THEN + nc = numchars(Model_output_file) + PRINT 9004, 'Writing PRMS Water Budget File: ', Model_output_file(:nc) + ENDIF + + ELSEIF ( Process(:7)=='setdims' ) THEN + Process_flag = 4 + + ELSE !IF ( Process(:5)=='clean' ) THEN + Process_flag = 3 + IF ( Init_vars_from_file>0 ) CLOSE ( Restart_inunit ) + IF ( Save_vars_to_file==1 ) THEN + nc = numchars(Var_save_file) + CALL PRMS_open_output_file(Restart_outunit, Var_save_file(:nc), 'var_save_file', 1, iret) + IF ( iret/=0 ) STOP + CALL call_modules_restart(0) + ENDIF + ENDIF + + IF ( Model==99 ) THEN + IF ( Process_flag==4 .OR. Process_flag<2 ) THEN + Init_vars_from_file = 0 ! make sure this is set so all variables and parameters are declared + CALL module_doc() + call_modules = 0 + RETURN + ELSE + STOP + ENDIF + ENDIF + +! All modules must be called for setdims, declare, initialize, and cleanup + IF ( Process_flag/=0 ) THEN + call_modules = basin() + IF ( call_modules/=0 ) CALL module_error('basin', Arg, call_modules) + + IF ( Call_cascade==1 ) THEN + call_modules = cascade() + IF ( call_modules/=0 ) CALL module_error('cascade', Arg, call_modules) + ENDIF + + call_modules = climateflow() + IF ( call_modules/=0 ) CALL module_error('climateflow', Arg, call_modules) + + call_modules = soltab() + IF ( call_modules/=0 ) CALL module_error('soltab', Arg, call_modules) + + call_modules = setup() + IF ( call_modules/=0 ) CALL module_error('setup', Arg, call_modules) + ENDIF + + call_modules = prms_time() + IF ( call_modules/=0 ) CALL module_error('prms_time', Arg, call_modules) + + call_modules = obs() + IF ( call_modules/=0 ) CALL module_error('obs', Arg, call_modules) + + IF ( Water_use_flag==1 ) THEN + call_modules = water_use_read() + IF ( call_modules/=0 ) CALL module_error('water_use_read', Arg, call_modules) + ENDIF + + IF ( Dynamic_flag==1 ) THEN + call_modules = dynamic_param_read() + IF ( call_modules/=0 ) CALL module_error('dynamic_param_read', Arg, call_modules) + ENDIF + + IF ( Climate_hru_flag==1 ) THEN + call_modules = climate_hru() + IF ( call_modules/=0 ) CALL module_error('climate_hru', Arg, call_modules) + ENDIF + + IF ( Climate_temp_flag==0 ) THEN + IF ( Temp_combined_flag==1 ) THEN + call_modules = temp_1sta_laps() + ELSEIF ( Temp_flag==6 ) THEN + call_modules = xyz_dist() + ELSEIF ( Temp_flag==3 ) THEN + call_modules = temp_dist2() + ELSE !IF ( Temp_flag==5 ) THEN + call_modules = ide_dist() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Temp_module, Arg, call_modules) + ENDIF + + IF ( Climate_precip_flag==0 ) THEN + IF ( Precip_combined_flag==1 ) THEN + call_modules = precip_1sta_laps() + ELSEIF ( Precip_flag==3 ) THEN + call_modules = precip_dist2() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Precip_module, Arg, call_modules) + ENDIF + + IF ( Model==6 ) THEN + IF ( Process_flag==0 ) RETURN + ENDIF + +! frost_date is a pre-process module + IF ( Model==9 ) THEN + call_modules = frost_date() + IF ( call_modules/=0 ) CALL module_error('frost_date', Arg, call_modules) + IF ( Process_flag==0 ) RETURN + IF ( Process_flag==3 ) STOP + ENDIF + + IF ( Climate_swrad_flag==0 ) THEN + IF ( Solrad_flag==1 ) THEN + call_modules = ddsolrad() + ELSE !IF ( Solrad_flag==2 ) THEN + call_modules = ccsolrad() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Solrad_module, Arg, call_modules) + ENDIF + + IF ( Transp_flag==1 ) THEN + call_modules = transp_tindex() + ELSEIF ( Transp_flag==2 ) THEN + call_modules = transp_frost() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Transp_module, Arg, call_modules) + + IF ( Model==8 ) THEN + IF ( Process_flag==0 ) RETURN + ENDIF + + IF ( Climate_potet_flag==0 ) THEN + IF ( Et_flag==1 ) THEN + call_modules = potet_jh() + ELSEIF ( Et_flag==2 ) THEN + call_modules = potet_hamon() + ELSEIF ( Et_flag==4 ) THEN + call_modules = potet_pan() + ELSEIF ( Et_flag==5 ) THEN + call_modules = potet_pt() + ELSEIF ( Et_flag==6 ) THEN + call_modules = potet_pm_sta() + ELSEIF ( Et_flag==11 ) THEN + call_modules = potet_pm() + ELSE !IF ( Et_flag==10 ) THEN + call_modules = potet_hs() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Et_module, Arg, call_modules) + ENDIF + + IF ( Model==4 ) THEN + call_modules = write_climate_hru() + IF ( call_modules/=0 ) CALL module_error('write_climate_hru', Arg, call_modules) + IF ( Process_flag==0 ) RETURN + ENDIF + + IF ( Model==7 ) THEN + IF ( Process_flag==0 ) RETURN + ENDIF + + call_modules = intcp() + IF ( call_modules/=0 ) CALL module_error('intcp', Arg, call_modules) + + call_modules = snowcomp() + IF ( call_modules/=0 ) CALL module_error('snowcomp', Arg, call_modules) + + IF ( Glacier_flag==1 ) THEN + call_modules = glacr() + IF ( call_modules/=0 ) CALL module_error('glacr', Arg, call_modules) + ENDIF + + call_modules = srunoff() + IF ( call_modules/=0 ) CALL module_error(Srunoff_module, Arg, call_modules) + + call_modules = soilzone() + IF ( call_modules/=0 ) CALL module_error(Soilzone_module, Arg, call_modules) + + call_modules = gwflow() + IF ( call_modules/=0 ) CALL module_error('gwflow', Arg, call_modules) + + IF ( Stream_order_flag==1 ) THEN + call_modules = routing() + IF ( call_modules/=0 ) CALL module_error('routing', Arg, call_modules) + ENDIF + + IF ( Strmflow_flag==1 ) THEN + call_modules = strmflow() + ELSEIF ( Muskingum_flag==1 ) THEN ! muskingum = 4; muskingum_mann = 7 + call_modules = muskingum() + ELSEIF ( Strmflow_flag==5 ) THEN + call_modules = strmflow_in_out() + ELSEIF ( Strmflow_flag==6 ) THEN + call_modules = mizuroute() + ELSEIF ( Strmflow_flag==3 ) THEN + call_modules = muskingum_lake() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Strmflow_module, Arg, call_modules) + + IF ( Stream_temp_flag==1 ) call_modules = stream_temp() + + IF ( Print_debug>-2 ) THEN + call_modules = basin_sum() + IF ( call_modules/=0 ) CALL module_error('basin_sum', Arg, call_modules) + ENDIF + + IF ( Print_debug==1 ) CALL water_balance() + + IF ( MapOutON_OFF>0 ) THEN + call_modules = map_results() + IF ( call_modules/=0 ) CALL module_error('map_results', Arg, call_modules) + ENDIF + + IF ( Subbasin_flag==1 ) THEN + call_modules = subbasin() + IF ( call_modules/=0 ) CALL module_error('subbasin', Arg, call_modules) + ENDIF + + IF ( NhruOutON_OFF>0 ) CALL nhru_summary() + + IF ( NsubOutON_OFF==1 ) CALL nsub_summary() + + IF ( BasinOutON_OFF==1 ) CALL basin_summary() + + IF ( NsegmentOutON_OFF>0 ) CALL nsegment_summary() + + IF ( CsvON_OFF>0 ) CALL prms_summary() + + IF ( Process_flag==0 ) THEN + RETURN + ELSEIF ( Process_flag==3 ) THEN + CALL DATE_AND_TIME(VALUES=Elapsed_time_end) + Execution_time_end = Elapsed_time_end(5)*3600 + Elapsed_time_end(6)*60 + & + & Elapsed_time_end(7) + Elapsed_time_end(8)*0.001 + Elapsed_time = Execution_time_end - Execution_time_start + Elapsed_time_minutes = INT(Elapsed_time/60.0) + IF ( Print_debug>-1 ) THEN + PRINT 9001 + PRINT 9003, 'start', (Elapsed_time_start(i),i=1,3), (Elapsed_time_start(i),i=5,7) + PRINT 9003, 'end ', (Elapsed_time_end(i),i=1,3), (Elapsed_time_end(i),i=5,7) + PRINT '(A,I5,A,F6.2,A,/)', 'Execution elapsed time', Elapsed_time_minutes, ' minutes', & + & Elapsed_time - Elapsed_time_minutes*60.0, ' seconds' + ENDIF + IF ( Print_debug>-2 ) & + & WRITE ( PRMS_output_unit,'(A,I5,A,F6.2,A,/)') 'Execution elapsed time', Elapsed_time_minutes, ' minutes', & + & Elapsed_time - Elapsed_time_minutes*60.0, ' seconds' + IF ( Print_debug>-2 ) CLOSE ( PRMS_output_unit ) + IF ( Save_vars_to_file>0 ) CLOSE ( Restart_outunit ) + ELSEIF ( Process_flag==1 ) THEN + IF ( Print_debug>-2 ) THEN + PRINT '(A)', EQULS + WRITE ( PRMS_output_unit, '(A)' ) EQULS + ENDIF + IF ( Model==10 ) CALL convert_params() + ELSEIF ( Process_flag==2 ) THEN + IF ( Inputerror_flag==1 ) THEN + PRINT '(//,A,//,A,/,A,/,A)', '**Fix input errors in your Parameter File to continue**', & + & ' Set control parameter parameter_check_flag to 0 after', & + & ' all parameter values are valid.' + PRINT '(/,A,/,A,/,A,/,A,/,A,/)', & + & 'If input errors are related to paramters used for automated', & + & 'calibration processes, with CAUTION, set control parameter', & + & 'parameter_check_flag to 0. After calibration set the', & + & 'parameter_check_flag to 1 to verify that those calibration', & + & 'parameters have valid and compatible values.' + ENDIF + IF ( Parameter_check_flag==2 .OR. Inputerror_flag==1 ) STOP + IF ( Model==10 ) THEN + CALL convert_params() + STOP + ENDIF + IF ( Print_debug>-2 ) & + & PRINT 4, 'Simulation time period:', Start_year, Start_month, Start_day, ' -', End_year, End_month, End_day, EQULS + ENDIF + + 4 FORMAT (/, 2(A, I5, 2('/',I2.2)), //, A, /) + 9001 FORMAT (/, 26X, 25('='), /, 26X, 'Normal completion of PRMS', /, 26X, 25('='), /) + 9002 FORMAT (//, 74('='), /, 'Please give careful consideration to fixing all ERROR and WARNING messages', /, 74('=')) + 9003 FORMAT ('Execution ', A, ' date and time (yyyy/mm/dd hh:mm:ss)', I5, 2('/',I2.2), I3, 2(':',I2.2), /) + 9004 FORMAT (/, 2A) + + END FUNCTION call_modules + +!*********************************************************************** +! declare the dimensions +!*********************************************************************** + INTEGER FUNCTION setdims() + USE PRMS_MODULE + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: decldim, declfix, call_modules, control_integer_array, control_file_name + INTEGER, EXTERNAL :: control_string, control_integer + EXTERNAL :: read_error, PRMS_open_output_file, PRMS_open_input_file, check_module_names +! Local Variables + ! Maximum values are no longer limits +! Local Variables + INTEGER :: idim, iret, j +!*********************************************************************** + setdims = 1 + + Inputerror_flag = 0 + + ! debug print flag: + ! -1=quiet - reduced screen output + ! 0=none; 1=water balances; 2=basin; + ! 4=basin_sum; 5=soltab; 7=soil zone; + ! 9=snowcomp; 13=cascade; 14=subbasin tree + IF ( control_integer(Print_debug, 'print_debug')/=0 ) Print_debug = 0 + + IF ( control_integer(Parameter_check_flag, 'parameter_check_flag')/=0 ) Parameter_check_flag = 1 + + IF ( control_string(Model_mode, 'model_mode')/=0 ) CALL read_error(5, 'model_mode') + PRMS4_flag = 1 + IF ( Model_mode(:5)=='PRMS5' ) PRMS4_flag = 0 + PRMS_flag = 1 + GSFLOW_flag = 0 + ! Model (0=GSFLOW; 1=PRMS; 2=MODFLOW) + IF ( Model_mode(:4)=='PRMS' .OR. Model_mode(:4)==' ' .OR. Model_mode(:5)=='DAILY' ) THEN + Model = 1 + ELSEIF ( Model_mode(:5)=='FROST' ) THEN + Model = 9 + ELSEIF ( Model_mode(:13)=='WRITE_CLIMATE' ) THEN + Model = 4 + ELSEIF ( Model_mode(:7)=='CLIMATE' ) THEN + Model = 6 + ELSEIF ( Model_mode(:5)=='POTET' ) THEN + Model = 7 + ELSEIF ( Model_mode(:9)=='TRANSPIRE' ) THEN + Model = 8 + ELSEIF ( Model_mode(:7)=='CONVERT' ) THEN ! can be CONVERT4 or CONVERT5 or CONVERT (=CONVERT5) + Model = 10 + ELSEIF ( Model_mode(:13)=='DOCUMENTATION' ) THEN + Model = 99 + ELSE + PRINT '(/,2A)', 'ERROR, invalid model_mode value: ', Model_mode + STOP + ENDIF + + ! get simulation start_time and end_time + Starttime = -1 + DO j = 1, 6 + IF ( control_integer_array(Starttime(j), j, 'start_time')/=0 ) THEN + PRINT *, 'ERROR, start_time, index:', j, 'value: ', Starttime(j) + STOP + ENDIF + ENDDO + Start_year = Starttime(1) + IF ( Start_year<0 ) STOP 'ERROR, control parameter start_time must be specified' + Start_month = Starttime(2) + Start_day = Starttime(3) + Endtime = -1 + DO j = 1, 6 + IF ( control_integer_array(Endtime(j), j, 'end_time')/=0 ) THEN + PRINT *, 'ERROR, end_time, index:', j, 'value: ', Endtime(j) + STOP + ENDIF + ENDDO + End_year = Endtime(1) + IF ( End_year<0 ) STOP 'ERROR, control parameter start_time must be specified' + End_month = Endtime(2) + End_day = Endtime(3) + + IF ( control_integer(Init_vars_from_file, 'init_vars_from_file')/=0 ) Init_vars_from_file = 0 + IF ( control_integer(Save_vars_to_file, 'save_vars_to_file')/=0 ) Save_vars_to_file = 0 + + ! Open PRMS module output file + IF ( control_string(Model_output_file, 'model_output_file')/=0 ) CALL read_error(5, 'model_output_file') + IF ( Print_debug>-2 ) THEN + CALL PRMS_open_output_file(PRMS_output_unit, Model_output_file, 'model_output_file', 0, iret) + IF ( iret/=0 ) STOP + ENDIF + IF ( control_file_name(Model_control_file)/=0 ) CALL read_error(5, 'control_file_name') + IF ( control_string(Param_file, 'param_file')/=0 ) CALL read_error(5, 'param_file') + + ! Check for restart files + IF ( Init_vars_from_file>0 ) THEN + IF ( control_string(Var_init_file, 'var_init_file')/=0 ) CALL read_error(5, 'var_init_file') + CALL PRMS_open_input_file(Restart_inunit, Var_init_file, 'var_init_file', 1, iret) + IF ( iret/=0 ) STOP + ENDIF + IF ( Save_vars_to_file==1 ) THEN + IF ( control_string(Var_save_file, 'var_save_file')/=0 ) CALL read_error(5, 'var_save_file') + ENDIF + + Temp_module = ' ' + IF ( control_string(Temp_module, 'temp_module')/=0 ) CALL read_error(5, 'temp_module') + Precip_module = ' ' + IF ( control_string(Precip_module, 'precip_module')/=0 ) CALL read_error(5, 'precip_module') + Transp_module = ' ' + IF ( control_string(Transp_module, 'transp_module')/=0 ) CALL read_error(5, 'transp_module') + Et_module = ' ' + IF ( control_string(Et_module, 'et_module')/=0 ) CALL read_error(5, 'et_module') + Srunoff_module = ' ' + IF ( control_string(Srunoff_module, 'srunoff_module')/=0 ) CALL read_error(5, 'srunoff_module') + Solrad_module = ' ' + IF ( control_string(Solrad_module, 'solrad_module')/=0 ) CALL read_error(5, 'solrad_module') + Strmflow_module = 'strmflow' + IF ( control_string(Strmflow_module, 'strmflow_module')/=0 ) CALL read_error(5, 'strmflow_module') + + IF ( Parameter_check_flag>0 ) CALL check_module_names() + + Climate_precip_flag = 0 + Climate_temp_flag = 0 + Climate_transp_flag = 0 + Climate_potet_flag = 0 + Climate_swrad_flag = 0 + + IF ( Precip_module(:11)=='precip_1sta' .OR. Precip_module(:11)=='precip_prms') THEN + Precip_flag = 1 + ELSEIF ( Precip_module(:11)=='precip_laps' ) THEN + Precip_flag = 2 + ELSEIF ( Precip_module(:12)=='precip_dist2' ) THEN + Precip_flag = 3 + ELSEIF ( Precip_module(:8)=='ide_dist' ) THEN + Precip_flag = 5 + ELSEIF ( Precip_module(:11)=='climate_hru' ) THEN + Precip_flag = 7 + Climate_precip_flag = 1 + ELSEIF ( Precip_module(:8)=='xyz_dist' ) THEN + Precip_flag = 6 + ELSE + PRINT '(/,2A)', 'ERROR: invalid precip_module value: ', Precip_module + Inputerror_flag = 1 + ENDIF + Precip_combined_flag = 0 + IF ( Precip_flag==1 .OR. Precip_flag==2 ) Precip_combined_flag = 1 + + IF ( Temp_module(:9)=='temp_1sta' ) THEN + Temp_flag = 1 + ELSEIF ( Temp_module(:9)=='temp_laps' ) THEN + Temp_flag = 2 + ELSEIF ( Temp_module(:10)=='temp_dist2' ) THEN + Temp_flag = 3 + ELSEIF ( Temp_module(:8)=='ide_dist' ) THEN + Temp_flag = 5 + ELSEIF ( Temp_module(:11)=='climate_hru' ) THEN + Temp_flag = 7 + Climate_temp_flag = 1 + ELSEIF ( Temp_module(:8)=='xyz_dist' ) THEN + Temp_flag = 6 + ELSEIF ( Temp_module(:8)=='temp_sta' ) THEN + Temp_flag = 8 + ELSE + PRINT '(/,2A)', 'ERROR, invalid temp_module value: ', Temp_module + Inputerror_flag = 1 + ENDIF + Temp_combined_flag = 0 + IF ( Temp_flag==1 .OR. Temp_flag==2 .OR. Temp_flag==8 ) Temp_combined_flag = 1 + + IF ( Transp_module(:13)=='transp_tindex' ) THEN + Transp_flag = 1 + ELSEIF ( Transp_module(:12)=='transp_frost' ) THEN + Transp_flag = 2 + ELSEIF ( Transp_module(:11)=='climate_hru' ) THEN + Transp_flag = 3 + Climate_transp_flag = 1 + ELSE + PRINT '(/,2A)', 'ERROR, invalid transp_module value: ', Transp_module + Inputerror_flag = 1 + ENDIF + + IF ( Et_module(:8)=='potet_jh' ) THEN + Et_flag = 1 + ELSEIF ( Et_module(:11)=='potet_hamon' ) THEN + Et_flag = 2 + ELSEIF ( Et_module(:11)=='climate_hru' ) THEN + Et_flag = 7 + Climate_potet_flag = 1 + ELSEIF ( Et_module(:8)=='potet_hs' ) THEN + Et_flag = 10 + ELSEIF ( Et_module(:12)=='potet_pm_sta' ) THEN + Et_flag = 6 + ELSEIF ( Et_module(:8)=='potet_pm' ) THEN + Et_flag = 11 + ELSEIF ( Et_module(:8)=='potet_pt' ) THEN + Et_flag = 5 + ELSEIF ( Et_module(:9)=='potet_pan' ) THEN + Et_flag = 4 + ELSE + PRINT '(/,2A)', 'ERROR, invalid et_module value: ', Et_module + Inputerror_flag = 1 + ENDIF + + ! stream_temp + IF ( control_integer(Stream_temp_flag, 'stream_temp_flag')/=0 ) Stream_temp_flag = 0 + ! 0 = CBH File; 1 = specified constant; 2 = Stations + IF ( control_integer(Strmtemp_humidity_flag, 'strmtemp_humidity_flag')/=0 ) Strmtemp_humidity_flag = 0 + + Humidity_cbh_flag = 0 + Windspeed_cbh_flag = 0 + IF ( Et_flag==11 .OR. Et_flag==5 .OR. (Stream_temp_flag==1 .AND. Strmtemp_humidity_flag==0) ) Humidity_cbh_flag = 1 + IF ( Et_flag==11 ) Windspeed_cbh_flag = 1 + + IF ( Srunoff_module(:13)=='srunoff_smidx' ) THEN + Sroff_flag = 1 + ELSEIF ( Srunoff_module(:13)=='srunoff_carea' ) THEN + Sroff_flag = 2 + ELSE + PRINT '(/,2A)', 'ERROR, invalid srunoff_module value: ', Srunoff_module + Inputerror_flag = 1 + ENDIF + + Soilzone_module = 'soilzone' + + IF ( control_integer(Orad_flag, 'orad_flag')/=0 ) Orad_flag = 0 + IF ( Solrad_module(:8)=='ddsolrad' ) THEN + Solrad_flag = 1 + ELSEIF ( Solrad_module(:11)=='climate_hru' ) THEN + Solrad_flag = 7 + Climate_swrad_flag = 1 + ELSEIF ( Solrad_module(:8)=='ccsolrad' ) THEN + Solrad_flag = 2 + ELSE + PRINT '(/,2A)', 'ERROR, invalid solrad_module value: ', Solrad_module + Inputerror_flag = 1 + ENDIF + + Climate_hru_flag = 0 + IF ( Climate_temp_flag==1 .OR. Climate_precip_flag==1 .OR. Climate_potet_flag==1 .OR. & + & Climate_swrad_flag==1 .OR. Climate_transp_flag==1 .OR. & + & Humidity_cbh_flag==1 .OR. Windspeed_cbh_flag==1 ) Climate_hru_flag = 1 + + Muskingum_flag = 0 + IF ( Strmflow_module(:15)=='strmflow_in_out' ) THEN + Strmflow_flag = 5 + ELSEIF ( Strmflow_module(:14)=='muskingum_lake' ) THEN + Strmflow_flag = 3 + ELSEIF ( Strmflow_module(:13)=='strmflow_lake' ) THEN + PRINT '(/,2A)', 'ERROR, invalid strmflow_module value: ', Strmflow_module + Inputerror_flag = 1 + ELSEIF ( Strmflow_module(:8)=='strmflow' ) THEN + Strmflow_flag = 1 + ELSEIF ( Strmflow_module(:14)=='muskingum_mann' ) THEN + Strmflow_flag = 7 + Muskingum_flag = 1 + ELSEIF ( Strmflow_module(:9)=='muskingum' ) THEN + Strmflow_flag = 4 + Muskingum_flag = 1 + ELSEIF ( Strmflow_module(:9)=='mizuroute' ) THEN + Strmflow_flag = 6 + ELSE + PRINT '(/,2A)', 'ERROR, invalid strmflow_module value: ', Strmflow_module + Inputerror_flag = 1 + ENDIF + +! cascade dimensions + IF ( decldim('ncascade', 0, MAXDIM, & + & 'Number of HRU links for cascading flow')/=0 ) CALL read_error(7, 'ncascade') + IF ( decldim('ncascdgw', 0, MAXDIM, & + & 'Number of GWR links for cascading flow')/=0 ) CALL read_error(7, 'ncascdgw') + +! nsegment dimension + IF ( decldim('nsegment', 0, MAXDIM, 'Number of stream-channel segments')/=0 ) CALL read_error(7, 'nsegment') + +! subbasin dimensions + IF ( control_integer(Subbasin_flag, 'subbasin_flag')/=0 ) Subbasin_flag = 1 + IF ( decldim('nsub', 0, MAXDIM, 'Number of internal subbasins')/=0 ) CALL read_error(7, 'nsub') + + IF ( control_integer(Dprst_flag, 'dprst_flag')/=0 ) Dprst_flag = 0 + ! 0 = off, 1 = on, 2 = lauren version + IF ( control_integer(CsvON_OFF, 'csvON_OFF')/=0 ) CsvON_OFF = 0 + IF ( control_integer(Ripst_flag, 'ripst_flag')/=0 ) Ripst_flag = 0 + +! map results dimensions + IF ( control_integer(MapOutON_OFF, 'mapOutON_OFF')/=0 ) MapOutON_OFF = 0 + idim = 0 + IF ( GSFLOW_flag==1 .OR. MapOutON_OFF==1 ) idim = 1 + IF ( decldim('nhrucell', idim, MAXDIM, & + & 'Number of unique intersections between HRUs and spatial units of a target map for mapped results')/=0 ) & + & CALL read_error(7, 'nhrucell') + IF ( decldim('ngwcell', 0, MAXDIM, & + & 'Number of spatial units in the target map for mapped results')/=0 ) CALL read_error(7, 'ngwcell') + + IF ( control_integer(Glacier_flag, 'glacier_flag')/=0 ) Glacier_flag = 0 + IF ( control_integer(Frozen_flag, 'frozen_flag')/=0 ) Frozen_flag = 0 + IF ( control_integer(Dyn_imperv_flag, 'dyn_imperv_flag')/=0 ) Dyn_imperv_flag = 0 + IF ( control_integer(Dyn_intcp_flag, 'dyn_intcp_flag')/=0 ) Dyn_intcp_flag = 0 + IF ( control_integer(Dyn_covden_flag, 'dyn_covden_flag')/=0 ) Dyn_covden_flag = 0 + IF ( control_integer(Dyn_dprst_flag, 'dyn_dprst_flag')/=0 ) Dyn_dprst_flag = 0 + IF ( control_integer(Dyn_potet_flag, 'dyn_potet_flag')/=0 ) Dyn_potet_flag = 0 + IF ( control_integer(Dyn_covtype_flag, 'dyn_covtype_flag')/=0 ) Dyn_covtype_flag = 0 + IF ( control_integer(Dyn_transp_flag, 'dyn_transp_flag')/=0 ) Dyn_transp_flag = 0 + IF ( control_integer(Dyn_soil_flag, 'dyn_soil_flag')/=0 ) Dyn_soil_flag = 0 + IF ( control_integer(Dyn_radtrncf_flag, 'dyn_radtrncf_flag')/=0 ) Dyn_radtrncf_flag = 0 + IF ( control_integer(Dyn_sro2dprst_perv_flag, 'dyn_sro2dprst_perv_flag')/=0 ) Dyn_sro2dprst_perv_flag = 0 + IF ( control_integer(Dyn_sro2dprst_imperv_flag, 'dyn_sro2dprst_imperv_flag')/=0 ) Dyn_sro2dprst_imperv_flag = 0 + IF ( control_integer(Dyn_fallfrost_flag, 'dyn_fallfrost_flag')/=0 ) Dyn_fallfrost_flag = 0 + IF ( control_integer(Dyn_springfrost_flag, 'dyn_springfrost_flag')/=0 ) Dyn_springfrost_flag = 0 + IF ( control_integer(Dyn_snareathresh_flag, 'dyn_snareathresh_flag')/=0 ) Dyn_snareathresh_flag = 0 + IF ( control_integer(Dyn_transp_on_flag, 'dyn_transp_on_flag')/=0 ) Dyn_transp_on_flag = 0 + Dynamic_flag = 0 + IF ( Dyn_imperv_flag/=0 .OR. Dyn_intcp_flag/=0 .OR. Dyn_covden_flag/=0 .OR. Dyn_dprst_flag/=0 .OR. & + & Dyn_potet_flag/=0 .OR. Dyn_covtype_flag/=0 .OR. Dyn_transp_flag/=0 .OR. Dyn_soil_flag /=0 .OR. & + & Dyn_radtrncf_flag/=0 .OR. Dyn_sro2dprst_perv_flag/=0 .OR. Dyn_sro2dprst_imperv_flag/=0 .OR. & + & Dyn_fallfrost_flag/=0 .OR. Dyn_springfrost_flag/=0 .OR. Dyn_snareathresh_flag/=0 .OR. & + & Dyn_transp_on_flag/=0 ) Dynamic_flag = 1 + IF ( control_integer(Gwr_transferON_OFF, 'gwr_transferON_OFF')/=0) Gwr_transferON_OFF = 0 + IF ( control_integer(External_transferON_OFF, 'external_transferON_OFF')/=0 ) External_transferON_OFF = 0 + IF ( control_integer(Dprst_transferON_OFF, 'dprst_transferON_OFF')/=0 ) Dprst_transferON_OFF = 0 + IF ( control_integer(Segment_transferON_OFF, 'segment_transferON_OFF')/=0 ) Segment_transferON_OFF = 0 + IF ( control_integer(Lake_transferON_OFF, 'lake_transferON_OFF')/=0 ) Lake_transferON_OFF = 0 + IF ( control_integer(Gwr_swale_flag, 'gwr_swale_flag')/=0 ) Gwr_swale_flag = 0 + +! nhru_summary + IF ( control_integer(NhruOutON_OFF, 'nhruOutON_OFF')/=0 ) NhruOutON_OFF = 0 + +! nsub_summary + IF ( control_integer(NsubOutON_OFF, 'nsubOutON_OFF')/=0 ) NsubOutON_OFF = 0 + +! basin_summary + IF ( control_integer(BasinOutON_OFF, 'basinOutON_OFF')/=0 ) BasinOutON_OFF = 0 + +! nsegment_summary + IF ( control_integer(NsegmentOutON_OFF, 'nsegmentOutON_OFF')/=0 ) NsegmentOutON_OFF = 0 + + IF ( control_integer(Prms_warmup, 'prms_warmup')/=0 ) Prms_warmup = 0 + IF ( NhruOutON_OFF>0 .OR. NsubOutON_OFF>0 .OR. BasinOutON_OFF>0 .OR. NsegmentOutON_OFF>0 ) THEN + IF ( Start_year+Prms_warmup>End_year ) THEN ! change to start full date ??? + PRINT *, 'ERROR, prms_warmup > than simulation time period:', Prms_warmup + Inputerror_flag = 1 + ENDIF + ENDIF + +! cascade + ! if cascade_flag = 2, use hru_segment parameter for cascades, ncascade=ncascdgw=nhru (typical polygon HRUs) + IF ( control_integer(Cascade_flag, 'cascade_flag')/=0 ) Cascade_flag = 1 + ! if cascadegw_flag = 2, use same cascades as HRUs + IF ( control_integer(Cascadegw_flag, 'cascadegw_flag')/=0 ) Cascadegw_flag = 1 + +! spatial units + IF ( decldim('ngw', 1, MAXDIM, 'Number of GWRs')/=0 ) CALL read_error(7, 'ngw') + IF ( decldim('nhru', 1, MAXDIM, 'Number of HRUs')/=0 ) CALL read_error(7, 'nhru') + IF ( decldim('nssr', 1, MAXDIM, 'Number of subsurface reservoirs')/=0 ) CALL read_error(7, 'nssr') + IF ( decldim('nlake', 0, MAXDIM, 'Number of lakes')/=0 ) CALL read_error(7, 'nlake') + ! nlake_hrus to be added in 5.0.1 +! IF ( decldim('nlake_hrus', 0, MAXDIM, 'Number of lake HRUs')/=0 ) CALL read_error(7, 'nlake_hrus') + IF ( decldim('npoigages', 0, MAXDIM, 'Number of POI gages')/=0 ) CALL read_error(7, 'npoigages') + +! Time-series data stations, need to know if in Data File + IF ( decldim('nrain', 0, MAXDIM, 'Number of precipitation-measurement stations')/=0 ) CALL read_error(7, 'nrain') + IF ( decldim('nsol', 0, MAXDIM, 'Number of solar-radiation measurement stations')/=0 ) CALL read_error(7, 'nsol') + IF ( decldim('ntemp', 0, MAXDIM, 'Number of air-temperature-measurement stations')/=0 ) CALL read_error(7, 'ntemp') + IF ( decldim('nobs', 0, MAXDIM, 'Number of streamflow-measurement stations')/=0 ) CALL read_error(7, 'nobs') + IF ( decldim('nevap', 0, MAXDIM, 'Number of pan-evaporation data sets')/=0 ) CALL read_error(7, 'nevap') + IF ( decldim('nratetbl', 0, MAXDIM, 'Number of rating-table data sets for lake elevations') & + & /=0 ) CALL read_error(7, 'nratetbl') + +! depletion curves + IF ( decldim('ndepl', 1, MAXDIM, 'Number of snow-depletion curves')/=0 ) CALL read_error(7, 'ndelp') + IF ( decldim('ndeplval', 11, MAXDIM, 'Number of values in all snow-depletion curves (set to ndepl*11)')/=0 ) & + & CALL read_error(7, 'ndelplval') + +! water-use + IF ( decldim('nwateruse', 0, MAXDIM, 'Number of water-use data sets')/=0 ) CALL read_error(7, 'nwateruse') + IF ( decldim('nexternal', 0, MAXDIM, & + & 'Number of external water-use sources or destinations')/=0 ) CALL read_error(7, 'nexternal') + IF ( decldim('nconsumed', 0, MAXDIM, 'Number of consumptive water-use destinations')/=0 ) CALL read_error(7, 'nconsumed') + +! fixed dimensions + IF ( declfix('ndays', 366, 366, 'Maximum number of days in a year ')/=0 ) CALL read_error(7, 'ndays') + IF ( declfix('nmonths', 12, 12, 'Number of months in a year')/=0 ) CALL read_error(7, 'nmonths') + IF ( declfix('one', 1, 1, 'Number of values for scaler array')/=0 ) CALL read_error(7, 'one') + + IF ( call_modules('setdims')/=0 ) STOP 'ERROR, in setdims' + + IF ( Inputerror_flag==1 ) THEN + PRINT '(//,A,/,A)', '**FIX input errors in your Control File to continue**', & + & 'NOTE: some errors may be due to use of defalut values' + STOP + ENDIF + + setdims = 0 + END FUNCTION setdims + +!*********************************************************************** +! Get and check consistency of dimensions with flags +!*********************************************************************** + INTEGER FUNCTION check_dims() + USE PRMS_MODULE + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: getdim + EXTERNAL :: check_dimens +! Local Variables + INTEGER :: ierr +!*********************************************************************** + + Nhru = getdim('nhru') + IF ( Nhru==-1 ) CALL read_error(7, 'nhru') + + Nssr = getdim('nssr') + IF ( Nssr==-1 ) CALL read_error(7, 'nssr') + + Ngw = getdim('ngw') + IF ( Ngw==-1 ) CALL read_error(7, 'ngw') + + Ntemp = getdim('ntemp') + IF ( Ntemp==-1 ) CALL read_error(6, 'ntemp') + + Nrain = getdim('nrain') + IF ( Nrain==-1 ) CALL read_error(6, 'nrain') + + Nsol = getdim('nsol') + IF ( Nsol==-1 ) CALL read_error(6, 'nsol') + + Nobs = getdim('nobs') + IF ( Nobs==-1 ) CALL read_error(6, 'nobs') + + Nevap = getdim('nevap') + IF ( Nevap==-1 ) CALL read_error(6, 'nevap') + + Ncascade = getdim('ncascade') + IF ( Ncascade==-1 ) CALL read_error(7, 'ncascade') + Ncascdgw = getdim('ncascdgw') + IF ( Ncascdgw==-1 ) CALL read_error(7, 'ncascdgw') + IF ( Cascade_flag==2 ) THEN + Ncascade = Nhru + Cascadegw_flag = 2 + ENDIF + IF ( Cascadegw_flag==2 ) Ncascdgw = Ncascade + IF ( Ncascade==0 ) Cascade_flag = 0 + IF ( Ncascdgw==0 .OR. GSFLOW_flag==1 .OR. Model==2 ) Cascadegw_flag = 0 + IF ( (Cascade_flag>0 .OR. Cascadegw_flag>0) .AND. Model/=10 ) THEN ! don't call if model_mode = CONVERT + Call_cascade = 1 + ELSE + Call_cascade = 0 + ENDIF + + Nwateruse = getdim('nwateruse') + IF ( Nwateruse==-1 ) CALL read_error(7, 'nwateruse') + + Nexternal = getdim('nexternal') + IF ( Nexternal==-1 ) CALL read_error(6, 'nexternal') + + Nconsumed = getdim('nconsumed') + IF ( Nconsumed==-1 ) CALL read_error(6, 'nconsumed') + + Npoigages = getdim('npoigages') + IF ( Npoigages==-1 ) CALL read_error(6, 'npoigages') + + Nlake = getdim('nlake') + IF ( Nlake==-1 ) CALL read_error(7, 'nlake') + + ! Nlake_hrus will be added in version 5.0.1 +! Nlake_hrus = getdim('nlake_hrus') +! IF ( Nlake_hrus==-1 ) CALL read_error(7, 'nlake_hrus') +! IF ( Nlake>0 .AND. Nlake_hrus==0 ) Nlake_hrus = Nlake + Nlake_hrus = Nlake + + Ndepl = getdim('ndepl') + IF ( Ndepl==-1 ) CALL read_error(7, 'ndepl') + + Ndeplval = getdim('ndeplval') + IF ( Ndeplval==-1 ) CALL read_error(7, 'ndeplval') + + Nsub = getdim('nsub') + IF ( Nsub==-1 ) CALL read_error(7, 'nsub') + ! default = 1, turn off if no subbasins + IF ( Subbasin_flag==1 .AND. Nsub==0 ) Subbasin_flag = 0 + + Nsegment = getdim('nsegment') + IF ( Nsegment==-1 ) CALL read_error(7, 'nsegment') + + Nhrucell = getdim('nhrucell') + IF ( Nhrucell==-1 ) CALL read_error(6, 'nhrucell') + + Ngwcell = getdim('ngwcell') + IF ( Ngwcell==-1 ) CALL read_error(6, 'ngwcell') + + Nratetbl = getdim('nratetbl') + IF ( Nratetbl==-1 ) CALL read_error(6, 'nratetbl') + + Water_use_flag = 0 + IF ( Nwateruse>0 ) THEN + IF ( Segment_transferON_OFF==1 .OR. Gwr_transferON_OFF==1 .OR. External_transferON_OFF==1 .OR. & + & Dprst_transferON_OFF==1 .OR. Lake_transferON_OFF==1 .OR. Nconsumed>0 .OR. Nwateruse>0 ) Water_use_flag = 1 + ENDIF + + ierr = 0 + IF ( Segment_transferON_OFF==1 .OR. Gwr_transferON_OFF==1 .OR. External_transferON_OFF==1 .OR. & + & Dprst_transferON_OFF==1 .OR. Lake_transferON_OFF==1 .OR. Nconsumed>0 ) THEN + IF ( Dprst_transferON_OFF==1 .AND. Dprst_flag==0 ) THEN + PRINT *, 'ERROR, specified water-use event based dprst input and have dprst inactive' + ierr = 1 + ENDIF + IF ( Lake_transferON_OFF==1 .AND. Strmflow_flag/=3 ) THEN + PRINT *, 'ERROR, specified water-use event based lake input and have lake simulation inactive' + ierr = 1 + ENDIF + ENDIF + IF ( ierr==1 ) STOP + + Stream_order_flag = 0 + IF ( Nsegment>0 .AND. Strmflow_flag>1 .AND. Model/=0 ) THEN + Stream_order_flag = 1 ! strmflow_in_out, muskingum, muskingum_lake, muskingum_mann, mizuroute + ENDIF + + IF ( Nsegment<1 .AND. Model/=99 ) THEN + IF ( Stream_order_flag==1 .OR. Call_cascade==1 ) THEN + PRINT *, 'ERROR, streamflow and cascade routing require nsegment > 0, specified as:', Nsegment + STOP + ENDIF + ENDIF + + Lake_route_flag = 0 + IF ( Nlake>0 .AND. Strmflow_flag==3 .AND. Model/=0 ) Lake_route_flag = 1 ! muskingum_lake + + IF ( NsubOutON_OFF==1 .AND. Nsub==0 ) THEN + NsubOutON_OFF = 0 + IF ( Print_debug>-1 ) PRINT *, 'WARNING, nsubOutON_OFF = 1 and nsub = 0, thus nsub_summary not used' + ENDIF + + IF ( Model==99 .OR. Parameter_check_flag>0 ) CALL check_dimens() + + check_dims = Inputerror_flag + END FUNCTION check_dims + +!*********************************************************************** +! Check consistency of dimensions with flags +!*********************************************************************** + SUBROUTINE check_dimens() + USE PRMS_MODULE + IMPLICIT NONE +! Local Variables + INTEGER :: ierr +!*********************************************************************** + ierr = 0 + IF ( Nhru==0 .OR. Nssr==0 .OR. Ngw==0 ) THEN + PRINT *, 'ERROR, nhru, nssr, and ngw must be > 0: nhru=', Nhru, ', nssr=', Nssr, ', ngw=', Ngw + ierr = 1 + ELSEIF ( Nssr/=Nhru .OR. Ngw/=Nhru ) THEN + PRINT *, 'ERROR, nhru, nssr, and ngw must equal: nhru=', Nhru, ', nssr=', Nssr, ', ngw=', Ngw + ierr = 1 + ENDIF + IF ( Ndepl==0 ) THEN + PRINT *, 'ERROR, ndepl must be > 0: ndepl=', Ndepl + ierr = 1 + ENDIF + IF ( Ndeplval/=Ndepl*11 ) THEN + PRINT *, 'ERROR, ndeplval must be = ndepl*11: ndeplval:', Ndeplval, ', ndepl=', Ndepl + ierr = 1 + ENDIF + + IF ( ierr==1 ) STOP + + IF ( Model==99 ) THEN + IF ( Ntemp==0 ) Ntemp = 1 + IF ( Nrain==0 ) Nrain = 1 + IF ( Nlake==0 ) Nlake = 1 + IF ( Nlake_hrus==0 ) Nlake_hrus = 1 + IF ( Nsol==0 ) Nsol = 1 + IF ( Nobs==0 ) Nobs = 1 + IF ( Ncascade==0 ) Ncascade = 1 + IF ( Ncascdgw==0 ) Ncascdgw = 1 + IF ( Nsub==0 ) Nsub = 1 + IF ( Nevap==0 ) Nevap = 1 + IF ( Nhrucell==0 ) Nhrucell = 1 + IF ( Ngwcell==0 ) Ngwcell = 1 + IF ( Nsegment==0 ) Nsegment = 1 + IF ( Nratetbl==0 ) Nratetbl = 4 + IF ( Nwateruse==0 ) Nwateruse = 1 + IF ( Nexternal==0 ) Nexternal = 1 + IF ( Nconsumed==0 ) Nconsumed = 1 + IF ( Npoigages==0 ) Npoigages = 1 + Subbasin_flag = 1 + Cascade_flag = 1 + Cascadegw_flag = 1 + Call_cascade = 1 + Stream_order_flag = 1 + Climate_hru_flag = 1 + Lake_route_flag = 1 + Water_use_flag = 1 + Segment_transferON_OFF = 1 + Gwr_transferON_OFF = 1 + External_transferON_OFF = 1 + Dprst_transferON_OFF = 1 + Lake_transferON_OFF = 1 + ENDIF + + END SUBROUTINE check_dimens + +!********************************************************************** +! Module documentation +!********************************************************************** + SUBROUTINE module_doc() + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: basin, climateflow, prms_time + INTEGER, EXTERNAL :: cascade, obs, soltab, transp_tindex + INTEGER, EXTERNAL :: transp_frost, frost_date, routing + INTEGER, EXTERNAL :: temp_1sta_laps, temp_dist2 + INTEGER, EXTERNAL :: precip_1sta_laps, climate_hru + INTEGER, EXTERNAL :: precip_dist2, xyz_dist, ide_dist + INTEGER, EXTERNAL :: ddsolrad, ccsolrad + INTEGER, EXTERNAL :: potet_pan, potet_jh, potet_hamon, potet_hs, potet_pt, potet_pm + INTEGER, EXTERNAL :: intcp, snowcomp, gwflow, srunoff, soilzone, mizuroute + INTEGER, EXTERNAL :: strmflow, subbasin, basin_sum, map_results, strmflow_in_out + INTEGER, EXTERNAL :: write_climate_hru, muskingum, muskingum_lake + INTEGER, EXTERNAL :: stream_temp + EXTERNAL :: nhru_summary, prms_summary, water_balance, nsub_summary, basin_summary, nsegment_summary + INTEGER, EXTERNAL :: dynamic_param_read, water_use_read, setup, potet_pm_sta + INTEGER, EXTERNAL :: glacr +! Local variable + INTEGER :: test +!********************************************************************** + test = basin() + test = cascade() + test = climateflow() + test = soltab() + test = setup() + test = prms_time() + test = obs() + test = water_use_read() + test = dynamic_param_read() + test = temp_1sta_laps() + test = temp_dist2() + test = xyz_dist() + test = ide_dist() + test = climate_hru() + test = precip_1sta_laps() + test = precip_dist2() + test = ddsolrad() + test = ccsolrad() + test = transp_tindex() + test = frost_date() + test = transp_frost() + test = potet_jh() + test = potet_hamon() + test = potet_pan() + test = potet_hs() + test = potet_pt() + test = potet_pm() + test = potet_pm_sta() + test = write_climate_hru() + test = intcp() + test = snowcomp() + test = srunoff() + test = glacr() + test = soilzone() + test = gwflow() + test = routing() + test = strmflow() + test = strmflow_in_out() + test = muskingum() + test = mizuroute() + test = muskingum_lake() + test = stream_temp() + test = basin_sum() + test = map_results() + CALL nhru_summary() + CALL nsub_summary() + CALL basin_summary() + CALL nsegment_summary() + CALL prms_summary() + CALL water_balance() + test = subbasin() + + PRINT 9001 + 9001 FORMAT (//, ' All available modules have been called.', /, & + & ' All parameters have been declared.', /, & + & ' Note, no simulation was computed.', /) + + END SUBROUTINE module_doc + +!*********************************************************************** +! check module names +!*********************************************************************** + SUBROUTINE check_module_names() + USE PRMS_MODULE, ONLY: Temp_module, Precip_module, Et_module, Solrad_module, & + & Transp_module, Srunoff_module, Strmflow_module + IMPLICIT NONE +! Local Variables + INTEGER :: ierr +!*********************************************************************** + ierr = 0 + IF ( Temp_module(:14)=='temp_1sta_prms' ) THEN + PRINT *, 'WARNING, deprecated temp_module value, change temp_1sta_prms to temp_1sta' + Temp_module = 'temp_1sta' + ELSEIF ( Temp_module(:14)=='temp_laps_prms' ) THEN + PRINT *, 'WARNING, deprecated temp_module value, change temp_laps_prms to temp_laps' + Temp_module = 'temp_laps' + ELSEIF ( Temp_module(:15)=='temp_dist2_prms' ) THEN + PRINT *, 'WARNING, deprecated temp_module value, change temp_dist2_prms to temp_dist2' + Temp_module = 'temp_dist2' + ELSEIF ( Temp_module(:9)=='temp_2sta' ) THEN + PRINT *, 'ERROR, module temp_2sta_prms not available, use a different temp_module' + ierr = 1 + ENDIF + + IF ( Precip_module(:11)=='precip_prms' ) THEN + PRINT *, 'WARNING, deprecated precip_module value, change precip_prms to precip_1sta' + Precip_module = 'precip_1sta' + ELSEIF ( Precip_module(:16)=='precip_laps_prms' ) THEN + PRINT *, 'WARNING, deprecated precip_module value, change precip_laps_prms to precip_laps' + Precip_module = 'precip_laps' + ELSEIF ( Precip_module(:17)=='precip_dist2_prms' ) THEN + PRINT *, 'WARNING, deprecated precip_module value, change precip_dist2_prms to precip_dist2' + Precip_module = 'precip_dist2' + ENDIF + + IF ( Temp_module(:8)=='ide_dist' .AND. Precip_module(:8)/='ide_dist') THEN + PRINT '(/,A,/,2A)', 'ERROR, if ide_dist is specified for temp_module,', & + & 'it also must be specified for precip_module: ', Precip_module + ierr = 1 + ELSEIF ( Precip_module(:8)=='ide_dist' .AND. Temp_module(:8)/='ide_dist') THEN + PRINT '(/,A,/,2A)', 'ERROR, if ide_dist is specified for precip_module,', & + & 'it also must be specified for temp_module: ', Temp_module + ierr = 1 + ELSEIF ( Temp_module(:8)=='xyz_dist' .AND. Precip_module(:8)/='xyz_dist') THEN + PRINT '(/,A,/,2A)', 'ERROR, if xyz_dist is specified for temp_module,', & + & 'it also must be specified for precip_module: ', Precip_module + ierr = 1 + ELSEIF ( Precip_module(:8)=='xyz_dist' .AND. Temp_module(:8)/='xyz_dist') THEN + PRINT '(/,A,/,2A)', 'ERROR, if xyz_dist is specified for precip_module,', & + & 'it also must be specified for temp_module: ', Temp_module + ierr = 1 + ENDIF + + IF ( Transp_module(:18)=='transp_tindex_prms' ) THEN + PRINT *, 'WARNING, deprecated transp_module value, change transp_tindex_prms to transp_tindex' + Transp_module = 'transp_tindex' + ENDIF + + IF ( Et_module(:13)=='potet_jh_prms' ) THEN + PRINT *, 'WARNING, deprecated et_module value, change potet_jh_prms to potet_jh' + Et_module = 'potet_jh' + ELSEIF ( Et_module(:14)=='potet_pan_prms' ) THEN + PRINT *, 'WARNING, deprecated et_module value, change potet_pan_prms to potet_pan' + Et_module = 'potet_pan' + ELSEIF ( Et_module(:15)=='potet_epan_prms' ) THEN + PRINT *, 'ERROR, deprecated et_module value, change potet_epan_prms to potet_pan' + ierr = 1 + ELSEIF ( Et_module(:20)=='potet_hamon_hru_prms' ) THEN + PRINT *, 'WARNING, deprecated et_module value, change potet_hamon_hru_prms to potet_hamon_hru' + Et_module = 'potet_hamon' + ELSEIF ( Et_module(:16)=='potet_hamon_prms' ) THEN + PRINT *, 'WARNING, deprecated et_module value, change potet_hamon_prms to potet_hamon' + Et_module = 'potet_hamon' + ENDIF + + IF ( Solrad_module(:17)=='ddsolrad_hru_prms' ) THEN + PRINT *, 'WARNING, deprecated solrad_module value, change ddsolrad_hru_prms to ddsolrad' + Solrad_module = 'ddsolrad' + ELSEIF ( Solrad_module(:17)=='ccsolrad_hru_prms' ) THEN + PRINT *, 'WARNING, deprecated solrad_module value, change ccsolrad_hru_prms to ccsolrad' + Solrad_module = 'ccsolrad' + ELSEIF ( Solrad_module(:13)=='ddsolrad_prms' ) THEN + PRINT *, 'WARNING, deprecated solrad_module value, change ddsolrad_prms to ddsolrad' + Solrad_module = 'ddsolrad' + ELSEIF ( Solrad_module(:13)=='ccsolrad_prms' ) THEN + PRINT *, 'WARNING, deprecated solrad_module value, change ccsolrad_prms to ccsolrad' + Solrad_module = 'ccsolrad' + ENDIF + + IF ( Srunoff_module(:18)=='srunoff_carea_prms' ) THEN + PRINT *, 'WARNING, deprecated srunoff_module value, change srunoff_carea_prms to srunoff_carea' + Srunoff_module = 'srunoff_carea' + ELSEIF ( Srunoff_module(:18)=='srunoff_smidx_prms' ) THEN + PRINT *, 'WARNING, deprecated srunoff_module value, change srunoff_smidx_prms to srunoff_smidx' + Srunoff_module = 'srunoff_smidx' + ENDIF + + IF ( Strmflow_module(:13)=='strmflow_prms' ) THEN + PRINT *, 'WARNING, deprecated strmflow_module value, change strmflow_prms to strmflow' + Strmflow_module = 'strmflow' + ELSEIF ( Strmflow_module(:13)=='strmflow_lake' ) THEN + PRINT *, 'ERROR, module strmflow_lake not available, use a different strmflow_module, such as muskingum_lake' + ierr = 1 + ENDIF + IF ( ierr==1 ) STOP + END SUBROUTINE check_module_names + +!*********************************************************************** +! call_modules_restart - write or read restart file +!*********************************************************************** + SUBROUTINE call_modules_restart(In_out) + USE PRMS_MODULE + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart, check_restart_dimen + ! Functions + INTRINSIC TRIM + ! Local Variables + INTEGER :: nhru_test, dprst_test, nsegment_test, temp_test, et_test, ierr, time_step + INTEGER :: cascade_test, cascdgw_test, nhrucell_test, nlake_test, transp_test, start_time(6), end_time(6) + CHARACTER(LEN=MAXCONTROL_LENGTH) :: model_test + CHARACTER(LEN=12) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Timestep, Nhru, Dprst_flag, Nsegment, Temp_flag, Et_flag, & + & Cascade_flag, Cascadegw_flag, Nhrucell, Nlake, Transp_flag, Model_mode + WRITE ( Restart_outunit ) Starttime, Endtime + ELSE + ierr = 0 + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) time_step, nhru_test, dprst_test, nsegment_test, temp_test, et_test, & + & cascade_test, cascdgw_test, nhrucell_test, nlake_test, transp_test, model_test + READ ( Restart_inunit ) start_time, end_time + IF ( Print_debug>-2 ) PRINT 4, EQULS, 'Simulation time period of Restart File:', & + & start_time(1), start_time(2), start_time(3), ' -', end_time(1), end_time(2), end_time(3), & + & 'Last time step of simulation: ', time_step, EQULS + 4 FORMAT (/, A, /, 2(A, I5, 2('/',I2.2)), /, A, I0, /, A, /) + IF ( TRIM(Model_mode)/=TRIM(model_test) ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model_mode=', model_test + PRINT *, ' Current model has model_mode=', Model_mode, ' they must be equal' + ierr = 1 + ENDIF + CALL check_restart_dimen('nhru', nhru_test, Nhru, ierr) + CALL check_restart_dimen('nhrucell', nhrucell_test, Nhrucell, ierr) + CALL check_restart_dimen('nlake', nlake_test, Nlake, ierr) + IF ( Dprst_flag/=dprst_test ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model with dprst_flag=', dprst_test + PRINT *, ' Current model has dprst_flag=', Dprst_flag, ' they must be equal' + ierr = 1 + ENDIF + IF ( Cascade_flag/=cascade_test ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model with cascade_flag=', cascade_test + PRINT *, ' Current model has cascade_flag=', Cascade_flag, ' they must be equal' + ierr = 1 + ENDIF + IF ( Cascadegw_flag/=cascdgw_test ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model with cascadegw_flag=', cascdgw_test + PRINT *, ' Current model has cascadegw_flag=', Cascadegw_flag, ' they must be equal' + ierr = 1 + ENDIF + CALL check_restart_dimen('nsegment', nsegment_test, Nsegment, ierr) + ! Temp_flag (1=temp_1sta; 2=temp_laps; 3=temp_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru; 8=temp_sta + IF ( Temp_flag/=temp_test ) THEN + IF ( Temp_flag<4 .OR. temp_test<4 ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model with different temperature module' + PRINT *, ' than current model, cannot switch to/from temp_1sta, temp_laps, or temp_dist2' + ierr = 1 + ENDIF + ENDIF + IF ( Et_flag/=et_test ) THEN + IF ( Et_flag==4 .OR. et_test==4 ) THEN + PRINT *, 'ERROR, Cannot switch to/from potet_pan module for restart simulations' + ierr = 1 + ENDIF + ENDIF + IF ( Transp_flag/=transp_test ) THEN + IF ( Transp_flag==1 .OR. transp_test==1 ) THEN + PRINT *, 'ERROR, Cannot switch to/from transp_tindex module for restart simulations' + ierr = 1 + ENDIF + ENDIF + IF ( ierr==1 ) STOP + ENDIF + END SUBROUTINE call_modules_restart diff --git a/prms/muskingum.f90 b/prms/muskingum.f90 index 1345d260..37488c16 100644 --- a/prms/muskingum.f90 +++ b/prms/muskingum.f90 @@ -87,8 +87,6 @@ MODULE PRMS_MUSKINGUM DOUBLE PRECISION, SAVE, ALLOCATABLE :: Currinsum(:), Pastin(:), Pastout(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:), Inflow_ts(:) CHARACTER(LEN=14), SAVE :: MODNAME -! Declared Parameters - REAL, SAVE, ALLOCATABLE :: Segment_flow_init(:) END MODULE PRMS_MUSKINGUM !*********************************************************************** @@ -123,7 +121,7 @@ END FUNCTION muskingum !*********************************************************************** INTEGER FUNCTION muskingum_decl() USE PRMS_MUSKINGUM - USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file, Strmflow_flag + USE PRMS_MODULE, ONLY: Nsegment, Strmflow_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declparam @@ -145,15 +143,6 @@ INTEGER FUNCTION muskingum_decl() ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) ) ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) ) - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN - ALLOCATE ( Segment_flow_init(Nsegment) ) - IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Initial flow in each stream segment', & - & 'Initial flow in each stream segment', & - & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') - ENDIF - END FUNCTION muskingum_decl !*********************************************************************** @@ -175,14 +164,6 @@ INTEGER FUNCTION muskingum_init() !*********************************************************************** muskingum_init = 0 - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN - IF ( getparam(MODNAME, 'segment_flow_init', Nsegment, 'real', Segment_flow_init)/=0 ) & - & CALL read_error(2,'segment_flow_init') - DO i = 1, Nsegment - Seg_outflow(i) = Segment_flow_init(i) - ENDDO - DEALLOCATE ( Segment_flow_init ) - ENDIF IF ( Init_vars_from_file==0 ) Outflow_ts = 0.0D0 Basin_segment_storage = 0.0D0 @@ -198,8 +179,8 @@ END FUNCTION muskingum_init !*********************************************************************** INTEGER FUNCTION muskingum_run() USE PRMS_MUSKINGUM - USE PRMS_MODULE, ONLY: Nsegment - USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv + USE PRMS_MODULE, ONLY: Nsegment, Glacier_flag + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, Basin_gl_cfs, Basin_gl_ice_cfs USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out @@ -209,6 +190,7 @@ INTEGER FUNCTION muskingum_run() & Obsin_segment, Segment_order, Tosegment, C0, C1, C2, Ts, Ts_i, Obsout_segment, & & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Segment_type, Flow_terminus, & & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes + USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt USE PRMS_SRUNOFF, ONLY: Basin_sroff USE PRMS_GWFLOW, ONLY: Basin_gwflow IMPLICIT NONE @@ -258,10 +240,10 @@ INTEGER FUNCTION muskingum_run() ! current inflow to the segment is the time weighted average of the outflow ! of the upstream segments plus the lateral HRU inflow plus any gains. - currin = Seg_lateral_inflow(iorder) + currin = 0.0D0 !Seg_lateral_inflow(iorder) route this to outlet to be like mizuroute IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) currin = currin + Seg_upstream_inflow(iorder) - Seg_inflow(iorder) = Seg_inflow(iorder) + currin + Seg_inflow(iorder) = Seg_inflow(iorder) + currin + Seg_lateral_inflow(iorder) Inflow_ts(iorder) = Inflow_ts(iorder) + currin Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder) @@ -280,6 +262,7 @@ INTEGER FUNCTION muskingum_run() ! Outflow_ts is the value from last hour Outflow_ts(iorder) = Inflow_ts(iorder) ENDIF + Outflow_ts(iorder) = Outflow_ts(iorder)+Seg_lateral_inflow(iorder) !add it here instead to be like mizuroute ! pastin is equal to the Inflow_ts on the previous routed timestep Pastin(iorder) = Inflow_ts(iorder) @@ -377,6 +360,11 @@ INTEGER FUNCTION muskingum_run() Basin_cfs = Flow_out Basin_stflow_out = Basin_cfs / area_fac Basin_cms = Basin_cfs*CFS2CMS_CONV + IF ( Glacier_flag==1 ) THEN + Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt + Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac + Basin_gl_cfs = Basin_gl_top_melt*area_fac + ENDIF Basin_sroff_cfs = Basin_sroff*area_fac Basin_ssflow_cfs = Basin_ssflow*area_fac Basin_gwflow_cfs = Basin_gwflow*area_fac diff --git a/prms/muskingumRip.f90 b/prms/muskingumRip.f90 new file mode 100644 index 00000000..801656c5 --- /dev/null +++ b/prms/muskingumRip.f90 @@ -0,0 +1,477 @@ +!*********************************************************************** +! Routes water between segments in the system using Muskingum routing +! +! The Muskingum equation is described in 'Hydrology for Engineers', 3rd ed. +! by Linsley, R.K, Kohler, M.A., and Paulhus, J.L.H., 1982 p. 275 and in +! 'Water in Environmental Planning' by Dunne, T., and Leopold, L.B. 1978 +! p. 357. +! +! Note that the Muskingum equation assumes a linear relation of storage +! to the inflow/outflow relation and therefore the relation is the same +! throughout the range of the hydrograph. The route_time parameter in +! the fixroute module is replaced by two new parameters, K_coef and +! x_coef, which are described below: +! +! The Muskingum method is based on the equation: S = K[xI + (1 - x)O] +! where S is storage, K is the storage coefficient, x is a coefficient +! between 0 and .5, I is inflow, and O is outflow. +! +! Solving for the outflow at day 2,O2; and knowing the inflow at day 1, +! I1; the inflow at day 2,I2; and the outflow at day 1, O1; the storage +! equation can be written as follows: +! +! O2 = czero*I2 + cone*I1 + ctwo*O1 +! +! where czero = -((Kx - 12) / (K - Kx + 12)) +! cone = (Kx + 12) / (K - Kx + 12) +! ctwo = (K - Kx - 12) / (K - Kx + 12) +! +! assuming a time step of one day and K is in units of hours +! +! This module is based on the "musroute.f" module. It differs in three +! basic ways: +! +! 1. This module uses an internal routing time step of one hour. +! The old muskingum module ran on the same daily time step as +! the rest of PRMS. The problem with this is that there is no +! ability to distinguish where the flood wave (front of the flow +! change) within the segment. For example, if there is a series +! of 4 1-day long segments, a flood wave will make it to the bottom +! of these in 1 day. If the same system is modeled as 1 4-day long +! segment, it will take 4 days. +! +! 2. The X parameter has been removed as a specified input and is now computed. To +! my knowledge, no modeler had ever set this to anything other than the default +! value (0.2) anyway. Always using the default value can lead to problems +! with the C coffecients which can result in mass balance problems or negative +! flow values. +! +! To solve this problem, I assume that the C coefficients must +! always be between 0 and 1. By setting the C coefficients equal to 0 and 1, +! various limits on the time step (ts), X, and K can be determined. There are +! two of these limits which are of interest: +! +! When C0 = 0: +! ts +! K = ----- +! 2X +! +! When C2 = 0: +! ts +! K = ----- +! 2(1-X) +! +! Determining a value of K half way between these two limits (by averaging) +! and solving for X using the quadratic formula results in: +! +! 1-sqrt(1-(ts/K)) +! X = ------------------ +! 2 +! +! So when ts is fixed at one hour and K is fixed as the average (or expected) +! travel time corresponding to the segment (for each segment in the stream +! network), a value of X can be computed (for each segment in the stream +! network) which will result in both conservation of mass and non-negative +! flows. Another benefit is that only one input parameter (K) needs to be +! input to the module. +! +! 3. If the travel time of a segment is less than or equal to the routing +! time step (one hour), then the outflow of the segment is set to the +! value of the inflow. +! +!*********************************************************************** + MODULE PRMS_MUSKINGUM + IMPLICIT NONE +! Local Variables + DOUBLE PRECISION, PARAMETER :: ONE_24TH = 1.0D0 / 24.0D0 + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Currinsum(:), Pastin(:), Pastout(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:), Inflow_ts(:) + CHARACTER(LEN=14), SAVE :: MODNAME + END MODULE PRMS_MUSKINGUM + +!*********************************************************************** +! Main muskingum routine +!*********************************************************************** + INTEGER FUNCTION muskingum() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: muskingum_decl, muskingum_init, muskingum_run + EXTERNAL :: muskingum_restart +!*********************************************************************** + muskingum = 0 + + IF ( Process(:3)=='run' ) THEN + muskingum = muskingum_run() + ELSEIF ( Process(:4)=='decl' ) THEN + muskingum = muskingum_decl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL muskingum_restart(1) + muskingum = muskingum_init() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL muskingum_restart(0) + ENDIF + + END FUNCTION muskingum + +!*********************************************************************** +! muskingum_decl - Declare parameters and variables and allocate arrays +! Declared Parameters +! tosegment, hru_segment, obsin_segment, K_coef, x_coef +!*********************************************************************** + INTEGER FUNCTION muskingum_decl() + USE PRMS_MUSKINGUM + USE PRMS_MODULE, ONLY: Nsegment, Strmflow_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_muskingum +!*********************************************************************** + muskingum_decl = 0 + + Version_muskingum = 'muskingum.f90 2019-06-05 17:18:00Z' + IF ( Strmflow_flag==4 ) THEN + MODNAME = 'muskingum' + ELSE + MODNAME = 'muskingum_mann' + ENDIF + CALL print_module(Version_muskingum, 'Streamflow Routing ', 90) + + ALLOCATE ( Currinsum(Nsegment) ) + ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) ) + ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) ) + + END FUNCTION muskingum_decl + +!*********************************************************************** +! muskingum_init - Get and check parameter values and initialize variables +!*********************************************************************** + INTEGER FUNCTION muskingum_init() + USE PRMS_MUSKINGUM + USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file + USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv + USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_ROUTING, ONLY: Basin_segment_storage + IMPLICIT NONE +! Functions + EXTERNAL :: read_error + INTEGER, EXTERNAL :: getparam +! Local Variables + INTEGER :: i +!*********************************************************************** + muskingum_init = 0 + + IF ( Init_vars_from_file==0 ) Outflow_ts = 0.0D0 + + Basin_segment_storage = 0.0D0 + DO i = 1, Nsegment + Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) + ENDDO + Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv + + END FUNCTION muskingum_init + +!*********************************************************************** +! muskingum_run - Compute routing summary values +!*********************************************************************** + INTEGER FUNCTION muskingum_run() + USE PRMS_MUSKINGUM + USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, Active_hrus, Hru_route_order, & + & Basin_gl_cfs, Basin_gl_ice_cfs + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & + & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & + & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out + USE PRMS_OBS, ONLY: Streamflow_cfs + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_ROUTING, ONLY: Use_transfer_segment, Segment_delta_flow, Basin_segment_storage, & + & Obsin_segment, Segment_order, Tosegment, C0, C1, C2, Ts, Ts_i, Obsout_segment, & + & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Segment_type, Flow_terminus, & + & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes, & + & Flow_in_great_lakes, Stage_ts, Stage_ante, Seg_bankflow, Mann_n, Seg_width, Seg_slope, Basin_bankflow, & + & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, Basin_ripflow, & + & Basin_bankst_seep_rate, Basin_bankflow, Basin_bankst_seep, Basin_bankst_vol, & + & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_seep, Basin_ripst_evap, & + & Basin_ripst_vol, Bankst_seep_rate + USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt + USE PRMS_SRUNOFF, ONLY: Basin_sroff + USE PRMS_GWFLOW, ONLY: Basin_gwflow + IMPLICIT NONE +! Functions + INTRINSIC MOD + EXTERNAL comp_bank_storage, drain_the_swamp +! Local Variables + INTEGER :: i, j, iorder, toseg, imod, tspd, segtype + DOUBLE PRECISION :: area_fac, segout, currin +!*********************************************************************** + muskingum_run = 0 + +! SET yesterdays inflows and outflows into temp (past arrays) +! values may be 0.0 as intial, > 0.0 for runtime and dynamic +! initial condtions. Then set outlfow and inflow for this time +! step to 0.0 +! +! upstream_inflow and outflow will vary by hour +! lateral_inflow and everything else will vary by day +! +! Compute surface runoff, ssflow, and gwflow going to each segment +! This is todays "seg_inflow" before additional water is routed to +! a new (if any is routed) +! +! For each HRU if the lateral flow for this HRU goes to the +! segment being evaluated (segment i) then sum flows +! +! Do these calculations once for the current day, before the hourly +! routing starts. +! +! Out2 = In2*C0 + In1*C1 + Out1*C2 +! Seg_outflow = Seg_inflow*Czero + Pastinflow*Cone + Pastoutflow*Ctwo +! C0, C1, and C2: initialized in the "init" part of this module +! + Pastin = Seg_inflow + Pastout = Seg_outflow + Seg_inflow = 0.0D0 + Seg_outflow = 0.0D0 + Inflow_ts = 0.0D0 + Currinsum = 0.0D0 + IF ( Ripst_flag==1 ) Stage_ante =Stage_ts + +! 24 hourly timesteps per day + DO j = 1, 24 + + Seg_upstream_inflow = 0.0D0 + DO i = 1, Nsegment + iorder = Segment_order(i) + +! current inflow to the segment is the time weighted average of the outflow +! of the upstream segments plus the lateral HRU inflow plus any gains. + currin = 0.0D0 !Seg_lateral_inflow(iorder) route this to outlet to be like mizuroute + IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) + currin = currin + Seg_upstream_inflow(iorder) + Seg_inflow(iorder) = Seg_inflow(iorder) + currin + Seg_lateral_inflow(iorder) + Inflow_ts(iorder) = Inflow_ts(iorder) + currin + Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder) + + ! Check to see if this segment is to be routed on this time step + tspd = Ts_i(iorder) + imod = MOD( j, tspd ) + IF ( imod==0 ) THEN + Inflow_ts(iorder) = (Inflow_ts(iorder) / Ts(iorder)) +! Compute routed streamflow + IF ( Ts_i(iorder)>0 ) THEN +! Muskingum routing equation + Outflow_ts(iorder) = Inflow_ts(iorder)*C0(iorder) + Pastin(iorder)*C1(iorder) + Outflow_ts(iorder)*C2(iorder) + ELSE +! If travel time (K_coef paremter) is less than or equal to +! time step (one hour), then the outflow is equal to the inflow +! Outflow_ts is the value from last hour + Outflow_ts(iorder) = Inflow_ts(iorder) + ENDIF + Outflow_ts(iorder) = Outflow_ts(iorder)+Seg_lateral_inflow(iorder) !add it here instead to be like mizuroute + + ! pastin is equal to the Inflow_ts on the previous routed timestep + Pastin(iorder) = Inflow_ts(iorder) + +! because the upstream inflow from streams is used, reset it to zero so new average +! can be computed next routing timestep. + Inflow_ts(iorder) = 0.0D0 + ENDIF + + IF ( Obsout_segment(iorder)>0 ) Outflow_ts(iorder) = Streamflow_cfs(Obsout_segment(iorder)) + + ! water-use removed/added in routing module + ! check for negative flow + IF ( Outflow_ts(iorder)<0.0 ) THEN + IF ( Use_transfer_segment==1 ) THEN + PRINT *, 'ERROR, transfer(s) from stream segment:', iorder, ' causes outflow to be negative' + PRINT *, ' outflow =', Outflow_ts(iorder), ' must fix water-use stream segment transfer file' + ELSE + PRINT *, 'ERROR, outflow from segment:', iorder, ' is negative:', Outflow_ts(iorder) + PRINT *, ' routing parameters may be invalid' + ENDIF + STOP + ENDIF + + ! Seg_outflow (the mean daily flow rate for each segment) will be the average of the hourly values. + Seg_outflow(iorder) = Seg_outflow(iorder) + Outflow_ts(iorder) + ! pastout is equal to the Inflow_ts on the previous routed timestep + Pastout(iorder) = Outflow_ts(iorder) + +! Add current timestep's flow rate to sum the upstream flow rates. +! This can be thought of as a volume because it is a volumetric rate +! (cubic feet per second) over a time step of an hour. Down below when +! this value is used, it will be divided by the number of hours in the +! segment's simulation time step, giving the mean flow rate over that +! period of time. + toseg = Tosegment(iorder) + IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Outflow_ts(iorder) + + ENDDO ! segment + + ENDDO ! timestep + + DO i = 1, Nsegment + Seg_outflow(i) = Seg_outflow(i) * ONE_24TH + ENDDO + ! for stage estimate + IF ( Ripst_flag==1 ) THEN + Basin_bankst_seep = 0.D0 + Basin_bankst_seep_rate = 0.0D0 + Basin_bankst_head = 0.0D0 + Basin_bankst_vol = 0.0D0 + Basin_ripst_area = 0.0D0 + Basin_ripst_seep = 0.0D0 + Basin_ripst_evap = 0.0D0 + Basin_ripst_vol = 0.0D0 + Bankst_seep_rate = 0.0 !collect by segment that HRUs go to + Seg_bankflow = 0.0D0 !collect by segment that HRUs go to + DO i = 1, Nsegment + Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & + & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + IF (Stage_ts(i)>250.) Stage_ts(i) = 250. + ENDDO + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) & + & CALL comp_bank_storage(i) +! ******Compute the bank storage component +! transfers water between separate bank storage and stream depending on seepage + ENDDO + Basin_bankst_seep = Basin_bankst_seep*Basin_area_inv + Basin_bankst_head = Basin_bankst_head*Basin_area_inv + Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv + DO i = 1, Nsegment + Basin_bankst_seep_rate = Basin_bankst_seep_rate + Bankst_seep_rate(i) & + & *Seg_length(i)/SUM(Seg_length) !m2/day per stream ft length + Seg_outflow(i) = Seg_outflow(i)+Seg_bankflow(i) + IF (Seg_bankflow(i) < 0.0) THEN ! only could go negative because of bankflow if is negative + IF (Seg_outflow(i) < 0.0) THEN ! took out more than streamflow, this could also be a water_use problem + Seg_bankflow(i) = Seg_bankflow(i) - Seg_outflow(i) + Seg_outflow(i) = 0.0 + ENDIF + ENDIF + ENDDO + Bankst_seep_rate = 0.0 !collect by segment that HRUs go to + Seg_ripflow = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_segment(i)>0 .AND. Ripst_areafr_max(i)>0.0) & + & CALL drain_the_swamp(i) +! ******Compute the overbank riparian storage component +! transfers water between separate riparian storage and stream depending on seepage + ENDDO + Basin_ripst_seep = Basin_ripst_seep*Basin_area_inv + Basin_ripst_evap = Basin_ripst_evap*Basin_area_inv + Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv + DO i = 1, Nsegment + Seg_outflow(i) = Seg_outflow(i)+Seg_ripflow(i) ! cannot go negative by design + Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & + & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + IF (Stage_ts(i)>250.) Stage_ts(i) = 250. + ENDDO + ENDIF + + Basin_segment_storage = 0.0D0 + Basin_bankflow = 0.0D0 + Basin_ripflow = 0.0D0 + Flow_out = 0.0D0 + Flow_to_lakes = 0.0D0 + Flow_to_ocean = 0.0D0 + Flow_to_great_lakes = 0.0D0 + Flow_out_region = 0.0D0 + Flow_out_NHM = 0.0D0 + Flow_in_region = 0.0D0 + Flow_terminus = 0.0D0 + Flow_in_nation = 0.0D0 + Flow_headwater = 0.0D0 + Flow_in_great_lakes = 0.0D0 + Flow_replacement = 0.0D0 + DO i = 1, Nsegment + segtype = Segment_type(i) + Seg_inflow(i) = Seg_inflow(i) * ONE_24TH + Seg_upstream_inflow(i) = Currinsum(i) * ONE_24TH + segout = Seg_outflow(i) +! Flow_out is the total flow out of the basin, which allows for multiple outlets +! includes closed basins (tosegment=0) + IF ( segtype==1 ) THEN + Flow_headwater = Flow_headwater + segout + ELSEIF ( segtype==2 ) THEN + Flow_to_lakes = Flow_to_lakes + segout + ELSEIF ( segtype==3 ) THEN + Flow_replacement = Flow_replacement + segout + ELSEIF ( segtype==4 ) THEN + Flow_in_nation = Flow_in_nation + segout + ELSEIF ( segtype==5 ) THEN + Flow_out_NHM = Flow_out_NHM + segout + ELSEIF ( segtype==6 ) THEN + Flow_in_region = Flow_in_region + segout + ELSEIF ( segtype==7 ) THEN + Flow_out_region = Flow_out_region + segout + ELSEIF ( segtype==8 ) THEN + Flow_to_ocean = Flow_to_ocean + segout + ELSEIF ( segtype==9 ) THEN + Flow_terminus = Flow_terminus + segout + ELSEIF ( segtype==10 ) THEN + Flow_in_great_lakes = Flow_in_great_lakes + segout + ELSEIF ( segtype==11 ) THEN + Flow_to_great_lakes = Flow_to_great_lakes + segout + ENDIF + IF ( Tosegment(i)==0 ) Flow_out = Flow_out + segout + Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout +! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) + Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) + IF ( Ripst_flag==1 ) THEN + Basin_bankflow = Basin_bankflow + Seg_bankflow(i) + Basin_ripflow = Basin_ripflow + Seg_ripflow(i) + ENDIF + ENDDO + + ENDDO + + area_fac = Cfs_conv/Basin_area_inv + Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows + Basin_cfs = Flow_out + Basin_stflow_out = Basin_cfs / area_fac + Basin_cms = Basin_cfs*CFS2CMS_CONV + IF ( Glacier_flag==1 ) THEN + Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt + Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac + Basin_gl_cfs = Basin_gl_top_melt*area_fac + ENDIF + Basin_sroff_cfs = Basin_sroff*area_fac + Basin_ssflow_cfs = Basin_ssflow*area_fac + Basin_gwflow_cfs = Basin_gwflow*area_fac + Basin_segment_storage = Basin_segment_storage/area_fac + IF ( Ripst_flag==1 ) THEN + Basin_bankflow = Basin_bankflow/area_fac + Basin_ripflow = Basin_ripflow/area_fac + ENDIF + + END FUNCTION muskingum_run + +!*********************************************************************** +! muskingum_restart - write or read restart file +!*********************************************************************** + SUBROUTINE muskingum_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_MUSKINGUM + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + ! Function + EXTERNAL :: check_restart + ! Local Variable + CHARACTER(LEN=9) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Outflow_ts + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Outflow_ts + ENDIF + END SUBROUTINE muskingum_restart diff --git a/prms/routing.f90 b/prms/routing.f90 index ab0b7ea9..efa04db8 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -24,7 +24,7 @@ MODULE PRMS_ROUTING DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_outflow(:), Seg_ssflow(:), Seg_sroff(:), Seg_gwflow(:) ! Declared Parameters INTEGER, SAVE, ALLOCATABLE :: Segment_type(:), Tosegment(:), Hru_segment(:), Obsin_segment(:), Obsout_segment(:) - REAL, SAVE, ALLOCATABLE :: Seg_depth(:), K_coef(:), X_coef(:), Mann_n(:), Seg_width(:) + REAL, SAVE, ALLOCATABLE :: Seg_depth(:), K_coef(:), X_coef(:), Mann_n(:), Seg_width(:), Segment_flow_init(:) REAL, SAVE, ALLOCATABLE :: Seg_length(:), Seg_slope(:) !in stream_temp too END MODULE PRMS_ROUTING @@ -58,7 +58,8 @@ END FUNCTION routing !*********************************************************************** INTEGER FUNCTION routingdecl() USE PRMS_ROUTING - USE PRMS_MODULE, ONLY: Nhru, Nsegment, Model, Strmflow_flag, Cascade_flag + USE PRMS_MODULE, ONLY: Nhru, Nsegment, Model, Strmflow_flag, Cascade_flag, & + & Init_vars_from_file IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declparam, declvar @@ -163,7 +164,7 @@ INTEGER FUNCTION routingdecl() & 'Segment river depth', & & 'Segment river depth at bankfull, shallowest from Blackburn-Lynch 2017,'//& & 'Congo is deepest at 250 m but in the US it is probably the Hudson at 66 m', & - & 'meters')/=0 ) CALL read_error(1, 'seg_width') + & 'meters')/=0 ) CALL read_error(1, 'seg_depth') ENDIF ALLOCATE ( Segment_type(Nsegment) ) @@ -213,6 +214,14 @@ INTEGER FUNCTION routingdecl() & 'Index of measured streamflow station that replaces outflow from a segment', & & 'none')/=0 ) CALL read_error(1, 'obsout_segment') + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN + ALLOCATE ( Segment_flow_init(Nsegment) ) + IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & + & '0.0', '0.0', '1.0E7', & + & 'Initial flow in each stream segment', & + & 'Initial flow in each stream segment', & + & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') + ENDIF IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Strmflow_flag==7 ) ALLOCATE ( K_coef(Nsegment) ) IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Model==99 ) THEN IF ( declparam(MODNAME, 'K_coef', 'nsegment', 'real', & @@ -308,6 +317,7 @@ INTEGER FUNCTION routinginit() & Water_use_flag, Segment_transferON_OFF, Inputerror_flag, Parameter_check_flag !, Print_debug USE PRMS_SET_TIME, ONLY: Timestep_seconds USE PRMS_BASIN, ONLY: FT2_PER_ACRE, DNEARZERO, Active_hrus, Hru_route_order, Hru_area_dble, NEARZERO !, Active_area + USE PRMS_FLOWVARS, ONLY: Seg_outflow IMPLICIT NONE ! Functions INTRINSIC MOD @@ -378,6 +388,15 @@ INTEGER FUNCTION routinginit() ALLOCATE ( C1(Nsegment), C2(Nsegment), C0(Nsegment), Ts(Nsegment), Ts_i(Nsegment) ) ENDIF + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN + IF ( getparam(MODNAME, 'segment_flow_init', Nsegment, 'real', Segment_flow_init)/=0 ) & + & CALL read_error(2,'segment_flow_init') + DO i = 1, Nsegment + Seg_outflow(i) = Segment_flow_init(i) + ENDDO + DEALLOCATE ( Segment_flow_init ) + ENDIF + ! if cascades are active then ignore hru_segment Noarea_flag = 0 IF ( Hru_seg_cascades==1 ) THEN @@ -626,13 +645,14 @@ INTEGER FUNCTION route_run() USE PRMS_WATER_USE, ONLY: Segment_transfer, Segment_gain USE PRMS_GWFLOW, ONLY: Gwres_flow USE PRMS_SRUNOFF, ONLY: Strm_seg_in + USE PRMS_GLACR, ONLY: Glacr_flow IMPLICIT NONE +! Functions INTRINSIC DBLE ! Local Variables - INTEGER :: i, j, jj + INTEGER :: i, j, jj,this_seg DOUBLE PRECISION :: tocfs LOGICAL :: found - INTEGER :: this_seg !*********************************************************************** route_run = 0 @@ -660,6 +680,9 @@ INTEGER FUNCTION route_run() j = Hru_route_order(jj) tocfs = DBLE( Hru_area(j) )*Cfs_conv Hru_outflow(j) = DBLE( (Sroff(j) + Ssres_flow(j) + Gwres_flow(j)) )*tocfs + ! Note: glacr_flow (from glacier or snowfield) is added as a gain, outside stream network addition + ! glacr_flow in inch^3, 1728=12^3 + IF ( Glacier_flag==1 ) Hru_outflow(j) = Hru_outflow(j) + Glacr_flow(j)/1728.0/Timestep_seconds IF ( Hru_seg_cascades==1 ) THEN i = Hru_segment(j) IF ( i>0 ) THEN diff --git a/prms/routingRip.f90 b/prms/routingRip.f90 new file mode 100644 index 00000000..561a661b --- /dev/null +++ b/prms/routingRip.f90 @@ -0,0 +1,1556 @@ +!*********************************************************************** +! Defines stream and lake routing parameters and variables +!*********************************************************************** + MODULE PRMS_ROUTING + IMPLICIT NONE +! Local Variables + CHARACTER(LEN=7), SAVE :: MODNAME + DOUBLE PRECISION, SAVE :: Cfs2acft + DOUBLE PRECISION, SAVE :: Segment_area + INTEGER, SAVE :: Use_transfer_segment, Noarea_flag, Hru_seg_cascades + INTEGER, SAVE, ALLOCATABLE :: Segment_order(:), Segment_up(:), Seg_hru_num(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Segment_hruarea(:) + CHARACTER(LEN=80), SAVE :: Version_routing + !CHARACTER(LEN=32), SAVE :: Outfmt + INTEGER, SAVE, ALLOCATABLE :: Ts_i(:) + REAL, SAVE, ALLOCATABLE :: Ts(:), C0(:), C1(:), C2(:) + REAL, SAVE, ALLOCATABLE :: Ripst_area_max(:), Ripst_area(:), Ripst_depth(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_vol_max(:) +! Declared Variables + DOUBLE PRECISION, SAVE :: Basin_segment_storage + DOUBLE PRECISION, SAVE :: Flow_to_lakes, Flow_to_ocean, Flow_to_great_lakes, Flow_out_region + DOUBLE PRECISION, SAVE :: Flow_in_region, Flow_in_nation, Flow_headwater, Flow_out_NHM + DOUBLE PRECISION, SAVE :: Flow_in_great_lakes, Flow_replacement, Flow_terminus + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seginc_ssflow(:), Seginc_sroff(:), Segment_delta_flow(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seginc_gwflow(:), Seginc_swrad(:), Seginc_potet(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_outflow(:), Seg_ssflow(:), Seg_sroff(:), Seg_gwflow(:) +! Declared Parameters + INTEGER, SAVE, ALLOCATABLE :: Segment_type(:), Tosegment(:), Hru_segment(:), Obsin_segment(:), Obsout_segment(:) + REAL, SAVE, ALLOCATABLE :: Seg_depth(:), K_coef(:), X_coef(:), Mann_n(:), Seg_width(:), Segment_flow_init(:) + REAL, SAVE, ALLOCATABLE :: Seg_length(:), Seg_slope(:) !in stream_temp too +! Declared Parameters for Overbank and bank Storage + REAL, SAVE, ALLOCATABLE :: Transmiss_seg(:), Ripst_areafr_max(:) +! Declared Parameters for Overbank Storage + REAL, SAVE, ALLOCATABLE :: Tr_ratio(:), Porosity_seg(:), Ripst_et_coef(:), Ripst_frac_init(:) +! Declared Variables for Overbank Storage + DOUBLE PRECISION, SAVE :: Basin_ripst_evap, Basin_ripst_seep, Basin_ripflow, Basin_ripst_vol, Basin_ripst_area + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_stor_hru(:), Ripst_seep_hru(:), Ripst_vol(:), Seg_ripflow(:) + REAL, SAVE, ALLOCATABLE :: Ripst_evap_hru(:), Ripst_frac(:) +! Declared Parameters for Bank Storage + REAL, SAVE, ALLOCATABLE :: Specyield_seg(:), Bankst_head_init(:) + INTEGER, SAVE, ALLOCATABLE :: Bankfinite_hru(:) +! Declared Variables for Bank Storage + DOUBLE PRECISION, SAVE :: Basin_bankst_head, Basin_bankst_seep_rate, Basin_bankflow + DOUBLE PRECISION, SAVE :: Basin_bankst_seep, Basin_bankst_vol, Basin_bankst_area + REAL, SAVE, ALLOCATABLE :: Bankst_head(:), Bankst_seep_rate(:), Bankst_seep_hru(:) + REAL, SAVE, ALLOCATABLE :: Bankst_stor_hru(:), Bankst_head_pts(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Stage_ante(:), Stage_ts(:), Seg_bankflow(:) + END MODULE PRMS_ROUTING + +!*********************************************************************** +! Main routing routine +!*********************************************************************** + INTEGER FUNCTION routing() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: routingdecl, routinginit, route_run + EXTERNAL :: routing_restart +!*********************************************************************** + routing = 0 + + IF ( Process(:3)=='run' ) THEN + routing = route_run() + ELSEIF ( Process(:4)=='decl' ) THEN + routing = routingdecl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL routing_restart(1) + routing = routinginit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL routing_restart(0) + ENDIF + + END FUNCTION routing + +!*********************************************************************** +! routingdecl - set up parameters +!*********************************************************************** + INTEGER FUNCTION routingdecl() + USE PRMS_ROUTING + USE PRMS_MODULE, ONLY: Nhru, Nsegment, Model, Strmflow_flag, Cascade_flag, & + & Ripst_flag, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar + EXTERNAL read_error, print_module +!*********************************************************************** + routingdecl = 0 + + Version_routing = 'routing.f90 2019-06-05 17:22:00Z' + CALL print_module(Version_routing, 'Routing Initialization ', 90) + MODNAME = 'routing' + +! Declared Variables + ALLOCATE ( Hru_outflow(Nhru) ) + IF ( declvar(MODNAME, 'hru_outflow', 'nhru', Nhru, 'double', & + & 'Total flow leaving each HRU', & + & 'cfs', Hru_outflow)/=0 ) CALL read_error(3, 'hru_outflow') + + IF ( declvar(MODNAME, 'flow_to_lakes', 'one', 1, 'double', & + & 'Total flow to lakes (segment_type=2)', & + & 'cfs', Flow_to_lakes)/=0 ) CALL read_error(3, 'flow_to_lakes') + + IF ( declvar(MODNAME, 'flow_terminus', 'one', 1, 'double', & + & 'Total flow to terminus segments (segment_type=9)', & + & 'cfs', Flow_terminus)/=0 ) CALL read_error(3, 'flow_terminus') + + IF ( declvar(MODNAME, 'flow_to_ocean', 'one', 1, 'double', & + & 'Total flow to oceans (segment_type=8)', & + & 'cfs', Flow_to_ocean)/=0 ) CALL read_error(3, 'flow_to_ocean') + + IF ( declvar(MODNAME, 'flow_to_great_lakes', 'one', 1, 'double', & + & 'Total flow to Great Lakes (segment_type=11)', & + & 'cfs', Flow_to_great_lakes)/=0 ) CALL read_error(3, 'Flow_to_great_lakes') + + IF ( declvar(MODNAME, 'flow_out_region', 'one', 1, 'double', & + & 'Total flow out of region (segment_type=7)', & + & 'cfs', Flow_out_region)/=0 ) CALL read_error(3, 'flow_out_region') + + IF ( declvar(MODNAME, 'flow_out_NHM', 'one', 1, 'double', & + & 'Total flow out of model domain to Mexico or Canada (segment_type=5)', & + & 'cfs', Flow_out_NHM)/=0 ) CALL read_error(3, 'flow_out_NHM') + + IF ( declvar(MODNAME, 'flow_in_region', 'one', 1, 'double', & + & 'Total flow into region (segment_type=6)', & + & 'cfs', Flow_in_region)/=0 ) CALL read_error(3, 'flow_in_region') + + IF ( declvar(MODNAME, 'flow_in_nation', 'one', 1, 'double', & + & 'Total flow into model domain from Mexico or Canada (segment_type=4)', & + & 'cfs', Flow_in_nation)/=0 ) CALL read_error(3, 'flow_in_nation') + + IF ( declvar(MODNAME, 'flow_headwater', 'one', 1, 'double', & + & 'Total flow out of headwater segments (segment_type=1)', & + & 'cfs', Flow_headwater)/=0 ) CALL read_error(3, 'flow_headwater') + + IF ( declvar(MODNAME, 'flow_in_great_lakes', 'one', 1, 'double', & + & 'Total flow out into model domain from Great Lakes (segment_type=10)', & + & 'cfs', Flow_in_great_lakes)/=0 ) CALL read_error(3, 'flow_in_great_lakes') + + IF ( declvar(MODNAME, 'flow_replacement', 'one', 1, 'double', & + & 'Total flow out from replacement flow (segment_type=3)', & + & 'cfs', Flow_replacement)/=0 ) CALL read_error(3, 'flow_replacement') + + ! 0 = normal; 1 = headwater; 2 = lake; 3 = replacement flow; 4 = inbound to nation; + ! 5 = outbound from nation; 6 = inbound to region; 7 = outbound from region; + ! 8 = drains to ocean; 9 = sink (terminus to soil); 10 = inbound from Great Lakes; + ! 11 = outbound to Great Lakes; 12 = ephemeral; + 100 user updated; 1000 user virtual segment + ! 100 = user normal; 101 - 108 = not used; 109 sink (tosegment used by Lumen) + + IF ( Ripst_flag==1 .OR. Model==99 ) THEN +! Overbank storage variables + IF ( declvar(MODNAME, 'basin_ripst_evap', 'one', 1, 'double', & + & 'Basin area-weighted average evaporation from riparian overbank flow storage', & + & 'inches', Basin_ripst_evap)/=0 ) CALL read_error(3, 'basin_ripst_evap') + + IF ( declvar(MODNAME, 'basin_ripst_seep', 'one', 1, 'double', & + & 'Basin area-weighted average seepage from riparian overbank flow storage', & + & 'inches', Basin_ripst_seep)/=0 ) CALL read_error(3, 'basin_ripst_seep') + + IF ( declvar(MODNAME, 'basin_ripst_vol', 'one', 1, 'double', & + & 'Basin area-weighted average storage volume in riparian overbank flow storage', & + & 'inches', Basin_ripst_vol)/=0 ) CALL read_error(3, 'basin_ripst_vol') + + IF ( declvar(MODNAME, 'basin_ripst_area', 'one', 1, 'double', & + & 'Basin area of riparian overbank flow storage', & + & 'acres', Basin_ripst_area)/=0 ) CALL read_error(3, 'basin_ripst_area') + + ALLOCATE ( Seg_ripflow(Nsegment) ) + IF ( declvar(MODNAME, 'seg_ripflow', 'nsegment', Nsegment, 'double', & + & 'Riparian area contribution to streamflow, negative if steam goes overbank', & + & 'cfs', Seg_ripflow)/=0 ) CALL read_error(3, 'seg_ripflow') + + ALLOCATE ( Ripst_stor_hru(Nhru) ) + IF ( declvar(MODNAME, 'ripst_stor_hru', 'nhru', Nhru, 'double', & + & 'Riparian overbank flow storage for each HRU', & + & 'inches', Ripst_stor_hru)/=0 ) CALL read_error(3, 'ripst_stor_hru') + + ALLOCATE ( Ripst_seep_hru(Nhru) ) + IF ( declvar(MODNAME, 'ripst_seep_hru', 'nhru', Nhru, 'double', & + & 'Seepage from riparian overbank flow storage to associated riparian-GWR for each HRU', & + & 'inches', Ripst_seep_hru)/=0 ) CALL read_error(3, 'ripst_seep_hru') + + ALLOCATE ( Ripst_evap_hru(Nhru) ) + IF ( declvar(MODNAME, 'ripst_evap_hru', 'nhru', Nhru, 'real', & + & 'Evaporation from riparian overbank flow storage for each HRU', & + & 'inches', Ripst_evap_hru)/=0 ) CALL read_error(3, 'ripst_evap_hru') + + ALLOCATE ( Ripst_vol(Nhru) ) + IF ( declvar(MODNAME, 'ripst_vol', 'nhru', Nhru, 'double', & + & 'Volume in riparian overbank flow storage for each HRU', & + & 'acre-inches', Ripst_vol)/=0 ) CALL read_error(3, 'ripst_vol') + + ALLOCATE ( Ripst_frac(Nhru) ) + IF ( declvar(MODNAME, 'ripst_frac', 'nhru', Nhru, 'real', & + & 'Volume and area fraction of riparian overbank flow storage of the maximum storage for each HRU', & + & 'decimal fraction', Ripst_frac)/=0 ) CALL read_error(3, 'ripst_frac') + + IF ( declvar(MODNAME, 'basin_ripflow', 'one', 1, 'double', & + & 'Basin riparian area contribution to streamflow, negative if steam goes overbank', & + & 'cfs', Basin_bankflow)/=0 ) CALL read_error(3, 'basin_ripflow') + + ALLOCATE ( Ripst_vol_max(Nhru), Ripst_area(Nhru), Ripst_area_max(Nhru), Ripst_depth(Nhru) ) + ALLOCATE ( Seg_hru_num(Nsegment) ) + +! Bank storage variables + IF ( declvar(MODNAME, 'basin_bankst_head', 'one', 1, 'double', & + & 'Basin bank storage area only area-weighted average head of bank storage above groundwater head', & + & 'meters', Basin_bankst_head)/=0 ) CALL read_error(3, 'basin_bankst_head') + + IF ( declvar(MODNAME, 'basin_bankst_seep', 'one', 1, 'double', & + & 'Basin area-weighted average seepage from bank storage to streams', & + & 'inches', Basin_bankst_seep)/=0 ) CALL read_error(3, 'basin_bankst_seep') + + IF ( declvar(MODNAME, 'basin_bankst_vol', 'one', 1, 'double', & + & 'Basin area-weighted average bank storage', & + & 'inches', Basin_bankst_vol)/=0 ) CALL read_error(3, 'basin_bankst_vol') + + IF ( declvar(MODNAME, 'basin_bankst_area', 'one', 1, 'double', & + & 'Basin area bank storage, if all semi-infinite will be area of basin', & + & 'acres', Basin_bankst_area)/=0 ) CALL read_error(3, 'basin_bankst_area') + + IF ( declvar(MODNAME, 'basin_bankst_seep_rate', 'one', 1, 'double', & + & 'Basin rate of seepage from bank storage into stream per unit length stream', & + & 'meter3/day/meter', Basin_bankst_seep_rate)/=0 ) CALL read_error(3, 'basin_bankst_seep_rate') + + IF ( declvar(MODNAME, 'basin_bankflow', 'one', 1, 'double', & + & 'Basin bank storage contribution to streamflow can be negative if steam losing water', & + & 'cfs', Basin_bankflow)/=0 ) CALL read_error(3, 'basin_bankflow') + + ALLOCATE ( Bankst_head(Nhru) ) + IF ( declvar(MODNAME, 'bankst_head', 'nhru', Nhru, 'real', & + & 'Bank storage area only average head of bank storage above groundwater head', & + & 'meters', Bankst_head)/=0 ) CALL read_error(3, 'bankst_head') + + ALLOCATE ( Seg_bankflow(Nsegment) ) + IF ( declvar(MODNAME, 'seg_bankflow', 'nsegment', Nsegment, 'double', & + & 'Bank storage area contribution to streamflow can be negative if steam losing water', & + & 'cfs', Seg_bankflow)/=0 ) CALL read_error(3, 'seg_bankflow') + + ALLOCATE ( Bankst_head_pts(Nhru) ) + IF ( declvar(MODNAME, 'bankst_head_pts', 'nhru', Nhru, 'real', & + & 'Head of bank storage above groundwater head: at half width away', & + & 'meters', Bankst_head_pts)/=0 ) CALL read_error(3, 'bankst_head_pts') + + ALLOCATE ( Stage_ante(Nsegment) ) + IF ( declvar(MODNAME, 'stage_ante', 'nsegment', Nsegment, 'double', & + & 'Antecedent stage height of segment, estimated with Manning Equation', & + & 'meters', stage_ante)/=0 ) CALL read_error(3, 'stage_ante') + + ALLOCATE ( Stage_ts(Nsegment) ) + IF ( declvar(MODNAME, 'stage_ts', 'nsegment', Nsegment, 'double', & + & 'Stage height of segment, estimated with Manning Equation', & + & 'meters', stage_ts)/=0 ) CALL read_error(3, 'stage_ts') + + ALLOCATE ( Bankst_seep_hru(Nhru) ) + IF ( declvar(MODNAME, 'bankst_seep_hru', 'nhru', Nhru, 'real', & + & 'HRU average seepage from bank storage to associated stream_segment for each HRU', & + & 'inches', Bankst_seep_hru)/=0 ) CALL read_error(3, 'bankst_seep_hru') + + ALLOCATE ( Bankst_stor_hru(Nhru) ) + IF ( declvar(MODNAME, 'bankst_stor_hru', 'nhru', Nhru, 'real', & + & 'HRU average bank storage for each HRU', & + & 'inches', Bankst_stor_hru)/=0 ) CALL read_error(3, 'bankst_stor_hru') + + ALLOCATE ( Bankst_seep_rate(Nsegment) ) + IF ( declvar(MODNAME, 'bankst_seep_rate', 'nsegment', Nsegment, 'real', & + & 'Seepage rate from bank storage into stream per unit length segment', & + & 'meter2/day', Bankst_seep_rate )/=0 ) CALL read_error(1, 'bankst_seep_rate') + + ENDIF + + IF ( Strmflow_flag==6 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN + ALLOCATE ( Mann_n(Nsegment) ) + IF ( declparam( MODNAME, 'mann_n', 'nsegment', 'real', & + & '0.04', '0.001', '0.15', & + & 'Mannings roughness coefficient', & + & 'Mannings roughness coefficient for each segment', & + & 'dimensionless')/=0 ) CALL read_error(1, 'mann_n') + + ALLOCATE ( Seg_width(Nsegment) ) + IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & + & '15.0', '0.18', '40000.0', & + & 'Segment river width', & + & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & + & 'meters')/=0 ) CALL read_error(1, 'seg_width') + + ALLOCATE ( Seg_slope(Nsegment) ) + IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & + & '0.0001', '0.0000001', '2.0', & + & 'Surface slope of each segment', & + & 'Surface slope of each segment as approximation for bed slope of stream', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'seg_slope') + + ALLOCATE ( Seg_length(Nsegment) ) + IF ( declparam( MODNAME, 'seg_length', 'nsegment', 'real', & + & '1000.0', '0.001', '200000.0', & + & 'Length of each segment', & + & 'Length of each segment, bounds based on CONUS', & + & 'meters')/=0 ) CALL read_error(1, 'seg_length') + ENDIF + + IF (Ripst_flag==1 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN + ALLOCATE ( Seg_depth(Nsegment) ) + IF ( declparam(MODNAME, 'seg_depth', 'nsegment', 'real', & + & '1.0', '0.03', '250.0', & + & 'Segment river depth', & + & 'Segment river depth at bankfull, shallowest from Blackburn-Lynch 2017,'//& + & 'Congo is deepest at 250 m but in the US it is probably the Hudson at 66 m', & + & 'meters')/=0 ) CALL read_error(1, 'seg_depth') + ENDIF + + ALLOCATE ( Segment_type(Nsegment) ) + IF ( declparam(MODNAME, 'segment_type', 'nsegment', 'integer', & + & '0', '0', '111', & + & 'Segment type', & + & 'Segment type (0=segment; 1=headwater; 2=lake; 3=replace inflow; 4=inbound to NHM;'// & + & ' 5=outbound from NHM; 6=inbound to region; 7=outbound from region; 8=drains to ocean;'// & + & ' 9=sink; 10=inbound from Great Lakes; 11=outbound to Great Lakes)', & + & 'none')/=0 ) CALL read_error(1, 'segment_type') + + ! user updated values if different than tosegment_orig + ! -5 = outbound from NHM; -6 = inbound from region; -7 = outbound from region; + ! -8 = drains to ocean; -11 = drains to Great Lake + ALLOCATE ( Tosegment(Nsegment) ) + IF ( declparam(MODNAME, 'tosegment', 'nsegment', 'integer', & + & '0', '-11', '1000000', & + & 'The index of the downstream segment', & + & 'Index of downstream segment to which the segment'// & + & ' streamflow flows, for segments that do not flow to another segment enter 0', & + & 'none')/=0 ) CALL read_error(1, 'tosegment') + + IF ( Cascade_flag==0 .OR. Cascade_flag==2 .OR. Model==99 ) THEN + Hru_seg_cascades = 1 + ALLOCATE ( Hru_segment(Nhru) ) + IF ( declparam(MODNAME, 'hru_segment', 'nhru', 'integer', & + & '0', 'bounded', 'nsegment', & + & 'Segment index for HRU lateral inflows', & + & 'Segment index to which an HRU contributes lateral flows'// & + & ' (surface runoff, interflow, and groundwater discharge)', & + & 'none')/=0 ) CALL read_error(1, 'hru_segment') + ELSE + Hru_seg_cascades = 0 + ENDIF + + ALLOCATE ( Obsin_segment(Nsegment) ) + IF ( declparam(MODNAME, 'obsin_segment', 'nsegment', 'integer', & + & '0', 'bounded', 'nobs', & + & 'Index of measured streamflow station that replaces inflow to a segment', & + & 'Index of measured streamflow station that replaces inflow to a segment', & + & 'none')/=0 ) CALL read_error(1, 'obsin_segment') + + ALLOCATE ( Obsout_segment(Nsegment) ) + IF ( declparam(MODNAME, 'obsout_segment', 'nsegment', 'integer', & + & '0', 'bounded', 'nobs', & + & 'Index of measured streamflow station that replaces outflow from a segment', & + & 'Index of measured streamflow station that replaces outflow from a segment', & + & 'none')/=0 ) CALL read_error(1, 'obsout_segment') + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN + ALLOCATE ( Segment_flow_init(Nsegment) ) + IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & + & '0.0', '0.0', '1.0E7', & + & 'Initial flow in each stream segment', & + & 'Initial flow in each stream segment', & + & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') +! Bank Storage parameters: + IF ( Ripst_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Bankst_head_init(Nhru) ) + IF ( declparam(MODNAME, 'bankst_head_init', 'nhru', 'real', & + & '0.0', '0.0', '1000.0', & + & 'Bank storage area only average initial head of bank storage above groundwater head', & + & 'Bank storage area only average initial head of bank storage above groundwater head', & + & 'meters')/=0 ) CALL read_error(1, 'bankst_head_init') + +! Riparian Overbank Storage parameters: + ALLOCATE ( Ripst_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'ripst_frac_init', 'nhru', 'real', & + & '0.5', '0.0', '1.0', & + & 'Fraction of maximum storage that contains water at the start of a simulation', & + & 'Fraction of maximum riparian overbank flow storage that'// & + & ' contains water at the start of a simulation', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_frac_init') + + ENDIF + ENDIF + + IF ( Ripst_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Ripst_areafr_max(Nhru) ) + IF ( declparam(MODNAME, 'ripst_areafr_max', 'nhru', 'real', & + & '0.1', '0.0', '1.0', & + & 'Surface area fraction of HRU that has possible riparian overbank or bank storage', & + & 'Surface area fraction of HRU that has possible riparian overbank or bank storage;'// & + & ' if =0, then overbank storage is turned off, if also bankfinite_hru =1 bank storage is off', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_areafr_max') + + ALLOCATE ( Porosity_seg(Nhru) ) + IF ( declparam(MODNAME, 'porosity_seg', 'nsegment', 'real', & + & '0.4', '0.15', '0.75', & + & 'Porosity of soil of riparian overbank flow storage', & + & 'Porosity of soil around segment involved in riparian overbank flow storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'porosity_seg') + + ALLOCATE ( Ripst_et_coef(Nhru) ) + IF ( declparam(MODNAME, 'ripst_et_coef', 'nhru', 'real', & + & '1.0', '0.0', '1.0', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to riparian overbank flow storage', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to riparian overbank flow storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_et_coef') + + ALLOCATE ( Tr_ratio(Nhru) ) + IF ( declparam(MODNAME, 'tr_ratio', 'nhru', 'real', & + & '0.5', '0.0', '1.0', & + & 'Triangle to rectangle ratio describing vertical cross-section'// & + & ' shape of riparian overbank flow storage', & + & 'Triangle to rectangle ratio describing vertical cross-section'// & + & ' shape of riparian overbank flow storage;'// & + & ' 1 is a triangle, 0 is a rectangle', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'tr_ratio') + + ALLOCATE ( Bankfinite_hru(Nhru) ) + IF ( declparam(MODNAME, 'bankfinite_hru', 'nhru', 'integer', & + & '0', '0', '1', & + & 'Bank storage is finite flag', & + & '1 means the bank storage is considered finite and not semi-infinite', & + & 'none')/=0 ) CALL read_error(1, 'bankfinite_hru') + + ALLOCATE ( Transmiss_seg(Nsegment) ) + IF ( declparam(MODNAME, 'transmiss_seg', 'nsegment', 'real', & + & '50.0', '0.00001', '100000', & + & 'Effective transmissivity of groundwater aquifer beneath segment', & + & 'Efective transmissivity of groundwater aquifer beneath segment;'// & + & ' 1.e-8 is unfractured basalt; 10000 is gravel', & + & 'm squared/day')/=0 ) CALL read_error(1, 'transmiss_seg') + + ALLOCATE ( Specyield_seg(Nsegment) ) !Storativity approximated as Specific yield since storativity hard to measure + IF ( declparam(MODNAME, 'specyield_seg', 'nsegment', 'real', & + & '0.2', '0.01', '0.5', & + & 'Volume of water released from storage per unit aquifer surface per unit head decline', & + & 'Volume of water released from storage per unit aquifer surface per unit head decline; '// & + & ' 0.01 is clay; 0.5 is peat', & + & 'none')/=0 ) CALL read_error(1, 'specyield_seg') + +! Not using at moment +! ALLOCATE ( Gwdepth_seg(Nsegment) ) +! IF ( declparam(MODNAME, 'gwdepth_seg', 'nsegment', 'real', & +! & '100.0', '-10.0', '10000.0', & +! & 'Depth to groundwater aquifer beneath segment', & +! & 'Depth to groundwater aquifer beneath segment;'// & +! & ' CONUS goes to ~300 m, but worldwide higher', & +! & 'meters')/=0 ) CALL read_error(1, 'gwdepth_seg') + + ENDIF + + + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Strmflow_flag==7 ) ALLOCATE ( K_coef(Nsegment) ) + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Model==99 ) THEN + IF ( declparam(MODNAME, 'K_coef', 'nsegment', 'real', & + & '1.0', '0.01', '24.0', & + & 'Muskingum storage coefficient', & + & 'Travel time of flood wave from one segment to the next downstream segment,'// & + & ' called the Muskingum storage coefficient; enter 1.0 for reservoirs,'// & + & ' diversions, and segment(s) flowing out of the basin', & + & 'hours')/=0 ) CALL read_error(1, 'K_coef') + ENDIF + + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN + ALLOCATE ( X_coef(Nsegment) ) + IF ( declparam(MODNAME, 'x_coef', 'nsegment', 'real', & + & '0.2', '0.0', '0.5', & + & 'Routing weighting factor', & + & 'The amount of attenuation of the flow wave, called the'// & + & ' Muskingum routing weighting factor; enter 0.0 for'// & + & ' reservoirs, diversions, and segment(s) flowing out of the basin', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'x_coef') + ENDIF + + IF ( Hru_seg_cascades==1 .OR. Model==99 ) THEN + ALLOCATE ( Seginc_potet(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_potet', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average potential ET for each segment'// & + & ' from HRUs contributing flow to the segment', & + & 'inches', Seginc_potet)/=0 ) CALL read_error(3, 'seginc_potet') + + ALLOCATE ( Seginc_swrad(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_swrad', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average solar radiation for each segment'// & + & ' from HRUs contributing flow to the segment', & + & 'Langleys', Seginc_swrad)/=0 ) CALL read_error(3, 'seginc_swrad') + + ALLOCATE ( Seginc_ssflow(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_ssflow', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average interflow for each segment from'// & + & ' HRUs contributing flow to the segment', & + & 'cfs', Seginc_ssflow)/=0 ) CALL read_error(3, 'seginc_ssflow') + + ALLOCATE ( Seginc_gwflow(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_gwflow', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average groundwater discharge for each'// & + & ' segment from HRUs contributing flow to the segment', & + & 'cfs', Seginc_gwflow)/=0 ) CALL read_error(3, 'seginc_gwflow') + + ALLOCATE ( Seginc_sroff(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_sroff', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average surface runoff for each'// & + & ' segment from HRUs contributing flow to the segment', & + & 'cfs', Seginc_sroff)/=0 ) CALL read_error(3, 'seginc_sroff') + + ALLOCATE ( Seg_ssflow(Nsegment) ) + IF ( declvar(MODNAME, 'seg_ssflow', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average interflow for each segment from'// & + & ' HRUs contributing flow to the segment and upstream HRUs', & + & 'inches', Seg_ssflow)/=0 ) CALL read_error(3, 'seg_ssflow') + + ALLOCATE ( Seg_gwflow(Nsegment) ) + IF ( declvar(MODNAME, 'seg_gwflow', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average groundwater discharge for each segment from'// & + & ' HRUs contributing flow to the segment and upstream HRUs', & + & 'inches', Seg_gwflow)/=0 ) CALL read_error(3, 'seg_gwflow') + + ALLOCATE ( Seg_sroff(Nsegment) ) + IF ( declvar(MODNAME, 'seg_sroff', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average surface runoff for each segment from'// & + & ' HRUs contributing flow to the segment and upstream HRUs', & + & 'inches', Seg_sroff)/=0 ) CALL read_error(3, 'seg_sroff') + ENDIF + + IF ( declvar(MODNAME, 'basin_segment_storage', 'one', 1, 'double', & + & 'Basin area-weighted average storage in the stream network', & + & 'inches', Basin_segment_storage)/=0 ) CALL read_error(3, 'basin_segment_storage') + + ALLOCATE ( Segment_delta_flow(Nsegment) ) + IF ( declvar(MODNAME, 'segment_delta_flow', 'nsegment', Nsegment, 'double', & + & 'Cummulative flow in minus flow out for each stream segment', & + & 'cfs', Segment_delta_flow)/=0 ) CALL read_error(3, 'segment_delta_flow') + + ! local arrays + ALLOCATE ( Segment_order(Nsegment), Segment_up(Nsegment), Segment_hruarea(Nsegment) ) + + END FUNCTION routingdecl + +!********************************************************************** +! routinginit - check for validity of parameters +!********************************************************************** + INTEGER FUNCTION routinginit() + USE PRMS_ROUTING + USE PRMS_MODULE, ONLY: Nsegment, Nhru, Init_vars_from_file, Strmflow_flag, & + & Water_use_flag, Segment_transferON_OFF, Inputerror_flag, Parameter_check_flag , & + & Ripst_flag !, Print_debug + USE PRMS_SET_TIME, ONLY: Timestep_seconds + USE PRMS_BASIN, ONLY: FT2_PER_ACRE, DNEARZERO, Active_hrus, Hru_route_order, Hru_area_dble, NEARZERO, & + & Hru_area, FEET2METERS !, Active_area + USE PRMS_FLOWVARS, ONLY: Seg_outflow + IMPLICIT NONE +! Functions + INTRINSIC MOD, DBLE + INTEGER, EXTERNAL :: getparam + EXTERNAL :: read_error +! Local Variable + INTEGER :: i, j, test, lval, toseg, iseg, isegerr, ierr, eseg + REAL :: k, x, d, x_max, velocity + DOUBLE PRECISION :: flow + INTEGER, ALLOCATABLE :: x_off(:) + CHARACTER(LEN=10) :: buffer +!********************************************************************** + routinginit = 0 + + Use_transfer_segment = 0 + IF ( Water_use_flag==1 .AND. Segment_transferON_OFF==1 ) Use_transfer_segment = 1 + + IF ( Init_vars_from_file==0 ) THEN + Basin_segment_storage = 0.0D0 + Segment_delta_flow = 0.0D0 + ENDIF + + IF ( Hru_seg_cascades==1 ) THEN + Seginc_potet = 0.0D0 + Seginc_gwflow = 0.0D0 + Seginc_ssflow = 0.0D0 + Seginc_sroff = 0.0D0 + Seginc_swrad = 0.0D0 + Seg_gwflow = 0.0D0 + Seg_ssflow = 0.0D0 + Seg_sroff = 0.0D0 + ENDIF + Hru_outflow = 0.0D0 + Flow_to_ocean = 0.0D0 + Flow_to_great_lakes = 0.0D0 + Flow_out_region = 0.0D0 + Flow_out_NHM = 0.0D0 + Flow_terminus = 0.0D0 + Flow_to_lakes = 0.0D0 + Flow_in_nation = 0.0D0 + Flow_in_region = 0.0D0 + Flow_headwater = 0.0D0 + Flow_in_great_lakes = 0.0D0 + Flow_replacement = 0.0D0 + + Cfs2acft = Timestep_seconds/FT2_PER_ACRE + + IF ( getparam(MODNAME, 'segment_type', Nsegment, 'integer', Segment_type)/=0 ) CALL read_error(2, 'segment_type') + DO i = 1, Nsegment + Segment_type(i) = MOD( Segment_type(i), 100 ) + ENDDO + + IF ( Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN + IF ( getparam(MODNAME, 'mann_n', Nsegment, 'real', Mann_n)/=0 ) CALL read_error(2, 'mann_n') + IF ( getparam(MODNAME, 'seg_width', Nsegment, 'real', Seg_width)/=0 ) CALL read_error(2, 'seg_width') + IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') + IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') + ENDIF + IF ( Ripst_flag==1 .OR. Strmflow_flag==7 ) THEN + IF ( getparam(MODNAME, 'seg_depth', Nsegment, 'real', seg_depth)/=0 ) CALL read_error(2, 'seg_depth') + ENDIF + + IF ( getparam(MODNAME, 'tosegment', Nsegment, 'integer', Tosegment)/=0 ) CALL read_error(2, 'tosegment') + IF ( getparam(MODNAME, 'obsin_segment', Nsegment, 'integer', Obsin_segment)/=0 ) CALL read_error(2, 'obsin_segment') + IF ( getparam(MODNAME, 'obsout_segment', Nsegment, 'integer', Obsout_segment)/=0 ) CALL read_error(2, 'obsout_segment') + + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Strmflow_flag==7 ) THEN + IF ( getparam(MODNAME, 'x_coef', Nsegment, 'real', X_coef)/=0 ) CALL read_error(2, 'x_coef') + ALLOCATE ( C1(Nsegment), C2(Nsegment), C0(Nsegment), Ts(Nsegment), Ts_i(Nsegment) ) + ENDIF + +! Riparian storage variables + IF ( Ripst_flag==1 ) THEN + Basin_bankst_seep = 0.D0 + Basin_bankst_seep_rate = 0.0D0 + Basin_bankst_head = 0.0D0 + Basin_bankst_vol = 0.0D0 + Basin_bankflow = 0.0D0 + Basin_bankst_area = 0.0D0 + Basin_ripflow = 0.0D0 + Basin_ripst_evap = 0.0D0 + Basin_ripst_seep = 0.0D0 + Basin_ripst_vol = 0.0D0 + Basin_ripst_area = 0.D0 + Ripst_evap_hru = 0.0 + Ripst_seep_hru = 0.0D0 + Ripst_frac = 0.0 + Bankst_seep_hru = 0.0 + Bankst_seep_rate = 0.0 + Bankst_head = 0.0 + Bankst_head_pts = 0.0 + Stage_ante = 0.0D0 + Stage_ts = 0.0D0 + Seg_bankflow = 0.0D0 + Seg_ripflow = 0.0D0 + Ripst_area = 0.0 + ENDIF + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN + IF ( getparam(MODNAME, 'segment_flow_init', Nsegment, 'real', Segment_flow_init)/=0 ) & + & CALL read_error(2,'segment_flow_init') + DO i = 1, Nsegment + Seg_outflow(i) = Segment_flow_init(i) + IF ( Ripst_flag==1 ) THEN + flow = Seg_outflow(i)*CFS2CMS_CONV + Stage_ts(i) = (Mann_n(i)*flow/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + ENDIF + ENDDO + DEALLOCATE ( Segment_flow_init ) + ENDIF + +! if cascades are active then ignore hru_segment + Noarea_flag = 0 + IF ( Hru_seg_cascades==1 ) THEN + IF ( getparam(MODNAME, 'hru_segment', Nhru, 'integer', Hru_segment)/=0 ) CALL read_error(2, 'hru_segment') + Segment_hruarea = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + iseg = Hru_segment(i) + IF ( iseg>0 ) Segment_hruarea(iseg) = Segment_hruarea(iseg) + Hru_area_dble(i) + ENDDO + Segment_area = 0.0D0 + DO j = 1, Nsegment + Segment_area = Segment_area + Segment_hruarea(j) + IF ( Segment_hruarea(j)0 ) THEN + WRITE ( buffer, '(I10)' ) j + CALL write_outfile('WARNING, No HRUs are associated with segment:'//buffer) + IF ( Tosegment(j)==0 ) PRINT *, 'WARNING, No HRUs and tosegment=0 for segment:', j + ENDIF + ENDIF + ENDDO +! IF ( Active_area/=Segment_area ) PRINT *, 'Not all area in model domain included with segments, basin area =', & +! & Active_area, ' segment area = ', Segment_area + ENDIF + + IF ( Ripst_flag==1 ) THEN + IF ( getparam(MODNAME, 'ripst_areafr_max', Nhru, 'real', Ripst_areafr_max)/=0 ) CALL read_error(2, 'ripst_areafr_max') + IF ( getparam(MODNAME, 'ripst_et_coef', Nhru, 'real', Ripst_et_coef)/=0 ) CALL read_error(2, 'ripst_et_coef') + IF ( getparam(MODNAME, 'tr_ratio', Nhru, 'real', Tr_ratio)/=0 ) CALL read_error(2, 'tr_ratio') + IF ( getparam(MODNAME, 'bankfinite_hru', Nhru, 'integer', Bankfinite_hru)/=0 ) CALL read_error(2, 'bankfinite_hru') + ! might be able to calculate if want bankfinite_hru = 1 or 0 based on ripst_areafr_max and transmiss_seg + IF ( getparam(MODNAME, 'transmiss_seg', Nsegment, 'real', Transmiss_seg)/=0 ) CALL read_error(2, 'transmiss_seg') + IF ( getparam(MODNAME, 'specyield_seg', Nsegment, 'real', Specyield_seg)/=0 ) CALL read_error(2, 'specyield_seg') + IF ( getparam(MODNAME, 'porosity_seg', Nsegment, 'real', Porosity_seg)/=0 ) CALL read_error(2, 'porosity_seg') + Seg_hru_num = 0 + DO i = 1, Active_hrus + IF ( Hru_segment(i)>0) THEN + IF (Bankfinite_hru(i)==1) Basin_bankst_area = Basin_bankst_area+Ripst_areafr_max(i)*Hru_area_dble(i) ! in inches + IF (Bankfinite_hru(i)==0) Basin_bankst_area = Basin_bankst_area+Hru_area_dble(i) ! in inches + Ripst_area_max(i) = Ripst_areafr_max(i)*Hru_area(i) +! depth of hyporheic estimated at stream depth/porosity, Harvey and Wagner (2000) ?? + Ripst_depth(i) = Seg_depth(Hru_segment(i)) / Porosity_seg(Hru_segment(i)) + IF (Ripst_areafr_max(i)==0.0) Ripst_depth(i) = 0.0 + Ripst_vol_max(i) = DBLE( Ripst_area_max(i)*Ripst_depth(i)*(1.0-0.5*Tr_ratio(i)) ) + Seg_hru_num(Hru_segment(i)) =Seg_hru_num(Hru_segment(i)) +1 + ENDIF + ENDDO + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN + IF ( getparam(MODNAME, 'ripst_frac_init', Nhru, 'real', Ripst_frac_init)/=0 ) CALL read_error(2, 'ripst_frac_init') + IF ( getparam(MODNAME, 'bankst_head_init', Nhru, 'real', Bankst_head_init)/=0 ) CALL read_error(2, 'bankst_head_init') + CALL init_the_swamp() + CALL init_bank_storage() + DEALLOCATE ( Bankst_head_init, Ripst_frac_init ) + ENDIF + ENDIF + + isegerr = 0 + Segment_up = 0 + ! Begin the loops for ordering segments + DO j = 1, Nsegment + iseg = Obsin_segment(j) + toseg = Tosegment(j) + IF ( toseg==j ) THEN + PRINT *, 'ERROR, tosegment value (', toseg, ') equals itself for segment:', j + isegerr = 1 + ELSEIF ( toseg>0 ) THEN + IF ( Tosegment(toseg)==j ) THEN + PRINT *, 'ERROR, circle found, segment:', j, ' sends flow to segment:', toseg, ' that sends it flow' + isegerr = 1 + ELSE + ! load segment_up with last stream segment that flows into a segment + Segment_up(toseg) = j + ENDIF + ENDIF + ENDDO + + IF ( Parameter_check_flag>0 ) THEN + DO i = 1, Nsegment + IF ( Segment_up(i)==0 .AND. Tosegment(i)==0 ) & + & PRINT *, 'WARNING, no other segment flows into segment:', i, ' and tosegment=0' + ENDDO + ENDIF + + IF ( isegerr==1 ) THEN + Inputerror_flag = 1 + RETURN + ENDIF + + ! Begin the loops for ordering segments + ALLOCATE ( x_off(Nsegment) ) + x_off = 0 + k_coef = 1 + Segment_order = 0 + lval = 0 + iseg = 0 + eseg = 0 + DO WHILE ( lval0 + Ts = 1.0 + ierr = 0 + DO i = 1, Nsegment + IF ( Strmflow_flag==7 ) THEN ! muskingum_mann +! velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))* +! & ( Seg_width(i)*Seg_depth(i)/( Seg_width(i)+2.*Seg_depth(i) ) )**(2./3.) + velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say w>>d + K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours + ENDIF + + IF ( Segment_type(i)==2 .AND. K_coef(i)<24.0 ) K_coef(i) = 24.0 !K_coef must be specified = 24.0 for lake segments' + IF ( K_coef(i)<0.01 ) K_coef(i) = 0.01 !make compliant with old version of K_coef + IF ( K_coef(i)>24.0 ) K_coef(i) = 24.0 + k = K_coef(i) + x = X_coef(i) + +! check the values of k and x to make sure that Muskingum routing is stable + + IF ( k<1.0 ) THEN + IF ( Parameter_check_flag>0 ) THEN + PRINT '(/,A,I6,A,F6.2,/,9X,A,/)', 'WARNING, segment ', i, ' has K_coef < 1.0,', k, & + & 'this may produce unstable results' +! ierr = 1 + ENDIF +! Ts(i) = 0.0 ! not sure why this was set to zero, causes divide by 0 if K_coef < 1, BUG FIX 10/18/2016 RSR + Ts_i(i) = -1 + + ELSEIF ( k<2.0 ) THEN + Ts(i) = 1.0 + Ts_i(i) = 1 + + ELSEIF ( k<3.0 ) THEN + Ts(i) = 2.0 + Ts_i(i) = 2 + + ELSEIF ( k<4.0 ) THEN + Ts(i) = 3.0 + Ts_i(i) = 3 + + ELSEIF ( k<6.0 ) THEN + Ts(i) = 4.0 + Ts_i(i) = 4 + + ELSEIF ( k<8.0 ) THEN + Ts(i) = 6.0 + Ts_i(i) = 6 + + ELSEIF ( k<12.0 ) THEN + Ts(i) = 8.0 + Ts_i(i) = 8 + + ELSEIF ( k<24.0 ) THEN + Ts(i) = 12.0 + Ts_i(i) = 12 + + ELSE + Ts(i) = 24.0 + Ts_i(i) = 24 + + ENDIF + +! x must be <= t/(2K) the C coefficents will be negative. Check for this for all segments +! with Ts >= minimum Ts (1 hour). + IF ( Ts(i)>0.1 ) THEN + x_max = Ts(i) / (2.0 * k) + IF ( x>x_max ) THEN + PRINT *, 'ERROR, x_coef value is too large for stable routing for segment:', i, ' x_coef:', x + PRINT *, ' a maximum value of:', x_max, ' is suggested' + Inputerror_flag = 1 + CYCLE + ENDIF + ENDIF + + d = k - (k * x) + (0.5 * Ts(i)) + IF ( ABS(d)0 ) PRINT *, 'WARNING, segment ', i, ' computed value d <', NEARZERO, ', set to 0.0001' + d = 0.0001 + ENDIF + C0(i) = (-(k * x) + (0.5 * Ts(i))) / d + C1(i) = ((k * x) + (0.5 * Ts(i))) / d + C2(i) = (k - (k * x) - (0.5 * Ts(i))) / d + + ! the following code was in the original musroute, but, not in Linsley and others + ! rsr, 3/1/2016 - having < 0 coefficient can cause negative flows as found by Jacob in GCPO headwater +! if c2 is <= 0.0 then short travel time though reach (less daily +! flows), thus outflow is mainly = inflow w/ small influence of previous +! inflow. Therefore, keep c0 as is, and lower c1 by c2, set c2=0 + +! if c0 is <= 0.0 then long travel time through reach (greater than daily +! flows), thus mainly dependent on yesterdays flows. Therefore, keep +! c2 as is, reduce c1 by c0 and set c0=0 +! SHORT travel time + IF ( C2(i)<0.0 ) THEN + IF ( Parameter_check_flag>0 ) THEN + PRINT '(/,A)', 'WARNING, c2 < 0, set to 0, c1 set to c1 + c2' + PRINT *, ' old c2:', C2(i), '; old c1:', C1(i), '; new c1:', C1(i) + C2(i) + PRINT *, ' K_coef:', K_coef(i), '; x_coef:', x_coef(i) + ENDIF + C1(i) = C1(i) + C2(i) + C2(i) = 0.0 + ENDIF + +! LONG travel time + IF ( C0(i)<0.0 ) THEN + IF ( Parameter_check_flag>0 ) THEN + PRINT '(/,A)', 'WARNING, c0 < 0, set to 0, c0 set to c1 + c0' + PRINT *, ' old c0:', C0(i), 'old c1:', C1(i), 'new c1:', C1(i) + C0(i) + PRINT *, ' K_coef:', K_coef(i), '; x_coef:', x_coef(i) + ENDIF + C1(i) = C1(i) + C0(i) + C0(i) = 0.0 + ENDIF + + ENDDO + IF ( ierr==1 ) PRINT '(/,A,/)', '***Recommend that the Muskingum parameters be adjusted in the Parameter File' + DEALLOCATE ( k_coef, X_coef) + + END FUNCTION routinginit + +!*********************************************************************** +! route_run - Computes segment flow states and fluxes +!*********************************************************************** + INTEGER FUNCTION route_run() + USE PRMS_ROUTING + USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag + USE PRMS_BASIN, ONLY: Hru_area, Hru_route_order, Active_hrus, NEARZERO, FT2_PER_ACRE + USE PRMS_CLIMATEVARS, ONLY: Swrad, Potet + USE PRMS_SET_TIME, ONLY: Timestep_seconds, Cfs_conv + USE PRMS_FLOWVARS, ONLY: Ssres_flow, Sroff, Seg_lateral_inflow !, Seg_outflow + USE PRMS_WATER_USE, ONLY: Segment_transfer, Segment_gain + USE PRMS_GWFLOW, ONLY: Gwres_flow + USE PRMS_SRUNOFF, ONLY: Strm_seg_in + USE PRMS_GLACR, ONLY: Glacr_flow + IMPLICIT NONE +! Functions + INTRINSIC DBLE +! Local Variables + INTEGER :: i, j, jj, this_seg + DOUBLE PRECISION :: tocfs + LOGICAL :: found +!*********************************************************************** + route_run = 0 + + Cfs2acft = Timestep_seconds/FT2_PER_ACRE + +! seg variables are not computed if cascades are active as hru_segment is ignored + IF ( Hru_seg_cascades==1 ) THEN + ! add hru_ppt, hru_actet + Seginc_gwflow = 0.0D0 + Seginc_ssflow = 0.0D0 + Seginc_sroff = 0.0D0 + Seginc_swrad = 0.0D0 + Seginc_potet = 0.0D0 + Seg_gwflow = 0.0D0 + Seg_sroff = 0.0D0 + Seg_ssflow = 0.0D0 + ENDIF + IF ( Cascade_flag==0 ) THEN + Seg_lateral_inflow = 0.0D0 + ELSE ! use strm_seg_in for cascade_flag = 1 or 2 + Seg_lateral_inflow = Strm_seg_in + ENDIF + + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + tocfs = DBLE( Hru_area(j) )*Cfs_conv + Hru_outflow(j) = DBLE( (Sroff(j) + Ssres_flow(j) + Gwres_flow(j)) )*tocfs + ! Note: glacr_flow (from glacier or snowfield) is added as a gain, outside stream network addition + ! glacr_flow in inch^3, 1728=12^3 + IF ( Glacier_flag==1 ) Hru_outflow(j) = Hru_outflow(j) + Glacr_flow(j)/1728.0/Timestep_seconds + IF ( Hru_seg_cascades==1 ) THEN + i = Hru_segment(j) + IF ( i>0 ) THEN + Seg_gwflow(i) = Seg_gwflow(i) + Gwres_flow(j) + Seg_sroff(i) = Seg_sroff(i) + Sroff(j) + Seg_ssflow(i) = Seg_ssflow(i) + Ssres_flow(j) + ! if cascade_flag = 2, seg_lateral_inflow set with strm_seg_in + IF ( Cascade_flag==0 ) Seg_lateral_inflow(i) = Seg_lateral_inflow(i) + Hru_outflow(j) + Seginc_sroff(i) = Seginc_sroff(i) + DBLE( Sroff(j) )*tocfs + Seginc_ssflow(i) = Seginc_ssflow(i) + DBLE( Ssres_flow(j) )*tocfs + Seginc_gwflow(i) = Seginc_gwflow(i) + DBLE( Gwres_flow(j) )*tocfs + Seginc_swrad(i) = Seginc_swrad(i) + DBLE( Swrad(j)*Hru_area(j) ) + Seginc_potet(i) = Seginc_potet(i) + DBLE( Potet(j)*Hru_area(j) ) + ENDIF + ENDIF + ENDDO + + IF ( Use_transfer_segment==1 ) THEN + DO i = 1, Nsegment + Seg_lateral_inflow(i) = Seg_lateral_inflow(i) + DBLE( Segment_gain(i) - Segment_transfer(i) ) + ENDDO + ENDIF + + IF ( Cascade_flag==1 ) RETURN + +! Divide solar radiation and PET by sum of HRU area to get avarage + IF ( Noarea_flag==0 ) THEN + DO i = 1, Nsegment + Seginc_swrad(i) = Seginc_swrad(i)/Segment_hruarea(i) + Seginc_potet(i) = Seginc_potet(i)/Segment_hruarea(i) + ENDDO + +! If there are no HRUs associated with a segment, then figure out some +! other way to get the solar radiation, the following is not great + ELSE ! IF ( Noarea_flag==1 ) THEN + DO i = 1, Nsegment +! This reworked by markstrom + IF ( Segment_hruarea(i)>NEARZERO ) THEN + Seginc_swrad(i) = Seginc_swrad(i)/Segment_hruarea(i) + Seginc_potet(i) = Seginc_potet(i)/Segment_hruarea(i) + ELSE + +! Segment does not have any HRUs, check upstream segments. + this_seg = i + found = .false. + do + if (Segment_hruarea(this_seg) <= NEARZERO) then + + ! Hit the headwater segment without finding any HRUs (i.e. sources of streamflow) + if (segment_up(this_seg) .eq. 0) then + found = .false. + exit + endif + + ! There is an upstream segment, check that segment for HRUs + this_seg = segment_up(this_seg) + else + ! This segment has HRUs so there will be swrad and potet + Seginc_swrad(i) = Seginc_swrad(this_seg)/Segment_hruarea(this_seg) + Seginc_potet(i) = Seginc_potet(this_seg)/Segment_hruarea(this_seg) + found = .true. + exit + endif + enddo + + if (.not. found) then +! Segment does not have any upstream segments with HRUs, check downstream segments. + + this_seg = i + found = .false. + do + if (Segment_hruarea(this_seg) <= NEARZERO) then + + ! Hit the terminal segment without finding any HRUs (i.e. sources of streamflow) + if (tosegment(this_seg) .eq. 0) then + found = .false. + exit + endif + + ! There is a downstream segment, check that segment for HRUs + this_seg = tosegment(this_seg) + else + ! This segment has HRUs so there will be swrad and potet + Seginc_swrad(i) = Seginc_swrad(this_seg)/Segment_hruarea(this_seg) + Seginc_potet(i) = Seginc_potet(this_seg)/Segment_hruarea(this_seg) + found = .true. + exit + endif + enddo + + if (.not. found) then +! write(*,*) "route_run: no upstream or downstream HRU found for segment ", i +! write(*,*) " no values for seginc_swrad and seginc_potet" + Seginc_swrad(i) = -99.9 + Seginc_potet(i) = -99.9 + endif + endif + ENDIF + ENDDO + ENDIF + + END FUNCTION route_run + +!*********************************************************************** +! Initialize overbank riparian (swamp) hydrology +!*********************************************************************** + SUBROUTINE init_the_swamp() + USE PRMS_BASIN, ONLY: Basin_area_inv, Hru_area_dble, Active_hrus + USE PRMS_ROUTING, ONLY: Basin_ripst_vol, Basin_ripst_area, Ripst_vol, Ripst_frac, & + & Hru_segment, Ripst_frac_init, Basin_ripst_vol, Ripst_area, Ripst_area_max, & + & Ripst_vol_max, Ripst_stor_hru + IMPLICIT NONE +! Functions + INTRINSIC SNGL, DBLE +! Local Variables + INTEGER :: i +!*********************************************************************** + DO i = 1, Active_hrus + IF ( Hru_segment(i)>0) THEN + Ripst_frac(i) = Ripst_frac_init(i) + Ripst_vol(i) = DBLE(Ripst_frac(i))*Ripst_vol_max(i) + Ripst_stor_hru(i) = Ripst_vol(i)/Hru_area_dble(i) +! Filled riparian storage surface area for each HRU: +! Fills outward from the river with one edge on river and with same depth and same side shape +! this works out to keeping fraction same for area and volume filled + Ripst_area(i) = Ripst_area_max(i)*Ripst_frac(i) !area +! calculate the basin riparian storage volumes + Basin_ripst_vol = Basin_ripst_vol + Ripst_vol(i) + Basin_ripst_area = Basin_ripst_area + Ripst_area(i) + ENDIF + ENDDO + Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv + + END SUBROUTINE init_the_swamp + +!*********************************************************************** +! Compute overbank area (swamp) fill and drain +! Treat like a closed surface depression in that it can't spill. +! Right now, not getting water from anywhere but stream, and losing only +! to ET and seep. Possibly should take water in from precipitation, +! runoff, and interflow. +! This is called after bank storage has been removed, so not inside +! hourly routing. +!*********************************************************************** + SUBROUTINE drain_the_swamp(Ihru) + USE PRMS_ROUTING, ONLY: Seg_width, Seg_depth, Seg_width, Hru_segment, Mann_n, & + & Transmiss_seg, Tr_ratio, Ripst_vol_max, Ripst_et_coef, Ripst_evap_hru, & + & Basin_ripst_vol, Basin_ripst_evap, Basin_ripst_seep, Ripst_stor_hru, & + & Ripst_frac, Ripst_vol, Ripst_area_max, Ripst_area, Ripst_seep_hru, Seg_slope, & + & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area, Seg_length + USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Hru_area, Hru_area_dble, FEET2METERS, & + & FT2_PER_ACRE, CFS2CMS_CONV + USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_CLIMATEVARS, ONLY: Potet + USE PRMS_SET_TIME, ONLY: Timestep_seconds + USE PRMS_SRUNOFF, ONLY: Hru_impervevap, Dprst_evap_hru + USE PRMS_INTCP, ONLY: Hru_intcpevap + USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap + IMPLICIT NONE +! Functions + INTRINSIC EXP, LOG, MIN, DBLE, SNGL +! Arguments + INTEGER, INTENT(IN) :: Ihru +! Local Variables + REAL :: ripst_avail_et, unsatisfied_et, ripst_evap, ripst_wid + REAL :: inflow, inflow_in, max_depth + DOUBLE PRECISION :: seep, ripst_grnd, poss, seep_in +!*********************************************************************** +!It won't get deeper than this depth, should be Seg_depth but not accurate or Seg_width and other terms not accurate + !max_depth = Seg_depth(Hru_segment(Ihru))*10.0 + max_depth = Seg_depth(Hru_segment(Ihru))*1e30 +! amount possible in cfs given a river depth + poss = Seg_width(Hru_segment(Ihru))*SQRT(Seg_slope(Hru_segment(Ihru)))* & + & max_depth**(3./5.)/ ( CFS2CMS_CONV*Mann_n(Hru_segment(Ihru)) ) +!inflow is water over bank, remove from Seg_outflow(Hru_segment(Ihru)) and give half to +! each side of bank, in acre inches + inflow = 0.0 +! in cfs, amount over amount possible + IF ( poss < Seg_outflow(Hru_segment(Ihru)) ) inflow = SNGL(Seg_outflow(Hru_segment(Ihru)) - poss) +! give it equally to each HRU surrounding it + inflow = inflow/REAL(Seg_hru_num(Hru_segment(Ihru))) +!negative flow is out of stream into riparian + Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru)) - inflow + inflow_in = SNGL(inflow*Timestep_seconds/(FT2_PER_ACRE*12.0)) + IF ( Ripst_area_max(Ihru)>0.0 ) THEN + Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow_in + Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) + ENDIF +! Filled riparian storage surface area for each HRU: +! Fills outward from the river with one edge on river and with same depth and same side shape +! this works out to keeping fraction same for area and volume filled + Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) + + ! evaporate water from riparian area based on snowcov_area + ! ripst_evap_open & ripst_evap_clos = inches-acres on the HRU + unsatisfied_et = Potet(Ihru) - Snow_evap(Ihru) - Hru_intcpevap(Ihru) & + & - Hru_impervevap(Ihru) - Dprst_evap_hru(Ihru) + ripst_avail_et = Potet(Ihru)*(1.0-Snowcov_area(Ihru))*Ripst_et_coef(Ihru) + Ripst_evap_hru(Ihru) = 0.0 + IF ( ripst_avail_et>0.0 ) THEN + ripst_evap = 0.0 + IF ( Ripst_area(Ihru)>0.0 ) THEN + ripst_evap = MIN(Ripst_area(Ihru)*ripst_avail_et, SNGL(Ripst_vol(Ihru))) + IF ( ripst_evap/Hru_area(Ihru)>unsatisfied_et ) THEN + !IF ( Print_debug>-1 ) THEN + ! PRINT *, 'Warning, ripst evaporation > available ET, HRU:, ', Ihru, & +! & unsatisfied_et, ripst_evap*Ripst_frac(Ihru) + ! PRINT *, 'Set to available ET, perhaps ripst_et_coef specified too large' + ! PRINT *, 'Set print_debug to -1 to turn off message' + !ENDIF + ripst_evap = unsatisfied_et*Hru_area(Ihru) + ENDIF + IF ( ripst_evap>SNGL(Ripst_vol(Ihru)) ) ripst_evap = SNGL( Ripst_vol(Ihru) ) + Ripst_vol(Ihru) = Ripst_vol(Ihru) - DBLE( ripst_evap ) + ENDIF + Ripst_evap_hru(Ihru) = ripst_evap/Hru_area(Ihru) + ENDIF + + ! compute seepage + Ripst_seep_hru(Ihru) = 0.0D0 + seep = 0.0 + IF ( Ripst_area_max(Ihru)>0.0 ) THEN + IF ( Ripst_vol(Ihru)>NEARZERO ) THEN + ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters +!assumed it was a one sided stream, here a headwater with both sides in one HRU + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 +! Stream ground area is stream side area (flat wall) and other side area (fraction of triangle (1) to rectangle (0)) + ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle + & (SQRT( ripst_wid**2.0 + Ripst_depth(Ihru)**2.0 )- Ripst_depth(Ihru))*Tr_ratio(Ihru) + & !triangle + & 2.0*Ripst_depth(Ihru) ) ) !stream and other side +!assumed it was a one sided stream, here a headwater with both sides in one HRU + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 +!seep in a day through ground surface area of riparian, m^3 into ft^3 to acre_in +!Transmissivity would be way too big, maybe ssr2gw_rate + seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) + !seep = 0.0 !if want to turn off seep + seep_in = seep*FT2_PER_ACRE*12.0 + Ripst_vol(Ihru) = Ripst_vol(Ihru) - seep_in + IF ( Ripst_vol(Ihru)<0.0D0 ) THEN + !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) + seep_in = seep_in + Ripst_vol(Ihru) + seep = seep_in/(FT2_PER_ACRE*12.0) + Ripst_vol(Ihru) = 0.0D0 + ENDIF + Ripst_seep_hru(Ihru) = seep_in/Hru_area_dble(Ihru) !inch per HRU + ENDIF + IF ( Ripst_vol(Ihru)<0.0D0 ) THEN +! IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) + Ripst_vol(Ihru) = 0.0D0 + ENDIF + ENDIF + ! seep goes back in stream as positive flow, cfs + Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru))+ seep/Timestep_seconds + !Seg_ripflow(Hru_segment(Ihru)) = 0.0 !if want to turn off overbank flow + +! print*, Ihru, Hru_segment(Ihru), poss, Seg_outflow(Hru_segment(Ihru)), Seg_ripflow(Hru_segment(Ihru)), Seg_depth(Hru_segment(Ihru)),& +! & Stage_ts(Hru_segment(Ihru)) + + Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) + Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) + Ripst_stor_hru(Ihru) = Ripst_vol(Ihru)/Hru_area_dble(Ihru) + Basin_ripst_vol = Basin_ripst_vol + Ripst_vol(Ihru) + Basin_ripst_evap = Basin_ripst_evap + DBLE(Ripst_evap_hru(Ihru))*Hru_area_dble(Ihru) + Basin_ripst_seep = Basin_ripst_seep + Ripst_seep_hru(Ihru)*Hru_area_dble(Ihru) + Basin_ripst_area = Basin_ripst_area + Ripst_area(Ihru) + + END SUBROUTINE drain_the_swamp + +!*********************************************************************** +! Initialize bank storage hydrology +!*********************************************************************** + SUBROUTINE init_bank_storage() + USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_area_dble, Active_hrus, & + & FT2_PER_ACRE, FEET2METERS, CFS2CMS_CONV + USE PRMS_ROUTING, ONLY: Basin_bankst_head, Bankst_head_init, Basin_bankst_area, & + & Basin_bankst_vol, Bankst_head, Hru_segment, Seg_width, Seg_length, & + & Bankst_stor_hru, Bankst_head_pts, Ripst_areafr_max, Bankfinite_hru + USE PRMS_FLOWVARS, ONLY: Seg_outflow + IMPLICIT NONE +! Functions + INTRINSIC SNGL +! Local Variables + INTEGER :: i +!*********************************************************************** + DO i = 1, Active_hrus + IF ( Hru_segment(i)>0) THEN + Bankst_head(i) = Bankst_head_init(i) + Bankst_head_pts(i) =SNGL(Seg_outflow(Hru_segment(i))*CFS2CMS_CONV)*60.*60.*24. & + & /Seg_width(Hru_segment(i))/Seg_length(Hru_segment(i)) + IF (Bankfinite_hru(i)==1) THEN + Bankst_stor_hru(i) = Ripst_areafr_max(i)*12.0*Bankst_head(i)/FEET2METERS !in inches + Basin_bankst_head = Basin_bankst_head + Ripst_areafr_max(i)*Bankst_head(i)*Hru_area_dble(i) ! in meters + ELSE + Bankst_stor_hru(i) = 12.0*Bankst_head(i)/FEET2METERS !in inches + Basin_bankst_head = Basin_bankst_head + Bankst_head(i)*Hru_area_dble(i) ! in meters + ENDIF + Basin_bankst_vol = Basin_bankst_vol+Bankst_stor_hru(i)*Hru_area_dble(i) ! in inches + ENDIF + ENDDO + Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv + Basin_bankst_head = Basin_bankst_head/Basin_bankst_area + + END SUBROUTINE init_bank_storage + +!*********************************************************************** +! Compute bank storage hydrology +! For the linear boundary-value problems discussed by Moench and Barlow (2000), the total +! response of a stream–aquifer system to a time series of individual stresses (stream-stage +! fluctuations or recharge) can be determined by superposition (or convolution) of the +! system’s response to the individual stresses. +! Assume no layer of semi-pervious bank sediments, so storage right at the bank. Use a +! finite confined aquifer with no overlying aquitard, or a finite water table aquifer +! (swamp) with a specific yield of aquifer = 0, or ~ 0. +! This is saying very little water is released by the aquifer from the water table lowering +! and the unsaturated zone is thin. This is true for shallow water table aquifers; see +! Barlow et al (2000). +!*********************************************************************** + SUBROUTINE comp_bank_storage(Ihru) + USE PRMS_ROUTING, ONLY: Bankst_seep_rate, Bankst_head, Bankst_head_pts, Hru_segment, & + & Bankst_seep_hru, Bankst_stor_hru, Stage_ts, Stage_ante, Seg_bankflow, Ripst_areafr_max, & + & Transmiss_seg, Seg_width, Seg_length, Specyield_seg, Bankfinite_hru, Seg_hru_num, & + & Basin_bankst_seep, Basin_bankst_head, Basin_bankst_vol + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, FT2_PER_ACRE, FEET2METERS, Hru_area, Hru_area_dble + USE PRMS_FLOWVARS, ONLY: Gwres_stor + IMPLICIT NONE +! Functions + INTRINSIC SUM, SNGL, SQRT + EXTERNAL LTST1 +! Arguments + INTEGER, INTENT(IN) :: Ihru + ! Local Variables + INTEGER :: h, t0 + INTEGER, PARAMETER :: nbankd = 2 + REAL, PARAMETER :: PI = 3.14159 + REAL :: area, str_wid, tot_wid, bank_wid, trans, a, xd, t, td + REAL :: delt, delta_input(nbankd), delta_diff(nbankd), head(nbankd), seep(nbankd) + REAL :: bank(nbankd), bankv(nbankd), ripfrac + DOUBLE PRECISION :: input_net(nbankd), diff_net(nbankd), recharge(nbankd), stage(nbankd) + DOUBLE PRECISION :: head_step, head_step_grad, seep_sum, head_sum +!*********************************************************************** + area = Ripst_areafr_max(Ihru)*Hru_area(Ihru) !acres + trans = Transmiss_seg(Hru_segment(Ihru)) +!aquifer diffusivity, ratio of the transmissivity/storativity of the aquifer + a = trans/Specyield_seg(Hru_segment(Ihru)) + str_wid = Seg_width(Hru_segment(Ihru))/2.0 + bank_wid = SNGL(area*FT2_PER_ACRE*(FEET2METERS**2.)/Seg_length(Hru_segment(Ihru))/str_wid) !dimensionless + tot_wid = bank_wid+1.0 !dimensionless + delt = 1.0 !fraction of day +! might want to interpolate a curve, so leaving nbankd as a dimension -- sh + stage(1) = Stage_ante(Hru_segment(Ihru)) + stage(2) = Stage_ts(Hru_segment(Ihru)) + ! changes in a day + DO h = 1, nbankd + seep(h) = 0.0 + bank(h) = 0.0 + bankv(h) = 0.0 + recharge(h) = (h-1)*delt*Gwres_stor(Ihru)*FEET2METERS/12.D0 ! in meters, currently ignoring ET +! Can only use recharge change if say it's a leaky aquifer overlain by a water table aquitard. +! might want to do that. Also might want to go other way and make simpler, make it semi-infinite so then +! no numerical Laplace inverse, just can solve + input_net(h) = stage(h) !+ recharge(h) + diff_net(h) = stage(h) !- recharge(h) !FIX What is this vs input_net + ENDDO +!Make head ideal flood wave for volume change and recharge ideal observed response at a well for vol change?? + DO h = 2,nbankd + delta_input(h-1) = SNGL( (input_net(h)-input_net(h-1))/delt ) + delta_diff(h-1) = SNGL((diff_net(h)-diff_net(h-1))/delt ) + ENDDO + Bankst_seep_hru(Ihru) = 0.0 + xd = 1.0+ bank_wid/2.0 ! at x = 1.0 is stage which already know, calc at middle of bank storage area + head=Bankst_head_pts(Ihru) !set at last height for initial +! Calculate heads, seepage, and bank storage using convolution + DO h = 1, (nbankd-1) + head_sum = 0.0 + seep_sum = 0.0 + DO t0 = 1,h + t = t0*delt + td = t*a/(str_wid**2.0) !dimensionless + IF (Bankfinite_hru(Ihru)==1) then !finite solution if transmissivity high, COMPUTATIONALLY EXPENSIVE, might eliminate + ripfrac = Ripst_areafr_max(Ihru) + CALL LTST1(td, xd, tot_wid, bank_wid, head_step, head_step_grad) + ELSE IF (Bankfinite_hru(Ihru)==0) then !semi-infinite solution + ripfrac = 1.0 + head_step = ERFC( (xd - 1.0)/SQRT((4.0*td)) ) + head_step_grad = -( 1.0/SQRT((PI*td)) ) + ENDIF + !head is a function of xd + head_sum = delta_input(h-t0+1)*head_step + head_sum + !seep is per unit segment length rate goes out, not a function of xd + seep_sum = delta_diff(h-t0+1)*head_step_grad + seep_sum + ENDDO + head(h+1)=head(h+1) + SNGL(head_sum*delt) + seep(h+1)=SNGL((trans/str_wid)*seep_sum*delt) + bank(h+1)=bank(h) - seep(h+1)*delt + bankv(h+1)=bank(h+1)*Seg_length(Hru_segment(Ihru)) + !IF (Ihru==1) print*,h+1,stage(h+1),bank(h+1),seep(h+1),bankv(h+1) !for plotting daily pattern + ENDDO + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) THEN +!assumed it was a one sided stream, here a headwater with both sides in one HRU + seep = seep*2.0 + bank = bank*2.0 + bankv = bankv*2.0 + ENDIF + Bankst_head_pts(Ihru) = head(nbankd) ! meters + !linear interpolation for total average head over bank storage area, meters + Bankst_head(Ihru) = 0.5*(SNGL(stage(nbankd))+Bankst_head_pts(Ihru)) + ! Bankst_head_pts at finite edge of bank storage area is 0 (xd = 1, so head_step = 0) + ! is only saved at the end of the timestep + Bankst_head(Ihru) = Bankst_head(Ihru) + 0.5*Bankst_head_pts(Ihru) + ! m2 per 24 hr per stream segment for both sides of stream + ! seep hru is inch over hru seeping out per day + Bankst_seep_hru(Ihru) = -12.0*bankv(nbankd)/SNGL(CFS2CMS_CONV*Hru_area(Ihru)*FT2_PER_ACRE) + Bankst_seep_rate(Hru_segment(Ihru)) = Bankst_seep_rate(Hru_segment(Ihru)) - bank(nbankd) + Bankst_stor_hru(Ihru) = Bankst_stor_hru(Ihru)- Bankst_seep_hru(Ihru) !inch over hru + Seg_bankflow(Hru_segment(Ihru)) = Seg_bankflow(Hru_segment(Ihru))-bankv(nbankd)/(24.*60.*60.)/CFS2CMS_CONV + !FIX area change?? no I don't think so + Basin_bankst_seep = Basin_bankst_seep + Bankst_seep_hru(Ihru)*Hru_area_dble(Ihru) + + Basin_bankst_head = Basin_bankst_head + ripfrac*Bankst_head(Ihru)* Hru_area_dble(Ihru) + Basin_bankst_vol = Basin_bankst_vol+Bankst_stor_hru(Ihru)*Hru_area_dble(Ihru) + + END SUBROUTINE comp_bank_storage + +!*********************************************************************** +! Laplace transform leakage equation +!*********************************************************************** + SUBROUTINE LTST1(td, xd, tot_wid, bank_wid, head_step, head_step_grad) + IMPLICIT NONE +! Functions + INTRINSIC EXP, LOG, DBLE + EXTERNAL LINVST +! Arguments + REAL, INTENT(IN) :: td, xd, tot_wid, bank_wid + DOUBLE PRECISION, INTENT(OUT) :: head_step, head_step_grad +! Local Variables + INTEGER, PARAMETER :: NS=12 ! Number of Stehfest terms, 8 usually sufficient but Barlow uses 12 + INTEGER :: expmax, i, NH + DOUBLE PRECISION :: c1, c2, c3, c4, ff, fnum, fden, xLN2, p + DOUBLE PRECISION :: caq, ca, re0, re0q, pdl, pdlq, xp, xpq, V(NS) +!*********************************************************************** + NH=NS/2 + CALL LINVST(NS,NH,V) + xLN2=LOG(2.0) +!expmax is the maximum allowable absolute value of the exponential arguments + expmax=708 + xp=0.0 + xpq=0.0 + DO i=1,NS + p=xLN2*i/td +!calculate coeficients + c1 = SQRT(p) + c2 = p + fnum = EXP(DBLE( -2.0*SQRT(p)*(tot_wid-xd) )) +1.0 + fden = EXP(DBLE( -2.0*SQRT(p)*bank_wid )) +1.0 + ff = fnum/fden + c3 = fden + c4 = c2*c3 + caq = -(c1/c4)*(EXP(DBLE( -2.0*SQRT(p)*bank_wid )) -1.0) + ca = c1*(xd-1.0) + IF (ca > expmax) ca = expmax +!calculate head and seepage terms + re0 = ff*EXP(-ca) + re0q = caq + pdl = re0/c2 + pdlq = re0q + xp = xp + V(i)*pdl + xpq = xpq + V(i)*pdlq + ENDDO + head_step = xp*xLN2/td + head_step_grad = xpq*xLN2/td + + END SUBROUTINE LTST1 + +!*********************************************************************** +! Stehfest coefficients for Laplace transform +!*********************************************************************** + SUBROUTINE LINVST(NS, NH, V) + IMPLICIT NONE +! Functions + INTRINSIC FLOOR +! Arguments + INTEGER, INTENT(IN) :: NS,NH + DOUBLE PRECISION, INTENT(OUT) :: V(NS) +! Local Variables + INTEGER :: i, j, FI, SN, K1,K2 + DOUBLE PRECISION :: G(NS), HS(NH) +!*********************************************************************** + G(1)=1.0 + DO i=2,NS + G(i)=G(i-1)*i + ENDDO + HS(1)=2.0/G(NH-1) + DO i = 2,NH + FI=i + IF (i== NH) THEN + HS(i)=(FI**NH)*G(2*i)/(G(i)*G(i-1)) + ELSE + HS(i)=(FI**NH)*G(2*i)/(G(NH-i)*G(i)*G(i-1)) + ENDIF + ENDDO + SN=2*(NH-NH/2*2)-1 + DO i=1,NS + V(i)=0.0 + K1=FLOOR((i+1)/2.0) + K2=i + IF (K2 > NH) K2 = NH + DO j=K1,K2 + IF (2*j-i == 0) THEN + V(i)=V(i)+HS(j)/(G(i-j)) + ELSEIF (i == j) THEN + V(i)=V(i)+HS(j)/G(2*j-i) + ELSE + V(i)=V(i)+HS(j)/(G(i-j)*G(2*j-i)) + ENDIF + ENDDO + V(i)=SN*V(i) + SN=-SN + ENDDO + + END SUBROUTINE LINVST + +!*********************************************************************** +! routing_restart - write or read restart file +!*********************************************************************** + SUBROUTINE routing_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Ripst_flag + USE PRMS_ROUTING + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variables + CHARACTER(LEN=7) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Basin_segment_storage + WRITE ( Restart_outunit ) Segment_delta_flow + IF ( Ripst_flag==1 ) THEN + WRITE ( Restart_outunit ) Basin_bankst_head + WRITE ( Restart_outunit ) Basin_bankst_vol + WRITE ( Restart_outunit ) Basin_bankst_seep_rate + WRITE ( Restart_outunit ) Basin_bankst_seep, Basin_bankflow + WRITE ( Restart_outunit ) Bankst_head, Seg_bankflow + WRITE ( Restart_outunit ) Bankst_head_pts + WRITE ( Restart_outunit ) Bankst_stor_hru + WRITE ( Restart_outunit ) Stage_ante, Stage_ts + WRITE ( Restart_outunit ) Basin_ripflow + WRITE ( Restart_outunit ) Basin_ripst_evap, Basin_ripst_seep + WRITE ( Restart_outunit ) Basin_ripst_vol, Basin_ripst_area + WRITE ( Restart_outunit ) Ripst_stor_hru, Ripst_seep_hru, Ripst_vol + WRITE ( Restart_outunit ) Seg_ripflow, Ripst_evap_hru, Ripst_frac + ENDIF + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Basin_segment_storage + READ ( Restart_inunit ) Segment_delta_flow + IF ( Ripst_flag==1 ) THEN + READ ( Restart_inunit ) Basin_segment_storage + READ ( Restart_inunit ) Segment_delta_flow + READ ( Restart_inunit ) Basin_bankst_head + READ ( Restart_inunit ) Basin_bankst_vol + READ ( Restart_inunit ) Basin_bankst_seep_rate + READ ( Restart_inunit ) Basin_bankst_seep, Basin_bankflow + READ ( Restart_inunit ) Bankst_head, Seg_bankflow + READ ( Restart_inunit ) Bankst_head_pts + READ ( Restart_inunit ) Bankst_stor_hru + READ ( Restart_inunit ) Stage_ante, Stage_ts + READ ( Restart_inunit ) Basin_ripflow + READ ( Restart_inunit ) Basin_ripst_evap, Basin_ripst_seep + READ ( Restart_inunit ) Basin_ripst_vol, Basin_ripst_area + READ ( Restart_inunit ) Ripst_stor_hru, Ripst_seep_hru, Ripst_vol + READ ( Restart_inunit ) Seg_ripflow, Ripst_evap_hru, Ripst_frac + ENDIF + ENDIF + END SUBROUTINE routing_restart diff --git a/prms/srunoff.f90 b/prms/srunoff.f90 index 0fdc3cc3..d3167a1b 100644 --- a/prms/srunoff.f90 +++ b/prms/srunoff.f90 @@ -4,6 +4,10 @@ ! Combinded smidx and carea modules 3/12/2013 ! ! version: 2.2 added cascading flow for infiltration and runoff +! +! includes glacrb_melt for HRUs with glaciers and frozen ground under glaciers 12/2014 +! +! rsr, 10/21/2008 added frozen ground code ! rsr, 10/30/2008 added depression storage code ! rsr, 04/11/2011 changed so dprst_area to be a parameter (does not change) ! rsr, 07/1/2013 combined smidx and carea into one module @@ -18,8 +22,8 @@ MODULE PRMS_SRUNOFF REAL, SAVE, ALLOCATABLE :: Carea_dif(:), Imperv_stor_ante(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Dprst_stor_ante(:) REAL, SAVE :: Srp, Sri, Perv_frac, Imperv_frac, Hruarea_imperv, Hruarea - DOUBLE PRECISION, SAVE :: Hruarea_dble, Basin_apply_sroff - INTEGER, SAVE :: Use_sroff_transfer + DOUBLE PRECISION, SAVE :: Hruarea_dble, Basin_apply_sroff, Basin_cfgi_sroff + INTEGER, SAVE :: Use_sroff_transfer, Isglacier ! Declared Variables DOUBLE PRECISION, SAVE :: Basin_sroff_down, Basin_sroff_upslope DOUBLE PRECISION, SAVE :: Basin_sroffi, Basin_sroffp @@ -32,7 +36,10 @@ MODULE PRMS_SRUNOFF REAL, SAVE, ALLOCATABLE :: Hortonian_flow(:) REAL, SAVE, ALLOCATABLE :: Hru_impervevap(:), Hru_impervstor(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Strm_seg_in(:), Hortonian_lakes(:), Hru_hortn_cascflow(:) + REAL, SAVE, ALLOCATABLE :: Cfgi(:), Cfgi_prev(:) + INTEGER, SAVE, ALLOCATABLE :: Frozen(:) ! Declared Parameters + REAL, SAVE :: Cfgi_thrshld, Cfgi_decay REAL, SAVE, ALLOCATABLE :: Smidx_coef(:), Smidx_exp(:) REAL, SAVE, ALLOCATABLE :: Carea_min(:), Carea_max(:) ! Declared Parameters for Depression Storage @@ -80,6 +87,7 @@ END FUNCTION srunoff ! Declared Parameters ! smidx_coef, smidx_exp, carea_max, imperv_stor_max, snowinfil_max ! hru_area, soil_moist_max, soil_rechr_max, carea_min +! cfgi_thrshld, cfgi_decay !*********************************************************************** INTEGER FUNCTION srunoffdecl() USE PRMS_SRUNOFF @@ -284,6 +292,36 @@ INTEGER FUNCTION srunoffdecl() & 'cfs', Strm_seg_in)/=0 ) CALL read_error(3,'strm_seg_in') ENDIF +! frozen ground variables and parameters + IF ( Frozen_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Frozen(Nhru) ) + IF ( declvar(MODNAME, 'frozen', 'nhru', Nhru, 'integer', & + & 'Flag for frozen ground (0=no; 1=yes)', & + & 'dimensionless', Frozen)/=0 ) CALL read_error(3, 'frozen') + + ALLOCATE ( Cfgi(Nhru) ) + IF ( declvar(MODNAME, 'cfgi', 'nhru', Nhru, 'real', & + & 'Continuous Frozen Ground Index', & + & 'index', Cfgi)/=0 ) CALL read_error(3, 'cfgi') + + ALLOCATE ( Cfgi_prev(Nhru) ) + IF ( declvar(MODNAME, 'cfgi_prev', 'nhru', Nhru, 'real', & + & 'Continuous Frozen Ground Index from previous day', & + & 'index', Cfgi_prev)/=0 ) CALL read_error(3, 'cfgi_prev') + + IF ( declparam(MODNAME, 'cfgi_decay', 'one', 'real', & + & '0.97', '0.01', '1.0', & + & 'CFGI daily decay of index, value of 1.0 is no decay', & + & 'CFGI daily decay of index, value of 1.0 is no decay', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'cfgi_decay') + + IF ( declparam(MODNAME, 'cfgi_thrshld', 'one', 'real', & + & '83.0', '1.0', '500.0', & + & 'CFGI threshold value indicating frozen soil', & + & 'CFGI threshold value indicating frozen soil', & + & 'index')/=0 ) CALL read_error(1, 'cfgi_thrshld') + ENDIF + ! Declare parameters IF ( Sroff_flag==1 .OR. Model==99 ) THEN ALLOCATE ( Smidx_coef(Nhru) ) @@ -410,7 +448,7 @@ INTEGER FUNCTION srunoffdecl() & 'Coefficient in the exponential equation relating'// & & ' maximum surface area to the fraction that open'// & & ' depressions are full to compute current surface area for each HRU;'// & - & ' 0.001 is an approximate rectangle; 1.0 is a triangle', & + & ' 0.001 is an approximate cylinder; 1.0 is a cone', & & 'none')/=0 ) CALL read_error(1, 'va_open_exp') ALLOCATE ( Va_clos_exp(Nhru) ) @@ -421,7 +459,7 @@ INTEGER FUNCTION srunoffdecl() & 'Coefficient in the exponential equation relating'// & & ' maximum surface area to the fraction that closed'// & & ' depressions are full to compute current surface area for each HRU;'// & - & ' 0.001 is an approximate rectangle; 1.0 is a triangle', & + & ' 0.001 is an approximate cylinder; 1.0 is a cone', & & 'none')/=0 ) CALL read_error(1, 'va_clos_exp') ENDIF @@ -438,7 +476,8 @@ END FUNCTION srunoffdecl INTEGER FUNCTION srunoffinit() USE PRMS_SRUNOFF USE PRMS_MODULE, ONLY: Dprst_flag, Nhru, Nlake, Cascade_flag, Sroff_flag, & - & Init_vars_from_file, Call_cascade, Water_use_flag !, Parameter_check_flag + & Init_vars_from_file, Call_cascade, Water_use_flag, & + & Frozen_flag, Glacier_flag !, Parameter_check_flag USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order ! USE PRMS_FLOWVARS, ONLY: Soil_moist_max IMPLICIT NONE @@ -539,6 +578,12 @@ INTEGER FUNCTION srunoffinit() ! & 'carea_max very sensitive for those HRUs' ! ENDIF +! Frozen soil parameters + IF ( Frozen_flag==1 ) THEN + IF ( getparam(MODNAME, 'cfgi_thrshld', 1, 'real', Cfgi_thrshld)/=0 ) CALL read_error(2, 'cfgi_thrshld') + IF ( getparam(MODNAME, 'cfgi_decay', 1, 'real', Cfgi_decay)/=0 ) CALL read_error(2, 'cfgi_decay') + ENDIF + ! Depression Storage parameters and variables: IF ( Dprst_flag==1 ) CALL dprst_init() @@ -550,24 +595,26 @@ END FUNCTION srunoffinit !*********************************************************************** INTEGER FUNCTION srunoffrun() USE PRMS_SRUNOFF - USE PRMS_MODULE, ONLY: Dprst_flag, Cascade_flag, Call_cascade, Print_debug + USE PRMS_MODULE, ONLY: Dprst_flag, Cascade_flag, Call_cascade, Print_debug, Frozen_flag, Glacier_flag USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, & & Hru_perv, Hru_imperv, Hru_percent_imperv, Hru_frac_perv, & & Dprst_area_max, Hru_area, Hru_type, Basin_area_inv, & & Dprst_area_clos_max, Dprst_area_open_max, Hru_area_dble USE PRMS_CLIMATEVARS, ONLY: Potet USE PRMS_FLOWVARS, ONLY: Sroff, Infil, Imperv_stor, Pkwater_equiv, Dprst_vol_open, Dprst_vol_clos, & - & Imperv_stor_max, Snowinfil_max + & Imperv_stor_max, Snowinfil_max, Glacier_frac USE PRMS_CASCADE, ONLY: Ncascade_hru USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Hru_intcpevap, Net_apply, Intcp_changeover - USE PRMS_SNOW, ONLY: Snow_evap, Snowcov_area, Snowmelt + USE PRMS_SNOW, ONLY: Snow_evap, Snowcov_area, Snowmelt, Pk_depth, Glacrb_melt IMPLICIT NONE INTRINSIC SNGL, DBLE EXTERNAL imperv_et, compute_infil, run_cascade_sroff, dprst_comp, perv_comp ! Local Variables - INTEGER :: i, k, dprst_chk + INTEGER :: i, k, dprst_chk, frzen, active_glacier REAL :: srunoff, avail_et, hperv, sra, availh2o DOUBLE PRECISION :: hru_sroff_down, runoff, apply_sroff + REAL :: cfgi_sroff, cfgi_k, depth_cm + REAL :: glcrmltb, temp, temp2 ! Ashley glaciers !*********************************************************************** srunoffrun = 0 @@ -583,6 +630,7 @@ INTEGER FUNCTION srunoffrun() Basin_imperv_stor = 0.0D0 Basin_hortonian = 0.0D0 Basin_contrib_fraction = 0.0D0 + Basin_cfgi_sroff = 0.0D0 Basin_apply_sroff = 0.0D0 IF ( Call_cascade==1 ) Strm_seg_in = 0.0D0 @@ -608,6 +656,22 @@ INTEGER FUNCTION srunoffrun() Hruarea_dble = Hru_area_dble(i) Ihru = i runoff = 0.0D0 + glcrmltb = 0.0 ! Ashley glacier + Isglacier = 0 + active_glacier = -1 ! not an Ashley glacier + IF ( Glacier_flag>0 ) THEN + IF ( Hru_type(i)==4 ) THEN + IF ( Glacier_flag==1 ) THEN ! Ashley glacier + Isglacier = 1 + glcrmltb = Glacrb_melt(i) + IF ( Glacier_frac(i)>0.0 ) THEN + active_glacier = 1 + ELSE + active_glacier = 0 ! glacier capable HRU, but not glaciated + ENDIF + ENDIF + ENDIF + ENDIF IF ( Hru_type(i)==2 ) THEN ! HRU is a lake @@ -638,7 +702,38 @@ INTEGER FUNCTION srunoffrun() avail_et = Potet(i) - Snow_evap(i) - Hru_intcpevap(i) -!******Compute runoff for pervious, impervious, and depression storage area + frzen = 0 + IF ( Frozen_flag==1 ) THEN + IF ( Tavgc(i)>0.0 ) THEN + cfgi_k = 0.5 + ELSE + cfgi_k = 0.08 + ENDIF + depth_cm = Pk_depth(i)*2.54 + Cfgi(i) = (Cfgi_decay*Cfgi_prev(i)) - (Tavgc(i)*(2.71828**(-0.4*cfgi_k*depth_cm))) + IF ( active_glacier==1 ) THEN + Cfgi(i) = 0.0 !if glacier over, want ground completely unfrozen, or below threshold, infiltration + IF ( Glacier_frac(i)<1.0 ) Cfgi(i) = Cfgi_thrshld ! Ashley glacier with some open fraction + ENDIF + IF ( Cfgi(i)<0.0 ) Cfgi(i) = 0.0 + Cfgi_prev(i) = Cfgi(i) + IF ( Cfgi(i)>=Cfgi_thrshld ) THEN + frzen = 1 + ! depression storage states are not changed if frozen + IF ( Cascade_flag>0 ) THEN + cfgi_sroff = (Snowmelt(i) + Net_rain(i) + Upslope_hortonian(i) + glcrmltb)*Hruarea + ELSE + cfgi_sroff = (Snowmelt(i) + Net_rain(i) + glcrmltb)*Hruarea + ENDIF + IF ( Use_sroff_transfer==1 ) cfgi_sroff = cfgi_sroff + Net_apply(i)*Hruarea + runoff = runoff + cfgi_sroff + Basin_cfgi_sroff = Basin_cfgi_sroff + cfgi_sroff + ENDIF + Frozen(i) = frzen + ENDIF + +!******Compute runoff for pervious, impervious, and depression storage area, only if not frozen ground + IF ( frzen==0 ) THEN ! DO IRRIGATION APPLICATION, ONLY DONE HERE, ASSUMES NO SNOW and ! only for pervious areas (just like infiltration) IF ( Use_sroff_transfer==1 ) THEN @@ -653,6 +748,17 @@ INTEGER FUNCTION srunoffrun() runoff = runoff + apply_sroff ENDIF ENDIF + + IF ( Isglacier==1 ) THEN ! Ashley glacier + temp = Snowmelt(i) + glcrmltb !Snowmelt or 0.0 + temp2 = availh2o*(1.0-Glacier_frac(i)) + CALL compute_infil(temp2, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), temp, & + & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i)) + ELSE + CALL compute_infil(availh2o, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), Snowmelt(i), & + & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i)) + ENDIF + ENDIF availh2o = Intcp_changeover(i) + Net_rain(i) @@ -666,17 +772,19 @@ INTEGER FUNCTION srunoffrun() dprst_chk = 1 ! ******Compute the depression storage component ! only call if total depression surface area for each HRU is > 0.0 - CALL dprst_comp(Dprst_vol_clos(i), Dprst_area_clos_max(i), Dprst_area_clos(i), & + IF ( frzen==0 ) THEN + CALL dprst_comp(Dprst_vol_clos(i), Dprst_area_clos_max(i), Dprst_area_clos(i), & & Dprst_vol_open_max(i), Dprst_vol_open(i), Dprst_area_open_max(i), Dprst_area_open(i), & & Dprst_sroff_hru(i), Dprst_seep_hru(i), Sro_to_dprst_perv(i), Sro_to_dprst_imperv(i), & & Dprst_evap_hru(i), avail_et, availh2o, Dprst_in(i)) - runoff = runoff + Dprst_sroff_hru(i)*Hruarea_dble + runoff = runoff + Dprst_sroff_hru(i)*Hruarea_dble + ENDIF ENDIF ENDIF ! ********************************************************** srunoff = 0.0 - IF ( Hru_type(i)==1 ) THEN + IF ( Hru_type(i)==1 .OR. active_glacier==0 ) THEN ! could be an Ashley glacier-capable HRU with no ice !******Compute runoff for pervious and impervious area, and depression storage area runoff = runoff + DBLE( Srp*hperv + Sri*Hruarea_imperv ) srunoff = SNGL( runoff/Hruarea_dble ) @@ -703,27 +811,29 @@ INTEGER FUNCTION srunoffrun() Basin_contrib_fraction = Basin_contrib_fraction + DBLE( Contrib_fraction(i)*hperv ) !******Compute evaporation from impervious area - IF ( Hruarea_imperv>0.0 ) THEN - IF ( Imperv_stor(i)>0.0 ) THEN - CALL imperv_et(Imperv_stor(i), Potet(i), Imperv_evap(i), Snowcov_area(i), avail_et) - Hru_impervevap(i) = Imperv_evap(i)*Imperv_frac - !IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 - avail_et = avail_et - Hru_impervevap(i) - IF ( avail_et<0.0 ) THEN - ! sanity check -! IF ( avail_et<-NEARZERO ) PRINT*, 'avail_et<0 in srunoff imperv', i, Nowmonth, Nowday, avail_et - Hru_impervevap(i) = Hru_impervevap(i) + avail_et - IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 - Imperv_evap(i) = Hru_impervevap(i)/Imperv_frac - Imperv_stor(i) = Imperv_stor(i) - avail_et/Imperv_frac - avail_et = 0.0 + IF ( frzen==0 ) THEN + IF ( Hruarea_imperv>0.0 ) THEN + IF ( Imperv_stor(i)>0.0 ) THEN + CALL imperv_et(Imperv_stor(i), Potet(i), Imperv_evap(i), Snowcov_area(i), avail_et) + Hru_impervevap(i) = Imperv_evap(i)*Imperv_frac + !IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 + avail_et = avail_et - Hru_impervevap(i) + IF ( avail_et<0.0 ) THEN + ! sanity check +! IF ( avail_et<-NEARZERO ) PRINT*, 'avail_et<0 in srunoff imperv', i, Nowmonth, Nowday, avail_et + Hru_impervevap(i) = Hru_impervevap(i) + avail_et + IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 + Imperv_evap(i) = Hru_impervevap(i)/Imperv_frac + Imperv_stor(i) = Imperv_stor(i) - avail_et/Imperv_frac + avail_et = 0.0 + ENDIF + Basin_imperv_evap = Basin_imperv_evap + DBLE( Hru_impervevap(i)*Hruarea ) + Hru_impervstor(i) = Imperv_stor(i)*Imperv_frac + Basin_imperv_stor = Basin_imperv_stor + DBLE(Imperv_stor(i)*Hruarea_imperv ) ENDIF - Basin_imperv_evap = Basin_imperv_evap + DBLE( Hru_impervevap(i)*Hruarea ) - Hru_impervstor(i) = Imperv_stor(i)*Imperv_frac - Basin_imperv_stor = Basin_imperv_stor + DBLE(Imperv_stor(i)*Hruarea_imperv ) + Hru_sroffi(i) = Sri*Imperv_frac + Basin_sroffi = Basin_sroffi + DBLE( Sri*Hruarea_imperv ) ENDIF - Hru_sroffi(i) = Sri*Imperv_frac - Basin_sroffi = Basin_sroffi + DBLE( Sri*Hruarea_imperv ) ENDIF IF ( dprst_chk==1 ) Dprst_stor_hru(i) = (Dprst_vol_open(i)+Dprst_vol_clos(i))/Hruarea_dble @@ -740,6 +850,7 @@ INTEGER FUNCTION srunoffrun() Basin_imperv_evap = Basin_imperv_evap*Basin_area_inv Basin_imperv_stor = Basin_imperv_stor*Basin_area_inv Basin_infil = Basin_infil*Basin_area_inv + ! doesn't include CFGI runoff Basin_sroffp = Basin_sroffp*Basin_area_inv Basin_sroffi = Basin_sroffi*Basin_area_inv Basin_hortonian = Basin_hortonian*Basin_area_inv @@ -793,7 +904,7 @@ END SUBROUTINE imperv_et !*********************************************************************** SUBROUTINE compute_infil(Net_rain, Net_ppt, Imperv_stor, Imperv_stor_max, Snowmelt, & & Snowinfil_max, Net_snow, Pkwater_equiv, Infil, Hru_type) - USE PRMS_SRUNOFF, ONLY: Sri, Hruarea_imperv, Upslope_hortonian, Ihru, Srp + USE PRMS_SRUNOFF, ONLY: Sri, Hruarea_imperv, Upslope_hortonian, Ihru, Srp, Isglacier USE PRMS_SNOW, ONLY: Pptmix_nopack USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO USE PRMS_MODULE, ONLY: Cascade_flag @@ -809,13 +920,16 @@ SUBROUTINE compute_infil(Net_rain, Net_ppt, Imperv_stor, Imperv_stor_max, Snowme EXTERNAL perv_comp, check_capacity ! Local Variables REAL :: avail_water + INTEGER :: hru_flag !*********************************************************************** + hru_flag = 0 + IF ( Hru_type==1 .OR. Isglacier==1 ) hru_flag = 1 ! land or Ashley glacier ! compute runoff from cascading Hortonian flow IF ( Cascade_flag>0 ) THEN avail_water = SNGL( Upslope_hortonian(Ihru) ) IF ( avail_water>0.0 ) THEN Infil = avail_water - IF ( Hru_type==1 ) CALL perv_comp(avail_water, avail_water, Infil, Srp) + IF ( hru_flag==1 ) CALL perv_comp(avail_water, avail_water, Infil, Srp) ENDIF ELSE avail_water = 0.0 @@ -828,7 +942,7 @@ SUBROUTINE compute_infil(Net_rain, Net_ppt, Imperv_stor, Imperv_stor_max, Snowme IF ( Pptmix_nopack(Ihru)==1 ) THEN avail_water = avail_water + Net_rain Infil = Infil + Net_rain - IF ( Hru_type==1 ) CALL perv_comp(Net_rain, Net_rain, Infil, Srp) + IF ( hru_flag==1 ) CALL perv_comp(Net_rain, Net_rain, Infil, Srp) ENDIF !******If precipitation on snowpack, all water available to the surface is @@ -840,7 +954,7 @@ SUBROUTINE compute_infil(Net_rain, Net_ppt, Imperv_stor, Imperv_stor_max, Snowme IF ( Snowmelt>0.0 ) THEN avail_water = avail_water + Snowmelt Infil = Infil + Snowmelt - IF ( Hru_type==1 ) THEN + IF ( hru_flag==1 ) THEN IF ( Pkwater_equiv>0.0D0 .OR. Net_ppt-Net_snow0.0 ) THEN - IF ( Hru_type==1 ) CALL check_capacity(Snowinfil_max, Infil) + IF ( hru_flag==1 ) CALL check_capacity(Snowinfil_max, Infil) ENDIF !******Impervious area computations IF ( Hruarea_imperv>0.0 ) THEN Imperv_stor = Imperv_stor + avail_water - IF ( Hru_type==1 ) THEN + IF ( hru_flag==1 ) THEN IF ( Imperv_stor>Imperv_stor_max ) THEN Sri = Imperv_stor - Imperv_stor_max Imperv_stor = Imperv_stor_max @@ -1393,7 +1507,8 @@ END SUBROUTINE dprst_comp ! srunoff_restart - write or read srunoff restart file !*********************************************************************** SUBROUTINE srunoff_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Dprst_flag + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Dprst_flag, & + & Frozen_flag, Glacier_flag USE PRMS_SRUNOFF IMPLICIT NONE ! Argument @@ -1415,6 +1530,11 @@ SUBROUTINE srunoff_restart(In_out) WRITE ( Restart_outunit ) Dprst_stor_hru WRITE ( Restart_outunit ) Dprst_vol_thres_open ENDIF + IF ( Frozen_flag==1 ) THEN + WRITE ( Restart_outunit ) Frozen + WRITE ( Restart_outunit ) Cfgi + WRITE ( Restart_outunit ) Cfgi_prev + ENDIF ELSE READ ( Restart_inunit ) module_name CALL check_restart(MODNAME, module_name) @@ -1429,5 +1549,10 @@ SUBROUTINE srunoff_restart(In_out) READ ( Restart_inunit ) Dprst_stor_hru READ ( Restart_inunit ) Dprst_vol_thres_open ENDIF + IF ( Frozen_flag==1 ) THEN ! could be problem for restart + READ ( Restart_inunit ) Frozen + READ ( Restart_inunit ) Cfgi + READ ( Restart_inunit ) Cfgi_prev + ENDIF ENDIF END SUBROUTINE srunoff_restart diff --git a/prms/water_balance.f90 b/prms/water_balance.f90 index ca558287..64e482ff 100644 --- a/prms/water_balance.f90 +++ b/prms/water_balance.f90 @@ -116,9 +116,9 @@ SUBROUTINE water_balance_decl() 9004 FORMAT (' Date Water Bal last store GWR store', & ' GW input GW flow GW sink GW upslope minarea_in downflow') 9005 FORMAT (' Date Water Bal Robal Sroff Infil Impervevap Impervstor Dprst_evap Dprst_seep', & - & ' Perv Sro Imperv Sro Dprst Sro') + & ' Perv Sro Imperv Sro Dprst Sro CFGI Sro Glacrmelt') 9006 FORMAT (' Date Water Bal Robal Sroff Infil Impervevap Impervstor Dprst_evap Dprst_seep', & - & ' Perv Sro Imperv Sro Dprst Sro Sroffdown Srofflake') + & ' Perv Sro Imperv Sro Dprst Sro Sroffdown Srofflake CFGI Sro Glacrmelt') 9007 FORMAT (' Date Water Bal Snowpack Snowmelt Snowevap Snowcover' ) END SUBROUTINE water_balance_decl @@ -148,7 +148,7 @@ END SUBROUTINE water_balance_init !*********************************************************************** SUBROUTINE water_balance_run() USE PRMS_WATER_BALANCE - USE PRMS_MODULE, ONLY: Cascade_flag, Cascadegw_flag, Dprst_flag + USE PRMS_MODULE, ONLY: Cascade_flag, Cascadegw_flag, Dprst_flag, Glacier_flag USE PRMS_BASIN, ONLY: Hru_route_order, Active_hrus, Hru_frac_perv, Hru_area_dble, Hru_perv, & & Hru_type, Basin_area_inv, NEARZERO, Dprst_area_max, Hru_percent_imperv, Dprst_frac, Cov_type, DNEARZERO USE PRMS_CLIMATEVARS, ONLY: Hru_ppt, Basin_ppt, Hru_rain, Hru_snow, Newsnow, Pptmix @@ -164,14 +164,15 @@ SUBROUTINE water_balance_run() & Canopy_covden, Intcp_changeover, Net_ppt, Intcp_stor_ante, Last_intcp_stor, & & Net_apply, Gain_inches, Use_transfer_intcp, Basin_hru_apply, Basin_net_apply USE PRMS_SNOW, ONLY: Snowmelt, Pptmix_nopack, Snow_evap, Snowcov_area, Basin_pweqv, & - & Basin_snowmelt, Basin_snowevap, Basin_snowcov, Pkwater_ante + & Basin_snowmelt, Basin_snowevap, Basin_snowcov, Pkwater_ante, Glacrb_melt + USE PRMS_GLACR, ONLY: Glacr_flow USE PRMS_SRUNOFF, ONLY: Basin_infil, Hru_hortn_cascflow, Upslope_hortonian, Hru_impervstor, & & Dprst_stor_hru, Basin_sroffp, Basin_sroffi, Basin_dprst_sroff, Basin_sroff_down, & & Basin_hortonian_lakes, Basin_imperv_evap, Basin_imperv_stor, & & Basin_dprst_evap, Basin_dprst_seep, Basin_sroff, Hru_impervevap, Dprst_seep_hru, & - & Dprst_evap_hru, Dprst_sroff_hru, Dprst_insroff_hru, & + & Dprst_evap_hru, Dprst_sroff_hru, Dprst_insroff_hru, Basin_glacr_melt, & & Sro_to_dprst_perv, Dprst_area_clos, Hortonian_flow, Dprst_in, Hru_sroffp, Hru_sroffi, Imperv_stor_ante, & - & Dprst_stor_ante, Use_sroff_transfer + & Dprst_stor_ante, Use_sroff_transfer, Basin_cfgi_sroff USE PRMS_SOILZONE, ONLY: Swale_actet, Dunnian_flow, Basin_sz2gw, & & Perv_actet, Cap_infil_tot, Pref_flow_infil, Cap_waterin, Upslope_interflow, & & Upslope_dunnianflow, Pref_flow, Pref_flow_stor, Soil_lower, Gvr2pfr, Basin_ssin, & @@ -191,7 +192,7 @@ SUBROUTINE water_balance_run() ! Local Variables INTEGER :: i, k REAL :: last_sm, last_ss, soilbal, perv_frac, gvrbal, test, waterin, waterout, hrubal - REAL :: delstor, robal + REAL :: delstor, robal, gmelt DOUBLE PRECISION :: basin_bal, bsmbal, soil_in, gwbal, gwup, basin_robal, bsnobal DOUBLE PRECISION :: hru_out, hru_in, wbal, delta_stor, pptbal, brobal, dprst_hru_wb, harea CHARACTER(LEN=20), PARAMETER :: fmt1 = '(A, I5, 2("/",I2.2))' @@ -266,11 +267,13 @@ SUBROUTINE water_balance_run() robal = robal + Net_rain(i) ENDIF !IF ( Net_snow(i)0 ) robal = robal + SNGL( Upslope_hortonian(i) - Hru_hortn_cascflow(i) ) IF ( Dprst_flag==1 ) robal = robal - Dprst_evap_hru(i) + & & SNGL( Dprst_stor_ante(i) - Dprst_stor_hru(i) - Dprst_seep_hru(i) ) !- Dprst_in(i) - Dprst_insroff_hru(i) + gmelt = 0.0 basin_robal = basin_robal + DBLE( robal ) IF ( ABS(robal)>TOOSMALL ) THEN IF ( Dprst_flag==1 ) THEN @@ -293,16 +296,19 @@ SUBROUTINE water_balance_run() ELSE WRITE ( BALUNT, * ) 'HRU surface runoff rounding issue', i, ' hru_type:', Hru_type(i) ENDIF + IF ( Glacier_flag==1 ) THEN + gmelt = Glacrb_melt(i) + Glacr_flow(i) + ENDIF IF ( Cascade_flag>0 ) THEN WRITE ( BALUNT, '(3I3,F10.6,17F10.4)' ) Nowmonth, Nowday, Pptmix_nopack(i), robal, Snowmelt(i), & & Upslope_hortonian(i), Imperv_stor_ante(i), Hru_hortn_cascflow(i), Infil(i), Hortonian_flow(i), & & Hru_impervstor(i), Hru_impervevap(i), Net_ppt(i), & - & Pkwater_equiv(i), Snow_evap(i), Net_snow(i), Net_rain(i), Hru_sroffp(i), Hru_sroffi(i), harea + & Pkwater_equiv(i), Snow_evap(i), Net_snow(i), Net_rain(i), Hru_sroffp(i), Hru_sroffi(i), gmelt, harea ELSE - WRITE ( BALUNT,'(3I3,F10.6,15F10.5,F10.3)' ) Nowmonth, Nowday, Pptmix_nopack(i), & + WRITE ( BALUNT,'(3I3,F10.6,16F10.4)' ) Nowmonth, Nowday, Pptmix_nopack(i), & & robal, Snowmelt(i), Imperv_stor_ante(i), Infil(i), & & Hortonian_flow(i), Hru_impervstor(i), Hru_impervevap(i), Hru_percent_imperv(i), Net_ppt(i), & - & Pkwater_equiv(i), Snow_evap(i), Net_snow(i), Net_rain(i), Hru_sroffp(i), Hru_sroffi(i), harea + & Pkwater_equiv(i), Snow_evap(i), Net_snow(i), Net_rain(i), Hru_sroffp(i), Hru_sroffi(i), gmelt, harea ENDIF ENDIF @@ -435,19 +441,19 @@ SUBROUTINE water_balance_run() & Basin_snowmelt, Basin_snowevap, Basin_snowcov ! srunoff - brobal = Basin_sroff - Basin_sroffp - Basin_sroffi - Basin_dprst_sroff + brobal = Basin_sroff - Basin_sroffp - Basin_sroffi - Basin_dprst_sroff - Basin_cfgi_sroff - Basin_glacr_melt IF ( Cascade_flag>0 ) THEN brobal = brobal + Basin_sroff_down WRITE ( SROUNIT, 9002 ) Nowyear, Nowmonth, Nowday, basin_robal, & & brobal, Basin_sroff, Basin_infil, Basin_imperv_evap, & & Basin_imperv_stor, Basin_dprst_evap, Basin_dprst_seep, & & Basin_sroffp, Basin_sroffi, Basin_dprst_sroff, & - & Basin_sroff_down, Basin_hortonian_lakes + & Basin_sroff_down, Basin_hortonian_lakes, Basin_cfgi_sroff, Basin_glacr_melt ELSE WRITE ( SROUNIT, 9002 ) Nowyear, Nowmonth, Nowday, basin_robal, & & brobal, Basin_sroff, Basin_infil, Basin_imperv_evap, & & Basin_imperv_stor, Basin_dprst_evap, Basin_dprst_seep, & - & Basin_sroffp, Basin_sroffi, Basin_dprst_sroff + & Basin_sroffp, Basin_sroffi, Basin_dprst_sroff, Basin_cfgi_sroff, Basin_glacr_melt ENDIF IF ( DABS(basin_robal)>DSMALL ) THEN WRITE ( BALUNT, 9003 ) 'possible srunoff basin water balance ERROR', & From 759e319e37e3e26902dff306632dec02d1cf0a8a Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 22 Jun 2019 11:54:25 -0600 Subject: [PATCH 03/47] Makefiles --- Makefile | 21 ++++++--- makelist | 40 ++++++++++------- prms/Makefile | 119 +++++++++++++++++++++++++++++++++++++++++++++----- 3 files changed, 148 insertions(+), 32 deletions(-) diff --git a/Makefile b/Makefile index dc311de6..706345ca 100644 --- a/Makefile +++ b/Makefile @@ -10,15 +10,26 @@ include ./makelist # Standard Targets for Users # -all: standard +all: prms -standard: +prms: +# Create lib directory, if necessary + @if [ ! -d $(MMFDIR) ] ; then \ + mkdir $(MMFDIR) ; \ + echo Created directory $(MMFDIR) ; \ + fi +# Create bin directory, if necessary + @if [ ! -d $(BINDIR) ] ; then \ + mkdir $(BINDIR) ; \ + echo Created directory $(BINDIR) ; \ + fi cd $(MMFDIR); $(MAKE); - cd $(MIZU); $(MAKE); + cd $(MIZUDIR); $(MAKE); cd $(PRMSDIR); $(MAKE); clean: cd $(MMFDIR); $(MAKE) clean; - cd $(MIZU); $(MAKE); clean; + cd $(MIZUDIR); $(MAKE) clean; cd $(PRMSDIR); $(MAKE) clean; - + $(RM) $(BINDIR)/prms*~ + $(RM) $(BINDIR)/prmsrip*~ diff --git a/makelist b/makelist index 225bea55..bc8fa06f 100644 --- a/makelist +++ b/makelist @@ -2,10 +2,17 @@ #------------------------------------------------------------------- #------------------------------------------------------------------- -MMFDIR = ./mmf -PRMSDIR = ./prms -BINDIR = ../bin -MMFLIB = .$(MMFDIR)/libmmf.a +F_MASTER = /Users/amedin/Research/ExtCONUS_AK +CODEDIR = $(F_MASTER)/NHM_glacier +MMFDIR = $(CODEDIR)/mmf +MIZUDIR = $(CODEDIR)/mizu +LIBDIR = $(CODEDIR)/lib +PRMSDIR = $(CODEDIR)/prms +BINDIR = $(F_MASTER)/bin +MMFLIB = $(LIBDIR)/libmmf.a +MIZULIB = $(LIBDIR)/libmizu.a +MIZULIB2 = $(LIBDIR)/libmizu2.a +INCMIZU = -I$(MIZUDIR)/include ######################################################### # Configure tags for each system @@ -16,21 +23,22 @@ ARC = LINUX #OPTLEVEL = -g OPTLEVEL = -O -Bstatic #for gfortran -#LDFLAGS =$(OPTLEVEL) +LDFLAGS =$(OPTLEVEL) #for ifort -LDFLAGS =$(OPTLEVEL) -nofor_main +#LDFLAGS =$(OPTLEVEL) -nofor_main +MFLAGS = -ffree-line-length-none ########################################################## # Define the Fortran compile flags ########################################################## #for gfortran -#FFLAGS= $(OPTLEVEL) -fbounds-check -fno-second-underscore -Wall +FFLAGS= $(OPTLEVEL) -fbounds-check -Wall -fno-second-underscore $(MFLAGS) #FFLAGS= $(OPTLEVEL) -fno-second-underscore +FC = gfortran #for ifort #FFLAGS= $(OPTLEVEL) -warn all -fltconsistency -FFLAGS= $(OPTLEVEL) -fp-model source -#FC = gfortran -FC = ifort +#FFLAGS= $(OPTLEVEL) -fp-model source +#FC = ifort ########################################################## # Define the C compile flags @@ -38,19 +46,19 @@ FC = ifort ########################################################## CFLAGS = $(OPTLEVEL) -D$(ARC) -D_UF -Wall #for gfortran -#CC = gcc +CC = gcc #for ifort -CC = icc +#CC = icc ########################################################## # Define the libraries ########################################################## #for gfortran -#MATHLIB = -lm -#GCLIB = -lgfortran -lgcc $(MATHLIB) +MATHLIB = -lm +GCLIB = -L/opt/local/lib -lgfortran -lgcc_s.1 #for ifort -MATHLIB = -GCLIB = +#MATHLIB = +#GCLIB = FLIBS = $(GCLIB) ########################################################## diff --git a/prms/Makefile b/prms/Makefile index 48825d6e..e1184f95 100644 --- a/prms/Makefile +++ b/prms/Makefile @@ -1,12 +1,17 @@ # PRMS V makefile include ../makelist -TARGET = $(BINDIR)/prms +TARGET = $(BINDIR)/prmsg +TARGET2 = $(BINDIR)/prmsgrip #################################################### # Rules for targets #################################################### -all: $(TARGET) +all: $(TARGET) $(TARGET2) + +orig: $(TARGET) + +rip: $(TARGET2) # # Define all object files which make up the library @@ -42,6 +47,7 @@ OBJS = \ transp_frost.o \ transp_tindex.o \ frost_date.o \ + glacr_melt.o \ intcp.o \ snowcomp.o \ srunoff.o \ @@ -68,16 +74,78 @@ OBJS = \ stream_temp.o \ utils_prms.o +RIP = \ + call_modulesRip.o \ + basin.o \ + climateflow.o \ + cascade.o \ + soltab.o \ + setup_param.o \ + convert_params.o \ + prms_time.o \ + obs.o \ + climate_hru.o \ + potet_jh.o \ + potet_pt.o \ + potet_hs.o \ + potet_pm.o \ + potet_pm_sta.o \ + potet_pan.o \ + potet_hamon.o \ + ddsolrad.o \ + ccsolrad.o \ + ide_dist.o \ + xyz_dist.o \ + precip_1sta_laps.o \ + precip_dist2.o \ + temp_1sta_laps.o \ + temp_dist2.o \ + transp_frost.o \ + transp_tindex.o \ + frost_date.o \ + glacr_melt.o \ + intcp.o \ + snowcomp.o \ + srunoff.o \ + soilzone.o \ + gwflow.o \ + water_use_read.o \ + dynamic_param_read.o \ + water_balance.o \ + routingRip.o \ + strmflow.o \ + strmflow_in_outCopy.o \ + muskingumRip.o \ + muskingum_lakeCopy.o \ + mizurouteRip.o \ + subbasin.o \ + map_results.o \ + nhru_summary.o \ + nsub_summary.o \ + nsegment_summary.o \ + basin_summary.o \ + write_climate_hru.o \ + prms_summary_lauren.o \ + basin_sumCopy.o \ + utils_prms.o \ + stream_tempCopy.o + $(TARGET): $(OBJS) $(RM) $(TARGET) - $(FC) $(LDFLAGS) -o $(TARGET) $(OBJS) $(MMFLIB) $(MIZULIB) $(FLIBS) + $(FC) $(LDFLAGS) -o $(TARGET) $(OBJS) $(MMFLIB) $(MIZULIB) $(INCMIZU) $(FLIBS) + +$(TARGET2): $(RIP) + $(RM) $(TARGET2) + $(FC) $(LDFLAGS) -o $(TARGET2) $(RIP) $(MMFLIB) $(MIZULIB) $(INCMIZU) $(FLIBS) # # Define all object files which make up the library # clean: + cd $(MMFDIR);make clean; cd - $(RM) $(TARGET) + $(RM) $(TARGET2) $(RM) *.o *.mod *~ call_modules.o: call_modules.f90 @@ -101,9 +169,6 @@ ccsolrad.o: ccsolrad.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prm prms_summary_lauren.o: prms_summary_lauren.f90 prms_module.mod prms_climatevars.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_intcp.mod prms_snow.mod prms_srunoff.mod prms_soilzone.mod prms_gwflow.mod $(FC) -c $(FFLAGS) prms_summary_lauren.f90 -muskingum.o: muskingum.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routing.mod prms_srunoff.mod prms_gwflow.mod - $(FC) -c $(FFLAGS) muskingum.f90 - intcp.o: intcp.f90 prms_obs.mod prms_climatevars.mod prms_flowvars.mod prms_module.mod prms_basin.mod prms_water_use.mod prms_set_time.mod prms_obs.mod $(FC) -c $(FFLAGS) intcp.f90 @@ -140,9 +205,6 @@ climateflow.o: climateflow.f90 prms_module.mod prms_basin.mod prms_set_time.mod soilzone.o: soilzone.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snow.mod prms_cascade.mod prms_climatevars.mod prms_set_time.mod prms_srunoff.mod $(FC) -c $(FFLAGS) soilzone.f90 -routing.o: routing.f90 prms_module.mod prms_basin.mod prms_gwflow.mod prms_flowvars.mod prms_set_time.mod prms_water_use.mod prms_srunoff.mod - $(FC) -c $(FFLAGS) routing.f90 - subbasin.o: subbasin.f90 prms_module.mod prms_basin.mod prms_gwflow.mod prms_flowvars.mod prms_set_time.mod prms_intcp.mod prms_srunoff.mod prms_soilzone.mod prms_muskingum_lake.mod prms_snow.mod prms_climatevars.mod $(FC) -c $(FFLAGS) subbasin.f90 @@ -236,9 +298,44 @@ xyz_dist.o: xyz_dist.f prms_module.mod prms_basin.mod prms_set_time.mod prms_cli stream_temp.o: stream_temp.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routing.mod prms_soltab.mod prms_snow.mod prms_climate_hru.mod $(FC) -c $(FFLAGS) stream_temp.f90 -mizuroute.o: mizuroute.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routing.mod prms_srunoff.mod prms_gwflow.mod +glacr_melt.o: glacr_melt.f90 prms_snow.mod prms_intcp.mod prms_soltab.mod + $(FC) -c $(FFLAGS) glacr_melt.f90 + +call_modulesRip.o: call_modulesRip.f90 + $(FC) -c $(FFLAGS) call_modulesRip.f90 + +muskingum.o: muskingum.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routing.mod prms_srunoff.mod prms_gwflow.mod prms_glacr.mod + $(FC) -c $(FFLAGS) muskingum.f90 + +routing.o: routing.f90 prms_module.mod prms_basin.mod prms_gwflow.mod prms_flowvars.mod prms_set_time.mod prms_water_use.mod prms_srunoff.mod prms_glacr.mod + $(FC) -c $(FFLAGS) routing.f90 + +mizuroute.o: mizuroute.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routing.mod prms_srunoff.mod prms_gwflow.mod prms_glacr.mod $(FC) -c $(FFLAGS) $(INCMIZU) mizuroute.f90 +muskingumRip.o: muskingumRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoff.mod prms_gwflow.mod prms_glacr.mod + $(FC) -c $(FFLAGS) muskingumRip.f90 + +routingRip.o: routingRip.f90 prms_moduleRip.mod prms_basin.mod prms_gwflow.mod prms_flowvars.mod prms_set_time.mod prms_water_use.mod prms_srunoff.mod prms_glacr.mod + $(FC) -c $(FFLAGS) routingRip.f90 + +mizurouteRip.o: mizurouteRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoff.mod prms_gwflow.mod prms_glacr.mod + $(FC) -c $(FFLAGS) $(INCMIZU) mizurouteRip.f90 + +basin_sumCopy.o: basin_sumCopy.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snow.mod prms_srunoff.mod prms_gwflow.mod prms_climatevars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod + $(FC) -c $(FFLAGS) basin_sumCopy.f90 + +muskingum_lakeCopy.o: muskingum_lakeCopy.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoff.mod prms_gwflow.mod prms_soilzone.mod + $(FC) -c $(FFLAGS) muskingum_lakeCopy.f90 + +strmflow_in_outCopy.o: strmflow_in_outCopy.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_routingRip.mod prms_obs.mod prms_srunoff.mod prms_gwflow.mod + $(FC) -c $(FFLAGS) strmflow_in_outCopy.f90 + +stream_tempCopy.o: stream_tempCopy.f90 prms_module.mod prms_basin.mod prms_routingRip.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_soltab.mod prms_climatevars.mod prms_snow.mod + $(FC) -c $(FFLAGS) stream_tempCopy.f90 + +prms_routingRip.mod: routingRip.o +prms_moduleRip.mod: call_modulesRip.o prms_climatevars.mod: climateflow.o prms_flowvars.mod: climateflow.o prms_module.mod: call_modules.o @@ -256,4 +353,4 @@ prms_routing.mod: routing.o prms_water_use.mod: water_use_read.o prms_obs.mod: obs.o prms_set_time.mod: prms_time.o - +prms_glacr.mod: glacr_melt.o From 1221ebe2c255c79e52506937ed8d1fde763438c7 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 22 Jun 2019 12:11:21 -0600 Subject: [PATCH 04/47] git ignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 2fa838c3..c275160a 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ *.mod *.a prms/prms +prms/makelist \ No newline at end of file From 9ec14873806b9a0b68b465b8f40f80dcb4057562 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 22 Jun 2019 12:15:22 -0600 Subject: [PATCH 05/47] makelist --- makelist | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/makelist b/makelist index bc8fa06f..419d166c 100644 --- a/makelist +++ b/makelist @@ -2,8 +2,8 @@ #------------------------------------------------------------------- #------------------------------------------------------------------- -F_MASTER = /Users/amedin/Research/ExtCONUS_AK -CODEDIR = $(F_MASTER)/NHM_glacier +F_MASTER = /Users/amedin/Research/Glaciers/ExtCONUS_AK +CODEDIR = $(F_MASTER)/NHM_glacr MMFDIR = $(CODEDIR)/mmf MIZUDIR = $(CODEDIR)/mizu LIBDIR = $(CODEDIR)/lib From 8224c27174941f7385d5d742d90a50de9a6cd510 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 22 Jun 2019 12:20:21 -0600 Subject: [PATCH 06/47] don't track makelist --- makelist | 75 -------------------------------------------------------- 1 file changed, 75 deletions(-) delete mode 100644 makelist diff --git a/makelist b/makelist deleted file mode 100644 index 419d166c..00000000 --- a/makelist +++ /dev/null @@ -1,75 +0,0 @@ - -#------------------------------------------------------------------- -#------------------------------------------------------------------- - -F_MASTER = /Users/amedin/Research/Glaciers/ExtCONUS_AK -CODEDIR = $(F_MASTER)/NHM_glacr -MMFDIR = $(CODEDIR)/mmf -MIZUDIR = $(CODEDIR)/mizu -LIBDIR = $(CODEDIR)/lib -PRMSDIR = $(CODEDIR)/prms -BINDIR = $(F_MASTER)/bin -MMFLIB = $(LIBDIR)/libmmf.a -MIZULIB = $(LIBDIR)/libmizu.a -MIZULIB2 = $(LIBDIR)/libmizu2.a -INCMIZU = -I$(MIZUDIR)/include - -######################################################### -# Configure tags for each system -########################################################## -ARC = LINUX -#ARC = WINDOWS - -#OPTLEVEL = -g -OPTLEVEL = -O -Bstatic -#for gfortran -LDFLAGS =$(OPTLEVEL) -#for ifort -#LDFLAGS =$(OPTLEVEL) -nofor_main -MFLAGS = -ffree-line-length-none - -########################################################## -# Define the Fortran compile flags -########################################################## -#for gfortran -FFLAGS= $(OPTLEVEL) -fbounds-check -Wall -fno-second-underscore $(MFLAGS) -#FFLAGS= $(OPTLEVEL) -fno-second-underscore -FC = gfortran -#for ifort -#FFLAGS= $(OPTLEVEL) -warn all -fltconsistency -#FFLAGS= $(OPTLEVEL) -fp-model source -#FC = ifort - -########################################################## -# Define the C compile flags -# -D_UF defines UNIX naming conventions for mixed language compilation. -########################################################## -CFLAGS = $(OPTLEVEL) -D$(ARC) -D_UF -Wall -#for gfortran -CC = gcc -#for ifort -#CC = icc - -########################################################## -# Define the libraries -########################################################## -#for gfortran -MATHLIB = -lm -GCLIB = -L/opt/local/lib -lgfortran -lgcc_s.1 -#for ifort -#MATHLIB = -#GCLIB = -FLIBS = $(GCLIB) - -########################################################## -# Unix system commands -########################################################## -RM = rm -f -AR = ar ruv -RANLIB = ranlib -MAKE = make -#LN = ln -s -LN = cp -CD = cd -CP = cp - From 5524a83f5934852c7bfb9da212f5509b187b3b66 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 22 Jun 2019 16:57:30 -0500 Subject: [PATCH 07/47] debugging merge --- Makefile | 4 +++- mizu/Makefile | 2 +- prms/Makefile | 17 +++++++---------- prms/basin.f90 | 2 +- prms/glacr_melt.f90 | 28 +++++++++++----------------- prms/muskingumRip.f90 | 2 -- prms/routing.f90 | 2 +- prms/routingRip.f90 | 9 ++++----- prms/snowcomp.f90 | 17 ++++++++++------- prms/soltab.f90 | 16 ++++++++-------- prms/srunoff.f90 | 39 +++++++++++++++++++++++---------------- prms/water_balance.f90 | 10 +++++----- 12 files changed, 74 insertions(+), 74 deletions(-) mode change 100644 => 100755 Makefile diff --git a/Makefile b/Makefile old mode 100644 new mode 100755 index 706345ca..3d2680ca --- a/Makefile +++ b/Makefile @@ -3,6 +3,9 @@ # # Top-level makefile for the PRMS # +#------------------------------------------------------------------- +# $Id: Makefile +#------------------------------------------------------------------- include ./makelist @@ -32,4 +35,3 @@ clean: cd $(MIZUDIR); $(MAKE) clean; cd $(PRMSDIR); $(MAKE) clean; $(RM) $(BINDIR)/prms*~ - $(RM) $(BINDIR)/prmsrip*~ diff --git a/mizu/Makefile b/mizu/Makefile index 7b75878e..a4ef8d72 100644 --- a/mizu/Makefile +++ b/mizu/Makefile @@ -57,5 +57,5 @@ install: mv *.mod $(MIZUDIR)/include clean: - $(RM) $(MIZULIB) $(MIZUOBJS) *.mod *~ + $(RM) $(MIZULIB) $(MIZUOBJS) $(RM) $(MIZUDIR)/include/*.mod diff --git a/prms/Makefile b/prms/Makefile index e1184f95..3520f99a 100644 --- a/prms/Makefile +++ b/prms/Makefile @@ -1,8 +1,8 @@ # PRMS V makefile include ../makelist -TARGET = $(BINDIR)/prmsg -TARGET2 = $(BINDIR)/prmsgrip +TARGET = $(BINDIR)/prmsgl +TARGET2 = $(BINDIR)/prmsglrip #################################################### # Rules for targets @@ -69,7 +69,7 @@ OBJS = \ nsegment_summary.o \ basin_summary.o \ write_climate_hru.o \ - prms_summary_lauren.o \ + prms_summary.o \ basin_sum.o \ stream_temp.o \ utils_prms.o @@ -125,7 +125,7 @@ RIP = \ nsegment_summary.o \ basin_summary.o \ write_climate_hru.o \ - prms_summary_lauren.o \ + prms_summary.o \ basin_sumCopy.o \ utils_prms.o \ stream_tempCopy.o @@ -143,10 +143,7 @@ $(TARGET2): $(RIP) # clean: - cd $(MMFDIR);make clean; cd - - $(RM) $(TARGET) - $(RM) $(TARGET2) - $(RM) *.o *.mod *~ + $(RM) $(OBJS) $(RIP) *.mod *~ call_modules.o: call_modules.f90 $(FC) -c $(FFLAGS) call_modules.f90 @@ -166,8 +163,8 @@ ddsolrad.o: ddsolrad.f90 prms_module.mod prms_climatevars.mod prms_soltab.mod pr ccsolrad.o: ccsolrad.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_soltab.mod prms_set_time.mod prms_obs.mod $(FC) -c $(FFLAGS) ccsolrad.f90 -prms_summary_lauren.o: prms_summary_lauren.f90 prms_module.mod prms_climatevars.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_intcp.mod prms_snow.mod prms_srunoff.mod prms_soilzone.mod prms_gwflow.mod - $(FC) -c $(FFLAGS) prms_summary_lauren.f90 +prms_summary.o: prms_summary.f90 prms_module.mod prms_climatevars.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_intcp.mod prms_snow.mod prms_srunoff.mod prms_soilzone.mod prms_gwflow.mod + $(FC) -c $(FFLAGS) prms_summary.f90 intcp.o: intcp.f90 prms_obs.mod prms_climatevars.mod prms_flowvars.mod prms_module.mod prms_basin.mod prms_water_use.mod prms_set_time.mod prms_obs.mod $(FC) -c $(FFLAGS) intcp.f90 diff --git a/prms/basin.f90 b/prms/basin.f90 index 99489654..7b1ea21e 100644 --- a/prms/basin.f90 +++ b/prms/basin.f90 @@ -70,7 +70,7 @@ INTEGER FUNCTION basdecl() USE PRMS_BASIN USE PRMS_MODULE, ONLY: Model, Nhru, Dprst_flag, Lake_route_flag, & & Et_flag, Precip_flag, Nlake, Cascadegw_flag, Stream_temp_flag, & - & PRMS4_flag, Cascade_flag, Glacier_flag + & PRMS4_flag, Glacier_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declparam, declvar diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 index 93b13f20..8ffef8ce 100644 --- a/prms/glacr_melt.f90 +++ b/prms/glacr_melt.f90 @@ -182,11 +182,6 @@ INTEGER FUNCTION glacrdecl() & 'Yearly mass balance for each glacier, indexed by Glacr_tag', & & 'inches', Gl_mb_yrcumul)/=0 ) CALL read_error(3, 'gl_mb_yrcumul') - ALLOCATE ( Glmax_mb_yrcumul(Nhru) ) - IF ( declvar(MODNAME, 'glmax_mb_yrcumul', 'nhru', Nhru, 'double', & - & 'Finds max year mass balance for each glacier, indexed by Glacr_tag', & - & 'inches', Glmax_mb_yrcumul)/=0 ) CALL read_error(3, 'glmax_mb_yrcumul') - IF ( declvar(MODNAME, 'basin_gl_area', 'one', 1, 'double', & & 'Basin area-weighted average glacier-covered area', & & 'decimal fraction', Basin_gl_area)/=0 ) CALL read_error(3, 'basin_gl_area') @@ -858,7 +853,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) USE PRMS_MODULE, ONLY: Nhru, Starttime USE PRMS_BASIN, ONLY: Hru_type, Hru_elev_ts, Basin_area_inv, Active_hrus, & & Hru_route_order, NEARZERO, DNEARZERO, Elev_units, FEET2METERS, METERS2FEET, Hru_elev - USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday, Julwater, Modays + USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Julwater USE PRMS_INTCP, ONLY: Net_rain, Net_snow USE PRMS_SNOW, ONLY: Snowcov_area, Snowmelt, Glacrmelt, Glacr_air_deltemp, Glacr_delsnow, & & Snowfld_frac_init, Snowcov_area, Basin_snowicecov, Snow_evap, Glacr_evap, Basin_glacrb_melt @@ -915,8 +910,6 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) Gl_top_melt = 0.0 Gl_ice_melt = 0.0 Glacr_flow = 0.0 - Gmbc_bsicm = 0.D0 - Gmbc_bsicm_sego = 0.0D0 Basin_snowicecov = Basin_snowicecov*Acre_inch2/Basin_area_inv gl_gain = 0.D0 ! @@ -1502,6 +1495,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) in_top_melt_itot(jj) = 0.0D0 tot_reserv(jj) = 0.0D0 tot_reservi(jj) = 0.0D0 + stor = 0.0 IF ( jj==1 ) THEN stor = Stor_firn(Term(o),Nowmonth)/24.0 !days ELSEIF ( jj==2 ) THEN @@ -1734,19 +1728,19 @@ INTEGER FUNCTION recompute_soltab() ! Local Variables INTEGER :: jd, n, nn DOUBLE PRECISION :: obliquity(366) - REAL :: y, y2, y3, jdreal !, dayangle + DOUBLE PRECISION :: y, y2, y3, jddbl !*********************************************************************** recompute_soltab = 0 ! initialize DO jd = 1, 366 - jdreal = FLOAT( jd ) - obliquity(jd) = 1.0 - (ECCENTRICY*COS((jdreal-3.0)*DEGDAYRAD)) - y = SNGL(DEGDAYRAD)*(jdreal-1.0) ! assume noon - y2 = 2.0*y - y3 = 3.0*y - Solar_declination(jd) = 0.006918 - 0.399912*COS(y) + 0.070257*SIN(y) & - & - 0.006758*COS(y2) + 0.000907*SIN(y2) & - & - 0.002697*COS(y3) + 0.00148*SIN(y3) + jddbl = DBLE(jd) + obliquity(jd) = 1.0D0 - (ECCENTRICY*COS((jddbl-3.0D0)*DEGDAYRAD)) + y = DEGDAYRAD*(jddbl-1.0D0) ! assume noon + y2 = 2.0D0*y + y3 = 3.0D0*y + Solar_declination(jd) = 0.006918D0 - 0.399912D0*COS(y) + 0.070257D0*SIN(y) & + & - 0.006758D0*COS(y2) + 0.000907D0*SIN(y2) & + & - 0.002697D0*COS(y3) + 0.00148D0*SIN(y3) ENDDO ! Module Variables DO nn = 1, Active_hrus diff --git a/prms/muskingumRip.f90 b/prms/muskingumRip.f90 index 801656c5..217b27b0 100644 --- a/prms/muskingumRip.f90 +++ b/prms/muskingumRip.f90 @@ -429,8 +429,6 @@ INTEGER FUNCTION muskingum_run() ENDIF ENDDO - ENDDO - area_fac = Cfs_conv/Basin_area_inv Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows Basin_cfs = Flow_out diff --git a/prms/routing.f90 b/prms/routing.f90 index efa04db8..f12006ce 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -637,7 +637,7 @@ END FUNCTION routinginit !*********************************************************************** INTEGER FUNCTION route_run() USE PRMS_ROUTING - USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag + USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag, Glacier_flag USE PRMS_BASIN, ONLY: Hru_area, Hru_route_order, Active_hrus, NEARZERO, FT2_PER_ACRE USE PRMS_CLIMATEVARS, ONLY: Swrad, Potet USE PRMS_SET_TIME, ONLY: Timestep_seconds, Cfs_conv diff --git a/prms/routingRip.f90 b/prms/routingRip.f90 index 561a661b..f6bbd547 100644 --- a/prms/routingRip.f90 +++ b/prms/routingRip.f90 @@ -547,7 +547,7 @@ INTEGER FUNCTION routinginit() & Ripst_flag !, Print_debug USE PRMS_SET_TIME, ONLY: Timestep_seconds USE PRMS_BASIN, ONLY: FT2_PER_ACRE, DNEARZERO, Active_hrus, Hru_route_order, Hru_area_dble, NEARZERO, & - & Hru_area, FEET2METERS !, Active_area + & Hru_area, FEET2METERS, CFS2CMS_CONV !, Active_area USE PRMS_FLOWVARS, ONLY: Seg_outflow IMPLICIT NONE ! Functions @@ -931,7 +931,7 @@ END FUNCTION routinginit !*********************************************************************** INTEGER FUNCTION route_run() USE PRMS_ROUTING - USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag + USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag, Glacier_flag USE PRMS_BASIN, ONLY: Hru_area, Hru_route_order, Active_hrus, NEARZERO, FT2_PER_ACRE USE PRMS_CLIMATEVARS, ONLY: Swrad, Potet USE PRMS_SET_TIME, ONLY: Timestep_seconds, Cfs_conv @@ -1349,6 +1349,8 @@ SUBROUTINE comp_bank_storage(Ihru) xd = 1.0+ bank_wid/2.0 ! at x = 1.0 is stage which already know, calc at middle of bank storage area head=Bankst_head_pts(Ihru) !set at last height for initial ! Calculate heads, seepage, and bank storage using convolution + ripfrac = Ripst_areafr_max(Ihru) + IF (Bankfinite_hru(Ihru)==0) ripfrac = 1.0 DO h = 1, (nbankd-1) head_sum = 0.0 seep_sum = 0.0 @@ -1356,10 +1358,8 @@ SUBROUTINE comp_bank_storage(Ihru) t = t0*delt td = t*a/(str_wid**2.0) !dimensionless IF (Bankfinite_hru(Ihru)==1) then !finite solution if transmissivity high, COMPUTATIONALLY EXPENSIVE, might eliminate - ripfrac = Ripst_areafr_max(Ihru) CALL LTST1(td, xd, tot_wid, bank_wid, head_step, head_step_grad) ELSE IF (Bankfinite_hru(Ihru)==0) then !semi-infinite solution - ripfrac = 1.0 head_step = ERFC( (xd - 1.0)/SQRT((4.0*td)) ) head_step_grad = -( 1.0/SQRT((PI*td)) ) ENDIF @@ -1394,7 +1394,6 @@ SUBROUTINE comp_bank_storage(Ihru) Seg_bankflow(Hru_segment(Ihru)) = Seg_bankflow(Hru_segment(Ihru))-bankv(nbankd)/(24.*60.*60.)/CFS2CMS_CONV !FIX area change?? no I don't think so Basin_bankst_seep = Basin_bankst_seep + Bankst_seep_hru(Ihru)*Hru_area_dble(Ihru) - Basin_bankst_head = Basin_bankst_head + ripfrac*Bankst_head(Ihru)* Hru_area_dble(Ihru) Basin_bankst_vol = Basin_bankst_vol+Bankst_stor_hru(Ihru)*Hru_area_dble(Ihru) diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index a6d7fb66..5702248d 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -50,7 +50,7 @@ MODULE PRMS_SNOW REAL, SAVE, ALLOCATABLE :: Glacr_pk_ice(:), Glacr_freeh2o(:), Glacrcov_area(:), Glacr_tcal(:) REAL, SAVE, ALLOCATABLE :: Glacrb_melt(:), Glacr_pk_def(:), Glacr_pk_temp(:), Glacr_air_avtemp(:) REAL, SAVE, ALLOCATABLE :: Glacr_air_5avtemp1(:), Glacr_air_deltemp(:), Glacr_air_5avtemp(:) - REAL, SAVE, ALLOCATABLE :: Glacr_5avsnow1(:), Glacr_5avsnow(:),Glacr_delsnow(:), + REAL, SAVE, ALLOCATABLE :: Glacr_5avsnow1(:), Glacr_5avsnow(:),Glacr_delsnow(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pkwater_ante(:), Glacr_pkwater_equiv(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pk_depth(:), Glacr_pss(:), Glacr_pst(:) !**************************************************************** @@ -104,7 +104,7 @@ END FUNCTION snowcomp !*********************************************************************** INTEGER FUNCTION snodecl() USE PRMS_SNOW - USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag + USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag, Model IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declparam, declvar @@ -832,6 +832,7 @@ INTEGER FUNCTION snoinit() Glacr_tcal = 0.0 Glacr_pk_den = 0.917 Glacr_pk_temp = 0.0 + Glacr_pk_ice = 0.0 Glacr_pk_def = 0.0 Glacr_pkwater_equiv = 0.0D0 Glacr_evap = 0.0 @@ -853,9 +854,9 @@ INTEGER FUNCTION snoinit() reduce = 1.0 ENDIF Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) + Glacr_pk_ice(i) = reduce*(SNGL(Glacr_pkwater_equiv(i)) - Glacr_freeh2o(i))/0.9340 !density of pure ice ENDIF ENDIF - Glacr_pk_ice(i) = reduce*(SNGL(Glacr_pkwater_equiv(i)) - Glacr_freeh2o(i))/0.9340 !density of pure ice ENDDO Glacr_pkwater_ante = Glacr_pkwater_equiv Glacr_pss = Glacr_pkwater_equiv @@ -1256,6 +1257,7 @@ INTEGER FUNCTION snorun() ! track total heat flux from both night and day periods Tcal(i) = cals ! [cal/cm^2] or [Langleys] + iswn = 0.0 IF ( Active_glacier>=1 ) THEN IF ( Glacrcov_area(i)>0.0 ) THEN iswn = Swrad(i)*(1.0-Glacr_albedo(i))*Rad_trncf(i) ! [cal/cm^2] !want bare ice albedo @@ -1366,7 +1368,7 @@ INTEGER FUNCTION snorun() Pkwater_equiv(i) = 0.0D0 ! just to be sure negative values are ignored ENDIF IF ( Active_glacier>=1 ) THEN - IF ( Glacrcov_area(i)>NEARZERO ) & + IF ( Glacrcov_area(i)>0.0 ) & & CALL snowevap(Potet_sublim(i), Potet(i), Glacrcov_area(i), & & Glacr_evap(i), Glacr_pkwater_equiv(i), Glacr_pk_ice(i), & & Glacr_pk_def(i), Glacr_freeh2o(i), Glacr_pk_temp(i), Hru_intcpevap(i)) @@ -1808,7 +1810,7 @@ SUBROUTINE caloss(Cal, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) Pkwater_equiv = 0.0D0 ! Snowpack or glacr layer has been completely depleted, reset all states to no-snowpack values ! If melting glacier can still be snow, Ihru_gl >0 signifies glacier caloss - If (Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl) + If (Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl) ENDIF END SUBROUTINE caloss @@ -1825,7 +1827,8 @@ SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO IMPLICIT NONE ! Arguments - INTEGER, INTENT(IN) :: Iasw, Ihru_gl + INTEGER, INTENT(INOUT) :: Iasw + INTEGER, INTENT(IN) :: Ihru_gl REAL, INTENT(IN) :: Cal, Freeh2o_cap, Snowcov_area REAL, INTENT(INOUT) :: Freeh2o DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv @@ -2501,7 +2504,7 @@ SUBROUTINE snowevap(Potet_sublim, Potet, Snowcov_area, Snow_evap, & REAL, INTENT(IN) :: Potet_sublim, Potet, Snowcov_area, Hru_intcpevap REAL, INTENT(INOUT) :: Pk_ice, Pk_def, Pk_temp DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv - REAL, INTENT(OUT) :: Snow_evap + REAL, INTENT(OUT) :: Snow_evap, Freeh2o ! Local Variables REAL :: avail_et, cal, ez !*********************************************************************** diff --git a/prms/soltab.f90 b/prms/soltab.f90 index 7165eb95..be663ba8 100644 --- a/prms/soltab.f90 +++ b/prms/soltab.f90 @@ -19,6 +19,14 @@ MODULE PRMS_SOLTAB ! TWOPI ~ 6.2831853071786 ! RADIANS ~ 0.017453292519943 ! PI_12 ~ 3.8197186342055 + DOUBLE PRECISION, PARAMETER :: ECCENTRICY = 0.01671D0 + DOUBLE PRECISION, PARAMETER :: DAYSYR = 365.242D0 + ! 0.016723401 daily change -1.115E-09, eccen = 0.016723401 + (julhour-julhour(1966,1,0,18))+dmin/60)/24*-1.115E-09 + ! julday(1966,1,0.75 UT) = 2439126.25 + ! eccen = 0.01675104-0.00004180*T-0.000000126*T^2 T is julian centuries (days time from epoch, is GMT from Jan 0.0 + DOUBLE PRECISION, PARAMETER :: DEGDAY = 360.0D0/DAYSYR + DOUBLE PRECISION, PARAMETER :: DEGDAYRAD = DEGDAY*RADIANS ! about 0.00143356672 +! DEGDAY = 360 degrees/days in year CHARACTER(LEN=6), SAVE :: MODNAME DOUBLE PRECISION, SAVE :: Solar_declination(366), Soltab_basinpotsw(366) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_cossl(:), Soltab_sunhrs(:, :) @@ -120,14 +128,6 @@ INTEGER FUNCTION sthinit() DOUBLE PRECISION :: basin_cossl DOUBLE PRECISION :: basin_sunhrs(366), obliquity(366) DOUBLE PRECISION :: y, y2, y3, jddbl - DOUBLE PRECISION, PARAMETER :: ECCENTRICY = 0.01671D0 - DOUBLE PRECISION, PARAMETER :: DAYSYR = 365.242D0 - ! 0.016723401 daily change -1.115E-09, eccen = 0.016723401 + (julhour-julhour(1966,1,0,18))+dmin/60)/24*-1.115E-09 - ! julday(1966,1,0.75 UT) = 2439126.25 - ! eccen = 0.01675104-0.00004180*T-0.000000126*T^2 T is julian centuries (days time from epoch, is GMT from Jan 0.0 - DOUBLE PRECISION, PARAMETER :: DEGDAY = 360.0D0/DAYSYR - DOUBLE PRECISION, PARAMETER :: DEGDAYRAD = DEGDAY*RADIANS ! about 0.00143356672 -! DEGDAY = 360 degrees/days in year !*********************************************************************** sthinit = 0 diff --git a/prms/srunoff.f90 b/prms/srunoff.f90 index d3167a1b..111aeb85 100644 --- a/prms/srunoff.f90 +++ b/prms/srunoff.f90 @@ -92,7 +92,8 @@ END FUNCTION srunoff INTEGER FUNCTION srunoffdecl() USE PRMS_SRUNOFF USE PRMS_MODULE, ONLY: Model, Dprst_flag, Nhru, Nsegment, Print_debug, & - & Cascade_flag, Sroff_flag, Nlake, Init_vars_from_file, Call_cascade, PRMS4_flag + & Cascade_flag, Sroff_flag, Nlake, Init_vars_from_file, Call_cascade, PRMS4_flag, & + & Frozen_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declvar, declparam @@ -477,7 +478,7 @@ INTEGER FUNCTION srunoffinit() USE PRMS_SRUNOFF USE PRMS_MODULE, ONLY: Dprst_flag, Nhru, Nlake, Cascade_flag, Sroff_flag, & & Init_vars_from_file, Call_cascade, Water_use_flag, & - & Frozen_flag, Glacier_flag !, Parameter_check_flag + & Frozen_flag!, Parameter_check_flag USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order ! USE PRMS_FLOWVARS, ONLY: Soil_moist_max IMPLICIT NONE @@ -526,6 +527,11 @@ INTEGER FUNCTION srunoffinit() Basin_contrib_fraction = 0.0D0 Srp = 0.0 Sri = 0.0 + IF ( Frozen_flag==1 ) THEN + Frozen = 0 + Cfgi = 0.0 + Cfgi_prev = 0.0 + ENDIF ENDIF IF ( getparam(MODNAME, 'carea_max', Nhru, 'real', Carea_max)/=0 ) CALL read_error(2, 'carea_max') @@ -600,7 +606,7 @@ INTEGER FUNCTION srunoffrun() & Hru_perv, Hru_imperv, Hru_percent_imperv, Hru_frac_perv, & & Dprst_area_max, Hru_area, Hru_type, Basin_area_inv, & & Dprst_area_clos_max, Dprst_area_open_max, Hru_area_dble - USE PRMS_CLIMATEVARS, ONLY: Potet + USE PRMS_CLIMATEVARS, ONLY: Potet, Tavgc USE PRMS_FLOWVARS, ONLY: Sroff, Infil, Imperv_stor, Pkwater_equiv, Dprst_vol_open, Dprst_vol_clos, & & Imperv_stor_max, Snowinfil_max, Glacier_frac USE PRMS_CASCADE, ONLY: Ncascade_hru @@ -612,8 +618,8 @@ INTEGER FUNCTION srunoffrun() ! Local Variables INTEGER :: i, k, dprst_chk, frzen, active_glacier REAL :: srunoff, avail_et, hperv, sra, availh2o - DOUBLE PRECISION :: hru_sroff_down, runoff, apply_sroff - REAL :: cfgi_sroff, cfgi_k, depth_cm + DOUBLE PRECISION :: hru_sroff_down, runoff, apply_sroff, cfgi_sroff + REAL :: cfgi_k, depth_cm REAL :: glcrmltb, temp, temp2 ! Ashley glaciers !*********************************************************************** srunoffrun = 0 @@ -709,7 +715,7 @@ INTEGER FUNCTION srunoffrun() ELSE cfgi_k = 0.08 ENDIF - depth_cm = Pk_depth(i)*2.54 + depth_cm = SNGL(Pk_depth(i))*2.54 Cfgi(i) = (Cfgi_decay*Cfgi_prev(i)) - (Tavgc(i)*(2.71828**(-0.4*cfgi_k*depth_cm))) IF ( active_glacier==1 ) THEN Cfgi(i) = 0.0 !if glacier over, want ground completely unfrozen, or below threshold, infiltration @@ -736,16 +742,17 @@ INTEGER FUNCTION srunoffrun() IF ( frzen==0 ) THEN ! DO IRRIGATION APPLICATION, ONLY DONE HERE, ASSUMES NO SNOW and ! only for pervious areas (just like infiltration) - IF ( Use_sroff_transfer==1 ) THEN - IF ( Net_apply(i)>0.0 ) THEN - sra = 0.0 - Infil(i) = Infil(i) + Net_apply(i) - IF ( Hru_type(i)==1 ) THEN - CALL perv_comp(Net_apply(i), Net_apply(i), Infil(i), sra) + IF ( Use_sroff_transfer==1 ) THEN + IF ( Net_apply(i)>0.0 ) THEN + sra = 0.0 + Infil(i) = Infil(i) + Net_apply(i) + IF ( Hru_type(i)==1 ) THEN + CALL perv_comp(Net_apply(i), Net_apply(i), Infil(i), sra) ! ** ADD in water from irrigation application and water-use transfer for pervious portion - sra (if any) - apply_sroff = DBLE( sra*hperv ) - Basin_apply_sroff = Basin_apply_sroff + apply_sroff - runoff = runoff + apply_sroff + apply_sroff = DBLE( sra*hperv ) + Basin_apply_sroff = Basin_apply_sroff + apply_sroff + runoff = runoff + apply_sroff + ENDIF ENDIF ENDIF @@ -1508,7 +1515,7 @@ END SUBROUTINE dprst_comp !*********************************************************************** SUBROUTINE srunoff_restart(In_out) USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Dprst_flag, & - & Frozen_flag, Glacier_flag + & Frozen_flag USE PRMS_SRUNOFF IMPLICIT NONE ! Argument diff --git a/prms/water_balance.f90 b/prms/water_balance.f90 index 64e482ff..eff82de9 100644 --- a/prms/water_balance.f90 +++ b/prms/water_balance.f90 @@ -170,8 +170,8 @@ SUBROUTINE water_balance_run() & Dprst_stor_hru, Basin_sroffp, Basin_sroffi, Basin_dprst_sroff, Basin_sroff_down, & & Basin_hortonian_lakes, Basin_imperv_evap, Basin_imperv_stor, & & Basin_dprst_evap, Basin_dprst_seep, Basin_sroff, Hru_impervevap, Dprst_seep_hru, & - & Dprst_evap_hru, Dprst_sroff_hru, Dprst_insroff_hru, Basin_glacr_melt, & - & Sro_to_dprst_perv, Dprst_area_clos, Hortonian_flow, Dprst_in, Hru_sroffp, Hru_sroffi, Imperv_stor_ante, & + & Dprst_evap_hru, Dprst_sroff_hru, Dprst_insroff_hru, Sro_to_dprst_perv, & + & Dprst_area_clos, Hortonian_flow, Dprst_in, Hru_sroffp, Hru_sroffi, Imperv_stor_ante, & & Dprst_stor_ante, Use_sroff_transfer, Basin_cfgi_sroff USE PRMS_SOILZONE, ONLY: Swale_actet, Dunnian_flow, Basin_sz2gw, & & Perv_actet, Cap_infil_tot, Pref_flow_infil, Cap_waterin, Upslope_interflow, & @@ -441,19 +441,19 @@ SUBROUTINE water_balance_run() & Basin_snowmelt, Basin_snowevap, Basin_snowcov ! srunoff - brobal = Basin_sroff - Basin_sroffp - Basin_sroffi - Basin_dprst_sroff - Basin_cfgi_sroff - Basin_glacr_melt + brobal = Basin_sroff - Basin_sroffp - Basin_sroffi - Basin_dprst_sroff - Basin_cfgi_sroff IF ( Cascade_flag>0 ) THEN brobal = brobal + Basin_sroff_down WRITE ( SROUNIT, 9002 ) Nowyear, Nowmonth, Nowday, basin_robal, & & brobal, Basin_sroff, Basin_infil, Basin_imperv_evap, & & Basin_imperv_stor, Basin_dprst_evap, Basin_dprst_seep, & & Basin_sroffp, Basin_sroffi, Basin_dprst_sroff, & - & Basin_sroff_down, Basin_hortonian_lakes, Basin_cfgi_sroff, Basin_glacr_melt + & Basin_sroff_down, Basin_hortonian_lakes, Basin_cfgi_sroff ELSE WRITE ( SROUNIT, 9002 ) Nowyear, Nowmonth, Nowday, basin_robal, & & brobal, Basin_sroff, Basin_infil, Basin_imperv_evap, & & Basin_imperv_stor, Basin_dprst_evap, Basin_dprst_seep, & - & Basin_sroffp, Basin_sroffi, Basin_dprst_sroff, Basin_cfgi_sroff, Basin_glacr_melt + & Basin_sroffp, Basin_sroffi, Basin_dprst_sroff, Basin_cfgi_sroff ENDIF IF ( DABS(basin_robal)>DSMALL ) THEN WRITE ( BALUNT, 9003 ) 'possible srunoff basin water balance ERROR', & From 84b1a0fd6769f6a7b16501f19e3efda128b5dde0 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 22 Jun 2019 17:12:44 -0500 Subject: [PATCH 08/47] makelist back in --- makelist | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++ prms/Makefile | 4 +-- 2 files changed, 75 insertions(+), 2 deletions(-) create mode 100644 makelist diff --git a/makelist b/makelist new file mode 100644 index 00000000..22c15e9f --- /dev/null +++ b/makelist @@ -0,0 +1,73 @@ + +#------------------------------------------------------------------- +#------------------------------------------------------------------- + +F_MASTER = /Users/amedin/Research/NHM_dev +MMFDIR = $(F_MASTER)/mmf +MIZUDIR = $(F_MASTER)/mizu +LIBDIR = $(F_MASTER)/lib +PRMSDIR = $(F_MASTER)/prms +BINDIR = $(F_MASTER)/bin +MMFLIB = $(LIBDIR)/libmmf.a +MIZULIB = $(LIBDIR)/libmizu.a +INCMIZU = -I$(MIZUDIR)/include + +######################################################### +# Configure tags for each system +########################################################## +ARC = UNIX +#ARC = LINUX +#ARC = WINDOWS + +#OPTLEVEL = -g +OPTLEVEL = -O -Bstatic +#for gfortran +LDFLAGS =$(OPTLEVEL) +#for ifort +#LDFLAGS =$(OPTLEVEL) -nofor_main +MFLAGS = -ffree-line-length-none + +########################################################## +# Define the Fortran compile flags +########################################################## +#for gfortran +FFLAGS= $(OPTLEVEL) -fbounds-check -Wall -fno-second-underscore $(MFLAGS) +#FFLAGS= $(OPTLEVEL) -fno-second-underscore +FC = gfortran +#for ifort +#FFLAGS= $(OPTLEVEL) -warn all -fltconsistency +#FFLAGS= $(OPTLEVEL) -fp-model source +#FC = ifort + +########################################################## +# Define the C compile flags +# -D_UF defines UNIX naming conventions for mixed language compilation. +########################################################## +CFLAGS = $(OPTLEVEL) -D$(ARC) -D_UF +#for gfortran +CC = gcc +#for ifort +#CC = icc + +########################################################## +# Define the libraries +########################################################## +#for gfortran +MATHLIB = -lm +GCLIB = -L/opt/local/lib -lgfortran -lgcc_s.1 +#for ifort +#GCLIB = -lgfortran -lgcc $(MATHLIB) +FLIBS = $(GCLIB) + +########################################################## +# Unix system commands +########################################################## +RM = rm -f +AR = ar ruv +RANLIB = ranlib +MAKE = make +#LN = ln -s +LN = cp +CD = cd +CP = cp + diff --git a/prms/Makefile b/prms/Makefile index 3520f99a..8764e00e 100644 --- a/prms/Makefile +++ b/prms/Makefile @@ -1,8 +1,8 @@ # PRMS V makefile include ../makelist -TARGET = $(BINDIR)/prmsgl -TARGET2 = $(BINDIR)/prmsglrip +TARGET = $(BINDIR)/prms +TARGET2 = $(BINDIR)/prmsrip #################################################### # Rules for targets From 995c6114547d1eae341ef66dde02fdb4aa7068c1 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 22 Jun 2019 17:13:54 -0500 Subject: [PATCH 09/47] fix .gitignore --- .gitignore | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index c275160a..73c5abf2 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,4 @@ *.o *.mod *.a -prms/prms -prms/makelist \ No newline at end of file +prms/prms \ No newline at end of file From e55b0a434d15b3038f95d4645625bb348c73a5e4 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 22 Jun 2019 18:08:41 -0500 Subject: [PATCH 10/47] fixed makefile --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 3d2680ca..b2e5c039 100755 --- a/Makefile +++ b/Makefile @@ -13,9 +13,9 @@ include ./makelist # Standard Targets for Users # -all: prms +all: prmsglrip -prms: +prmsglrip: # Create lib directory, if necessary @if [ ! -d $(MMFDIR) ] ; then \ mkdir $(MMFDIR) ; \ From 57a9f9c2abcd51b9900a351cbe327005a2525dba Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Mon, 24 Jun 2019 10:06:49 -0500 Subject: [PATCH 11/47] getting rid of some bugs --- prms/Makefile | 2 +- prms/climate_hru.f90 | 2 +- prms/snowcomp.f90 | 40 +++++++++++++++++++++------------------- 3 files changed, 23 insertions(+), 21 deletions(-) diff --git a/prms/Makefile b/prms/Makefile index 8764e00e..f71670de 100644 --- a/prms/Makefile +++ b/prms/Makefile @@ -47,7 +47,7 @@ OBJS = \ transp_frost.o \ transp_tindex.o \ frost_date.o \ - glacr_melt.o \ + glacr_melt.o \ intcp.o \ snowcomp.o \ srunoff.o \ diff --git a/prms/climate_hru.f90 b/prms/climate_hru.f90 index 26ff41d1..08dddca5 100644 --- a/prms/climate_hru.f90 +++ b/prms/climate_hru.f90 @@ -469,7 +469,7 @@ SUBROUTINE read_cbh_date(Year, Month, Day, Var, Ios, Iret) right_day = 1 IF ( Year/=Nowyear .OR. Month/=Nowmonth .OR. Day/=Nowday ) right_day = 0 IF ( Ios/=0 .OR. right_day==0 ) THEN - PRINT *, 'ERROR, reading CBH File, variable: ', Var, ' IOSTAT=', Ios + PRINT *, 'ERROR, reading CBH File, variable: ', Var, ' IOSTAT=', Ios IF ( Ios==-1 ) THEN PRINT *, ' End-of-File found' ELSEIF ( right_day==0 ) THEN diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index 5702248d..7abd6cfa 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -992,29 +992,31 @@ INTEGER FUNCTION snorun() ENDIF ENDIF IF ( Active_glacier==2 ) Glacr_albedo(i) = Albedo_ice(i) !glacr_albedo doesn't change if snow field but could get zeroed out - IF ( Nowyear >= Starttime(1)+10 .AND. MOD(Nowyear-Starttime(1),5)==0 ) THEN - Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 10 years of data - Glacr_delsnow(i) = 10.0*(Glacr_5avsnow1(i) - Glacr_5avsnow(i))/Glacr_5avsnow1(i) !number of 10 percent (*100.0/10.0) changes - ENDIF - !keep before restart - IF ( MOD(Nowyear-Starttime(1),5)==0 ) THEN - IF ( Nowyear-Starttime(1)==5 ) THEN - Glacr_air_5avtemp1(i) = Glacr_air_5avtemp(i) - Glacr_5avsnow1(i) = Glacr_5avsnow(i) + IF ( isglacier==1 ) THEN + IF (Nowyear >= Starttime(1)+10 .AND. MOD(Nowyear-Starttime(1),5)==0 ) THEN + Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 10 years of data + Glacr_delsnow(i) = 10.0*(Glacr_5avsnow1(i) - Glacr_5avsnow(i))/Glacr_5avsnow1(i) !number of 10 percent (*100.0/10.0) changes ENDIF - Glacr_air_5avtemp(i) = 0.0 !zero out for new year restart - Glacr_5avsnow(i) = 0.0 !zero out for new year restart - ENDIF - Glacr_air_avtemp(i) = 0.0 !zero out for new year restart - ENDIF !end start of year calculations + !keep before restart + IF ( MOD(Nowyear-Starttime(1),5)==0 ) THEN + IF ( Nowyear-Starttime(1)==5 ) THEN + Glacr_air_5avtemp1(i) = Glacr_air_5avtemp(i) + Glacr_5avsnow1(i) = Glacr_5avsnow(i) + ENDIF + Glacr_air_5avtemp(i) = 0.0 !zero out for new year restart + Glacr_5avsnow(i) = 0.0 !zero out for new year restart + ENDIF + Glacr_air_avtemp(i) = 0.0 !zero out for new year restart + ENDIF !end start of year calculations + ENDIF ! Do for summer - IF ( isglacier==1 .AND. Julwater>151 .AND. Julwater<244) THEN ! Now following McGrath et al 2017, temp June-August, 92 days - Yrdays5 = Yrdays5 + 1 - Glacr_air_5avtemp(i) = ( Glacr_air_5avtemp(i)*(Yrdays5-1)+ (Tminc(i)+Tavgc(i))*0.5 )/Yrdays5 - ENDIF + IF ( isglacier==1 ) THEN + IF (Julwater>151 .AND. Julwater<244) THEN ! Now following McGrath et al 2017, temp June-August, 92 days + Yrdays5 = Yrdays5 + 1 + Glacr_air_5avtemp(i) = ( Glacr_air_5avtemp(i)*(Yrdays5-1)+ (Tminc(i)+Tavgc(i))*0.5 )/Yrdays5 + ENDIF ! Do for every time step - IF ( isglacier==1) THEN Glacr_air_avtemp(i) = ( Glacr_air_avtemp(i)*(Julwater-1)+ (Tminc(i)+Tavgc(i))*0.5 )/Julwater Glacr_5avsnow(i) = Glacr_5avsnow(i) + Net_snow(i)/5.0 ENDIF From 16d8499aa28756aa96e98ef5ebdfb6019175e91e Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Mon, 24 Jun 2019 15:45:24 -0500 Subject: [PATCH 12/47] routing bug fixes in merge --- prms/muskingum.f90 | 10 ++++------ prms/muskingumRip.f90 | 10 ++++------ prms/muskingum_lake.f90 | 20 -------------------- prms/muskingum_lakeCopy.f90 | 20 -------------------- prms/routing.f90 | 9 ++++++--- prms/routingRip.f90 | 9 ++++++--- prms/srunoff.f90 | 5 +---- 7 files changed, 21 insertions(+), 62 deletions(-) diff --git a/prms/muskingum.f90 b/prms/muskingum.f90 index 37488c16..48110cc5 100644 --- a/prms/muskingum.f90 +++ b/prms/muskingum.f90 @@ -150,7 +150,7 @@ END FUNCTION muskingum_decl !*********************************************************************** INTEGER FUNCTION muskingum_init() USE PRMS_MUSKINGUM - USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file + USE PRMS_MODULE, ONLY: Nsegment USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv USE PRMS_FLOWVARS, ONLY: Seg_outflow USE PRMS_SET_TIME, ONLY: Cfs_conv @@ -164,8 +164,7 @@ INTEGER FUNCTION muskingum_init() !*********************************************************************** muskingum_init = 0 - IF ( Init_vars_from_file==0 ) Outflow_ts = 0.0D0 - + !Seg_outflow will have been initialized to Segment_flow_init in PRMS_ROUTING Basin_segment_storage = 0.0D0 DO i = 1, Nsegment Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) @@ -240,10 +239,10 @@ INTEGER FUNCTION muskingum_run() ! current inflow to the segment is the time weighted average of the outflow ! of the upstream segments plus the lateral HRU inflow plus any gains. - currin = 0.0D0 !Seg_lateral_inflow(iorder) route this to outlet to be like mizuroute + currin = Seg_lateral_inflow(iorder) !note, this routes to inlet and mizuroute routes to outlet IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) currin = currin + Seg_upstream_inflow(iorder) - Seg_inflow(iorder) = Seg_inflow(iorder) + currin + Seg_lateral_inflow(iorder) + Seg_inflow(iorder) = Seg_inflow(iorder) + currin Inflow_ts(iorder) = Inflow_ts(iorder) + currin Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder) @@ -262,7 +261,6 @@ INTEGER FUNCTION muskingum_run() ! Outflow_ts is the value from last hour Outflow_ts(iorder) = Inflow_ts(iorder) ENDIF - Outflow_ts(iorder) = Outflow_ts(iorder)+Seg_lateral_inflow(iorder) !add it here instead to be like mizuroute ! pastin is equal to the Inflow_ts on the previous routed timestep Pastin(iorder) = Inflow_ts(iorder) diff --git a/prms/muskingumRip.f90 b/prms/muskingumRip.f90 index 217b27b0..61035381 100644 --- a/prms/muskingumRip.f90 +++ b/prms/muskingumRip.f90 @@ -150,7 +150,7 @@ END FUNCTION muskingum_decl !*********************************************************************** INTEGER FUNCTION muskingum_init() USE PRMS_MUSKINGUM - USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file + USE PRMS_MODULE, ONLY: Nsegment USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv USE PRMS_FLOWVARS, ONLY: Seg_outflow USE PRMS_SET_TIME, ONLY: Cfs_conv @@ -164,8 +164,7 @@ INTEGER FUNCTION muskingum_init() !*********************************************************************** muskingum_init = 0 - IF ( Init_vars_from_file==0 ) Outflow_ts = 0.0D0 - + !Seg_outflow will have been initialized to Segment_flow_init in PRMS_ROUTING Basin_segment_storage = 0.0D0 DO i = 1, Nsegment Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) @@ -248,10 +247,10 @@ INTEGER FUNCTION muskingum_run() ! current inflow to the segment is the time weighted average of the outflow ! of the upstream segments plus the lateral HRU inflow plus any gains. - currin = 0.0D0 !Seg_lateral_inflow(iorder) route this to outlet to be like mizuroute + currin = Seg_lateral_inflow(iorder) !note, this routes to inlet and mizuroute routes to outlet IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) currin = currin + Seg_upstream_inflow(iorder) - Seg_inflow(iorder) = Seg_inflow(iorder) + currin + Seg_lateral_inflow(iorder) + Seg_inflow(iorder) = Seg_inflow(iorder) + currin Inflow_ts(iorder) = Inflow_ts(iorder) + currin Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder) @@ -270,7 +269,6 @@ INTEGER FUNCTION muskingum_run() ! Outflow_ts is the value from last hour Outflow_ts(iorder) = Inflow_ts(iorder) ENDIF - Outflow_ts(iorder) = Outflow_ts(iorder)+Seg_lateral_inflow(iorder) !add it here instead to be like mizuroute ! pastin is equal to the Inflow_ts on the previous routed timestep Pastin(iorder) = Inflow_ts(iorder) diff --git a/prms/muskingum_lake.f90 b/prms/muskingum_lake.f90 index 119ce789..2737b6a1 100644 --- a/prms/muskingum_lake.f90 +++ b/prms/muskingum_lake.f90 @@ -110,7 +110,6 @@ MODULE PRMS_MUSKINGUM_LAKE DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_precip(:), Lake_sroff(:), Lake_interflow(:), Lake_outvol_ts(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_seep_in(:), Lake_evap(:), Lake_2gw(:), Lake_outq2(:) ! Declared Parameters - REAL, SAVE, ALLOCATABLE :: Segment_flow_init(:) ! lake_segment_id only required if cascades are active, otherwise use hru_segment INTEGER, SAVE, ALLOCATABLE :: Obsout_lake(:), Lake_out2(:), Nsos(:), Ratetbl_lake(:), Lake_segment_id(:) REAL, SAVE, ALLOCATABLE :: Lake_qro(:), Lake_coef(:), Elev_outflow(:), Weir_coef(:), Weir_len(:) @@ -287,15 +286,6 @@ INTEGER FUNCTION muskingum_lake_decl() ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) ) ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) ) - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - ALLOCATE ( Segment_flow_init(Nsegment) ) - IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Initial flow in each stream segment', & - & 'Initial flow in each stream segment', & - & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') - ENDIF - ! Lake declared variables ALLOCATE ( Lake_inflow(Nlake) ) IF ( declvar(MODNAME, 'lake_inflow', 'nlake', Nlake, 'double', & @@ -641,16 +631,6 @@ INTEGER FUNCTION muskingum_lake_init() !*********************************************************************** muskingum_lake_init = 0 - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - IF ( getparam(MODNAME, 'segment_flow_init', Nsegment, 'real', Segment_flow_init)/=0 ) & - & CALL read_error(2,'segment_flow_init') - DO i = 1, Nsegment - Seg_outflow(i) = Segment_flow_init(i) - ENDDO - DEALLOCATE ( Segment_flow_init ) - ENDIF - IF ( Init_vars_from_file==0 ) Outflow_ts = 0.0D0 - Basin_segment_storage = 0.0D0 DO i = 1, Nsegment Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) diff --git a/prms/muskingum_lakeCopy.f90 b/prms/muskingum_lakeCopy.f90 index 119ce789..2737b6a1 100644 --- a/prms/muskingum_lakeCopy.f90 +++ b/prms/muskingum_lakeCopy.f90 @@ -110,7 +110,6 @@ MODULE PRMS_MUSKINGUM_LAKE DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_precip(:), Lake_sroff(:), Lake_interflow(:), Lake_outvol_ts(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_seep_in(:), Lake_evap(:), Lake_2gw(:), Lake_outq2(:) ! Declared Parameters - REAL, SAVE, ALLOCATABLE :: Segment_flow_init(:) ! lake_segment_id only required if cascades are active, otherwise use hru_segment INTEGER, SAVE, ALLOCATABLE :: Obsout_lake(:), Lake_out2(:), Nsos(:), Ratetbl_lake(:), Lake_segment_id(:) REAL, SAVE, ALLOCATABLE :: Lake_qro(:), Lake_coef(:), Elev_outflow(:), Weir_coef(:), Weir_len(:) @@ -287,15 +286,6 @@ INTEGER FUNCTION muskingum_lake_decl() ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) ) ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) ) - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - ALLOCATE ( Segment_flow_init(Nsegment) ) - IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Initial flow in each stream segment', & - & 'Initial flow in each stream segment', & - & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') - ENDIF - ! Lake declared variables ALLOCATE ( Lake_inflow(Nlake) ) IF ( declvar(MODNAME, 'lake_inflow', 'nlake', Nlake, 'double', & @@ -641,16 +631,6 @@ INTEGER FUNCTION muskingum_lake_init() !*********************************************************************** muskingum_lake_init = 0 - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - IF ( getparam(MODNAME, 'segment_flow_init', Nsegment, 'real', Segment_flow_init)/=0 ) & - & CALL read_error(2,'segment_flow_init') - DO i = 1, Nsegment - Seg_outflow(i) = Segment_flow_init(i) - ENDDO - DEALLOCATE ( Segment_flow_init ) - ENDIF - IF ( Init_vars_from_file==0 ) Outflow_ts = 0.0D0 - Basin_segment_storage = 0.0D0 DO i = 1, Nsegment Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) diff --git a/prms/routing.f90 b/prms/routing.f90 index f12006ce..db3a7db2 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -388,6 +388,10 @@ INTEGER FUNCTION routinginit() ALLOCATE ( C1(Nsegment), C2(Nsegment), C0(Nsegment), Ts(Nsegment), Ts_i(Nsegment) ) ENDIF + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 ) THEN + IF ( getparam(MODNAME, 'K_coef', Nsegment, 'real', K_coef)/=0 ) CALL read_error(2, 'K_coef') + ENDIF + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN IF ( getparam(MODNAME, 'segment_flow_init', Nsegment, 'real', Segment_flow_init)/=0 ) & & CALL read_error(2,'segment_flow_init') @@ -458,7 +462,6 @@ INTEGER FUNCTION routinginit() ! Begin the loops for ordering segments ALLOCATE ( x_off(Nsegment) ) x_off = 0 - k_coef = 1 Segment_order = 0 lval = 0 iseg = 0 @@ -469,7 +472,7 @@ INTEGER FUNCTION routinginit() ! If segment "i" has not been crossed out consider it, else continue IF ( x_off(i)==1 ) CYCLE iseg = i - ! Test to see if segment "i" is the to segment from other segments + ! Test to see if segment "i" is the tosegment from other segments test = 1 DO j = 1, Nsegment IF ( Tosegment(j)==i ) THEN @@ -628,7 +631,7 @@ INTEGER FUNCTION routinginit() ENDDO IF ( ierr==1 ) PRINT '(/,A,/)', '***Recommend that the Muskingum parameters be adjusted in the Parameter File' - DEALLOCATE ( k_coef, X_coef) + DEALLOCATE ( K_coef, X_coef) END FUNCTION routinginit diff --git a/prms/routingRip.f90 b/prms/routingRip.f90 index f6bbd547..42eb3b2a 100644 --- a/prms/routingRip.f90 +++ b/prms/routingRip.f90 @@ -620,6 +620,10 @@ INTEGER FUNCTION routinginit() ALLOCATE ( C1(Nsegment), C2(Nsegment), C0(Nsegment), Ts(Nsegment), Ts_i(Nsegment) ) ENDIF + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 ) THEN + IF ( getparam(MODNAME, 'K_coef', Nsegment, 'real', K_coef)/=0 ) CALL read_error(2, 'K_coef') + ENDIF + ! Riparian storage variables IF ( Ripst_flag==1 ) THEN Basin_bankst_seep = 0.D0 @@ -752,7 +756,6 @@ INTEGER FUNCTION routinginit() ! Begin the loops for ordering segments ALLOCATE ( x_off(Nsegment) ) x_off = 0 - k_coef = 1 Segment_order = 0 lval = 0 iseg = 0 @@ -763,7 +766,7 @@ INTEGER FUNCTION routinginit() ! If segment "i" has not been crossed out consider it, else continue IF ( x_off(i)==1 ) CYCLE iseg = i - ! Test to see if segment "i" is the to segment from other segments + ! Test to see if segment "i" is the tosegment from other segments test = 1 DO j = 1, Nsegment IF ( Tosegment(j)==i ) THEN @@ -922,7 +925,7 @@ INTEGER FUNCTION routinginit() ENDDO IF ( ierr==1 ) PRINT '(/,A,/)', '***Recommend that the Muskingum parameters be adjusted in the Parameter File' - DEALLOCATE ( k_coef, X_coef) + DEALLOCATE ( K_coef, X_coef) END FUNCTION routinginit diff --git a/prms/srunoff.f90 b/prms/srunoff.f90 index 111aeb85..342d477c 100644 --- a/prms/srunoff.f90 +++ b/prms/srunoff.f90 @@ -756,6 +756,7 @@ INTEGER FUNCTION srunoffrun() ENDIF ENDIF + availh2o = Intcp_changeover(i) + Net_rain(i) IF ( Isglacier==1 ) THEN ! Ashley glacier temp = Snowmelt(i) + glcrmltb !Snowmelt or 0.0 temp2 = availh2o*(1.0-Glacier_frac(i)) @@ -768,10 +769,6 @@ INTEGER FUNCTION srunoffrun() ENDIF - availh2o = Intcp_changeover(i) + Net_rain(i) - CALL compute_infil(availh2o, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), Snowmelt(i), & - & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i)) - IF ( Dprst_flag==1 ) THEN Dprst_in(i) = 0.0D0 dprst_chk = 0 From 371e5940eaf4e79bec66f32687614321f52fdf85 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Mon, 24 Jun 2019 16:14:43 -0500 Subject: [PATCH 13/47] fixed merged riparian bugs --- prms/routing.f90 | 24 +++++++++++++----------- prms/routingRip.f90 | 28 +++++++++++++++------------- 2 files changed, 28 insertions(+), 24 deletions(-) diff --git a/prms/routing.f90 b/prms/routing.f90 index db3a7db2..1e961524 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -135,13 +135,6 @@ INTEGER FUNCTION routingdecl() & 'Mannings roughness coefficient for each segment', & & 'dimensionless')/=0 ) CALL read_error(1, 'mann_n') - ALLOCATE ( Seg_width(Nsegment) ) - IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & - & '15.0', '0.18', '40000.0', & - & 'Segment river width', & - & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & - & 'meters')/=0 ) CALL read_error(1, 'seg_width') - ALLOCATE ( Seg_slope(Nsegment) ) IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & & '0.0001', '0.0000001', '2.0', & @@ -157,6 +150,15 @@ INTEGER FUNCTION routingdecl() & 'meters')/=0 ) CALL read_error(1, 'seg_length') ENDIF + IF ( Strmflow_flag==6 .OR. Model==99 ) THEN + ALLOCATE ( Seg_width(Nsegment) ) + IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & + & '15.0', '0.18', '40000.0', & + & 'Segment river width', & + & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & + & 'meters')/=0 ) CALL read_error(1, 'seg_width') + ENDIF + IF ( Strmflow_flag==7 .OR. Model==99 ) THEN ALLOCATE ( Seg_depth(Nsegment) ) IF ( declparam(MODNAME, 'seg_depth', 'nsegment', 'real', & @@ -371,10 +373,12 @@ INTEGER FUNCTION routinginit() IF ( Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN IF ( getparam(MODNAME, 'mann_n', Nsegment, 'real', Mann_n)/=0 ) CALL read_error(2, 'mann_n') - IF ( getparam(MODNAME, 'seg_width', Nsegment, 'real', Seg_width)/=0 ) CALL read_error(2, 'seg_width') IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') ENDIF + IF ( Strmflow_flag==6 ) THEN + IF ( getparam(MODNAME, 'seg_width', Nsegment, 'real', Seg_width)/=0 ) CALL read_error(2, 'seg_width') + ENDIF IF ( Strmflow_flag==7 ) THEN IF ( getparam(MODNAME, 'seg_depth', Nsegment, 'real', seg_depth)/=0 ) CALL read_error(2, 'seg_depth') ENDIF @@ -520,9 +524,7 @@ INTEGER FUNCTION routinginit() ierr = 0 DO i = 1, Nsegment IF ( Strmflow_flag==7 ) THEN ! muskingum_mann -! velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))* -! & ( Seg_width(i)*Seg_depth(i)/( Seg_width(i)+2.*Seg_depth(i) ) )**(2./3.) - velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say w>>d + velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours ENDIF diff --git a/prms/routingRip.f90 b/prms/routingRip.f90 index 42eb3b2a..acde0c41 100644 --- a/prms/routingRip.f90 +++ b/prms/routingRip.f90 @@ -268,7 +268,7 @@ INTEGER FUNCTION routingdecl() ENDIF - IF ( Strmflow_flag==6 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN + IF (Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN ALLOCATE ( Mann_n(Nsegment) ) IF ( declparam( MODNAME, 'mann_n', 'nsegment', 'real', & & '0.04', '0.001', '0.15', & @@ -276,13 +276,6 @@ INTEGER FUNCTION routingdecl() & 'Mannings roughness coefficient for each segment', & & 'dimensionless')/=0 ) CALL read_error(1, 'mann_n') - ALLOCATE ( Seg_width(Nsegment) ) - IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & - & '15.0', '0.18', '40000.0', & - & 'Segment river width', & - & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & - & 'meters')/=0 ) CALL read_error(1, 'seg_width') - ALLOCATE ( Seg_slope(Nsegment) ) IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & & '0.0001', '0.0000001', '2.0', & @@ -298,6 +291,15 @@ INTEGER FUNCTION routingdecl() & 'meters')/=0 ) CALL read_error(1, 'seg_length') ENDIF + IF (Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Model==99 ) THEN + ALLOCATE ( Seg_width(Nsegment) ) + IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & + & '15.0', '0.18', '40000.0', & + & 'Segment river width', & + & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & + & 'meters')/=0 ) CALL read_error(1, 'seg_width') + ENDIF + IF (Ripst_flag==1 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN ALLOCATE ( Seg_depth(Nsegment) ) IF ( declparam(MODNAME, 'seg_depth', 'nsegment', 'real', & @@ -601,12 +603,14 @@ INTEGER FUNCTION routinginit() Segment_type(i) = MOD( Segment_type(i), 100 ) ENDDO - IF ( Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN + IF ( Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN IF ( getparam(MODNAME, 'mann_n', Nsegment, 'real', Mann_n)/=0 ) CALL read_error(2, 'mann_n') - IF ( getparam(MODNAME, 'seg_width', Nsegment, 'real', Seg_width)/=0 ) CALL read_error(2, 'seg_width') IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') ENDIF + IF ( Ripst_flag==1 .OR. Strmflow_flag==6 ) THEN + IF ( getparam(MODNAME, 'seg_width', Nsegment, 'real', Seg_width)/=0 ) CALL read_error(2, 'seg_width') + ENDIF IF ( Ripst_flag==1 .OR. Strmflow_flag==7 ) THEN IF ( getparam(MODNAME, 'seg_depth', Nsegment, 'real', seg_depth)/=0 ) CALL read_error(2, 'seg_depth') ENDIF @@ -814,9 +818,7 @@ INTEGER FUNCTION routinginit() ierr = 0 DO i = 1, Nsegment IF ( Strmflow_flag==7 ) THEN ! muskingum_mann -! velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))* -! & ( Seg_width(i)*Seg_depth(i)/( Seg_width(i)+2.*Seg_depth(i) ) )**(2./3.) - velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say w>>d + velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours ENDIF From 4096fd9c3dce8eac0060a5958e73f56abdff5c82 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 25 Jun 2019 21:59:43 -0500 Subject: [PATCH 14/47] fix merged streamtemp and glacr_melt errors (without glaciers in params) --- prms/glacr_melt.f90 | 28 ++++-- prms/routing.f90 | 27 +++++- prms/routingRip.f90 | 24 +++++- prms/stream_temp.f90 | 182 ++++++++++++++++----------------------- prms/stream_tempCopy.f90 | 182 ++++++++++++++++----------------------- 5 files changed, 215 insertions(+), 228 deletions(-) diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 index 8ffef8ce..e513bf9b 100644 --- a/prms/glacr_melt.f90 +++ b/prms/glacr_melt.f90 @@ -75,7 +75,7 @@ MODULE PRMS_GLACR DOUBLE PRECISION, SAVE :: Basin_gl_storstart DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_mb_yrcumul(:), Delta_volyr(:), Prev_vol(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Prev_area(:), Gl_mb_yrcumul(:), Gl_area(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Gl_mb_cumul(:), Glnet_ar_delta(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Gl_mb_cumul(:), Glnet_ar_delta(:), Gl_mbc_yrend(:) !**************************************************************** ! Declared Parameters @@ -182,6 +182,11 @@ INTEGER FUNCTION glacrdecl() & 'Yearly mass balance for each glacier, indexed by Glacr_tag', & & 'inches', Gl_mb_yrcumul)/=0 ) CALL read_error(3, 'gl_mb_yrcumul') + ALLOCATE ( Gl_mb_cumul(Nhru) ) + IF ( declvar(MODNAME, 'gl_mb_cumul', 'nhru', Nhru, 'double', & + & 'Cumulative mass balance for each glacier since start day, indexed by Glacr_tag', & + & 'inches', Gl_mb_cumul)/=0 ) CALL read_error(3, 'gl_mb_cumul') + IF ( declvar(MODNAME, 'basin_gl_area', 'one', 1, 'double', & & 'Basin area-weighted average glacier-covered area', & & 'decimal fraction', Basin_gl_area)/=0 ) CALL read_error(3, 'basin_gl_area') @@ -347,7 +352,7 @@ INTEGER FUNCTION glacrdecl() ENDIF ! local arrays - ALLOCATE ( Hru_area_inch2(Nhru)) + ALLOCATE ( Hru_area_inch2(Nhru), Gl_mbc_yrend(Nhru) ) ! declare parameters ALLOCATE ( Tohru(Nhru) ) @@ -489,6 +494,7 @@ INTEGER FUNCTION glacrinit() Delta_volyr = 0.0D0 Gl_mb_yrcumul = 0.0D0 Gl_mb_cumul = 0.0D0 + Gl_mbc_yrend = 0.0D0 Hru_slope_ts = Hru_slope Basal_elev = Hru_elev_ts ! Hru_elev_ts always set in basin, need in case of restart Basal_slope = Hru_slope_ts @@ -506,6 +512,7 @@ INTEGER FUNCTION glacrinit() Basin_gl_storstart = 0.0D0 Basin_gl_storvol = 0.0D0 ENDIF + hru_flowline = 0 toflowline = 0 str_idm = 1.0E15 @@ -534,6 +541,7 @@ INTEGER FUNCTION glacrinit() ENDIF ENDIF ENDDO + IF ( count>0 ) THEN ! Number the glaciers and tags parts that belong together CALL tag_count(1, hru_flowline, toflowline, glacier_frac_use) @@ -767,6 +775,7 @@ INTEGER FUNCTION glacrinit() !print*, 'Basin area acres=', 1.0/Basin_area_inv ENDIF ! skip all if no glaciers ! + END FUNCTION glacrinit !*********************************************************************** @@ -786,6 +795,7 @@ INTEGER FUNCTION glacrrun() !*********************************************************************** glacrrun = 0 count = 0 + ! DO j = 1, Active_hrus i = Hru_route_order(j) @@ -796,6 +806,7 @@ INTEGER FUNCTION glacrrun() ENDIF ENDIF ENDDO + IF( Ngl==0 ) THEN !no more glaciers, will first happen at 10/1 when size changes Gl_area = 0.D0 Glnet_ar_delta = 0.0D0 @@ -807,6 +818,7 @@ INTEGER FUNCTION glacrrun() Delta_volyr = 0.0D0 Gl_mb_yrcumul = 0.0D0 Gl_mb_cumul = 0.0D0 + Gl_mbc_yrend = 0.0D0 Av_basal_slope = 0.0 Av_fgrad = 0.0 Hru_slope_ts = Basal_slope @@ -1096,7 +1108,11 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) ENDDO Glnet_ar_delta=0.D0 !start at beginning ENDIF - + DO o = 1, Ngl + p = Glacr_tag(Term(o)) !index by Glacr_tag + !for next year, positive mass outside + Gl_mbc_yrend(p) = Gl_mbc_yrend(p)+Gl_mb_yrcumul(p) + ENDDO ! ! Do retreat/advance on whole glacier at end of year ! last year's area/volume is previous area @@ -1318,6 +1334,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) Delta_volyr(p) = 0.0D0 Gl_mb_yrcumul(p) = 0.0D0 Gl_mb_cumul(p) = 0.0D0 + Gl_mbc_yrend(p) = 0.0D0 Av_basal_slope(p) = 0.0 Av_fgrad(p) = 0.0 ENDIF @@ -1548,6 +1565,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) DO o = 1, Ngl p = Glacr_tag(Term(o)) !index by Glacr_tag Gl_mb_yrcumul(p) = tot_delta_mb(Term(o))/(Gl_area(p)*Acre_inch2) !if glaciers combine or split will jump to new area and terminus + Gl_mb_cumul(p) = Gl_mbc_yrend(p)+Gl_mb_yrcumul(p) ENDDO ENDIF ! @@ -3004,7 +3022,7 @@ SUBROUTINE glacr_restart(In_out) IF ( In_out==0 ) THEN WRITE ( Restart_outunit ) MODNAME WRITE ( Restart_outunit ) Nhrugl, Basin_gl_top_melt, Gl_mb_yrcumul - WRITE ( Restart_outunit ) Gl_mb_cumul, Glnet_ar_delta + WRITE ( Restart_outunit ) Gl_mb_cumul, Glnet_ar_delta, Gl_mbc_yrend WRITE ( Restart_outunit ) Basin_gl_top_gain WRITE ( Restart_outunit ) Basin_gl_area, Gl_area, Basin_gl_ice_melt WRITE ( Restart_outunit ) Hru_glres_melt, Basin_gl_storstart @@ -3033,7 +3051,7 @@ SUBROUTINE glacr_restart(In_out) READ ( Restart_inunit ) module_name CALL check_restart(MODNAME, module_name) READ ( Restart_inunit ) Nhrugl, Basin_gl_top_melt, Gl_mb_yrcumul - READ ( Restart_inunit ) Gl_mb_cumul, Glnet_ar_delta + READ ( Restart_inunit ) Gl_mb_cumul, Glnet_ar_delta, Gl_mbc_yrend READ ( Restart_inunit ) Basin_gl_top_gain READ ( Restart_inunit ) Basin_gl_area, Gl_area, Basin_gl_ice_melt READ ( Restart_inunit ) Hru_glres_melt, Basin_gl_storstart diff --git a/prms/routing.f90 b/prms/routing.f90 index 1e961524..1609613b 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -25,7 +25,7 @@ MODULE PRMS_ROUTING ! Declared Parameters INTEGER, SAVE, ALLOCATABLE :: Segment_type(:), Tosegment(:), Hru_segment(:), Obsin_segment(:), Obsout_segment(:) REAL, SAVE, ALLOCATABLE :: Seg_depth(:), K_coef(:), X_coef(:), Mann_n(:), Seg_width(:), Segment_flow_init(:) - REAL, SAVE, ALLOCATABLE :: Seg_length(:), Seg_slope(:) !in stream_temp too + REAL, SAVE, ALLOCATABLE :: Seg_length(:), Seg_slope(:) END MODULE PRMS_ROUTING !*********************************************************************** @@ -59,7 +59,7 @@ END FUNCTION routing INTEGER FUNCTION routingdecl() USE PRMS_ROUTING USE PRMS_MODULE, ONLY: Nhru, Nsegment, Model, Strmflow_flag, Cascade_flag, & - & Init_vars_from_file + & Stream_temp_flag, Init_vars_from_file IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declparam, declvar @@ -134,7 +134,9 @@ INTEGER FUNCTION routingdecl() & 'Mannings roughness coefficient', & & 'Mannings roughness coefficient for each segment', & & 'dimensionless')/=0 ) CALL read_error(1, 'mann_n') + ENDIF + IF ( Stream_temp_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN ALLOCATE ( Seg_slope(Nsegment) ) IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & & '0.0001', '0.0000001', '2.0', & @@ -316,7 +318,8 @@ END FUNCTION routingdecl INTEGER FUNCTION routinginit() USE PRMS_ROUTING USE PRMS_MODULE, ONLY: Nsegment, Nhru, Init_vars_from_file, Strmflow_flag, & - & Water_use_flag, Segment_transferON_OFF, Inputerror_flag, Parameter_check_flag !, Print_debug + & Water_use_flag, Segment_transferON_OFF, Inputerror_flag, Parameter_check_flag, & + & Stream_temp_flag !, Print_debug USE PRMS_SET_TIME, ONLY: Timestep_seconds USE PRMS_BASIN, ONLY: FT2_PER_ACRE, DNEARZERO, Active_hrus, Hru_route_order, Hru_area_dble, NEARZERO !, Active_area USE PRMS_FLOWVARS, ONLY: Seg_outflow @@ -373,7 +376,9 @@ INTEGER FUNCTION routinginit() IF ( Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN IF ( getparam(MODNAME, 'mann_n', Nsegment, 'real', Mann_n)/=0 ) CALL read_error(2, 'mann_n') - IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') + ENDIF + IF ( Stream_temp_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7) THEN + IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') ENDIF IF ( Strmflow_flag==6 ) THEN @@ -383,6 +388,20 @@ INTEGER FUNCTION routinginit() IF ( getparam(MODNAME, 'seg_depth', Nsegment, 'real', seg_depth)/=0 ) CALL read_error(2, 'seg_depth') ENDIF +! find segments that are too short and print them out as they are found + ierr = 0 + DO i = 1, Nsegment + IF ( Seg_length(i)0 ) THEN ! assign downstream values Seg_close(i) = Tosegment(i) ! don't have a value yet, need to fix ELSE ! no upstream or downstream segment @@ -574,7 +540,7 @@ INTEGER FUNCTION stream_temp_init() Press(i) = 1013.0 - (0.1055 * Seg_elev(i)) IF ( Stream_temp_shade_flag==0 ) THEN -! LATITUDE TRIGONOMETRIC PARAMETERS +! LATITUDE TRIGONOMETRIC PARAMETERS Cos_seg_lat(i) = COS(Seg_lat(i)) ! coso IF ( Cos_seg_lat(i) < NEARZERO ) Cos_Seg_lat(i) = NEARZERO Sin_seg_lat(i) = SIN(Seg_lat(i)) ! sino @@ -631,7 +597,7 @@ INTEGER FUNCTION stream_temp_init() ENDDO ! There may be headwater segments that do not have any HRUs and do not have any upstream segments to produce -! streamflow. These segments will never have any streamflow, and consequently never be able to simulate +! streamflow. These segments will never have any streamflow, and consequently never be able to simulate ! stream temperature. This block finds these and sets the stream temperature value to -99.9. Subsequent code ! should be able to check if the temperature value is less than -99.0 and know that it doesn't need to do ! any stream temperature calculation because there will never be any water in the segment. @@ -676,7 +642,7 @@ INTEGER FUNCTION stream_temp_run() USE PRMS_CLIMATE_HRU, ONLY: Humidity_hru USE PRMS_FLOWVARS, ONLY: Seg_outflow USE PRMS_SNOW, ONLY: Snowmelt - USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Seginc_swrad + USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Seginc_swrad, Seg_length USE PRMS_OBS, ONLY: Humidity USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday, Jday USE PRMS_SOLTAB, ONLY: Soltab_potsw, Hru_cossl @@ -695,7 +661,7 @@ INTEGER FUNCTION stream_temp_run() !*********************************************************************** stream_temp_run = 0 Seg_tave_air = 0.0 - + ! Humidity info come from parameter file when Strmtemp_humidity_flag==1 ! Otherwise it comes as daily values per HRU from CBH. Code for this is ! down in the HRU loop. @@ -710,7 +676,7 @@ INTEGER FUNCTION stream_temp_run() ELSE Seg_humid = 0.0 ENDIF - + Seg_potet = 0.0D0 Seg_ccov = 0.0 Seg_melt = 0.0 @@ -744,7 +710,7 @@ INTEGER FUNCTION stream_temp_run() Seg_ccov(i) = Seg_ccov(i) + ccov*harea Seg_potet(i) = Seg_potet(i) + DBLE( Potet(j)*harea ) Seg_melt(i) = Seg_melt(i) + Snowmelt(j)*harea - Seg_rain(i) = Seg_rain(i) + Hru_rain(j)*harea + Seg_rain(i) = Seg_rain(i) + Hru_rain(j)*harea ENDDO @@ -825,7 +791,7 @@ INTEGER FUNCTION stream_temp_run() cycle endif -! GW moving average +! GW moving average gw_sum(i) = gw_sum(i) - gw_silo(i, gw_index) gw_silo(i, gw_index) = Seg_tave_air(i) gw_sum(i) = gw_sum(i) + gw_silo(i, gw_index) @@ -850,7 +816,7 @@ INTEGER FUNCTION stream_temp_run() endif ENDIF ENDDO - + ! Finish computing seg_tave_upstream IF ( fs > NEARZERO) THEN seg_tave_upstream(i) = up_temp / fs @@ -867,15 +833,15 @@ INTEGER FUNCTION stream_temp_run() ! Compute flow-dependent water-in-segment width value if (seg_outflow(i) > NEARZERO) then - Seg_width(i) = width_alpha(i) * sngl(Seg_outflow(i)) ** width_m(i) + Seg_width_flow(i) = width_alpha(i) * sngl(Seg_outflow(i)) ** width_m(i) else - Seg_width(i) = 0.0 + Seg_width_flow(i) = 0.0 if (Seg_tave_water(i) > -99.0) then ! This segment has upstream HRUs somewhere, but the current day's flow is zero Seg_tave_water(i) = -98.9 endif endif - + ! Compute the shade on the segment. Either set by value in the parameter file or computed IF ( Stream_temp_shade_flag==1 ) THEN IF ( Summer_flag==0 ) THEN @@ -883,19 +849,19 @@ INTEGER FUNCTION stream_temp_run() ELSE seg_shade(i) = Segshade_sum(i) ENDIF - + ! Svi = RIPARIAN VEGETATION SHADE svi = 0.0 ELSE CALL shday(i, seg_shade(i), svi) ENDIF - + ! Start working towards the computation of the equilibrium temperature qlat = 0.0D0 seg_tave_lat(i) = 0.0 - ak1 = 0.0 + ak1 = 0.0 ak2 = 0.0 - + ! Inputs: seg_tave_gw, Seg_tave_air, seg_tave_ss, seg_tave_upstream, Seg_melt, Seg_rain ! Outputs: qlat (in CMS), seg_tave_lat CALL lat_inflow(qlat, seg_tave_lat(i), i, seg_tave_gw(i), Seg_tave_air(i), seg_tave_ss(i), & @@ -912,7 +878,7 @@ INTEGER FUNCTION stream_temp_run() ! Compute t_o ! t_o is the temperature of the water at the beginning of the time step (this is To in equation 32) - if (Seg_tave_water(i) < -99.0) then + if (Seg_tave_water(i) < -99.0) then ! No flow in this segment and there never will be becuase there are no upstream HRUs. t_o = Seg_tave_water(i) @@ -935,18 +901,18 @@ INTEGER FUNCTION stream_temp_run() ! if this is true, then there is no lateral flow, but there is flow from upstream t_o = seg_tave_upstream(i) - else + else ! if this is true, then there is both lateral flow and flow from upstream ! qlat is in CMS so fs needs to be converted t_o = sngl((seg_tave_upstream(i) * fs * CFS2CMS_CONV) + & & (sngl(qlat) * (seg_tave_lat(i) + lat_temp_adj(i,Nowmonth)))) / & & sngl((fs * CFS2CMS_CONV) + sngl(qlat)) - endif + endif ! debug if (t_o .ne. t_o) then write(*,*) "t_o is Nan, seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & - & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) + & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) continue endif @@ -954,12 +920,12 @@ INTEGER FUNCTION stream_temp_run() if (t_o .gt. 100.0) then write(*,*) "this is the place: t_o = ", t_o, " ted = ", te, " seg_id = ", i write(*,*) " seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & - & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) - write(*,*) " width = ", Seg_width(i), Nowyear, Nowmonth, Nowday + & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) + write(*,*) " width = ", Seg_width_flow(i), Nowyear, Nowmonth, Nowday continue exit endif - + ! Need a good value of t_o if (t_o .gt. -98.0) then ! This block computes the value for seg_tave_water @@ -970,9 +936,9 @@ INTEGER FUNCTION stream_temp_run() CALL equilb(te, ak1, ak2, seg_shade(i), svi, i, t_o) ! Compute the daily mean water temperature - ! In: t_o, qlat, seg_tave_lat(i), te, ak1, ak2, i, seg_width, seg_length - Seg_tave_water(i) = twavg(fs, t_o, qlat, seg_tave_lat(i), te, ak1, ak2, seg_width(i), seg_length(i)) - + ! In: t_o, qlat, seg_tave_lat(i), te, ak1, ak2, i, seg_width_flow, seg_length/1000 (km) + Seg_tave_water(i) = twavg(fs, t_o, qlat, seg_tave_lat(i), te, ak1, ak2, seg_width_flow(i), seg_length(i)/1000.0) + else ! bad t_o value Seg_tave_water(i) = -98.9 @@ -1013,7 +979,7 @@ SUBROUTINE lat_inflow(Qlat, Tl_avg, id, tave_gw, tave_air, tave_ss, melt, rain) weight_ss = 0.0 weight_gw = 0.0 ENDIF - + IF (melt > 0.0) THEN melt_wt = melt/(melt + rain) IF (melt_wt < 0.0) melt_wt = 0.0 @@ -1030,7 +996,7 @@ SUBROUTINE lat_inflow(Qlat, Tl_avg, id, tave_gw, tave_air, tave_ss, melt, rain) troff = tave_air tss = tave_ss ENDIF - + Tl_avg = weight_roff * troff + weight_ss * tss + weight_gw * tave_gw END SUBROUTINE lat_inflow @@ -1056,7 +1022,7 @@ REAL FUNCTION twavg(qup, T0, Qlat, Tl_avg, Te, Ak1, Ak2, width, length) Ql = SNGL( Qlat ) ! This is confused logic coment out here and compute the terms as needed below -! b = (Ql / Seg_length) + ((Ak1 * Seg_width) / 4182.0E03) +! b = (Ql / Seg_length/1000) + ((Ak1 * Seg_width_flow) / 4182.0E03) ! IF ( b < NEARZERO ) b = NEARZERO ! rsr, don't know what value this should be to avoid divide by 0 ! r = 1.0 + (Ql / q_init) ! IF ( r < NEARZERO ) r = NEARZERO @@ -1099,7 +1065,7 @@ REAL FUNCTION twavg(qup, T0, Qlat, Tl_avg, Te, Ak1, Ak2, width, length) ELSE rexp = 0.0 ENDIF - + ! DANGER -- replaced this potential divide by zero with the logic below ! r = 1.0 + (Ql / q_init) if (q_init < NEARZERO) then @@ -1131,11 +1097,11 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) ! 1. DETERMINE THE AVERAGE DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS ! 2. DETERMINE THE MAXIMUM DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS - USE PRMS_STRMTEMP, ONLY: ZERO_C, Seg_width, Seg_humid, Press, MPS_CONVERT, & - & Seg_ccov, Seg_slope, Seg_potet, Albedo, seg_tave_gw + USE PRMS_STRMTEMP, ONLY: ZERO_C, Seg_width_flow, Seg_humid, Press, MPS_CONVERT, & + & Seg_ccov, Seg_potet, Albedo, seg_tave_gw USE PRMS_BASIN, ONLY: NEARZERO, CFS2CMS_CONV USE PRMS_FLOWVARS, ONLY: Seg_inflow - USE PRMS_ROUTING, ONLY: Seginc_swrad + USE PRMS_ROUTING, ONLY: Seginc_swrad, Seg_slope IMPLICIT NONE ! Functions INTRINSIC EXP, SQRT, ABS, SNGL, DBLE @@ -1158,11 +1124,11 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) taabs = DBLE( t_o + ZERO_C ) vp_sat = 6.108 * EXP(17.26939 * t_o/(t_o + 237.3)) -! +! ! Convert units and set up parameters q_init = SNGL( Seg_inflow(Seg_id) * CFS2CMS_CONV ) IF ( q_init < NEARZERO ) q_init = NEARZERO - + ! sw_power should be in watts / m2 ! seginc_swrad is in langly / day ! Used to use RAD_CONVERT, the conversion I'm using now is a slightly different number. @@ -1170,14 +1136,14 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) del_ht = 2.36E06 ! could multiple by 10E6 for this and other terms later to reduce round-off ltnt_ht = 2495.0E06 - + ! If humidity is 1.0, there is a divide by zero below. if (Seg_humid(Seg_id) > 0.99) then foo = 0.99 else foo = Seg_humid(Seg_id) endif - + bow_coeff = (0.00061 * Press(Seg_id))/(vp_sat * (1.0 - foo)) evap = SNGL( Seg_potet(Seg_id) * MPS_CONVERT ) ! @@ -1188,7 +1154,7 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) & * (1.0 + (0.17*(Seg_ccov(Seg_id)**2)))) ) * (taabs**4) ! hf is heat from stream friction. See eqn. 14. q_init is in CMS - hf = 9805.0 * (q_init/Seg_width(Seg_id)) * Seg_slope(Seg_id) + hf = 9805.0 * (q_init/Seg_width_flow(Seg_id)) * Seg_slope(Seg_id) hs = (1.0 - sh) * sw_power * (1.0 - Albedo) hv = 5.24D-8 * DBLE(Svi) * (taabs**4) @@ -1206,7 +1172,7 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) Ted = t_o CALL teak1(A, b, c, d, Ted, Ak1d) - + ! ! DETERMINE 2ND ORDER THERMAL EXCHANGE COEFFICIENT hnet = (A * ((t_o + ZERO_C)**4)) + (b * t_o) - (c * (t_o**2.0)) - d @@ -1225,7 +1191,7 @@ END SUBROUTINE equilb ! "teak1" !********************************************************************************** SUBROUTINE teak1(A, B, C, D, Teq, Ak1c) -! PURPOSE: +! PURPOSE: ! 1. TO DETERMINE THE EQUILIBRIUM WATER TEMPERATURE FROM THE ENERGY BALANCE ! EQUATION BY ITERATING NEWTON'S METHOD ! 2. TO DETERMINE THE 1ST THERMAL EXCHANGE COEFFICIENT. @@ -1259,7 +1225,7 @@ SUBROUTINE teak1(A, B, C, D, Teq, Ak1c) delte = fte / fpte Teq = Teq - delte ENDDO - + ! DETERMINE 1ST THERMAL EXCHANGE COEFFICIENT Ak1c = (4.0 * A * ((Teq + ZERO_C)**3.0)) + B - (2.0 * C * Teq) ! @@ -1345,7 +1311,7 @@ SUBROUTINE shday(Seg_id, Shade, Svi) ! Vow = OFFSET, WEST SIDE VEGETATION ! USE PRMS_SET_TIME, ONLY: Jday - USE PRMS_STRMTEMP, ONLY: Azrh, Alte, Altw, Seg_daylight, Seg_width, & + USE PRMS_STRMTEMP, ONLY: Azrh, Alte, Altw, Seg_daylight, Seg_width_flow, & & PI, HALF_PI, Cos_seg_lat, Sin_seg_lat, Cos_lat_decl, Horizontal_hour_angle, & & Level_sunset_azimuth, Max_solar_altitude, Sin_alrs, Sin_declination, Sin_lat_decl, Total_shade USE PRMS_BASIN, ONLY: CFS2CMS_CONV @@ -1367,7 +1333,7 @@ SUBROUTINE shday(Seg_id, Shade, Svi) REAL, PARAMETER :: RADTOHOUR = 24.0/(2.0 * PI) !********************************************************************************* -! LATITUDE TRIGONOMETRIC PARAMETERS +! LATITUDE TRIGONOMETRIC PARAMETERS coso = Cos_seg_lat(Seg_id) sino = Sin_seg_lat(Seg_id) sin_d = Sin_declination(Jday, Seg_id) @@ -1416,11 +1382,11 @@ SUBROUTINE shday(Seg_id, Shade, Svi) ! azss = azso hrss = hrso sti = 0.0 - Svi = (rprnvg(hrsr, hrrs, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width(Seg_id) * totsh) + Svi = (rprnvg(hrsr, hrrs, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width_flow(Seg_id) * totsh) ELSE ! INITIALIZE SHADE VALUES -! +! ! INSERT STARTING TOPOGRAPHIC AZIMUTH VALUES BETWEEN LEVEL PLAIN SUNRISE AND SUNSET aztop = 0.0 ! @@ -1492,12 +1458,12 @@ SUBROUTINE shday(Seg_id, Shade, Svi) Seg_daylight(Seg_id) = (hrss - hrsr) * RADTOHOUR sti = 1.0 - ((((hrss - hrsr) * sinod) + ((SIN(hrss) - SIN(hrsr)) * cosod)) / (totsh)) - Svi = ((rprnvg(hrsr, hrrh, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width(Seg_id)*totsh)) + Svi = ((rprnvg(hrsr, hrrh, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width_flow(Seg_id)*totsh)) ! -! END SUNRISE/SUNSET CALCULATION +! END SUNRISE/SUNSET CALCULATION ENDIF ! -! CHECK FOR ROUNDOFF ERRORS +! CHECK FOR ROUNDOFF ERRORS IF ( sti < 0.0 ) sti = 0.0 IF ( sti > 1.0 ) sti = 1.0 IF ( Svi < 0.0 ) Svi = 0.0 @@ -1582,7 +1548,7 @@ SUBROUTINE snr_sst (Coso, Sino, Sin_d, Alt, Almn, Almx, Azmn, Azmx, Azs, Als, Hr IF ( Als < (Almn + NEARZERO) ) Als = (Almn + NEARZERO) IF ( Als > (Almx - NEARZERO) ) Als = (Almx - NEARZERO) ENDDO -! +! ! ENSURE AZIMUTH REMAINS BETWEEN -PI & PI IF ( Azs < (-PI) ) THEN Azs = Azs + PI @@ -1664,7 +1630,7 @@ REAL FUNCTION solalt (Coso, Sino, Sin_d, Az, Almn, Almx) fppal = b - fal delal = (2.0 * fal * fpal) / ((2.0 * fpal * fpal) - (fal * fppal)) ENDIF - al = al - delal + al = al - delal IF (al < Almn) al = (alold + Almn) / 2.0 IF (al > Almx) al = (alold + Almx) / 2.0 ENDDO @@ -1681,7 +1647,7 @@ REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) ! THIS SUBPROGRAM IS TO COMPUTE THE RIPARIAN VEGETATION SHADE ! SEGMENT BETWEEN THE TWO HOUR ANGLES HRSR & HRSS. ! - USE PRMS_STRMTEMP, ONLY: Azrh, Vce, Vdemx, Vhe, Voe, Vcw, Vdwmx, Vhw, Vow, Seg_width, & + USE PRMS_STRMTEMP, ONLY: Azrh, Vce, Vdemx, Vhe, Voe, Vcw, Vdwmx, Vhw, Vow, Seg_width_flow, & & Vdemn, Vdwmn, HALF_PI USE PRMS_BASIN, ONLY: NEARZERO USE PRMS_SET_TIME, ONLY: Summer_flag @@ -1741,10 +1707,10 @@ REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) azs = ACOS(temp) IF ( azs < 0.0 ) azs = HALF_PI - azs IF ( hrs < 0.0 ) azs = -azs -! DETERMINE AMOUNT OF STREAM WIDTH SHADED +! DETERMINE AMOUNT OF STREAM WIDTH SHADED bs = ((Vhe(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco IF ( bs < 0.0 ) bs = 0.0 - IF ( bs > Seg_width(Seg_id) ) bs = Seg_width(Seg_id) + IF ( bs > Seg_width_flow(Seg_id) ) bs = Seg_width_flow(Seg_id) ! INCREMENT SUNRISE SIDE VEGETATIVE SHADE IF ( Summer_flag == 1 ) THEN ! put back spring and autumn svri = svri + SNGL(Vdemx(Seg_id) * bs * sinals * Weight(n)) @@ -1786,7 +1752,7 @@ REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) ! DETERMINE AMOUNT OF STREAM WIDTH SHADED bs = ((Vhw(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco IF ( bs < 0.0 ) bs = 0.0 - IF ( bs > Seg_width(Seg_id) ) bs = Seg_width(Seg_id) + IF ( bs > Seg_width_flow(Seg_id) ) bs = Seg_width_flow(Seg_id) ! INCREMENT SUNSET SIDE VEGETATIVE SHADE IF ( Summer_flag == 1 ) THEN ! fix for seasons svsi = SNGL(svsi + (Vdwmx(Seg_id) * bs * sinals * Weight(n))) diff --git a/prms/stream_tempCopy.f90 b/prms/stream_tempCopy.f90 index 0978f824..5e3b707c 100644 --- a/prms/stream_tempCopy.f90 +++ b/prms/stream_tempCopy.f90 @@ -24,12 +24,11 @@ MODULE PRMS_STRMTEMP ! Declared Variables REAL, SAVE, ALLOCATABLE :: Seg_tave_water(:), seg_tave_upstream(:), Seg_daylight(:) - REAL, SAVE, ALLOCATABLE :: Seg_humid(:), Seg_width(:), Seg_ccov(:), seg_shade(:) + REAL, SAVE, ALLOCATABLE :: Seg_humid(:), Seg_width_flow(:), Seg_ccov(:), seg_shade(:) REAL, SAVE, ALLOCATABLE :: Seg_tave_air(:), Seg_melt(:), Seg_rain(:) DOUBLE PRECISION, ALLOCATABLE :: Seg_potet(:) ! Segment Parameters - REAL, SAVE, ALLOCATABLE :: Seg_length(:) !, Mann_n(:) - REAL, SAVE, ALLOCATABLE :: Seg_slope(:), Width_values(:, :) + REAL, SAVE, ALLOCATABLE :: Width_values(:, :) REAL, SAVE, ALLOCATABLE :: width_alpha(:), width_m(:) INTEGER, SAVE:: Width_dim, Maxiter_sntemp REAL, SAVE, ALLOCATABLE :: Seg_humidity(:, :) @@ -105,10 +104,10 @@ INTEGER FUNCTION stream_temp_decl() IF ( control_integer(Stream_temp_shade_flag, 'stream_temp_shade_flag')/=0 ) Stream_temp_shade_flag = 0 ! Declared Variables - ALLOCATE ( Seg_width(Nsegment) ) - IF ( declvar( MODNAME, 'seg_width', 'nsegment', Nsegment, 'real', & - & 'Width of each segment', & - & 'meters', Seg_width)/=0 ) CALL read_error(3, 'seg_width') + ALLOCATE ( Seg_width_flow(Nsegment) ) + IF ( declvar( MODNAME, 'seg_width_flow', 'nsegment', Nsegment, 'real', & + & 'Width of each segment, flow-dependent', & + & 'meters', Seg_width_flow)/=0 ) CALL read_error(3, 'seg_width_flow') ALLOCATE (Seg_tave_water(Nsegment) ) ! previous ?? IF ( declvar( MODNAME, 'seg_tave_water', 'nsegment', Nsegment, 'real', & @@ -149,7 +148,7 @@ INTEGER FUNCTION stream_temp_decl() IF ( declvar( MODNAME, 'seg_ccov', 'nsegment', Nsegment, 'real', & & 'Area-weighted average cloud cover fraction for each segment from HRUs contributing flow to the segment', & & 'decimal fraction', Seg_ccov )/=0 ) CALL read_error(3, 'seg_ccov') - + ALLOCATE(Seg_shade(Nsegment)) IF (declvar(MODNAME, 'seg_shade', 'nsegment', Nsegment, 'real', & & 'Area-weighted average shade fraction for each segment', & @@ -159,27 +158,27 @@ INTEGER FUNCTION stream_temp_decl() IF ( declvar( MODNAME, 'seg_daylight', 'nsegment', Nsegment, 'real', & & 'Hours of daylight', & & 'hours', Seg_daylight)/=0 ) CALL read_error(3,'seg_daylight') - + ALLOCATE(seg_tave_gw(Nsegment)) IF ( declvar( MODNAME, 'seg_tave_gw', 'nsegment', Nsegment, 'real', & & 'groundwater temperature', & & 'degrees Celsius', seg_tave_gw)/=0 ) CALL read_error(3,'seg_tave_gw') - + ALLOCATE(seg_tave_ss(Nsegment)) IF ( declvar( MODNAME, 'seg_tave_ss', 'nsegment', Nsegment, 'real', & & 'subsurface temperature', & & 'degrees Celsius', seg_tave_ss)/=0 ) CALL read_error(3,'seg_tave_ss') - + ALLOCATE(seg_tave_sroff(Nsegment)) IF ( declvar( MODNAME, 'seg_tave_sroff', 'nsegment', Nsegment, 'real', & & 'surface runoff temperature', & & 'degrees Celsius', seg_tave_sroff)/=0 ) CALL read_error(3,'seg_tave_sroff') - + ALLOCATE(seg_tave_lat(Nsegment)) IF ( declvar( MODNAME, 'seg_tave_lat', 'nsegment', Nsegment, 'real', & & 'lateral flow temperature', & & 'degrees Celsius', seg_tave_lat)/=0 ) CALL read_error(3,'seg_tave_lat') - + ALLOCATE (Press(Nsegment) ) ALLOCATE ( Seg_hru_count(Nsegment) ) ALLOCATE (Seg_carea_inv(Nsegment) ) @@ -193,7 +192,7 @@ INTEGER FUNCTION stream_temp_decl() & 'Short-wave solar radiation reflected by streams', & & 'Short-wave solar radiation reflected by streams', & & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo') - + ALLOCATE(lat_temp_adj(Nsegment,12)) IF ( declparam( MODNAME, 'lat_temp_adj', 'nsegment,nmonths', 'real', & & '0.0', '-5.0', '5.0', & @@ -201,27 +200,13 @@ INTEGER FUNCTION stream_temp_decl() & 'Correction factor to adjust the bias of the temperature of the lateral inflow', & & 'decimal fraction')/=0 ) CALL read_error(1, 'lat_temp_adj') - ALLOCATE ( Seg_length(Nsegment) ) - IF ( declparam( MODNAME, 'seg_length', 'nsegment', 'real', & - & '1000.0', '1.0', '100000.0', & - & 'Length of each segment', & - & 'Length of each segment', & - & 'meters')/=0 ) CALL read_error(1, 'seg_length') - - ALLOCATE ( Seg_slope(Nsegment) ) - IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & - & '0.015', '0.0001', '2.0', & - & 'Bed slope of each segment', & - & 'Bed slope of each segment', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'seg_slope') - ALLOCATE (width_alpha(Nsegment) ) IF ( declparam( MODNAME, 'width_alpha', 'nsegment', 'real', & & '0.015', '0.0001', '2.0', & & 'Alpha coefficient in power function for width calculation', & & 'Alpha coefficient in power function for width calculation', & & 'unknown')/=0 ) CALL read_error(1, 'width_alpha') - + ALLOCATE (width_m(Nsegment) ) IF ( declparam( MODNAME, 'width_m', 'nsegment', 'real', & & '0.015', '0.0001', '2.0', & @@ -262,14 +247,14 @@ INTEGER FUNCTION stream_temp_decl() IF ( declparam( MODNAME, 'vdemx', 'nsegment', 'real', & & '0.0', '0.0', '1.0', & & 'Maximum east bank vegetation density', & - & 'Maximum east bank vegetation density for each segment', & + & 'Maximum east bank vegetation density for each segment', & & 'decimal fraction')/=0 ) CALL read_error(1, 'vdemx') ALLOCATE ( Vdemn(Nsegment) ) IF ( declparam( MODNAME, 'vdemn', 'nsegment', 'real', & & '0.0', '0.0', '1.0', & & 'Minimum east bank vegetation density', & - & 'Minimum east bank vegetation density for each segment', & + & 'Minimum east bank vegetation density for each segment', & & 'decimal fraction')/=0 ) CALL read_error(1, 'vdemn') ALLOCATE ( Vhe(Nsegment) ) @@ -351,7 +336,7 @@ INTEGER FUNCTION stream_temp_decl() & 'Average residence time in groundwater flow', & & 'Average residence time in groundwater flow', & & 'days')/=0 ) CALL read_error(1, 'gw_tau') - + IF ( declparam( MODNAME, 'melt_temp', 'one', 'real', & & '1.5', '0.0', '10.0', & & 'Temperature at which snowmelt enters a stream', & @@ -400,7 +385,7 @@ END FUNCTION stream_temp_decl !*********************************************************************** INTEGER FUNCTION stream_temp_init() USE PRMS_STRMTEMP - USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file, Inputerror_flag, Strmtemp_humidity_flag + USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file, Strmtemp_humidity_flag USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, NEARZERO USE PRMS_OBS, ONLY: Nhumid USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Segment_up @@ -418,7 +403,6 @@ INTEGER FUNCTION stream_temp_init() IF ( getparam( MODNAME, 'albedo', 1, 'real', Albedo)/=0 ) CALL read_error(2, 'albedo') IF ( getparam( MODNAME, 'lat_temp_adj', Nsegment*12, 'real', lat_temp_adj)/=0 ) CALL read_error(2, 'lat_temp_adj') - IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') IF (getparam(MODNAME, 'seg_lat', Nsegment, 'real', Seg_lat)/=0 ) CALL read_error(2, 'seg_lat') ! Convert latitude from degrees to radians @@ -426,10 +410,6 @@ INTEGER FUNCTION stream_temp_init() IF (getparam(MODNAME, 'seg_elev', Nsegment, 'real', Seg_elev)/=0 ) CALL read_error(2, 'seg_elev') -! convert stream length in meters to km - Seg_length = Seg_length / 1000.0 - - IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') IF ( getparam( MODNAME, 'width_alpha', Nsegment, 'real', width_alpha)/=0 ) CALL read_error(2, 'width_alpha') IF ( getparam( MODNAME, 'width_m', Nsegment, 'real', width_m)/=0 ) CALL read_error(2, 'width_m') @@ -451,7 +431,7 @@ INTEGER FUNCTION stream_temp_init() IF ( getparam( MODNAME, 'segshade_sum', Nsegment, 'real', Segshade_sum)/=0 ) CALL read_error(2, 'segshade_sum') IF ( getparam( MODNAME, 'segshade_win', Nsegment, 'real', Segshade_win)/=0 ) CALL read_error(2, 'segshade_win') ENDIF - + IF ( getparam( MODNAME, 'ss_tau', Nsegment, 'integer', Ss_tau)/=0 ) CALL read_error(2, 'ss_tau') IF ( getparam( MODNAME, 'gw_tau', Nsegment, 'integer', Gw_tau)/=0 ) CALL read_error(2, 'Gw_tau') IF ( getparam( MODNAME, 'melt_temp', 1, 'real', Melt_temp)/=0 ) CALL read_error(2, 'melt_temp') @@ -473,7 +453,7 @@ INTEGER FUNCTION stream_temp_init() seg_tave_upstream = 0.0 Seg_potet = 0.0D0 Seg_humid = 0.0 - Seg_width = 0.0 + Seg_width_flow = 0.0 Seg_ccov = 0.0 Seg_tave_air = 0.0 seg_tave_gw = 0.0 @@ -513,20 +493,6 @@ INTEGER FUNCTION stream_temp_init() Seg_hru_count(i) = Seg_hru_count(i) + 1 ENDDO -! find segments that are too short and print them out as they are found - DO i = 1, Nsegment - IF ( Seg_length(i)0 ) THEN ! assign downstream values Seg_close(i) = Tosegment(i) ! don't have a value yet, need to fix ELSE ! no upstream or downstream segment @@ -574,7 +540,7 @@ INTEGER FUNCTION stream_temp_init() Press(i) = 1013.0 - (0.1055 * Seg_elev(i)) IF ( Stream_temp_shade_flag==0 ) THEN -! LATITUDE TRIGONOMETRIC PARAMETERS +! LATITUDE TRIGONOMETRIC PARAMETERS Cos_seg_lat(i) = COS(Seg_lat(i)) ! coso IF ( Cos_seg_lat(i) < NEARZERO ) Cos_Seg_lat(i) = NEARZERO Sin_seg_lat(i) = SIN(Seg_lat(i)) ! sino @@ -631,7 +597,7 @@ INTEGER FUNCTION stream_temp_init() ENDDO ! There may be headwater segments that do not have any HRUs and do not have any upstream segments to produce -! streamflow. These segments will never have any streamflow, and consequently never be able to simulate +! streamflow. These segments will never have any streamflow, and consequently never be able to simulate ! stream temperature. This block finds these and sets the stream temperature value to -99.9. Subsequent code ! should be able to check if the temperature value is less than -99.0 and know that it doesn't need to do ! any stream temperature calculation because there will never be any water in the segment. @@ -676,7 +642,7 @@ INTEGER FUNCTION stream_temp_run() USE PRMS_CLIMATE_HRU, ONLY: Humidity_hru USE PRMS_FLOWVARS, ONLY: Seg_outflow USE PRMS_SNOW, ONLY: Snowmelt - USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Seginc_swrad + USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Seginc_swrad, Seg_length USE PRMS_OBS, ONLY: Humidity USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday, Jday USE PRMS_SOLTAB, ONLY: Soltab_potsw, Hru_cossl @@ -695,7 +661,7 @@ INTEGER FUNCTION stream_temp_run() !*********************************************************************** stream_temp_run = 0 Seg_tave_air = 0.0 - + ! Humidity info come from parameter file when Strmtemp_humidity_flag==1 ! Otherwise it comes as daily values per HRU from CBH. Code for this is ! down in the HRU loop. @@ -710,7 +676,7 @@ INTEGER FUNCTION stream_temp_run() ELSE Seg_humid = 0.0 ENDIF - + Seg_potet = 0.0D0 Seg_ccov = 0.0 Seg_melt = 0.0 @@ -744,7 +710,7 @@ INTEGER FUNCTION stream_temp_run() Seg_ccov(i) = Seg_ccov(i) + ccov*harea Seg_potet(i) = Seg_potet(i) + DBLE( Potet(j)*harea ) Seg_melt(i) = Seg_melt(i) + Snowmelt(j)*harea - Seg_rain(i) = Seg_rain(i) + Hru_rain(j)*harea + Seg_rain(i) = Seg_rain(i) + Hru_rain(j)*harea ENDDO @@ -825,7 +791,7 @@ INTEGER FUNCTION stream_temp_run() cycle endif -! GW moving average +! GW moving average gw_sum(i) = gw_sum(i) - gw_silo(i, gw_index) gw_silo(i, gw_index) = Seg_tave_air(i) gw_sum(i) = gw_sum(i) + gw_silo(i, gw_index) @@ -850,7 +816,7 @@ INTEGER FUNCTION stream_temp_run() endif ENDIF ENDDO - + ! Finish computing seg_tave_upstream IF ( fs > NEARZERO) THEN seg_tave_upstream(i) = up_temp / fs @@ -867,15 +833,15 @@ INTEGER FUNCTION stream_temp_run() ! Compute flow-dependent water-in-segment width value if (seg_outflow(i) > NEARZERO) then - Seg_width(i) = width_alpha(i) * sngl(Seg_outflow(i)) ** width_m(i) + Seg_width_flow(i) = width_alpha(i) * sngl(Seg_outflow(i)) ** width_m(i) else - Seg_width(i) = 0.0 + Seg_width_flow(i) = 0.0 if (Seg_tave_water(i) > -99.0) then ! This segment has upstream HRUs somewhere, but the current day's flow is zero Seg_tave_water(i) = -98.9 endif endif - + ! Compute the shade on the segment. Either set by value in the parameter file or computed IF ( Stream_temp_shade_flag==1 ) THEN IF ( Summer_flag==0 ) THEN @@ -883,19 +849,19 @@ INTEGER FUNCTION stream_temp_run() ELSE seg_shade(i) = Segshade_sum(i) ENDIF - + ! Svi = RIPARIAN VEGETATION SHADE svi = 0.0 ELSE CALL shday(i, seg_shade(i), svi) ENDIF - + ! Start working towards the computation of the equilibrium temperature qlat = 0.0D0 seg_tave_lat(i) = 0.0 - ak1 = 0.0 + ak1 = 0.0 ak2 = 0.0 - + ! Inputs: seg_tave_gw, Seg_tave_air, seg_tave_ss, seg_tave_upstream, Seg_melt, Seg_rain ! Outputs: qlat (in CMS), seg_tave_lat CALL lat_inflow(qlat, seg_tave_lat(i), i, seg_tave_gw(i), Seg_tave_air(i), seg_tave_ss(i), & @@ -912,7 +878,7 @@ INTEGER FUNCTION stream_temp_run() ! Compute t_o ! t_o is the temperature of the water at the beginning of the time step (this is To in equation 32) - if (Seg_tave_water(i) < -99.0) then + if (Seg_tave_water(i) < -99.0) then ! No flow in this segment and there never will be becuase there are no upstream HRUs. t_o = Seg_tave_water(i) @@ -935,18 +901,18 @@ INTEGER FUNCTION stream_temp_run() ! if this is true, then there is no lateral flow, but there is flow from upstream t_o = seg_tave_upstream(i) - else + else ! if this is true, then there is both lateral flow and flow from upstream ! qlat is in CMS so fs needs to be converted t_o = sngl((seg_tave_upstream(i) * fs * CFS2CMS_CONV) + & & (sngl(qlat) * (seg_tave_lat(i) + lat_temp_adj(i,Nowmonth)))) / & & sngl((fs * CFS2CMS_CONV) + sngl(qlat)) - endif + endif ! debug if (t_o .ne. t_o) then write(*,*) "t_o is Nan, seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & - & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) + & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) continue endif @@ -954,12 +920,12 @@ INTEGER FUNCTION stream_temp_run() if (t_o .gt. 100.0) then write(*,*) "this is the place: t_o = ", t_o, " ted = ", te, " seg_id = ", i write(*,*) " seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & - & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) - write(*,*) " width = ", Seg_width(i), Nowyear, Nowmonth, Nowday + & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) + write(*,*) " width = ", Seg_width_flow(i), Nowyear, Nowmonth, Nowday continue exit endif - + ! Need a good value of t_o if (t_o .gt. -98.0) then ! This block computes the value for seg_tave_water @@ -970,9 +936,9 @@ INTEGER FUNCTION stream_temp_run() CALL equilb(te, ak1, ak2, seg_shade(i), svi, i, t_o) ! Compute the daily mean water temperature - ! In: t_o, qlat, seg_tave_lat(i), te, ak1, ak2, i, seg_width, seg_length - Seg_tave_water(i) = twavg(fs, t_o, qlat, seg_tave_lat(i), te, ak1, ak2, seg_width(i), seg_length(i)) - + ! In: t_o, qlat, seg_tave_lat(i), te, ak1, ak2, i, seg_width_flow, seg_length/1000 (km) + Seg_tave_water(i) = twavg(fs, t_o, qlat, seg_tave_lat(i), te, ak1, ak2, seg_width_flow(i), seg_length(i)/1000.0) + else ! bad t_o value Seg_tave_water(i) = -98.9 @@ -1013,7 +979,7 @@ SUBROUTINE lat_inflow(Qlat, Tl_avg, id, tave_gw, tave_air, tave_ss, melt, rain) weight_ss = 0.0 weight_gw = 0.0 ENDIF - + IF (melt > 0.0) THEN melt_wt = melt/(melt + rain) IF (melt_wt < 0.0) melt_wt = 0.0 @@ -1030,7 +996,7 @@ SUBROUTINE lat_inflow(Qlat, Tl_avg, id, tave_gw, tave_air, tave_ss, melt, rain) troff = tave_air tss = tave_ss ENDIF - + Tl_avg = weight_roff * troff + weight_ss * tss + weight_gw * tave_gw END SUBROUTINE lat_inflow @@ -1056,7 +1022,7 @@ REAL FUNCTION twavg(qup, T0, Qlat, Tl_avg, Te, Ak1, Ak2, width, length) Ql = SNGL( Qlat ) ! This is confused logic coment out here and compute the terms as needed below -! b = (Ql / Seg_length) + ((Ak1 * Seg_width) / 4182.0E03) +! b = (Ql / Seg_length/1000) + ((Ak1 * Seg_width_flow) / 4182.0E03) ! IF ( b < NEARZERO ) b = NEARZERO ! rsr, don't know what value this should be to avoid divide by 0 ! r = 1.0 + (Ql / q_init) ! IF ( r < NEARZERO ) r = NEARZERO @@ -1099,7 +1065,7 @@ REAL FUNCTION twavg(qup, T0, Qlat, Tl_avg, Te, Ak1, Ak2, width, length) ELSE rexp = 0.0 ENDIF - + ! DANGER -- replaced this potential divide by zero with the logic below ! r = 1.0 + (Ql / q_init) if (q_init < NEARZERO) then @@ -1131,11 +1097,11 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) ! 1. DETERMINE THE AVERAGE DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS ! 2. DETERMINE THE MAXIMUM DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS - USE PRMS_STRMTEMP, ONLY: ZERO_C, Seg_width, Seg_humid, Press, MPS_CONVERT, & - & Seg_ccov, Seg_slope, Seg_potet, Albedo, seg_tave_gw + USE PRMS_STRMTEMP, ONLY: ZERO_C, Seg_width_flow, Seg_humid, Press, MPS_CONVERT, & + & Seg_ccov, Seg_potet, Albedo, seg_tave_gw USE PRMS_BASIN, ONLY: NEARZERO, CFS2CMS_CONV USE PRMS_FLOWVARS, ONLY: Seg_inflow - USE PRMS_ROUTING, ONLY: Seginc_swrad + USE PRMS_ROUTING, ONLY: Seginc_swrad, Seg_slope IMPLICIT NONE ! Functions INTRINSIC EXP, SQRT, ABS, SNGL, DBLE @@ -1158,11 +1124,11 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) taabs = DBLE( t_o + ZERO_C ) vp_sat = 6.108 * EXP(17.26939 * t_o/(t_o + 237.3)) -! +! ! Convert units and set up parameters q_init = SNGL( Seg_inflow(Seg_id) * CFS2CMS_CONV ) IF ( q_init < NEARZERO ) q_init = NEARZERO - + ! sw_power should be in watts / m2 ! seginc_swrad is in langly / day ! Used to use RAD_CONVERT, the conversion I'm using now is a slightly different number. @@ -1170,14 +1136,14 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) del_ht = 2.36E06 ! could multiple by 10E6 for this and other terms later to reduce round-off ltnt_ht = 2495.0E06 - + ! If humidity is 1.0, there is a divide by zero below. if (Seg_humid(Seg_id) > 0.99) then foo = 0.99 else foo = Seg_humid(Seg_id) endif - + bow_coeff = (0.00061 * Press(Seg_id))/(vp_sat * (1.0 - foo)) evap = SNGL( Seg_potet(Seg_id) * MPS_CONVERT ) ! @@ -1188,7 +1154,7 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) & * (1.0 + (0.17*(Seg_ccov(Seg_id)**2)))) ) * (taabs**4) ! hf is heat from stream friction. See eqn. 14. q_init is in CMS - hf = 9805.0 * (q_init/Seg_width(Seg_id)) * Seg_slope(Seg_id) + hf = 9805.0 * (q_init/Seg_width_flow(Seg_id)) * Seg_slope(Seg_id) hs = (1.0 - sh) * sw_power * (1.0 - Albedo) hv = 5.24D-8 * DBLE(Svi) * (taabs**4) @@ -1206,7 +1172,7 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) Ted = t_o CALL teak1(A, b, c, d, Ted, Ak1d) - + ! ! DETERMINE 2ND ORDER THERMAL EXCHANGE COEFFICIENT hnet = (A * ((t_o + ZERO_C)**4)) + (b * t_o) - (c * (t_o**2.0)) - d @@ -1225,7 +1191,7 @@ END SUBROUTINE equilb ! "teak1" !********************************************************************************** SUBROUTINE teak1(A, B, C, D, Teq, Ak1c) -! PURPOSE: +! PURPOSE: ! 1. TO DETERMINE THE EQUILIBRIUM WATER TEMPERATURE FROM THE ENERGY BALANCE ! EQUATION BY ITERATING NEWTON'S METHOD ! 2. TO DETERMINE THE 1ST THERMAL EXCHANGE COEFFICIENT. @@ -1259,7 +1225,7 @@ SUBROUTINE teak1(A, B, C, D, Teq, Ak1c) delte = fte / fpte Teq = Teq - delte ENDDO - + ! DETERMINE 1ST THERMAL EXCHANGE COEFFICIENT Ak1c = (4.0 * A * ((Teq + ZERO_C)**3.0)) + B - (2.0 * C * Teq) ! @@ -1345,7 +1311,7 @@ SUBROUTINE shday(Seg_id, Shade, Svi) ! Vow = OFFSET, WEST SIDE VEGETATION ! USE PRMS_SET_TIME, ONLY: Jday - USE PRMS_STRMTEMP, ONLY: Azrh, Alte, Altw, Seg_daylight, Seg_width, & + USE PRMS_STRMTEMP, ONLY: Azrh, Alte, Altw, Seg_daylight, Seg_width_flow, & & PI, HALF_PI, Cos_seg_lat, Sin_seg_lat, Cos_lat_decl, Horizontal_hour_angle, & & Level_sunset_azimuth, Max_solar_altitude, Sin_alrs, Sin_declination, Sin_lat_decl, Total_shade USE PRMS_BASIN, ONLY: CFS2CMS_CONV @@ -1367,7 +1333,7 @@ SUBROUTINE shday(Seg_id, Shade, Svi) REAL, PARAMETER :: RADTOHOUR = 24.0/(2.0 * PI) !********************************************************************************* -! LATITUDE TRIGONOMETRIC PARAMETERS +! LATITUDE TRIGONOMETRIC PARAMETERS coso = Cos_seg_lat(Seg_id) sino = Sin_seg_lat(Seg_id) sin_d = Sin_declination(Jday, Seg_id) @@ -1416,11 +1382,11 @@ SUBROUTINE shday(Seg_id, Shade, Svi) ! azss = azso hrss = hrso sti = 0.0 - Svi = (rprnvg(hrsr, hrrs, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width(Seg_id) * totsh) + Svi = (rprnvg(hrsr, hrrs, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width_flow(Seg_id) * totsh) ELSE ! INITIALIZE SHADE VALUES -! +! ! INSERT STARTING TOPOGRAPHIC AZIMUTH VALUES BETWEEN LEVEL PLAIN SUNRISE AND SUNSET aztop = 0.0 ! @@ -1492,12 +1458,12 @@ SUBROUTINE shday(Seg_id, Shade, Svi) Seg_daylight(Seg_id) = (hrss - hrsr) * RADTOHOUR sti = 1.0 - ((((hrss - hrsr) * sinod) + ((SIN(hrss) - SIN(hrsr)) * cosod)) / (totsh)) - Svi = ((rprnvg(hrsr, hrrh, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width(Seg_id)*totsh)) + Svi = ((rprnvg(hrsr, hrrh, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width_flow(Seg_id)*totsh)) ! -! END SUNRISE/SUNSET CALCULATION +! END SUNRISE/SUNSET CALCULATION ENDIF ! -! CHECK FOR ROUNDOFF ERRORS +! CHECK FOR ROUNDOFF ERRORS IF ( sti < 0.0 ) sti = 0.0 IF ( sti > 1.0 ) sti = 1.0 IF ( Svi < 0.0 ) Svi = 0.0 @@ -1582,7 +1548,7 @@ SUBROUTINE snr_sst (Coso, Sino, Sin_d, Alt, Almn, Almx, Azmn, Azmx, Azs, Als, Hr IF ( Als < (Almn + NEARZERO) ) Als = (Almn + NEARZERO) IF ( Als > (Almx - NEARZERO) ) Als = (Almx - NEARZERO) ENDDO -! +! ! ENSURE AZIMUTH REMAINS BETWEEN -PI & PI IF ( Azs < (-PI) ) THEN Azs = Azs + PI @@ -1664,7 +1630,7 @@ REAL FUNCTION solalt (Coso, Sino, Sin_d, Az, Almn, Almx) fppal = b - fal delal = (2.0 * fal * fpal) / ((2.0 * fpal * fpal) - (fal * fppal)) ENDIF - al = al - delal + al = al - delal IF (al < Almn) al = (alold + Almn) / 2.0 IF (al > Almx) al = (alold + Almx) / 2.0 ENDDO @@ -1681,7 +1647,7 @@ REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) ! THIS SUBPROGRAM IS TO COMPUTE THE RIPARIAN VEGETATION SHADE ! SEGMENT BETWEEN THE TWO HOUR ANGLES HRSR & HRSS. ! - USE PRMS_STRMTEMP, ONLY: Azrh, Vce, Vdemx, Vhe, Voe, Vcw, Vdwmx, Vhw, Vow, Seg_width, & + USE PRMS_STRMTEMP, ONLY: Azrh, Vce, Vdemx, Vhe, Voe, Vcw, Vdwmx, Vhw, Vow, Seg_width_flow, & & Vdemn, Vdwmn, HALF_PI USE PRMS_BASIN, ONLY: NEARZERO USE PRMS_SET_TIME, ONLY: Summer_flag @@ -1741,10 +1707,10 @@ REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) azs = ACOS(temp) IF ( azs < 0.0 ) azs = HALF_PI - azs IF ( hrs < 0.0 ) azs = -azs -! DETERMINE AMOUNT OF STREAM WIDTH SHADED +! DETERMINE AMOUNT OF STREAM WIDTH SHADED bs = ((Vhe(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco IF ( bs < 0.0 ) bs = 0.0 - IF ( bs > Seg_width(Seg_id) ) bs = Seg_width(Seg_id) + IF ( bs > Seg_width_flow(Seg_id) ) bs = Seg_width_flow(Seg_id) ! INCREMENT SUNRISE SIDE VEGETATIVE SHADE IF ( Summer_flag == 1 ) THEN ! put back spring and autumn svri = svri + SNGL(Vdemx(Seg_id) * bs * sinals * Weight(n)) @@ -1786,7 +1752,7 @@ REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) ! DETERMINE AMOUNT OF STREAM WIDTH SHADED bs = ((Vhw(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco IF ( bs < 0.0 ) bs = 0.0 - IF ( bs > Seg_width(Seg_id) ) bs = Seg_width(Seg_id) + IF ( bs > Seg_width_flow(Seg_id) ) bs = Seg_width_flow(Seg_id) ! INCREMENT SUNSET SIDE VEGETATIVE SHADE IF ( Summer_flag == 1 ) THEN ! fix for seasons svsi = SNGL(svsi + (Vdwmx(Seg_id) * bs * sinals * Weight(n))) From cccc43919b95d566c26b9820a4179d19d189d56b Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Wed, 26 Jun 2019 12:54:46 -0500 Subject: [PATCH 15/47] fixed merged glacr_melt bugs --- prms/basin.f90 | 2 +- prms/climateflow.f90 | 12 ++--- prms/glacr_melt.f90 | 122 ++++++++++++++++++++++++------------------- prms/snowcomp.f90 | 58 ++++++++++---------- 4 files changed, 105 insertions(+), 89 deletions(-) diff --git a/prms/basin.f90 b/prms/basin.f90 index 7b1ea21e..dae1affa 100644 --- a/prms/basin.f90 +++ b/prms/basin.f90 @@ -166,7 +166,7 @@ INTEGER FUNCTION basdecl() ! when GSFLOW can run in multi-mode will need these arrays IF ( Model/=0 .OR. Cascadegw_flag>0 ) ALLOCATE ( Gwr_route_order(Nhru), Gwr_type(Nhru) ) ! potet_pm, potet_pm_sta, or potet_pt - IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 ) ALLOCATE ( Hru_elev_feet(Nhru) ) + IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Glacier_flag==1 ) ALLOCATE ( Hru_elev_feet(Nhru) ) ! ide_dist, potet_pm, potet_pm_sta, potet_pt, or stream_temp IF ( Precip_flag==5 .OR. Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Stream_temp_flag==1 ) & & ALLOCATE ( Hru_elev_meters(Nhru) ) diff --git a/prms/climateflow.f90 b/prms/climateflow.f90 index b018f69b..229b26df 100644 --- a/prms/climateflow.f90 +++ b/prms/climateflow.f90 @@ -84,7 +84,7 @@ MODULE PRMS_FLOWVARS DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seg_upstream_inflow(:), Seg_lateral_inflow(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seg_outflow(:), Seg_inflow(:) ! glacr - REAL, SAVE, ALLOCATABLE :: Glacier_frac(:), Alt_above_ela(:), Snowfld_frac(:) + REAL, SAVE, ALLOCATABLE :: Glacier_frac(:), Alt_above_ela(:), Glrette_frac(:) ! Declared Parameters REAL, SAVE, ALLOCATABLE :: Soil_moist_max(:), Soil_rechr_max(:), Sat_threshold(:) REAL, SAVE, ALLOCATABLE :: Snowinfil_max(:), Imperv_stor_max(:) @@ -545,10 +545,10 @@ INTEGER FUNCTION climateflow_decl() 'Fraction of glaciation (0=none; 1=100%)', & 'decimal fraction', Glacier_frac)/=0 ) CALL read_error(3, 'glacier_frac') - ALLOCATE ( Snowfld_frac(Nhru) ) - IF ( declvar(MODNAME, 'snowfld_frac', 'nhru', Nhru, 'real', & + ALLOCATE ( Glrette_frac(Nhru) ) + IF ( declvar(MODNAME, 'glrette_frac', 'nhru', Nhru, 'real', & 'Fraction of snow field (too small for glacier dynamics)', & - 'decimal fraction', Snowfld_frac)/=0 ) CALL read_error(3, 'snowfld_frac') + 'decimal fraction', Glrette_frac)/=0 ) CALL read_error(3, 'glrette_frac') ALLOCATE ( Alt_above_ela(Nhru) ) IF ( declvar(MODNAME, 'alt_above_ela', 'nhru', Nhru, 'real', & @@ -1377,7 +1377,7 @@ SUBROUTINE climateflow_restart(In_out) WRITE ( Restart_outunit ) Pkwater_equiv IF ( Glacier_flag==1 ) THEN WRITE ( Restart_outunit) Glacier_frac - WRITE ( Restart_outunit) Snowfld_frac + WRITE ( Restart_outunit) Glrette_frac WRITE ( Restart_outunit) Alt_above_ela ENDIF WRITE ( Restart_outunit ) Soil_moist @@ -1408,7 +1408,7 @@ SUBROUTINE climateflow_restart(In_out) READ ( Restart_inunit ) Pkwater_equiv IF ( Glacier_flag==1 ) THEN READ ( Restart_inunit) Glacier_frac - READ ( Restart_inunit) Snowfld_frac + READ ( Restart_inunit) Glrette_frac READ ( Restart_inunit) Alt_above_ela ENDIF READ ( Restart_inunit ) Soil_moist diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 index e513bf9b..093d4842 100644 --- a/prms/glacr_melt.f90 +++ b/prms/glacr_melt.f90 @@ -26,15 +26,17 @@ ! ! HRUs with glaciers must have parameter glacier_frac(i)=1, unless they ! are at the terminus of the glacier (in which case they can have -! glacier_frac(i)<1). Code assumes there is at least one glacier at the start, but may -! disappear to nothing or just snowfields. +! glacier_frac(i)<1). Hru numbering goes from largest HRU ID at top of glacier to +! smallest at ID at bottom (the way Weasel delineation was designed). The parameter +! Glac_HRUnum_down = 1 then in the init function. If the opposite direction, +! then set Glac_HRUnum_down = 0. IDs need to be stacked. ! ! HRUs containing insubstantial (relative to basin) glaciers have their glaciated -! fraction as snowfld_frac(i)>0 (but <1) +! fraction as glrette_frac(i)>0 (but <1) ! ! NOTE: Multiple branches are possible in the melt generation, but basal topography -!calculations will be mathematically unsound as each branch will be considered a different -! glacier. +! calculations will be mathematically unsound as each branch will be considered a +! different glacier. ! ! modified June 2012 by Steve Regan ! modified Jan 2017 by AE Van Beusekom @@ -53,7 +55,7 @@ MODULE PRMS_GLACR ! Nhrugl - Number of at least partially glacierized hrus at initiation !#of cells=Nhrugl,#of streams=Ntp,#of cells/stream<=Ntp, #of glaciers<=Nhru INTEGER, SAVE :: Nglres, Ngl, Ntp, Nhrugl, MbInit_flag, Output_unit, Fraw_unit, All_unit - INTEGER, SAVE :: Seven, Four + INTEGER, SAVE :: Seven, Four, Glac_HRUnum_down DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_area_inch2(:) REAL, PARAMETER :: Gravity = 9.8 ! m/s2 REAL, PARAMETER :: Aflow = 1.e-25 ! Pa^-3/s, Farinotti 2009 could be 2.4e-24, could be 1e-26 see Patterson 2010 @@ -64,7 +66,7 @@ MODULE PRMS_GLACR !**************************************************************** ! Declared Variables - REAL, SAVE, ALLOCATABLE :: Hru_glres_melt(:), Snowfld_melt(:), Gl_ice_melt(:), Glacr_elev_init(:) + REAL, SAVE, ALLOCATABLE :: Hru_glres_melt(:), Glrette_melt(:), Gl_ice_melt(:), Glacr_elev_init(:) REAL, SAVE, ALLOCATABLE :: Basal_elev(:), Basal_slope(:), Keep_gl(:,:), Prev_outi(:, :), Prev_out(:, :) REAL, SAVE, ALLOCATABLE :: Ode_glacrva_coef(:), Av_basal_slope(:), Av_fgrad(:), Hru_slope_ts(:) REAL, SAVE, ALLOCATABLE :: Hru_mb_yrend(:), Glacr_flow(:), Glacr_slope_init(:), Gl_top_melt(:) @@ -166,15 +168,15 @@ INTEGER FUNCTION glacrdecl() & 'decimal fraction', Hru_slope_ts)/=0 ) CALL read_error(3, 'hru_slope_ts') IF ( declvar(MODNAME, 'basin_gl_top_melt', 'one', 1, 'double', & - & 'Basin area-weighted glacier surface melt (snow, ice and rain) coming out of termini of all glaciers and snowflds', & + & 'Basin area-weighted glacier surface melt (snow, ice and rain) coming out of termini of all glaciers and glrettes', & & 'inches', Basin_gl_top_melt)/=0 ) CALL read_error(3, 'basin_gl_top_melt') IF ( declvar(MODNAME, 'basin_gl_top_gain', 'one', 1, 'double', & - & 'Basin area-weighted glacier surface gain (snow and rain minus evap) for all glaciers and snowflds', & + & 'Basin area-weighted glacier surface gain (snow and rain minus evap) for all glaciers and glrettes', & & 'inches', Basin_gl_top_gain)/=0 ) CALL read_error(3, 'basin_gl_top_gain') IF ( declvar(MODNAME, 'basin_gl_ice_melt', 'one', 1, 'double', & - & 'Basin area-weighted glacier ice (firn) melt coming out of termini of all glaciers and snowflds', & + & 'Basin area-weighted glacier ice (firn) melt coming out of termini of all glaciers and glrettes', & & 'inches', Basin_gl_ice_melt)/=0 ) CALL read_error(3, 'basin_gl_ice_melt') ALLOCATE ( Gl_mb_yrcumul(Nhru) ) @@ -286,10 +288,10 @@ INTEGER FUNCTION glacrdecl() & 'Amount of glacier surface melt (snow, ice, rain) from an HRU that goes into reservoirs', & & 'inches', Hru_glres_melt)/=0 ) CALL read_error(3, 'hru_glres_melt') - ALLOCATE ( Snowfld_melt(Nhru) ) - IF ( declvar(MODNAME, 'snowfld_melt', 'nhru', Nhru, 'real', & - & 'Amount of snow field surface melt (snow, ice, rain) from an HRU', & - & 'inches', Snowfld_melt)/=0 ) CALL read_error(3, 'snowfld_melt') + ALLOCATE ( Glrette_melt(Nhru) ) + IF ( declvar(MODNAME, 'glrette_melt', 'nhru', Nhru, 'real', & + & 'Amount of glacierette surface melt (snow, ice, rain) from an HRU', & + & 'inches', Glrette_melt)/=0 ) CALL read_error(3, 'glrette_melt') ALLOCATE ( Gl_top_melt(Nhru) ) IF ( declvar(MODNAME, 'gl_top_melt', 'nhru', Nhru, 'real', & @@ -442,7 +444,7 @@ INTEGER FUNCTION glacrinit() USE PRMS_MODULE, ONLY: Nhru, Init_vars_from_file USE PRMS_BASIN, ONLY: Hru_area, Hru_elev_ts, Active_hrus, Hru_route_order, & & Hru_type, Basin_area_inv, Hru_elev_meters - USE PRMS_FLOWVARS, ONLY: Glacier_frac, Alt_above_ela, Snowfld_frac + USE PRMS_FLOWVARS, ONLY: Glacier_frac, Alt_above_ela, Glrette_frac IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: getparam, get_ftnunit, compute_ela_aar @@ -513,6 +515,10 @@ INTEGER FUNCTION glacrinit() Basin_gl_storvol = 0.0D0 ENDIF + Glac_HRUnum_down = 0 ! 1 is the way Weasel delineation was designed + ! 1 is terminus is smallest ID and top is largest. IDs are stacked. + ! 0 is terminus is smallest ID and top is largest. IDs are stacked. + hru_flowline = 0 toflowline = 0 str_idm = 1.0E15 @@ -535,9 +541,11 @@ INTEGER FUNCTION glacrinit() IF ( Hru_type(j)==4 ) THEN count = 1 !has at least one glacier glacier_frac_use(j) = 1.0 - !should be end of extensions or branches-- will fail if Weasel doesn't set up this way and then should go off area of branch - IF ( Tohru(j)/=j-1 ) THEN - glacier_frac_use(j) = 0.999 + !should be end of extensions or branches-- will fail if don't set up with indices stacked + IF ( Glac_HRUnum_down==1) THEN + IF (Tohru(j)/=j-1 ) glacier_frac_use(j) = 0.999 + ELSEIF ( Glac_HRUnum_down==0) THEN + IF (Tohru(j)/=j+1 ) glacier_frac_use(j) = 0.999 ENDIF ENDIF ENDDO @@ -698,9 +706,13 @@ INTEGER FUNCTION glacrinit() Hru_area_inch2(j) = Hru_area(j)*Acre_inch2 IF ( Hru_type(j)==4 ) THEN glacier_frac_use(j)= Glacier_frac(j) - !should be end of extensions or branches-- will fail if Weasel doesn't set up this way and then should go off area of branch + !should be end of extensions or branches-- will fail if don't set up with indices stacked ! making it so has no connected branches because branching bottom calculations don't work - IF ( Tohru(j)/=j-1 .AND. glacier_frac_use(j)==1.0) glacier_frac_use(j) = 0.999 + IF ( Glac_HRUnum_down==1) THEN + IF (Tohru(j)/=j-1 .AND. glacier_frac_use(j)==1.0 ) glacier_frac_use(j) = 0.999 + ELSEIF ( Glac_HRUnum_down==0) THEN + IF (Tohru(j)/=j+1 .AND. glacier_frac_use(j)==1.0 ) glacier_frac_use(j) = 0.999 + ENDIF ENDIF ENDDO CALL tag_count(0, hru_flowline, toflowline, glacier_frac_use) @@ -749,6 +761,7 @@ INTEGER FUNCTION glacrinit() !ENDDO Gl_area = 0.D0 Basin_gl_area = 0.D0 + DO o = 1, Ngl p = Glacr_tag(Term(o)) !index by Glacr_tag Basin_gl_area = Basin_gl_area + curr_area(Term(o)) @@ -757,7 +770,7 @@ INTEGER FUNCTION glacrinit() ENDDO DO i = 1, Active_hrus j = Hru_route_order(i) - IF ( Hru_type(j)==1 ) Basin_gl_area = Basin_gl_area + DBLE(Snowfld_frac(j))*Hru_area_inch2(j) + IF ( Hru_type(j)==1 ) Basin_gl_area = Basin_gl_area + DBLE(Glrette_frac(j))*Hru_area_inch2(j) ENDDO ! doela = compute_ela_aar() !no previous years MB, get ELA from AAR ratio, need Prev_area @@ -786,7 +799,7 @@ INTEGER FUNCTION glacrrun() USE PRMS_GLACR USE PRMS_BASIN, ONLY: Hru_elev_ts, Active_hrus, Hru_route_order, Hru_type, NEARZERO, & & Elev_units, Hru_elev_feet, Hru_elev_meters, FEET2METERS, METERS2FEET - USE PRMS_FLOWVARS, ONLY: Alt_above_ela, Snowfld_frac + USE PRMS_FLOWVARS, ONLY: Alt_above_ela, Glrette_frac IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: comp_glsurf, recompute_soltab @@ -800,7 +813,7 @@ INTEGER FUNCTION glacrrun() DO j = 1, Active_hrus i = Hru_route_order(j) IF ( Hru_type(i)==1 ) THEN - IF (Snowfld_frac(j)>NEARZERO) THEN + IF (Glrette_frac(j)>NEARZERO) THEN count=1 !has at least one snowfield EXIT ENDIF @@ -860,7 +873,7 @@ END FUNCTION glacrrun ! function comp_glsurf - Computes surface runoff using contributing area ! computations !*********************************************************************** - INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) + INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) USE PRMS_GLACR USE PRMS_MODULE, ONLY: Nhru, Starttime USE PRMS_BASIN, ONLY: Hru_type, Hru_elev_ts, Basin_area_inv, Active_hrus, & @@ -868,8 +881,8 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Julwater USE PRMS_INTCP, ONLY: Net_rain, Net_snow USE PRMS_SNOW, ONLY: Snowcov_area, Snowmelt, Glacrmelt, Glacr_air_deltemp, Glacr_delsnow, & - & Snowfld_frac_init, Snowcov_area, Basin_snowicecov, Snow_evap, Glacr_evap, Basin_glacrb_melt - USE PRMS_FLOWVARS, ONLY: Glacier_frac, Alt_above_ela, Snowfld_frac + & Glrette_frac_init, Snowcov_area, Basin_snowicecov, Snow_evap, Glacr_evap, Basin_glacrb_melt + USE PRMS_FLOWVARS, ONLY: Glacier_frac, Alt_above_ela, Glrette_frac IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: get_ftnunit, compute_ela_mb, compute_ela_aar, recompute_soltab @@ -888,7 +901,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) DOUBLE PRECISION :: in_top_melt_tot(3), in_top_melt(3, Nhru), tot_delta_mb(Nhru), add_area(Nhru) DOUBLE PRECISION :: tot_reservi(3),in_top_melt_itot(3), in_top_melt_ice(3, Nhru), curr_areap(Nhru) ! Arguments - INTEGER, INTENT(IN) :: glacr_exist, snowfld_exist + INTEGER, INTENT(IN) :: glacr_exist, glrette_exist !*********************************************************************** comp_glsurf = 1 dobot = 1 ! 1 calls bottom calcs, 0 doesn't: Set to 0 for calibrating, then run one extra step with it on @@ -918,7 +931,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) Basin_gl_top_gain = 0.0D0 Basin_gl_ice_melt = 0.0D0 Hru_glres_melt = 0.0 - Snowfld_melt = 0.0 + Glrette_melt = 0.0 Gl_top_melt = 0.0 Gl_ice_melt = 0.0 Glacr_flow = 0.0 @@ -962,10 +975,13 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) j = Hru_route_order(jj) IF ( Hru_type(j)==4 ) THEN glacier_frac_use(j)= Glacier_frac(j) - !should be end of extensions or branches-- will fail if Weasel doesn't set up this way, - ! and then should go off area of branch + !should be end of extensions or branches-- will fail if don't set up with indices stacked ! making it so has no connected branches because branching bottom calculations don't work - IF ( Tohru(j)/=j-1 .AND. glacier_frac_use(j)==1.0) glacier_frac_use(j) = 0.999 + IF ( Glac_HRUnum_down==1) THEN + IF (Tohru(j)/=j-1 .AND. glacier_frac_use(j)==1.0 ) glacier_frac_use(j) = 0.999 + ELSEIF ( Glac_HRUnum_down==0) THEN + IF (Tohru(j)/=j+1 .AND. glacier_frac_use(j)==1.0 ) glacier_frac_use(j) = 0.999 + ENDIF ENDIF ENDDO CALL tag_count(0, hru_flowline, toflowline, glacier_frac_use) @@ -1342,23 +1358,23 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) ENDIF !Snowfield area change uses Baumann and Winkler 2010 to change area every 10 years; ! technically each snowfield should have own ablation elevation range. - IF (snowfld_exist==1) THEN !have snowfields, + IF (glrette_exist==1) THEN !have snowfields, IF ( MOD(Nowyear-Starttime(1),10)==0 ) THEN !change them DO i = 1, Active_hrus j = Hru_route_order(i) - IF ( Hru_type(j)==1 .AND. Snowfld_frac(j)>NEARZERO) THEN - IF ( Elev_units==0 ) Snowfld_frac(j) = ( METERS2FEET*(45.7*Glacr_air_deltemp(j) & - & -12.0*Glacr_delsnow(j))/Abl_elev_range(j) +1.0 )*Snowfld_frac_init(j) - IF ( Elev_units==1 ) Snowfld_frac(j) = ( (45.7*Glacr_air_deltemp(j) & - & -12.0*Glacr_delsnow(j))/Abl_elev_range(j) +1.0 )*Snowfld_frac_init(j) - IF ( Snowfld_frac(j)<0.0 ) Snowfld_frac(j)=0.0 - IF ( Snowfld_frac(j)>1.0 ) Snowfld_frac(j)=1.0 + IF ( Hru_type(j)==1 .AND. Glrette_frac(j)>NEARZERO) THEN + IF ( Elev_units==0 ) Glrette_frac(j) = ( METERS2FEET*(45.7*Glacr_air_deltemp(j) & + & -12.0*Glacr_delsnow(j))/Abl_elev_range(j) +1.0 )*Glrette_frac_init(j) + IF ( Elev_units==1 ) Glrette_frac(j) = ( (45.7*Glacr_air_deltemp(j) & + & -12.0*Glacr_delsnow(j))/Abl_elev_range(j) +1.0 )*Glrette_frac_init(j) + IF ( Glrette_frac(j)<0.0 ) Glrette_frac(j)=0.0 + IF ( Glrette_frac(j)>1.0 ) Glrette_frac(j)=1.0 ENDIF ENDDO ENDIF DO i = 1, Active_hrus !every year j = Hru_route_order(i) - Basin_gl_area = Basin_gl_area + DBLE(Snowfld_frac(j))*Hru_area_inch2(j) !keep in inches + Basin_gl_area = Basin_gl_area + DBLE(Glrette_frac(j))*Hru_area_inch2(j) !keep in inches ENDDO ENDIF @@ -1391,13 +1407,13 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) ENDIF ENDIF IF ( Hru_type(j)==1 ) THEN - Snowfld_melt(j) = 0.0 + Glrette_melt(j) = 0.0 !melting ice + melting snow (energy model), *area = volume - IF ( Snowfld_frac(j)>NEARZERO ) THEN - Snowfld_melt(j) = Snowfld_frac(j)*(Snowmelt(j) + Glacrmelt(j)/Snowfld_frac(j)) - Snowmelt(j) = (1.0 - Snowfld_frac(j))*Snowmelt(j) ! this is the snowmelt that is not included in Snow field melt - gl_snow = Snowfld_frac(j)*(Net_rain(j)+Net_Snow(j)) !Pk_precip is zero if no snow, so don't use - gl_evap = Snowfld_frac(j)*(Snow_evap(j) + Glacr_evap(j)/Snowfld_frac(j)) + IF ( Glrette_frac(j)>NEARZERO ) THEN + Glrette_melt(j) = Glrette_frac(j)*(Snowmelt(j) + Glacrmelt(j)/Glrette_frac(j)) + Snowmelt(j) = (1.0 - Glrette_frac(j))*Snowmelt(j) ! this is the snowmelt that is not included in glacierette melt + gl_snow = Glrette_frac(j)*(Net_rain(j)+Net_Snow(j)) !Pk_precip is zero if no snow, so don't use + gl_evap = Glrette_frac(j)*(Snow_evap(j) + Glacr_evap(j)/Glrette_frac(j)) gl_gain(j) = DBLE(gl_snow - gl_evap) ENDIF ENDIF @@ -1569,17 +1585,17 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, snowfld_exist) ENDDO ENDIF ! - IF (snowfld_exist==1) THEN + IF (glrette_exist==1) THEN DO i = 1, Active_hrus j = Hru_route_order(i) - IF ( Hru_type(j)==1 .AND. Snowfld_frac(j)>NEARZERO) THEN + IF ( Hru_type(j)==1 .AND. Glrette_frac(j)>NEARZERO) THEN ! all excess rain is included in melt, should be true unless Glacrmelt==0 - IF ( Glacrmelt(j)-Net_rain(j)*Snowfld_frac(j)>NEARZERO ) & - & Basin_gl_ice_melt = Basin_gl_ice_melt + DBLE(Glacrmelt(j)-Net_rain(j)*Snowfld_frac(j))*Hru_area_inch2(j) - Basin_gl_top_melt = Basin_gl_top_melt + DBLE(Snowfld_melt(j))*Hru_area_inch2(j) + IF ( Glacrmelt(j)-Net_rain(j)*Glrette_frac(j)>NEARZERO ) & + & Basin_gl_ice_melt = Basin_gl_ice_melt + DBLE(Glacrmelt(j)-Net_rain(j)*Glrette_frac(j))*Hru_area_inch2(j) + Basin_gl_top_melt = Basin_gl_top_melt + DBLE(Glrette_melt(j))*Hru_area_inch2(j) Basin_gl_top_gain = Basin_gl_top_gain + DBLE(gl_gain(j))*Hru_area_inch2(j) - Basin_snowicecov = Basin_snowicecov + DBLE(( 1.-Snowcov_area(j) )*Snowfld_frac(j))*Hru_area_inch2(j) - Glacr_flow(j) = REAL(Snowfld_melt(j)*Hru_area_inch2(j)) + Basin_snowicecov = Basin_snowicecov + DBLE(( 1.-Snowcov_area(j) )*Glrette_frac(j))*Hru_area_inch2(j) + Glacr_flow(j) = REAL(Glrette_melt(j)*Hru_area_inch2(j)) ENDIF ENDDO ENDIF diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index 7abd6cfa..d07f83d7 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -64,7 +64,7 @@ MODULE PRMS_SNOW REAL, SAVE, ALLOCATABLE :: Rad_trncf(:), Snarea_thresh(:), Snowpack_init(:) REAL, SAVE, ALLOCATABLE :: Snarea_curve(:, :) REAL, SAVE, ALLOCATABLE :: Glacr_layer(:), Albedo_coef(:), Albedo_ice(:) - REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_cap(:), Glacier_frac_init(:), Snowfld_frac_init(:) + REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_cap(:), Glacier_frac_init(:), Glrette_frac_init(:) END MODULE PRMS_SNOW @@ -169,37 +169,37 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Glacr_air_avtemp(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_avtemp', 'nhru', Nhru, 'real', & - & 'Current average year air temperature over glacier or snowfld HRU', & + & 'Current average year air temperature over glacier or glrette HRU', & & 'degrees Celsius', Glacr_air_avtemp)/=0 ) CALL read_error(3, 'glacr_air_avtemp') ALLOCATE ( Glacr_air_5avtemp(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_5avtemp', 'nhru', Nhru, 'real', & - & 'Current 5-yr average summer (June July Aug) air temperature over glacier or snowfld HRU', & + & 'Current 5-yr average summer (June July Aug) air temperature over glacier or glrette HRU', & & 'degrees Celsius', Glacr_air_5avtemp)/=0 ) CALL read_error(3, 'glacr_air_5avtemp') ALLOCATE ( Glacr_air_5avtemp1(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_5avtemp1', 'nhru', Nhru, 'real', & - & 'First 5-yr average summer temperature over glacier or snowfld HRU', & + & 'First 5-yr average summer temperature over glacier or glrette HRU', & & 'degrees Celsius', Glacr_air_5avtemp1)/=0 ) CALL read_error(3, 'glacr_air_5avtemp1') ALLOCATE ( Glacr_air_deltemp(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_deltemp', 'nhru', Nhru, 'real', & - & 'Change in 5-yr average air temperature over glacier or snowfld HRU from first', & + & 'Change in 5-yr average air temperature over glacier or glrette HRU from first', & & 'degrees Celsius', Glacr_air_deltemp)/=0 ) CALL read_error(3, 'glacr_air_deltemp') ALLOCATE ( Glacr_5avsnow(Nhru) ) IF ( declvar(MODNAME, 'glacr_5avsnow', 'nhru', Nhru, 'real', & - & 'Current 5-yr average snow over glacier or snowfld HRU', & + & 'Current 5-yr average snow over glacier or glrette HRU', & & 'inches/yr', Glacr_5avsnow)/=0 ) CALL read_error(3, 'glacr_5avsnow') ALLOCATE ( Glacr_5avsnow1(Nhru) ) IF ( declvar(MODNAME, 'glacr_5avsnow1', 'nhru', Nhru, 'real', & - & 'First 5-yr average snow over glacier or snowfld HRU', & + & 'First 5-yr average snow over glacier or glrette HRU', & & 'inches/yr', Glacr_5avsnow1)/=0 ) CALL read_error(3, 'glacr_5avsnow1') ALLOCATE ( Glacr_delsnow(Nhru) ) IF ( declvar(MODNAME, 'glacr_delsnow', 'nhru', Nhru, 'real', & - & 'Change in 5-yr average snow over glacier or snowfld HRU from first', & + & 'Change in 5-yr average snow over glacier or glrette HRU from first', & & 'inches/yr', Glacr_delsnow)/=0 ) CALL read_error(3, 'glacr_delsnow') ALLOCATE ( Glacr_pk_temp(Nhru) ) @@ -249,7 +249,7 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Glacrcov_area(Nhru) ) IF ( declvar(MODNAME, 'glacrcov_area', 'nhru', Nhru, 'real', & - & 'Ice-covered area on each glacier HRU or HRU with snow field at start of step', & + & 'Ice-covered area on each glacier HRU or HRU with glacierette at start of step', & & 'decimal fraction', Glacrcov_area)/=0 ) CALL read_error(3, 'glacrcov_area') ALLOCATE ( Glacr_pk_ice(Nhru) ) @@ -278,7 +278,7 @@ INTEGER FUNCTION snodecl() & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & - & 'Basin area-weighted average snow and glacier and snowfld covered area', & + & 'Basin area-weighted average snow and glacier and glrette covered area', & & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) @@ -305,12 +305,12 @@ INTEGER FUNCTION snodecl() & 'Inital fraction of glaciation (0=none; 1=100%)', & & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') - ALLOCATE ( Snowfld_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'snowfld_frac_init', 'nhru', 'real', & + ALLOCATE ( Glrette_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glrette_frac_init', 'nhru', 'real', & & '0.0', '0.0', '1.0', & - & 'Initial fraction of snow field (too small for glacier dynamics)', & - & 'Initial fraction of snow field (too small for glacier dynamics)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'snowfld_frac_init') + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glrette_frac_init') ENDIF ENDIF @@ -661,7 +661,7 @@ INTEGER FUNCTION snoinit() USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_route_order, Active_hrus, Hru_area_dble, & & FEET2METERS, Elev_units, Hru_type ! USE PRMS_BASIN, ONLY: Hru_elev_feet - USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Snowfld_frac, Alt_above_ela + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Glrette_frac, Alt_above_ela IMPLICIT NONE ! Functions INTRINSIC :: DBLE, ATAN, SNGL @@ -763,8 +763,8 @@ INTEGER FUNCTION snoinit() IF ( getparam(MODNAME, 'glacier_frac_init', Nhru, 'real', Glacier_frac_init)/=0 ) CALL read_error(2, 'glacier_frac_init') Glacr_albedo = 0.0 Glacier_frac = Glacier_frac_init - IF ( getparam(MODNAME, 'snowfld_frac_init', Nhru, 'real', Snowfld_frac_init)/=0 ) CALL read_error(2, 'snowfld_frac_init') - Snowfld_frac = Snowfld_frac_init + IF ( getparam(MODNAME, 'glrette_frac_init', Nhru, 'real', Glrette_frac_init)/=0 ) CALL read_error(2, 'glrette_frac_init') + Glrette_frac = Glrette_frac_init DO j = 1, Active_hrus i = Hru_route_order(j) IF ( Glacier_frac(i)>0.0 ) THEN @@ -780,13 +780,13 @@ INTEGER FUNCTION snoinit() Glacier_frac(i) = 0.0 ENDIF ENDIF - IF ( Snowfld_frac(i)>0.0 ) THEN + IF ( Glrette_frac(i)>0.0 ) THEN IF ( Hru_type(i)==1 ) THEN Glacr_albedo(i) = Albedo_ice(i) ELSE - PRINT *, 'Warning, snowfld_frac > 0, but hru_type not equal to 1, snowfld_frac set to 0' - PRINT *, 'in HRU ', i, 'snowfld_frac_init = ',Snowfld_frac_init(i) - Snowfld_frac(i) = 0.0 + PRINT *, 'Warning, glrette_frac > 0, but hru_type not equal to 1, glrette_frac set to 0' + PRINT *, 'in HRU ', i, 'glrette_frac_init = ',Glrette_frac_init(i) + Glrette_frac(i) = 0.0 ENDIF ENDIF ENDDO @@ -874,7 +874,7 @@ INTEGER FUNCTION snorun() & Basin_area_inv, Hru_route_order, Cov_type, INCH2M, FEET2METERS, Elev_units USE PRMS_CLIMATEVARS, ONLY: Newsnow, Pptmix, Orad, Basin_horad, Potet_sublim, & & Hru_ppt, Prmx, Tmaxc, Tminc, Tavgc, Swrad, Potet, Transp_on, Tmax_allsnow_c - USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Snowfld_frac, Alt_above_ela + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Glrette_frac, Alt_above_ela USE PRMS_SET_TIME, ONLY: Jday, Nowmonth, Julwater, Nowyear USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Canopy_covden, Hru_intcpevap IMPLICIT NONE @@ -924,9 +924,9 @@ INTEGER FUNCTION snorun() Glacrb_melt(i) = 0.0 ! [inches] Glacr_evap(i) = 0.0 ! [inches] Glacr_pkwater_ante(i) = Glacr_pkwater_equiv(i) - IF ( Glacier_frac(i)>0.0 .OR. Snowfld_frac(i)>0.0 ) THEN + IF ( Glacier_frac(i)>0.0 .OR. Glrette_frac(i)>0.0 ) THEN IF (Glacier_frac(i)>0.0) Active_glacier = 1 - IF (Snowfld_frac(i)>0.0) Active_glacier = 2 + IF (Glrette_frac(i)>0.0) Active_glacier = 2 Glacr_pk_den(i) = 0.917 ! if melted whole active layer make 0 deg and no holding capacity IF ( Glacr_layer(i)==0.0 .OR. Glacr_pk_depth(i)>1.0D3 ) THEN @@ -991,7 +991,7 @@ INTEGER FUNCTION snorun() Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) ENDIF ENDIF - IF ( Active_glacier==2 ) Glacr_albedo(i) = Albedo_ice(i) !glacr_albedo doesn't change if snow field but could get zeroed out + IF ( Active_glacier==2 ) Glacr_albedo(i) = Albedo_ice(i) !glacr_albedo doesn't change if glacierette but could get zeroed out IF ( isglacier==1 ) THEN IF (Nowyear >= Starttime(1)+10 .AND. MOD(Nowyear-Starttime(1),5)==0 ) THEN Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 10 years of data @@ -1068,7 +1068,7 @@ INTEGER FUNCTION snorun() ! initial snow covered area is complete (1) IF ( Newsnow(i)==1 .AND. Pkwater_equiv(i)0.0D0 ) THEN @@ -1447,7 +1447,7 @@ INTEGER FUNCTION snorun() frac = 1.0 IF ( Active_glacier==1 ) frac = (1.0 - Glacier_frac(i)) - IF ( Active_glacier==2 ) frac = (1.0 - Snowfld_frac(i)) + IF ( Active_glacier==2 ) frac = (1.0 - Glrette_frac(i)) ! Sum volumes for basin totals Basin_snowmelt = Basin_snowmelt + DBLE( Snowmelt(i)*Hru_area(i)*frac ) !don't include stuff melting into glacier Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*DBLE( Hru_area(i)*frac ) !don't include stuff melting into glacier From c2f33dadf689e41ca012c9c247d011a1785e7ae9 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Thu, 27 Jun 2019 16:18:22 -0500 Subject: [PATCH 16/47] fixed snow density issue when change from melting snow to glacier underneath --- prms/snowcomp.f90 | 107 ++++++++++++++-------------------------------- 1 file changed, 33 insertions(+), 74 deletions(-) diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index d07f83d7..c9699105 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -47,7 +47,7 @@ MODULE PRMS_SNOW REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_capm(:), Frac_swe(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Pk_depth(:), Pkwater_ante(:), Ai(:) REAL, SAVE, ALLOCATABLE :: Glacrmelt(:), Glacr_evap(:), Glacr_albedo(:), Glacr_pk_den(:) - REAL, SAVE, ALLOCATABLE :: Glacr_pk_ice(:), Glacr_freeh2o(:), Glacrcov_area(:), Glacr_tcal(:) + REAL, SAVE, ALLOCATABLE :: Glacr_pk_ice(:), Glacr_freeh2o(:), Glacrcov_area(:) REAL, SAVE, ALLOCATABLE :: Glacrb_melt(:), Glacr_pk_def(:), Glacr_pk_temp(:), Glacr_air_avtemp(:) REAL, SAVE, ALLOCATABLE :: Glacr_air_5avtemp1(:), Glacr_air_deltemp(:), Glacr_air_5avtemp(:) REAL, SAVE, ALLOCATABLE :: Glacr_5avsnow1(:), Glacr_5avsnow(:),Glacr_delsnow(:) @@ -217,11 +217,6 @@ INTEGER FUNCTION snodecl() & 'Density of the icepack on each glacier HRU, hard-coded to equal 0.917', & & 'gm/cm3', Glacr_pk_den)/=0 ) CALL read_error(3, 'glacr_pk_den') - ALLOCATE ( Glacr_tcal(Nhru) ) - IF ( declvar(MODNAME, 'glacr_tcal', 'nhru', Nhru, 'real', & - & 'Net icepack energy balance on each glacier HRU', & - & 'Langleys', Glacr_tcal)/=0 ) CALL read_error(3, 'glacr_tcal') - ALLOCATE ( Glacr_albedo(Nhru) ) IF ( declvar(MODNAME, 'glacr_albedo', 'nhru', Nhru, 'real', & & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier HRU', & @@ -666,10 +661,9 @@ INTEGER FUNCTION snoinit() ! Functions INTRINSIC :: DBLE, ATAN, SNGL INTEGER, EXTERNAL :: getparam - EXTERNAL :: read_error, snowcomp_restart, sca_deplcrv + EXTERNAL :: read_error, snowcomp_restart, sca_deplcrv, glacr_states_to_zero ! Local Variables INTEGER :: i, j - REAL :: reduce ! Save Variables REAL, SAVE :: acum_init(MAXALB), amlt_init(MAXALB) DATA acum_init/.80, .77, .75, .72, .70, .69, .68, .67, .66, .65, .64, .63, .62, .61, .60/ @@ -829,12 +823,12 @@ INTEGER FUNCTION snoinit() Glacr_delsnow = 0.0 Glacrb_melt = 0.0 Glacrmelt = 0.0 - Glacr_tcal = 0.0 - Glacr_pk_den = 0.917 + Glacr_pk_den = 0.0 Glacr_pk_temp = 0.0 Glacr_pk_ice = 0.0 Glacr_pk_def = 0.0 Glacr_pkwater_equiv = 0.0D0 + Glacr_pkwater_ante = 0.0D0 Glacr_evap = 0.0 Glacr_freeh2o = 0.0 Glacr_pk_depth = 0.0D0 @@ -844,22 +838,8 @@ INTEGER FUNCTION snoinit() Glacr_freeh2o_capm = Glacr_freeh2o_cap DO j = 1, Active_hrus i = Hru_route_order(j) - IF ( Glacier_frac(i)>0.0 ) THEN - IF ( Hru_type(i)==4 ) THEN - Glacr_pk_depth(i) = DBLE(Glacr_layer(i)) - reduce = 0.8 !if start Glacr_pk_ice too close to Glacr_pk_depth can't grow with energy loss to free water gain - IF ( Glacr_layer(i)==0.0 ) THEN - Glacr_pk_depth(i) = 1.0D5 - Glacr_freeh2o_capm(i) = 0.0 - reduce = 1.0 - ENDIF - Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) - Glacr_pk_ice(i) = reduce*(SNGL(Glacr_pkwater_equiv(i)) - Glacr_freeh2o(i))/0.9340 !density of pure ice - ENDIF - ENDIF + IF ( Glacier_frac(i)>0.0 .AND. Hru_type(i)==4 ) CALL glacr_states_to_zero(i,1) ENDDO - Glacr_pkwater_ante = Glacr_pkwater_equiv - Glacr_pss = Glacr_pkwater_equiv ENDIF END FUNCTION snoinit @@ -928,7 +908,7 @@ INTEGER FUNCTION snorun() IF (Glacier_frac(i)>0.0) Active_glacier = 1 IF (Glrette_frac(i)>0.0) Active_glacier = 2 Glacr_pk_den(i) = 0.917 - ! if melted whole active layer make 0 deg and no holding capacity + ! if no active layer make 0 deg and no holding capacity at start of each day IF ( Glacr_layer(i)==0.0 .OR. Glacr_pk_depth(i)>1.0D3 ) THEN Glacr_pk_def(i) = 0.0 Glacr_pk_temp(i) = 0.0 @@ -965,7 +945,7 @@ INTEGER FUNCTION snorun() Lso(i) = 0 ! [counter] - IF ( Active_glacier>=1 ) CALL glacr_states_to_zero(i) !all snow on glacier becomes firn, + IF ( Active_glacier>=1 ) CALL glacr_states_to_zero(i,1) !all snow on glacier becomes firn, reset active layer thickness IF ( Active_glacier==1 ) THEN !do not zero out snowpack for snowfields because a lot is off glacier ! snow will melt more than should on snowfields if include a lot of low elevation ! if terminus glacier, and has snow will disappear off glacier but that is likely anyhow @@ -1289,16 +1269,6 @@ INTEGER FUNCTION snorun() & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) - ! track total heat flux from both night and day periods - IF ( Glacr_pk_depth(i)<=0.0D0 ) THEN ! make infinite and 0 deg and no freewater capacity - ! should be just 0.0 but just in case - Glacr_pk_depth(i) = 1.0D5 - Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) - Glacr_pk_ice(i) = SNGL(Glacr_pkwater_equiv(i)-Glacr_freeh2o(i))/0.9340 !density of pure ice - Glacr_pk_temp(i) = 0.0 - Glacr_pk_def(i) = 0.0 - Glacr_freeh2o_capm(i) = 0.0 - ENDIF ENDIF ENDIF @@ -1332,18 +1302,6 @@ INTEGER FUNCTION snorun() & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) - ! track total heat flux from both night and day periods - if(isnan(Glacrmelt(i)).OR. abs(Glacrmelt(i))>1.e15) & - Glacr_tcal(i) = Glacr_tcal(i) + icals ! [cal/cm^2] or [Langleys] - IF ( Glacr_pk_depth(i)<=0.0D0 ) THEN ! make infinite and 0 deg and no freewater capacity - ! should be just 0.0 but just in case - Glacr_pk_depth(i) = 1.0D5 - Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) - Glacr_pk_ice(i) = SNGL(Glacr_pkwater_equiv(i))*0.9340 !density of pure ice - Glacr_pk_temp(i) = 0.0 - Glacr_pk_def(i) = 0.0 - Glacr_freeh2o_capm(i) = 0.0 - ENDIF ENDIF ENDIF @@ -1436,12 +1394,7 @@ INTEGER FUNCTION snorun() IF ( Glacr_pkwater_equiv(i)>0.0D0 ) THEN Glacr_pk_depth(i) = Glacr_pkwater_equiv(i)/DBLE(Glacr_pk_den(i)) ELSE - Glacr_pk_depth(i) = 1.0D5 - Glacr_pkwater_equiv(i) = Glacr_pk_den(i)*Glacr_pk_depth(i) - Glacr_pk_ice(i) = SNGL(Glacr_pkwater_equiv(i)-Glacr_freeh2o(i))/0.9340 !density of pure ice - Glacr_pk_temp(i) = 0.0 - Glacr_pk_def(i) = 0.0 - Glacr_freeh2o_capm(i) = 0.0 + CALL glacr_states_to_zero(i,0) ENDIF ENDIF @@ -1810,9 +1763,8 @@ SUBROUTINE caloss(Cal, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) ! IF ( Pkwater_equiv<-DNEARZERO ) & ! & PRINT *, 'snowpack issue 4, negative pkwater_equiv', Pkwater_equiv Pkwater_equiv = 0.0D0 - ! Snowpack or glacr layer has been completely depleted, reset all states to no-snowpack values - ! If melting glacier can still be snow, Ihru_gl >0 signifies glacier caloss - If (Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl) + ! If on melting glacier ice/firn, Ihru_gl >0, so melted active layer (won't melt infinite ice layer) + If (Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl,0) ENDIF END SUBROUTINE caloss @@ -1902,10 +1854,16 @@ SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & ! if on snow over glacier or active_layer and have excess energy from day over ! depth can melt from layer thickness, add depth to that layer IF ( pmlt>apk_ice .AND. Active_glacier>=1 ) THEN + !fractionate density with snow/active layer melting vs extra ice underneath melting + Pk_den = Pk_den*SNGL(apk_ice/pmlt) + 0.917*SNGL((pmlt-apk_ice)/pmlt) apk_ice = pmlt - Pk_ice = apk_ice*Snowcov_area - Pkwater_equiv = Freeh2o + apmlt - Freeh2o_cap*(Pk_ice - apmlt) - Pk_depth = 0.0D0 + Pk_ice = apmlt + Pkwater_equiv = apmlt + Freeh2o = 0.0 ! [inches] + Iasw = 0 + Pk_def = 0.0 ! [cal / cm^2] + Pk_temp = 0.0 ! [degreees C] + Pst = 0.0D0 ! [inches] ENDIF IF ( pmlt>apk_ice ) THEN ! will not happen if Active_glacier>=1 because of above @@ -1974,8 +1932,9 @@ SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & Pk_temp = 0.0 ! [degrees C] Pk_def = 0.0 ! [cal/cm^2] ENDIF - IF ( Pkwater_equiv<=0.0D0 .AND. Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl) - ! Snowpack on glacier has been completely depleted, reset all states to no-snowpack values + IF ( Pkwater_equiv<=0.0D0 ) Pk_den = 0.0 + ! If on melting glacier ice/firn, Ihru_gl >0, so melted active layer (won't melt infinite ice layer) + IF ( Pkwater_equiv<=0.0D0 .AND. Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl,0) END SUBROUTINE calin @@ -2833,30 +2792,32 @@ END SUBROUTINE sca_deplcrv !*********************************************************************** ! Set all glacier states to 0 !*********************************************************************** - SUBROUTINE glacr_states_to_zero(Ihru) + SUBROUTINE glacr_states_to_zero(Ihru, active_layer_present) USE PRMS_SNOW, ONLY: Glacr_freeh2o_cap, Glacr_freeh2o_capm, Glacr_pk_def, Glacr_pk_depth, & & Glacr_layer, Glacr_pk_temp, Glacr_air_avtemp, Glacr_pkwater_equiv, Glacr_pk_den, & - & Glacr_pk_ice, Glacr_pkwater_ante, Glacr_freeh2o, Glacr_pss + & Glacr_pk_ice, Glacr_pkwater_ante, Glacr_freeh2o, Glacr_pss, Glacr_pk_den IMPLICIT NONE ! Arguments - INTEGER, INTENT(IN) :: Ihru + INTEGER, INTENT(IN) :: Ihru, active_layer_present ! Functions INTRINSIC ATAN, SNGL ! Local Variables REAL :: reduce !*********************************************************************** - Glacr_freeh2o_capm(Ihru) = Glacr_freeh2o_cap(Ihru) - Glacr_pk_depth(Ihru) = DBLE(Glacr_layer(Ihru)) - Glacr_pk_temp(Ihru) = Glacr_air_avtemp(Ihru) !start at average last year temp like Oerlemans 1992 - reduce = 0.8 !if start Glacr_pk_ice too close to Glacr_pk_depth can't grow with energy loss to free water gain - IF ( Glacr_pk_temp(Ihru) > 0.0) Glacr_pk_temp(Ihru) = 0.0 - IF ( Glacr_layer(Ihru)==0.0 ) THEN + IF ( Glacr_layer(Ihru)==0.0 .OR. active_layer_present==0) THEN Glacr_pk_depth(Ihru) = 1.0D5 Glacr_pk_temp(Ihru) = 0.0 Glacr_pk_def(Ihru) = 0.0 Glacr_freeh2o_capm(Ihru) = 0.0 reduce = 1.0 + ElSE + Glacr_pk_depth(Ihru) = DBLE(Glacr_layer(Ihru)) + Glacr_pk_temp(Ihru) = Glacr_air_avtemp(Ihru) !start at average last year temp like Oerlemans 1992 + IF ( Glacr_pk_temp(Ihru) > 0.0) Glacr_pk_temp(Ihru) = 0.0 + Glacr_freeh2o_capm(Ihru) = Glacr_freeh2o_cap(Ihru) + reduce = 0.8 !if start Glacr_pk_ice too close to Glacr_pk_depth can't grow with energy loss to free water gain ENDIF + Glacr_pk_den(Ihru) = 0.917 Glacr_pkwater_equiv(Ihru) = Glacr_pk_den(Ihru)*Glacr_pk_depth(Ihru) Glacr_pkwater_ante(Ihru) = Glacr_pkwater_equiv(Ihru) Glacr_pk_ice(Ihru) = reduce*SNGL(Glacr_pkwater_equiv(Ihru)-Glacr_freeh2o(Ihru))/0.9340 !density of pure ice @@ -2913,7 +2874,6 @@ SUBROUTINE snowcomp_restart(In_out) WRITE ( Restart_outunit ) Glacr_pk_ice WRITE ( Restart_outunit ) Glacr_freeh2o WRITE ( Restart_outunit ) Glacrcov_area - WRITE ( Restart_outunit ) Glacr_tcal WRITE ( Restart_outunit ) Glacr_pss WRITE ( Restart_outunit ) Glacr_pst WRITE ( Restart_outunit ) Glacr_pk_depth @@ -2964,7 +2924,6 @@ SUBROUTINE snowcomp_restart(In_out) READ ( Restart_inunit ) Glacr_pk_ice READ ( Restart_inunit ) Glacr_freeh2o READ ( Restart_inunit ) Glacrcov_area - READ ( Restart_inunit ) Glacr_tcal READ ( Restart_inunit ) Glacr_pss READ ( Restart_inunit ) Glacr_pst READ ( Restart_inunit ) Glacr_pk_depth From dfff6bf293b7c5949dd20c0e5fbb220fd6c1ca1f Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Fri, 28 Jun 2019 09:29:03 -0500 Subject: [PATCH 17/47] changed glacier delineation to read the way the weasel makes it --- prms/glacr_melt.f90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 index 093d4842..ebc429db 100644 --- a/prms/glacr_melt.f90 +++ b/prms/glacr_melt.f90 @@ -515,7 +515,7 @@ INTEGER FUNCTION glacrinit() Basin_gl_storvol = 0.0D0 ENDIF - Glac_HRUnum_down = 0 ! 1 is the way Weasel delineation was designed + Glac_HRUnum_down = 1 ! 1 is the way Weasel delineation was designed ! 1 is terminus is smallest ID and top is largest. IDs are stacked. ! 0 is terminus is smallest ID and top is largest. IDs are stacked. @@ -808,7 +808,6 @@ INTEGER FUNCTION glacrrun() !*********************************************************************** glacrrun = 0 count = 0 - ! DO j = 1, Active_hrus i = Hru_route_order(j) From fa2aefae7716f3987ea3208033ca4602dccacf67 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 9 Jul 2019 17:04:22 -0600 Subject: [PATCH 18/47] Fixed some flag bugs and added logic in snowcomp wether we want to zero out snowpack into firn or not on glacierettes (zeroed in Copper application, thinking don't want to now). --- prms/basin.f90 | 8 +++--- prms/routing.f90 | 29 +++++++++---------- prms/routingRip.f90 | 70 +++++++++++++++++++++------------------------ prms/snowcomp.f90 | 9 ++++-- 4 files changed, 57 insertions(+), 59 deletions(-) diff --git a/prms/basin.f90 b/prms/basin.f90 index dae1affa..1a78e009 100644 --- a/prms/basin.f90 +++ b/prms/basin.f90 @@ -168,7 +168,7 @@ INTEGER FUNCTION basdecl() ! potet_pm, potet_pm_sta, or potet_pt IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Glacier_flag==1 ) ALLOCATE ( Hru_elev_feet(Nhru) ) ! ide_dist, potet_pm, potet_pm_sta, potet_pt, or stream_temp - IF ( Precip_flag==5 .OR. Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Stream_temp_flag==1 ) & + IF ( Precip_flag==5 .OR. Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Stream_temp_flag==1 .OR. Glacier_flag==1 ) & & ALLOCATE ( Hru_elev_meters(Nhru) ) ! Declared Parameters @@ -265,7 +265,7 @@ INTEGER FUNCTION basinit() USE PRMS_MODULE, ONLY: Nhru, Nlake, Dprst_flag, PRMS4_flag, & & Print_debug, Model, PRMS_VERSION, Starttime, Endtime, & & Lake_route_flag, Et_flag, Precip_flag, Cascadegw_flag, Parameter_check_flag, & - & Stream_temp_flag, Frozen_flag + & Stream_temp_flag, Frozen_flag, Glacier_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: getparam @@ -395,10 +395,10 @@ INTEGER FUNCTION basinit() Basin_lat = Basin_lat + DBLE( Hru_lat(i)*harea ) IF ( Elev_units==0 ) THEN IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 ) Hru_elev_feet(i) = Hru_elev(i) - IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Precip_flag==5 .OR. Stream_temp_flag==1 ) & + IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Precip_flag==5 .OR. Stream_temp_flag==1 .OR. Glacier_flag==1 ) & & Hru_elev_meters(i) = Hru_elev(i)*FEET2METERS ELSE - IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Precip_flag==5 .OR. Stream_temp_flag==1 ) & + IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 .OR. Precip_flag==5 .OR. Stream_temp_flag==1 .OR. Glacier_flag==1 ) & & Hru_elev_meters(i) = Hru_elev(i) IF ( Et_flag==5 .OR. Et_flag==11 .OR. Et_flag==6 ) Hru_elev_feet(i) = Hru_elev(i)*METERS2FEET ENDIF diff --git a/prms/routing.f90 b/prms/routing.f90 index 1609613b..5e59c7df 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -378,8 +378,21 @@ INTEGER FUNCTION routinginit() IF ( getparam(MODNAME, 'mann_n', Nsegment, 'real', Mann_n)/=0 ) CALL read_error(2, 'mann_n') ENDIF IF ( Stream_temp_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7) THEN - IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') + IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') +! find segments that are too short and print them out as they are found + ierr = 0 + DO i = 1, Nsegment + IF ( Seg_length(i)0.0 ) THEN - Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow_in - Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) - ENDIF + Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow_in + Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) ! Filled riparian storage surface area for each HRU: ! Fills outward from the river with one edge on river and with same depth and same side shape ! this works out to keeping fraction same for area and volume filled @@ -1221,36 +1218,35 @@ SUBROUTINE drain_the_swamp(Ihru) ! compute seepage Ripst_seep_hru(Ihru) = 0.0D0 seep = 0.0 - IF ( Ripst_area_max(Ihru)>0.0 ) THEN - IF ( Ripst_vol(Ihru)>NEARZERO ) THEN - ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters + IF ( Ripst_vol(Ihru)>NEARZERO ) THEN + ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters !assumed it was a one sided stream, here a headwater with both sides in one HRU - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 ! Stream ground area is stream side area (flat wall) and other side area (fraction of triangle (1) to rectangle (0)) - ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle + ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle & (SQRT( ripst_wid**2.0 + Ripst_depth(Ihru)**2.0 )- Ripst_depth(Ihru))*Tr_ratio(Ihru) + & !triangle & 2.0*Ripst_depth(Ihru) ) ) !stream and other side !assumed it was a one sided stream, here a headwater with both sides in one HRU - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 !seep in a day through ground surface area of riparian, m^3 into ft^3 to acre_in !Transmissivity would be way too big, maybe ssr2gw_rate - seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) - !seep = 0.0 !if want to turn off seep - seep_in = seep*FT2_PER_ACRE*12.0 - Ripst_vol(Ihru) = Ripst_vol(Ihru) - seep_in - IF ( Ripst_vol(Ihru)<0.0D0 ) THEN - !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) - seep_in = seep_in + Ripst_vol(Ihru) - seep = seep_in/(FT2_PER_ACRE*12.0) - Ripst_vol(Ihru) = 0.0D0 - ENDIF - Ripst_seep_hru(Ihru) = seep_in/Hru_area_dble(Ihru) !inch per HRU - ENDIF + seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) + !seep = 0.0 !if want to turn off seep + seep_in = seep*FT2_PER_ACRE*12.0 + Ripst_vol(Ihru) = Ripst_vol(Ihru) - seep_in IF ( Ripst_vol(Ihru)<0.0D0 ) THEN -! IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) + !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) + seep_in = seep_in + Ripst_vol(Ihru) + seep = seep_in/(FT2_PER_ACRE*12.0) Ripst_vol(Ihru) = 0.0D0 ENDIF + Ripst_seep_hru(Ihru) = seep_in/Hru_area_dble(Ihru) !inch per HRU ENDIF + IF ( Ripst_vol(Ihru)<0.0D0 ) THEN + !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) + Ripst_vol(Ihru) = 0.0D0 + ENDIF + ! seep goes back in stream as positive flow, cfs Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru))+ seep/Timestep_seconds !Seg_ripflow(Hru_segment(Ihru)) = 0.0 !if want to turn off overbank flow diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index c9699105..2da07037 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -946,9 +946,12 @@ INTEGER FUNCTION snorun() IF ( Active_glacier>=1 ) CALL glacr_states_to_zero(i,1) !all snow on glacier becomes firn, reset active layer thickness - IF ( Active_glacier==1 ) THEN !do not zero out snowpack for snowfields because a lot is off glacier - ! snow will melt more than should on snowfields if include a lot of low elevation - ! if terminus glacier, and has snow will disappear off glacier but that is likely anyhow + IF ( Active_glacier==1 ) THEN +! If Active_glacier>=1 we are zeroing out snowpack if have glacierettes even though possibly a lot of HRU is not glacierized. +! If Active_glacier==1 do not zero out glacierettes, but then will maybe never melt ice on glacierettes. If the climate is +! correct the snowpack will deplete quick because there is a lot of lower elevation than the glacierette included in the HRU. +! Choice does not effect runoff much, but will effect Basin_pweqv and things like that + ! if terminus glacier, and has snow will disappear off glacier but that is likely anyhow Pkwater_equiv(i) = 0.0 Pk_depth(i) = 0.0D0 Pss(i) = 0.0D0 From 2b4601f7f79a4c690a1d09b21872f961dc56c2ec Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Wed, 10 Jul 2019 11:55:47 -0600 Subject: [PATCH 19/47] Looking at glacrcov_area and snowcov_area. New code doesn't lose as much snowcov for same snowmelt. --- prms/snowcomp.f90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index 2da07037..ffb094ed 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -1050,8 +1050,8 @@ INTEGER FUNCTION snorun() ! If there is no existing snow pack and there is new snow, the ! initial snow covered area is complete (1) IF ( Newsnow(i)==1 .AND. Pkwater_equiv(i)=1 ) THEN ! Albedo so transition snow to ice smooothly, see Oerlemans 1992, this is albedo if snowcovered ice too @@ -1406,8 +1408,8 @@ INTEGER FUNCTION snorun() IF ( Active_glacier==2 ) frac = (1.0 - Glrette_frac(i)) ! Sum volumes for basin totals Basin_snowmelt = Basin_snowmelt + DBLE( Snowmelt(i)*Hru_area(i)*frac ) !don't include stuff melting into glacier - Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*DBLE( Hru_area(i)*frac ) !don't include stuff melting into glacier - Basin_snowevap = Basin_snowevap + DBLE( Snow_evap(i)*Hru_area(i)*frac ) !don't include stuff melting into glacier + Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*DBLE( Hru_area(i) ) + Basin_snowevap = Basin_snowevap + DBLE( Snow_evap(i)*Hru_area(i) ) Basin_snowcov = Basin_snowcov + DBLE( Snowcov_area(i)*Hru_area(i) ) Basin_pk_precip = Basin_pk_precip + DBLE( Pk_precip(i)*Hru_area(i) ) Basin_snowdepth = Basin_snowdepth + Pk_depth(i)*DBLE(Hru_area(i)) From 72c809346c3f8313e74b8045351b5946cd2db2d8 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Fri, 12 Jul 2019 00:33:29 -0600 Subject: [PATCH 20/47] Now assuming seg_length includes length of sloped line not 2-D length --- prms/routing.f90 | 3 ++- prms/routingRip.f90 | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/prms/routing.f90 b/prms/routing.f90 index 5e59c7df..1d7cf97e 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -543,7 +543,8 @@ INTEGER FUNCTION routinginit() DO i = 1, Nsegment IF ( Strmflow_flag==7 ) THEN ! muskingum_mann velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth - K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours + K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped lenght + !K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours ENDIF IF ( Segment_type(i)==2 .AND. K_coef(i)<24.0 ) K_coef(i) = 24.0 !K_coef must be specified = 24.0 for lake segments' diff --git a/prms/routingRip.f90 b/prms/routingRip.f90 index 5b64cb86..2806d53f 100644 --- a/prms/routingRip.f90 +++ b/prms/routingRip.f90 @@ -836,7 +836,8 @@ INTEGER FUNCTION routinginit() DO i = 1, Nsegment IF ( Strmflow_flag==7 ) THEN ! muskingum_mann velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth - K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours + K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped lenght + !K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours ENDIF IF ( Segment_type(i)==2 .AND. K_coef(i)<24.0 ) K_coef(i) = 24.0 !K_coef must be specified = 24.0 for lake segments' From d1cf075887c88ef7dfdda7aa95443a78dc5e82e1 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Mon, 29 Jul 2019 20:29:57 -0600 Subject: [PATCH 21/47] Changing somethings for CFGI --- prms/routing.f90 | 3 +- prms/routingRip.f90 | 4 +- prms/snowcomp.f90 | 168 ++++++++++++++++++++++--------------------- prms/srunoff.f90 | 32 +++++---- prms/stream_temp.f90 | 12 ++-- 5 files changed, 112 insertions(+), 107 deletions(-) diff --git a/prms/routing.f90 b/prms/routing.f90 index 1d7cf97e..08dd0f82 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -543,8 +543,9 @@ INTEGER FUNCTION routinginit() DO i = 1, Nsegment IF ( Strmflow_flag==7 ) THEN ! muskingum_mann velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth - K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped lenght + K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped length !K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours + print*, i, K_coef(i) ENDIF IF ( Segment_type(i)==2 .AND. K_coef(i)<24.0 ) K_coef(i) = 24.0 !K_coef must be specified = 24.0 for lake segments' diff --git a/prms/routingRip.f90 b/prms/routingRip.f90 index 2806d53f..ff638dd6 100644 --- a/prms/routingRip.f90 +++ b/prms/routingRip.f90 @@ -396,7 +396,7 @@ INTEGER FUNCTION routingdecl() & ' if =0, then overbank storage is turned off, if also bankfinite_hru =1 bank storage is off', & & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_areafr_max') - ALLOCATE ( Porosity_seg(Nhru) ) + ALLOCATE ( Porosity_seg(Nsegment) ) IF ( declparam(MODNAME, 'porosity_seg', 'nsegment', 'real', & & '0.4', '0.15', '0.75', & & 'Porosity of soil of riparian overbank flow storage', & @@ -836,7 +836,7 @@ INTEGER FUNCTION routinginit() DO i = 1, Nsegment IF ( Strmflow_flag==7 ) THEN ! muskingum_mann velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth - K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped lenght + K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped length !K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours ENDIF diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index ffb094ed..f3184967 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -48,7 +48,7 @@ MODULE PRMS_SNOW DOUBLE PRECISION, SAVE, ALLOCATABLE :: Pk_depth(:), Pkwater_ante(:), Ai(:) REAL, SAVE, ALLOCATABLE :: Glacrmelt(:), Glacr_evap(:), Glacr_albedo(:), Glacr_pk_den(:) REAL, SAVE, ALLOCATABLE :: Glacr_pk_ice(:), Glacr_freeh2o(:), Glacrcov_area(:) - REAL, SAVE, ALLOCATABLE :: Glacrb_melt(:), Glacr_pk_def(:), Glacr_pk_temp(:), Glacr_air_avtemp(:) + REAL, SAVE, ALLOCATABLE :: Glacrb_melt(:), Glacr_pk_def(:), Glacr_pk_temp(:), Ann_tempc(:) REAL, SAVE, ALLOCATABLE :: Glacr_air_5avtemp1(:), Glacr_air_deltemp(:), Glacr_air_5avtemp(:) REAL, SAVE, ALLOCATABLE :: Glacr_5avsnow1(:), Glacr_5avsnow(:),Glacr_delsnow(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pkwater_ante(:), Glacr_pkwater_equiv(:) @@ -167,10 +167,10 @@ INTEGER FUNCTION snodecl() 'Glacier basal melt, goes to soil', & 'inches/day', Glacrb_melt)/=0 ) CALL read_error(3, 'glacrb_melt') - ALLOCATE ( Glacr_air_avtemp(Nhru) ) - IF ( declvar(MODNAME, 'glacr_air_avtemp', 'nhru', Nhru, 'real', & - & 'Current average year air temperature over glacier or glrette HRU', & - & 'degrees Celsius', Glacr_air_avtemp)/=0 ) CALL read_error(3, 'glacr_air_avtemp') + ALLOCATE ( Ann_tempc(Nhru) ) + IF ( declvar(MODNAME, 'ann_tempc', 'nhru', Nhru, 'real', & + & 'Current average year air temperature overs HRU', & + & 'degrees Celsius', Ann_tempc)/=0 ) CALL read_error(3, 'ann_tempc') ALLOCATE ( Glacr_air_5avtemp(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_5avtemp', 'nhru', Nhru, 'real', & @@ -814,7 +814,7 @@ INTEGER FUNCTION snoinit() Basin_glacrevap = 0.0D0 IF ( Glacier_flag==1 ) THEN Alt_above_ela = 0.0 - Glacr_air_avtemp = 0.0 + Ann_tempc = 0.0 Glacr_air_5avtemp = 0.0 Glacr_air_5avtemp1 = 0.0 Glacr_air_deltemp = 0.0 @@ -977,7 +977,7 @@ INTEGER FUNCTION snorun() IF ( Active_glacier==2 ) Glacr_albedo(i) = Albedo_ice(i) !glacr_albedo doesn't change if glacierette but could get zeroed out IF ( isglacier==1 ) THEN IF (Nowyear >= Starttime(1)+10 .AND. MOD(Nowyear-Starttime(1),5)==0 ) THEN - Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 10 years of data + Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 5 years of data Glacr_delsnow(i) = 10.0*(Glacr_5avsnow1(i) - Glacr_5avsnow(i))/Glacr_5avsnow1(i) !number of 10 percent (*100.0/10.0) changes ENDIF !keep before restart @@ -989,7 +989,7 @@ INTEGER FUNCTION snorun() Glacr_air_5avtemp(i) = 0.0 !zero out for new year restart Glacr_5avsnow(i) = 0.0 !zero out for new year restart ENDIF - Glacr_air_avtemp(i) = 0.0 !zero out for new year restart + Ann_tempc(i) = 0.0 !zero out for new year restart ENDIF !end start of year calculations ENDIF @@ -997,10 +997,10 @@ INTEGER FUNCTION snorun() IF ( isglacier==1 ) THEN IF (Julwater>151 .AND. Julwater<244) THEN ! Now following McGrath et al 2017, temp June-August, 92 days Yrdays5 = Yrdays5 + 1 - Glacr_air_5avtemp(i) = ( Glacr_air_5avtemp(i)*(Yrdays5-1)+ (Tminc(i)+Tavgc(i))*0.5 )/Yrdays5 + Glacr_air_5avtemp(i) = ( Glacr_air_5avtemp(i)*(Yrdays5-1)+ Tavgc(i) )/Yrdays5 ENDIF ! Do for every time step - Glacr_air_avtemp(i) = ( Glacr_air_avtemp(i)*(Julwater-1)+ (Tminc(i)+Tavgc(i))*0.5 )/Julwater + Ann_tempc(i) = ( Ann_tempc(i)*(Julwater-1)+ Tavgc(i) )/Julwater Glacr_5avsnow(i) = Glacr_5avsnow(i) + Net_snow(i)/5.0 ENDIF @@ -1125,18 +1125,12 @@ INTEGER FUNCTION snorun() ! is no precipitation emis = Emis_noppt(i) ! [fraction of radiation] ! Could use equation from Swinbank 63 using Temp, a is -13.638, b is 6.148 - !emis = ((temp+273.16)**(Emis_coefb-4.0))*(10.0**(Emis_coefa+1.0))/5.670373E−8 ! /by Stefan Boltzmann in SI units + !emis = ((temp+273.15)**(Emis_coefb-4.0))*(10.0**(Emis_coefa+1.0))/5.670373E−8 ! /by Stefan Boltzmann in SI units ! If there is any precipitation in the HRU, reset the ! emissivity to 1 IF ( Hru_ppt(i)>0.0 ) emis = 1.0 ! [fraction of radiation] ! Save the current value of emissivity esv = emis ! [fraction of radiation] - ! The incoming shortwave radiation is the HRU radiation - ! adjusted by the albedo (some is reflected back into the - ! atmoshphere) and the transmission coefficient (some is - ! intercepted by the winter vegetative canopy) - swn = Swrad(i)*(1.0-Albedo(i))*Rad_trncf(i) ! [cal/cm^2] - ! or [Langleys] ! Set the convection-condensation for a half-day interval cec = Cecn_coef(i, Nowmonth)*0.5 ! [cal/(cm^2 degC)] ! or [Langleys / degC] @@ -1144,48 +1138,6 @@ INTEGER FUNCTION snorun() ! condensation parameter by half IF ( Cov_type(i)>2 ) cec = cec*0.5 ! [cal/(cm^2 degC)] RSR: cov_type=4 is valid for trees (coniferous) ! or [Langleys / degC] - - ! Calculate the new snow depth (Riley et al. 1973) - ! RSR: the following 3 lines of code were developed by Rob Payn, 7/10/2013 - ! The snow depth depends on the previous snow pack water - ! equivalent plus the new net snow - Pss(i) = Pss(i) + DBLE( Net_snow(i) ) ! [inches] - dpt_before_settle = Pk_depth(i) + DBLE(Net_snow(i))*Deninv - dpt1 = dpt_before_settle + Settle_const_dble * ((Pss(i)*Denmaxinv) - dpt_before_settle) -! dpt1 = Pk_depth(i) + (Net_snow(i)*Deninv) + & -! Settle_const * ((Pss(i)*Denmaxinv) - Pk_depth(i)) -! dpt1 = ((Net_snow(i)*Deninv)+ (Setden*Pss(i))+Pk_depth(i))*Set1 ! [inches] - ! RAPCOMMENT - CHANGED TO THE APPROPRIATE FINITE DIFFERENCE - ! APPROXIMATION OF SNOW DEPTH - Pk_depth(i) = dpt1 ! [inches] - - ! Calculate the snowpack density - IF ( dpt1>0.0D0 ) THEN - Pk_den(i) = SNGL( Pkwater_equiv(i)/dpt1 ) - ELSE - Pk_den(i) = 0.0 - ENDIF - ! [inch water equiv / inch depth] - - ! The effective thermal conductivity is approximated - ! (empirically) as 0.0077 times (snowpack density)^2 - ! [cal / (sec g degC)] Therefore, the effective - ! conductivity term (inside the square root) in the - ! equation for conductive heat exchange can be - ! calculated as follows (0.0077*pk_den^2)/(pk_den*0.5) - ! where 0.5 is the specific heat of ice [cal / (g degC)] - ! this simplifies to the following - effk = 0.0154*Pk_den(i) ! [unitless] - ! 13751 is the number of seconds in 12 hours over pi - ! So for a half day, to calculate the conductive heat - ! exchange per cm snow per cm^2 area per degree - ! temperature difference is the following - ! In effect, multiplying cst times the temperature - ! gradient gives the heatexchange by heat conducted - ! (calories) per square cm of snowpack - cst = Pk_den(i)*(SQRT(effk*13751.0)) ! [cal/(cm^2 degC)] - ! or [Langleys / degC] - ! Check whether to force spring melt ! Spring melt is forced if time is before the melt-force ! day and after the melt-look day (parameters) @@ -1229,21 +1181,71 @@ INTEGER FUNCTION snorun() ! niteda is a flag indicating nighttime (1) or daytime (2) ! set the flag indicating night time niteda = 1 ! [flag] - ! no shortwave (solar) radiation at night - sw = 0.0 ! [cal / cm^2] or [Langleys] ! temparature is halfway between the minimum and average temperature ! for the day temp = (Tminc(i)+Tavgc(i))*0.5 - ! calculate the night time energy balance - CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & - & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & - & Canopy_covden(i), cec, Pkwater_equiv(i), & - & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & - & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & - & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) - ! track total heat flux from both night and day periods - Tcal(i) = cals ! [cal/cm^2] or [Langleys] + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + ! The incoming shortwave radiation is the HRU radiation + ! adjusted by the albedo (some is reflected back into the + ! atmoshphere) and the transmission coefficient (some is + ! intercepted by the winter vegetative canopy) + swn = Swrad(i)*(1.0-Albedo(i))*Rad_trncf(i) ! [cal/cm^2] + ! or [Langleys] + ! Calculate the new snow depth (Riley et al. 1973) + ! RSR: the following 3 lines of code were developed by Rob Payn, 7/10/2013 + ! The snow depth depends on the previous snow pack water + ! equivalent plus the new net snow + Pss(i) = Pss(i) + DBLE( Net_snow(i) ) ! [inches] + dpt_before_settle = Pk_depth(i) + DBLE(Net_snow(i))*Deninv + dpt1 = dpt_before_settle + Settle_const_dble * ((Pss(i)*Denmaxinv) - dpt_before_settle) + ! dpt1 = Pk_depth(i) + (Net_snow(i)*Deninv) + & + ! Settle_const * ((Pss(i)*Denmaxinv) - Pk_depth(i)) + ! dpt1 = ((Net_snow(i)*Deninv)+ (Setden*Pss(i))+Pk_depth(i))*Set1 ! [inches] + ! RAPCOMMENT - CHANGED TO THE APPROPRIATE FINITE DIFFERENCE + ! APPROXIMATION OF SNOW DEPTH + Pk_depth(i) = dpt1 ! [inches] + + ! Calculate the snowpack density + IF ( dpt1>0.0D0 ) THEN + Pk_den(i) = SNGL( Pkwater_equiv(i)/dpt1 ) + ELSE + Pk_den(i) = 0.0 + ENDIF + ! [inch water equiv / inch depth] + + ! The effective thermal conductivity is approximated + ! (empirically) as 0.0077 times (snowpack density)^2 + ! [cal / (sec g degC)] Therefore, the effective + ! conductivity term (inside the square root) in the + ! equation for conductive heat exchange can be + ! calculated as follows (0.0077*pk_den^2)/(pk_den*0.5) + ! where 0.5 is the specific heat of ice [cal / (g degC)] + ! this simplifies to the following + effk = 0.0154*Pk_den(i) ! [unitless] + ! 13751 is the number of seconds in 12 hours over pi + ! So for a half day, to calculate the conductive heat + ! exchange per cm snow per cm^2 area per degree + ! temperature difference is the following + ! In effect, multiplying cst times the temperature + ! gradient gives the heatexchange by heat conducted + ! (calories) per square cm of snowpack + cst = Pk_den(i)*(SQRT(effk*13751.0)) ! [cal/(cm^2 degC)] + ! or [Langleys / degC] + + + ! no shortwave (solar) radiation at night + sw = 0.0 ! [cal / cm^2] or [Langleys] + ! calculate the night time energy balance + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Pkwater_equiv(i), & + & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & + & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & + & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) + ! track total heat flux from both night and day periods + Tcal(i) = cals ! [cal/cm^2] or [Langleys] + ENDIF iswn = 0.0 IF ( Active_glacier>=1 ) THEN IF ( Glacrcov_area(i)>0.0 ) THEN @@ -1277,16 +1279,16 @@ INTEGER FUNCTION snorun() ENDIF ENDIF - ! Compute energy balance for day period (if the snowpack - ! still exists) - IF ( Pkwater_equiv(i)>0.0D0 ) THEN - ! set the flag indicating daytime - niteda = 2 ! [flag] + ! Compute energy balance for day period + ! set the flag indicating daytime + niteda = 2 ! [flag] + ! temparature is halfway between the maximum and average + ! temperature for the day + temp = (Tmaxc(i)+Tavgc(i))*0.5 ! [degrees C] + + IF ( Pkwater_equiv(i)>0.0D0 ) THEN !(if the snowpack still exists) ! set shortwave radiation as calculated earlier sw = swn ! [cal/cm^2] or [Langleys] - ! temparature is halfway between the maximum and average - ! temperature for the day - temp = (Tmaxc(i)+Tavgc(i))*0.5 ! [degrees C] CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & & Canopy_covden(i), cec, Pkwater_equiv(i), & @@ -2234,7 +2236,7 @@ SUBROUTINE snowbal(Niteda, Tstorm_mo, Iasw, Temp, Esv, Hru_ppt, & ! Calculate the potential long wave energy from air based on ! temperature (assuming perfect black-body emission) ! Stefan Boltzmann/2 = (11.71E-8)/2 = 0.585E-7 because add for day and night - air = 0.585E-7*((Temp+273.16)**4.0) ! [cal/cm^2] or [Langleys] + air = 0.585E-7*((Temp+273.15)**4.0) ! [cal/cm^2] or [Langleys] ! set emissivity, which is the fraction of perfect black-body ! emission that is actually applied emis = Esv ! [fraction of radiation] @@ -2799,7 +2801,7 @@ END SUBROUTINE sca_deplcrv !*********************************************************************** SUBROUTINE glacr_states_to_zero(Ihru, active_layer_present) USE PRMS_SNOW, ONLY: Glacr_freeh2o_cap, Glacr_freeh2o_capm, Glacr_pk_def, Glacr_pk_depth, & - & Glacr_layer, Glacr_pk_temp, Glacr_air_avtemp, Glacr_pkwater_equiv, Glacr_pk_den, & + & Glacr_layer, Glacr_pk_temp, Ann_tempc, Glacr_pkwater_equiv, Glacr_pk_den, & & Glacr_pk_ice, Glacr_pkwater_ante, Glacr_freeh2o, Glacr_pss, Glacr_pk_den IMPLICIT NONE ! Arguments @@ -2817,7 +2819,7 @@ SUBROUTINE glacr_states_to_zero(Ihru, active_layer_present) reduce = 1.0 ElSE Glacr_pk_depth(Ihru) = DBLE(Glacr_layer(Ihru)) - Glacr_pk_temp(Ihru) = Glacr_air_avtemp(Ihru) !start at average last year temp like Oerlemans 1992 + Glacr_pk_temp(Ihru) = Ann_tempc(Ihru) !start at average last year temp like Oerlemans 1992 IF ( Glacr_pk_temp(Ihru) > 0.0) Glacr_pk_temp(Ihru) = 0.0 Glacr_freeh2o_capm(Ihru) = Glacr_freeh2o_cap(Ihru) reduce = 0.8 !if start Glacr_pk_ice too close to Glacr_pk_depth can't grow with energy loss to free water gain @@ -2885,7 +2887,7 @@ SUBROUTINE snowcomp_restart(In_out) WRITE ( Restart_outunit ) Glacr_pkwater_equiv WRITE ( Restart_outunit ) Glacr_pkwater_ante WRITE ( Restart_outunit ) Glacr_pk_temp - WRITE ( Restart_outunit ) Glacr_air_avtemp, Yrdays5 + WRITE ( Restart_outunit ) Ann_tempc, Yrdays5 WRITE ( Restart_outunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp WRITE ( Restart_outunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow WRITE ( Restart_outunit ) Glacr_pk_def @@ -2935,7 +2937,7 @@ SUBROUTINE snowcomp_restart(In_out) READ ( Restart_inunit ) Glacr_pkwater_equiv READ ( Restart_inunit ) Glacr_pkwater_ante READ ( Restart_inunit ) Glacr_pk_temp - READ ( Restart_inunit ) Glacr_air_avtemp, Yrdays5 + READ ( Restart_inunit ) Ann_tempc, Yrdays5 READ ( Restart_inunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp READ ( Restart_inunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow READ ( Restart_inunit ) Glacr_pk_def diff --git a/prms/srunoff.f90 b/prms/srunoff.f90 index 342d477c..7a832cd2 100644 --- a/prms/srunoff.f90 +++ b/prms/srunoff.f90 @@ -36,12 +36,14 @@ MODULE PRMS_SRUNOFF REAL, SAVE, ALLOCATABLE :: Hortonian_flow(:) REAL, SAVE, ALLOCATABLE :: Hru_impervevap(:), Hru_impervstor(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Strm_seg_in(:), Hortonian_lakes(:), Hru_hortn_cascflow(:) - REAL, SAVE, ALLOCATABLE :: Cfgi(:), Cfgi_prev(:) - INTEGER, SAVE, ALLOCATABLE :: Frozen(:) ! Declared Parameters - REAL, SAVE :: Cfgi_thrshld, Cfgi_decay REAL, SAVE, ALLOCATABLE :: Smidx_coef(:), Smidx_exp(:) REAL, SAVE, ALLOCATABLE :: Carea_min(:), Carea_max(:) +! Declared Parameters for Frozen Ground + REAL, SAVE :: Cfgi_thrshld, Cfgi_decay +! Declared Variables for Frozen Ground + REAL, SAVE, ALLOCATABLE :: Cfgi(:), Cfgi_prev(:) + INTEGER, SAVE, ALLOCATABLE :: Frozen(:) ! Declared Parameters for Depression Storage REAL, SAVE, ALLOCATABLE :: Op_flow_thres(:), Sro_to_dprst_perv(:) REAL, SAVE, ALLOCATABLE :: Va_clos_exp(:), Va_open_exp(:) @@ -317,7 +319,7 @@ INTEGER FUNCTION srunoffdecl() & 'decimal fraction')/=0 ) CALL read_error(1, 'cfgi_decay') IF ( declparam(MODNAME, 'cfgi_thrshld', 'one', 'real', & - & '83.0', '1.0', '500.0', & + & '52.55', '5.0', '83.0', & & 'CFGI threshold value indicating frozen soil', & & 'CFGI threshold value indicating frozen soil', & & 'index')/=0 ) CALL read_error(1, 'cfgi_thrshld') @@ -619,8 +621,8 @@ INTEGER FUNCTION srunoffrun() INTEGER :: i, k, dprst_chk, frzen, active_glacier REAL :: srunoff, avail_et, hperv, sra, availh2o DOUBLE PRECISION :: hru_sroff_down, runoff, apply_sroff, cfgi_sroff - REAL :: cfgi_k, depth_cm - REAL :: glcrmltb, temp, temp2 ! Ashley glaciers + REAL :: cfgi_k, depth_cm !frozen ground + REAL :: glcrmltb, temp, temp2 ! glaciers !*********************************************************************** srunoffrun = 0 @@ -662,12 +664,12 @@ INTEGER FUNCTION srunoffrun() Hruarea_dble = Hru_area_dble(i) Ihru = i runoff = 0.0D0 - glcrmltb = 0.0 ! Ashley glacier + glcrmltb = 0.0 ! glacier Isglacier = 0 - active_glacier = -1 ! not an Ashley glacier + active_glacier = -1 ! not an glacier IF ( Glacier_flag>0 ) THEN IF ( Hru_type(i)==4 ) THEN - IF ( Glacier_flag==1 ) THEN ! Ashley glacier + IF ( Glacier_flag==1 ) THEN ! glacier Isglacier = 1 glcrmltb = Glacrb_melt(i) IF ( Glacier_frac(i)>0.0 ) THEN @@ -715,11 +717,11 @@ INTEGER FUNCTION srunoffrun() ELSE cfgi_k = 0.08 ENDIF - depth_cm = SNGL(Pk_depth(i))*2.54 - Cfgi(i) = (Cfgi_decay*Cfgi_prev(i)) - (Tavgc(i)*(2.71828**(-0.4*cfgi_k*depth_cm))) + depth_cm = SNGL(Pk_depth(i))*2.54 !depth of snow cover averaged over HRU + Cfgi(i) = Cfgi_decay*Cfgi_prev(i) - Tavgc(i)*( 2.71828**(-0.4*cfgi_k*depth_cm) ) IF ( active_glacier==1 ) THEN Cfgi(i) = 0.0 !if glacier over, want ground completely unfrozen, or below threshold, infiltration - IF ( Glacier_frac(i)<1.0 ) Cfgi(i) = Cfgi_thrshld ! Ashley glacier with some open fraction + IF ( Glacier_frac(i)<1.0 ) Cfgi(i) = Cfgi_thrshld ! glacier with some open fraction ENDIF IF ( Cfgi(i)<0.0 ) Cfgi(i) = 0.0 Cfgi_prev(i) = Cfgi(i) @@ -757,7 +759,7 @@ INTEGER FUNCTION srunoffrun() ENDIF availh2o = Intcp_changeover(i) + Net_rain(i) - IF ( Isglacier==1 ) THEN ! Ashley glacier + IF ( Isglacier==1 ) THEN ! glacier temp = Snowmelt(i) + glcrmltb !Snowmelt or 0.0 temp2 = availh2o*(1.0-Glacier_frac(i)) CALL compute_infil(temp2, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), temp, & @@ -788,7 +790,7 @@ INTEGER FUNCTION srunoffrun() ! ********************************************************** srunoff = 0.0 - IF ( Hru_type(i)==1 .OR. active_glacier==0 ) THEN ! could be an Ashley glacier-capable HRU with no ice + IF ( Hru_type(i)==1 .OR. active_glacier==0 ) THEN ! could be an glacier-capable HRU with no ice !******Compute runoff for pervious and impervious area, and depression storage area runoff = runoff + DBLE( Srp*hperv + Sri*Hruarea_imperv ) srunoff = SNGL( runoff/Hruarea_dble ) @@ -927,7 +929,7 @@ SUBROUTINE compute_infil(Net_rain, Net_ppt, Imperv_stor, Imperv_stor_max, Snowme INTEGER :: hru_flag !*********************************************************************** hru_flag = 0 - IF ( Hru_type==1 .OR. Isglacier==1 ) hru_flag = 1 ! land or Ashley glacier + IF ( Hru_type==1 .OR. Isglacier==1 ) hru_flag = 1 ! land or glacier ! compute runoff from cascading Hortonian flow IF ( Cascade_flag>0 ) THEN avail_water = SNGL( Upslope_hortonian(Ihru) ) diff --git a/prms/stream_temp.f90 b/prms/stream_temp.f90 index 5e3b707c..fc30a24f 100644 --- a/prms/stream_temp.f90 +++ b/prms/stream_temp.f90 @@ -41,7 +41,7 @@ MODULE PRMS_STRMTEMP INTEGER, SAVE :: Spring_jday, Summer_jday, Autumn_jday, Winter_jday ! Shade Parameters needed if stream_temp_shade_flag = 2 REAL, SAVE, ALLOCATABLE :: Segshade_sum(:), Segshade_win(:) - REAL, SAVE:: Albedo, Melt_temp + REAL, SAVE:: Albedo_str, Melt_temp ! INTEGER, SAVE :: Shadeflg, now using stream_temp_shade_flag INTEGER, SAVE, ALLOCATABLE :: Ss_tau(:), Gw_tau(:) ! Control parameters @@ -187,11 +187,11 @@ INTEGER FUNCTION stream_temp_decl() ALLOCATE (gw_silo(nsegment,365), ss_silo(nsegment,365)) ALLOCATE (hru_area_sum(nsegment)) - IF ( declparam( MODNAME, 'albedo', 'one', 'real', & + IF ( declparam( MODNAME, 'albedo_str', 'one', 'real', & & '0.10', '0.0', '1.0', & & 'Short-wave solar radiation reflected by streams', & & 'Short-wave solar radiation reflected by streams', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo') + & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo_str') ALLOCATE(lat_temp_adj(Nsegment,12)) IF ( declparam( MODNAME, 'lat_temp_adj', 'nsegment,nmonths', 'real', & @@ -401,7 +401,7 @@ INTEGER FUNCTION stream_temp_init() !*********************************************************************** stream_temp_init = 0 - IF ( getparam( MODNAME, 'albedo', 1, 'real', Albedo)/=0 ) CALL read_error(2, 'albedo') + IF ( getparam( MODNAME, 'albedo_str', 1, 'real', Albedo_str)/=0 ) CALL read_error(2, 'albedo_str') IF ( getparam( MODNAME, 'lat_temp_adj', Nsegment*12, 'real', lat_temp_adj)/=0 ) CALL read_error(2, 'lat_temp_adj') IF (getparam(MODNAME, 'seg_lat', Nsegment, 'real', Seg_lat)/=0 ) CALL read_error(2, 'seg_lat') @@ -1098,7 +1098,7 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) ! 2. DETERMINE THE MAXIMUM DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS USE PRMS_STRMTEMP, ONLY: ZERO_C, Seg_width_flow, Seg_humid, Press, MPS_CONVERT, & - & Seg_ccov, Seg_potet, Albedo, seg_tave_gw + & Seg_ccov, Seg_potet, Albedo_str, seg_tave_gw USE PRMS_BASIN, ONLY: NEARZERO, CFS2CMS_CONV USE PRMS_FLOWVARS, ONLY: Seg_inflow USE PRMS_ROUTING, ONLY: Seginc_swrad, Seg_slope @@ -1155,7 +1155,7 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) ! hf is heat from stream friction. See eqn. 14. q_init is in CMS hf = 9805.0 * (q_init/Seg_width_flow(Seg_id)) * Seg_slope(Seg_id) - hs = (1.0 - sh) * sw_power * (1.0 - Albedo) + hs = (1.0 - sh) * sw_power * (1.0 - Albedo_str) hv = 5.24D-8 * DBLE(Svi) * (taabs**4) ! Stefan-Boltzmann constant = 5.670373D-08; emissivity of water = 0.9526, times each other: 5.4016D-08 From 2ec9cb133fbde56341526030ee7fa58a68580be3 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Mon, 29 Jul 2019 21:23:44 -0600 Subject: [PATCH 22/47] clean up makefile --- prms/Makefile | 82 +- prms/basin_sumCopy.f90 | 911 ----------------- prms/muskingum_lakeCopy.f90 | 1451 --------------------------- prms/stream_tempCopy.f90 | 1805 ---------------------------------- prms/strmflow_in_outCopy.f90 | 108 -- 5 files changed, 61 insertions(+), 4296 deletions(-) delete mode 100644 prms/basin_sumCopy.f90 delete mode 100644 prms/muskingum_lakeCopy.f90 delete mode 100644 prms/stream_tempCopy.f90 delete mode 100644 prms/strmflow_in_outCopy.f90 diff --git a/prms/Makefile b/prms/Makefile index f71670de..afa8a9b9 100644 --- a/prms/Makefile +++ b/prms/Makefile @@ -103,29 +103,29 @@ RIP = \ transp_frost.o \ transp_tindex.o \ frost_date.o \ - glacr_melt.o \ + glacr_meltCopy.o \ intcp.o \ - snowcomp.o \ - srunoff.o \ - soilzone.o \ - gwflow.o \ + snowcompCfgim.o \ + srunoffCfgim.o \ + soilzoneCfgim.o \ + gwflowCopy.o \ water_use_read.o \ - dynamic_param_read.o \ - water_balance.o \ + dynamic_param_readCopy.o \ + water_balanceCopy.o \ routingRip.o \ - strmflow.o \ + strmflowCopy.o \ strmflow_in_outCopy.o \ muskingumRip.o \ muskingum_lakeCopy.o \ mizurouteRip.o \ - subbasin.o \ + subbasinCopy.o \ map_results.o \ nhru_summary.o \ nsub_summary.o \ nsegment_summary.o \ basin_summary.o \ write_climate_hru.o \ - prms_summary.o \ + prms_summaryCopy.o \ basin_sumCopy.o \ utils_prms.o \ stream_tempCopy.o @@ -310,29 +310,69 @@ routing.o: routing.f90 prms_module.mod prms_basin.mod prms_gwflow.mod prms_flowv mizuroute.o: mizuroute.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routing.mod prms_srunoff.mod prms_gwflow.mod prms_glacr.mod $(FC) -c $(FFLAGS) $(INCMIZU) mizuroute.f90 -muskingumRip.o: muskingumRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoff.mod prms_gwflow.mod prms_glacr.mod +muskingumRip.o: muskingumRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod prms_glacrCopy.mod $(FC) -c $(FFLAGS) muskingumRip.f90 -routingRip.o: routingRip.f90 prms_moduleRip.mod prms_basin.mod prms_gwflow.mod prms_flowvars.mod prms_set_time.mod prms_water_use.mod prms_srunoff.mod prms_glacr.mod +routingRip.o: routingRip.f90 prms_moduleRip.mod prms_basin.mod prms_gwflowCopy.mod prms_flowvars.mod prms_set_time.mod prms_water_use.mod prms_srunoffCfgim.mod prms_glacrCopy.mod $(FC) -c $(FFLAGS) routingRip.f90 -mizurouteRip.o: mizurouteRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoff.mod prms_gwflow.mod prms_glacr.mod +mizurouteRip.o: mizurouteRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod prms_glacrCopy.mod $(FC) -c $(FFLAGS) $(INCMIZU) mizurouteRip.f90 -basin_sumCopy.o: basin_sumCopy.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snow.mod prms_srunoff.mod prms_gwflow.mod prms_climatevars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod - $(FC) -c $(FFLAGS) basin_sumCopy.f90 +basin_sumCopy.o: basin_sum.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod prms_climatevars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod + $(FC) -c $(FFLAGS) basin_sum.f90 + +muskingum_lakeCopy.o: muskingum_lake.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod prms_soilzoneCfgim.mod + $(FC) -c $(FFLAGS) muskingum_lake.f90 + +strmflow_in_outCopy.o: strmflow_in_out.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_routingRip.mod prms_obs.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod + $(FC) -c $(FFLAGS) strmflow_in_out.f90 + +stream_tempCopy.o: stream_temp.f90 prms_module.mod prms_basin.mod prms_routingRip.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_soltab.mod prms_climatevars.mod prms_snowCfgim.mod + $(FC) -c $(FFLAGS) stream_temp.f90 + + +srunoffCfgim.o: srunoffCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_climatevars.mod prms_intcp.mod prms_snow.mod prms_cascade.mod prms_set_time.mod + $(FC) -c $(FFLAGS) srunoffCfgim.f90 -muskingum_lakeCopy.o: muskingum_lakeCopy.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoff.mod prms_gwflow.mod prms_soilzone.mod - $(FC) -c $(FFLAGS) muskingum_lakeCopy.f90 +soilzoneCfgim.o: soilzoneCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snowCfgim.mod prms_cascade.mod prms_climatevars.mod prms_set_time.mod prms_srunoffCfgim.mod + $(FC) -c $(FFLAGS) soilzoneCfgim.f90 -strmflow_in_outCopy.o: strmflow_in_outCopy.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_routingRip.mod prms_obs.mod prms_srunoff.mod prms_gwflow.mod - $(FC) -c $(FFLAGS) strmflow_in_outCopy.f90 +snowcompCfgim.o: snowcompCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_climatevars.mod prms_set_time.mod prms_intcp.mod + $(FC) -c $(FFLAGS) snowcompCfgim.f90 -stream_tempCopy.o: stream_tempCopy.f90 prms_module.mod prms_basin.mod prms_routingRip.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_soltab.mod prms_climatevars.mod prms_snow.mod - $(FC) -c $(FFLAGS) stream_tempCopy.f90 +prms_summaryCopy.o: prms_summary.f90 prms_module.mod prms_climatevars.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_gwflowCopy.mod + $(FC) -c $(FFLAGS) prms_summary.f90 + +subbasinCopy.o: subbasin.f90 prms_module.mod prms_basin.mod prms_gwflowCopy.mod prms_flowvars.mod prms_set_time.mod prms_intcp.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_muskingum_lake.mod prms_snowCfgim.mod prms_climatevars.mod + $(FC) -c $(FFLAGS) subbasin.f90 + + +water_balanceCopy.o: water_balance.f90 prms_module.mod prms_basin.mod prms_srunoffCfgim.mod prms_flowvars.mod prms_gwflowCopy.mod prms_climatevars.mod prms_set_time.mod prms_cascade.mod prms_intcp.mod prms_snowCfgim.mod prms_soilzoneCfgim.mod + $(FC) -c $(FFLAGS) water_balance.f90 + +dynamic_param_readCopy.o: dynamic_param_read.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_flowvars.mod prms_potet_jh.mod prms_potet_pm.mod prms_potet_hs.mod prms_potet_pt.mod prms_potet_hamon.mod transp_tindex.o transp_frost.o prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_climate_hru.mod + $(FC) -c $(FFLAGS) dynamic_param_read.f90 + + +gwflowCopy.o: gwflow.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_cascade.mod prms_set_time.mod + $(FC) -c $(FFLAGS) gwflow.f90 + + +strmflowCopy.o: strmflow.f90 prms_module.mod prms_basin.mod prms_gwflowCopy.mod prms_srunoffCfgim.mod prms_set_time.mod + $(FC) -c $(FFLAGS) strmflow.f90 + + +glacr_meltCopy.o: glacr_melt.f90 prms_snowCfgim.mod prms_intcp.mod prms_soltab.mod + $(FC) -c $(FFLAGS) glacr_melt.f90 prms_routingRip.mod: routingRip.o prms_moduleRip.mod: call_modulesRip.o +prms_srunoffCfgim.mod: srunoffCfgim.o +prms_soilzoneCfgim.mod: soilzoneCfgim.o +prms_snowcompCfgim.mod: snowcompCfgim.o +prms_gwflowCopy.mod: gwflowCopy.o +prms_glacrCopy.mod: glacr_meltCopy.o prms_climatevars.mod: climateflow.o prms_flowvars.mod: climateflow.o prms_module.mod: call_modules.o diff --git a/prms/basin_sumCopy.f90 b/prms/basin_sumCopy.f90 deleted file mode 100644 index 6ccf8a46..00000000 --- a/prms/basin_sumCopy.f90 +++ /dev/null @@ -1,911 +0,0 @@ -!*********************************************************************** -! Computes daily, monthly, yearly, and total flow summaries of volumes -! and flows for all HRUs -!*********************************************************************** - MODULE PRMS_BASINSUM - IMPLICIT NONE -! Local Variables - INTEGER, SAVE :: BALUNT, Totdays - CHARACTER(LEN=9), SAVE :: MODNAME - INTEGER, SAVE :: Header_prt, Endjday - CHARACTER(LEN=32) :: Buffer32 - CHARACTER(LEN=40) :: Buffer40 - CHARACTER(LEN=48) :: Buffer48 - CHARACTER(LEN=80) :: Buffer80 - CHARACTER(LEN=120) :: Buffer120 - CHARACTER(LEN=151) :: Buffer151 - CHARACTER(LEN=151), PARAMETER :: DASHS = ' --------------------------------------------------------'// & - & '----------------------------------------------------------------------------------------------' - CHARACTER(LEN=151), PARAMETER :: STARS = ' ********************************************************'// & - & '**********************************************************************************************' - CHARACTER(LEN=151), PARAMETER :: EQULS = ' ========================================================'// & - & '==============================================================================================' - LOGICAL, SAVE :: Dprt, Mprt, Yprt, Tprt - DOUBLE PRECISION, SAVE :: Basin_swrad_yr, Basin_swrad_tot, Basin_swrad_mo -! Declared Variables - DOUBLE PRECISION, SAVE :: Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot - DOUBLE PRECISION, SAVE :: Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot - DOUBLE PRECISION, SAVE :: Basin_net_ppt_yr, Basin_net_ppt_tot, Watbal_sum - DOUBLE PRECISION, SAVE :: Basin_max_temp_yr, Basin_max_temp_tot - DOUBLE PRECISION, SAVE :: Basin_min_temp_yr, Basin_min_temp_tot - DOUBLE PRECISION, SAVE :: Basin_potet_yr, Basin_potet_tot - DOUBLE PRECISION, SAVE :: Basin_actet_yr, Basin_actet_tot - DOUBLE PRECISION, SAVE :: Basin_snowmelt_yr, Basin_snowmelt_tot - DOUBLE PRECISION, SAVE :: Basin_gwflow_yr, Basin_gwflow_tot - DOUBLE PRECISION, SAVE :: Basin_ssflow_yr, Basin_ssflow_tot - DOUBLE PRECISION, SAVE :: Basin_sroff_yr, Basin_sroff_tot - DOUBLE PRECISION, SAVE :: Basin_stflow_yr, Basin_stflow_tot - DOUBLE PRECISION, SAVE :: Basin_ppt_yr, Basin_ppt_tot, Last_basin_stor - DOUBLE PRECISION, SAVE :: Basin_intcp_evap_yr, Basin_intcp_evap_tot, Basin_lakeevap_yr - DOUBLE PRECISION, SAVE :: Obsq_inches_yr, Obsq_inches_tot - DOUBLE PRECISION, SAVE :: Basin_net_ppt_mo, Obsq_inches_mo - DOUBLE PRECISION, SAVE :: Basin_max_temp_mo, Basin_min_temp_mo - DOUBLE PRECISION, SAVE :: Basin_actet_mo - DOUBLE PRECISION, SAVE :: Basin_snowmelt_mo, Basin_gwflow_mo - DOUBLE PRECISION, SAVE :: Basin_sroff_mo, Basin_stflow_mo - DOUBLE PRECISION, SAVE :: Basin_intcp_evap_mo, Basin_storage - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_et_yr(:) - DOUBLE PRECISION, SAVE :: Basin_storvol, Basin_potet_mo - DOUBLE PRECISION, SAVE :: Basin_ssflow_mo, Basin_ppt_mo - DOUBLE PRECISION, SAVE :: Obsq_inches - DOUBLE PRECISION, SAVE :: Basin_runoff_ratio, Basin_runoff_ratio_mo - DOUBLE PRECISION, SAVE :: Basin_lakeevap_mo -! Declared Parameters - INTEGER, SAVE :: Print_type, Print_freq, Outlet_sta - END MODULE PRMS_BASINSUM - -!*********************************************************************** -! Main basin_sum routine -!*********************************************************************** - INTEGER FUNCTION basin_sum() - USE PRMS_MODULE, ONLY: Process, Save_vars_to_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: sumbdecl, sumbinit, sumbrun - EXTERNAL :: basin_sum_restart -!*********************************************************************** - basin_sum = 0 - - IF ( Process(:3)=='run' ) THEN - basin_sum = sumbrun() - ELSEIF ( Process(:4)=='decl' ) THEN - basin_sum = sumbdecl() - ELSEIF ( Process(:4)=='init' ) THEN - basin_sum = sumbinit() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL basin_sum_restart(0) - ENDIF - - END FUNCTION basin_sum - -!*********************************************************************** -! sumbdecl - set up basin summary parameters -! Declared Parameters -! print_type, print_freq, outlet_sta -!*********************************************************************** - INTEGER FUNCTION sumbdecl() - USE PRMS_BASINSUM - USE PRMS_MODULE, ONLY: Model, Nhru, Nobs - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: declparam, declvar - EXTERNAL read_error, print_module -! Local Variables - CHARACTER(LEN=80), SAVE :: Version_basin_sum -!*********************************************************************** - sumbdecl = 0 - - Version_basin_sum = 'basin_sum.f90 2017-10-21 14:18:00Z' - CALL print_module(Version_basin_sum, 'Summary ', 90) - MODNAME = 'basin_sum' - - IF ( declvar(MODNAME, 'last_basin_stor', 'one', 1, 'double', & - & 'Basin area-weighted average storage in all water storage reservoirs from previous time step', & - & 'inches', Last_basin_stor)/=0 ) CALL read_error(3, 'last_basin_stor') - IF ( declvar(MODNAME, 'watbal_sum', 'one', 1, 'double', & - & 'Water balance aggregate', & - & 'inches', Watbal_sum)/=0 ) CALL read_error(3, 'watbal_sum') - IF ( declvar(MODNAME, 'obs_runoff_mo', 'one', 1, 'double', & - & 'Monthly measured streamflow at basin outlet', & - & 'cfs', Obs_runoff_mo)/=0 ) CALL read_error(3, 'obs_runoff_mo') - IF ( declvar(MODNAME, 'basin_cfs_mo', 'one', 1, 'double', & - & 'Monthly total streamflow to stream network', & - & 'cfs', Basin_cfs_mo)/=0 ) CALL read_error(3, 'basin_cfs_mo') - IF ( declvar(MODNAME, 'obs_runoff_yr', 'one', 1, 'double', & - & 'Yearly measured streamflow at basin outlet', & - & 'cfs', Obs_runoff_yr)/=0 ) CALL read_error(3, 'obs_runoff_yr') - IF ( declvar(MODNAME, 'basin_cfs_yr', 'one', 1, 'double', & - & 'Yearly total streamflow to stream network', & - & 'cfs', Basin_cfs_yr)/=0 ) CALL read_error(3, 'basin_cfs_yr') - IF ( declvar(MODNAME, 'basin_net_ppt_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average net precipitation', & - & 'inches', Basin_net_ppt_yr)/=0 ) CALL read_error(3, 'basin_net_ppt_yr') - IF ( declvar(MODNAME, 'basin_max_temp_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average maximum temperature', & - & 'temp_units', Basin_max_temp_yr)/=0) CALL read_error(3,'basin_max_temp_yr') - IF ( declvar(MODNAME, 'basin_min_temp_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average minimum temperature', & - & 'temp_units', Basin_min_temp_yr)/=0) CALL read_error(3,'basin_min_temp_yr') - IF ( declvar(MODNAME, 'basin_potet_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average potential ET', & - & 'temp_units', Basin_potet_yr)/=0 ) CALL read_error(3, 'basin_potet_yr') - IF ( declvar(MODNAME, 'basin_actet_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average actual ET', & - & 'inches', Basin_actet_yr)/=0 ) CALL read_error(3, 'basin_actet_yr') - IF ( declvar(MODNAME, 'basin_snowmelt_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average snowmelt', & - & 'inches', Basin_snowmelt_yr)/=0) CALL read_error(3,'basin_snowmelt_yr') - IF ( declvar(MODNAME, 'basin_gwflow_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average groundwater discharge', & - & 'inches', Basin_gwflow_yr)/=0 ) CALL read_error(3, 'basin_gwflow_yr') - IF ( declvar(MODNAME, 'basin_ssflow_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average interflow', & - & 'inches', Basin_ssflow_yr)/=0 ) CALL read_error(3, 'basin_ssflow_yr') - IF ( declvar(MODNAME, 'basin_sroff_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average overland runoff', & - & 'inches', Basin_sroff_yr)/=0 ) CALL read_error(3, 'basin_sroff_yr') - IF ( declvar(MODNAME, 'basin_ppt_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average precipitation', & - & 'inches', Basin_ppt_yr)/=0 ) CALL read_error(3, 'basin_ppt_yr') - IF ( declvar(MODNAME, 'basin_stflow_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average streamflow', & - & 'inches', Basin_stflow_yr)/=0 ) CALL read_error(3, 'basin_stflow_yr') - IF ( declvar(MODNAME, 'obsq_inches_yr', 'one', 1, 'double', & - & 'Yearly measured streamflow at specified outlet station', & - & 'inches', Obsq_inches_yr)/=0 ) CALL read_error(3, 'obsq_inches_yr') - IF ( declvar(MODNAME, 'basin_intcp_evap_yr', 'one', 1, 'double', & - & 'Yearly basin area-weighted average canopy evaporation', & - & 'inches', Basin_intcp_evap_yr)/=0 ) CALL read_error(3, 'basin_intcp_evap_yr') - IF ( declvar(MODNAME, 'obs_runoff_tot', 'one', 1, 'double', & - & 'Total simulation measured streamflow at basin outlet', & - & 'cfs', Obs_runoff_tot)/=0 ) CALL read_error(3, 'obs_runoff_tot') - IF ( declvar(MODNAME, 'basin_cfs_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average streamflow', & - & 'inches', Basin_cfs_tot)/=0 ) CALL read_error(3, 'basin_cfs_tot') - IF ( declvar(MODNAME, 'basin_ppt_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average precipitation', & - & 'inches', Basin_ppt_tot)/=0 ) CALL read_error(3, 'basin_ppt_tot') - IF ( declvar(MODNAME, 'basin_max_temp_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average maximum temperature', & - & 'temp_units', Basin_max_temp_tot)/=0 ) CALL read_error(3, 'basin_max_temp_tot') - IF ( declvar(MODNAME, 'basin_min_temp_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average minimum temperature', & - & 'temp_units', Basin_min_temp_tot)/=0 ) CALL read_error(3, 'basin_min_temp_tot') - IF ( declvar(MODNAME, 'basin_potet_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average potential ET', & - & 'inches', Basin_potet_tot)/=0 ) CALL read_error(3, 'basin_potet_tot') - IF ( declvar(MODNAME, 'basin_actet_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average actual ET', & - & 'inches', Basin_actet_tot)/=0 ) CALL read_error(3, 'basin_actet_tot') - IF ( declvar(MODNAME, 'basin_snowmelt_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average snowmelt', & - & 'inches', Basin_snowmelt_tot)/=0 ) CALL read_error(3, 'basin_snowmelt_tot') - IF ( declvar(MODNAME, 'basin_gwflow_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average groundwater discharge' , & - & 'inches', Basin_gwflow_tot)/=0 ) CALL read_error(3, 'basin_gwflow_tot') - IF ( declvar(MODNAME, 'basin_ssflow_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average interflow', & - & 'inches', Basin_ssflow_tot)/=0 ) CALL read_error(3, 'basin_ssflow_tot') - IF ( declvar(MODNAME, 'basin_sroff_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average overland flow', & - & 'inches', Basin_sroff_tot)/=0 ) CALL read_error(3, 'basin_sroff_tot') - IF ( declvar(MODNAME, 'basin_stflow_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average streamflow', & - & 'inches', Basin_stflow_tot)/=0 ) CALL read_error(3, 'basin_stflow_tot') - IF ( declvar(MODNAME, 'obsq_inches_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average measured streamflow at specified outlet station', & - & 'inches', Obsq_inches_tot)/=0 ) CALL read_error(3, 'obsq_inches_tot') - IF ( declvar(MODNAME, 'basin_intcp_evap_tot', 'one', 1, 'double', & - & 'Total simulation basin area-weighted average canopy evaporation', & - & 'inches', Basin_intcp_evap_tot)/=0 ) CALL read_error(3, 'basin_intcp_evap_tot') - -! declare parameters - IF ( Nobs>0 .OR. Model==99 ) THEN - IF ( declparam(MODNAME, 'outlet_sta', 'one', 'integer', & - & '0', 'bounded', 'nobs', & - & 'Index of measurement station to use for basin outlet', & - & 'Index of measured streamflow station corresponding to the basin outlet', & - & 'none')/=0 ) CALL read_error(1, 'outlet_sta') - ENDIF - - IF ( declparam(MODNAME, 'print_type', 'one', 'integer', & - & '1', '0', '2', & - & 'Type of output written to output file', & - & 'Flag to select the type of results written to the output'// & - & ' file (0=measured and simulated flow only;'// & - & ' 1=water balance table; 2=detailed output)', & - & 'none')/=0 ) CALL read_error(1, 'print_type') - - IF ( declparam(MODNAME, 'print_freq', 'one', 'integer', & - & '3', '0', '15', & - & 'Frequency for the output frequency', & - & 'Flag to select the output frequency; for combinations,'// & - & ' add index numbers, e.g., daily plus yearly = 10;'// & - & ' yearly plus total = 3 (0=none; 1=run totals; 2=yearly;'// & - & ' 4=monthly; 8=daily; or additive combinations)', & - & 'none')/=0 ) CALL read_error(1, 'print_freq') - - IF ( declvar(MODNAME, 'basin_intcp_evap_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average interception evaporation', & - & 'inches', Basin_intcp_evap_mo)/=0 ) CALL read_error(3, 'basin_intcp_evap_mo') - - IF ( declvar(MODNAME, 'basin_storage', 'one', 1, 'double', & - & 'Basin area-weighted average storage in all water storage reservoirs', & - & 'inches', Basin_storage)/=0 ) CALL read_error(3, 'basin_storage') - -!******************basin_storage volume: - IF ( declvar(MODNAME, 'basin_storvol', 'one', 1, 'double', & - & 'Basin area-weighted average storage volume in all water storage reservoirs', & - & 'acre-inches', Basin_storvol)/=0 ) CALL read_error(3, 'basin_storvol') - - IF ( declvar(MODNAME, 'obsq_inches', 'one', 1, 'double', & - & 'Measured streamflow at specified outlet station', & - & 'inches', Obsq_inches)/=0 ) CALL read_error(3, 'obsq_inches') - - IF ( declvar(MODNAME, 'basin_ppt_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average precipitation', & - & 'inches', Basin_ppt_mo)/=0 ) CALL read_error(3, 'basin_ppt_mo') - - IF ( declvar(MODNAME, 'basin_net_ppt_mo', 'one', 1, 'double', & - & 'Monthly area-weighted average net precipitation', & - & 'inches', Basin_net_ppt_mo)/=0 ) CALL read_error(3, 'basin_net_ppt_mo') - - IF ( declvar(MODNAME, 'basin_max_temp_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average maximum air temperature', & - & 'temp_units', Basin_max_temp_mo)/=0 ) CALL read_error(3, 'basin_max_temp_mo') - - IF ( declvar(MODNAME, 'basin_min_temp_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average minimum air temperature', & - & 'temp_units', Basin_min_temp_mo)/=0 ) CALL read_error(3, 'basin_min_temp_mo') - - IF ( declvar(MODNAME, 'basin_potet_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average potential ET', & - & 'inches', Basin_potet_mo)/=0 ) CALL read_error(3, 'basin_potet_mo') - - IF ( declvar(MODNAME, 'basin_actet_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average actual ET', & - & 'inches', Basin_actet_mo)/=0 ) CALL read_error(3, 'basin_actet_mo') - - IF ( declvar(MODNAME, 'basin_snowmelt_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average snowmelt', & - & 'inches', Basin_snowmelt_mo)/=0 ) CALL read_error(3, 'basin_snowmelt_mo') - - IF ( declvar(MODNAME, 'basin_gwflow_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average groundwater discharge', & - & 'inches', Basin_gwflow_mo)/=0 ) CALL read_error(3, 'basin_gwflow_mo') - - IF ( declvar(MODNAME, 'basin_ssflow_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average interflow', & - & 'inches', Basin_ssflow_mo)/=0 ) CALL read_error(3, 'basin_ssflow_mo') - - IF ( declvar(MODNAME, 'basin_sroff_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average surface runoff', & - & 'inches', Basin_sroff_mo)/=0 ) CALL read_error(3, 'basin_sroff_mo') - - IF ( declvar(MODNAME, 'basin_stflow_mo', 'one', 1, 'double', & - & 'Monthly basin area-weighted average simulated streamflow', & - & 'inches', Basin_stflow_mo)/=0 ) CALL read_error(3, 'basin_stflow_mo') - - IF ( declvar(MODNAME, 'obsq_inches_mo', 'one', 1, 'double', & - & 'Monthly measured streamflow at specified outlet station', & - & 'inches', Obsq_inches_mo)/=0 ) CALL read_error(3, 'obsq_inches_mo') - - ALLOCATE ( Hru_et_yr(Nhru) ) - IF ( declvar(MODNAME, 'hru_et_yr', 'nhru', Nhru, 'double', & - & 'Yearly area-weighted average actual ET for each HRU', & - & 'inches', Hru_et_yr)/=0 ) CALL read_error(3, 'hru_et_yr') - - IF ( declvar(MODNAME, 'basin_runoff_ratio_mo', 'one', 1, 'double', & - & 'Monthly area-weighted average discharge/precipitation', & - & 'decimal fraction', Basin_runoff_ratio_mo)/=0 ) CALL read_error(3, 'basin_runoff_ratio_mo') - - IF ( declvar(MODNAME, 'basin_runoff_ratio', 'one', 1, 'double', & - & 'Basin area-weighted average discharge/precipitation', & - & 'decimal fraction', Basin_runoff_ratio)/=0 ) CALL read_error(3, 'basin_runoff_ratio') - - END FUNCTION sumbdecl - -!*********************************************************************** -! sumbinit - Initialize basinsum module - get parameter values -!*********************************************************************** - INTEGER FUNCTION sumbinit() - USE PRMS_BASINSUM - USE PRMS_MODULE, ONLY: Print_debug, Nobs, Init_vars_from_file - USE PRMS_FLOWVARS, ONLY: Basin_soil_moist, Basin_ssstor, Basin_lake_stor - USE PRMS_INTCP, ONLY: Basin_intcp_stor - USE PRMS_SNOW, ONLY: Basin_pweqv - USE PRMS_SRUNOFF, ONLY: Basin_imperv_stor, Basin_dprst_volcl, Basin_dprst_volop - USE PRMS_GWFLOW, ONLY: Basin_gwstor - IMPLICIT NONE - INTRINSIC MAX, MOD - INTEGER, EXTERNAL :: getparam, julian_day - EXTERNAL :: header_print, read_error, write_outfile, basin_sum_restart, PRMS_open_module_file -! Local Variables - INTEGER :: pftemp -!*********************************************************************** - sumbinit = 0 - - IF ( Nobs>0 ) THEN - IF ( getparam(MODNAME, 'outlet_sta', 1, 'integer', Outlet_sta) & - & /=0 ) CALL read_error(2, 'outlet_sta') - IF ( Outlet_sta==0 ) Outlet_sta = 1 - ENDIF - - IF ( getparam(MODNAME, 'print_type', 1, 'integer', Print_type) & - & /=0 ) CALL read_error(2, 'print_type') - - IF ( getparam(MODNAME, 'print_freq', 1, 'integer', Print_freq) & - & /=0 ) CALL read_error(2, 'print_freq') - - IF ( Init_vars_from_file>0 ) THEN - CALL basin_sum_restart(1) - ELSE -! Zero stuff out when Timestep = 0 - Watbal_sum = 0.0D0 - - Obs_runoff_mo = 0.0D0 - Basin_cfs_mo = 0.0D0 - Basin_ppt_mo = 0.0D0 - Basin_net_ppt_mo = 0.0D0 - Basin_swrad_mo = 0.0D0 - Basin_max_temp_mo = 0.0D0 - Basin_min_temp_mo = 0.0D0 - Basin_intcp_evap_mo = 0.0D0 - Basin_potet_mo = 0.0D0 - Basin_actet_mo = 0.0D0 - Basin_snowmelt_mo = 0.0D0 - Basin_gwflow_mo = 0.0D0 - Basin_ssflow_mo = 0.0D0 - Basin_sroff_mo = 0.0D0 - Basin_stflow_mo = 0.0D0 - Obsq_inches_mo = 0.0D0 - Basin_runoff_ratio = 0.0D0 - Basin_runoff_ratio_mo = 0.0D0 - Basin_lakeevap_mo = 0.0D0 - - Obs_runoff_yr = 0.0D0 - Basin_cfs_yr = 0.0D0 - Basin_ppt_yr = 0.0D0 - Basin_net_ppt_yr = 0.0D0 - Basin_swrad_yr = 0.0D0 - Basin_max_temp_yr = 0.0D0 - Basin_min_temp_yr = 0.0D0 - Basin_intcp_evap_yr = 0.0D0 - Basin_lakeevap_yr = 0.0D0 - Basin_potet_yr = 0.0D0 - Basin_actet_yr = 0.0D0 - Basin_snowmelt_yr = 0.0D0 - Basin_gwflow_yr = 0.0D0 - Basin_ssflow_yr = 0.0D0 - Basin_sroff_yr = 0.0D0 - Basin_stflow_yr = 0.0D0 - Obsq_inches_yr = 0.0D0 - - Obs_runoff_tot = 0.0D0 - Basin_cfs_tot = 0.0D0 - Basin_ppt_tot = 0.0D0 - Basin_net_ppt_tot = 0.0D0 - Basin_swrad_tot = 0.0D0 - Basin_max_temp_tot = 0.0D0 - Basin_min_temp_tot = 0.0D0 - Basin_intcp_evap_tot = 0.0D0 - Basin_potet_tot = 0.0D0 - Basin_actet_tot = 0.0D0 - Basin_snowmelt_tot = 0.0D0 - Basin_gwflow_tot = 0.0D0 - Basin_ssflow_tot = 0.0D0 - Basin_sroff_tot = 0.0D0 - Basin_stflow_tot = 0.0D0 - Obsq_inches_tot = 0.0D0 - Hru_et_yr = 0.0D0 - Totdays = 0 - Obsq_inches = 0.0D0 - Basin_storage = 0.0D0 - Basin_storvol = 0.0D0 - ENDIF - -!******Set daily print switch - IF ( Print_freq>7 ) THEN - Dprt = .TRUE. - ELSE - Dprt = .FALSE. - ENDIF - -!******Set monthly print switch - IF ( Print_freq>3 .AND. (Print_freq<8 .OR. Print_freq>11) ) THEN - Mprt = .TRUE. - ELSE - Mprt = .FALSE. - ENDIF - -!******Set yearly print switch - IF ( Print_freq==2 .OR. Print_freq==3 .OR. Print_freq==6 .OR. Print_freq==7 .OR. & - & Print_freq==10.OR.Print_freq==11.OR.Print_freq==14.OR.Print_freq==15 ) THEN - Yprt = .TRUE. - ELSE - Yprt = .FALSE. - ENDIF - -!******Set total print switch - pftemp = MOD( Print_freq, 2 ) - IF ( pftemp==1 ) THEN - Tprt = .TRUE. - ELSE - Tprt = .FALSE. - ENDIF - -!******Set header print switch (1 prints a new header after every month -!****** summary, 2 prints a new header after every year summary) - Header_prt = 0 - IF ( Print_freq==6 .OR. Print_freq==7 .OR. Print_freq==10 .OR. Print_freq==11 ) Header_prt = 1 - IF ( Print_freq>=12 ) Header_prt = 2 - IF ( .NOT.Dprt .AND. Print_type==1 ) Header_prt = 3 - - Basin_storage = Basin_soil_moist + Basin_intcp_stor + & - & Basin_gwstor + Basin_ssstor + Basin_pweqv + & - & Basin_imperv_stor + Basin_lake_stor + & - & Basin_dprst_volop + Basin_dprst_volcl -!glacier storage not known at start - - IF ( Print_freq/=0 ) THEN - CALL header_print(Print_type) -! Print span dashes and initial storage - IF ( Print_type==1 ) THEN - WRITE (Buffer48, "(' initial', 27X,F9.3)") Basin_storage - CALL write_outfile(Buffer48(:44)) - - ELSEIF ( Print_type==2 ) THEN - WRITE (Buffer120, 9001) Basin_intcp_stor, & - & Basin_soil_moist, Basin_pweqv, Basin_gwstor, Basin_ssstor - CALL write_outfile(Buffer120(:98)) - ENDIF - ENDIF - - Endjday = julian_day('end', 'calendar') - - IF ( Print_debug==4 ) CALL PRMS_open_module_file(BALUNT, 'basin_sum.dbg') - - 9001 FORMAT (' initial', 33X, F6.2, 20X, 2F6.2, F13.2, F6.2) - - END FUNCTION sumbinit - -!*********************************************************************** -! sumbrun - Computes summary values -!*********************************************************************** - INTEGER FUNCTION sumbrun() - USE PRMS_BASINSUM - USE PRMS_MODULE, ONLY: Print_debug, Nobs, End_year, Strmflow_flag, Glacier_flag - USE PRMS_BASIN, ONLY: Active_area, Active_hrus, Hru_route_order - USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_lakeevap, & - & Basin_actet, Basin_perv_et, Basin_swale_et, Hru_actet, & - & Basin_ssstor, Basin_soil_moist, Basin_cfs, Basin_stflow_out, Basin_lake_stor - USE PRMS_CLIMATEVARS, ONLY: Basin_swrad, Basin_ppt, Basin_potet, Basin_tmax, Basin_tmin - USE PRMS_SET_TIME, ONLY: Jday, Modays, Yrdays, Julwater, Nowyear, Nowmonth, Nowday, Cfs2inches - USE PRMS_OBS, ONLY: Streamflow_cfs - USE PRMS_GWFLOW, ONLY: Basin_gwflow, Basin_gwstor, Basin_gwsink, Basin_gwstor_minarea_wb - USE PRMS_INTCP, ONLY: Basin_intcp_evap, Basin_intcp_stor, Basin_net_ppt - USE PRMS_SNOW, ONLY: Basin_snowmelt, Basin_pweqv, Basin_snowevap - USE PRMS_GLACR, ONLY: Basin_gl_storage - USE PRMS_SRUNOFF, ONLY: Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, & - & Basin_dprst_evap, Basin_dprst_volcl, Basin_dprst_volop - USE PRMS_ROUTING, ONLY: Basin_segment_storage - IMPLICIT NONE -! Functions - INTRINSIC SNGL, ABS, ALOG, DBLE - EXTERNAL :: header_print, write_outfile -! Local variables - INTEGER :: i, j, wyday, endrun, monthdays - DOUBLE PRECISION :: wat_bal, obsrunoff -!*********************************************************************** - sumbrun = 0 - - wyday = Julwater - - IF ( Nowyear==End_year .AND. Jday==Endjday ) THEN - endrun = 1 - ELSE - endrun = 0 - ENDIF - -!*****Compute aggregated values - - Last_basin_stor = Basin_storage - Basin_storage = Basin_soil_moist + Basin_intcp_stor + & - & Basin_gwstor + Basin_ssstor + Basin_pweqv + & - & Basin_imperv_stor + Basin_lake_stor + Basin_dprst_volop + Basin_dprst_volcl -! Basin_storage doesn't include any processes on glacier -! In glacier module, Basin_gl_storstart is an estimate for starting glacier volume, but only -! includes glaciers that have depth estimates and these are known to be iffy - IF ( Glacier_flag==1 ) Basin_storage = Basin_storage + Basin_gl_storage - IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 ) Basin_storage = Basin_storage + Basin_segment_storage - -! volume calculation for storage - Basin_storvol = Basin_storage*Active_area - - obsrunoff = 0.0D0 - IF ( Nobs>0 ) obsrunoff = Streamflow_cfs(Outlet_sta) - Obsq_inches = obsrunoff*Cfs2inches - - wat_bal = Last_basin_stor - Basin_storage + Basin_ppt + Basin_gwstor_minarea_wb & - & - Basin_actet - Basin_stflow_out - Basin_gwsink - - IF ( Basin_stflow_out>0.0 ) THEN - Basin_runoff_ratio = Basin_ppt/Basin_stflow_out - ELSE - Basin_runoff_ratio = 0.0 - ENDIF - - IF ( Print_debug==4 ) THEN - WRITE ( BALUNT, "(A,2I4,7F8.4)" ) ' bsto-sm-in-gw-ss-sn-iv ', & - & Nowmonth, Nowday, Basin_storage, Basin_soil_moist, & - & Basin_intcp_stor, Basin_gwstor, Basin_ssstor, & - & Basin_pweqv, Basin_imperv_stor - - WRITE ( BALUNT, "(A,I6,8F8.4)" )' bet-pv-iv-in-sn-lk-sw-dp', Nowday, & - & Basin_actet, Basin_perv_et, Basin_imperv_evap, & - & Basin_intcp_evap, Basin_snowevap, Basin_lakeevap, & - & Basin_swale_et, Basin_dprst_evap - - WRITE ( BALUNT, "(A,I6,7F8.4,/)" ) ' bal-pp-et-st-ls-bs-gs ', & - & Nowday, wat_bal, Basin_ppt, Basin_actet, Basin_stflow_out, & - & Last_basin_stor, Basin_storage, Basin_gwsink - ENDIF - - Watbal_sum = Watbal_sum + wat_bal - -!******Check for daily print - - IF ( Dprt ) THEN - IF ( Print_type==0 ) THEN - WRITE ( Buffer40, "(I7,2I5,F11.2,F12.2)" ) Nowyear, & - & Nowmonth, Nowday, obsrunoff, Basin_cfs - CALL write_outfile(Buffer40) - - ELSEIF ( Print_type==1 ) THEN - WRITE ( Buffer80, "(I7,2I5,7F9.3)" ) Nowyear, & - & Nowmonth, Nowday, Basin_ppt, Basin_actet, Basin_storage, & - & Basin_stflow_out, Obsq_inches, wat_bal, Watbal_sum - CALL write_outfile(Buffer80) - - ELSEIF ( Print_type==2 ) THEN - WRITE ( Buffer151, 9001 ) Nowyear, Nowmonth, Nowday, Basin_swrad, & - & Basin_tmax, Basin_tmin, Basin_ppt, Basin_net_ppt, & - & Basin_intcp_stor, Basin_intcp_evap, Basin_potet, & - & Basin_actet, Basin_soil_moist, Basin_pweqv, & - & Basin_snowmelt, Basin_gwstor, Basin_ssstor, & - & Basin_gwflow, Basin_ssflow, Basin_sroff, & - & Basin_stflow_out, Basin_cfs, obsrunoff, Basin_lakeevap - CALL write_outfile(Buffer151) - - ENDIF - ENDIF - IF ( Print_debug==4 ) WRITE ( BALUNT, * ) 'wat_bal =', wat_bal, & - & ' watbal_sum=', Watbal_sum - -!******Compute monthly values - IF ( Nowday==1 ) THEN - Obs_runoff_mo = 0.0D0 - Basin_cfs_mo = 0.0D0 - Basin_ppt_mo = 0.0D0 - Basin_net_ppt_mo = 0.0D0 - Basin_swrad_mo = 0.0D0 - Basin_max_temp_mo = 0.0D0 - Basin_min_temp_mo = 0.0D0 - Basin_intcp_evap_mo = 0.0D0 - Basin_potet_mo = 0.0D0 - Basin_actet_mo = 0.0D0 - Basin_snowmelt_mo = 0.0D0 - Basin_gwflow_mo = 0.0D0 - Basin_ssflow_mo = 0.0D0 - Basin_sroff_mo = 0.0D0 - Basin_stflow_mo = 0.0D0 - Obsq_inches_mo = 0.0D0 - Basin_lakeevap_mo = 0.0D0 - ENDIF - - Obs_runoff_mo = Obs_runoff_mo + obsrunoff - Obsq_inches_mo = Obsq_inches_mo + obsrunoff*Cfs2inches - Basin_cfs_mo = Basin_cfs_mo + Basin_cfs - Basin_ppt_mo = Basin_ppt_mo + Basin_ppt - Basin_net_ppt_mo = Basin_net_ppt_mo + Basin_net_ppt - Basin_swrad_mo = Basin_swrad_mo + Basin_swrad - Basin_max_temp_mo = Basin_max_temp_mo + Basin_tmax - Basin_min_temp_mo = Basin_min_temp_mo + Basin_tmin - Basin_intcp_evap_mo = Basin_intcp_evap_mo + Basin_intcp_evap - Basin_potet_mo = Basin_potet_mo + Basin_potet - Basin_actet_mo = Basin_actet_mo + Basin_actet - Basin_snowmelt_mo = Basin_snowmelt_mo + Basin_snowmelt - Basin_gwflow_mo = Basin_gwflow_mo + Basin_gwflow - Basin_ssflow_mo = Basin_ssflow_mo + Basin_ssflow - Basin_sroff_mo = Basin_sroff_mo + Basin_sroff - Basin_stflow_mo = Basin_stflow_mo + Basin_stflow_out - Basin_lakeevap_mo = Basin_lakeevap_mo + Basin_lakeevap - - IF ( Nowday==Modays(Nowmonth) ) THEN - monthdays = Modays(Nowmonth) - Basin_swrad_mo = Basin_swrad_mo/monthdays - Basin_max_temp_mo = Basin_max_temp_mo/monthdays - Basin_min_temp_mo = Basin_min_temp_mo/monthdays - Obs_runoff_mo = Obs_runoff_mo/monthdays - Basin_cfs_mo = Basin_cfs_mo/monthdays - Basin_runoff_ratio_mo = Basin_ppt_mo/monthdays/Basin_stflow_mo - Basin_lakeevap_mo = Basin_lakeevap_mo/monthdays - - IF ( Mprt ) THEN - IF ( Print_type==0 ) THEN - IF ( Dprt ) CALL write_outfile(DASHS(:40)) - WRITE ( Buffer40, "(I7,I5,F16.2,F12.2)" ) Nowyear, Nowmonth, Obs_runoff_mo, Basin_cfs_mo - CALL write_outfile(Buffer40) - IF ( Dprt ) CALL write_outfile(DASHS(:40)) - - ELSEIF ( Print_type==1 ) THEN - IF ( Dprt ) CALL write_outfile(DASHS(:62)) - WRITE ( Buffer80, "(I7,I5,5X,5F9.3)" ) Nowyear, & - & Nowmonth, Basin_ppt_mo, Basin_actet_mo, Basin_storage, & - & Basin_stflow_mo, Obsq_inches_mo - CALL write_outfile(Buffer80(:62)) - IF ( Dprt ) CALL write_outfile(DASHS(:62)) - - ELSEIF ( Print_type==2 ) THEN - IF ( Dprt ) CALL write_outfile(DASHS) - WRITE ( Buffer151, 9006 ) Nowyear, Nowmonth, Basin_swrad_mo, Basin_max_temp_mo, & - & Basin_min_temp_mo, Basin_ppt_mo, Basin_net_ppt_mo, & - & Basin_intcp_evap_mo, Basin_potet_mo, Basin_actet_mo, & - & Basin_soil_moist, Basin_pweqv, Basin_snowmelt_mo, & - & Basin_gwstor, Basin_ssstor, Basin_gwflow_mo, & - & Basin_ssflow_mo, Basin_sroff_mo, Basin_stflow_mo, & - & Basin_cfs_mo, Obs_runoff_mo, Basin_lakeevap_mo - CALL write_outfile(Buffer151) - IF ( Dprt ) CALL write_outfile(DASHS) - ENDIF - - ENDIF - ENDIF - -!******Check for year print - - IF ( Yprt ) THEN - Obs_runoff_yr = Obs_runoff_yr + obsrunoff - Obsq_inches_yr = Obsq_inches_yr + obsrunoff*Cfs2inches - Basin_cfs_yr = Basin_cfs_yr + Basin_cfs - Basin_ppt_yr = Basin_ppt_yr + Basin_ppt - Basin_net_ppt_yr = Basin_net_ppt_yr + Basin_net_ppt - Basin_swrad_yr = Basin_swrad_yr + Basin_swrad - Basin_max_temp_yr = Basin_max_temp_yr + Basin_tmax - Basin_min_temp_yr = Basin_min_temp_yr + Basin_tmin - Basin_intcp_evap_yr = Basin_intcp_evap_yr + Basin_intcp_evap - Basin_lakeevap_yr = Basin_lakeevap_yr + Basin_lakeevap - Basin_potet_yr = Basin_potet_yr + Basin_potet - Basin_actet_yr = Basin_actet_yr + Basin_actet - Basin_snowmelt_yr = Basin_snowmelt_yr + Basin_snowmelt - Basin_gwflow_yr = Basin_gwflow_yr + Basin_gwflow - Basin_ssflow_yr = Basin_ssflow_yr + Basin_ssflow - Basin_sroff_yr = Basin_sroff_yr + Basin_sroff - Basin_stflow_yr = Basin_stflow_yr + Basin_stflow_out - DO j = 1, Active_hrus - i = Hru_route_order(j) - Hru_et_yr(i) = Hru_et_yr(i) + DBLE( Hru_actet(i) ) - ENDDO - - IF ( wyday==Yrdays ) THEN - IF ( Print_type==0 ) THEN - - Obs_runoff_yr = Obs_runoff_yr/Yrdays - Basin_cfs_yr = Basin_cfs_yr/Yrdays - IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:40)) - WRITE ( Buffer40, "(I7,F21.2,F12.2)" ) Nowyear, Obs_runoff_yr, Basin_cfs_yr - CALL write_outfile(Buffer40) - IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:40)) - -! ****annual summary here - ELSEIF ( Print_type==1 ) THEN - IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:62)) - WRITE ( Buffer80, "(I7,10X,5F9.3)" ) Nowyear, Basin_ppt_yr, & - & Basin_actet_yr, Basin_storage, Basin_stflow_yr, Obsq_inches_yr - CALL write_outfile(Buffer80(:62)) - IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS(:62)) - - ELSEIF ( Print_type==2 ) THEN - Basin_swrad_yr = Basin_swrad_yr/Yrdays - Basin_max_temp_yr = Basin_max_temp_yr/Yrdays - Basin_min_temp_yr = Basin_min_temp_yr/Yrdays - Obs_runoff_yr = Obs_runoff_yr/Yrdays - Basin_cfs_yr = Basin_cfs_yr/Yrdays - IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS) - WRITE ( Buffer151, 9007 ) Nowyear, Basin_swrad_yr, Basin_max_temp_yr, & - & Basin_min_temp_yr, Basin_ppt_yr, Basin_net_ppt_yr, & - & Basin_intcp_stor, Basin_intcp_evap_yr, Basin_potet_yr, Basin_actet_yr, & - & Basin_soil_moist, Basin_pweqv, Basin_snowmelt_yr, & - & Basin_gwstor, Basin_ssstor, Basin_gwflow_yr, & - & Basin_ssflow_yr, Basin_sroff_yr, Basin_stflow_yr, & - & Basin_cfs_yr, Obs_runoff_yr, Basin_lakeevap_yr - CALL write_outfile(Buffer151) - IF ( Mprt .OR. Dprt ) CALL write_outfile(EQULS) - ENDIF - - Obs_runoff_yr = 0.0D0 - Basin_cfs_yr = 0.0D0 - Basin_ppt_yr = 0.0D0 - Basin_net_ppt_yr = 0.0D0 - Basin_swrad_yr = 0.0D0 - Basin_max_temp_yr = 0.0D0 - Basin_min_temp_yr = 0.0D0 - Basin_intcp_evap_yr = 0.0D0 - Basin_lakeevap_yr = 0.0D0 - Basin_potet_yr = 0.0D0 - Basin_actet_yr = 0.0D0 - Basin_snowmelt_yr = 0.0D0 - Basin_gwflow_yr = 0.0D0 - Basin_ssflow_yr = 0.0D0 - Basin_sroff_yr = 0.0D0 - Basin_stflow_yr = 0.0D0 - Obsq_inches_yr = 0.0D0 - Hru_et_yr = 0.0D0 - - ENDIF - ENDIF - -!******Check for total print - - IF ( Tprt ) THEN -!******Print heading if needed -! IF ( endrun==1 ) THEN -! CALL write_outfile(' ') -! IF ( .NOT.Dprt .OR. .NOT.Mprt .OR. .NOT.Yprt ) CALL header_print(Print_type) -! ENDIF - - Totdays = Totdays + 1 - Obs_runoff_tot = Obs_runoff_tot + obsrunoff - Obsq_inches_tot = Obsq_inches_tot + obsrunoff*Cfs2inches - Basin_cfs_tot = Basin_cfs_tot + Basin_cfs - Basin_ppt_tot = Basin_ppt_tot + Basin_ppt - Basin_net_ppt_tot = Basin_net_ppt_tot + Basin_net_ppt - Basin_swrad_tot = Basin_swrad_tot + Basin_swrad - Basin_max_temp_tot = Basin_max_temp_tot + Basin_tmax - Basin_min_temp_tot = Basin_min_temp_tot + Basin_tmin - Basin_intcp_evap_tot = Basin_intcp_evap_tot + Basin_intcp_evap - Basin_potet_tot = Basin_potet_tot + Basin_potet - Basin_actet_tot = Basin_actet_tot + Basin_actet - Basin_snowmelt_tot = Basin_snowmelt_tot + Basin_snowmelt - Basin_gwflow_tot = Basin_gwflow_tot + Basin_gwflow - Basin_ssflow_tot = Basin_ssflow_tot + Basin_ssflow - Basin_sroff_tot = Basin_sroff_tot + Basin_sroff - Basin_stflow_tot = Basin_stflow_tot + Basin_stflow_out - - IF ( endrun==1 ) THEN - - IF ( Print_type==0 ) THEN - Obs_runoff_tot = Obs_runoff_tot/Totdays - Basin_cfs_tot = Basin_cfs_tot/Totdays - CALL write_outfile(STARS(:40)) - WRITE ( Buffer48, "(A,F14.2,F12.2)" ) ' Total for run', Obs_runoff_tot, Basin_cfs_tot - CALL write_outfile(Buffer48(:40)) - CALL write_outfile(STARS(:40)) - - ELSEIF ( Print_type==1 ) THEN - CALL write_outfile(STARS(:62)) - WRITE ( Buffer80, 9005 ) ' Total for run', Basin_ppt_tot, & - & Basin_actet_tot, Basin_storage, Basin_stflow_tot, Obsq_inches_tot - CALL write_outfile(Buffer80(:62)) - CALL write_outfile(STARS(:62)) - - ELSEIF ( Print_type==2 ) THEN - Obs_runoff_tot = Obs_runoff_tot/Totdays - Basin_cfs_tot = Basin_cfs_tot/Totdays - CALL write_outfile(STARS) - WRITE ( Buffer151, 9004 ) ' Total for run', Basin_ppt_tot, & - & Basin_net_ppt_tot, Basin_intcp_evap_tot, & - & Basin_potet_tot, Basin_actet_tot, Basin_soil_moist, & - & Basin_pweqv, Basin_snowmelt_tot, Basin_gwstor, & - & Basin_ssstor, Basin_gwflow_tot, Basin_ssflow_tot, & - & Basin_sroff_tot, Basin_stflow_tot, Basin_cfs_tot, Obs_runoff_tot, Basin_lakeevap_yr - CALL write_outfile(Buffer151) - CALL write_outfile(STARS) - ENDIF - ENDIF - ENDIF - - 9001 FORMAT (I6, 2I3, F5.0, 2F5.1, 2F7.2, 2F6.2, 2F7.2, F6.2, F6.3, F7.3, 2F6.3, 3F7.2, F7.4, F9.1, F9.2, F7.2) - 9004 FORMAT (A, 13X, 2F7.2, F12.1, 2F7.2, 2F6.2, F7.2, 2F6.2, 4F7.2, F9.1, F9.2, F7.2) - 9005 FORMAT (A, 3X, 6F9.3) - 9006 FORMAT (I6, I3, 3X, 3F5.1, 2F7.2, F12.1, 2F7.2, 2F6.2, F7.2, 2F6.2, 3F7.2, F9.1, F9.2, 2F7.2) - 9007 FORMAT (I6, 6X, 3F5.1, 2F7.2, 2F6.2, 2F7.2, 2F6.2, F7.2, 2F6.2, 3F7.2, F9.2, F9.2, 2F7.2) - - END FUNCTION sumbrun - -!*********************************************************************** -! Print headers for tables -! This writes the measured and simulated table header. -!*********************************************************************** - SUBROUTINE header_print(Print_type) - USE PRMS_BASINSUM, ONLY: DASHS, Buffer80, Print_freq, Header_prt - IMPLICIT NONE - EXTERNAL write_outfile -! Arguments - INTEGER, INTENT(IN) :: Print_type -!*********************************************************************** - CALL write_outfile(' ') -! This writes the water balance table header. - IF ( Header_prt==3 ) THEN - CALL write_outfile(' Year Month Day Precip ET Storage S-Runoff M-Runoff') - WRITE (Buffer80, 9002) - CALL write_outfile(Buffer80(:62)) - CALL write_outfile(DASHS(:62)) - - ELSEIF ( Print_type==0 ) THEN - IF ( Print_freq==1 ) THEN - CALL write_outfile(' Measured Simulated') - ELSE - CALL write_outfile(' Year Month Day Measured Simulated') - ENDIF - CALL write_outfile(' (cfs) (cfs)') - CALL write_outfile(DASHS(:40)) - -! This writes the water balance table header. - ELSEIF ( Print_type==1 ) THEN - CALL write_outfile(' Year Month Day Precip ET Storage S-Runoff M-Runoff Watbal WBalSum') - WRITE (Buffer80, 9001) - CALL write_outfile(Buffer80) - CALL write_outfile(DASHS(:80)) - -! This writes the detailed table header. - ELSEIF ( Print_type==2 ) THEN - CALL write_outfile(' Year mo day srad tmx tmn ppt n-ppt ints intl potet'// & - & ' actet smav pweqv melt gwsto sssto gwflow ssflow sroff tot-fl sim meas lkevap') - CALL write_outfile(' (ly) (F/C)(F/C) (in) (in) (in) (in) (in)'// & - & ' (in) (in) (in) (in) (in) (in) (in) (in) (in) (in) (cfs) (cfs) (in)') - CALL write_outfile(DASHS) - - ENDIF - - 9001 FORMAT (17X, 7(' (inches)')) - 9002 FORMAT (17X, 5(' (inches)')) - - END SUBROUTINE header_print - -!*********************************************************************** -! Write or read restart file -!*********************************************************************** - SUBROUTINE basin_sum_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit - USE PRMS_BASINSUM - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - EXTERNAL check_restart - ! Local Variable - CHARACTER(LEN=9) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Totdays, Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot, Watbal_sum - WRITE ( Restart_outunit ) Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot, Basin_net_ppt_yr, Basin_net_ppt_tot - WRITE ( Restart_outunit ) Basin_max_temp_yr, Basin_max_temp_tot, Basin_min_temp_yr, Basin_min_temp_tot - WRITE ( Restart_outunit ) Basin_potet_yr, Basin_potet_tot, Basin_actet_yr, Basin_actet_tot - WRITE ( Restart_outunit ) Last_basin_stor, Basin_snowmelt_yr, Basin_snowmelt_tot, Basin_gwflow_yr, Basin_gwflow_tot - WRITE ( Restart_outunit ) Basin_ssflow_yr, Basin_ssflow_tot, Basin_sroff_yr, Basin_sroff_tot - WRITE ( Restart_outunit ) Basin_stflow_yr, Basin_stflow_tot, Basin_ppt_yr, Basin_ppt_tot - WRITE ( Restart_outunit ) Basin_intcp_evap_yr, Basin_intcp_evap_tot, Obsq_inches_yr, Obsq_inches_tot, Basin_lakeevap_yr - WRITE ( Restart_outunit ) Basin_net_ppt_mo, Obsq_inches_mo, Basin_max_temp_mo, Basin_min_temp_mo, Basin_actet_mo - WRITE ( Restart_outunit ) Basin_snowmelt_mo, Basin_gwflow_mo, Basin_sroff_mo, Basin_stflow_mo - WRITE ( Restart_outunit ) Basin_intcp_evap_mo, Basin_storage, Basin_storvol, Basin_potet_mo - WRITE ( Restart_outunit ) Basin_ssflow_mo, Basin_ppt_mo, Obsq_inches, Basin_runoff_ratio, Basin_runoff_ratio_mo - WRITE ( Restart_outunit ) Hru_et_yr - ELSE - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) Totdays, Obs_runoff_mo, Obs_runoff_yr, Obs_runoff_tot, Watbal_sum - READ ( Restart_inunit ) Basin_cfs_mo, Basin_cfs_yr, Basin_cfs_tot, Basin_net_ppt_yr, Basin_net_ppt_tot - READ ( Restart_inunit ) Basin_max_temp_yr, Basin_max_temp_tot, Basin_min_temp_yr, Basin_min_temp_tot - READ ( Restart_inunit ) Basin_potet_yr, Basin_potet_tot, Basin_actet_yr, Basin_actet_tot - READ ( Restart_inunit ) Last_basin_stor, Basin_snowmelt_yr, Basin_snowmelt_tot, Basin_gwflow_yr, Basin_gwflow_tot - READ ( Restart_inunit ) Basin_ssflow_yr, Basin_ssflow_tot, Basin_sroff_yr, Basin_sroff_tot - READ ( Restart_inunit ) Basin_stflow_yr, Basin_stflow_tot, Basin_ppt_yr, Basin_ppt_tot - READ ( Restart_inunit ) Basin_intcp_evap_yr, Basin_intcp_evap_tot, Obsq_inches_yr, Obsq_inches_tot, Basin_lakeevap_yr - READ ( Restart_inunit ) Basin_net_ppt_mo, Obsq_inches_mo, Basin_max_temp_mo, Basin_min_temp_mo, Basin_actet_mo - READ ( Restart_inunit ) Basin_snowmelt_mo, Basin_gwflow_mo, Basin_sroff_mo, Basin_stflow_mo - READ ( Restart_inunit ) Basin_intcp_evap_mo, Basin_storage, Basin_storvol, Basin_potet_mo - READ ( Restart_inunit ) Basin_ssflow_mo, Basin_ppt_mo, Obsq_inches, Basin_runoff_ratio, Basin_runoff_ratio_mo - READ ( Restart_inunit ) Hru_et_yr - ENDIF - END SUBROUTINE basin_sum_restart diff --git a/prms/muskingum_lakeCopy.f90 b/prms/muskingum_lakeCopy.f90 deleted file mode 100644 index 2737b6a1..00000000 --- a/prms/muskingum_lakeCopy.f90 +++ /dev/null @@ -1,1451 +0,0 @@ -!*********************************************************************** -! Routes water between segments and lakes in the stream network; -! using Muskingum routing for stream segments and 5 lake routing methods -! -! gwflow goes to GWR instead of to the lake unless specified as -! going to stream segment associated with the lake, which would be a -! problem -! -! nlake_hrus set to nlake for version 5.0.0, nlake_hrus to be added in 5.0.1 -! in future this module may be used for muskingum only, so would need to -! check lake_route_flag = 1 in a bunch of places -! -! The Muskingum equation is described in 'Hydrology for Engineers', 3rd ed. -! by Linsley, R.K, Kohler, M.A., and Paulhus, J.L.H., 1982 p. 275 and in -! 'Water in Environmental Planning' by Dunne, T., and Leopold, L.B. 1978 -! p. 357. -! -! Note that the Muskingum equation assumes a linear relation of storage -! to the inflow/outflow relation and therefore the relation is the same -! throughout the range of the hydrograph. The route_time parameter in -! the fixroute module is replaced by two new parameters, K_coef and -! x_coef, which are described below: -! -! The Muskingum method is based on the equation: S = K[xI + (1 - x)O] -! where S is storage, K is the storage coefficient, x is a coefficient -! between 0 and .5, I is inflow, and O is outflow. -! -! Solving for the outflow at day 2,O2; and knowing the inflow at day 1, -! I1; the inflow at day 2,I2; and the outflow at day 1, O1; the storage -! equation can be written as follows: -! -! O2 = czero*I2 + cone*I1 + ctwo*O1 -! -! where czero = -((Kx - 12) / (K - Kx + 12)) -! cone = (Kx + 12) / (K - Kx + 12) -! ctwo = (K - Kx - 12) / (K - Kx + 12) -! -! assuming a time step of one day and K is in units of hours -! -! This module is based on the "musroute.f" module. It differs in three -! basic ways: -! -! 1. This module uses an internal routing time step of one hour. -! The old muskingum module ran on the same daily time step as -! the rest of PRMS. The problem with this is that there is no -! ability to distinguish where the flood wave (front of the flow -! change) within the segment. For example, if there is a series -! of 4 1-day long segments, a flood wave will make it to the bottom -! of these in 1 day. If the same system is modeled as 1 4-day long -! segment, it will take 4 days. -! -! 2. The X parameter has been removed as a specified input and is now computed. To -! my knowledge, no modeler had ever set this to anything other than the default -! value (0.2) anyway. Always using the default value can lead to problems -! with the C coffecients which can result in mass balance problems or negative -! flow values. -! -! To solve this problem, I assume that the C coefficients must -! always be between 0 and 1. By setting the C coefficients equal to 0 and 1, -! various limits on the time step (ts), X, and K can be determined. There are -! two of these limits which are of interest: -! -! When C0 = 0: -! ts -! K = ----- -! 2X -! -! When C2 = 0: -! ts -! K = ----- -! 2(1-X) -! -! Determining a value of K half way between these two limits (by averaging) -! and solving for X using the quadratic formula results in: -! -! 1-sqrt(1-(ts/K)) -! X = ------------------ -! 2 -! -! So when ts is fixed at one hour and K is fixed as the average (or expected) -! travel time corresponding to the segment (for each segment in the stream -! network), a value of X can be computed (for each segment in the stream -! network) which will result in both conservation of mass and non-negative -! flows. Another benefit is that only one input parameter (K) needs to be -! input to the module. -! -! 3. If the travel time of a segment is less than or equal to the routing -! time step (one hour), then the outflow of the segment is set to the -! value of the inflow. -! -!*********************************************************************** - MODULE PRMS_MUSKINGUM_LAKE - IMPLICIT NONE -! Local Variables - DOUBLE PRECISION, PARAMETER :: ONE_24TH = 1.0D0 / 24.0D0 - INTEGER, SAVE :: Obs_flag, Linear_flag, Weir_flag, Gate_flag, Puls_flag - INTEGER, SAVE :: Secondoutflow_flag - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Currinsum(:), Pastin(:), Pastout(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:), Inflow_ts(:) - CHARACTER(LEN=14), SAVE :: MODNAME - DOUBLE PRECISION, SAVE, ALLOCATABLE :: C24(:, :), S24(:, :), Wvd(:, :) -! Dimensions - INTEGER, SAVE :: Mxnsos, Ngate, Nstage, Ngate2, Nstage2, Ngate3, Nstage3, Ngate4, Nstage4 -! Declared Variables - DOUBLE PRECISION, SAVE :: Basin_2ndstflow - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Din1(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_outcfs(:), Lake_outcms(:), Lake_outvol(:), Lake_invol(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_sto(:), Lake_inflow(:), Lake_outflow(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_stream_in(:), Lake_lateral_inflow(:), Lake_gwflow(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_precip(:), Lake_sroff(:), Lake_interflow(:), Lake_outvol_ts(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Lake_seep_in(:), Lake_evap(:), Lake_2gw(:), Lake_outq2(:) -! Declared Parameters - ! lake_segment_id only required if cascades are active, otherwise use hru_segment - INTEGER, SAVE, ALLOCATABLE :: Obsout_lake(:), Lake_out2(:), Nsos(:), Ratetbl_lake(:), Lake_segment_id(:) - REAL, SAVE, ALLOCATABLE :: Lake_qro(:), Lake_coef(:), Elev_outflow(:), Weir_coef(:), Weir_len(:) - REAL, SAVE, ALLOCATABLE :: Lake_out2_a(:), Lake_out2_b(:), O2(:, :), S2(:, :) - REAL, SAVE, ALLOCATABLE :: Lake_din1(:), Lake_init(:), Lake_vol_init(:) - REAL, SAVE, ALLOCATABLE :: Rate_table(:, :), Rate_table2(:, :), Rate_table3(:, :), Rate_table4(:, :) - REAL, SAVE, ALLOCATABLE :: Tbl_stage(:), Tbl_gate(:), Tbl_stage2(:), Tbl_gate2(:) - REAL, SAVE, ALLOCATABLE :: Tbl_stage3(:), Tbl_gate3(:), Tbl_stage4(:), Tbl_gate4(:) - END MODULE PRMS_MUSKINGUM_LAKE - -!*********************************************************************** -! Main muskingum_lake routine -!*********************************************************************** - INTEGER FUNCTION muskingum_lake() - USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: muskingum_lake_decl, muskingum_lake_init, muskingum_lake_run, muskingum_lake_setdims - EXTERNAL :: muskingum_lake_restart -!*********************************************************************** - muskingum_lake = 0 - - IF ( Process(:3)=='run' ) THEN - muskingum_lake = muskingum_lake_run() - ELSEIF ( Process(:7)=='setdims' ) THEN - muskingum_lake = muskingum_lake_setdims() - ELSEIF ( Process(:4)=='decl' ) THEN - muskingum_lake = muskingum_lake_decl() - ELSEIF ( Process(:4)=='init' ) THEN - IF ( Init_vars_from_file>0 ) CALL muskingum_lake_restart(1) - muskingum_lake = muskingum_lake_init() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL muskingum_lake_restart(0) - ENDIF - - END FUNCTION muskingum_lake - -!*********************************************************************** -! declares Lake routing specific dimensions -!*********************************************************************** - INTEGER FUNCTION muskingum_lake_setdims() - USE PRMS_MODULE, ONLY: MAXDIM - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: decldim - EXTERNAL read_error -!*********************************************************************** - muskingum_lake_setdims = 0 - - IF ( decldim('ngate', 0, MAXDIM, & - & 'Maximum number of reservoir gate-opening values (columns) for lake rating table 1')/=0 ) & - & CALL read_error(7, 'ngate') - IF ( decldim('nstage', 0, MAXDIM, & - & 'Maximum number of lake elevations values (rows) for lake rating table 1')/=0 ) CALL read_error(7, 'nstage') - - IF ( decldim('ngate2', 0, MAXDIM, & - & 'Maximum number of reservoir gate-opening values (columns) for lake rating table 2')/=0 ) & - & CALL read_error(7, 'ngate2') - IF ( decldim('nstage2', 0, MAXDIM, & - & 'Maximum number of lake elevations values (rows) for lake rating table 2')/=0 ) CALL read_error(7, 'nstage2') - - IF ( decldim('ngate3', 0, MAXDIM, & - & 'Maximum number of reservoir gate-opening values (columns) for lake rating table 3')/=0 ) & - & CALL read_error(7, 'ngate3') - IF ( decldim('nstage3', 0, MAXDIM, & - & 'Maximum number of lake elevations values (rows) for lake rating table 3')/=0 ) CALL read_error(7, 'nstage3') - - IF ( decldim('ngate4', 0, MAXDIM, & - & 'Maximum number of reservoir gate-opening values (columns) for lake rating table 4')/=0 ) & - & CALL read_error(7, 'ngate4') - IF ( decldim('nstage4', 0, MAXDIM, & - & 'Maximum number of lake elevations values (rows) for lake rating table 4')/=0 ) CALL read_error(7, 'nstage4') - - IF ( decldim('mxnsos', 0, MAXDIM, & - & 'Maximum number of storage/outflow table values for storage-detention reservoirs and lakes connected to'// & - & ' the stream network using Puls routing')/=0 ) CALL read_error(7, 'mxnsos') - - END FUNCTION muskingum_lake_setdims - -!*********************************************************************** -! muskingum_lake_decl - Declare parameters and variables and allocate arrays -! Declared Parameters -! tosegment, hru_segment, obsin_segment, K_coef, x_coef, segment_type -! lake_type, lake_init, lake_qro, lake_din1, lake_coef, o2, s2, nsos, hru_area, lake_segment_id -! tbl_stage, tbl_gate, lake_vol_init, rate_table, weir_coef, weir_len, elev_outflow, elevlake_init -! lake_out2, lake_out2_a, lake_out2_b -!*********************************************************************** - INTEGER FUNCTION muskingum_lake_decl() - USE PRMS_MUSKINGUM_LAKE - USE PRMS_MODULE, ONLY: Model, Nsegment, Init_vars_from_file, Nratetbl, Cascade_flag, Nlake - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: declparam, declvar, getdim - EXTERNAL read_error, print_module -! Local Variables - CHARACTER(LEN=80), SAVE :: Version_muskingum_lake -!*********************************************************************** - muskingum_lake_decl = 0 - - Version_muskingum_lake = 'muskingum_lake.f90 2018-04-25 17:00:00Z' - CALL print_module(Version_muskingum_lake, 'Streamflow Routing ', 90) - MODNAME = 'muskingum_lake' - - ! Dimension for Puls routing - Mxnsos = getdim('mxnsos') - IF ( Mxnsos==-1 ) CALL read_error(1, 'mxnsos') - IF ( Model==99 .AND. Mxnsos<1 ) Mxnsos = 1 - -! Nlake_hrus set to nlake in call_modules for 5.0.0, dimension nlake_hrus will be in 5.0.1 -! 5.0.0 assumes lakes are 1 HRU - IF ( Mxnsos>0 ) ALLOCATE ( Wvd(Mxnsos, Nlake), S24(Mxnsos, Nlake), C24(Mxnsos, Nlake) ) - - Ngate = 0 - Nstage = 0 - Ngate2 = 0 - Nstage2 = 0 - Ngate3 = 0 - Nstage3 = 0 - Ngate4 = 0 - Nstage4 = 0 - IF ( Model==99 ) Nratetbl = 4 - IF ( Nratetbl>4 ) THEN - PRINT *, 'ERROR, lake routing allows maximum of 4 rating tables' - PRINT *, 'nratetbl specified as:', Nratetbl - STOP - ENDIF - IF ( Nratetbl>0 ) THEN - Ngate = getdim('ngate') - IF ( Ngate==-1 ) CALL read_error(6, 'ngate') - Nstage = getdim('nstage') - IF ( Nstage==-1 ) CALL read_error(6, 'nstage') - IF ( Nratetbl>1 ) THEN - Ngate2 = getdim('ngate2') - IF ( Ngate2==-1 ) CALL read_error(6, 'ngate2') - Nstage2 = getdim('nstage2') - IF ( Nstage2==-1 ) CALL read_error(6, 'nstage2') - IF ( Nratetbl>2 ) THEN - Ngate3 = getdim('ngate3') - IF ( Ngate3==-1 ) CALL read_error(6, 'ngate3') - Nstage3 = getdim('nstage3') - IF ( Nstage3==-1 ) CALL read_error(6, 'nstage3') - IF ( Nratetbl==4 ) THEN - Ngate4 = getdim('ngate4') - IF ( Ngate4==-1 ) CALL read_error(6, 'ngate4') - Nstage4 = getdim('nstage4') - IF ( Nstage4==-1 ) CALL read_error(6, 'nstage4') - ENDIF - ENDIF - ENDIF - IF ( Model==99 ) THEN - IF ( Nstage==0 ) Nstage = 1 - IF ( Ngate==0 ) Ngate = 1 - IF ( Nstage2==0 ) Nstage2 = 1 - IF ( Ngate2==0 ) Ngate2 = 1 - IF ( Nstage3==0 ) Nstage3 = 1 - IF ( Ngate3==0 ) Ngate3 = 1 - IF ( Nstage4==0 ) Nstage4 = 1 - IF ( Ngate4==0 ) Ngate4 = 1 - ELSE - IF ( Nstage<1 .OR. Ngate<1 ) STOP 'ERROR, nratetbl>0 and nstage or ngate = 0' - ENDIF - IF ( Nratetbl>1 ) THEN - IF ( Nstage2<1.OR.Ngate2<1 ) STOP 'ERROR, nratetbl>1 and nstage2 or ngate2 = 0' - ENDIF - IF ( Nratetbl>2 ) THEN - IF ( Nstage3<1 .OR. Ngate3<1 ) STOP 'ERROR, nratetbl>2 and nstage3 or ngate3 = 0' - ENDIF - IF ( Nratetbl>3 ) THEN - IF ( Nstage4<1 .OR. Ngate4<1 ) STOP 'ERROR, nratetbl>3 and nstage4 or ngate4 = 0' - ENDIF - ENDIF - - ALLOCATE ( Currinsum(Nsegment) ) - ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) ) - ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) ) - - ! Lake declared variables - ALLOCATE ( Lake_inflow(Nlake) ) - IF ( declvar(MODNAME, 'lake_inflow', 'nlake', Nlake, 'double', & - & 'Total inflow to each lake', & - & 'cfs', Lake_inflow)/=0 ) CALL read_error(3, 'lake_inflow') - - ALLOCATE ( Lake_outflow(Nlake) ) - IF ( declvar(MODNAME, 'lake_outflow', 'nlake', Nlake, 'double', & - & 'Evaporation and seepage from each lake', & - & 'cfs', Lake_outflow)/=0 ) CALL read_error(3, 'lake_outflow') - - ALLOCATE ( Lake_outcfs(Nlake) ) - IF ( declvar(MODNAME, 'lake_outcfs', 'nlake', Nlake, 'double', & - & 'Streamflow leaving each lake, includes any second outlet flow', & - & 'cfs', Lake_outcfs)/=0 ) CALL read_error(3, 'lake_outcfs') - - ALLOCATE ( Lake_outcms(Nlake) ) - IF ( declvar(MODNAME, 'lake_outcms', 'nlake', Nlake, 'double', & - & 'Streamflow leaving each lake, includes any second outlet flow', & - & 'cms', Lake_outcms)/=0 ) CALL read_error(3, 'lake_outcms') - -! Declared Variables for Puls or linear routing - ALLOCATE ( Lake_sto(Nlake) ) - IF ( declvar(MODNAME, 'lake_sto', 'nlake', Nlake, 'double', & - & 'Storage in each lake using Puls or linear storage routing', & - & 'cfs-days', Lake_sto)/=0 ) CALL read_error(3, 'lake_sto') - - ALLOCATE ( Din1(Nlake) ) - IF ( declvar(MODNAME, 'din1', 'nlake', Nlake, 'double', & - & 'Inflow from the previous time step to each lake using Puls or linear storage routing', & - & 'cfs', Din1)/=0 ) CALL read_error(3, 'din1') - - ALLOCATE ( Lake_stream_in(Nlake) ) - IF ( declvar(MODNAME, 'lake_stream_in', 'nlake', Nlake, 'double', & - & 'Total streamflow into each lake', & - & 'cfs', Lake_stream_in)/=0 ) CALL read_error(3, 'lake_stream_in') - - ALLOCATE ( Lake_precip(Nlake) ) - IF ( declvar(MODNAME, 'lake_precip', 'nlake', Nlake, 'double', & - & 'Total precipitation into each lake', & - & 'cfs', Lake_precip)/=0 ) CALL read_error(3, 'lake_precip') - - IF ( Cascade_flag>0 .OR. Model==99 ) THEN - ALLOCATE ( Lake_lateral_inflow(Nlake) ) - IF ( declvar(MODNAME, 'lake_lateral_inflow', 'nlake', Nlake, 'double', & - & 'Lateral inflow to each lake', & - & 'cfs', Lake_lateral_inflow)/=0 ) CALL read_error(3, 'lake_lateral_inflow') - ALLOCATE ( Lake_sroff(Nlake) ) - IF ( declvar(MODNAME, 'lake_sroff', 'nlake', Nlake, 'double', & - & 'Total surface runoff into each lake', & - & 'cfs', Lake_sroff)/=0 ) CALL read_error(3, 'lake_sroff') - ALLOCATE ( Lake_interflow(Nlake) ) - IF ( declvar(MODNAME, 'lake_interflow', 'nlake', Nlake,'double', & - & 'Total interflow into each lake', & - & 'cfs', Lake_interflow)/=0 ) CALL read_error(3, 'lake_interflow') - ALLOCATE ( Lake_gwflow(Nlake) ) - IF ( declvar(MODNAME, 'lake_gwflow', 'nlake', Nlake,'double', & - & 'Total groundflow into each lake', & - & 'cfs', Lake_gwflow)/=0 ) CALL read_error(3, 'lake_gwflow') - ENDIF - - ALLOCATE ( Lake_evap(Nlake) ) - IF ( declvar(MODNAME, 'lake_evap', 'nlake', Nlake, 'double', & - & 'Total evaporation from each lake', & - & 'cfs', Lake_evap)/=0 ) CALL read_error(3, 'lake_evap') - -! Declared Variables for broad-crested weir or gate opening routing - ALLOCATE ( Lake_2gw(Nlake) ) - IF ( declvar(MODNAME, 'lake_2gw', 'nlake', Nlake, 'double', & - & 'Total seepage from each lake using broad-crested weir or gate opening routing', & - & 'cfs', Lake_2gw)/=0 ) CALL read_error(3, 'lake_2gw') - - ALLOCATE ( Lake_seep_in(Nlake) ) - IF ( declvar(MODNAME, 'lake_seep_in', 'nlake', Nlake, 'double', & - & 'Total seepage into each lake using broad-crested weir or gate opening routing', & - & 'cfs', Lake_seep_in)/=0 ) CALL read_error(3, 'lake_seep_in') - - ALLOCATE ( Lake_invol(Nlake) ) - IF ( declvar(MODNAME, 'lake_invol', 'nlake', Nlake, 'double', & - & 'Inflow to each lake using broad-crested weir or gate opening routing', & - & 'acre-feet', Lake_invol)/=0 ) CALL read_error(3, 'lake_invol') - -! Declared Variables for gate opening routing - ALLOCATE ( Lake_outvol(Nlake) ) - IF ( declvar(MODNAME, 'lake_outvol', 'nlake', Nlake, 'double', & - & 'Outflow from each lake using broad-crested weir or gate opening routing', & - & 'acre-inches', Lake_outvol)/=0 ) CALL read_error(3, 'lake_outvol') - - ALLOCATE ( Lake_outvol_ts(Nlake) ) - IF ( declvar(MODNAME, 'lake_outvol_ts', 'nlake', Nlake, 'double', & - & 'Outflow from each lake using broad-crested weir or gate opening routing for the time step', & - & 'acre-inches', Lake_outvol_ts)/=0 ) CALL read_error(3, 'lake_outvol_ts') - -! Declared Variables for lakes with a second outlet and gate opening routing - IF ( Nratetbl>0 .OR. Model==99 ) THEN - IF ( declvar(MODNAME, 'basin_2ndstflow', 'one', 1, 'double', & - & 'Basin volume-weighted average streamflow from each lake with a second outlet', & - & 'inches', Basin_2ndstflow)/=0 ) CALL read_error(3, 'basin_2ndstflow') - ALLOCATE ( Lake_outq2(Nlake) ) - IF ( declvar(MODNAME, 'lake_outq2', 'nlake', Nlake, 'double', & - & 'Streamflow from second outlet for each lake with a second outlet', & - & 'cfs', Lake_outq2)/=0 ) CALL read_error(3, 'lake_outq2') - ENDIF - -! Declared Parameters - ALLOCATE ( Lake_segment_id(Nsegment) ) - IF ( Cascade_flag>0 ) THEN - IF ( declparam(MODNAME, 'lake_segment_id', 'nsegment', 'integer', & - & '0', 'bounded', 'nlake', & - & 'Index of lake associated with a segment', & - & 'Index of lake associated with a segment', & - & 'none')/=0 ) CALL read_error(1, 'lake_segment_id') - ENDIF - - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - ALLOCATE ( Lake_qro(Nlake) ) - IF ( declparam(MODNAME, 'lake_qro', 'nlake', 'real', & - & '0.1', '0.0', '1.0E7', & - & 'Initial daily mean outflow from each lake', & - & 'Initial daily mean outflow from each lake', & - & 'cfs')/=0 ) CALL read_error(1, 'lake_qro') - -! Declared Parameters for Puls or linear routing - ALLOCATE ( Lake_init(Nlake) ) - IF ( declparam(MODNAME, 'lake_init', 'nlake', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Initial storage in each lake', & - & 'Initial storage in each lake using Puls or linear storage routing', & - & 'cfs-days')/=0 ) CALL read_error(1, 'lake_init') - - ALLOCATE ( Lake_din1(Nlake) ) - IF ( declparam(MODNAME, 'lake_din1', 'nlake', 'real', & - & '0.1', '0.0', '1.0E7', & - & 'Initial inflow to each lake', & - & 'Initial inflow to each lake using Puls or linear storage routing', & - & 'cfs')/=0 ) CALL read_error(1, 'lake_din1') - ENDIF - -! Declared Parameters for linear routing - ALLOCATE ( Lake_coef(Nlake) ) - IF ( declparam(MODNAME, 'lake_coef', 'nlake', 'real', & - & '0.1', '0.0001', '1.0', & - & 'Linear lake routing coefficient', & - & 'Coefficient in equation to route storage to streamflow for each lake using linear routing', & - & 'fraction/day')/=0 ) CALL read_error(1, 'lake_coef') - -! Declared Parameters for Puls routing - IF ( Mxnsos>0 ) THEN - ALLOCATE ( O2(Mxnsos, Nlake) ) - IF ( declparam(MODNAME, 'o2', 'mxnsos,nlake', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Outflow values in outflow/storage tables for Puls routing', & - & 'Outflow values in outflow/storage tables for each lake using Puls routing', & - & 'cfs')/=0 ) CALL read_error(1, 'o2') - - ALLOCATE ( S2(Mxnsos, Nlake) ) - IF ( declparam(MODNAME, 's2', 'mxnsos,nlake', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Storage values in outflow/storage tables for Puls routing', & - & 'Storage values in outflow/storage table for each lake using Puls routing', & - & 'cfs-days')/=0 ) CALL read_error(1, 's2') - - ALLOCATE ( Nsos(Nlake) ) - IF ( declparam(MODNAME, 'nsos', 'nlake', 'integer', & - & '0', 'bounded', 'mxnsos', & - & 'Number of storage/outflow values in table for Puls routing', & - & 'Number of storage/outflow values in table for each lake using Puls routing', & - & 'none')/=0 ) CALL read_error(1, 'nsos') - ENDIF - -! Declared Parameters for broad-crested weir or gate opening routing - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - ALLOCATE ( Lake_vol_init(Nlake) ) - IF ( declparam(MODNAME, 'lake_vol_init', 'nlake', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Initial lake volume', & - & 'Initial lake volume for each lake using broad-crested weir or gate opening routing', & - & 'acre-feet')/=0 ) CALL read_error(1, 'lake_vol_init') - ENDIF - -! Declared Parameters for broad-crested weir routing - ALLOCATE ( Weir_coef(Nlake) ) - IF ( declparam(MODNAME, 'weir_coef', 'nlake', 'real', & - & '2.7', '2.0', '3.0', & - & 'Broad-crested weir coefficent', & - & 'Coefficient for lakes using broad-crested weir routing', & - & 'none')/=0 ) CALL read_error(1, 'weir_coef') - - ALLOCATE ( Weir_len(Nlake) ) - IF ( declparam(MODNAME, 'weir_len', 'nlake', 'real', & - & '5.0', '1.0', '1000.0', & - & 'Broad-crested weir length', & - & 'Weir length for lakes using broad-crested weir routing', & - & 'feet')/=0 ) CALL read_error(1, 'weir_len') - - ALLOCATE ( Elev_outflow(Nlake) ) - IF ( declparam(MODNAME, 'elev_outflow', 'nlake', 'real', & - & '0.0', '-300.0', '10000.0', & - & 'Elevation of the main outflow point', & - & 'Elevation of the main outflow point for each lake using broad-crested weir routing', & - & 'feet')/=0 ) CALL read_error(1, 'elev_outflow') - -! Declared Parameters for gate opening routing - IF ( Nratetbl>0 ) THEN - ALLOCATE ( Ratetbl_lake(Nratetbl), Rate_table(Nstage,Ngate), Tbl_stage(Nstage), Tbl_gate(Ngate) ) - IF ( declparam(MODNAME, 'ratetbl_lake', 'nratetbl', 'integer', & - & '0', 'bounded', 'nlake', & - & 'Index of lake associated with each rating table', & - & 'Index of lake associated with each rating table for'// & - & ' each lake using gate opening routing', & - & 'none')/=0 ) CALL read_error(1, 'ratetbl_lake') - IF ( declparam(MODNAME, 'rate_table', 'nstage,ngate', 'real', & - & '5.0', '-100.0', '1000.0', & - & 'Rating table 1 with stage (rows) and gate opening (cols)', & - & 'Rating table with stage (rows) and gate opening'// & - & ' (cols) for rating table 1 for lakes using gate opening routing and nratetbl>0', & - & 'cfs')/=0 ) CALL read_error(1, 'rate_table') - IF ( declparam(MODNAME, 'tbl_stage', 'nstage', 'real', & - & '5.0', '-100.0', '1000.0', & - & 'Stage values for each row of rating table 1', & - & 'Stage values for each row for rating table 1 for lakes using gate opening routing and nratetbl>0', & - & 'feet')/=0 ) CALL read_error(1, 'tbl_stage') - IF ( declparam(MODNAME, 'tbl_gate', 'ngate', 'real', & - & '0.0', '0.0', '20.0', & - & 'Gate openings for each column of rating table 1', & - & 'Gate openings for each column for rating table 1 for lakes using gate opening routing and nratetbl>0', & - & 'inches')/=0 ) CALL read_error(1, 'tbl_gate') - - IF ( Nratetbl>1 ) THEN - ALLOCATE ( Rate_table2(Nstage2,Ngate2), Tbl_stage2(Nstage2), Tbl_gate2(Ngate2) ) - IF ( declparam(MODNAME, 'rate_table2', 'nstage2,ngate2', 'real', & - & '5.0', '-100.0', '1000.0', & - & 'Rating table 2 with stage (rows) and gate opening (cols)', & - & 'Rating table with stage (rows) and gate opening'// & - & ' (cols) for rating table 2 for lakes using gate opening routing and nratetbl>1', & - & 'cfs')/=0 ) CALL read_error(1, 'rate_table2') - IF ( declparam(MODNAME, 'tbl_stage2', 'nstage2', 'real', & - & '5.0', '-100.0', '1000.0', & - & 'Stage values for each row of rating table 2', & - & 'Stage values for each row for rating table 2 for lakes using gate opening routing and nratetbl>1', & - & 'feet')/=0 ) CALL read_error(1, 'tbl_stage2') - IF ( declparam(MODNAME, 'tbl_gate2', 'ngate2', 'real', & - & '0.0', '0.0', '20.0', & - & 'Gate openings for each column of rating table 2', & - & 'Gate openings for each column for rating table 2 for lakes using gate opening routing and nratetbl>1', & - & 'inches')/=0 ) CALL read_error(1, 'tbl_gate2') - - IF ( Nratetbl>2 ) THEN - ALLOCATE ( Rate_table3(Nstage3,Ngate3), Tbl_stage3(Nstage3), Tbl_gate3(Ngate3) ) - IF ( declparam(MODNAME, 'rate_table3', 'nstage3,ngate3', 'real', & - & '5.0', '-100.0', '1000.0', & - & 'Rating table 3 with stage (rows) and gate opening (cols)', & - & 'Rating table with stage (rows) and gate opening'// & - & ' (cols) for rating table 3 for lakes using gate opening routing and nratetbl>2', & - & 'cfs')/=0 ) CALL read_error(1, 'rate_table3') - IF ( declparam(MODNAME, 'tbl_stage3', 'nstage3', 'real', & - & '5.0', '-100.0', '1000.0', & - & 'Stage values for each row of rating table 3', & - & 'Stage values for each row for rating table 3 for lakes using gate opening routing and nratetbl>2', & - & 'feet')/=0 ) CALL read_error(1, 'tbl_stage3') - IF ( declparam(MODNAME, 'tbl_gate3', 'ngate3', 'real', & - & '0.0', '0.0', '20.0', & - & 'Gate openings for each column of rating table 3', & - & 'Gate openings for each column for rating table 3 for lakes using gate opening routing and nratetbl>2', & - & 'inches')/=0 ) CALL read_error(1, 'tbl_gate3') - - IF ( Nratetbl>3 ) THEN - ALLOCATE ( Rate_table4(Nstage4,Ngate4), Tbl_stage4(Nstage4), Tbl_gate4(Ngate4) ) - IF ( declparam(MODNAME, 'rate_table4', 'nstage4,ngate4', 'real', & - & '5.0', '-100.0', '1000.0', & - & 'Rating table 4 with stage (rows) and gate opening (cols)', & - & 'Rating table with stage (rows) and gate opening'// & - & ' (cols) for rating table 4 for lakes using gate opening routing and nratetbl>3', & - & 'cfs')/=0 ) CALL read_error(1, 'rate_table4') - IF ( declparam(MODNAME, 'tbl_stage4', 'nstage4', 'real', & - & '5.0', '-100.0', '1000.0', & - & 'Stage values for each row of rating table 4', & - & 'Stage values for each row for rating table 4 for lakes using gate opening routing and nratetbl>3', & - & 'feet')/=0 ) CALL read_error(1, 'tbl_stage4') - IF ( declparam(MODNAME, 'tbl_gate4', 'ngate4', 'real', & - & '0.0', '0.0', '20.0', & - & 'Gate openings for each column of rating table 4', & - & 'Gate openings for each column for rating table 4 for lakes using gate opening routing and nratetbl>3', & - & 'inches')/=0 ) CALL read_error(1, 'tbl_gate4') - ENDIF - ENDIF - ENDIF - ENDIF - -! Declared Parameters for lakes with lake outflow set to measured streamflow - ALLOCATE ( Obsout_lake(Nlake) ) - IF ( declparam(MODNAME, 'obsout_lake', 'nlake', 'integer', & - & '0', 'bounded', 'nobs', & - & 'Index of streamflow measurement station that specifies outflow from a lake', & - & 'Index of streamflow measurement station that specifies outflow from each lake using measured flow replacement', & - & 'none')/=0 ) CALL read_error(1, 'obsout_lake') - - IF ( Nratetbl>0 ) THEN -! Declared Parameters for lakes with a second outlet and gate opening routing - ALLOCATE ( Lake_out2(Nlake) ) - IF ( declparam(MODNAME, 'lake_out2', 'nlake', 'integer', & - & '0', '0', '1', & - & 'Switch to specify a second outlet from a lake', & - & 'Switch to specify a second outlet from each lake using gate opening routing (0=no; 1=yes)', & - & 'none')/=0 ) CALL read_error(1, 'lake_out2') - - ALLOCATE ( Lake_out2_a(Nlake) ) - IF ( declparam(MODNAME, 'lake_out2_a', 'nlake', 'real', & - & '1.0', '0.0', '10000.0', & - & 'Outflow coefficient A for each lake with second outlet', & - & 'Coefficient A in outflow equation for each lake with a second outlet using gate opening routing', & - & 'cfs/ft')/=0 ) CALL read_error(1, 'lake_out2_a') - - ALLOCATE ( Lake_out2_b(Nlake) ) - IF ( declparam(MODNAME, 'lake_out2_b', 'nlake', 'real', & - & '100.0', '0.0', '10000.0', & - & 'Outflow coefficient A for each lake with second outlet', & - & 'Coefficient B in outflow equation for each lake with a second outlet using gate opening routing', & - & 'cfs')/=0 ) CALL read_error(1, 'lake_out2_b') - ENDIF - - END FUNCTION muskingum_lake_decl - -!*********************************************************************** -! muskingum_lake_init - Get and check parameter values and initialize variables -!*********************************************************************** - INTEGER FUNCTION muskingum_lake_init() - USE PRMS_MUSKINGUM_LAKE - USE PRMS_MODULE, ONLY: Nsegment, Inputerror_flag, Init_vars_from_file, Nratetbl, Nhru, Cascade_flag, Nlake - USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, DNEARZERO, Active_hrus, Hru_route_order, Gwr_type, & - & CFS2CMS_CONV, Lake_hru_id, Weir_gate_flag, Lake_type, Puls_lin_flag - USE PRMS_FLOWVARS, ONLY: Seg_outflow, Basin_lake_stor, Lake_vol - USE PRMS_SET_TIME, ONLY: Cfs_conv - USE PRMS_ROUTING, ONLY: Basin_segment_storage, Segment_type, Hru_segment - IMPLICIT NONE -! Functions - INTRINSIC ABS, NINT, DBLE, DABS - EXTERNAL :: read_error - INTEGER, EXTERNAL :: getparam -! Local Variables - INTEGER :: i, ierr, j, jj, kk, ii, jjj - DOUBLE PRECISION :: tmp -!*********************************************************************** - muskingum_lake_init = 0 - - Basin_segment_storage = 0.0D0 - DO i = 1, Nsegment - Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) - ENDDO - Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv - -! Weir_gate_flag and Puls_lin_flag set in basin as needed for restart and gwflow module - Obs_flag = 0 - Linear_flag = 0 - Weir_flag = 0 - Gate_flag = 0 - Puls_flag = 0 - DO i = 1, Nlake - IF ( Lake_type(i)==1 ) THEN - Puls_flag = 1 - ELSEIF ( Lake_type(i)==2 ) THEN - Linear_flag = 1 - ELSEIF ( Lake_type(i)==4 ) THEN - Weir_flag = 1 - ELSEIF ( Lake_type(i)==5 ) THEN - Gate_flag = 1 - ELSEIF ( Lake_type(i)==6 ) THEN - Obs_flag = 1 - ELSEIF ( Lake_type(i)/=3 ) THEN - PRINT *, 'ERROR, invalid lake_type for lake:', i, Lake_type(i) - Inputerror_flag = 1 - ENDIF - ENDDO - - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - IF ( getparam(MODNAME, 'lake_qro', Nlake, 'real', Lake_qro)/=0 ) CALL read_error(2, 'lake_qro') - DO j = 1, Nlake - Lake_outcfs(j) = Lake_qro(j) - Lake_outcms(j) = Lake_qro(j)*CFS2CMS_CONV - ENDDO - ENDIF - - Lake_outvol = 0.0D0 - Lake_outvol_ts = 0.0D0 - Lake_invol = 0.0D0 - Lake_precip = 0.0D0 - Lake_seep_in = 0.0D0 - Lake_evap = 0.0D0 - Lake_2gw = 0.0D0 - Lake_inflow = 0.0D0 - Lake_outflow = 0.0D0 - IF ( Gate_flag==1 ) Lake_outq2 = 0.0D0 - Basin_2ndstflow = 0.0D0 - Lake_stream_in = 0.0D0 - Basin_lake_stor = 0.0D0 - IF ( Cascade_flag>0 ) THEN - Lake_lateral_inflow = 0.0D0 - Lake_sroff = 0.0D0 - Lake_interflow = 0.0D0 - Lake_gwflow = 0.0D0 - ENDIF - - IF ( Cascade_flag==0 .OR. Cascade_flag==2 ) THEN ! when cascades are active, hru_segment is not used - Lake_segment_id = 0 - DO jjj = 1, Active_hrus - j = Hru_route_order(jjj) - i = Hru_segment(j) - IF ( i>0 ) THEN - IF ( Segment_type(i)==2 ) Lake_segment_id(i) = Lake_hru_id(j) - ENDIF - ENDDO - ELSE - ! if cascades are active, must input new parameter lake_segment_id - IF ( getparam(MODNAME, 'lake_segment_id', Nsegment, 'integer', Lake_segment_id)/=0 ) CALL read_error(2, 'lake_segment_id') - ENDIF - DO j = 1, Nsegment - IF ( Lake_segment_id(j)>0 .AND. Segment_type(j)/=2 ) THEN - PRINT *, 'ERROR, segment_type not equal to 2 when the segment is associated with a lake' - PRINT *, ' segment:', j, ' lake:', Lake_segment_id(j) - Inputerror_flag = 1 - ENDIF - IF ( Lake_segment_id(j)==0 .AND. Segment_type(j)==2 ) THEN - PRINT *, 'ERROR, segment_type equals 2 when the segment is not associated with a lake' - PRINT *, ' segment:', j, ' lake:', Lake_segment_id(j) - Inputerror_flag = 1 - ENDIF - ENDDO - - Secondoutflow_flag = 0 - IF ( Gate_flag==1 ) THEN - IF ( Nratetbl<1 ) STOP 'ERROR, nratetbl = 0 and gate opening routing requested' - IF ( getparam(MODNAME, 'rate_table', Nstage*Ngate, 'real', Rate_table)/=0 ) CALL read_error(2, 'rate_table') - IF ( getparam(MODNAME, 'tbl_stage', Nstage, 'real', Tbl_stage)/=0 ) CALL read_error(2, 'tbl_stage') - IF ( getparam(MODNAME, 'tbl_gate', Ngate, 'real', Tbl_gate)/=0 ) CALL read_error(2, 'tbl_gate') - IF ( getparam(MODNAME, 'ratetbl_lake', Nratetbl, 'integer', Ratetbl_lake)/=0 ) CALL read_error(2, 'ratetbl_lake') - IF ( Gate_flag==1 ) THEN - IF ( getparam(MODNAME, 'lake_out2', Nlake, 'integer', Lake_out2)/=0 ) CALL read_error(2, 'lake_out2') - DO j = 1, Nlake - IF ( Lake_out2(j)==1 ) Secondoutflow_flag = 1 - ENDDO - IF ( Secondoutflow_flag==1 ) THEN - IF ( getparam(MODNAME, 'lake_out2_a', Nlake, 'real', Lake_out2_a)/=0 ) CALL read_error(2, 'lake_out2_a') - IF ( getparam(MODNAME, 'lake_out2_b', Nlake, 'real', Lake_out2_b)/=0 ) CALL read_error(2, 'lake_out2_b') - ENDIF - ENDIF - - IF ( Nratetbl>1 ) THEN - IF ( getparam(MODNAME, 'rate_table2', Nstage2*Ngate2, 'real', Rate_table2)/=0 ) CALL read_error(2, 'rate_table2') - IF ( getparam(MODNAME, 'tbl_stage2', Nstage2, 'real', Tbl_stage2)/=0 ) CALL read_error(2, 'tbl_stage2') - IF ( getparam(MODNAME, 'tbl_gate2', Ngate2, 'real', Tbl_gate2)/=0 ) CALL read_error(2, 'tbl_gate2') - - IF ( Nratetbl>2 ) THEN - IF ( getparam(MODNAME, 'rate_table3', Nstage3*Ngate3, 'real', Rate_table3)/=0 ) & - & CALL read_error(2, 'rate_table3') - IF ( getparam(MODNAME, 'tbl_stage3', Nstage3, 'real', Tbl_stage3)/=0 ) CALL read_error(2, 'tbl_stage3') - IF ( getparam(MODNAME, 'tbl_gate3', Ngate3, 'real', Tbl_gate3)/=0 ) CALL read_error(2, 'tbl_gate3') - - IF ( Nratetbl>3 ) THEN - IF ( getparam(MODNAME, 'rate_table4', Nstage4*Ngate4, 'real', Rate_table4)/=0 ) & - & CALL read_error(2, 'rate_table4') - IF ( getparam(MODNAME, 'tbl_stage4', Nstage4, 'real', Tbl_stage4)/=0 ) CALL read_error(2, 'tbl_stage4') - IF ( getparam(MODNAME, 'tbl_gate4', Ngate4, 'real', Tbl_gate4)/=0 ) CALL read_error(2, 'tbl_gate4') - ENDIF - ENDIF - ENDIF - ENDIF - - IF ( Puls_lin_flag==1 ) THEN - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - IF ( getparam(MODNAME, 'lake_init', Nlake, 'real', Lake_init)/=0 ) CALL read_error(2, 'lake_init') - IF ( getparam(MODNAME, 'lake_din1', Nlake, 'real', Lake_din1)/=0 ) CALL read_error(2, 'lake_din1') - DO i = 1, Nlake - Lake_sto(i) = DBLE( Lake_init(i) ) - Din1(i) = DBLE( Lake_din1(i) ) - ENDDO - ENDIF - DO i = 1, Nlake - IF ( Lake_type(i)==1 ) THEN - kk = Nsos(i) - IF ( kk<1 ) THEN - PRINT *, 'ERROR, lake_type = 1, but, nsos<1, lake:', i, ' nsos:', kk, ' mxnsos:', Mxnsos - Inputerror_flag = 1 - ENDIF - ENDIF - ENDDO - ENDIF - - IF ( Puls_flag==1 ) THEN - IF ( Mxnsos==0 ) STOP 'ERROR, dimension mxnsos = 0 and Puls routing requested' - IF ( getparam(MODNAME, 'o2', Mxnsos*Nlake, 'real', O2)/=0 ) CALL read_error(2, 'o2') - IF ( getparam(MODNAME, 's2', Mxnsos*Nlake, 'real', S2)/=0 ) CALL read_error(2, 's2') - IF ( getparam(MODNAME, 'nsos', Nlake, 'integer', Nsos)/=0 ) CALL read_error(2, 'nsos') - ENDIF - - IF ( Linear_flag==1 ) THEN - IF ( getparam(MODNAME, 'lake_coef', Nlake, 'real', Lake_coef)/=0 ) CALL read_error(2, 'lake_coef') - ENDIF - - IF ( Weir_gate_flag==1 ) THEN - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==4 ) THEN - IF ( getparam(MODNAME, 'lake_vol_init', Nlake, 'real', Lake_vol_init)/=0 ) CALL read_error(2, 'lake_vol_init') - DO i = 1, Nlake - Lake_vol(i) = DBLE( Lake_vol_init(i) ) - ENDDO - ENDIF - ENDIF - DO j = 1, Nhru - IF ( Gwr_type(j)==2 ) THEN - jjj = Lake_hru_id(j) - IF ( jjj==0 ) THEN - PRINT *, 'ERROR, GWR specified as a lake but lake_hru_id value = 0, GWR:', j - Inputerror_flag = 1 - ENDIF - ENDIF - IF ( Lake_hru_id(j)>0 .AND. Gwr_type(j)/=2 ) THEN - PRINT *, 'ERROR, GWR specified as associated with a lake but gwr_type = 0, GWR:', j - Inputerror_flag = 1 - ENDIF - ENDDO - - IF ( Weir_flag==1 ) THEN - IF ( getparam(MODNAME, 'weir_coef', Nlake, 'real', Weir_coef)/=0 ) CALL read_error(2, 'weir_coef') - IF ( getparam(MODNAME, 'weir_len', Nlake, 'real', Weir_len)/=0 ) CALL read_error(2, 'weir_len') - IF ( getparam(MODNAME, 'elev_outflow', Nlake, 'real', Elev_outflow)/=0 ) CALL read_error(2, 'elev_outflow') - ENDIF - - IF ( Obs_flag==1 ) THEN - IF ( getparam(MODNAME, 'obsout_lake', Nlake, 'integer', Obsout_lake)/=0 ) CALL read_error(2, 'obsout_lake') - ELSE - Obsout_lake = 1 - ENDIF - - DO j = 1, Nlake - ierr = 0 - IF ( Lake_type(j)==1 .OR. Lake_type(j)==2 ) THEN - IF ( Lake_type(j)==1 ) THEN - kk = Nsos(j) - IF ( kk<1 ) THEN - PRINT *, 'ERROR, lake_type = 1, but, nsos<1, lake:', j, ' nsos:', kk, ' mxnsos:', Mxnsos - ierr = 1 - ENDIF - ENDIF -! ELSEIF ( Weir_gate_flag==1 ) THEN -! IF ( Lake_type(j)==4 ) THEN -! IF ( Elev_outflow(j)<0.0 ) THEN -! PRINT *, 'ERROR, elev_outflow < 0.0 for lake:', j, Elev_outflow(j) -! ierr = 1 -! ENDIF -! ENDIF - ELSEIF ( Lake_type(j)==6 ) THEN - IF ( Obsout_lake(j)==0 ) THEN - PRINT *, 'ERROR, obsout_lake value = 0 for lake:', j, Obsout_lake(j) - ierr = 1 - ENDIF - ENDIF - IF ( ierr==1 ) THEN - Inputerror_flag = 1 - CYCLE - ENDIF - IF ( Lake_type(j)==1 ) THEN - kk = Nsos(j) - DO ii = 1, kk - Wvd(ii, j) = DBLE( S2(ii, j) + O2(ii, j)*0.5 ) - ENDDO - DO jj = 2, kk - tmp = Wvd(jj, j) - Wvd(jj-1, j) - IF ( DABS(tmp)0 ) DEALLOCATE ( O2, S2 ) - - END FUNCTION muskingum_lake_init - -!*********************************************************************** -! muskingum_lake_run - Compute routing summary values -!*********************************************************************** - INTEGER FUNCTION muskingum_lake_run() - USE PRMS_MUSKINGUM_LAKE - USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag, Nlake, Glacier_flag - USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, & - & Lake_area, Lake_type, Hru_area_dble, Lake_hru_id, Hru_type, Weir_gate_flag, & - & Hru_route_order, Active_hrus, Basin_gl_cfs, Basin_gl_ice_cfs - USE PRMS_CLIMATEVARS, ONLY: Hru_ppt - USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & - & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & - & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out, Basin_lake_stor, Hru_actet, Lake_vol - USE PRMS_OBS, ONLY: Streamflow_cfs - USE PRMS_SET_TIME, ONLY: Cfs_conv - USE PRMS_ROUTING, ONLY: Use_transfer_segment, Segment_delta_flow, Basin_segment_storage, & - & Obsin_segment, Segment_order, Tosegment, C0, C1, C2, Ts, Ts_i, Obsout_segment, & - & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Segment_type, Flow_terminus, & - & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes - USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt - USE PRMS_SRUNOFF, ONLY: Basin_sroff, Hortonian_lakes - USE PRMS_SOILZONE, ONLY: Upslope_dunnianflow, Upslope_interflow - USE PRMS_GWFLOW, ONLY: Basin_gwflow, Lake_seepage, Gw_seep_lakein, Gw_upslope - IMPLICIT NONE -! Functions - INTRINSIC MOD, DBLE - EXTERNAL route_lake -! Local Variables - INTEGER :: i, j, iorder, toseg, imod, tspd, segtype, lakeid, k, jj - DOUBLE PRECISION :: area_fac, segout, currin, tocfs, lake_in_ts -!*********************************************************************** - muskingum_lake_run = 0 - -! SET yesterdays inflows and outflows into temp (past arrays) -! values may be 0.0 as intial, > 0.0 for runtime and dynamic -! initial condtions. Then set outlfow and inflow for this time -! step to 0.0 -! -! upstream_inflow and outflow will vary by hour -! lateral_inflow and everything else will vary by day -! -! Compute surface runoff, ssflow, and gwflow going to each segment -! This is todays "seg_inflow" before additional water is routed to -! a new (if any is routed) -! -! For each HRU if the lateral flow for this HRU goes to the -! segment being evaluated (segment i) then sum flows -! -! Do these calculations once for the current day, before the hourly -! routing starts. -! -! Out2 = In2*C0 + In1*C1 + Out1*C2 -! Seg_outflow = Seg_inflow*Czero + Pastinflow*Cone + Pastoutflow*Ctwo -! C0, C1, and C2: initialized in the "init" part of this module -! - Pastin = Seg_inflow - Pastout = Seg_outflow - Seg_inflow = 0.0D0 - Seg_outflow = 0.0D0 - Inflow_ts = 0.0D0 - Currinsum = 0.0D0 - - IF ( Secondoutflow_flag==1 ) THEN - Basin_2ndstflow = 0.0D0 - Lake_outq2 = 0.0D0 - ENDIF - Basin_lake_stor = 0.0D0 - Lake_inflow = 0.0D0 - Lake_outflow = 0.0D0 - Lake_stream_in = 0.0D0 - Lake_precip = 0.0D0 - IF ( Cascade_flag>0 ) THEN - Lake_lateral_inflow = 0.0D0 - Lake_sroff = 0.0D0 - Lake_interflow = 0.0D0 - Lake_gwflow = 0.0D0 - ENDIF - IF ( Weir_gate_flag==1 ) THEN - Lake_seep_in = 0.0D0 - Lake_2gw = 0.0D0 - ENDIF - Lake_evap = 0.0D0 - ! shouldn't have snowpack, all precipitation should be added directly to lake - ! units of lake_inflow = cfs - DO jj = 1, Active_hrus - k = Hru_route_order(jj) - IF ( Hru_type(k)/=2 ) CYCLE - tocfs = Hru_area_dble(k)*Cfs_conv - lakeid = Lake_hru_id(k) - Lake_precip(lakeid) = Lake_precip(lakeid) + tocfs*DBLE(Hru_ppt(k)) - IF ( Cascade_flag>0 ) THEN - Lake_sroff(lakeid) = Lake_sroff(lakeid) + tocfs*(Hortonian_lakes(k)+Upslope_dunnianflow(k)) - Lake_interflow(lakeid) = Lake_interflow(lakeid) + tocfs*Upslope_interflow(k) - Lake_gwflow(lakeid) = Lake_gwflow(lakeid) + tocfs*Gw_upslope(k) - ENDIF - Lake_evap(lakeid) = Lake_evap(lakeid) + tocfs*Hru_actet(k) - ENDDO - DO lakeid = 1, Nlake - Lake_inflow(lakeid) = Lake_precip(lakeid) - IF ( Cascade_flag>0 ) THEN - Lake_lateral_inflow(lakeid) = Lake_sroff(lakeid) + Lake_interflow(lakeid) + Lake_gwflow(lakeid) - Lake_inflow(lakeid) = Lake_inflow(lakeid) + Lake_lateral_inflow(lakeid) - ENDIF - Lake_outflow(lakeid) = Lake_evap(lakeid) - IF ( Weir_gate_flag==1 ) THEN - tocfs = Lake_area(lakeid)*Cfs_conv - Lake_seep_in(lakeid) = tocfs*Gw_seep_lakein(lakeid) - Lake_2gw(lakeid) = tocfs*Lake_seepage(lakeid) - Lake_inflow(lakeid) = Lake_inflow(lakeid) + Lake_seep_in(lakeid) - Lake_outflow(lakeid) = Lake_outflow(lakeid) + Lake_2gw(lakeid) - ENDIF - ENDDO - -! 24 hourly timesteps per day - DO j = 1, 24 - - Seg_upstream_inflow = 0.0D0 - DO i = 1, Nsegment - iorder = Segment_order(i) - -! current inflow to the segment is the time weighted average of the outflow -! of the upstream segments plus the lateral HRU inflow plus any gains. - currin = Seg_lateral_inflow(iorder) - IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) - currin = currin + Seg_upstream_inflow(iorder) - Seg_inflow(iorder) = Seg_inflow(iorder) + currin - Inflow_ts(iorder) = Inflow_ts(iorder) + currin - Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder) - - ! Check to see if this segment is to be routed on this time step - tspd = Ts_i(iorder) - imod = MOD( j, tspd ) - IF ( imod==0 ) THEN - Inflow_ts(iorder) = (Inflow_ts(iorder) / Ts(iorder)) - IF ( Segment_type(iorder)==2 ) THEN ! TS must equal 24 - lakeid = Lake_segment_id(iorder) - lake_in_ts = Lake_inflow(lakeid) + currin -! what about water use? - CALL route_lake(lakeid, Lake_type(lakeid), Lake_area(lakeid), lake_in_ts, & - & Lake_outvol_ts(lakeid), Lake_vol(lakeid)) - Outflow_ts(iorder) = Lake_outcfs(lakeid) - Seg_outflow(iorder) = Lake_outcfs(lakeid) - Lake_stream_in(lakeid) = Seg_upstream_inflow(iorder) - ELSE -! Compute routed streamflow - IF ( Ts_i(iorder)>0 ) THEN -! Muskingum routing equation - Outflow_ts(iorder) = Inflow_ts(iorder)*C0(iorder) + Pastin(iorder)*C1(iorder) + Outflow_ts(iorder)*C2(iorder) - ELSE -! If travel time (K_coef paremter) is less than or equal to -! time step (one hour), then the outflow is equal to the inflow -! Outflow_ts is the value from last hour - Outflow_ts(iorder) = Inflow_ts(iorder) - ENDIF - ENDIF - - ! pastin is equal to the Inflow_ts on the previous routed timestep - Pastin(iorder) = Inflow_ts(iorder) - -! because the upstream inflow from streams is used, reset it to zero so new average -! can be computed next routing timestep. - Inflow_ts(iorder) = 0.0D0 - ENDIF - - IF ( Obsout_segment(iorder)>0 ) Outflow_ts(iorder) = Streamflow_cfs(Obsout_segment(iorder)) - - ! water-use removed/added in routing module - ! check for negative flow - IF ( Outflow_ts(iorder)<0.0 ) THEN - IF ( Use_transfer_segment==1 ) THEN - PRINT *, 'ERROR, transfer(s) from stream segment:', iorder, ' causes outflow to be negative' - PRINT *, ' outflow =', Outflow_ts(iorder), ' must fix water-use stream segment transfer file' - ELSE - PRINT *, 'ERROR, outflow from segment:', iorder, ' is negative:', Outflow_ts(iorder) - PRINT *, ' routing parameters may be invalid' - ENDIF - STOP - ENDIF - - IF ( Segment_type(iorder)/=2 ) THEN - ! Seg_outflow (the mean daily flow rate for each segment) will be the average of the hourly values. - Seg_outflow(iorder) = Seg_outflow(iorder) + Outflow_ts(iorder) - ! pastout is equal to the Inflow_ts on the previous routed timestep - Pastout(iorder) = Outflow_ts(iorder) - ENDIF - -! Add current timestep's flow rate to sum the upstream flow rates. -! This can be thought of as a volume because it is a volumetric rate -! (cubic feet per second) over a time step of an hour. Down below when -! this value is used, it will be divided by the number of hours in the -! segment's simulation time step, giving the mean flow rate over that -! period of time. - toseg = Tosegment(iorder) - IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Outflow_ts(iorder) - - ENDDO ! segment - - ENDDO ! timestep - - Basin_segment_storage = 0.0D0 - Flow_out = 0.0D0 - Flow_to_lakes = 0.0D0 - Flow_to_ocean = 0.0D0 - Flow_to_great_lakes = 0.0D0 - Flow_out_region = 0.0D0 - Flow_out_NHM = 0.0D0 - Flow_in_region = 0.0D0 - Flow_terminus = 0.0D0 - Flow_in_nation = 0.0D0 - Flow_headwater = 0.0D0 - Flow_in_great_lakes = 0.0D0 - Flow_replacement = 0.0D0 - ! add water balance check - DO i = 1, Nsegment - segtype = Segment_type(i) - IF ( segtype/=2 ) Seg_outflow(i) = Seg_outflow(i) * ONE_24TH ! lake values set above - segout = Seg_outflow(i) - Seg_inflow(i) = Seg_inflow(i) * ONE_24TH - Seg_upstream_inflow(i) = Currinsum(i) * ONE_24TH -! Flow_out is the total flow out of the basin, which allows for multiple outlets -! includes closed basins (tosegment=0) - IF ( segtype==1 ) THEN - Flow_headwater = Flow_headwater + segout - ELSEIF ( segtype==2 ) THEN - Flow_to_lakes = Flow_to_lakes + segout - lakeid = Lake_segment_id(i) - Lake_outcms(lakeid) = Lake_outcfs(lakeid)*CFS2CMS_CONV - Basin_lake_stor = Basin_lake_stor + Lake_vol(Lakeid)*12.0D0 - ELSEIF ( segtype==3 ) THEN - Flow_replacement = Flow_replacement + segout - ELSEIF ( segtype==4 ) THEN - Flow_in_nation = Flow_in_nation + segout - ELSEIF ( segtype==5 ) THEN - Flow_out_NHM = Flow_out_NHM + segout - ELSEIF ( segtype==6 ) THEN - Flow_in_region = Flow_in_region + segout - ELSEIF ( segtype==7 ) THEN - Flow_out_region = Flow_out_region + segout - ELSEIF ( segtype==8 ) THEN - Flow_to_ocean = Flow_to_ocean + segout - ELSEIF ( segtype==9 ) THEN - Flow_terminus = Flow_terminus + segout - ELSEIF ( segtype==10 ) THEN - Flow_in_great_lakes = Flow_in_great_lakes + segout - ELSEIF ( segtype==11 ) THEN - Flow_to_great_lakes = Flow_to_great_lakes + segout - ENDIF - IF ( Tosegment(i)==0 ) Flow_out = Flow_out + segout - Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout -! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) - Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) - ENDDO - - area_fac = Cfs_conv/Basin_area_inv - Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows - Basin_cfs = Flow_out - Basin_stflow_out = Basin_cfs / area_fac - Basin_cms = Basin_cfs*CFS2CMS_CONV - IF ( Glacier_flag==1 ) THEN - Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt - Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac - Basin_gl_cfs = Basin_gl_top_melt*area_fac - ENDIF - Basin_sroff_cfs = Basin_sroff*area_fac - Basin_ssflow_cfs = Basin_ssflow*area_fac - Basin_gwflow_cfs = Basin_gwflow*area_fac - Basin_segment_storage = Basin_segment_storage/area_fac - Basin_2ndstflow = Basin_2ndstflow*Basin_area_inv - Basin_lake_stor = Basin_lake_stor*Basin_area_inv - -! write(77,'(10f11.3)') lake_vol, lake_outflow, lake_stream_in, lake_outcfs, elevlake - END FUNCTION muskingum_lake_run - -! *********************************** -! * Route Lake -! *********************************** - SUBROUTINE route_lake(Lakeid, Laketype, Lake_area, Lake_in_ts, Lake_outvol_ts, Lake_vol) - USE PRMS_MUSKINGUM_LAKE, ONLY: Lake_sto, Lake_outcfs, Lake_inflow, Din1, Lake_outflow, & - & Wvd, Nsos, S24, C24, Lake_coef, Lake_invol, Weir_coef, Weir_len, Elev_outflow, & - & Tbl_gate, Tbl_stage, Rate_table, Tbl_gate2, Tbl_stage2, Rate_table2, & - & Tbl_gate3, Tbl_stage3, Rate_table3, Tbl_gate4, Tbl_stage4, Rate_table4, & - & Obsout_lake, Ratetbl_lake, Ngate, Nstage, Ngate2, Nstage2, Ngate3, Nstage3, Ngate4, Nstage4, & - & Secondoutflow_flag, Lake_out2, Lake_out2_a, Lake_out2_b, Lake_outq2, Basin_2ndstflow - USE PRMS_MODULE, ONLY: Nratetbl, Print_debug - USE PRMS_OBS, ONLY: Gate_ht, Streamflow_cfs - USE PRMS_ROUTING, ONLY: Cfs2acft - USE PRMS_GWFLOW, ONLY: Elevlake - IMPLICIT NONE -! Functions - INTRINSIC EXP, DBLE, SNGL, DABS - EXTERNAL table_comp -! Arguments - INTEGER, INTENT(IN) :: Lakeid, Laketype - DOUBLE PRECISION, INTENT(IN) :: Lake_area, Lake_in_ts - DOUBLE PRECISION, INTENT(INOUT) :: Lake_outvol_ts, Lake_vol ! acft -! Local Variables - INTEGER :: n, jjj, i - REAL :: q1, q3, elevold, head, new_elevlake, head2, scnd_cfs1, scnd_cfs2 - DOUBLE PRECISION :: avin, s2o2, q2, lake_out, diff_vol, lake_out1 - DOUBLE PRECISION :: xkt, coef2, lake_storage -!*********************************************************************** - !!! ? adjust storage at end of time step ?? - ! q2 = lake out in cfs - q2 = 0.0D0 - lake_storage = 0.0D0 - IF ( Laketype==1 .OR. Laketype==2 ) THEN - lake_storage = Lake_sto(Lakeid) - ELSE - Lake_outcfs(Lakeid) = 0.0D0 - ENDIF -! Compute outflow using Puls routing method - IF ( Laketype==1 ) THEN - !rsr, why half of current in and last in??? - avin = (Lake_inflow(Lakeid)+Din1(Lakeid))*0.5D0 - s2o2 = lake_storage - (Lake_outflow(Lakeid)+Lake_outcfs(Lakeid))*0.5D0 - s2o2 = s2o2 + avin - Din1(Lakeid) = Lake_inflow(Lakeid) - n = Nsos(Lakeid) - DO jjj = 2, n - IF ( s2o2-1 ) THEN - PRINT *, 'WARNING: specified observed runoff value for outflow from lake < 0:', Lakeid, ' value:', q2 - PRINT *, 'runoff id:', Obsout_lake(Lakeid), ' outflow set to 0.0' - ENDIF - q2 = 0.0D0 - ENDIF - - ELSE ! 4 or 5; broad-crested weir or gate opening - elevold = Elevlake(Lakeid) - - ! units lake_invol = acft - Lake_invol(Lakeid) = Lake_in_ts * Cfs2acft - - ! units lake_out = acft - lake_out = Lake_outflow(Lakeid) * Cfs2acft ! evap and seepage - diff_vol = Lake_invol(Lakeid) - lake_out - q1 = 0.0 - q3 = 0.0 - -! Compute using lake surface elevation and broad crested weir - IF ( Laketype==4 ) THEN - head = elevold - Elev_outflow(Lakeid) - IF ( head<0.0 ) head = 0.0 - q1 = (head**1.5) * Weir_coef(Lakeid) * Weir_len(Lakeid) - lake_out1 = DBLE(q1)*Cfs2acft - - ! new_elevlake has units of feet - new_elevlake = elevold + SNGL( (diff_vol-lake_out1)/Lake_area ) - - head2 = (new_elevlake+elevold)*0.5 - Elev_outflow(Lakeid) - IF ( head2<0.0 ) head2 = 0.0 - q3 = (head2**1.5) * Weir_coef(Lakeid) * Weir_len(Lakeid) - -! Compute using a rating table of lake surface elevation & gate opening - ELSE ! type = 5 - DO i = 1, Nratetbl - IF ( Lakeid==Ratetbl_lake(i) ) THEN - IF ( i==1 ) THEN - CALL table_comp(Ngate, Nstage, Tbl_gate, Tbl_stage, & - & Rate_table, elevold, Gate_ht(i), q1, Lake_area) - ELSEIF ( i==2 ) THEN - CALL table_comp(Ngate2, Nstage2, Tbl_gate2, Tbl_stage2, & - & Rate_table2, elevold, Gate_ht(i), q1, Lake_area) - ELSEIF ( i==3 ) THEN - CALL table_comp(Ngate3, Nstage3, Tbl_gate3, Tbl_stage3, & - & Rate_table3, elevold, Gate_ht(i), q1, Lake_area) - ELSEIF ( i==4 ) THEN - CALL table_comp(Ngate4, Nstage4, Tbl_gate4, Tbl_stage4, & - & Rate_table4, elevold, Gate_ht(i), q1, Lake_area) - ENDIF - ENDIF - ENDDO - scnd_cfs1 = 0.0D0 - IF ( Secondoutflow_flag==1 ) THEN -! if lake has a second outlet then outflow in cfs is computed by -! Q = Lake_out2_a*Elevlake - Lake_out2_b -! (as per Rob Dudley email 7 Sep 2006) - IF ( Lake_out2(Lakeid)==1 ) scnd_cfs1 = (Lake_out2_a(Lakeid)*elevold) - Lake_out2_b(Lakeid) - ENDIF - - lake_out1 = DBLE(q1+scnd_cfs1)*Cfs2acft - - ! new_elevlake has units of feet - new_elevlake = elevold + SNGL( (diff_vol-lake_out1)/Lake_area ) - - DO i = 1, Nratetbl - IF ( Lakeid==Ratetbl_lake(i) ) THEN - IF ( i==1 ) THEN - CALL table_comp(Ngate, Nstage, Tbl_gate, Tbl_stage, Rate_table, & - & new_elevlake, Gate_ht(i), q3, Lake_area) - ELSEIF ( i==2 ) THEN - CALL table_comp(Ngate2, Nstage2, Tbl_gate2, Tbl_stage2, Rate_table2, & - & new_elevlake, Gate_ht(i), q3, Lake_area) - ELSEIF ( i==3 ) THEN - CALL table_comp(Ngate3, Nstage3, Tbl_gate3, Tbl_stage3, Rate_table3, & - & new_elevlake, Gate_ht(i), q3, Lake_area) - ELSEIF ( i==4 ) THEN - CALL table_comp(Ngate4, Nstage4, Tbl_gate4, Tbl_stage4, Rate_table4, & - & new_elevlake, Gate_ht(i), q3, Lake_area) - ENDIF - ENDIF - ENDDO - - IF ( Secondoutflow_flag==1 ) THEN - IF ( Lake_out2(lakeid)==1 ) THEN - scnd_cfs2 = (Lake_out2_a(Lakeid)*new_elevlake) - Lake_out2_b(Lakeid) - ELSE - scnd_cfs2 = 0.0D0 - ENDIF - Lake_outq2(Lakeid) = (scnd_cfs1+scnd_cfs2)*0.5D0 - Basin_2ndstflow = Basin_2ndstflow + Lake_outq2(Lakeid)*Cfs2acft*12.0D0 - ENDIF - ENDIF - - q2 = DBLE( (q1+q3)*0.5 ) -! !sanity check, rsr - IF ( q2<0.0D0 ) PRINT *, 'q2<0', q2, ' lake:', Lakeid - IF ( Secondoutflow_flag==1 ) q2 = q2 + Lake_outq2(Lakeid) - - Lake_outvol_ts = q2*Cfs2acft + lake_out - Lake_vol = Lake_vol + Lake_invol(Lakeid) - Lake_outvol_ts - IF ( Lake_vol<0.0D0 ) THEN - Lake_outvol_ts = DABS(Lake_vol) - Lake_vol = 0.0D0 - ELSE - ! adjust lake elevation with stream and lateral inflows - ! and streamflow, any second outlet, GWR, and evaporation outflows - Elevlake(Lakeid) = Elevlake(Lakeid) + SNGL( (Lake_invol(Lakeid)-Lake_outvol_ts)/Lake_area ) - ENDIF - ENDIF - IF ( lake_storage<0.0D0 ) THEN - PRINT *, 'ERROR: lake storage < 0 lake:', Lakeid, '; storage:', lake_storage - STOP - ENDIF - - Lake_outcfs(Lakeid) = q2 - - END SUBROUTINE route_lake - -!===================================================================== -! Rating table computation -!===================================================================== - SUBROUTINE table_comp(Ngate, Nstage, Tbl_gate, Tbl_stage, Rate_table, Elevlake, Gate_ht, Q2, Lake_area) - USE PRMS_MODULE, ONLY: Print_debug - USE PRMS_ROUTING, ONLY: Cfs2acft - IMPLICIT NONE -! Arguments - INTEGER, INTENT(IN) :: Ngate, Nstage - REAL, INTENT(IN) :: Tbl_gate(Ngate), Tbl_stage(Nstage), Rate_table(Nstage, Ngate), Gate_ht, Elevlake - DOUBLE PRECISION, INTENT(IN) :: Lake_area - REAL, INTENT(OUT) :: Q2 -! Functions - INTRINSIC SNGL -! Local Variables - INTEGER m, mm, stg1, stg2, gate1, gate2 - REAL :: diff_q_stg1, diff_q_stg2, ratiog, ratios, q_stg1, q_stg2, diffq -!*********************************************************************** - IF ( ElevlakeTbl_stage(1) ) THEN - ! lake elevation is > maximum stage, spill all water - Q2 = (Elevlake-Tbl_stage(1))*SNGL(Lake_area/Cfs2acft) - IF ( Print_debug>-1 ) THEN - PRINT *, 'WARNING, lake elevation > maximum stage in rating table all water above rating table spills' - PRINT *, 'Lake elevation:', Elevlake, ' Rating table stage:', Tbl_stage(1), ' discharge to stream:', Q2 - ENDIF - ELSE - stg2 = 1 - stg1 = 0 - DO m = 1, Nstage - IF ( Elevlake>Tbl_stage(m) ) THEN - IF ( m==1 ) THEN - stg2 = 1 - stg1 = 1 - ELSE - stg2 = m - stg1 = m - 1 - ENDIF - EXIT - ENDIF - ENDDO - - gate2 = Ngate - gate1 = Ngate - 1 - IF ( Gate_ht<=Tbl_gate(Ngate) ) THEN - DO mm = 1, Ngate - IF ( Tbl_gate(mm)>Gate_ht ) THEN - IF ( mm==1 ) THEN - gate2 = 1 - gate1 = 1 - ELSE - gate2 = mm - gate1 = mm - 1 - ENDIF - EXIT - ENDIF - ENDDO - ENDIF - - IF ( stg1==0 ) THEN - Q2 = Rate_table(1, gate2) - - ELSE - diff_q_stg2 = Rate_table(stg2, gate2) - Rate_table(stg2, gate1) - diff_q_stg1 = Rate_table(stg1, gate2) - Rate_table(stg1, gate1) - - !rsr, possible divide by 0.0??? - ratiog = (Gate_ht-Tbl_gate(gate1))/(Tbl_gate(gate2)-Tbl_gate(gate1)) - q_stg2 = (ratiog*diff_q_stg2) + Rate_table(stg2, gate1) - q_stg1 = (ratiog*diff_q_stg1) + Rate_table(stg1, gate1) - - !rsr, possible divide by 0.0??? - ratios = (Elevlake-Tbl_stage(stg2))/(Tbl_stage(stg1)-Tbl_stage(stg2)) - diffq = q_stg1 - q_stg2 - Q2 = q_stg2 + (ratios*diffq) - ENDIF - ENDIF - - END SUBROUTINE table_comp - -!*********************************************************************** -! muskingum_lake_restart - write or read restart file -!*********************************************************************** - SUBROUTINE muskingum_lake_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit - USE PRMS_BASIN, ONLY: Puls_lin_flag - USE PRMS_MUSKINGUM_LAKE - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - ! Function - EXTERNAL :: check_restart - ! Local Variable - CHARACTER(LEN=14) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Outflow_ts - IF ( Puls_lin_flag==1 ) THEN - WRITE ( Restart_outunit ) Din1 - WRITE ( Restart_outunit ) Lake_sto - ENDIF - ELSE - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) Outflow_ts - IF ( Puls_lin_flag==1 ) THEN - READ ( Restart_inunit ) Din1 - READ ( Restart_inunit ) Lake_sto - ENDIF - ENDIF - END SUBROUTINE muskingum_lake_restart diff --git a/prms/stream_tempCopy.f90 b/prms/stream_tempCopy.f90 deleted file mode 100644 index 5e3b707c..00000000 --- a/prms/stream_tempCopy.f90 +++ /dev/null @@ -1,1805 +0,0 @@ -!*********************************************************************** -! stream temperature module -!*********************************************************************** - MODULE PRMS_STRMTEMP - IMPLICIT NONE -! Local Variables - CHARACTER(LEN=11), SAVE :: MODNAME - INTEGER, SAVE, ALLOCATABLE :: Seg_hru_count(:), Seg_close(:) - REAL, SAVE, ALLOCATABLE :: seg_tave_ss(:), Seg_carea_inv(:), seg_tave_sroff(:), seg_tave_lat(:) - REAL, SAVE, ALLOCATABLE :: seg_tave_gw(:), Flowsum(:) - - ! next variables only needed if strm_temp_shade_flag = 0 - REAL, SAVE, ALLOCATABLE :: Shade_jday(:, :), Svi_jday(:, :) - REAL, SAVE, ALLOCATABLE :: Seg_lat(:), Seg_elev(:) - REAL, SAVE, ALLOCATABLE :: Press(:) - REAL, SAVE, ALLOCATABLE :: Cos_seg_lat(:), Sin_seg_lat(:), Horizontal_hour_angle(:, :), Total_shade(:, :) - REAL, SAVE, ALLOCATABLE :: Sin_declination(:, :), Sin_lat_decl(:, :), Cos_lat_decl(:, :), Sin_alrs(:, :) - REAL, SAVE, ALLOCATABLE :: Max_solar_altitude(:, :), Level_sunset_azimuth(:, :) - REAL, SAVE, ALLOCATABLE :: Local_sunset_hour_angle(:, :), Local_sunrise_hour_angle(:, :) - REAL, SAVE, ALLOCATABLE :: gw_sum(:), ss_sum(:) - REAL, SAVE, ALLOCATABLE :: gw_silo(:,:), ss_silo(:,:) - REAL, SAVE, ALLOCATABLE :: hru_area_sum(:) - INTEGER, SAVE :: gw_index, ss_index - -! Declared Variables - REAL, SAVE, ALLOCATABLE :: Seg_tave_water(:), seg_tave_upstream(:), Seg_daylight(:) - REAL, SAVE, ALLOCATABLE :: Seg_humid(:), Seg_width_flow(:), Seg_ccov(:), seg_shade(:) - REAL, SAVE, ALLOCATABLE :: Seg_tave_air(:), Seg_melt(:), Seg_rain(:) - DOUBLE PRECISION, ALLOCATABLE :: Seg_potet(:) -! Segment Parameters - REAL, SAVE, ALLOCATABLE :: Width_values(:, :) - REAL, SAVE, ALLOCATABLE :: width_alpha(:), width_m(:) - INTEGER, SAVE:: Width_dim, Maxiter_sntemp - REAL, SAVE, ALLOCATABLE :: Seg_humidity(:, :) - REAL, SAVE, ALLOCATABLE :: lat_temp_adj(:, :) - INTEGER, SAVE, ALLOCATABLE :: Seg_humidity_sta(:) -! Shade Parameters needed if stream_temp_shade_flag = 0 - REAL, SAVE, ALLOCATABLE :: Azrh(:), Alte(:), Altw(:), Vce(:) - REAL, SAVE, ALLOCATABLE :: Vdemx(:), Vhe(:), Voe(:), Vcw(:), Vdwmx(:), Vhw(:), Vow(:) - REAL, SAVE, ALLOCATABLE :: Vdemn(:), Vdwmn(:) - INTEGER, SAVE :: Spring_jday, Summer_jday, Autumn_jday, Winter_jday -! Shade Parameters needed if stream_temp_shade_flag = 2 - REAL, SAVE, ALLOCATABLE :: Segshade_sum(:), Segshade_win(:) - REAL, SAVE:: Albedo, Melt_temp - ! INTEGER, SAVE :: Shadeflg, now using stream_temp_shade_flag - INTEGER, SAVE, ALLOCATABLE :: Ss_tau(:), Gw_tau(:) -! Control parameters - INTEGER, SAVE :: Stream_temp_shade_flag -! Conversions - INTRINSIC :: ACOS - REAL, PARAMETER :: HALF_PI = ACOS(0.0), ZERO_C = 273.16 - REAL, PARAMETER :: PI = ACOS(-1.0) - REAL, PARAMETER :: DEG_TO_RAD = PI / 180.0, DAYSYR = 365.242 - DOUBLE PRECISION :: MPS_CONVERT = 2.93981481D-07 - END MODULE PRMS_STRMTEMP - -!*********************************************************************** -! Main stream temperature routine -!*********************************************************************** - INTEGER FUNCTION stream_temp() - USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: stream_temp_decl, stream_temp_init, stream_temp_run, stream_temp_setdims - EXTERNAL :: stream_temp_restart -!*********************************************************************** - stream_temp = 0 - - IF ( Process(:3)=='run' ) THEN - stream_temp = stream_temp_run() - ELSEIF ( Process(:4)=='decl' ) THEN - stream_temp = stream_temp_decl() - ELSEIF ( Process(:4)=='init' ) THEN - IF ( Init_vars_from_file>0 ) CALL stream_temp_restart(1) - stream_temp = stream_temp_init() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL stream_temp_restart(0) - ENDIF - - END FUNCTION stream_temp - -!*********************************************************************** -! stream_temp_decl - set up parameters and storage -! Declared Parameters -!*********************************************************************** - INTEGER FUNCTION stream_temp_decl() - USE PRMS_STRMTEMP - USE PRMS_MODULE, ONLY: Nsegment, Strmtemp_humidity_flag, Model - IMPLICIT NONE -! Functions - INTRINSIC INDEX - INTEGER, EXTERNAL :: declparam, declvar, getdim, control_integer - EXTERNAL :: read_error, print_module -! Local Variables - CHARACTER(LEN=80), SAVE :: Version_stream_temp -!*********************************************************************** - stream_temp_decl = 0 - - Version_stream_temp = 'stream_temp.f90 2018-04-18 16:18:00Z' - CALL print_module(Version_stream_temp, 'Stream Temperature ', 90) - MODNAME = 'stream_temp' - - ! 0 = compute shade; 1 = specified constant - IF ( control_integer(Stream_temp_shade_flag, 'stream_temp_shade_flag')/=0 ) Stream_temp_shade_flag = 0 - -! Declared Variables - ALLOCATE ( Seg_width_flow(Nsegment) ) - IF ( declvar( MODNAME, 'seg_width_flow', 'nsegment', Nsegment, 'real', & - & 'Width of each segment, flow-dependent', & - & 'meters', Seg_width_flow)/=0 ) CALL read_error(3, 'seg_width_flow') - - ALLOCATE (Seg_tave_water(Nsegment) ) ! previous ?? - IF ( declvar( MODNAME, 'seg_tave_water', 'nsegment', Nsegment, 'real', & - & 'Computed daily mean stream temperature for each segment', & - & 'degrees Celsius', Seg_tave_water)/=0 ) CALL read_error(3, 'seg_tave_water') - - ALLOCATE ( seg_tave_upstream(Nsegment) ) - IF ( declvar( MODNAME, 'seg_tave_upstream', 'nsegment', Nsegment, 'real', & - & 'Temperature of streamflow entering each segment', & - & 'degrees Celsius', seg_tave_upstream)/=0 ) CALL read_error(3,'seg_tave_upstream') - - ALLOCATE ( Seg_humid(Nsegment) ) - IF ( declvar( MODNAME, 'seg_humid', 'nsegment', Nsegment, 'real', & - & 'Area-weighted average relative humidity for each segment from HRUs contributing flow to the segment', & - & 'decimal fraction', Seg_humid)/=0 ) CALL read_error(3,'seg_humid') - - ALLOCATE ( Seg_melt(Nsegment) ) - IF ( declvar( MODNAME, 'seg_melt', 'nsegment', Nsegment, 'real', & - & 'Area-weighted average snowmelt for each segment from HRUs contributing flow to the segment', & - & 'inches', Seg_melt)/=0 ) CALL read_error(3, 'seg_melt') - - ALLOCATE ( Seg_rain(Nsegment) ) - IF ( declvar( MODNAME, 'seg_rain', 'nsegment', Nsegment, 'real', & - & 'Area-weighted average rainfall for each segment from HRUs contributing flow to the segment', & - & 'inches', Seg_rain)/=0 ) CALL read_error(3, 'seg_rain') - - ALLOCATE ( Seg_tave_air(Nsegment) ) - IF ( declvar( MODNAME, 'seg_tave_air', 'nsegment', Nsegment, 'real', & - & 'Area-weighted average air temperature for each segment from HRUs contributing flow to the segment', & - & 'degrees Celsius', Seg_tave_air)/=0 ) CALL read_error(3, 'seg_tave_air') - - ALLOCATE ( Seg_potet(Nsegment) ) - IF ( declvar( MODNAME, 'seg_potet', 'nsegment', Nsegment, 'double', & - & 'HRU area-weighted average potential ET for each segment', & - & 'inches', Seg_potet)/=0 ) CALL read_error(3, 'seg_potet') - - ALLOCATE ( Seg_ccov(Nsegment) ) - IF ( declvar( MODNAME, 'seg_ccov', 'nsegment', Nsegment, 'real', & - & 'Area-weighted average cloud cover fraction for each segment from HRUs contributing flow to the segment', & - & 'decimal fraction', Seg_ccov )/=0 ) CALL read_error(3, 'seg_ccov') - - ALLOCATE(Seg_shade(Nsegment)) - IF (declvar(MODNAME, 'seg_shade', 'nsegment', Nsegment, 'real', & - & 'Area-weighted average shade fraction for each segment', & - & 'decimal fraction', seg_shade)/=0 ) CALL read_error(3, 'seg_shade') - - ALLOCATE ( Seg_daylight(Nsegment) ) - IF ( declvar( MODNAME, 'seg_daylight', 'nsegment', Nsegment, 'real', & - & 'Hours of daylight', & - & 'hours', Seg_daylight)/=0 ) CALL read_error(3,'seg_daylight') - - ALLOCATE(seg_tave_gw(Nsegment)) - IF ( declvar( MODNAME, 'seg_tave_gw', 'nsegment', Nsegment, 'real', & - & 'groundwater temperature', & - & 'degrees Celsius', seg_tave_gw)/=0 ) CALL read_error(3,'seg_tave_gw') - - ALLOCATE(seg_tave_ss(Nsegment)) - IF ( declvar( MODNAME, 'seg_tave_ss', 'nsegment', Nsegment, 'real', & - & 'subsurface temperature', & - & 'degrees Celsius', seg_tave_ss)/=0 ) CALL read_error(3,'seg_tave_ss') - - ALLOCATE(seg_tave_sroff(Nsegment)) - IF ( declvar( MODNAME, 'seg_tave_sroff', 'nsegment', Nsegment, 'real', & - & 'surface runoff temperature', & - & 'degrees Celsius', seg_tave_sroff)/=0 ) CALL read_error(3,'seg_tave_sroff') - - ALLOCATE(seg_tave_lat(Nsegment)) - IF ( declvar( MODNAME, 'seg_tave_lat', 'nsegment', Nsegment, 'real', & - & 'lateral flow temperature', & - & 'degrees Celsius', seg_tave_lat)/=0 ) CALL read_error(3,'seg_tave_lat') - - ALLOCATE (Press(Nsegment) ) - ALLOCATE ( Seg_hru_count(Nsegment) ) - ALLOCATE (Seg_carea_inv(Nsegment) ) - ALLOCATE ( Seg_close(Nsegment) ) - ALLOCATE (gw_sum(Nsegment), ss_sum(Nsegment)) - ALLOCATE (gw_silo(nsegment,365), ss_silo(nsegment,365)) - ALLOCATE (hru_area_sum(nsegment)) - - IF ( declparam( MODNAME, 'albedo', 'one', 'real', & - & '0.10', '0.0', '1.0', & - & 'Short-wave solar radiation reflected by streams', & - & 'Short-wave solar radiation reflected by streams', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo') - - ALLOCATE(lat_temp_adj(Nsegment,12)) - IF ( declparam( MODNAME, 'lat_temp_adj', 'nsegment,nmonths', 'real', & - & '0.0', '-5.0', '5.0', & - & 'Correction factor to adjust the bias of the temperature of the lateral inflow', & - & 'Correction factor to adjust the bias of the temperature of the lateral inflow', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'lat_temp_adj') - - ALLOCATE (width_alpha(Nsegment) ) - IF ( declparam( MODNAME, 'width_alpha', 'nsegment', 'real', & - & '0.015', '0.0001', '2.0', & - & 'Alpha coefficient in power function for width calculation', & - & 'Alpha coefficient in power function for width calculation', & - & 'unknown')/=0 ) CALL read_error(1, 'width_alpha') - - ALLOCATE (width_m(Nsegment) ) - IF ( declparam( MODNAME, 'width_m', 'nsegment', 'real', & - & '0.015', '0.0001', '2.0', & - & 'M value in power function for width calculation', & - & 'M value in power function for width calculation', & - & 'unknown')/=0 ) CALL read_error(1, 'width_m') - - IF ( Stream_temp_shade_flag==0 .OR. Model==99 ) THEN - ALLOCATE ( Azrh(Nsegment) ) - IF ( declparam( MODNAME, 'azrh', 'nsegment', 'real', & - & '0.0', '-1.5708', '1.5708', & - & 'Azimuth angle of each segment', & - & 'Azimuth angle of each segment', & - & 'radians')/=0 ) CALL read_error(1, 'azrh') - - ALLOCATE ( Alte(Nsegment) ) - IF ( declparam( MODNAME, 'alte', 'nsegment', 'real', & - & '0.0', '0.0','1.57079633', & - & 'East bank topographic altitude', & - & 'East bank topographic altitude of each segment', & - & 'radians')/=0 ) CALL read_error(1, 'alte') - - ALLOCATE ( Altw(Nsegment) ) - IF ( declparam( MODNAME, 'altw', 'nsegment', 'real', & - & '0.0', '0.0', '1.57079633', & - & 'West bank topographic altitude', & - & 'West bank topographic altitude of each segment', & - & 'radians')/=0 ) CALL read_error(1, 'altw') - - ALLOCATE ( Vce(Nsegment) ) - IF ( declparam( MODNAME, 'vce', 'nsegment', 'real', & - & '0.0', '0.0', '15.0', & - & 'East bank average vegetation crown width', & - & 'East bank average vegetation crown width for each segment', & - & 'meters')/=0 ) CALL read_error(1, 'vce') - - ALLOCATE ( Vdemx(Nsegment) ) - IF ( declparam( MODNAME, 'vdemx', 'nsegment', 'real', & - & '0.0', '0.0', '1.0', & - & 'Maximum east bank vegetation density', & - & 'Maximum east bank vegetation density for each segment', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'vdemx') - - ALLOCATE ( Vdemn(Nsegment) ) - IF ( declparam( MODNAME, 'vdemn', 'nsegment', 'real', & - & '0.0', '0.0', '1.0', & - & 'Minimum east bank vegetation density', & - & 'Minimum east bank vegetation density for each segment', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'vdemn') - - ALLOCATE ( Vhe(Nsegment) ) - IF ( declparam( MODNAME, 'vhe', 'nsegment', 'real', & - & '0.0', '0.0', '30.0', & - & 'East bank vegetation height', & - & 'East bank average vegetation height for each segment', & - & 'meters')/=0 ) CALL read_error(1, 'vhe') - - ALLOCATE ( Voe(Nsegment) ) - IF ( declparam( MODNAME, 'voe', 'nsegment', 'real', & - & '0.0', '0.0', '100.0',& - & 'East bank vegetation offset', & - & 'East bank vegetation offset for each segment', & - & 'meters')/=0 ) CALL read_error(1, 'voe') - - ALLOCATE ( Vcw(Nsegment) ) - IF ( declparam( MODNAME, 'vcw', 'nsegment', 'real', & - & '0.0', '0.0', '15.0', & - & 'West bank vegetation crown width', & - & 'West bank average vegetation crown width for each segment', & - & 'meters')/=0 ) CALL read_error(1, 'vcw') - - ALLOCATE ( Vdwmx(Nsegment) ) - IF ( declparam( MODNAME, 'vdwmx', 'nsegment', 'real', & - & '0.0', '0.0', '1.0', & - & 'Maximum west bank vegetation density', & - & 'Maximum west bank vegetation density for each segment', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'vdwmx') - - ALLOCATE ( Vdwmn(Nsegment) ) - IF ( declparam( MODNAME, 'vdwmn', 'nsegment', 'real', & - & '0.0', '0.0', '1.0', & - & 'Minimum west bank vegetation density', & - & 'Minimum west bank vegetation density for each segment', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'vdwmn') - - ALLOCATE ( Vhw(Nsegment) ) - IF ( declparam( MODNAME, 'vhw', 'nsegment', 'real', & - & '0.0', '0.0', '30.0', & - & 'West bank vegetation height', & - & 'West bank average vegetation height for each segment', & - & 'meters')/=0 ) CALL read_error(1, 'vhw') - - ALLOCATE ( Vow(Nsegment) ) - IF ( declparam( MODNAME, 'vow', 'nsegment', 'real', & - & '0.0', '0.0', '100.0', & - & 'West bank vegetation offset', & - & 'West bank vegetation offset for each segment', & - & 'meters')/=0 ) CALL read_error(1, 'vow') - ENDIF - - IF ( Stream_temp_shade_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Segshade_sum(Nsegment) ) - IF ( declparam( MODNAME, 'segshade_sum', 'nsegment', 'real', & - & '0.0', '0.0', '1.0.', & - & 'Total shade fraction for summer vegetation', & - & 'Total shade fraction for summer vegetation; required when stream_temp_flag=1', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'segshade_sum') - - ALLOCATE ( Segshade_win(Nsegment) ) - IF ( declparam( MODNAME, 'segshade_win', 'nsegment', 'real', & - & '0.0', '0.0', '1.0.', & - & 'Total shade fraction for winter vegetation', & - & 'Total shade fraction for winter vegetation; required when stream_temp_flag=1', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'segshade_win') - ENDIF - - ALLOCATE (ss_tau(Nsegment) ) - IF ( declparam( MODNAME, 'ss_tau', 'nsegment', 'integer', & - & '30', '1', '365', & - & 'Average residence time of subsurface interflow', & - & 'Average residence time of subsurface interflow', & - & 'days')/=0 ) CALL read_error(1, 'ss_tau') - - ALLOCATE (gw_tau(Nsegment) ) - IF ( declparam( MODNAME, 'gw_tau', 'nsegment', 'integer', & - & '365', '1', '365', & - & 'Average residence time in groundwater flow', & - & 'Average residence time in groundwater flow', & - & 'days')/=0 ) CALL read_error(1, 'gw_tau') - - IF ( declparam( MODNAME, 'melt_temp', 'one', 'real', & - & '1.5', '0.0', '10.0', & - & 'Temperature at which snowmelt enters a stream', & - & 'Temperature at which snowmelt enters a stream', & - & 'degrees Celsius')/=0 ) CALL read_error(1, 'melt_temp') - - IF ( declparam( MODNAME, 'maxiter_sntemp', 'one', 'integer', & - & '1000', '10', '2000', & - & 'Maximum number of Newton-Raphson iterations to compute stream temperature', & - & 'Maximum number of Newton-Raphson iterations to compute stream temperature', & - & 'none')/=0 ) CALL read_error(1, 'maxiter_sntemp') - - IF ( Strmtemp_humidity_flag==1 .OR. Model==99 ) THEN ! specified constant - ALLOCATE ( Seg_humidity(Nsegment, 12) ) - IF ( declparam( MODNAME, 'seg_humidity', 'nsegment,nmonths', 'real', & - & '0.7', '0.0', '1.0', & - & 'Mean monthly humidity for each segment', & - & 'Mean monthly humidity for each segment, used when values not input in CBH File', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'seg_humidity') - ELSEIF ( Strmtemp_humidity_flag==2 .OR. Model==99 ) THEN ! use station data - ALLOCATE ( Seg_humidity_sta(Nsegment) ) - IF ( declparam(MODNAME, 'seg_humidity_sta', 'nsegment', 'integer', & - & '0', 'bounded', 'nhumid', & - & 'Index of humidity measurement station for each stream segment', & - & 'Index of humidity measurement station for each stream segment', & - & 'none')/=0 ) CALL read_error(1, 'seg_humidity_sta') - ENDIF - - ALLOCATE (seg_lat(nsegment)) - IF ( declparam( MODNAME, 'seg_lat', 'nsegment', 'real', & - & '40.0', '-90.0', '90.0', & - & 'Segment latitude', & - & 'Latitiude of each segment', & - & 'degrees North')/=0 ) CALL read_error(1, 'seg_lat') - - ALLOCATE (seg_elev(nsegment)) - IF (declparam(MODNAME, 'seg_elev', 'nsegment', 'real', & - & '0.0', '-1000.0', '30000.0', & - & 'Segment elevation at midpoint', 'Segment elevation at midpoint', & - & 'meters')/=0 ) CALL read_error(1, 'seg_elev') - - END FUNCTION stream_temp_decl - -!*********************************************************************** -! stream_temp_init - Initialize module - get parameter values -!*********************************************************************** - INTEGER FUNCTION stream_temp_init() - USE PRMS_STRMTEMP - USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file, Strmtemp_humidity_flag - USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, NEARZERO - USE PRMS_OBS, ONLY: Nhumid - USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Segment_up - IMPLICIT NONE -! Functions - INTRINSIC :: COS, SIN, ABS, SIGN, ASIN - INTEGER, EXTERNAL :: getparam - REAL, EXTERNAL :: solalt - EXTERNAL :: read_error, checkdim_param_limits -! Local Variables - INTEGER :: i, j, k, iseg, ierr, ii, this_seg - REAL :: tan_d, tano, sinhro, temp, decl, cos_d, tanod, alrs -!*********************************************************************** - stream_temp_init = 0 - - IF ( getparam( MODNAME, 'albedo', 1, 'real', Albedo)/=0 ) CALL read_error(2, 'albedo') - IF ( getparam( MODNAME, 'lat_temp_adj', Nsegment*12, 'real', lat_temp_adj)/=0 ) CALL read_error(2, 'lat_temp_adj') - - IF (getparam(MODNAME, 'seg_lat', Nsegment, 'real', Seg_lat)/=0 ) CALL read_error(2, 'seg_lat') -! Convert latitude from degrees to radians - seg_lat = seg_lat * DEG_TO_RAD - - IF (getparam(MODNAME, 'seg_elev', Nsegment, 'real', Seg_elev)/=0 ) CALL read_error(2, 'seg_elev') - - IF ( getparam( MODNAME, 'width_alpha', Nsegment, 'real', width_alpha)/=0 ) CALL read_error(2, 'width_alpha') - IF ( getparam( MODNAME, 'width_m', Nsegment, 'real', width_m)/=0 ) CALL read_error(2, 'width_m') - - IF ( Stream_temp_shade_flag==0 ) THEN - IF ( getparam( MODNAME, 'azrh', Nsegment, 'real', Azrh)/=0 ) CALL read_error(2, 'azrh') - IF ( getparam( MODNAME, 'alte', Nsegment, 'real', Alte)/=0 ) CALL read_error(2, 'alte') - IF ( getparam( MODNAME, 'altw', Nsegment, 'real', Altw)/=0 ) CALL read_error(2, 'altw') - IF ( getparam( MODNAME, 'vce', Nsegment, 'real', Vce)/=0 ) CALL read_error(2, 'vce') - IF ( getparam( MODNAME, 'vdemx', Nsegment, 'real', Vdemx)/=0 ) CALL read_error(2, 'vdemx') - IF ( getparam( MODNAME, 'vdemn', Nsegment, 'real', Vdemn)/=0 ) CALL read_error(2, 'vdemn') - IF ( getparam( MODNAME, 'vhe', Nsegment, 'real', Vhe)/=0 ) CALL read_error(2, 'vhe') - IF ( getparam( MODNAME, 'voe', Nsegment, 'real', Voe)/=0 ) CALL read_error(2, 'voe') - IF ( getparam( MODNAME, 'vcw', Nsegment, 'real', Vcw)/=0 ) CALL read_error(2, 'vcw') - IF ( getparam( MODNAME, 'vdwmx', Nsegment, 'real', Vdwmx)/=0 ) CALL read_error(2, 'vdwmx') - IF ( getparam( MODNAME, 'vdwmn', Nsegment, 'real', Vdwmn)/=0 ) CALL read_error(2, 'vdwmn') - IF ( getparam( MODNAME, 'vhw', Nsegment, 'real', Vhw)/=0 ) CALL read_error(2, 'vhw') - IF ( getparam( MODNAME, 'vow', Nsegment, 'real', Vow)/=0 ) CALL read_error(2, 'vow') - ELSE - IF ( getparam( MODNAME, 'segshade_sum', Nsegment, 'real', Segshade_sum)/=0 ) CALL read_error(2, 'segshade_sum') - IF ( getparam( MODNAME, 'segshade_win', Nsegment, 'real', Segshade_win)/=0 ) CALL read_error(2, 'segshade_win') - ENDIF - - IF ( getparam( MODNAME, 'ss_tau', Nsegment, 'integer', Ss_tau)/=0 ) CALL read_error(2, 'ss_tau') - IF ( getparam( MODNAME, 'gw_tau', Nsegment, 'integer', Gw_tau)/=0 ) CALL read_error(2, 'Gw_tau') - IF ( getparam( MODNAME, 'melt_temp', 1, 'real', Melt_temp)/=0 ) CALL read_error(2, 'melt_temp') - IF ( getparam( MODNAME, 'maxiter_sntemp', 1, 'real', Maxiter_sntemp)/=0 ) CALL read_error(2, 'maxiter_sntemp') - - ierr = 0 - IF ( Strmtemp_humidity_flag==1 ) THEN - IF ( getparam( MODNAME, 'seg_humidity', Nsegment*12, 'real', Seg_humidity)/=0 ) & - & CALL read_error(2, 'seg_humidity') - ELSEIF ( Strmtemp_humidity_flag==2 ) THEN ! use station data - IF ( getparam(MODNAME, 'seg_humidity_sta', Nsegment, 'integer', Seg_humidity_sta)/=0 ) & - & CALL read_error(2, 'seg_humidity_sta') - DO i = 1, Nsegment - CALL checkdim_param_limits(i, 'seg_humidity_sta', 'nhumid', Seg_humidity_sta(i), 1, Nhumid, ierr) - ENDDO - ENDIF - -! Initialize declared variables - seg_tave_upstream = 0.0 - Seg_potet = 0.0D0 - Seg_humid = 0.0 - Seg_width_flow = 0.0 - Seg_ccov = 0.0 - Seg_tave_air = 0.0 - seg_tave_gw = 0.0 - seg_tave_ss = 0.0 - seg_tave_sroff = 0.0 - - IF ( Init_vars_from_file == 0 ) THEN - Seg_tave_water = 0.0 - gw_silo = 0.0 - ss_silo = 0.0 - gw_sum = 0.0 - ss_sum = 0.0 -! these are set to zero because they will be incremented to 1 down in the run function - gw_index = 0 - ss_index = 0 - ENDIF - - Seg_daylight = 12.0 - IF ( Stream_temp_shade_flag==0 ) THEN - ALLOCATE ( Cos_seg_lat(Nsegment), Sin_seg_lat(Nsegment), Horizontal_hour_angle(366,Nsegment) ) - ALLOCATE ( Total_shade(366,Nsegment), Sin_declination(366,Nsegment), Sin_alrs(366,Nsegment) ) - ALLOCATE ( Sin_lat_decl(366,Nsegment), Cos_lat_decl(366,Nsegment) ) - ALLOCATE ( Max_solar_altitude(366,Nsegment), Level_sunset_azimuth(366,Nsegment) ) - ALLOCATE ( Local_sunset_hour_angle(366,Nsegment), Local_sunrise_hour_angle(366,Nsegment) ) - ALLOCATE ( Shade_jday(Nsegment, 366), Svi_jday(Nsegment, 366) ) - Shade_jday = 0.0 - Svi_jday = 0.0 - Seg_lat = 0.0 - ENDIF - -! Figure out how many HRUs are connected to each segment - Seg_hru_count = 0 - DO k = 1, Active_hrus - j = Hru_route_order(k) - i = Hru_segment(j) - IF ( i==0 ) CYCLE - Seg_hru_count(i) = Seg_hru_count(i) + 1 - ENDDO - - Seg_close = Segment_up ! assign upstream values - DO j = 1, Nsegment ! set values based on routing order for segments without associated HRUs - i = Segment_order(j) - - ! If a segment does not have any HRUs, need to find the closest one for elevation and latitude info - ! NOTE: seg_close variable can go upstream, downstream, or offstream looking for the "closest" segment with - ! an HRU. This is not approprite to use in a situation where computed values are going to be taken from - ! the closest HRU (i.e. flow). - ! - ! This does work for NHM network (most comprehensive test). - ! - IF ( Seg_hru_count(i)==0 ) THEN - IF ( Segment_up(i)==0 ) THEN - IF ( Tosegment(i)>0 ) THEN ! assign downstream values - Seg_close(i) = Tosegment(i) ! don't have a value yet, need to fix - ELSE ! no upstream or downstream segment - IF ( j>1 ) THEN - Seg_close(i) = Segment_order(j-1) ! set to previous segment id - ELSE - Seg_close(i) = Segment_order(j+1) ! assume at least 2 segments - ENDIF - ENDIF - ENDIF - IF ( Seg_elev(Seg_close(i))==30000.0 ) THEN ! need different segment - iseg = -1 - DO k = j+1, Nsegment ! find first segment with valid values - ii = Segment_order(k) - IF ( Seg_hru_count(ii)>0 ) THEN - Seg_close(i) = ii - EXIT - ENDIF - ENDDO - IF ( iseg==-1 ) THEN - IF ( j>1 ) THEN - Seg_close(i) = Segment_order(j-1) ! set to previous segment id - ELSE ! this is a problem, shouldn't happen - STOP 'ERROR, segments do not have associated HRUs' - ! Seg_close(i) = Segment_order(1) ! set to first segment id - ENDIF - ENDIF - ENDIF - ENDIF - - ! Compute atmospheric pressure based on segment elevation. - Press(i) = 1013.0 - (0.1055 * Seg_elev(i)) - - IF ( Stream_temp_shade_flag==0 ) THEN -! LATITUDE TRIGONOMETRIC PARAMETERS - Cos_seg_lat(i) = COS(Seg_lat(i)) ! coso - IF ( Cos_seg_lat(i) < NEARZERO ) Cos_Seg_lat(i) = NEARZERO - Sin_seg_lat(i) = SIN(Seg_lat(i)) ! sino - tano = Sin_seg_lat(i) / Cos_seg_lat(i) - DO k = 1, 366 -! DECLINATION TRIGONOMETRIC PARAMETERS - decl = 0.40928 * COS(((2.0 * PI) / 365.25) * (172.0 - k)) - cos_d = COS(decl) - Sin_declination(k, i) = SIN(decl) ! sin_d - IF ( cos_d < NEARZERO ) cos_d = NEARZERO - tan_d = Sin_declination(k, i) / cos_d -! -! JOINT LATITUDE & DECLINATION TRIGONOMETRIC PARAMETERS - Cos_lat_decl(k, i) = Cos_seg_lat(i) * cos_d ! cosod - Sin_lat_decl(k, i) = Sin_seg_lat(i) * Sin_declination(k, i) ! sinod - tanod = tano * tan_d - IF ( ABS(tanod) > 1.0 ) tanod = SIGN(1.0,tanod) - -! LEVEL-PLAIN SUNRISE/SET HOUR ANGLE - Horizontal_hour_angle(k, i) = ACOS(-tanod) ! hrso - sinhro = SIN(Horizontal_hour_angle(k, i)) -! -! LEVEL-PLAIN SOLAR AZIMUTH - temp = -Sin_declination(k, i)/Cos_Seg_lat(i) - IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0,temp) - Level_sunset_azimuth(k, i) = ACOS(temp) ! azso -! -! MAXIMUM POSSIBLE SOLAR ALTITUDE - Max_solar_altitude(k, i) = ASIN( Sin_lat_decl(k,i) + Cos_lat_decl(k,i) ) ! alsmx -! -! TOTAL POTENTIAL SHADE ON LEVEL-PLAIN ! totsh - Total_shade(k, i) = 2.0 * ((Horizontal_hour_angle(k, i) * Sin_lat_decl(k, i)) + (sinhro * Cos_lat_decl(k, i))) - IF ( Total_shade(k, i) < NEARZERO ) Total_shade(k, i) = NEARZERO -! -! CHECK FOR REACH AZIMUTH LESS THAN SUNRISE - IF ( Azrh(i) <= (-Level_sunset_azimuth(k, i)) ) THEN - alrs = 0.0 -! -! CHECK FOR REACH AZIMUTH GREATER THAN SUNSET - ELSEIF ( Azrh(i) >= Level_sunset_azimuth(k, i) ) THEN - alrs = 0.0 -! -! REACH AZIMUTH IS BETWEEN SUNRISE & SUNSET - ELSEIF ( Azrh(i) == 0.0 ) THEN - alrs = Max_Solar_altitude(k, i) - ELSE - alrs = solalt(Cos_seg_lat(i), Sin_seg_lat(i), Sin_declination(k,i), Azrh(i), 0.0, Max_Solar_altitude(k,i)) - Sin_alrs(k, i) = SIN(alrs) -! -! END REACH & SOLAR AZIMUTH CHECK - ENDIF - ENDDO - ENDIF - ENDDO - -! There may be headwater segments that do not have any HRUs and do not have any upstream segments to produce -! streamflow. These segments will never have any streamflow, and consequently never be able to simulate -! stream temperature. This block finds these and sets the stream temperature value to -99.9. Subsequent code -! should be able to check if the temperature value is less than -99.0 and know that it doesn't need to do -! any stream temperature calculation because there will never be any water in the segment. -! -! This code is similar to the code above that computes latitude and elevation, but is different because it -! must always look upstream because the downstream computations will not have been done when the current -! segment is being calculated. - Seg_tave_water = 0.0 - do j = 1, nsegment - this_seg = segment_order(j) - -! Check if this segment has any HRUs, keep moving up stream if not. - do - if (seg_hru_count(this_seg) .eq. 0) then - ! Hit the headwater segment without finding any HRUs (i.e. sources of streamflow) - ! Set the stream temp to -99.9 for this segment because there will never be any flow in this segment - if (segment_up(this_seg) .eq. 0) then - Seg_tave_water(segment_order(j)) = -99.9 - exit - endif - - ! There is an upstream segment, check that segment for HRUs - this_seg = segment_up(this_seg) - else - ! This segment has HRUs so there will be no streamflow - exit - endif - enddo - enddo - END FUNCTION stream_temp_init - - -!*********************************************************************** -! stream_temp_run - Computes stream temperatures -!*********************************************************************** - INTEGER FUNCTION stream_temp_run() - USE PRMS_STRMTEMP - USE PRMS_MODULE, ONLY: Nsegment, Strmtemp_humidity_flag - USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_area, NEARZERO, CFS2CMS_CONV - USE PRMS_SET_TIME, ONLY: Summer_flag, Nowmonth - USE PRMS_CLIMATEVARS, ONLY: Tavgc, Potet, Hru_rain, Swrad - USE PRMS_CLIMATE_HRU, ONLY: Humidity_hru - USE PRMS_FLOWVARS, ONLY: Seg_outflow - USE PRMS_SNOW, ONLY: Snowmelt - USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Seginc_swrad, Seg_length - USE PRMS_OBS, ONLY: Humidity - USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday, Jday - USE PRMS_SOLTAB, ONLY: Soltab_potsw, Hru_cossl - - IMPLICIT NONE -! Functions - INTRINSIC :: DBLE - REAL, EXTERNAL :: twavg, twmax, get_segwidth - EXTERNAL :: equilb, lat_inflow, shday -! Local Variables - REAL :: harea, svi, fs - INTEGER :: i, j, k, iseg - REAL :: te, ak1, ak2, ccov - DOUBLE PRECISION :: qlat - REAL :: t_o, up_temp -!*********************************************************************** - stream_temp_run = 0 - Seg_tave_air = 0.0 - -! Humidity info come from parameter file when Strmtemp_humidity_flag==1 -! Otherwise it comes as daily values per HRU from CBH. Code for this is -! down in the HRU loop. - IF ( Strmtemp_humidity_flag==1 ) THEN - DO i = 1, Nsegment - Seg_humid(i) = Seg_humidity(i, Nowmonth) - ENDDO - ELSEIF ( Strmtemp_humidity_flag==2 ) THEN ! use station data - DO i = 1, Nsegment - Seg_humid(i) = Humidity(Seg_humidity_sta(i)) - ENDDO - ELSE - Seg_humid = 0.0 - ENDIF - - Seg_potet = 0.0D0 - Seg_ccov = 0.0 - Seg_melt = 0.0 - Seg_rain = 0.0 - hru_area_sum = 0.0 - - ! Compute segment lateral inflow temperatures and segment meteorological values - DO k = 1, Active_hrus - j = Hru_route_order(k) - ccov = 1.0 - (Swrad(j) / sngl(Soltab_potsw(jday, j)) * sngl(Hru_cossl(j))) - IF ( ccov1.0 ) THEN - ccov = 1.0 - ENDIF - - harea = Hru_area(j) - i = Hru_segment(j) - IF ( i==0 ) CYCLE - -! Compute temperature of surface runoff here for HRU and stream segments - Seg_tave_air(i) = Seg_tave_air(i) + Tavgc(j)*harea - hru_area_sum(i) = hru_area_sum(i) + harea - -! Compute segment humidity if info is specified in CBH as timeseries by HRU - IF ( Strmtemp_humidity_flag==0 ) then - Seg_humid(i) = Seg_humid(i) + Humidity_hru(j)*harea - endif - -! Figure out the contributions of the HRUs to each segment for these drivers. - Seg_ccov(i) = Seg_ccov(i) + ccov*harea - Seg_potet(i) = Seg_potet(i) + DBLE( Potet(j)*harea ) - Seg_melt(i) = Seg_melt(i) + Snowmelt(j)*harea - Seg_rain(i) = Seg_rain(i) + Hru_rain(j)*harea - ENDDO - - - DO j = 1, Nsegment - i = Segment_order(j) - IF ( Seg_hru_count(i)>0 ) THEN -! carea = Seg_carea_inv(i) - Seg_ccov(i) = Seg_ccov(i) / hru_area_sum(i) - Seg_potet(i) = Seg_potet(i) / dble(hru_area_sum(i)) - Seg_tave_air(i) = Seg_tave_air(i) / hru_area_sum(i) - Seg_melt(i) = Seg_melt(i) / hru_area_sum(i) - Seg_rain(i) = Seg_rain(i) / hru_area_sum(i) - IF ( Strmtemp_humidity_flag==0 ) then - Seg_humid(i) = Seg_humid(i) / hru_area_sum(i) - -! DANGER potential hack here: Should CBH humidity data be converted to decimal fraction in -! the CBH file? Probably so. For now, convert it here. -! Humidity coming from CBH is in percent, not decimal fraction - Seg_humid(i) = Seg_humid(i) * 0.01 - endif - ELSE -! This block for segments that don't have contributing HRUs - iseg = Seg_close(i) ! doesn't work if upstream segment - Seg_tave_air(i) = Seg_tave_air(iseg) - Seg_ccov(i) = Seg_ccov(iseg) - Seg_potet(i) = Seg_potet(iseg) - Seg_melt(i) = Seg_melt(iseg) - Seg_rain(i) = Seg_rain(iseg) - IF ( Strmtemp_humidity_flag==0 ) then - Seg_humid(i) = Seg_humid(iseg)*Seg_carea_inv(iseg) ! ?? -! DANGER Humidity coming from CBH is in percent, not decimal fraction -! Same as comment in above block - Seg_humid(i) = Seg_humid(i) * 0.01 - endif - ENDIF - ENDDO - -! Compute the running averages for groundwater and subsurface temperatures. - if (gw_index >= gw_tau(i)) then - gw_index = 1 - else - gw_index = gw_index + 1 - endif - - if (ss_index >= ss_tau(i)) then - ss_index = 1 - else - ss_index = ss_index + 1 - endif - - ! Mark all of the upstream segment temperatures as not having been computed yet. - ! If the value is something other than -100.0, then I know that it has been computed. - ! Trying to get at the differece between computed bad values and segments that have not been - ! computed yet. - seg_tave_upstream(i) = -100.0 - -! Big do loop - DO j = 1, Nsegment - i = Segment_order(j) - - ! !! LOOP BREAKS HERE !! - ! - ! If the seg_tave_water value has been set to -99.9 (in init), then this is a segment that will - ! never have streamflow because it does not have any HRUs connected to it and none of the - ! upstream segments (if there are any) have HRUs connected. Because there can never be any - ! flow, the temperature calculation will always fail, so don't bother with it. - if (Seg_tave_water(i) < -99.0) then - cycle - endif - - ! !! LOOP BREAKS HERE !! - ! - ! If the seginc_swrad value has been set to -99.9 (route_run), then this segment will - ! never have solar radiation because it does not have any HRUs connected to it and none of the - ! upstream or downstream segments have HRUs connected. - if (seginc_swrad(i) < -99.0) then - Seg_tave_water(i) = -99.9 - cycle - endif - -! GW moving average - gw_sum(i) = gw_sum(i) - gw_silo(i, gw_index) - gw_silo(i, gw_index) = Seg_tave_air(i) - gw_sum(i) = gw_sum(i) + gw_silo(i, gw_index) - seg_tave_gw(i) = gw_sum(i) / gw_tau(i) - -! SS moving average - ss_sum(i) = ss_sum(i) - ss_silo(i, ss_index) - ss_silo(i, ss_index) = Seg_tave_air(i) - ss_sum(i) = ss_sum(i) + ss_silo(i, ss_index) - seg_tave_ss(i) = ss_sum(i) / ss_tau(i) - -! Find upstream intitial inflow temperature for segment i -! i is the current segment -! k is the upstream segment - fs = 0.0 - up_temp = 0.0 - DO k = 1, Nsegment - IF ( Tosegment(k)==i ) THEN - if (Seg_tave_water(k) > -1.0) then - up_temp = up_temp + (Seg_tave_water(k) * SNGL(Seg_outflow(k))) - fs = fs + SNGL(Seg_outflow(k)) - endif - ENDIF - ENDDO - - ! Finish computing seg_tave_upstream - IF ( fs > NEARZERO) THEN - seg_tave_upstream(i) = up_temp / fs - ELSE - ! -98.9 is the code for no flow on this timestep - seg_tave_upstream(i) = -98.9 - ENDIF - -! debug - if (seg_tave_upstream(i) > 100.0) then - write(*,*) "upstream_temp: i = ", i, " seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", & - & fs, " seg_tave_water = ", Seg_tave_water(i), " troff = " , Seg_tave_air(i), " up_temp = ", up_temp - endif - - ! Compute flow-dependent water-in-segment width value - if (seg_outflow(i) > NEARZERO) then - Seg_width_flow(i) = width_alpha(i) * sngl(Seg_outflow(i)) ** width_m(i) - else - Seg_width_flow(i) = 0.0 - if (Seg_tave_water(i) > -99.0) then - ! This segment has upstream HRUs somewhere, but the current day's flow is zero - Seg_tave_water(i) = -98.9 - endif - endif - - ! Compute the shade on the segment. Either set by value in the parameter file or computed - IF ( Stream_temp_shade_flag==1 ) THEN - IF ( Summer_flag==0 ) THEN - seg_shade(i) = Segshade_win(i) - ELSE - seg_shade(i) = Segshade_sum(i) - ENDIF - - ! Svi = RIPARIAN VEGETATION SHADE - svi = 0.0 - ELSE - CALL shday(i, seg_shade(i), svi) - ENDIF - - ! Start working towards the computation of the equilibrium temperature - qlat = 0.0D0 - seg_tave_lat(i) = 0.0 - ak1 = 0.0 - ak2 = 0.0 - - ! Inputs: seg_tave_gw, Seg_tave_air, seg_tave_ss, seg_tave_upstream, Seg_melt, Seg_rain - ! Outputs: qlat (in CMS), seg_tave_lat - CALL lat_inflow(qlat, seg_tave_lat(i), i, seg_tave_gw(i), Seg_tave_air(i), seg_tave_ss(i), & - & Seg_melt(i), Seg_rain(i)) - - - ! This code does not handle thermodynamics of ice, so temperatures below 0 are not allowed. - ! The question is when to set temperatures below 0 to 0. If, after computing the running averages - ! and mixing the different sources of lateral flow, the temperature is less than 0, set the lateral - ! flow temperature to 0 here. - if (seg_tave_lat(i) .lt. NEARZERO) then - seg_tave_lat(i) = 0.0 - endif - -! Compute t_o -! t_o is the temperature of the water at the beginning of the time step (this is To in equation 32) - if (Seg_tave_water(i) < -99.0) then -! No flow in this segment and there never will be becuase there are no upstream HRUs. - t_o = Seg_tave_water(i) - - elseif (Seg_tave_water(i) < -98.0) then -! No flow in this segment on this time step, but could be on future time step - t_o = Seg_tave_water(i) - - elseif ((fs .le. NEARZERO) .and. (qlat .le. NEARZERO)) then - ! If there is no flow, set the temperature to -98.9 - ! -99.9 means that the segment never has any flow (determined up in init). - ! -98.9 means that this a segment that could have flow, but doesn't - Seg_tave_water(i) = -98.9 - t_o = Seg_tave_water(i) - - elseif (fs .le. NEARZERO) then - ! if this is true, then there is no flow from upstream, but there is lateral inflow - t_o = seg_tave_lat(i) + lat_temp_adj(i,Nowmonth) - - elseif (qlat .le. NEARZERO) then - ! if this is true, then there is no lateral flow, but there is flow from upstream - t_o = seg_tave_upstream(i) - - else - ! if this is true, then there is both lateral flow and flow from upstream - ! qlat is in CMS so fs needs to be converted - t_o = sngl((seg_tave_upstream(i) * fs * CFS2CMS_CONV) + & - & (sngl(qlat) * (seg_tave_lat(i) + lat_temp_adj(i,Nowmonth)))) / & - & sngl((fs * CFS2CMS_CONV) + sngl(qlat)) - endif - -! debug - if (t_o .ne. t_o) then - write(*,*) "t_o is Nan, seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & - & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) - continue - endif - -! debug - if (t_o .gt. 100.0) then - write(*,*) "this is the place: t_o = ", t_o, " ted = ", te, " seg_id = ", i - write(*,*) " seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & - & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) - write(*,*) " width = ", Seg_width_flow(i), Nowyear, Nowmonth, Nowday - continue - exit - endif - -! Need a good value of t_o - if (t_o .gt. -98.0) then -! This block computes the value for seg_tave_water - -! Compute the equilibrium temerature - ! Out: te, ak1, ak2 - ! In: seg_shade, svi, i, t_o - CALL equilb(te, ak1, ak2, seg_shade(i), svi, i, t_o) - -! Compute the daily mean water temperature - ! In: t_o, qlat, seg_tave_lat(i), te, ak1, ak2, i, seg_width_flow, seg_length/1000 (km) - Seg_tave_water(i) = twavg(fs, t_o, qlat, seg_tave_lat(i), te, ak1, ak2, seg_width_flow(i), seg_length(i)/1000.0) - - else - ! bad t_o value - Seg_tave_water(i) = -98.9 - endif - ENDDO - END FUNCTION stream_temp_run -! -!********************************************************************************* -! Compute the flow-weighted average temperature and a total sum of lateral inflows -!********************************************************************************* - SUBROUTINE lat_inflow(Qlat, Tl_avg, id, tave_gw, tave_air, tave_ss, melt, rain) - USE PRMS_STRMTEMP, ONLY: Melt_temp - USE PRMS_BASIN, ONLY: CFS2CMS_CONV - USE PRMS_BASIN, ONLY: NEARZERO - USE PRMS_FLOWVARS, ONLY: Seg_lateral_inflow - USE PRMS_ROUTING, ONLY: Seginc_sroff, Seginc_ssflow, Seginc_gwflow - IMPLICIT NONE -! Functions - INTRINSIC SNGL -! Arguments - INTEGER, INTENT(IN) :: id - REAL, INTENT(IN) :: tave_gw, tave_air, tave_ss, melt, rain - REAL, INTENT(OUT) :: Tl_avg - DOUBLE PRECISION, INTENT(OUT) :: Qlat -! Local Variables - REAL :: weight_roff, weight_ss, weight_gw, melt_wt, rain_wt, troff, tss - INTRINSIC ABS -!***************************************************************************** - - Qlat = Seg_lateral_inflow(id) * CFS2CMS_CONV - Tl_avg = 0.0 - IF ( Qlat>0.0D0 ) THEN ! weights do not include water-use if active, not sure it works for cascades - weight_roff = SNGL( (Seginc_sroff(id) / Qlat) * CFS2CMS_CONV ) - weight_ss = SNGL( (Seginc_ssflow(id) / Qlat) * CFS2CMS_CONV ) - weight_gw = SNGL( (Seginc_gwflow(id) / Qlat) * CFS2CMS_CONV ) - ELSE - weight_roff = 0.0 - weight_ss = 0.0 - weight_gw = 0.0 - ENDIF - - IF (melt > 0.0) THEN - melt_wt = melt/(melt + rain) - IF (melt_wt < 0.0) melt_wt = 0.0 - IF (melt_wt > 1.0) melt_wt = 1.0 - rain_wt = 1.0 - melt_wt - IF (rain == 0.0) THEN - troff = Melt_temp - tss = Melt_temp - ELSE - troff = Melt_temp * melt_wt + tave_air * rain_wt - tss = Melt_temp * melt_wt + tave_ss * rain_wt - ENDIF - ELSE - troff = tave_air - tss = tave_ss - ENDIF - - Tl_avg = weight_roff * troff + weight_ss * tss + weight_gw * tave_gw - - END SUBROUTINE lat_inflow - -!*********************************************************************************************** - REAL FUNCTION twavg(qup, T0, Qlat, Tl_avg, Te, Ak1, Ak2, width, length) -! -! PURPOSE: -! 1. TO PREDICT THE AVERAGE DAILY WATER TEMPERATURE USING A SECOND-ORDER -! CLOSED-FORM SOLUTION TO THE STEADY-STATE HEAT TRANSPORT EQUATION. - USE PRMS_BASIN, ONLY: NEARZERO, CFS2CMS_CONV - IMPLICIT NONE -! Functions - INTRINSIC ABS, EXP, ALOG, SNGL, SIGN -! Arguments - REAL, INTENT(IN) :: T0, Tl_avg, Te, Ak1, Ak2, width, length, qup - DOUBLE PRECISION, INTENT(IN) :: Qlat -! Local Variables - REAL :: tep, b, r, rexp, tw, delt, q_init, denom, Ql -!*************************************************************************************************** -! DETERMINE EQUATION PARAMETERS - q_init = sngl(qup * CFS2CMS_CONV) - Ql = SNGL( Qlat ) - -! This is confused logic coment out here and compute the terms as needed below -! b = (Ql / Seg_length/1000) + ((Ak1 * Seg_width_flow) / 4182.0E03) -! IF ( b < NEARZERO ) b = NEARZERO ! rsr, don't know what value this should be to avoid divide by 0 -! r = 1.0 + (Ql / q_init) -! IF ( r < NEARZERO ) r = NEARZERO - - IF (Ql <= NEARZERO ) THEN -! -! ZERO LATERAL FLOW - tep = Te - b = (Ak1 * width) / 4182.0E03 - rexp = -1.0*(b * length) / q_init - r = EXP(rexp) - -! LOSING STREAM -! No such thing as losing streams in PRMS - ELSEIF ( Ql < 0.0 ) THEN - write(*,*) "twavg: losing stream!!! Should be no such thing in PRMS!" - tep = Te - b = (Ql / length) + ((Ak1 * width) / 4182.0E03) - rexp = (Ql - (b * length)) / Ql - r = 1.0 + (Ql / q_init) - r = r**rexp -! -! This is a headwaters (i.e. no streamflow from above, but lateral flow from HRUs. -! Treat the lateral flow as upstream flow to avoid divide by zero - ELSEIF ( Ql > NEARZERO .and. q_init <= NEARZERO ) THEN - tep = Te - b = (Ak1 * width) / 4182.0E03 -! rexp = -1.0*(b * length) / q_init - rexp = -1.0*(b * length) / Ql - r = EXP(rexp) -! -! GAINING STREAM (ie both ql and q_init have > zero values) - ELSE - b = (Ql / length) + ((Ak1 * width) / 4182.0E03) - tep = (((Ql / length) * Tl_avg) + (((Ak1 * width) / (4182.0E03)) * Te)) / b - -! shouldn't need to do this because Ql will always be greater than 0 if in here. - IF ( Ql > 0.0 ) THEN - rexp = -b / (Ql / length) - ELSE - rexp = 0.0 - ENDIF - -! DANGER -- replaced this potential divide by zero with the logic below -! r = 1.0 + (Ql / q_init) - if (q_init < NEARZERO) then - r = 2.0 - else - r = 1.0 + (Ql / q_init) - endif - r = r**rexp - -! END LATERAL FLOW TERM LOGIC - ENDIF -! -! DETERMINE WATER TEMPERATURE - delt = tep - T0 - denom = (1.0 + (Ak2 / Ak1) * delt * (1.0 - r)) - IF ( ABS(denom) < NEARZERO ) denom = SIGN(NEARZERO, denom) - tw = tep - (delt * r / denom) - IF ( tw < 0.0 ) tw = 0.0 - - twavg = tw - END FUNCTION twavg -! -!******************************************************************************* -! "equilb" -!******************************************************************************* - SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) -! -! PURPOSE: -! 1. DETERMINE THE AVERAGE DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS -! 2. DETERMINE THE MAXIMUM DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS - - USE PRMS_STRMTEMP, ONLY: ZERO_C, Seg_width_flow, Seg_humid, Press, MPS_CONVERT, & - & Seg_ccov, Seg_potet, Albedo, seg_tave_gw - USE PRMS_BASIN, ONLY: NEARZERO, CFS2CMS_CONV - USE PRMS_FLOWVARS, ONLY: Seg_inflow - USE PRMS_ROUTING, ONLY: Seginc_swrad, Seg_slope - IMPLICIT NONE -! Functions - INTRINSIC EXP, SQRT, ABS, SNGL, DBLE - EXTERNAL :: teak1 - REAL, EXTERNAL :: sat_vapor_press_poly -! Arguments: - REAL, INTENT(OUT) :: Ted - REAL, INTENT(OUT) :: Ak1d, Ak2d - REAL, INTENT(IN) :: Sh, Svi - INTEGER, INTENT(IN) :: Seg_id - REAL, INTENT(IN) :: t_o -! Local Variables: !RSR, maybe declare enegry balance fluxes - DOUBLE PRECISION :: ha, hv, taabs - REAL :: hf, hs, b, c, d, delt, del_ht, ltnt_ht, bow_coeff - REAL :: hnet, vp_sat, sw_power, evap, q_init - REAL, PARAMETER :: AKZ = 1.65, A = 5.40E-8, RAD_CONVERT = 41840.0/86400.0 - REAL :: foo -! ******************************************************************************* - - taabs = DBLE( t_o + ZERO_C ) - vp_sat = 6.108 * EXP(17.26939 * t_o/(t_o + 237.3)) - -! -! Convert units and set up parameters - q_init = SNGL( Seg_inflow(Seg_id) * CFS2CMS_CONV ) - IF ( q_init < NEARZERO ) q_init = NEARZERO - - ! sw_power should be in watts / m2 - ! seginc_swrad is in langly / day - ! Used to use RAD_CONVERT, the conversion I'm using now is a slightly different number. - sw_power = 11.63 / 24.0 * sngl(seginc_swrad(seg_id)) - - del_ht = 2.36E06 ! could multiple by 10E6 for this and other terms later to reduce round-off - ltnt_ht = 2495.0E06 - -! If humidity is 1.0, there is a divide by zero below. - if (Seg_humid(Seg_id) > 0.99) then - foo = 0.99 - else - foo = Seg_humid(Seg_id) - endif - - bow_coeff = (0.00061 * Press(Seg_id))/(vp_sat * (1.0 - foo)) - evap = SNGL( Seg_potet(Seg_id) * MPS_CONVERT ) -! -! HEAT FLUX COMPONENTS - ! document - ha = (1-rl)(1-sh)(1+0.17Cl**2)(0.61+0.05*SQRT(vp_sat)*stefan(Ta+273.16)**4 - - ha = ( (3.354939D-8 + 2.74995D-9 * DBLE(SQRT(Seg_humid(Seg_id) * vp_sat))) * DBLE((1.0 - Sh) & - & * (1.0 + (0.17*(Seg_ccov(Seg_id)**2)))) ) * (taabs**4) - -! hf is heat from stream friction. See eqn. 14. q_init is in CMS - hf = 9805.0 * (q_init/Seg_width_flow(Seg_id)) * Seg_slope(Seg_id) - hs = (1.0 - sh) * sw_power * (1.0 - Albedo) - hv = 5.24D-8 * DBLE(Svi) * (taabs**4) - -! Stefan-Boltzmann constant = 5.670373D-08; emissivity of water = 0.9526, times each other: 5.4016D-08 -! hw = water-emitted longwave radiation -! hw = 5.4016D-08 * (taabs**4) hw is include in other computations -! -! DETERMINE EQUILIBIRIUM COEFFICIENTS - b = bow_coeff * evap * (ltnt_ht + (del_ht * t_o)) + AKZ - (del_ht * evap) - c = bow_coeff * del_ht * evap - d = (SNGL(ha + hv) + hf + hs) + (ltnt_ht * evap * ((bow_coeff * t_o) - 1.0) + (seg_tave_gw(Seg_id) * AKZ)) - -! -! DETERMINE EQUILIBRIUM TEMPERATURE & 1ST ORDER THERMAL EXCHANGE COEF. - Ted = t_o - - CALL teak1(A, b, c, d, Ted, Ak1d) - -! -! DETERMINE 2ND ORDER THERMAL EXCHANGE COEFFICIENT - hnet = (A * ((t_o + ZERO_C)**4)) + (b * t_o) - (c * (t_o**2.0)) - d - delt = t_o - Ted - - IF ( ABS(delt) < NEARZERO) THEN - Ak2d = 0.0 - ELSE - Ak2d = ((delt * Ak1d) - hnet) / (delt**2) - ENDIF -! -! RETURN TO STREAMTEMP FUNCTION - END SUBROUTINE equilb - -!********************************************************************************** -! "teak1" -!********************************************************************************** - SUBROUTINE teak1(A, B, C, D, Teq, Ak1c) -! PURPOSE: -! 1. TO DETERMINE THE EQUILIBRIUM WATER TEMPERATURE FROM THE ENERGY BALANCE -! EQUATION BY ITERATING NEWTON'S METHOD -! 2. TO DETERMINE THE 1ST THERMAL EXCHANGE COEFFICIENT. - USE PRMS_STRMTEMP, ONLY: ZERO_C, Maxiter_sntemp - USE PRMS_BASIN, ONLY: NEARZERO -! USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday - IMPLICIT NONE - INTRINSIC ABS -! Arguments - REAL, INTENT(IN) :: A, B, C, D - REAL, INTENT(INOUT) :: Teq - REAL, INTENT(OUT) :: Ak1c -! Local variables - REAL :: teabs, fte, fpte, delte - INTEGER :: kount -! Parameters - ! SOLUTION CONVERGENCE TOLERANCE - REAL, PARAMETER :: TOLRN = 1.0E-4 -!********************************************************************************** - fte = 99999.0 ! rsr, fte was not set - delte = 99999.0 ! rsr, delte was not set - kount = 0 - -! BEGIN NEWTON ITERATION SOLUTION FOR TE - DO kount = 1, Maxiter_sntemp - IF ( ABS(fte) < TOLRN ) EXIT - IF ( ABS(delte) < TOLRN ) EXIT - teabs = Teq + ZERO_C - fte = (A * (teabs**4.0)) + (B * Teq) - (C * (Teq**2.0)) - D - fpte = (4.0 * A * (teabs**3.0)) + B - (2.0 * C * Teq) - delte = fte / fpte - Teq = Teq - delte - ENDDO - -! DETERMINE 1ST THERMAL EXCHANGE COEFFICIENT - Ak1c = (4.0 * A * ((Teq + ZERO_C)**3.0)) + B - (2.0 * C * Teq) -! -! RETURN TO 'EQUILB' SUBROUTINE - END SUBROUTINE teak1 - -! "shday" *********************************************************** - SUBROUTINE shday(Seg_id, Shade, Svi) -! -! THIS SUBPROGRAM IS TO CALCULATE THE TOTAL DAILY SHADE FOR A -! GIVEN REACH. BOTH TOPOGRAPHIC AND RIPARIAN VEGETATION SHADE -! IS INCLUDED. -! -! VARIABLE NAME LIST -! -! Als = CURRENT SOLAR ALTITUDE -! Alrs = SOLAR ALTITUDE WHEN SOLAR & REACH AZIMUTHS ARE EQUAL -! Alsmx = MAXIMUM POSSIBLE SOLAR ALTITUDE -! Alsr = LOCAL SUNRISE SOLAR ALTITUDE ! rsr, not used -! Alss = LOCAL SUNSET SOLAR ALTITUDE ! rsr, not used -! Alt = CURRENT TOPOGRAPHIC ALTITUDE -! Alte = EAST SIDE MAXIMUM TOPOGRAPHIC ALTITUDE -! Altmx = CURRENT MAXIMUM TOPOGRAPHIC ALTITUDE LIMIT -! Altop = CURRENT TOPOGRAPHIC ALTITUDE -! Altw = WEST SIDE MAXIMUM TOPOGRAPHIC ALTITUDE -! Azrh = STREAM REACH AZIMUTH -! Azs = CURRENT SOLAR AZIMUTH -! Azsr = LOCAL SUNRISE SOLAR AZIMUTH ! rsr, not used -! Azss = LOCAL SUNSET SOLAR AZIMUTH ! rsr, not used -! Azso = LEVEL-PLAIN SUNSET AZIMUTH -! Bavg = AVERAGE STREAM WIDTH -! Bs = SHADED PART OF STREAM WIDTH -! Cosas = COS(AS) -! Cosd = COS(DECL) -! Coshs = COS(HS) -! Coso = COS(XLAT) -! Cosod = COS(XLAT)*COS(DECL) -! Dayrad = CONVERSION RATIO FOR JULIAN DAYS TO RADIANS -! Decl = CURRENT SOLAR DECLINATION -! Delhsr = SUNRISE SIDE HOUR ANGLE INCREMENT -! Delhss = SUNSET SIDE HOUR ANGLE INCREMENT -! Hrrs = REACH HOUR ANGLE WHEN SOLAR & REACH AZIMUTHS ARE EQUAL -! Hrs = CURRENT SOLAR HOUR ANGLE -! Hrsr = LOCAL SUNRISE SOLAR HOUR ANGLE -! Hrss = LOCAL SUNSET SOLAR HOUR ANGLE -! Hrso = LEVEL-PLAIN SUNRISE/SET SOLAR HOUR ANGLE -! Nbhs = NUMBER OF SUNRISE/SET HOUR ANGLE INCREMENTS -! Shday = TOTAL DAILY SHADE -! Sinal = SIN(Al) -! Sinar = SIN(Ar) -! Sin_d = SIN(DECL) -! Sinhsr = SIN(Hrsr) -! Sinhss = SIN(Hrss) -! Sinhro = SIN(Hrso) -! Sino = SIN(XLAT) -! Sinod = SIN(XLAT)*SIN(DECL) -! Snflag = SOLAR NOON LIMIT FLAG -! Sti = TOPOGRAPHIC SHADE -! Svi = RIPARIAN VEGETATION SHADE -! Svri = SUNRISE VEGETATIVE SHADE -! Svsi = SUNSET VEGETATIVE SHADE -! Tanasr = TAN(Alsr) -! Tanass = TAN(Alss) -! Tanalt = TAN(Alt) -! Tano = TAN(XLAT) -! Tanod = TAN(XLAT)*TAN(DECL) -! Totsh = LEVEL-PLAIN TOTAL SHADE POTENTIAL -! Tolrn = CONVERGENCE TOLERANCE CRITERIA -! Flgrs = SUNRISE FLAG; TRUE IF SUNRISE, FALSE IF SUNSET -! Flgst = SUNSET FLAG; TRUE IF SUNSET, FALSE IF SUNRISE -! Vc = CROWN DIAMETER, CURRENT VEGETATION -! Vce = CROWN DIAMETER, EAST SIDE VEGETATION -! Vco = CURRENT VEGETATION OVERHANG -! Vcw = CROWN DIAMETER, WEST SIDE VEGETATION -! Vd = DENSITY, CURRENT VEGETATION -! Vde = DENSITY, EAST SIDE VEGETATION -! Vdw = DENSITY, WEST SIDE VEGETATION -! Vh = HEIGHT, CURRENT VEGETATION -! Vhe = HEIGHT, EAST SIDE VEGETATION -! Vhw = HEIGHT, WEST SIDE VEGETATION -! Vo = OFFSET, CURRENT VEGETATION -! Voe = OFFSET, EAST SIDE VEGETATION -! Vow = OFFSET, WEST SIDE VEGETATION -! - USE PRMS_SET_TIME, ONLY: Jday - USE PRMS_STRMTEMP, ONLY: Azrh, Alte, Altw, Seg_daylight, Seg_width_flow, & - & PI, HALF_PI, Cos_seg_lat, Sin_seg_lat, Cos_lat_decl, Horizontal_hour_angle, & - & Level_sunset_azimuth, Max_solar_altitude, Sin_alrs, Sin_declination, Sin_lat_decl, Total_shade - USE PRMS_BASIN, ONLY: CFS2CMS_CONV - IMPLICIT NONE -! Functions - INTRINSIC COS, SIN, TAN, ACOS, ASIN, ATAN, ABS, MAX, SNGL - REAL, EXTERNAL:: solalt, rprnvg - EXTERNAL snr_sst -! Arguments - INTEGER, INTENT(IN) :: Seg_id - REAL, INTENT(OUT):: Shade, Svi -! Local Variables - REAL :: coso, cosod, sin_d, sino, sinod - REAL :: altmx, alsmx, als, almn, almx - REAL :: azso, azmn, azmx, azs, hrrs, hrsr, hrss, hrso, hrs, hrrh - REAL :: temp, totsh, sti - REAL :: altop(3), aztop(3) -! PARAMETER - REAL, PARAMETER :: RADTOHOUR = 24.0/(2.0 * PI) -!********************************************************************************* - -! LATITUDE TRIGONOMETRIC PARAMETERS - coso = Cos_seg_lat(Seg_id) - sino = Sin_seg_lat(Seg_id) - sin_d = Sin_declination(Jday, Seg_id) - sinod = Sin_lat_decl(Jday, Seg_id) - cosod = Cos_lat_decl(Jday, Seg_id) -! -! INITIALIZE LOCAL SUNRISE/SET SOLAR PARAMETERS - hrsr = 0.0 - hrss = 0.0 -! -! MAXIMUM POSSIBLE SOLAR ALTITUDE - alsmx = Max_solar_altitude(Jday, Seg_id) -! -! LEVEL-PLAIN SUNRISE/SET HOUR ANGLE - hrso = Horizontal_hour_angle(Jday, Seg_id) -! -! LEVEL-PLAIN SOLAR AZIMUTH - azso = Level_sunset_azimuth(Jday, Seg_id) -! -! TOTAL POTENTIAL SHADE ON LEVEL-PLAIN - totsh = Total_shade(Jday, Seg_id) -! -! CHECK FOR REACH AZIMUTH LESS THAN SUNRISE - IF ( Azrh(Seg_id) <= (-azso) ) THEN - hrrs = -hrso -! -! CHECK FOR REACH AZIMUTH GREATER THAN SUNSET - ELSEIF ( Azrh(Seg_id) >= azso ) THEN - hrrs = hrso -! -! REACH AZIMUTH IS BETWEEN SUNRISE & SUNSET - ELSEIF ( Azrh(Seg_id) == 0.0 ) THEN - hrrs = 0.0 - ELSE - temp = (Sin_alrs(Jday, Seg_id) - sinod) / cosod - IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0,temp) - hrrs = SIGN(ACOS(temp), Azrh(Seg_id)) -! -! END REACH & SOLAR AZIMUTH CHECK - ENDIF -! -! CHECK IF LEVEL-PLAIN - IF ( (Alte(Seg_id) == 0.0 ) .AND. (Altw(Seg_id) == 0.0) ) THEN -! azsr = -azso - hrsr = -hrso -! azss = azso - hrss = hrso - sti = 0.0 - Svi = (rprnvg(hrsr, hrrs, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width_flow(Seg_id) * totsh) - - ELSE -! INITIALIZE SHADE VALUES -! -! INSERT STARTING TOPOGRAPHIC AZIMUTH VALUES BETWEEN LEVEL PLAIN SUNRISE AND SUNSET - aztop = 0.0 -! -! DETERMINE SUNRISE HOUR ANGLE. - altop = 0.0 - IF ( -azso <= Azrh(Seg_id) ) THEN - altop(1) = Alte(Seg_id) - aztop(1) = azso*(Alte(Seg_id)/HALF_PI) - azso - ELSE - altop(1) = Altw(Seg_id) - aztop(1) = azso*(Altw(Seg_id)/HALF_PI) - azso - ENDIF -! LEVEL PLAIN - IF (altop(1) == 0.0) THEN - hrsr = -hrso -! NOT - ELSE -! LOOK FOR SOLUTION BETWEEN LIMITS OF LEVEL PLAIN SUNRISE AND NOON - azmn = -azso - azmx = 0.0 - azs = aztop(1) - altmx = altop(1) - almn = 0.0 - almx = 1.5708 - als = solalt(coso, sino, sin_d, azs, almn, almx) - CALL snr_sst(coso, sino, sin_d, altmx, almn, almx, azmn, azmx, azs, als, hrs, Seg_id) -! azsr = azs -! alsr = als - hrsr = hrs -! altr = altmx - ENDIF -! -! DETERMINE SUNSET HOUR ANGLE. - IF ( azso <= Azrh(Seg_id) )THEN - altop(2) = Alte(Seg_id) - aztop(2) = azso - azso*(Alte(Seg_id)/HALF_PI) - ELSE - altop(2) = Altw(Seg_id) - aztop(2) = azso - azso*(Altw(Seg_id)/HALF_PI) - ENDIF -! LEVEL PLAIN - IF (altop(2) == 0.0) THEN - hrss = hrso -! NOT - ELSE -! LOOK FOR SOLUTION BETWEEN LIMITS OF NOON AND LEVEL PLAIN SUNSET - azmn = 0.0 - azmx = azso - azs = aztop(2) - altmx = altop(2) - almn = 0.0 - almx = 1.5708 - als = solalt(coso, sino, sin_d, azs, almn, almx) - CALL snr_sst(coso, sino, sin_d, altmx, almn, almx, azmn, azmx, azs, als, hrs, Seg_id) -! azss = azs -! alss = als - hrss = hrs -! alts = altmx - ENDIF -! -! SOLVE FOR SHADE INCREMENTS THIS SEGMENT - IF ( hrrs < hrsr ) THEN - hrrh = hrsr - ELSEIF ( hrrs > hrss ) THEN - hrrh = hrss - ELSE - hrrh = hrrs - ENDIF - - Seg_daylight(Seg_id) = (hrss - hrsr) * RADTOHOUR - sti = 1.0 - ((((hrss - hrsr) * sinod) + ((SIN(hrss) - SIN(hrsr)) * cosod)) / (totsh)) - Svi = ((rprnvg(hrsr, hrrh, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width_flow(Seg_id)*totsh)) -! -! END SUNRISE/SUNSET CALCULATION - ENDIF -! -! CHECK FOR ROUNDOFF ERRORS - IF ( sti < 0.0 ) sti = 0.0 - IF ( sti > 1.0 ) sti = 1.0 - IF ( Svi < 0.0 ) Svi = 0.0 - IF ( Svi > 1.0 ) Svi = 1.0 -! -! RECORD TOTAL SHADE - Shade = sti + Svi - - END SUBROUTINE shday -! -!********************************************************************************************************** -! "snr_sst" - SUBROUTINE snr_sst (Coso, Sino, Sin_d, Alt, Almn, Almx, Azmn, Azmx, Azs, Als, Hrs, Seg_id) -! -! THIS SUBPROGRAM DETERMINES THE LOCAL SOLAR SUNRISE/SET -! AZIMUTH, ALTITUDE, AND HOUR ANGLE -! - USE PRMS_STRMTEMP, ONLY: Azrh, PI, Maxiter_sntemp - USE PRMS_BASIN, ONLY: NEARZERO - IMPLICIT NONE -! Functions - INTRINSIC TAN, SIN, COS, ACOS, ASIN, ABS -! Arguments - INTEGER, INTENT(IN):: Seg_id - REAL, INTENT(IN):: Coso, Sino, Sin_d, Alt, Almn, Almx, Azmn, Azmx - REAL, INTENT(INOUT):: Azs, Als - REAL, INTENT(OUT):: Hrs -! Local Variables - REAL :: cosazs, sinazs, sinazr, cosazr, cosals, f, g, fazs, fals, gazs, gals, xjacob - REAL :: sinals, tanalt, tano, tanals, temp, delazs, delals - INTEGER :: count -!*********************************************************************************************************** -! TRIG FUNCTION FOR LOCAL ALTITUDE - tanalt = TAN(Alt) - tano = Sino / Coso - f = 999999.0 !rsr, these need values - delazs = 9999999.0 - g = 99999999.0 - delals = 99999999.0 - -! BEGIN NEWTON-RAPHSON SOLUTION - DO count = 1, Maxiter_sntemp - IF ( ABS(delazs) < NEARZERO ) EXIT - IF ( ABS(delals) < NEARZERO ) EXIT - IF ( ABS(f) < NEARZERO ) EXIT - IF ( ABS(g) < NEARZERO ) EXIT - - cosazs = COS(Azs) - sinazs = SIN(Azs) - - sinazr = ABS(SIN(Azs - Azrh(Seg_id))) - IF ( (((Azs-Azrh(Seg_id)) <= 0.0 ) .AND. ((Azs-Azrh(Seg_id)) <= (-PI))) .OR. & - & (((Azs-Azrh(Seg_id)) > 0.0 ) .AND. ((Azs-Azrh(Seg_id)) <= PI)) ) THEN - cosazr = COS(Azs-Azrh(Seg_id)) - ELSE - cosazr = -COS(Azs-Azrh(Seg_id)) - ENDIF - - cosals = COS(Als) - IF ( cosals < NEARZERO ) cosals = NEARZERO - sinals = SIN(Als) - tanals = sinals / cosals -! FUNCTIONS OF AZS & ALS - f = cosazs- (((Sino * sinals) - Sin_d) / (Coso * cosals)) - g = tanals - (tanalt * sinazr) -! FIRST PARTIALS DERIVATIVES OF F & G - fazs = -sinazs - fals = ((tanals * (Sin_d / Coso)) - (tano / cosals)) / cosals - gazs = -tanalt * cosazr - gals = 1.0 / (cosals * cosals) -! JACOBIAN - xjacob = (fals * gazs) - (fazs * gals) -! DELTA CORRECTIONS - delazs = ((f * gals) - (g * fals)) / xjacob - delals = ((g * fazs) - (f * gazs)) / xjacob -! NEW VALUES OF AZS & ALS - Azs = Azs + delazs - Als = Als + delals -! CHECK FOR LIMITS - IF ( Azs < (Azmn + NEARZERO) ) Azs = (Azmn + NEARZERO) - IF ( Azs > (Azmx - NEARZERO) ) Azs = (Azmx - NEARZERO) - IF ( Als < (Almn + NEARZERO) ) Als = (Almn + NEARZERO) - IF ( Als > (Almx - NEARZERO) ) Als = (Almx - NEARZERO) - ENDDO -! -! ENSURE AZIMUTH REMAINS BETWEEN -PI & PI - IF ( Azs < (-PI) ) THEN - Azs = Azs + PI - ELSEIF ( Azs > PI) THEN - Azs = Azs - PI - ENDIF -! -! DETERMINE LOCAL SUNRISE/SET HOUR ANGLE - sinals = SIN(Als) - temp = (sinals - (Sino * Sin_d)) / (Coso * COS(ASIN(Sin_d))) - IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0,temp) - Hrs = SIGN(ACOS(temp), Azs) - - END SUBROUTINE snr_sst - -!***************************************************************************** -! "solalt" - REAL FUNCTION solalt (Coso, Sino, Sin_d, Az, Almn, Almx) -! -! THIS SUBPROGRAM IS TO DETERMINE THE SOLAR ALTITUDE WHEN THE -! TRIGONOMETRIC PARAMETERS FOR LATITUDE, DECLINATION, AND AZIMUTH -! ARE GIVEN. -! -! VARIABLE NAME LIST -! -! Al = TRIAL SOLAR ALTITUDE -! AZ = SOLAR AZIMUTH -! COSAL = COS(AL) -! COSAZ = COS(AZ) -! Coso = COS(XLAT) -! DELAL = INCREMENTAL CORRECTION TO AL -! FAL = FUNCTION OF AL -! FPAL = FIRST DERIVATIVE OF FAL -! FPPAL = SECOND DERIVATIVE OF FAL -! Sin_d = SIN(DECL) -! Sino = SIN(XLAT) - USE PRMS_STRMTEMP, ONLY: HALF_PI, Maxiter_sntemp - USE PRMS_BASIN, ONLY: NEARZERO - IMPLICIT NONE -! Functions - INTRINSIC ASIN, ABS, COS, SIN -! Arguments - REAL, INTENT(IN):: Coso, Sino, Sin_d, Az, Almn, Almx -! Local Variables - REAL :: cosal, sinal, fal, fpal, fppal, al, alold, delal, a, b, cosaz, temp - INTEGER :: kount -!************************************************************************************* -! -! CHECK COS(AZ) EQUAL TO 0 - IF ( ABS(ABS(Az) - HALF_PI) < NEARZERO ) THEN - temp = ABS(Sin_d / Sino) - IF ( temp > 1.0 ) temp = 1.0 - Al = ASIN(temp) - ELSE -! -! DETERMINE SOLAR ALTITUDE FUNCTION COEFFICIENTS - cosaz = COS(Az) - a = Sino / (cosaz * Coso) - b = Sin_d / (cosaz * Coso) -! -! INITIALIZE - al = (Almn + Almx) / 2.0 - kount = 0 - fal = COS(al) - (a * SIN(al)) + b - delal = fal/(-SIN(al) - (a * COS(al))) -! -! BEGIN NEWTON SECOND-ORDER SOLUTION - DO kount = 1, Maxiter_sntemp - IF ( ABS(fal) < NEARZERO ) EXIT - IF ( ABS(delal) < NEARZERO ) EXIT - alold = al - cosal = COS(al) - sinal = SIN(al) - fal = cosal - (a * sinal) + b - fpal = -sinal - (a * cosal) - IF ( kount <= 3 ) THEN - delal = fal / fpal - ELSE - fppal = b - fal - delal = (2.0 * fal * fpal) / ((2.0 * fpal * fpal) - (fal * fppal)) - ENDIF - al = al - delal - IF (al < Almn) al = (alold + Almn) / 2.0 - IF (al > Almx) al = (alold + Almx) / 2.0 - ENDDO - ENDIF -! -! SOLUTION OBTAINED - solalt = al - - END FUNCTION solalt - -!*********************************************************************** - REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) -! -! THIS SUBPROGRAM IS TO COMPUTE THE RIPARIAN VEGETATION SHADE -! SEGMENT BETWEEN THE TWO HOUR ANGLES HRSR & HRSS. -! - USE PRMS_STRMTEMP, ONLY: Azrh, Vce, Vdemx, Vhe, Voe, Vcw, Vdwmx, Vhw, Vow, Seg_width_flow, & - & Vdemn, Vdwmn, HALF_PI - USE PRMS_BASIN, ONLY: NEARZERO - USE PRMS_SET_TIME, ONLY: Summer_flag - IMPLICIT NONE -! Functions - INTRINSIC COS, SIN, ASIN, ACOS, ABS -! Arguments - REAL, INTENT(IN) :: Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod - INTEGER, INTENT(IN):: Seg_id -! Local Variables - REAL :: svri, svsi, hrs, vco, delhsr, coshrs - REAL :: sinhrs, temp, als, cosals, sinals, azs, bs, delhss - INTEGER :: n -! Parameters - INTEGER, PARAMETER :: NBHS = 15 - DOUBLE PRECISION, SAVE :: Epslon(15), Weight(15) - DATA Epslon / .006003741, .031363304, .075896109, .137791135, .214513914, & - & .302924330, .399402954, .500000000, .600597047, .697075674, & - & .785486087, .862208866, .924103292, .968636696, .993996259 / - DATA Weight / .015376621, .035183024, .053579610, .069785339, .083134603, & - & .093080500, .099215743, .101289120, .099215743, .093080500, & - & .083134603, .069785339, .053579610, .035183024, .015376621 / -!****************************************************************************** -! ****************** Determine seasonal shade -! -! CKECK FOR NO SUNRISE - IF ( Hrsr == Hrss ) THEN - svri = 0.0 - svsi = 0.0 - - ELSE -! -! VEGETATIVE SHADE BETWEEN SUNRISE & REACH HOUR ANGLES - svri = 0.0 - IF ( Hrsr < Hrrs ) THEN - vco = ( Vce(Seg_id)/2.0 ) - Voe(Seg_id) -! -! DETERMINE SUNRISE SIDE HOUR ANGLE INCREMENT PARAMETERS - delhsr = Hrrs - Hrsr -! -! PERFORM NUMERICAL INTEGRATION - DO n = 1, NBHS -! CURRENT SOLAR HOUR ANGLE - hrs = SNGL(Hrsr + (Epslon(n) * delhsr)) - coshrs = COS(hrs) - sinhrs = SIN(hrs) -! CURRENT SOLAR ALTITUDE - temp = Sinod + (Cosod * coshrs) - IF ( temp > 1.0 ) temp = 1.0 - als = ASIN(temp) - cosals = COS(als) - sinals = SIN(als) - IF ( sinals == 0.0 ) sinals = NEARZERO -! CURRENT SOLAR AZIMUTH - temp = ((Sino * sinals) - Sin_d) / (Coso * cosals) - IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0, temp) - azs = ACOS(temp) - IF ( azs < 0.0 ) azs = HALF_PI - azs - IF ( hrs < 0.0 ) azs = -azs -! DETERMINE AMOUNT OF STREAM WIDTH SHADED - bs = ((Vhe(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco - IF ( bs < 0.0 ) bs = 0.0 - IF ( bs > Seg_width_flow(Seg_id) ) bs = Seg_width_flow(Seg_id) -! INCREMENT SUNRISE SIDE VEGETATIVE SHADE - IF ( Summer_flag == 1 ) THEN ! put back spring and autumn - svri = svri + SNGL(Vdemx(Seg_id) * bs * sinals * Weight(n)) - ELSE - svri = svri + SNGL(Vdemn(Seg_id) * bs * sinals * Weight(n)) - ENDIF - ENDDO -! - svri = svri * delhsr - ENDIF -! -! VEGETATIVE SHADE BETWEEN REACH & SUNSET HOUR ANGLES - svsi = 0.0 - IF ( Hrss > Hrrs ) THEN - vco = (Vcw(Seg_id)/2.0 ) - Vow(Seg_id) -! -! DETERMINE SUNSET SIDE HOUR ANGLE INCREMENT PARAMETERS - delhss = Hrss - Hrrs -! -! PERFORM NUMERICAL INTEGRATION - DO n = 1, Nbhs -! CURRENT SOLAR HOUR ANGLE - hrs = SNGL(Hrrs + (Epslon(n) * delhss)) - coshrs = COS(hrs) - sinhrs = SIN(hrs) -! CURRENT SOLAR ALTITUDE - temp = Sinod + (Cosod * coshrs) - IF ( temp > 1.0 ) temp = 1.0 - als = ASIN(temp) - cosals = COS(als) - sinals = SIN(als) - IF ( sinals == 0.0 ) sinals = NEARZERO -! CURRENT SOLAR AZIMUTH - temp = ((Sino * sinals) - Sin_d) / (Coso * cosals) - IF ( ABS(temp) > 1.0 ) temp = SIGN(1.0, temp) - azs = ACOS(temp) - IF ( azs < 0.0 ) azs = HALF_PI - azs - IF ( hrs < 0.0 ) azs = -azs -! DETERMINE AMOUNT OF STREAM WIDTH SHADED - bs = ((Vhw(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco - IF ( bs < 0.0 ) bs = 0.0 - IF ( bs > Seg_width_flow(Seg_id) ) bs = Seg_width_flow(Seg_id) -! INCREMENT SUNSET SIDE VEGETATIVE SHADE - IF ( Summer_flag == 1 ) THEN ! fix for seasons - svsi = SNGL(svsi + (Vdwmx(Seg_id) * bs * sinals * Weight(n))) - ELSE - svsi = SNGL(svsi + (Vdwmn(Seg_id) * bs * sinals * Weight(n))) - ENDIF - ENDDO - svsi = svsi * delhss - ENDIF - ENDIF - -! COMBINE SUNRISE/SET VEGETATIVE SHADE VALUES - rprnvg = svri + svsi - - END FUNCTION rprnvg - -!*********************************************************************** -! stream_temp_restart - write or read stream_temp restart file -!*********************************************************************** - SUBROUTINE stream_temp_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit - USE PRMS_STRMTEMP - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - EXTERNAL check_restart - ! Local Variable - CHARACTER(LEN=11) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Seg_tave_water - WRITE ( Restart_outunit ) gw_silo - WRITE ( Restart_outunit ) ss_silo - WRITE ( Restart_outunit ) gw_sum - WRITE ( Restart_outunit ) ss_sum - WRITE ( Restart_outunit ) gw_index - WRITE ( Restart_outunit ) ss_index - ELSE - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) Seg_tave_water - READ ( Restart_inunit ) gw_silo - READ ( Restart_inunit ) ss_silo - READ ( Restart_inunit ) gw_sum - READ ( Restart_inunit ) ss_sum - READ ( Restart_inunit ) gw_index - READ ( Restart_inunit ) ss_index - ENDIF - END SUBROUTINE stream_temp_restart diff --git a/prms/strmflow_in_outCopy.f90 b/prms/strmflow_in_outCopy.f90 deleted file mode 100644 index 93a1ebe9..00000000 --- a/prms/strmflow_in_outCopy.f90 +++ /dev/null @@ -1,108 +0,0 @@ -!*********************************************************************** -! Routes water between segments in the system as inflow equals outflow -!*********************************************************************** - INTEGER FUNCTION strmflow_in_out() - USE PRMS_MODULE, ONLY: Process, Nsegment, Print_debug - USE PRMS_SET_TIME, ONLY: Cfs_conv - USE PRMS_BASIN, ONLY: Active_area, CFS2CMS_CONV - USE PRMS_GWFLOW, ONLY: Basin_gwflow - USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cfs, Basin_cms, Basin_stflow_in, & - & Basin_sroff_cfs, Basin_ssflow_cfs, Basin_gwflow_cfs, Basin_stflow_out, & - & Seg_inflow, Seg_outflow, Seg_upstream_inflow, Seg_lateral_inflow, Flow_out - USE PRMS_ROUTING, ONLY: Obsin_segment, Segment_order, Tosegment, Obsout_segment, Segment_type, & - & Flow_to_lakes, Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_replacement, & - & Flow_out_NHM, Flow_terminus, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes - USE PRMS_SRUNOFF, ONLY: Basin_sroff - USE PRMS_OBS, ONLY: Streamflow_cfs - IMPLICIT NONE -! Functions - EXTERNAL :: print_module -! Local Variables - INTEGER :: i, iorder, toseg, segtype - DOUBLE PRECISION :: area_fac, segout - CHARACTER(LEN=80), SAVE :: Version_strmflow -!*********************************************************************** - strmflow_in_out = 0 - - IF ( Process(:3)=='run' ) THEN - Seg_inflow = 0.0D0 - Seg_outflow = 0.0D0 - Seg_upstream_inflow = 0.0D0 - Flow_out = 0.0D0 - Flow_to_lakes = 0.0D0 - Flow_to_ocean = 0.0D0 - Flow_to_great_lakes = 0.0D0 - Flow_out_region = 0.0D0 - Flow_out_NHM = 0.0D0 - Flow_in_region = 0.0D0 - Flow_terminus = 0.0D0 - Flow_in_nation = 0.0D0 - Flow_headwater = 0.0D0 - Flow_in_great_lakes = 0.0D0 - Flow_replacement = 0.0D0 - DO i = 1, Nsegment - iorder = Segment_order(i) - toseg = Tosegment(iorder) - segtype = Segment_type(iorder) - IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) - Seg_inflow(iorder) = Seg_upstream_inflow(iorder) + Seg_lateral_inflow(iorder) - IF ( Obsout_segment(iorder)>0 ) THEN - Seg_outflow(iorder) = Streamflow_cfs(Obsout_segment(iorder)) - ELSE - Seg_outflow(iorder) = Seg_inflow(iorder) - ENDIF - - IF ( Seg_outflow(iorder) < 0.0 ) THEN - IF ( Print_debug>-1 ) THEN - PRINT *, 'WARNING, negative flow from segment:', iorder, ' flow:', Seg_outflow(iorder) - PRINT *, ' likely a water-use specification or replacement flow issue' - ENDIF - ENDIF - - segout = Seg_outflow(iorder) -! Flow_out is the total flow out of the basin, which allows for multiple outlets -! includes closed basins (tosegment=0) - IF ( segtype==1 ) THEN - Flow_headwater = Flow_headwater + segout - ELSEIF ( segtype==2 ) THEN - Flow_to_lakes = Flow_to_lakes + segout - ELSEIF ( segtype==3 ) THEN - Flow_replacement = Flow_replacement + segout - ELSEIF ( segtype==4 ) THEN - Flow_in_nation = Flow_in_nation + segout - ELSEIF ( segtype==5 ) THEN - Flow_out_NHM = Flow_out_NHM + segout - ELSEIF ( segtype==6 ) THEN - Flow_in_region = Flow_in_region + segout - ELSEIF ( segtype==7 ) THEN - Flow_out_region = Flow_out_region + segout - ELSEIF ( segtype==8 ) THEN - Flow_to_ocean = Flow_to_ocean + segout - ELSEIF ( segtype==9 ) THEN - Flow_terminus = Flow_terminus + segout - ELSEIF ( segtype==10 ) THEN - Flow_in_great_lakes = Flow_in_great_lakes + segout - ELSEIF ( segtype==11 ) THEN - Flow_to_great_lakes = Flow_to_great_lakes + segout - ENDIF - IF ( toseg==0 ) THEN - Flow_out = Flow_out + segout - ELSE - Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + segout - ENDIF - ENDDO - - area_fac = Cfs_conv*Active_area - Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows - Basin_cfs = Flow_out - Basin_stflow_out = Basin_cfs/area_fac - Basin_cms = Basin_cfs*CFS2CMS_CONV - Basin_sroff_cfs = Basin_sroff*area_fac - Basin_ssflow_cfs = Basin_ssflow*area_fac - Basin_gwflow_cfs = Basin_gwflow*area_fac - ELSEIF ( Process(:4)=='decl' ) THEN - Version_strmflow = 'strmflow_in_out.f90 2017-03-20 16:41:00Z' - CALL print_module(Version_strmflow, 'Streamflow Routing ', 90) - ENDIF - - END FUNCTION strmflow_in_out From ad3dd35773e0a285f17ccaf8c77fd7c521257822 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Mon, 29 Jul 2019 21:36:37 -0600 Subject: [PATCH 23/47] New CFGI modified for depth and energy budget --- prms/snowcompCfgim.f90 | 3027 ++++++++++++++++++++++++++++++++++++++++ prms/soilzoneCfgim.f90 | 1875 +++++++++++++++++++++++++ prms/srunoffCfgim.f90 | 1686 ++++++++++++++++++++++ 3 files changed, 6588 insertions(+) create mode 100644 prms/snowcompCfgim.f90 create mode 100644 prms/soilzoneCfgim.f90 create mode 100644 prms/srunoffCfgim.f90 diff --git a/prms/snowcompCfgim.f90 b/prms/snowcompCfgim.f90 new file mode 100644 index 00000000..87149d2f --- /dev/null +++ b/prms/snowcompCfgim.f90 @@ -0,0 +1,3027 @@ +!*********************************************************************** +! Initiates development of a snowpack and simulates snow accumulation +! and depletion processes using an energy-budget approach +! +! Modified glacier melt and glacier basal melt +! These modifications includes albedo info for saving between runs 2/00 +!*********************************************************************** + +! PRMS_SNOW module for defining stateful variables + + MODULE PRMS_SNOW + + IMPLICIT NONE + !**************************************************************** + ! Local Constants + + INTEGER, PARAMETER :: MAXALB = 15 + + !**************************************************************** + ! Local Variables + + REAL, PARAMETER :: PI = 3.1415927 + INTEGER, SAVE :: Active_glacier, Active_freezing + INTEGER, SAVE, ALLOCATABLE :: Int_alb(:) + DOUBLE PRECISION, SAVE :: Deninv, Denmaxinv, Settle_const_dble + ! REAL, SAVE :: Setden, Set1 + REAL, SAVE :: Acum(MAXALB), Amlt(MAXALB) + REAL, SAVE, ALLOCATABLE :: Snowcov_areasv(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Scrv(:), Pss(:), Pksv(:), Pst(:) + REAL, SAVE, ALLOCATABLE :: Salb(:), Slst(:) + CHARACTER(LEN=8), SAVE :: MODNAME + + !**************************************************************** + ! Declared Variables + + INTEGER :: Yrdays5 + INTEGER, SAVE, ALLOCATABLE :: Pptmix_nopack(:), Lst(:) + INTEGER, SAVE, ALLOCATABLE :: Iasw(:), Iso(:), Mso(:), Lso(:) + DOUBLE PRECISION, SAVE :: Basin_snowmelt, Basin_pweqv, Basin_tcal + DOUBLE PRECISION, SAVE :: Basin_snowcov, Basin_snowevap + DOUBLE PRECISION, SAVE :: Basin_snowdepth, Basin_pk_precip + REAL, SAVE, ALLOCATABLE :: Snowmelt(:), Snow_evap(:) + REAL, SAVE, ALLOCATABLE :: Albedo(:), Pk_temp(:), Pk_den(:) + REAL, SAVE, ALLOCATABLE :: Pk_def(:), Pk_ice(:), Freeh2o(:) + REAL, SAVE, ALLOCATABLE :: Snowcov_area(:), Tcal(:) + REAL, SAVE, ALLOCATABLE :: Snsv(:), Pk_precip(:), Frac_swe(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Pk_depth(:), Pkwater_ante(:), Ai(:) +! Frozen ground variables + REAL, SAVE, ALLOCATABLE :: Tcal_nosnow(:), Land_albedo(:) +! Glacier variables + DOUBLE PRECISION, SAVE :: Basin_glacrevap, Basin_snowicecov + DOUBLE PRECISION, SAVE :: Basin_glacrb_melt + REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_capm(:), Prev_ann_tempc(:) + REAL, SAVE, ALLOCATABLE :: Glacrmelt(:), Glacr_evap(:), Glacr_albedo(:), Glacr_pk_den(:) + REAL, SAVE, ALLOCATABLE :: Glacr_pk_ice(:), Glacr_freeh2o(:), Glacrcov_area(:) + REAL, SAVE, ALLOCATABLE :: Glacrb_melt(:), Glacr_pk_def(:), Glacr_pk_temp(:), Ann_tempc(:) + REAL, SAVE, ALLOCATABLE :: Glacr_air_5avtemp1(:), Glacr_air_deltemp(:), Glacr_air_5avtemp(:) + REAL, SAVE, ALLOCATABLE :: Glacr_5avsnow1(:), Glacr_5avsnow(:),Glacr_delsnow(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pkwater_ante(:), Glacr_pkwater_equiv(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pk_depth(:), Glacr_pss(:), Glacr_pst(:) + !**************************************************************** + ! Declared Parameters + + INTEGER, SAVE, ALLOCATABLE :: Melt_look(:), Melt_force(:), Tstorm_mo(:, :) + INTEGER, SAVE, ALLOCATABLE :: Hru_deplcrv(:) + REAL, SAVE :: Albset_rnm, Albset_rna, Albset_snm, Albset_sna + REAL, SAVE, ALLOCATABLE :: Emis_noppt(:), Freeh2o_cap(:), Cecn_coef(:, :) + REAL, SAVE :: Den_init, Settle_const, Den_max + REAL, SAVE, ALLOCATABLE :: Rad_trncf(:), Snarea_thresh(:), Snowpack_init(:) + REAL, SAVE, ALLOCATABLE :: Snarea_curve(:, :) +! Glacier parameters + REAL, SAVE, ALLOCATABLE :: Glacr_layer(:), Albedo_coef(:), Albedo_ice(:) + REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_cap(:), Glacier_frac_init(:), Glrette_frac_init(:) + + END MODULE PRMS_SNOW + +!*********************************************************************** +! Main snowcomp routine +!*********************************************************************** + INTEGER FUNCTION snowcomp() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: snodecl, snoinit, snorun + EXTERNAL :: snowcomp_restart +!*********************************************************************** + snowcomp = 0 + + IF ( Process(:3)=='run' ) THEN + snowcomp = snorun() + ELSEIF ( Process(:4)=='decl' ) THEN + snowcomp = snodecl() + ELSEIF ( Process(:4)=='init' ) THEN + snowcomp = snoinit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL snowcomp_restart(0) + ENDIF + + END FUNCTION snowcomp + +!*********************************************************************** +! snodecl - set up parameters for snowmelt computations +! Declared Parameters +! den_init, settle_const, den_max, melt_look +! melt_force, rad_trncf, hru_deplcrv, snarea_curve, snarea_thresh +! albset_rnm, albset_rna, albset_snm, albset_sna, potet_sublim +! emis_noppt, cecn_coef, freeh2o_cap, tstorm_mo, tmax_allsnow +! hru_area, cov_type, covden_win +! glacr_freeh2o_cap, glacr_layer +!*********************************************************************** + INTEGER FUNCTION snodecl() + USE PRMS_SNOW + USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag, Model, & + & Frozen_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80) :: Version_snowcomp +!*********************************************************************** + snodecl = 0 + + Version_snowcomp = 'snowcomp.f90 2018-05-04 09:41:00Z' + CALL print_module(Version_snowcomp, 'Snow Dynamics ', 90) + MODNAME = 'snowcomp' + +! declare variables + ALLOCATE ( Scrv(Nhru) ) + IF ( declvar(MODNAME, 'scrv', 'nhru', Nhru, 'double', & + & 'Snowpack water equivalent plus a portion of new snow on each HRU', & + & 'inches', Scrv)/=0 ) CALL read_error(3, 'scrv') + + ALLOCATE ( Pksv(Nhru) ) + IF ( declvar(MODNAME, 'pksv', 'nhru', Nhru, 'double', & + & 'Snowpack water equivalent when there is new snow and in melt phase;'// & + & ' used to interpolate between depletion curve and 100 percent on each HRU', & + & 'inches', Pksv)/=0 ) CALL read_error(3, 'pksv') + + ALLOCATE ( Snowcov_areasv(Nhru) ) + IF ( declvar(MODNAME, 'snowcov_areasv', 'nhru', Nhru, 'real', & + & 'Snow cover fraction when there is new snow and in melt phase;'// & + & ' used to interpolate between depletion curve and 100 percent on each HRU', & + & 'decimal fraction', Snowcov_areasv)/=0 ) CALL read_error(3, 'snowcov_areasv') + + ALLOCATE ( Salb(Nhru) ) + IF ( declvar(MODNAME, 'salb', 'nhru', Nhru, 'real', & + & 'Days since last new snow to reset albedo for each HRU', & + & 'days', Salb)/=0 ) CALL read_error(3, 'salb') + + ALLOCATE ( Slst(Nhru) ) + IF ( declvar(MODNAME, 'slst', 'nhru', Nhru, 'real', & + & 'Days since last new snow for each HRU', & + & 'days', Slst)/=0 ) CALL read_error(3, 'slst') + + ALLOCATE ( Int_alb(Nhru) ) + IF ( declvar(MODNAME, 'int_alb', 'nhru', Nhru, 'integer', & + & 'Flag to indicate (1: accumulation season curve; 2: use of the melt season curve)', & + & 'none', Int_alb)/=0 ) CALL read_error(3, 'int_alb') + +! Glacier declares + IF ( Glacier_flag==1 .OR. Frozen_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Ann_tempc(Nhru) ) + IF ( declvar(MODNAME, 'ann_tempc', 'nhru', Nhru, 'real', & + & 'Current average year air temperature over HRU', & + & 'degrees Celsius', Ann_tempc)/=0 ) CALL read_error(3, 'ann_tempc') + ALLOCATE ( Prev_ann_tempc(Nhru) ) + ENDIF + + IF ( Glacier_flag==1 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'yrdays5', 'one', 1, 'integer', & + & 'Number of days since last 5 year mark', & + & 'none', Yrdays5)/=0 ) CALL read_error(3, 'yrdays5') + + ALLOCATE ( Glacr_freeh2o_capm(Nhru) ) + IF ( declvar(MODNAME, 'glacr_freeh2o_capm', 'nhru', Nhru, 'real', & + & 'Free-water holding capacity of glacier ice, changes to 0 if active layer melts', & + & 'decimal fraction', Glacr_freeh2o_capm)/=0 ) CALL read_error(3, 'glacr_freeh2o_capm') + + ALLOCATE ( Glacrb_melt(Nhru) ) + IF ( declvar(MODNAME, 'glacrb_melt', 'nhru', Nhru, 'real', & + 'Glacier basal melt, goes to soil', & + 'inches/day', Glacrb_melt)/=0 ) CALL read_error(3, 'glacrb_melt') + + ALLOCATE ( Glacr_air_5avtemp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_5avtemp', 'nhru', Nhru, 'real', & + & 'Current 5-yr average summer (June July Aug) air temperature over glacier or glrette HRU', & + & 'degrees Celsius', Glacr_air_5avtemp)/=0 ) CALL read_error(3, 'glacr_air_5avtemp') + + ALLOCATE ( Glacr_air_5avtemp1(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_5avtemp1', 'nhru', Nhru, 'real', & + & 'First 5-yr average summer temperature over glacier or glrette HRU', & + & 'degrees Celsius', Glacr_air_5avtemp1)/=0 ) CALL read_error(3, 'glacr_air_5avtemp1') + + ALLOCATE ( Glacr_air_deltemp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_deltemp', 'nhru', Nhru, 'real', & + & 'Change in 5-yr average air temperature over glacier or glrette HRU from first', & + & 'degrees Celsius', Glacr_air_deltemp)/=0 ) CALL read_error(3, 'glacr_air_deltemp') + + ALLOCATE ( Glacr_5avsnow(Nhru) ) + IF ( declvar(MODNAME, 'glacr_5avsnow', 'nhru', Nhru, 'real', & + & 'Current 5-yr average snow over glacier or glrette HRU', & + & 'inches/yr', Glacr_5avsnow)/=0 ) CALL read_error(3, 'glacr_5avsnow') + + ALLOCATE ( Glacr_5avsnow1(Nhru) ) + IF ( declvar(MODNAME, 'glacr_5avsnow1', 'nhru', Nhru, 'real', & + & 'First 5-yr average snow over glacier or glrette HRU', & + & 'inches/yr', Glacr_5avsnow1)/=0 ) CALL read_error(3, 'glacr_5avsnow1') + + ALLOCATE ( Glacr_delsnow(Nhru) ) + IF ( declvar(MODNAME, 'glacr_delsnow', 'nhru', Nhru, 'real', & + & 'Change in 5-yr average snow over glacier or glrette HRU from first', & + & 'inches/yr', Glacr_delsnow)/=0 ) CALL read_error(3, 'glacr_delsnow') + + ALLOCATE ( Glacr_pk_temp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_temp', 'nhru', Nhru, 'real', & + & 'Temperature of the glacier on each HRU', & + & 'degrees Celsius', Glacr_pk_temp)/=0 ) CALL read_error(3, 'glacr_pk_temp') + + ALLOCATE ( Glacr_pk_def(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_def', 'nhru', Nhru, 'real', & + & 'Heat deficit, amount of heat necessary to make the glacier snowpack isothermal at 0 degrees Celsius', & + & 'Langleys', Glacr_pk_def)/=0 ) CALL read_error(3, 'glacr_pk_def') + + ALLOCATE ( Glacr_pk_den(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_den', 'nhru', Nhru, 'real', & + & 'Density of the icepack on each glacier HRU, hard-coded to equal 0.917', & + & 'gm/cm3', Glacr_pk_den)/=0 ) CALL read_error(3, 'glacr_pk_den') + + ALLOCATE ( Glacr_albedo(Nhru) ) + IF ( declvar(MODNAME, 'glacr_albedo', 'nhru', Nhru, 'real', & + & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier HRU', & + & 'decimal fraction', Glacr_albedo)/=0 ) CALL read_error(3, 'glacr_albedo') + + ALLOCATE ( Glacr_evap(Nhru) ) + IF ( declvar(MODNAME, 'glacr_evap', 'nhru', Nhru, 'real', & + & 'Evaporation and sublimation from icepack on each glacier HRU', & + & 'inches', Glacr_evap)/=0 ) CALL read_error(3, 'glacr_evap') + + ALLOCATE ( Glacrmelt(Nhru) ) + IF ( declvar(MODNAME, 'glacrmelt', 'nhru', Nhru, 'real', & + & 'Melt from icepack on each glacier HRU, includes rain water that does not absorb', & + & 'inches', Glacrmelt)/=0 ) CALL read_error(3, 'glacrmelt') + + ALLOCATE ( Glacr_pkwater_equiv(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pkwater_equiv', 'nhru', Nhru, 'double', & + & 'Icepack water equivalent on each glacier HRU', & + & 'inches', Glacr_pkwater_equiv)/=0 ) CALL read_error(3, 'glacr_pkwater_equiv') + + ALLOCATE ( Glacr_pkwater_ante(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pkwater_ante', 'nhru', Nhru, 'double', & + & 'Antecedent icepack water equivalent on each glacier HRU', & + & 'inches', Glacr_pkwater_ante)/=0 ) CALL read_error(3, 'glacr_pkwater_ante') + + ALLOCATE ( Glacrcov_area(Nhru) ) + IF ( declvar(MODNAME, 'glacrcov_area', 'nhru', Nhru, 'real', & + & 'Ice-covered area on each glacier HRU or HRU with glacierette at start of step', & + & 'decimal fraction', Glacrcov_area)/=0 ) CALL read_error(3, 'glacrcov_area') + + ALLOCATE ( Glacr_pk_ice(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_ice', 'nhru', Nhru, 'real', & + & 'Storage of frozen water in the icepack on each glacier HRU', & + & 'inches', Glacr_pk_ice)/=0 ) CALL read_error(3, 'glacr_pk_ice') + + ALLOCATE ( Glacr_freeh2o(Nhru) ) + IF ( declvar(MODNAME, 'glacr_freeh2o', 'nhru', Nhru, 'real', & + & 'Storage of free liquid water in the icepack on each glacier HRU', & + & 'inches', Glacr_freeh2o)/=0 ) CALL read_error(3, 'glacr_freeh2o') + + ALLOCATE ( Glacr_pk_depth(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_depth', 'nhru', Nhru, 'double', & + & 'Depth of icepack on each glacier HRU, make essentially infinite', & + & 'inches', Glacr_pk_depth)/=0 ) CALL read_error(3, 'glacr_pk_depth') + + ALLOCATE ( Glacr_pss(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pss', 'nhru', Nhru, 'double', & + & 'Previous glacier pack water equivalent plus new ice', & + & 'inches', Glacr_pss)/=0 ) CALL read_error(3, 'glacr_pss') + + ALLOCATE ( Glacr_pst(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pst', 'nhru', Nhru, 'double', & + & 'While a icepack exists, glacr_pst tracks the maximum ice water equivalent of that icepack', & + & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') + + IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & + & 'Basin area-weighted average snow and glacier and glrette covered area', & + & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') + + ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) + IF ( declparam(MODNAME, 'glacr_freeh2o_cap', 'nhru', 'real', & + & '0.002', '0.0', '0.01', & + & 'Free-water holding capacity of glacier ice', & + & 'Free-water holding capacity of glacier ice expressed as a' // & + & ' decimal fraction of the frozen water content of the glacier ice (glacr_pk_ice)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacr_freeh2o_cap') + + ALLOCATE ( Glacr_layer(Nhru) ) + IF ( declparam(MODNAME, 'glacr_layer', 'nhru', 'real', & + & '3.94', '0.0', '590.6', & + & 'Active layer on glacier', & + & 'Active layer is 0 to 15 m (590.6 inches) thick at start of year, when' // & + & ' melts will set daily glacr_pk_temp to 0', & + & 'inches')/=0 ) CALL read_error(1, 'glacr_layer') + + IF ( Init_vars_from_file==0 ) THEN + ALLOCATE ( Glacier_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') + + ALLOCATE ( Glrette_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glrette_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glrette_frac_init') + + ENDIF + ENDIF + + IF ( Frozen_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Tcal_nosnow(Nhru) ) + IF ( declvar(MODNAME, 'tcal_nosnow', 'nhru', Nhru, 'real', & + & 'Net energy balance on each HRU without snow or glacier', & + & 'Langleys', Tcal_nosnow)/=0 ) CALL read_error(3, 'tcal_nosnow') + + ALLOCATE ( Land_albedo(Nhru) ) + IF ( declvar(MODNAME, 'land_albedo', 'nhru', Nhru, 'real', & + & 'Land surface albedo or the fraction of radiation reflected from the'// & + & ' land surface for each HRU', & + & 'decimal fraction', land_albedo)/=0 ) CALL read_error(3, 'land_albedo') + + ENDIF + + + IF ( declvar(MODNAME, 'basin_snowdepth', 'one', 1, 'double', & + & 'Basin area-weighted average snow depth', & + & 'inches', Basin_snowdepth)/=0 ) CALL read_error(3, 'basin_snowdepth') + + ALLOCATE ( Pk_precip(Nhru) ) + IF ( declvar(MODNAME, 'pk_precip', 'nhru', Nhru, 'real', & + & 'Precipitation added to snowpack for each HRU', & + & 'inches', Pk_precip)/=0 ) CALL read_error(3, 'pk_precip') + + IF ( declvar(MODNAME, 'basin_pk_precip', 'one', 1, 'double', & + & 'Basin area-weighted average precipitation added to snowpack', & + & 'inches', Basin_pk_precip)/=0 ) CALL read_error(3, 'basin_pk_precip') + + ALLOCATE ( Albedo(Nhru) ) + IF ( declvar(MODNAME, 'albedo', 'nhru', Nhru, 'real', & + & 'Snow surface albedo or the fraction of radiation reflected from the'// & + & ' snowpack surface for each HRU', & + & 'decimal fraction', Albedo)/=0 ) CALL read_error(3, 'albedo') + + ALLOCATE ( Pk_temp(Nhru) ) + IF ( declvar(MODNAME, 'pk_temp', 'nhru', Nhru, 'real', & + & 'Temperature of the snowpack on each HRU', & + & 'degrees Celsius', Pk_temp)/=0 ) CALL read_error(3, 'pk_temp') + + ALLOCATE ( Pk_den(Nhru) ) + IF ( declvar(MODNAME, 'pk_den', 'nhru', Nhru, 'real', & + & 'Density of the snowpack on each HRU', & + & 'gm/cm3', Pk_den)/=0 ) CALL read_error(3, 'pk_den') + + IF ( declvar(MODNAME, 'basin_tcal', 'one', 1, 'double', & + & 'Basin area-weighted average net snowpack energy balance', & + & 'Langleys', Basin_tcal)/=0 ) CALL read_error(3, 'basin_tcal') + + ALLOCATE ( Tcal(Nhru) ) + IF ( declvar(MODNAME, 'tcal', 'nhru', Nhru, 'real', & + & 'Net snowpack energy balance on each HRU', & + & 'Langleys', Tcal)/=0 ) CALL read_error(3, 'tcal') + + ALLOCATE ( Snow_evap(Nhru) ) + IF ( declvar(MODNAME, 'snow_evap', 'nhru', Nhru, 'real', & + & 'Evaporation and sublimation from snowpack on each HRU', & + & 'inches', Snow_evap)/=0 ) CALL read_error(3, 'snow_evap') + + ALLOCATE ( Snowmelt(Nhru) ) + IF ( declvar(MODNAME, 'snowmelt', 'nhru', Nhru, 'real', & + & 'Snowmelt from snowpack on each HRU (not including snow on glacier)', & + & 'inches', Snowmelt)/=0 ) CALL read_error(3, 'snowmelt') + + IF ( declvar(MODNAME, 'basin_snowmelt', 'one', 1, 'double', & + & 'Basin area-weighted average snowmelt (not on including snow on glacier)', & + & 'inches', Basin_snowmelt)/=0 ) CALL read_error(3, 'basin_snowmelt') + + IF ( declvar(MODNAME, 'basin_pweqv', 'one', 1, 'double', & + & 'Basin area-weighted average snowpack water equivalent not including glacier', & + & 'inches', Basin_pweqv)/=0 ) CALL read_error(3, 'basin_pweqv') + + ALLOCATE ( Pkwater_ante(Nhru) ) + IF ( declvar(MODNAME, 'pkwater_ante', 'nhru', Nhru, 'double', & + & 'Antecedent snowpack water equivalent on each HRU', & + & 'inches', Pkwater_ante)/=0 ) CALL read_error(3, 'pkwater_ante') + + ALLOCATE ( Snowcov_area(Nhru) ) + IF ( declvar(MODNAME, 'snowcov_area', 'nhru', Nhru, 'real', & + & 'Snow-covered area on each HRU prior to melt and sublimation unless snowpack depleted', & + & 'decimal fraction', Snowcov_area)/=0 ) CALL read_error(3, 'snowcov_area') + + IF ( declvar(MODNAME, 'basin_snowevap', 'one', 1, 'double', & + & 'Basin area-weighted average evaporation and sublimation not including glacier', & + & 'inches', Basin_snowevap)/=0 ) CALL read_error(3, 'basin_snowevap') + + IF ( declvar(MODNAME, 'basin_snowcov', 'one', 1, 'double', & + & 'Basin area-weighted average snow-covered area', & + & 'decimal fraction', Basin_snowcov)/=0 ) CALL read_error(3, 'basin_snowcov') + + IF ( declvar(MODNAME, 'basin_glacrb_melt', 'one', 1, 'double', & + & 'Basin area-weighted average basal melt of glacier, goes to soil', & + & 'inches', Basin_glacrb_melt)/=0 ) CALL read_error(3, 'basin_glacrb_melt') + + IF ( declvar(MODNAME, 'basin_glacrevap', 'one', 1, 'double', & + & 'Basin area-weighted average glacier ice evaporation and sublimation', & + & 'inches', Basin_glacrevap)/=0 ) CALL read_error(3, 'basin_glacrevap') + + !rpayn commented + ALLOCATE ( Pptmix_nopack(Nhru) ) + IF ( declvar(MODNAME, 'pptmix_nopack', 'nhru', Nhru, 'integer', & + & 'Flag indicating that a mixed precipitation event has'// & + & ' occurred with no snowpack present on an HRU (1), otherwise (0)', & + & 'none', Pptmix_nopack)/=0 ) CALL read_error(3, 'pptmix_nopack') + + !rpayn commented + ALLOCATE ( Iasw(Nhru) ) + IF ( declvar(MODNAME, 'iasw', 'nhru', Nhru, 'integer', & + & 'Flag indicating that snow covered area is'// & + & ' interpolated between previous location on curve and'// & + & ' maximum (1), or is on the defined curve (0)', & + & 'none', Iasw)/=0 ) CALL read_error(3, 'iasw') + + !rpayn commented + ALLOCATE ( Iso(Nhru) ) + IF ( declvar(MODNAME, 'iso', 'nhru', Nhru, 'integer', & + & 'Flag to indicate if time is before (1) or after (2)'// & + & ' the day to force melt season (melt_force)', & + & 'none', Iso)/=0 ) CALL read_error(3, 'iso') + + !rpayn commented + ALLOCATE ( Mso(Nhru) ) + IF ( declvar(MODNAME, 'mso', 'nhru', Nhru, 'integer', & + & 'Flag to indicate if time is before (1) or after (2)'// & + & ' the first potential day for melt season (melt_look)', & + & 'none', Mso)/=0 ) CALL read_error(3, 'mso') + + !rpayn commented + ALLOCATE ( Lso(Nhru) ) + IF ( declvar(MODNAME, 'lso', 'nhru', Nhru, 'integer', & + & 'Counter for tracking the number of days the snowpack'// & + & ' is at or above 0 degrees Celsius', & + & 'number of iterations', Lso)/=0 ) CALL read_error(3, 'lso') + + !rpayn commented + ALLOCATE ( Lst(Nhru) ) + IF ( declvar(MODNAME, 'lst', 'nhru', Nhru, 'integer', & + & 'Flag indicating whether there was new snow that'// & + & ' was insufficient to reset the albedo curve (1)'// & + & ' (albset_snm or albset_sna), otherwise (0)', & + & 'none', Lst)/=0 ) CALL read_error(3, 'lst') + + !rpayn commented + ALLOCATE ( Pk_def(Nhru) ) + IF ( declvar(MODNAME, 'pk_def', 'nhru', Nhru, 'real', & + & 'Heat deficit, amount of heat necessary to make'// & + & ' the snowpack isothermal at 0 degrees Celsius', & + & 'Langleys', Pk_def)/=0 ) CALL read_error(3, 'pk_def') + + !rpayn commented + ALLOCATE ( Pk_ice(Nhru) ) + IF ( declvar(MODNAME, 'pk_ice', 'nhru', Nhru, 'real', & + & 'Storage of frozen water in the snowpack on each HRU', & + & 'inches', Pk_ice)/=0 ) CALL read_error(3, 'pk_ice') + + !rpayn commented + ALLOCATE ( Freeh2o(Nhru) ) + IF ( declvar(MODNAME, 'freeh2o', 'nhru', Nhru, 'real', & + & 'Storage of free liquid water in the snowpack on each HRU', & + & 'inches', Freeh2o)/=0 ) CALL read_error(3, 'freeh2o') + + !rpayn commented + ALLOCATE ( Pk_depth(Nhru) ) + IF ( declvar(MODNAME, 'pk_depth', 'nhru', Nhru, 'double', & + & 'Depth of snowpack on each HRU', & + & 'inches', Pk_depth)/=0 ) CALL read_error(3, 'pk_depth') + + !rpayn commented + ALLOCATE ( Pss(Nhru) ) + IF ( declvar(MODNAME, 'pss', 'nhru', Nhru, 'double', & + & 'Previous snowpack water equivalent plus new snow', & + & 'inches', Pss)/=0 ) CALL read_error(3, 'pss') + + !rpayn commented + ALLOCATE ( Pst(Nhru) ) + IF ( declvar(MODNAME, 'pst', 'nhru', Nhru, 'double', & + & 'While a snowpack exists, pst tracks the maximum'// & + & ' snow water equivalent of that snowpack', & + & 'inches', Pst)/=0 ) CALL read_error(3, 'pst') + + !rpayn commented + ALLOCATE ( Snsv(Nhru) ) + IF ( declvar(MODNAME, 'snsv', 'nhru', Nhru, 'real', & + & 'Tracks the cumulative amount of new snow until'// & + & ' there is enough to reset the albedo curve (albset_snm or albset_sna)', & + & 'inches', Snsv)/=0 ) CALL read_error(3, 'snsv') + + ALLOCATE ( Ai(Nhru) ) + IF ( declvar(MODNAME, 'ai', 'nhru', Nhru, 'double', & + & 'Maximum snowpack for each HRU', & + & 'inches', Ai)/=0 ) CALL read_error(3, 'ai') + + ALLOCATE ( Frac_swe(Nhru) ) + IF ( declvar(MODNAME, 'frac_swe', 'nhru', Nhru, 'real', & + & 'Fraction of maximum snow-water equivalent (snarea_thresh) on each HRU', & + & 'decimal fraction', Frac_swe)/=0 ) CALL read_error(3, 'frac_swe') + +! declare parameters + IF ( Glacier_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Albedo_coef(Nhru) ) + IF ( declparam(MODNAME, 'albedo_coef', 'nhru', 'real', & + & '0.137', '0.1', '0.3', & + & 'Coefficient in calculation of ice albedo', & + & 'Coefficient in calculation of ice albedo', & + & 'none')/=0 ) CALL read_error(1, 'albedo_coef') + + ALLOCATE ( Albedo_ice(Nhru) ) + IF ( declparam(MODNAME, 'albedo_ice', 'nhru', 'real', & + & '0.344', '0.2', '0.6', & + & 'Ice albedo 300 meters below ELA', & + & 'Ice albedo 300 meters below ELA', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo_ice') + ENDIF + + IF ( declparam(MODNAME, 'den_init', 'one', 'real', & + & '0.10', '0.01', '0.5', & + & 'Initial density of new-fallen snow', & + & 'Initial density of new-fallen snow', & + & 'gm/cm3')/=0 ) CALL read_error(1, 'den_init') + + IF ( declparam(MODNAME, 'settle_const', 'one', 'real', & + & '0.10', '0.01', '0.5', & + & 'Snowpack settlement time constant', & + & 'Snowpack settlement time constant', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'settle_const') + + IF ( declparam(MODNAME, 'den_max', 'one', 'real', & + & '0.6', '0.1', '0.8', & + & 'Average maximum snowpack density', & + & 'Average maximum snowpack density', & + & 'gm/cm3')/=0 ) CALL read_error(1, 'den_max') + + ALLOCATE ( Melt_look(Nhru) ) + IF ( declparam(MODNAME, 'melt_look', 'nhru', 'integer', & + & '90', '1', '366', & + & 'Julian date to start looking for spring snowmelt for each HRU', & + & 'Julian date to start looking for spring snowmelt stage for each HRU;'// & + & ' varies with region depending on length of time that'// & + & ' permanent snowpack exists', & + & 'Julian day')/=0 ) CALL read_error(1, 'melt_look') + + ALLOCATE ( Melt_force(Nhru) ) + IF ( declparam(MODNAME, 'melt_force', 'nhru', 'integer', & + & '140', '1', '366', & + & 'Julian date to force snowpack to spring snowmelt stage for each HRU', & + & 'Julian date to force snowpack to spring snowmelt stage for each HRU;'// & + & ' varies with region depending on length of time that'// & + & ' permanent snowpack exists', & + & 'Julian day')/=0 ) CALL read_error(1, 'melt_force') + + ALLOCATE ( Rad_trncf(Nhru) ) + IF ( declparam(MODNAME, 'rad_trncf', 'nhru', 'real', & + & '0.5', '0.0', '1.0', & + & 'Solar radiation transmission coefficient', & + & 'Transmission coefficient for short-wave radiation through'// & + & ' the winter vegetation canopy', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'rad_trncf') + + ALLOCATE ( Hru_deplcrv(Nhru) ) + IF ( declparam(MODNAME, 'hru_deplcrv', 'nhru', 'integer', & + & '1', 'bounded', 'ndepl', & + & 'Index number for snowpack areal depletion curve', & + & 'Index number for the snowpack areal depletion curve associated with each HRU', & + & 'none')/=0 ) CALL read_error(1, 'hru_deplcrv') + + ALLOCATE ( Snarea_curve(11, Ndepl) ) + IF ( declparam(MODNAME, 'snarea_curve', 'ndeplval', 'real', & + & '1.0', '0.0', '1.0', & + & 'Snow area depletion curve values', & + & 'Snow area depletion curve values, 11 values for each'// & + & ' curve (0.0 to 1.0 in 0.1 increments)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'snarea_curve') + + ALLOCATE ( Snarea_thresh(Nhru) ) + IF ( declparam(MODNAME, 'snarea_thresh', 'nhru', 'real', & + & '50.0', '0.0', '200.0', & + & 'Maximum threshold water equivalent for snow depletion', & + & 'Maximum threshold snowpack water equivalent below'// & + & ' which the snow-covered-area curve is applied', & + & 'inches')/=0 ) CALL read_error(1, 'snarea_thresh') + + IF ( declparam(MODNAME, 'albset_rnm', 'one', 'real', & + & '0.6', '0.4', '1.0', & + & 'Albedo reset - rain, melt stage', & + & 'Fraction of rain in a mixed precipitation event'// & + & ' above which the snow albedo is not reset; applied during'// & + & ' the snowpack melt stage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'albset_rnm') + + IF ( declparam(MODNAME, 'albset_rna', 'one', 'real', & + & '0.8', '0.5', '1.0', & + & 'Albedo reset - rain, accumulation stage', & + & 'Fraction of rain in a mixed precipitation event'// & + & ' above which the snow albedo is not reset; applied during'// & + & ' the snowpack accumulation stage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'albset_rna') + + IF ( declparam(MODNAME, 'albset_snm', 'one', 'real', & + & '0.2', '0.1', '1.0', & + & 'Albedo reset - snow, melt stage', & + & 'Minimum snowfall, in water equivalent, needed to reset'// & + & ' snow albedo during the snowpack melt stage', & + & 'inches')/=0 ) CALL read_error(1, 'albset_snm') + + IF ( declparam(MODNAME, 'albset_sna', 'one', 'real', & + & '0.05', '0.01', '1.0', & + & 'Albedo reset - snow, accumulation stage', & + & 'Minimum snowfall, in water equivalent, needed to reset'// & + & ' snow albedo during the snowpack accumulation stage', & + & 'inches')/=0 ) CALL read_error(1, 'albset_sna') + + ALLOCATE ( Emis_noppt(Nhru) ) + IF ( declparam(MODNAME, 'emis_noppt', 'nhru', 'real', & + & '0.757', '0.757', '1.0', & + & 'Emissivity of air on days without precipitation for each HRU', & + & 'Average emissivity of air on days without precipitation for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'emis_noppt') + + ALLOCATE ( Cecn_coef(Nhru,12) ) + IF ( declparam(MODNAME, 'cecn_coef', 'nhru,nmonths', 'real', & + & '5.0', '0.02', '20.0', & + & 'Monthly convection condensation energy coefficient for each HRU', & + & 'Monthly (January to December) convection condensation energy coefficient for each HRU', & + & 'calories per degree Celsius above 0')/=0 ) CALL read_error(1, 'cecn_coef') + + ALLOCATE ( Freeh2o_cap(Nhru) ) + IF ( declparam(MODNAME, 'freeh2o_cap', 'nhru', 'real', & + & '0.05', '0.01', '0.2', & + & 'Free-water holding capacity of snowpack for each HRU', & + & 'Free-water holding capacity of snowpack for each HRU, expressed as a'// & + & ' decimal fraction of the frozen water content of the snowpack (pk_ice)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'freeh2o_cap') + + ALLOCATE ( Tstorm_mo(Nhru,12) ) + IF ( declparam(MODNAME, 'tstorm_mo', 'nhru,nmonths', 'integer', & + & '0', '0', '1', & + & 'Set to 1 if thunderstorms prevalent during month for each HRU', & + & 'Monthly flag (January to December) for prevalent storm'// & + & ' type for each HRU (0=frontal storms; 1=convective storms)', & + & 'none')/=0 ) CALL read_error(1, 'tstorm_mo') + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==3 ) THEN + ALLOCATE ( Snowpack_init(Nhru) ) + IF ( declparam(MODNAME, 'snowpack_init', 'nhru', 'real', & + & '0.0', '0.0', '5000.0', & + & 'Initial snowpack water equivalent in each HRU', & + & 'Storage of snowpack in each HRU at the beginning of a simulation', & + & 'inches')/=0 ) CALL read_error(1, 'snowpack_init') + ENDIF + + END FUNCTION snodecl + +!*********************************************************************** +! snoinit - Initialize snowcomp module - get parameter values, +! compute initial values +!*********************************************************************** + INTEGER FUNCTION snoinit() + USE PRMS_SNOW + USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag, Frozen_flag + USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_route_order, Active_hrus, Hru_area_dble, & + & FEET2METERS, Elev_units, Hru_type +! USE PRMS_BASIN, ONLY: Hru_elev_feet + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Glrette_frac, Alt_above_ela + IMPLICIT NONE +! Functions + INTRINSIC :: DBLE, ATAN, SNGL + INTEGER, EXTERNAL :: getparam + EXTERNAL :: read_error, snowcomp_restart, sca_deplcrv, glacr_states_to_zero +! Local Variables + INTEGER :: i, j +! Save Variables + REAL, SAVE :: acum_init(MAXALB), amlt_init(MAXALB) + DATA acum_init/.80, .77, .75, .72, .70, .69, .68, .67, .66, .65, .64, .63, .62, .61, .60/ + DATA amlt_init/.72, .65, .60, .58, .56, .54, .52, .50, .48, .46, .44, .43, .42, .41, .40/ +!*********************************************************************** + snoinit = 0 + + IF ( Init_vars_from_file>0 ) CALL snowcomp_restart(1) + + IF ( Glacier_flag==1 ) THEN + IF ( getparam(MODNAME, 'glacr_freeh2o_cap', Nhru, 'real', Glacr_freeh2o_cap)/=0 ) CALL read_error(2, 'glacr_freeh2o_cap') + IF ( getparam(MODNAME, 'albedo_ice', Nhru, 'real', Albedo_ice)/=0 ) CALL read_error(2, 'albedo_ice') + IF ( getparam(MODNAME, 'albedo_coef', Nhru, 'real', Albedo_coef)/=0 ) CALL read_error(2, 'albedo_coef') + IF ( getparam(MODNAME, 'glacr_layer', Nhru, 'real', Glacr_layer)/=0 ) CALL read_error(2, 'glacr_layer') + + ENDIF + + IF ( getparam(MODNAME, 'den_init', 1, 'real', Den_init)/=0 ) CALL read_error(2, 'den_init') + Deninv = 1.0D0/DBLE(Den_init) + IF ( getparam(MODNAME, 'den_max', 1, 'real', Den_max)/=0 ) CALL read_error(2, 'den_max') + Denmaxinv = 1.0D0/DBLE(Den_max) + + IF ( getparam(MODNAME, 'settle_const', 1, 'real', Settle_const)/=0 ) CALL read_error(2, 'settle_const') + Settle_const_dble = DBLE( Settle_const ) +! Set1 = 1.0/(1.0+Settle_const) +! Setden = Settle_const/Den_max + + IF ( getparam(MODNAME, 'melt_look', Nhru, 'integer', Melt_look)/=0 ) CALL read_error(2, 'melt_look') + IF ( getparam(MODNAME, 'melt_force', Nhru, 'integer', Melt_force)/=0 ) CALL read_error(2, 'melt_force') + IF ( getparam(MODNAME, 'rad_trncf', Nhru, 'real', Rad_trncf)/=0 ) CALL read_error(2, 'rad_trncf') + IF ( getparam(MODNAME, 'hru_deplcrv', Nhru, 'integer', Hru_deplcrv)/=0 ) CALL read_error(2, 'hru_deplcrv') + IF ( getparam(MODNAME, 'snarea_curve', Ndepl*11, 'real', Snarea_curve)/=0 ) CALL read_error(2, 'snarea_curve') + IF ( getparam(MODNAME, 'snarea_thresh', Nhru, 'real', Snarea_thresh)/=0 ) CALL read_error(2, 'snarea_thresh') + IF ( getparam(MODNAME, 'albset_rnm', 1, 'real', Albset_rnm)/=0 ) CALL read_error(2, 'albset_rnm') + IF ( getparam(MODNAME, 'albset_rna', 1, 'real', Albset_rna)/=0 ) CALL read_error(2, 'albset_rna') + IF ( getparam(MODNAME, 'albset_sna', 1, 'real', Albset_sna)/=0 ) CALL read_error(2, 'albset_sna') + IF ( getparam(MODNAME, 'albset_snm', 1, 'real', Albset_snm)/=0 ) CALL read_error(2, 'albset_snm') + IF ( getparam(MODNAME, 'emis_noppt', Nhru, 'real', Emis_noppt)/=0 ) CALL read_error(2, 'emis_noppt') + IF ( getparam(MODNAME, 'cecn_coef', Nhru*12, 'real', Cecn_coef)/=0 ) CALL read_error(2, 'cecn_coef') + IF ( getparam(MODNAME, 'freeh2o_cap', Nhru, 'real', Freeh2o_cap)/=0 ) CALL read_error(2, 'freeh2o_cap') + IF ( getparam(MODNAME, 'tstorm_mo', Nhru*12, 'integer', Tstorm_mo)/=0 ) CALL read_error(2, 'tstorm_mo') + + Pk_precip = 0.0 + Snowmelt = 0.0 + Snow_evap = 0.0 + Pptmix_nopack = 0 + Tcal = 0.0 + Frac_swe = 0.0 + Acum = acum_init + Amlt = amlt_init + IF (Frozen_flag==1) THEN + Tcal_nosnow = 0.0 + Land_albedo = 0.0 + ENDIF + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==3 ) THEN + IF ( getparam(MODNAME, 'snowpack_init', Nhru, 'real', Snowpack_init)/=0 ) CALL read_error(2, 'snowpack_init') + Pkwater_equiv = 0.0D0 + Pk_depth = 0.0D0 + Pk_den = 0.0 + Pk_ice = 0.0 + Freeh2o = 0.0 + Ai = 0.0D0 + Snowcov_area = 0.0 + Basin_pweqv = 0.0D0 + Basin_snowdepth = 0.0D0 + Basin_snowcov = 0.0D0 + Basin_snowicecov = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + Pkwater_equiv(i) = DBLE( Snowpack_init(i) ) + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*Hru_area_dble(i) + Pk_depth(i) = Pkwater_equiv(i)*Deninv + Pk_den(i) = SNGL( Pkwater_equiv(i)/Pk_depth(i) ) + Pk_ice(i) = SNGL( Pkwater_equiv(i) ) + Freeh2o(i) = Pk_ice(i)*Freeh2o_cap(i) + Ai(i) = Pkwater_equiv(i) ! [inches] + IF ( Ai(i)>Snarea_thresh(i) ) Ai(i) = DBLE( Snarea_thresh(i) ) ! [inches] + Frac_swe(i) = SNGL( Pkwater_equiv(i)/Ai(i) ) ! [fraction] + CALL sca_deplcrv(Snowcov_area(i), Snarea_curve(1,Hru_deplcrv(i)), Frac_swe(i)) + Basin_snowcov = Basin_snowcov + DBLE(Snowcov_area(i))*Hru_area_dble(i) + Basin_snowdepth = Basin_snowdepth + Pk_depth(i)*Hru_area_dble(i) + ENDIF + ENDDO + Basin_pweqv = Basin_pweqv*Basin_area_inv + Basin_snowcov = Basin_snowcov*Basin_area_inv + Basin_snowdepth = Basin_snowdepth*Basin_area_inv + DEALLOCATE ( Snowpack_init ) + Pkwater_ante = Pkwater_equiv + Pss = Pkwater_equiv + Pst = Pkwater_equiv + + IF ( Glacier_flag==1 ) THEN ! do here when not a restart simulation + IF ( getparam(MODNAME, 'glacier_frac_init', Nhru, 'real', Glacier_frac_init)/=0 ) CALL read_error(2, 'glacier_frac_init') + Glacr_albedo = 0.0 + Glacier_frac = Glacier_frac_init + IF ( getparam(MODNAME, 'glrette_frac_init', Nhru, 'real', Glrette_frac_init)/=0 ) CALL read_error(2, 'glrette_frac_init') + Glrette_frac = Glrette_frac_init + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Glacier_frac(i)>0.0 ) THEN + IF ( Hru_type(i)==4 ) THEN + IF ( Elev_units==0 ) THEN !from Oerlemans 1992 + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)*FEET2METERS+300.0)/200.0 ) + ELSE + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) + ENDIF + ELSE + PRINT *, 'Warning, glacier_frac > 0, but hru_type not equal to 4, glacier_frac set to 0' + PRINT *, 'in HRU ', i, 'glacier_frac_init = ',Glacier_frac_init(i) + Glacier_frac(i) = 0.0 + ENDIF + ENDIF + IF ( Glrette_frac(i)>0.0 ) THEN + IF ( Hru_type(i)==1 ) THEN + Glacr_albedo(i) = Albedo_ice(i) + ELSE + PRINT *, 'Warning, glrette_frac > 0, but hru_type not equal to 1, glrette_frac set to 0' + PRINT *, 'in HRU ', i, 'glrette_frac_init = ',Glrette_frac_init(i) + Glrette_frac(i) = 0.0 + ENDIF + ENDIF + ENDDO + DEALLOCATE ( Glacier_frac_init ) + ENDIF + ENDIF + + IF ( Init_vars_from_file>0 ) RETURN + Basin_tcal = 0.0D0 + Iasw = 0 + Iso = 1 + Mso = 1 + Lso = 0 + Pk_def = 0.0 + Pk_temp = 0.0 + Albedo = 0.0 + Snsv = 0.0 + Lst = 0 + Int_alb = 1 + Salb = 0.0 + Slst = 0.0 + Snowcov_areasv = 0.0 + Scrv = 0.0D0 + Pksv = 0.0D0 + Basin_snowmelt = 0.0D0 + Basin_snowevap = 0.0D0 + Basin_pk_precip = 0.0D0 + + Yrdays5 = 0 + Basin_glacrb_melt = 0.0D0 + Basin_glacrevap = 0.0D0 + IF ( Glacier_flag==1 .OR. Frozen_flag==1) THEN + Ann_tempc = 0.0 + Prev_ann_tempc = 0.0 + ENDIF + IF ( Glacier_flag==1 ) THEN + Alt_above_ela = 0.0 + Glacr_air_5avtemp = 0.0 + Glacr_air_5avtemp1 = 0.0 + Glacr_air_deltemp = 0.0 + Glacr_5avsnow = 0.0 + Glacr_5avsnow1 = 0.0 + Glacr_delsnow = 0.0 + Glacrb_melt = 0.0 + Glacrmelt = 0.0 + Glacr_pk_den = 0.0 + Glacr_pk_temp = 0.0 + Glacr_pk_ice = 0.0 + Glacr_pk_def = 0.0 + Glacr_pkwater_equiv = 0.0D0 + Glacr_pkwater_ante = 0.0D0 + Glacr_evap = 0.0 + Glacr_freeh2o = 0.0 + Glacr_pk_depth = 0.0D0 + Glacr_pst = 0.0D0 + Glacr_pss = 0.0D0 + Glacrcov_area = 0.0 + Glacr_freeh2o_capm = Glacr_freeh2o_cap + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Glacier_frac(i)>0.0 .AND. Hru_type(i)==4 ) CALL glacr_states_to_zero(i,1) + ENDDO + ENDIF + + END FUNCTION snoinit + +!*********************************************************************** +! snorun - daily mode snow estimates +!*********************************************************************** + INTEGER FUNCTION snorun() + USE PRMS_SNOW + USE PRMS_MODULE, ONLY: Nhru, Print_debug, Glacier_flag, Starttime, Frozen_flag + USE PRMS_BASIN, ONLY: DNEARZERO, Hru_area, Active_hrus, Hru_type, & + & Basin_area_inv, Hru_route_order, Cov_type, INCH2M, FEET2METERS, Elev_units + USE PRMS_CLIMATEVARS, ONLY: Newsnow, Pptmix, Orad, Basin_horad, Potet_sublim, & + & Hru_ppt, Prmx, Tmaxc, Tminc, Tavgc, Swrad, Potet, Transp_on, Tmax_allsnow_c + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Glrette_frac, Alt_above_ela + USE PRMS_SET_TIME, ONLY: Jday, Nowmonth, Julwater, Nowyear + USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Canopy_covden, Hru_intcpevap + IMPLICIT NONE +! Functions + EXTERNAL ppt_to_pack, snowcov, snalbedo, snowbal, snowevap, glacr_states_to_zero + INTRINSIC ABS, SQRT, DBLE, SNGL, EXP, DABS, MOD, ATAN +! Local Variables + INTEGER :: i, j, k, niteda, isglacier, ijunk + REAL :: trd, sw, effk, cst, temp, cals, emis, esv, swn, cec + REAL :: ieffk, icst, icals, isw, iswn, frac, lswn, lsw, rjunk + DOUBLE PRECISION :: dpt1, dpt_before_settle, djunk +!*********************************************************************** + snorun = 0 + + ! Set the basin totals to 0 + ! (recalculated at the end of the time step) + Basin_snowmelt = 0.0D0 + Basin_pweqv = 0.0D0 + Basin_snowevap = 0.0D0 + Basin_snowcov = 0.0D0 + Basin_snowicecov = 0.0D0 + Basin_pk_precip = 0.0D0 + Basin_snowdepth = 0.0D0 + Basin_tcal = 0.0D0 + IF ( Glacier_flag==1 ) THEN + Basin_glacrb_melt = 0.0D0 + Basin_glacrevap = 0.0D0 + ENDIF + + ! Calculate the ratio of measured radiation to potential radiation + ! (used as a cumulative indicator of cloud cover) + trd = Orad/SNGL(Basin_horad) ! [dimensionless ratio] + IF ( Julwater==1 .AND. MOD(Nowyear-Starttime(1),5)==0 ) Yrdays5 = 0 + + ! Loop through all the active HRUs, in routing order + DO j = 1, Active_hrus + i = Hru_route_order(j) ! [counter] + + ! Skip the HRU if it is a lake + IF ( Hru_type(i)==2 ) CYCLE !AVB 7/18/19 we want to do frozen ground under lakes? + + Active_glacier = 0 + Active_frozen = 0 + isglacier = 0 + IF (Frozen_flag==1) Active_frozen = 1 + IF ( Hru_type(i)==4 .OR. Hru_type(i)==1 ) THEN + IF ( Glacier_flag==1 ) THEN + Glacrmelt(i) = 0.0 ! [inches] + Glacrb_melt(i) = 0.0 ! [inches] + Glacr_evap(i) = 0.0 ! [inches] + Glacr_pkwater_ante(i) = Glacr_pkwater_equiv(i) + IF ( Glacier_frac(i)==1.0 .OR. Glrette_frac(i)==1.0 ) Active_frozen = 0 !no need to separately calculate energy if glacier + IF ( Glacier_frac(i)>0.0 .OR. Glrette_frac(i)>0.0 ) THEN + IF (Glacier_frac(i)>0.0) Active_glacier = 1 + IF (Glrette_frac(i)>0.0) Active_glacier = 2 + Glacr_pk_den(i) = 0.917 + ! if no active layer make 0 deg and no holding capacity at start of each day + IF ( Glacr_layer(i)==0.0 .OR. Glacr_pk_depth(i)>1.0D3 ) THEN + Glacr_pk_def(i) = 0.0 + Glacr_pk_temp(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + ENDIF + ELSE !zero out states for glacier if gone (glacier state changes in glacier module, not here) + Glacr_pkwater_equiv(i) = 0.D0 + Glacrcov_area(i) = 0.0 + Glacr_pk_def(i) = 0.0 + Glacr_pk_temp(i) = 0.0 + Glacr_pk_ice(i) = 0.0 + Glacr_freeh2o(i) = 0.0 + Glacr_pk_depth(i) = 0.D0 + Glacr_pss = 0.0D0 + Glacr_pst(i) = 0.0D0 + Glacr_pk_den(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + Glacr_albedo(i) = 0.0 + ENDIF + isglacier = 1 + ENDIF + ENDIF + + ! If it's the first julian day of the water year, several + ! variables need to be reset + ! - reset the previous snow water eqivalent plus new snow to 0 + ! - reset flags to indicate it is not melt season or potetential melt season + ! - reset the counter for the number of days a snowpack is at 0 deg Celsius + !rsr, do we want to reset all HRUs, what about Southern Hemisphere + IF ( Julwater==1 ) THEN + Pss(i) = 0.0D0 ! [inches] + Iso(i) = 1 ! [flag] + Mso(i) = 1 ! [flag] + Lso(i) = 0 ! [counter] + + + IF ( Active_glacier>=1 ) CALL glacr_states_to_zero(i,1) !all snow on glacier becomes firn, reset active layer thickness + IF ( Active_glacier==1 ) THEN +! If Active_glacier>=1 we are zeroing out snowpack if have glacierettes even though possibly a lot of HRU is not glacierized. +! If Active_glacier==1 do not zero out glacierettes, but then will maybe never melt ice on glacierettes. If the climate is +! correct the snowpack will deplete quick because there is a lot of lower elevation than the glacierette included in the HRU. +! Choice does not effect runoff much, but will effect Basin_pweqv and things like that + ! if terminus glacier, and has snow will disappear off glacier but that is likely anyhow + Pkwater_equiv(i) = 0.0 + Pk_depth(i) = 0.0D0 + Pss(i) = 0.0D0 + Snsv(i) = 0.0 + Lst(i) = 0 + Pst(i) = 0.0D0 + Iasw(i) = 0 + Pk_den(i) = 0.0 + Snowcov_area(i) = 0.0 + Pk_def(i) = 0.0 + Pk_temp(i) = 0.0 + Pk_ice(i) = 0.0 + Freeh2o(i) = 0.0 + Snowcov_areasv(i) = 0.0 ! rsr, not in original code + Ai(i) = 0.0D0 + Frac_swe(i) = 0.0 + IF ( Elev_units==0 ) THEN !from Oerlemans 1992 + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)*FEET2METERS+300.0)/200.0 ) + ELSE + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) + ENDIF + ENDIF + IF ( Active_glacier==2 ) Glacr_albedo(i) = Albedo_ice(i) !glacr_albedo doesn't change if glacierette but could get zeroed out + IF ( isglacier==1 ) THEN + IF (Nowyear >= Starttime(1)+10 .AND. MOD(Nowyear-Starttime(1),5)==0 ) THEN + Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 5 years of data + Glacr_delsnow(i) = 10.0*(Glacr_5avsnow1(i) - Glacr_5avsnow(i))/Glacr_5avsnow1(i) !number of 10 percent (*100.0/10.0) changes + ENDIF + !keep before restart + IF ( MOD(Nowyear-Starttime(1),5)==0 ) THEN + IF ( Nowyear-Starttime(1)==5 ) THEN + Glacr_air_5avtemp1(i) = Glacr_air_5avtemp(i) + Glacr_5avsnow1(i) = Glacr_5avsnow(i) + ENDIF + Glacr_air_5avtemp(i) = 0.0 !zero out for new year restart + Glacr_5avsnow(i) = 0.0 !zero out for new year restart + ENDIF + ENDIF + Prev_ann_tempc(i) = Ann_tempc(i) + Ann_tempc(i) = 0.0 !zero out for new year restart + ENDIF !end start of year calculations + +! Do for summer + IF ( isglacier==1 ) THEN + IF (Julwater>151 .AND. Julwater<244) THEN ! Now following McGrath et al 2017, temp June-August, 92 days + Yrdays5 = Yrdays5 + 1 + Glacr_air_5avtemp(i) = ( Glacr_air_5avtemp(i)*(Yrdays5-1)+ Tavgc(i) )/Yrdays5 + ENDIF +! Do for every time step + Glacr_5avsnow(i) = Glacr_5avsnow(i) + Net_snow(i)/5.0 + ENDIF + Ann_tempc(i) = ( Ann_tempc(i)*(Julwater-1)+ Tavgc(i) )/Julwater + + ! HRU SET-UP - SET DEFAULT VALUES AND/OR BASE + ! CONDITIONS FOR THIS TIME PERIOD + !************************************************************** + + ! Keep track of the pack water equivalent before it is changed + ! by precipitation during this time step + Pkwater_ante(i) = Pkwater_equiv(i) + + ! By default, the precipitation added to snowpack, snowmelt, + ! and snow evaporation are 0 + Pk_precip(i) = 0.0 ! [inches] + Snowmelt(i) = 0.0 ! [inches] + Snow_evap(i) = 0.0 ! [inches] + Frac_swe(i) = 0.0 + Ai(i) = 0.0D0 + Tcal(i) = 0.0 + IF (Frozen_flag==1) Tcal_nosnow(i) = 0.0 + + ! By default, there has not been a mixed event without a + ! snowpack + Pptmix_nopack(i) = 0 ! [flag] + + ! If the day of the water year is beyond the forced melt day + ! indicated by the parameter, then set the flag indicating + ! melt season + !rsr, need to rethink this at some point +!rsr10 IF ( Iso(i)/=2 ) THEN + IF ( Jday==Melt_force(i) ) Iso(i) = 2 ! [flag] +!rsr10 ENDIF + + ! If the day of the water year is beyond the first day to + ! look for melt season indicated by the parameter, + ! then set the flag indicating to watch for melt season + !rsr, need to rethink this at some point +!rsr10 IF ( Mso(i)/=2 ) THEN + IF ( Jday==Melt_look(i) ) Mso(i) = 2 ! [flag] +!rsr10 ENDIF + + ! Skip the HRU if there is no snowpack and no new snow and not a glacier and no frozen ground + IF ( Pkwater_equiv(i)0.0D0.AND.Net_ppt(i)>0.0) .OR. Net_snow(i)>0.0 ) & + & CALL ppt_to_pack(Pptmix(i), Iasw(i), Tmaxc(i), Tminc(i), & + & Tavgc(i), Pkwater_equiv(i), Net_rain(i), Pk_def(i), & + & Pk_temp(i), Pk_ice(i), Freeh2o(i), Snowcov_area(i), & + & Snowmelt(i), Pk_depth(i), Pss(i), Pst(i), Net_snow(i), & + & Pk_den(i), Pptmix_nopack(i), Pk_precip(i), Tmax_allsnow_c(i,Nowmonth), Freeh2o_cap(i), -1) + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0.AND.Glacr_pkwater_ante(i)>0.0D0.AND.Net_ppt(i)>0.0 & + & .AND.Pptmix(i)==0.AND.Net_snow(i)==0.0 ) THEN + CALL ppt_to_pack(0, Iasw(i), Tmaxc(i), Tminc(i), & + & Tavgc(i), Glacr_Pkwater_equiv(i), Net_rain(i), Glacr_pk_def(i), & + & Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), Glacrcov_area(i), & + & Glacrmelt(i), Glacr_pk_depth(i), Glacr_pss(i), Glacr_pst(i), 0.0, & + & Glacr_pk_den(i), Pptmix_nopack(i), Pk_precip(i), Tmax_allsnow_c(i,Nowmonth), Glacr_freeh2o_capm(i), i) + ENDIF + ENDIF + +! FOLLOWING does basal melt on glacier +!Paterson 2010 says 12 mm/yr for friction and geothermal heating + IF ( Active_glacier==1 ) Glacrb_melt(i) = 12.0*0.03937/365.242*Glacier_frac(i) + IF ( Active_glacier==2 ) Glacrb_melt(i) = 12.0*0.03937/365.242*Glrette_frac(i) !since not moving much, maybe =0 + + ! If there is still a snowpack + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + + ! HRU STEP 2 - CALCULATE THE NEW SNOW COVERED AREA + !********************************************************** + ! Compute snow-covered area from depletion curve + k = Hru_deplcrv(i) + ! calculate the new snow covered area + CALL snowcov(Iasw(i), Newsnow(i), Snowcov_area(i), & + & Snarea_curve(1, k), Pkwater_equiv(i), Pst(i), & + & Snarea_thresh(i), Net_snow(i), Scrv(i), & + & Pksv(i), Snowcov_areasv(i), Ai(i), Frac_swe(i)) + + ! HRU STEP 3 - COMPUTE THE NEW ALBEDO + !********************************************************** + + ! Compute albedo if there is any snowpack + CALL snalbedo(Newsnow(i), Iso(i), Lst(i), Snsv(i), & + & Prmx(i), Pptmix(i), Albset_rnm, Net_snow(i), & + & Albset_snm, Albset_rna, Albset_sna, Albedo(i), & + & Int_alb(i), Salb(i), Slst(i)) + ENDIF + IF ( Active_glacier==1 ) Glacrcov_area(i) =(1.0-Snowcov_area(i))*Glacier_frac(i) + IF ( Active_glacier==2 ) Glacrcov_area(i) =(1.0-Snowcov_area(i))*Glrette_frac(i) + IF ( Snowcov_area(i)==1.0 .OR. Glacrcov_area(i)==1.0) Active_frozen=0 !no need to separately calculate energy if snow or glacier + + IF ( Active_glacier>=1 ) THEN +! Albedo so transition snow to ice smooothly, see Oerlemans 1992, this is albedo if snowcovered ice too + Albedo(i) = Albedo(i) - (Albedo(i)-Glacr_albedo(i))*EXP(-5.0*SNGL(Pkwater_equiv(i))*INCH2M) + IF ( Albedo(i)<0.08 ) Albedo(i)=0.08 !See Brock 2000 + IF ( Albedo(i)>0.92 ) Albedo(i)=0.92 !See Brock 2000 + ENDIF + + IF ( Active_frozen==1 ) THEN +! Use land albedo based on geographic areas there is frozen ground, from Euskirchen et al 2016 +! Assumes canopy is assumed to be a perfect blackbody so only want albedo of land under canopy + If (Cov_type(i)==0) Land_albedo(i) = 0.12 !bare soil (rock, may be mostly impervious already) + If (Cov_type(i)>=1) Land_albedo(i) = 0.25 !grasses (boreal grass, tundra) possibly under trees + ENDIF + + ! If there is still a snowpack or glacier + IF ( Pkwater_equiv(i)>0.0D0 .OR. Active_glacier>=1 .OR. Active_frozen==1) THEN + + ! HRU STEP 4 - DETERMINE RADIATION FLUXES AND SNOWPACK + ! STATES NECESSARY FOR ENERGY BALANCE + !********************************************************** + + ! Set the emissivity of the air to the emissivity when there + ! is no precipitation + emis = Emis_noppt(i) ! [fraction of radiation] + ! Could use equation from Swinbank 63 using Temp, a is -13.638, b is 6.148 + !emis = ((temp+273.15)**(Emis_coefb-4.0))*(10.0**(Emis_coefa+1.0))/5.670373E−8 ! /by Stefan Boltzmann in SI units + ! If there is any precipitation in the HRU, reset the + ! emissivity to 1 + IF ( Hru_ppt(i)>0.0 ) emis = 1.0 ! [fraction of radiation] + ! Save the current value of emissivity + esv = emis ! [fraction of radiation] + ! Set the convection-condensation for a half-day interval + cec = Cecn_coef(i, Nowmonth)*0.5 ! [cal/(cm^2 degC)] + ! or [Langleys / degC] + ! If the land cover is trees, reduce the convection- + ! condensation parameter by half + IF ( Cov_type(i)>2 ) cec = cec*0.5 ! [cal/(cm^2 degC)] RSR: cov_type=4 is valid for trees (coniferous) + ! or [Langleys / degC] + ! Check whether to force spring melt + ! Spring melt is forced if time is before the melt-force + ! day and after the melt-look day (parameters) + ! If between these dates, the spring melt applies if the + ! snowpack temperature is above or equal to 0 + ! for more than 4 cycles of the snorun function + + ! If before the first melt-force day + IF ( Iso(i)==1 ) THEN + ! If after the first melt-look day + IF ( Mso(i)==2 ) THEN + + ! Melt season is determined by the number of days the + ! snowpack is above 0 degrees C. The first time that + ! the snowpack is isothermal at 0 degrees C for more + ! than 4 days is the beginning of snowmelt season. + ! 2 options below (if-then, else) + + ! (1) The snowpack temperature is 0 degrees + IF ( Pk_temp(i)>=0.0 ) THEN + ! Increment the number of days that the snowpack + ! has been isothermal at 0 degrees C + Lso(i) = Lso(i) + 1 ! [days] + ! If the snowpack temperature has been 0 or greater + ! for more than 4 cycles + IF ( Lso(i)>4 ) THEN + ! Set the melt-force flag and reset counter + Iso(i) = 2 ! [flag] + Lso(i) = 0 ! [days] + ENDIF + + ! (2) The snowpack temperature is less than 0 degrees + ELSE + ! Reset the counter for days snowpack temperature is above 0 + Lso(i) = 0 ! [days] + ENDIF + ENDIF + ENDIF + + ! Compute energy balance for night period + ! niteda is a flag indicating nighttime (1) or daytime (2) + ! set the flag indicating night time + niteda = 1 ! [flag] + ! temparature is halfway between the minimum and average temperature + ! for the day + temp = (Tminc(i)+Tavgc(i))*0.5 + + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + ! The incoming shortwave radiation is the HRU radiation + ! adjusted by the albedo (some is reflected back into the + ! atmoshphere) and the transmission coefficient (some is + ! intercepted by the winter vegetative canopy) + swn = Swrad(i)*(1.0-Albedo(i))*Rad_trncf(i) ! [cal/cm^2] + ! or [Langleys] + ! Calculate the new snow depth (Riley et al. 1973) + ! RSR: the following 3 lines of code were developed by Rob Payn, 7/10/2013 + ! The snow depth depends on the previous snow pack water + ! equivalent plus the new net snow + Pss(i) = Pss(i) + DBLE( Net_snow(i) ) ! [inches] + dpt_before_settle = Pk_depth(i) + DBLE(Net_snow(i))*Deninv + dpt1 = dpt_before_settle + Settle_const_dble * ((Pss(i)*Denmaxinv) - dpt_before_settle) + ! dpt1 = Pk_depth(i) + (Net_snow(i)*Deninv) + & + ! Settle_const * ((Pss(i)*Denmaxinv) - Pk_depth(i)) + ! dpt1 = ((Net_snow(i)*Deninv)+ (Setden*Pss(i))+Pk_depth(i))*Set1 ! [inches] + ! RAPCOMMENT - CHANGED TO THE APPROPRIATE FINITE DIFFERENCE + ! APPROXIMATION OF SNOW DEPTH + Pk_depth(i) = dpt1 ! [inches] + + ! Calculate the snowpack density + IF ( dpt1>0.0D0 ) THEN + Pk_den(i) = SNGL( Pkwater_equiv(i)/dpt1 ) + ELSE + Pk_den(i) = 0.0 + ENDIF + ! [inch water equiv / inch depth] + + ! The effective thermal conductivity is approximated + ! (empirically) as 0.0077 times (snowpack density)^2 + ! [cal / (sec g degC)] Therefore, the effective + ! conductivity term (inside the square root) in the + ! equation for conductive heat exchange can be + ! calculated as follows (0.0077*pk_den^2)/(pk_den*0.5) + ! where 0.5 is the specific heat of ice [cal / (g degC)] + ! this simplifies to the following + effk = 0.0154*Pk_den(i) ! [unitless] + ! 13751 is the number of seconds in 12 hours over pi + ! So for a half day, to calculate the conductive heat + ! exchange per cm snow per cm^2 area per degree + ! temperature difference is the following + ! In effect, multiplying cst times the temperature + ! gradient gives the heatexchange by heat conducted + ! (calories) per square cm of snowpack + cst = Pk_den(i)*(SQRT(effk*13751.0)) ! [cal/(cm^2 degC)] + ! or [Langleys / degC] + + + ! no shortwave (solar) radiation at night + sw = 0.0 ! [cal / cm^2] or [Langleys] + ! calculate the night time energy balance + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Pkwater_equiv(i), & + & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & + & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & + & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) + ! track total heat flux from both night and day periods + Tcal(i) = cals ! [cal/cm^2] or [Langleys] + ENDIF + iswn = 0.0 + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0 ) THEN + iswn = Swrad(i)*(1.0-Glacr_albedo(i))*Rad_trncf(i) ! [cal/cm^2] !want bare ice albedo + ! or [Langleys] + ! Calculate the Glacier icepack density + ! + ! The effective thermal conductivity is approximated + ! (empirically) as 0.0077 times (snowpack density)^2 cal/(cm sec degC) + ! from Oke 1987 + ! ice is 2.1 W/(m degC) = 0.021 W/(cm deg C) = 0.00502 cal/(cm sec degC) + ! = 0.00597 times (0.917**2), + ! firn (old snow density .5) is closer to 0.0042 W/(cm deg C) = 0.00401 times (0.5**2) + ! Therefore, the effective + ! conductivity term (inside the square root) in the + ! equation for conductive heat exchange can be + ! calculated as follows (0.0597*pk_den^2)/(pk_den*0.5) + ! where 0.5 is the specific heat of ice [cal / (g degC)] + ! this simplifies to the following + ! might want to use 0.005*2 = 0.01 half way between if doing mix of firn and ice + ieffk = 0.01194*Glacr_pk_den(i) ! [unitless] + icst = Glacr_pk_den(i)*(SQRT(ieffk*13751.0)) ! [cal/(cm^2 degC)] + ! or [Langleys / degC] + isw = 0.0 ! [cal / cm^2] or [Langleys] + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Glacr_pkwater_equiv(i), & + & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & + & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & + & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) + ENDIF + ENDIF + IF ( Active_frozen==1 ) THEN + lswn = Swrad(i)*(1.0-Land_albedo(i))*Rad_trncf(i) ! [cal/cm^2] + ! or [Langleys] + lsw = 0.0 ! [cal / cm^2] or [Langleys] + ijunk = 0 + rjunk = 0.0 + djunk = 0.D0 + ! only call for calories to frozen ground + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), ijunk, & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, djunk, & + & rjunk, rjunk, rjunk, rjunk, & + & rjunk, rjunk, djunk, & + & djunk, djunk, rjunk, cst, cals, lsw, rjunk,-100) + ! track total heat flux from both night and day periods + Tcal_nosnow(i) = cals ! [cal/cm^2] or [Langleys] + ENDIF + + ! Compute energy balance for day period + ! set the flag indicating daytime + niteda = 2 ! [flag] + ! temparature is halfway between the maximum and average + ! temperature for the day + temp = (Tmaxc(i)+Tavgc(i))*0.5 ! [degrees C] + + IF ( Pkwater_equiv(i)>0.0D0 ) THEN !(if the snowpack still exists) + ! set shortwave radiation as calculated earlier + sw = swn ! [cal/cm^2] or [Langleys] + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Pkwater_equiv(i), & + & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & + & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & + & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) + ! track total heat flux from both night and day periods + Tcal(i) = Tcal(i) + cals ! [cal/cm^2] or [Langleys] + ENDIF + ! Compute energy balance for day period (if glacier exists) + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0 ) THEN + ! set shortwave radiation as calculated earlier + isw = iswn ! [cal/cm^2] or [Langleys] + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Glacr_pkwater_equiv(i), & + & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & + & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & + & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) + ENDIF + ENDIF + IF ( Active_frozen==1 ) THEN + lsw = lswn ! [cal / cm^2] or [Langleys] + ijunk = 0 + rjunk = 0.0 + djunk = 0.D0 + ! only call for calories to frozen ground + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), ijunk, & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, djunk, & + & rjunk, rjunk, rjunk, rjunk, & + & rjunk, rjunk, djunk, & + & djunk, djunk, rjunk, cst, cals, lsw, rjunk,-100) + ! track total heat flux from both night and day periods + Tcal_nosnow(i) = cals ! [cal/cm^2] or [Langleys] + ENDIF + + ! HRU STEP 5 - CALCULATE SNOWPACK LOSS TO EVAPORATION + !******************************************************** + + ! Compute snow evaporation (if there is still a snowpack) + ! Some of the calculated evaporation can come from interception + ! rather than the snowpack. Therefore, the effects of + ! interception must be evaluated. + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + ! Snow can evaporate when transpiration is not occuring + ! or when transpiration is occuring with cover types of + ! bare soil or grass + IF ( Transp_on(i)==0 .OR. (Transp_on(i)==1 .AND. Cov_type(i)<2) ) & + & CALL snowevap(Potet_sublim(i), Potet(i), Snowcov_area(i), & + & Snow_evap(i), Pkwater_equiv(i), Pk_ice(i), & + & Pk_def(i), Freeh2o(i), Pk_temp(i), Hru_intcpevap(i)) + ELSEIF ( Pkwater_equiv(i)<0.0D0 ) THEN + IF ( Print_debug>-1 ) THEN + IF ( Pkwater_equiv(i)<-DNEARZERO ) PRINT *, 'snowpack issue 3, negative pkwater_equiv, & + & HRU:', i, ' value:', Pkwater_equiv(i) + ENDIF + Pkwater_equiv(i) = 0.0D0 ! just to be sure negative values are ignored + ENDIF + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0 ) & + & CALL snowevap(Potet_sublim(i), Potet(i), Glacrcov_area(i), & + & Glacr_evap(i), Glacr_pkwater_equiv(i), Glacr_pk_ice(i), & + & Glacr_pk_def(i), Glacr_freeh2o(i), Glacr_pk_temp(i), Hru_intcpevap(i)) + ENDIF + + ! HRU CLEAN-UP - ADJUST FINAL HRU SNOWPACK STATES AND + ! INCREMENT THE BASIN TOTALS + !********************************************************* + + ! Final state of the snowpack depends on whether it still + ! exists after all the processing above + ! 2 options below (if-then, else) + + ! (1) Snow pack still exists + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + ! Snowpack still exists + IF ( Pk_den(i)>0.0 ) THEN + Pk_depth(i) = Pkwater_equiv(i)/DBLE(Pk_den(i)) + ELSE + Pk_den(i) = Den_max + Pk_depth(i) = Pkwater_equiv(i)*Denmaxinv + ENDIF + Pss(i) = Pkwater_equiv(i) + ! If it is during the melt period and snowfall was + ! insufficient to reset albedo, then reduce the cumulative + ! new snow by the amount melted during the period + ! (but don't let it be negative) + IF ( Lst(i)>0 ) THEN + Snsv(i) = Snsv(i) - Snowmelt(i) + IF ( Snsv(i)<0.0 ) Snsv(i) = 0.0 + ENDIF + ENDIF + + ENDIF + +! LAST check to clear out all arrays if packwater is gone + IF ( Pkwater_equiv(i)<=0.0D0 ) THEN + IF ( Print_debug>-1 ) THEN + IF ( Pkwater_equiv(i)<-DNEARZERO ) & + & PRINT *, 'Snowpack problem, pkwater_equiv negative, HRU:', i, ' value:', Pkwater_equiv(i) + ENDIF + Pkwater_equiv(i) = 0.0D0 ! just to be sure negative values are ignored + ! Snowpack has been completely depleted, reset all states + ! to no-snowpack values + Pk_depth(i) = 0.0D0 + Pss(i) = 0.0D0 + Snsv(i) = 0.0 + Lst(i) = 0 + Pst(i) = 0.0D0 + Iasw(i) = 0 + Albedo(i) = 0.0 + Pk_den(i) = 0.0 + Snowcov_area(i) = 0.0 + Pk_def(i) = 0.0 + Pk_temp(i) = 0.0 + Pk_ice(i) = 0.0 + Freeh2o(i) = 0.0 + Snowcov_areasv(i) = 0.0 ! rsr, not in original code + Ai(i) = 0.0D0 + Frac_swe(i) = 0.0 + ENDIF + IF ( Active_glacier>=1 ) THEN + IF ( Glacr_pkwater_equiv(i)>0.0D0 ) THEN + Glacr_pk_depth(i) = Glacr_pkwater_equiv(i)/DBLE(Glacr_pk_den(i)) + ELSE + CALL glacr_states_to_zero(i,0) + ENDIF + ENDIF + + frac = 1.0 + IF ( Active_glacier==1 ) frac = (1.0 - Glacier_frac(i)) + IF ( Active_glacier==2 ) frac = (1.0 - Glrette_frac(i)) + ! Sum volumes for basin totals + Basin_snowmelt = Basin_snowmelt + DBLE( Snowmelt(i)*Hru_area(i)*frac ) !don't include stuff melting into glacier + Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*DBLE( Hru_area(i) ) + Basin_snowevap = Basin_snowevap + DBLE( Snow_evap(i)*Hru_area(i) ) + Basin_snowcov = Basin_snowcov + DBLE( Snowcov_area(i)*Hru_area(i) ) + Basin_pk_precip = Basin_pk_precip + DBLE( Pk_precip(i)*Hru_area(i) ) + Basin_snowdepth = Basin_snowdepth + Pk_depth(i)*DBLE(Hru_area(i)) + Basin_tcal = Basin_tcal + DBLE( Tcal(i)*Hru_area(i) ) + IF ( Active_glacier>=1 ) THEN + Basin_glacrb_melt = Basin_glacrb_melt + Glacrb_melt(i)*Hru_area(i) + Basin_glacrevap = Basin_glacrevap + Glacr_evap(i)*Hru_area(i) + ENDIF + + ENDDO + + ! Area normalize basin totals + Basin_snowmelt = Basin_snowmelt*Basin_area_inv + Basin_pweqv = Basin_pweqv*Basin_area_inv + Basin_snowevap = Basin_snowevap*Basin_area_inv + Basin_snowcov = Basin_snowcov*Basin_area_inv + Basin_snowicecov = Basin_snowcov + Basin_pk_precip = Basin_pk_precip*Basin_area_inv + Basin_snowdepth = Basin_snowdepth*Basin_area_inv + Basin_tcal = Basin_tcal*Basin_area_inv + IF ( Glacier_flag==1 ) THEN + Basin_glacrb_melt = Basin_glacrb_melt*Basin_area_inv + Basin_glacrevap = Basin_glacrevap*Basin_area_inv + ENDIF + + + IF ( Print_debug==9 ) THEN + PRINT 9001, Jday, (Net_rain(i), i=1, Nhru) + PRINT 9001, Jday, (Net_snow(i), i=1, Nhru) + PRINT 9001, Jday, (Snowmelt(i), i=1, Nhru) + ENDIF + + 9001 FORMAT (I5, 177F6.3) + + END FUNCTION snorun + +!*********************************************************************** +! Subroutine to add rain and/or snow to snowpack +!*********************************************************************** + SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & + & Pkwater_equiv, Net_rain, Pk_def, Pk_temp, Pk_ice, & + & Freeh2o, Snowcov_area, Snowmelt, Pk_depth, Pss, Pst, & + & Net_snow, Pk_den, Pptmix_nopack, Pk_precip, Tmax_allsnow_c, Freeh2o_cap, Ihru_gl) + USE PRMS_BASIN, ONLY: CLOSEZERO, INCH2CM !, DNEARZERO + IMPLICIT NONE + REAL, EXTERNAL :: f_to_c + EXTERNAL calin + INTRINSIC ABS, DBLE, SNGL +! Arguments + INTEGER, INTENT(IN) :: Pptmix, Ihru_gl + INTEGER, INTENT(INOUT) :: Iasw, Pptmix_nopack + REAL, INTENT(IN) :: Tmaxc, Tminc, Tavgc, Net_rain, Net_snow + REAL, INTENT(IN) :: Freeh2o_cap, Tmax_allsnow_c + REAL, INTENT(INOUT) :: Snowmelt, Freeh2o, Pk_precip + REAL, INTENT(INOUT) :: Pk_def, Pk_ice, Pk_den, Snowcov_area, Pk_temp + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv, Pk_depth, Pst, Pss +! Local Variables + REAL :: train, tsnow, caln, pndz, calpr, calps +!*********************************************************************** + + ! The temperature of precipitation will be different if it is mixed or + ! all rain or snow 2 options below (if-then, else) + + ! If there is any snow, the snow temperature is the average + ! temperature + tsnow = Tavgc ! [degrees C] + ! (1) If precipitation is mixed... + IF ( Pptmix==1 ) THEN + ! If there is any rain, the rain temperature is halfway between the maximum + ! temperature and the allsnow temperature + train = (Tmaxc+Tmax_allsnow_c)*0.5 ! [degrees C] + + ! Temperatures will be different, depending on if there is an + ! existing snowpack or not + + ! If there is a snowpack, snow temperature is halfway between + ! the minimum daily temperature and maximum temperature for + ! which all precipitation is snow + IF ( Pkwater_equiv>0.0D0 ) THEN + tsnow = (Tminc+Tmax_allsnow_c)*0.5 ! [degrees C] + + ! If there is no existing snowpack, snow temperature is the + ! average temperature for the day + ELSEIF ( Pkwater_equiv<0.0D0 ) THEN +! IF ( Pkwater_equiv<-DNEARZERO ) & +! & PRINT *, 'snowpack issue in ppt_to_pack, negative pkwater_equiv', Pkwater_equiv + Pkwater_equiv = 0.0D0 ! to be sure negative snowpack is ignored + ENDIF + + ! (2) If precipitation is all snow or all rain... + ELSE ! on glacier ice goes in here only + ! If there is any rain, the rain temperature is the average + ! temperature + train = Tavgc ! [degrees C] + ! If average temperature is close to freezing, the rain + ! temperature is halfway between the maximum daily temperature + ! and maximum temperature for which all precipitation is snow + IF ( train0.0 ) tsnow = 0.0 ! [degrees C] ! tsnow can't be > 0 + + ! Leavesley comments... + ! If snowpack already exists, add rain first, then add + ! snow. If no antecedent snowpack, rain is already taken care + ! of, so start snowpack with snow. This SUBROUTINE assumes + ! that in a mixed event, the rain will be first and turn to + ! snow as the temperature drops. + + ! Rain can only add to the snowpack if a previous snowpack + ! exists, so rain or a mixed event is processed differently + ! when a snowpack exists + ! 2 options below (if-then, elseif) + + ! (1) If there is net rain on an existing snowpack... + IF ( Pkwater_equiv>0.0D0 ) THEN + IF ( Net_rain>0.0 ) THEN ! on glacier ice goes in here only + ! Add rain water to pack (rain on snow) and increment the + ! precipitation on the snowpack by the rain water + Pkwater_equiv = Pkwater_equiv + DBLE(Net_rain) ! [inches] + Pk_precip = Pk_precip + Net_rain ! [inches] + + ! Incoming rain water carries heat that must be added to + ! the snowpack. + ! This heat could both warm the snowpack and melt snow. + ! Handling of this heat depends on the current thermal + ! condition of the snowpack. + ! 2 options below (if-then, else) + + ! (1.1) If the snowpack is colder than freezing it has a + ! heat deficit (requires heat to be brought to isothermal + ! at 0 degC)... + IF ( Pk_def>0.0 ) THEN + ! Calculate the number of calories given up per inch of + ! rain when cooling it from the current rain temperature + ! to 0 deg C and then freezing it (liquid to solid state + ! latent heat) + ! This calculation assumes a volume of an inch of rain + ! over a square cm of area + ! 80 cal come from freezing 1 cm3 at 0 C + ! (latent heat of fusion is 80 cal/cm^3), + ! 1 cal from cooling 1cm3 for every degree C + ! (specific heat of water is 1 cal/(cm^3 degC)), + ! convert from 1 cm depth over 1 square cm to + ! 1 inch depth over 1 square cm (INCH2CM = 2.54 cm/in) + caln = (80.0+train)*INCH2CM ! [cal / (in cm^2)] + ! calculate the amount of rain in inches + ! (at the current rain temperature) + ! needed to bring the snowpack to isothermal at 0 + pndz = Pk_def/caln ! [inches] + + ! The effect of rain on the snowpack depends on if there + ! is not enough, enough, or more than enough heat in the + ! rain to bring the snowpack to isothermal at 0 degC or not + ! 3 options below (if-then, elseif, else) + + ! (1.1.1) Exactly enough rain to bring pack to isothermal... + IF ( ABS(Net_rain-pndz)0.0 ) THEN + ! Be careful with the code here. + ! If this subroutine is called when there is an all-rain day + ! on no existing snowpack (currently, it will not), + ! then the flag here will be set inappropriately. + Pptmix_nopack = 1 ! [flag] + ENDIF + + ! At this point, the subroutine has handled all conditions + ! where there is net rain, so if there is net snow + ! (doesn't matter if there is a pack or not)... + IF ( Net_snow>0.0 ) THEN + ! add the new snow to the pack water equivalent, precip, and ice + Pkwater_equiv = Pkwater_equiv + DBLE(Net_snow) + Pk_precip = Pk_precip + Net_snow + Pk_ice = Pk_ice + Net_snow + + ! The temperature of the new snow will determine its effect on + ! snowpack heat deficit + ! 2 options below (if-then, else) + + ! (1) if the new snow is at 0 degC... + IF ( tsnow>=0.0 ) THEN + ! incoming snow does not change the overall heat content of + ! the snowpack. + ! However, the temperature will change, because the total heat + ! content of the snowpack will be "spread out" among + ! more snow. Calculate the snow pack temperature from the + ! heat deficit, specific heat of snow, + ! and the new total snowpack water content + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + + ! (2) if the new snow is colder than 0 degC... + ELSE + ! calculate the amount of heat the new snow will absorb if + ! warming it to 0C (negative number). + ! This is the negative of the heat deficit of the new snow. + calps = tsnow*Net_snow*1.27 ! [cal/cm^2] + + ! The heat to warm the new snow can come from different + ! sources depending on the state of the snowpack + ! 2 options below (if-then, else) + + ! (2.1) if there is free water in the pack + ! (at least some of it is going to freeze)... + IF ( Freeh2o>0.0 ) THEN + CALL caloss(calps, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) + + ! (2.2) if there is no free water (snow pack has a + ! heat deficit greater than or equal to 0)... + ELSE + ! heat deficit increases because snow is colder than + ! pack (minus a negative number = plus) + ! and calculate the new pack temperature + Pk_def = Pk_def - calps ! [cal/cm^2] + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ENDIF + ENDIF + ENDIF + + END SUBROUTINE ppt_to_pack + +!*********************************************************************** +! Subroutine to compute change in snowpack when a net loss in +! heat energy has occurred. +!*********************************************************************** + SUBROUTINE caloss(Cal, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) + USE PRMS_BASIN, ONLY: CLOSEZERO !, DNEARZERO + IMPLICIT NONE + INTRINSIC SNGL +! Arguments + INTEGER, INTENT(IN) :: Ihru_gl + REAL, INTENT(IN) :: Cal + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv + REAL, INTENT(INOUT) :: Pk_def, Pk_ice, Freeh2o, Pk_temp +! Functions + EXTERNAL glacr_states_to_zero +! Local Variables + REAL :: calnd, dif +!*********************************************************************** + + ! Loss of heat is handled differently if there is liquid water in + ! the snowpack or not + ! 2 options below (if-then, else) + + ! (1) No free water exists in pack + IF ( Freeh2o0.0 ) THEN + ! the calories absorbed by the new snow freezes some + ! of the free water + ! (increase in ice, decrease in free water) + Pk_ice = Pk_ice + (-Cal/203.2) ! [inches] + Freeh2o = Freeh2o - (-Cal/203.2) ! [inches] + RETURN + ! (1) All free water freezes + ELSE ! IF ( dif<=0.0 ) THEN + ! if all the water freezes, then the remaining heat + ! that can be absorbed by new snow (that which is not + ! provided by freezing free water) becomes the new pack + ! heat deficit + IF ( dif<0.0 ) Pk_def = -dif ! [cal/cm^2] + ! free pack water becomes ice + Pk_ice = Pk_ice + Freeh2o ! [inches] + Freeh2o = 0.0 ! [inches] + + ENDIF + ENDIF + + ! if there is still a snowpack, calculate the new temperature + IF ( Pkwater_equiv>0.0D0 ) THEN + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ELSEIF ( Pkwater_equiv<0.0D0 ) THEN +! IF ( Pkwater_equiv<-DNEARZERO ) & +! & PRINT *, 'snowpack issue 4, negative pkwater_equiv', Pkwater_equiv + Pkwater_equiv = 0.0D0 + ! If on melting glacier ice/firn, Ihru_gl >0, so melted active layer (won't melt infinite ice layer) + If (Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl,0) + ENDIF + + END SUBROUTINE caloss + +!*********************************************************************** +! Subroutine to compute changes in snowpack when a net gain in +! heat energy has occurred. +!*********************************************************************** + SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & + & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & + & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) + USE PRMS_SNOW, ONLY: Denmaxinv, Den_max, Active_glacier + USE PRMS_MODULE, ONLY: Print_debug + USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO + IMPLICIT NONE +! Arguments + INTEGER, INTENT(INOUT) :: Iasw + INTEGER, INTENT(IN) :: Ihru_gl + REAL, INTENT(IN) :: Cal, Freeh2o_cap, Snowcov_area + REAL, INTENT(INOUT) :: Freeh2o + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv + REAL, INTENT(INOUT) :: Pk_def, Pk_temp, Pk_ice, Pk_den, Snowmelt + DOUBLE PRECISION, INTENT(INOUT) :: Pss, Pst, Pk_depth +! Functions + INTRINSIC SNGL, DBLE + EXTERNAL :: print_date, glacr_states_to_zero +! Local Variables + REAL :: dif, pmlt, apmlt, apk_ice, pwcap + DOUBLE PRECISION :: dif_dble +!*********************************************************************** + + ! Calculate the difference between the incoming calories and the + ! calories needed to bring the pack to isothermal + ! at 0 (heat deficit) + dif = Cal - Pk_def ! [cal/cm^2] + + ! The way incoming heat is handled depends on whether there is + ! not enough, just enough, or more than enough heat to overcome + ! the heat deficit of the snowpack. + ! 3 choices below (if-then, elseif, else) + + ! (1) Not enough heat to overcome heat deficit... + IF ( dif<0.0 ) THEN + ! Reduce the heat deficit by the amount of incoming calories + ! and adjust to the new temperature based on new heat deficit + Pk_def = Pk_def - Cal ! [cal/cm^2] + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + + ! (3) More than enough heat to overcome heat deficit + ! (melt ice)... + ELSEIF ( dif>0.0 ) THEN + ! calculate the potential amount of snowmelt from excess + ! heat in rain it takes 203.2 calories / (in cm^2) to melt snow + ! (latent heat of fusion) + ! convert from 1 cm depth over 1 square cm to + ! 1 inch depth over 1 square cm 80.0*(INCH2CM = 2.54 cm/in) = 203.2 + pmlt = dif/203.2 ! [inches] + ! Actual snowmelt can only come from snow covered area, so to + ! calculate the actual potential snowmelt, the potential + ! snowmelt from snowcovered area must be re-normalized to + ! HRU area (rather than snowcover area) + ! In effect, the potential snowmelt per area is reduced by the + ! fraction of the watershed that is actually covered by snow + apmlt = pmlt*Snowcov_area ! [inches] + ! Set the heat deficit and temperature of the remaining + ! snowpack to 0 + Pk_def = 0.0 ! [cal/cm^2] + Pk_temp = 0.0 ! [degrees C] + ! The only pack ice that is melted is in the snow covered area, + ! so the pack ice needs to be re-normalized to the snowcovered + ! area (rather than HRU area) + ! In effect, the pack ice per area is increased by the fraction + ! of the watershed that is actually covered by snow + IF ( Snowcov_area>0.0 ) THEN + apk_ice = Pk_ice/Snowcov_area ! [inches] + ELSE +! PRINT *, 'snowcov_area really small, melt all ice', snowcov_area, ' pmlt:', pmlt, ' dif:', dif, ' pk_ice:', Pk_ice + apk_ice = 0.0 + ENDIF + + ! If snow is melting, the heat is handled based on whether all + ! or only part of the pack ice melts + ! 2 options below (if-then, else) + + ! (3.1) Heat applied to snow covered area is sufficient + ! to melt all the ice in that snow pack... + ! if on snow over glacier or active_layer and have excess energy from day over + ! depth can melt from layer thickness, add depth to that layer + IF ( pmlt>apk_ice .AND. Active_glacier>=1 ) THEN + !fractionate density with snow/active layer melting vs extra ice underneath melting + Pk_den = Pk_den*SNGL(apk_ice/pmlt) + 0.917*SNGL((pmlt-apk_ice)/pmlt) + apk_ice = pmlt + Pk_ice = apmlt + Pkwater_equiv = apmlt + Freeh2o = 0.0 ! [inches] + Iasw = 0 + Pk_def = 0.0 ! [cal / cm^2] + Pk_temp = 0.0 ! [degreees C] + Pst = 0.0D0 ! [inches] + ENDIF + + IF ( pmlt>apk_ice ) THEN ! will not happen if Active_glacier>=1 because of above + ! All pack water equivalent becomes meltwater + Snowmelt = Snowmelt + SNGL( Pkwater_equiv ) ! [inches] + Pkwater_equiv = 0.0D0 ! [inches] + Iasw = 0 ! snow area does not change + ! Set all snowpack states to 0 + ! Snowcov_area = 0.0 ! [fraction of area] ! shouldn't be changed with melt + Pk_def = 0.0 ! [cal / cm^2] + Pk_temp = 0.0 ! [degreees C] + Pk_ice = 0.0 ! [inches] + Freeh2o = 0.0 ! [inches] + Pk_depth = 0.0D0 ! [inches] + Pss = 0.0D0 ! [inches] + Pst = 0.0D0 ! [inches] + Pk_den = 0.0 ! [fraction of depth] + + ! (3.2) Heat only melts part of the ice in the snow pack... + ELSE + ! Remove actual melt from frozen water and add melt to + ! free water + Pk_ice = Pk_ice - apmlt ! [inches] + Freeh2o = Freeh2o + apmlt ! [inches] + ! Calculate the capacity of the snowpack to hold free water + ! according to its current level of frozen water + pwcap = Freeh2o_cap*Pk_ice ! [inches] + ! Calculate the amount of free water in excess of the + ! capacity to hold free water + dif_dble = DBLE( Freeh2o - pwcap ) ! [inches] + ! If there is more free water than the snowpack can hold, + ! then there is going to be melt... + IF ( dif_dble>0.0D0 ) THEN + IF ( dif_dble>Pkwater_equiv ) dif_dble = Pkwater_equiv + ! total packwater decreases by the excess and a new depth + ! is calculated based on density + Pkwater_equiv = Pkwater_equiv - dif_dble ! [inches] + ! free water is at the current capacity + Freeh2o = pwcap ! [inches] + IF ( Pk_den>0.0 ) THEN + Pk_depth = Pkwater_equiv/DBLE(Pk_den) ! [inches] + ! RAPCOMMENT - added the conditional statement to make + ! sure there is no division by zero (this can happen + ! if there is a mixed event on no existing snowpack + ! because a pack density has not been calculated, yet + ELSE + !rsr, this should not happen, remove later + IF ( Print_debug>-1 ) THEN + PRINT *, 'snow density problem', Pk_depth, Pk_den, Pss, Pkwater_equiv + CALL print_date(1) + ENDIF + IF ( Active_glacier==0 ) Pk_den = Den_max + Pk_depth = Pkwater_equiv*Denmaxinv ! [inches] + ENDIF + + ! snowmelt increases by the excess free water + Snowmelt = Snowmelt + SNGL( dif_dble ) ! [inches] + ! reset the previous-snowpack-plus-new-snow to the + ! current pack water equivalent + Pss = Pkwater_equiv ! [inches] + ENDIF + ENDIF + ! (2) Just enough heat to overcome heat deficit + ELSE ! IF ( dif==0.0 ) THEN ! rsr 1/27/2016 why not set all snow states to 0 ??? + ! Set temperature and heat deficit to zero + Pk_temp = 0.0 ! [degrees C] + Pk_def = 0.0 ! [cal/cm^2] + ENDIF + IF ( Pkwater_equiv<=0.0D0 ) Pk_den = 0.0 + ! If on melting glacier ice/firn, Ihru_gl >0, so melted active layer (won't melt infinite ice layer) + IF ( Pkwater_equiv<=0.0D0 .AND. Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl,0) + + END SUBROUTINE calin + +!*********************************************************************** +! Subroutine to compute snowpack albedo +!*********************************************************************** + SUBROUTINE snalbedo(Newsnow, Iso, Lst, Snsv, Prmx, Pptmix, Albset_rnm, & + & Net_snow, Albset_snm, Albset_rna, Albset_sna, Albedo, & + & Int_alb, Salb, Slst) + USE PRMS_SNOW, ONLY: MAXALB, Acum, Amlt + IMPLICIT NONE + INTRINSIC INT +! Arguments + INTEGER, INTENT(IN) :: Newsnow, Iso, Pptmix + INTEGER, INTENT(INOUT) :: Int_alb, Lst + REAL, INTENT(IN) :: Albset_rnm, Albset_snm, Albset_rna, Albset_sna, Prmx, Net_snow + REAL, INTENT(INOUT) :: Salb, Slst, Snsv + REAL, INTENT(OUT) :: Albedo +! Local Variables + INTEGER :: l +!*********************************************************************** + + ! The albedo is always reset to a new initial (high) value when + ! there is new snow above a threshold (parameter). Albedo + ! is then a function of the number of days since the last new snow + ! Intermediate conditions apply when there is new snow + ! below the threshold to reset the albedo to its highest value. + ! The curve for albedo change (decreasing) is different for the + ! snow accumulation season and the snow melt season. + ! The albedo first depends on if there is no new snow during the + ! current time step, if there is new snow during accumulation + ! season, or if there is new snow during melt season. + ! 3 options below (if-then, elseif, else) + + ! (1) There is no new snow + IF ( Newsnow==0 ) THEN + ! If no new snow, check if there was previous new snow that + ! was not sufficient to reset the albedo (Lst=1) + ! Lst can only be greater than 0 during melt season (see below) + IF ( Lst>0 ) THEN + ! Slst is the number of days (float) since the last + ! new snowfall + ! Set the albedo curve back three days from the number + ! of days since the previous snowfall + ! (see Salb assignment below) + ! (note that "shallow new snow" indicates new snow that + ! is insufficient to completely reset the albedo curve) + ! In effect, a shallow new snow sets the albedo curve back + ! a few days, rather than resetting it entirely. + Slst = Salb - 3.0 ! [days] + ! Make sure the number of days since last new snow + ! isn't less than 1 + IF ( Slst<1.0 ) Slst = 1.0 ! [days] + ! If not in melt season + IF ( Iso/=2 ) THEN + ! Note that this code is unreachable in its current state. + ! This code is only run during melt season due to the + ! fact that Lst can only be set to 1 in the melt season. + ! Therefore, Iso is always going to be equal to 2. + ! Make sure the maximum point on the albedo curve is 5 + ! In effect, if there is any new snow, the albedo can + ! only get so low in accumulation season, even if the + ! new snow is insufficient to reset albedo entirely + IF ( Slst>5.0 ) Slst = 5.0 ! [days] + ENDIF + ! Reset the shallow new snow flag and cumulative shallow + ! snow variable (see below) + Lst = 0 ! [flag] + Snsv = 0.0 ! [inches] + ENDIF + + ! (2) New snow during the melt season + ELSEIF ( Iso==2 ) THEN +! RAPCOMMENT - CHANGED TO ISO FROM MSO + + ! If there is too much rain in a precipitation mix, + ! albedo will not be reset + ! New snow changes albedo only if the fraction rain + ! is less than the threshold above which albedo is not reset + IF ( PrmxAlbset_snm ) THEN + ! Reset number of days since last new snow to 0 + Slst = 0.0 ! [days] + Lst = 0 ! [flag] + ! Reset the saved new snow to 0 + Snsv = 0.0 ! [inches] + + ! (2.2) If there is not enough new snow this time period + ! to reset the albedo on its own + ELSE + ! Snsv tracks the amount of snow that has fallen as long + ! as the total new snow is not + ! enough to reset the albedo. + Snsv = Snsv + Net_snow ! [inches] + + ! Even if the new snow during this time period is + ! insufficient to reset the albedo, it may still reset the + ! albedo if it adds enough to previous shallow snow + ! accumulation. The change in Albedo depends on if the + ! total amount of accumulated shallow snow has become enough + ! to reset the albedo or not. + ! 2 options below (if-then, else) + + ! (2.2.1) If accumulated shallow snow is enough to reset + ! the albedo + IF ( Snsv>Albset_snm ) THEN + ! Reset the albedo states. + Slst = 0.0 ! [days] + Lst = 0 ! [flag] + Snsv = 0.0 ! [inches] + + ! (2.2.2) If the accumulated shallow snow is not enough to + ! reset the albedo curve + ELSE + ! Salb records the number of days since the last new snow + ! that reset albedo + IF ( Lst==0 ) Salb = Slst ! [days] + ! Reset the number of days since new snow + Slst = 0.0 ! [days] + ! set the flag indicating that there is shallow new snow + ! (i.e. not enough new snow to reset albedo) + Lst = 1 ! [flag] + ENDIF + ENDIF + ENDIF + + ! (3) New snow during the accumulation season + ELSE + + ! The change in albedo depends on if the precipitation is a mix, + ! if the rain is above a threshold, or if the snow is above + ! a threshold. + ! 4 options below (if-then, elseif, elseif, else) + + ! (3.1) If it is not a mixed event... + IF ( Pptmix<1 ) THEN + ! During the accumulation season, the threshold for resetting + ! the albedo does not apply if there is a snow-only event. + ! Therefore, no matter how little snow there is, it will + ! always reset the albedo curve the the maximum, if it + ! occurs during the accumulation season. + ! reset the time since last snow to 0 + Slst = 0.0 ! [days] + ! there is no new shallow snow + Lst = 0 ! [flag] + + ! (3.2) If it is a mixed event and the fraction rain is above + ! the threshold above which albedo is not reset... + ELSEIF ( Prmx>=Albset_rna ) THEN + ! there is no new shallow snow + Lst = 0 ! [flag] + ! albedo continues to decrease on the curve + + ! (3.3) If it is a mixed event and there is enough new snow + ! to reset albedo... + ELSEIF ( Net_snow>=Albset_sna ) THEN + ! reset the albedo + Slst = 0.0 ! [days] + ! there is no new shallow snow + Lst = 0 ! [flag] + + ! (3.4) If it is a mixed event and the new snow was not + ! enough to reset the albedo... + ELSE + ! set the albedo curve back 3 days (increasing the albedo) + Slst = Slst - 3.0 ! [days] + ! Make sure the number of days since last new snow is not + ! less than 0 + IF ( Slst<0.0 ) Slst = 0.0 ! [days] + ! Make sure the number of days since last new snow is not + ! greater than 5 + ! In effect, if there is any new snow, the albedo can + ! only get so low in accumulation season, even if the + ! new snow is insufficient to reset albedo entirely + IF ( Slst>5.0 ) Slst = 5.0 ! [days] + Lst = 0 ! [flag] + ENDIF + Snsv = 0.0 ! [inches] + ENDIF + ! At this point, the subroutine knows where on the curve the + ! albedo should be based on current conditions and the + ! new snow (determined by value of Slst variable) + + ! Get the integer value for days (or effective days) + ! since last snowfall + l = INT(Slst+0.5) ! [days] + + ! Increment the state variable for days since the + ! last snowfall + Slst = Slst + 1.0 ! [days] + + !******Compute albedo + ! Albedo will only be different from the max (default value) + ! if it has been more than 0 days since the last new snow + ! capable of resetting the albedo. If albedo is at the + ! maximum, the maximum is different for accumulation and + ! melt season. + ! 3 options below (if-then, elseif, else) + + ! (1) It has been more than 0 days since the last new snow + IF ( l>0 ) THEN + + ! Albedo depends on whether it is currently on the + ! accumulation season curve or on the melt season curve. + ! 3 options below (if-then, elseif, else) + + ! (1.1) Currently using the melt season curve + ! (Old snow - Spring melt period)... + IF ( Int_alb==2 ) THEN + ! Don't go past the last possible albedo value + IF ( l>MAXALB ) l = MAXALB ! [days] + ! Get the albedo number from the melt season curve + Albedo = Amlt(l) ! [fraction of radiation] + + ! (1.2) Currently using the accumulation season curve + ! (Old snow - Winter accumulation period)... + ! and not past the maximum curve index + ELSEIF ( l<=MAXALB ) THEN + ! Get the albedo number from the accumulation season curve + Albedo = Acum(l) ! [fraction of radiation] + + ! (1.3) Currently using the accumulation season curve and + ! past the maximum curve index... + ELSE + ! start using the the MELT season curve at 12 days + ! previous to the current number of days since the last + ! new snow + l = l - 12 ! [days] + ! keep using the melt season curve until its minimum + ! value (maximum index) is reached or until there is new snow + IF ( l>MAXALB ) l = MAXALB ! [days] + ! get the albedo value from the melt season curve + Albedo = Amlt(l) ! [fraction of radiation] + ENDIF + + ! (2) New snow has reset the albedo and it is melt season + ELSEIF ( Iso==2 ) THEN +! RAPCOMMENT - CHANGED TO ISO FROM MSO + ! Set albedo to initial value during melt season + Albedo = 0.72 ! [fraction of radiation] value Rob suggested +! Albedo = 0.81 ! [fraction of radiation] original value + ! Int_alb is a flag to indicate use of the melt season curve (2) + ! or accumulation season curve (1) + ! Set flag to indicate melt season curve + Int_alb = 2 ! [flag] + + ! (3) New snow has reset the albedo and it is accumulation season + ELSE + ! Set albedo to initial value during accumulation season + Albedo = 0.91 ! [fraction of radiation] + ! Set flag to indicate accumulation season curve + Int_alb = 1 ! [flag] + ENDIF + + END SUBROUTINE snalbedo + +!*********************************************************************** +! Subroutine to compute energy balance of snowpack +! 1st call is for night period, 2nd call for day period +!*********************************************************************** + SUBROUTINE snowbal(Niteda, Tstorm_mo, Iasw, Temp, Esv, Hru_ppt, & + & Trd, Emis_noppt, Canopy_covden, Cec, Pkwater_equiv, & + & Pk_def, Pk_temp, Pk_ice, Freeh2o, Snowcov_area, & + & Snowmelt, Pk_depth, Pss, Pst, Pk_den, Cst, Cal, Sw, Freeh2o_cap, Ihru_gl) + USE PRMS_BASIN, ONLY: CLOSEZERO + IMPLICIT NONE + INTRINSIC SNGL + EXTERNAL calin, caloss +! Arguments + INTEGER, INTENT(IN) :: Niteda, Tstorm_mo, Ihru_gl + INTEGER, INTENT(INOUT) :: Iasw + REAL, INTENT(IN) :: Temp, Esv, Trd, Cec, Cst, Canopy_covden + REAL, INTENT(IN) :: Emis_noppt, Sw, Freeh2o_cap + REAL, INTENT(IN) :: Hru_ppt, Snowcov_area + DOUBLE PRECISION, INTENT(OUT) :: Pst, Pss + REAL, INTENT(OUT) :: Cal + REAL, INTENT(INOUT) :: Pk_den, Pk_def, Pk_temp, Pk_ice + REAL, INTENT(INOUT) :: Freeh2o, Snowmelt + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv, Pk_depth +! Local Variables + REAL :: air, ts, emis, sno, sky, can, cecsub, qcond, pk_defsub, pkt, pks + REAL, PARAMETER :: ONETHIRD = 1.0/3.0 +!*********************************************************************** + ! Calculate the potential long wave energy from air based on + ! temperature (assuming perfect black-body emission) + ! Stefan Boltzmann/2 = (11.71E-8)/2 = 0.585E-7 because add for day and night + air = 0.585E-7*((Temp+273.15)**4.0) ! [cal/cm^2] or [Langleys] + ! set emissivity, which is the fraction of perfect black-body + ! emission that is actually applied + emis = Esv ! [fraction of radiation] + + ! The snowpack surface temperature and long-wave radiation + ! FROM the snowpack depend on the air temperature (effectively, + ! snowpack temperature cannot be larger than 0 degC) + ! 2 options below (if-then, else) + + ! (1) If the temperature is below freezing, surface snow + ! temperature and long wave energy are determined + ! by temperature... + IF ( Temp<0.0 ) THEN + ts = Temp ! [degrees C] + sno = air ! [cal/cm^2] or [Langleys] + + ! (2) If the temperature is at or above freezing, snow + ! temperature and long wave energy are set to values + ! corresponding to a temperature of 0 degC... + ELSE + ts = 0.0 ! [degrees C] + sno = 325.7 ! [cal/cm^2] or [Langleys] + ENDIF + IF ( Ihru_gl==-100 ) sno=0.0 !frozen ground energy computation + + ! If precipitation over the time period was due to + ! convective thunderstorms, then the emissivity should be reset + IF ( Hru_ppt>0.0 ) THEN + IF ( Tstorm_mo==1 ) THEN + + ! The emissivity of air depends on if it is day or night + ! and the fraction of measured short wave radiation to + ! potential short wave radiation is used as a surrogate + ! to the duration of the convective storms + ! 2 options below (if-then, else) + + ! (1) Night + IF ( Niteda==1 ) THEN + ! set the default emissivity + emis = 0.85 ! [fraction of radiation] + ! if measured radiation is greater than 1/3 potential + ! radiation through the time period, then the emissivity + ! is set to the "no precipitation" value + IF ( Trd>ONETHIRD ) emis = Emis_noppt ![fraction of radiation] + + ! (2) Day + ELSE + ! if measured radiation is greater than 1/3 potential + ! radiation but less than 1/2, then the emissivity is + ! interpolated between 1.0 and 0.85 + ! if measured radiation is greater than 1/2 potential + ! radiation, then the emissivity is interpolated between + ! 0.85 and 0.75 + IF ( Trd>ONETHIRD ) emis = 1.29 - (0.882*Trd) + ! [fraction of radiation] + IF ( Trd>=0.5 ) emis = 0.95 - (0.2*Trd) + ! [fraction of radiation] + ENDIF + ENDIF + ENDIF + + ! Calculate the net incoming long wave radiation coming from the + ! sky or canopy in the uncovered or covered portions of the + ! snowpack, respectively. + ! Note that the canopy is assumed to be a perfect blackbody + ! (emissivity = 1) and the air has emissivity as determined + ! from previous calculations + sky = (1.0-Canopy_covden)*((emis*air)-sno) ! [cal/cm^2] or [Langleys] + can = Canopy_covden*(air-sno) ! [cal/cm^2] or [Langleys] +!RAPCOMMENT - CHECK THE INTERECEPT MODULE FOR CHANGE. What if the land +! cover is grass? Is this automatically covered by canopy_covden being zero +! if the cover type is grass? + + ! If air temperature is above 0 degC then set the energy from + ! condensation and convection, otherwise there is + ! no energy from convection or condensation + cecsub = 0.0 ! [cal/cm^2] or [Langleys] + IF ( Temp>0.0 ) THEN + IF ( Hru_ppt>0.0 ) cecsub = Cec*Temp ! [cal/cm^2] + ! or [Langleys] + ENDIF + + ! Total energy potentially available from atmosphere: longwave, + ! shortwave, and condensation/convection + Cal = sky + can + cecsub + Sw ! [cal/cm^2] or [Langleys] + + IF ( Ihru_gl==-100 ) RETURN !frozen ground energy computation, do not need more + ! If the surface temperature of the snow is 0 degC, and there + ! is net incoming energy, then energy conduction has to be from + ! the surface into the snowpack. + ! Therefore, the energy from the atmosphere is applied to the + ! snowpack and subroutine terminates + IF ( ts>=0.0 ) THEN + IF ( Cal>0.0 ) THEN + CALL calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & + & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & + & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) + RETURN + ENDIF + ENDIF + + ! If the program gets to this point, then either the surface + ! temperature is less than 0 degC, or the total energy from the + ! atmosphere is not providing energy to the snowpack + + ! Because the temperature of the surface of the snowpack is + ! assumed to be controlled by air temperature, there is a + ! potential heat flux due to conduction between the deeper + ! snowpack and its surface. + ! Calculate conductive heat flux as a function of the + ! temperature gradient then set new snowpack conditions + ! depending on the direction of heat flow + qcond = Cst*(ts-Pk_temp) ! [cal/cm^2] or [Langleys] +!RAPCOMMENT - The original equation in the paper implies that the +! this equation should be relative to the temperature gradient +! in degF, not degC (Anderson 1968). Which is correct? + + ! The energy flow depends on the direction of conduction and the + ! temperature of the surface of the snowpack. The total energy + ! from the atmosphere can only penetrate into the snow pack if + ! the temperature gradient allows conduction from the surface + ! into the snowpack. + ! 4 options below (if-then, elseif, elseif, else) + + ! (1) Heat is conducted from the snowpack to the surface + ! (atmospheric energy is NOT applied to snowpack)... + IF ( qcond<0.0 ) THEN + ! If the temperature of the snowpack is below 0 degC, + ! add to the heat deficit. Otherwise, remove heat + ! from the 0 degC isothermal snow pack. + IF ( Pk_temp<0.0 ) THEN + ! increase the heat deficit (minus a negative) + ! and adjust temperature + Pk_def = Pk_def - qcond ! [cal/cm^2] or [Langleys] + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ELSE + ! remove heat from the snowpack + CALL caloss(qcond, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) + ENDIF + ! Even though Cal is not applied to the snowpack under this + ! condition, it maintains its value and the referencing code + ! uses it to calculate the total energy balance of the snowpack. + ! Right, now, Cal isn't used for anything outside this subroutine, + ! but care should be taken if it is. + + ! (2) There is no heat conduction, qcond = 0.0 + ELSEIF ( qcond=0.0 ) THEN + ! It does not appear that the interior of the following if + ! statement is reachable in its current form, because if these + ! conditions are true, then the code for surface temperature=0 + ! and cal=positive number would have run and the subroutine + ! will have terminated + IF ( Cal>0.0 ) CALL calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & + & Pk_ice, Freeh2o, Snowcov_area, & + & Snowmelt, Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) + ENDIF + + ! (3) conduction is from the surface to the snowpack and the + ! surface temperature is 0 degrees C... + ELSEIF ( ts>=0.0 ) THEN + ! note that Cal must be <= 0 for this condition to apply. + ! Otherwise, the program wouldn't have gotten to this point. + + ! determine if the conductive heat is enough to overcome the + ! current heat deficit + pk_defsub = Pk_def - qcond + IF ( pk_defsub<0.0 ) THEN + ! deficit is overcome and snowpack becomes + ! isothermal at 0 degC + Pk_def = 0.0 ! [cal/cm^2] or [Langleys] + Pk_temp = 0.0 ! [degrees C] + ELSE + ! deficit is decreased by conducted heat and temperature + ! is recalculated + Pk_def = pk_defsub ! [cal/cm^2] or [Langleys] + Pk_temp = -pk_defsub/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ENDIF + + ! (4) conduction is from the surface to the snowpack and the + ! surface temperature is less than 0 degrees C... + ELSE + ! calculate the pack deficit if the snowpack was all at the + ! surface temperature, then calculate how many calories to + ! shift the pack to that deficit (pks will be a positive + ! number because the conduction direction is from the surface + ! into the snowpack) + pkt = -ts*SNGL(Pkwater_equiv*1.27D0) ! [cal/cm^2] or [Langleys] + pks = Pk_def - pkt ! [cal/cm^2] or [Langleys] + ! determine if the conducted heat is enough to shift the + ! pack to the deficit relative to the surface temperature + pk_defsub = pks - qcond ! [cal/cm^2] or [Langleys] + + ! The effect of incoming conducted heat depends on whether + ! it is enough to bring the snowpack to the same temperature + ! as the surface or not + ! 2 options below (if-then, else) + + ! (4.1) There is enough conducted heat to bring the deep + ! snowpack to the surface temperature... + IF ( pk_defsub<0.0 ) THEN + ! there is enough conduction to change to the new pack deficit + Pk_def = pkt ! [cal/cm^2] or [Langleys] + Pk_temp = ts ! [degrees C] + + ! (4.2) There is not enough conducted heat to bring the deep + ! snowpack to the surface temperature... + ELSE + ! the pack deficit doesn't make it all the way to the surface + ! deficit, but is decreased relative to the conducted heat + ! note that the next statement is equivalent to + ! Pk_def = Pk_def - qcond + Pk_def = pk_defsub + pkt ! [cal/cm^2] or [Langleys] + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ENDIF + ENDIF + + END SUBROUTINE snowbal + +!*********************************************************************** +! Subroutine to compute evaporation from snowpack +!*********************************************************************** + SUBROUTINE snowevap(Potet_sublim, Potet, Snowcov_area, Snow_evap, & + & Pkwater_equiv, Pk_ice, Freeh2o, Pk_def, Pk_temp, Hru_intcpevap) + USE PRMS_SNOW, ONLY: Active_glacier + USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO + USE PRMS_MODULE, ONLY: Print_debug + IMPLICIT NONE + INTRINSIC DBLE, SNGL +! Arguments + REAL, INTENT(IN) :: Potet_sublim, Potet, Snowcov_area, Hru_intcpevap + REAL, INTENT(INOUT) :: Pk_ice, Pk_def, Pk_temp + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv + REAL, INTENT(OUT) :: Snow_evap, Freeh2o +! Local Variables + REAL :: avail_et, cal, ez +!*********************************************************************** + ! the amount of evaporation affecting the snowpack is the + ! total evaporation potential minus the evaporation from + ! the interception storage + ez = Potet_sublim*Potet*Snowcov_area - Hru_intcpevap ! [inches] + + ! The effects of evaporation depend on whether there is any + ! potential for evaporation, and if the potential evapotation + ! is enough to completely deplete the snow pack or not + ! 3 options below (if-then, elseif, else) + + ! (1) There is no potential for evaporation... + ! if on snow over glacier or active_layer and have excess energy from day over + ! depth can evap from layer thickness, add depth to that layer + IF ( ez>Pkwater_equiv .AND. Active_glacier>=1 ) Pkwater_equiv = DBLE(ez) + IF ( ez=Pkwater_equiv ) THEN + ! Set the evaporation to the pack water equivalent and set + ! all snowpack variables to no-snowpack values + Snow_evap = SNGL(Pkwater_equiv) ! [inches] + Pkwater_equiv = 0.0D0 ! [inches] + Pk_ice = 0.0 ! [inches] + Pk_def = 0.0 ! [cal/cm^2] + Freeh2o = 0.0 ! [inches] + Pk_temp = 0.0 ! [degrees C] + + ! (3) Potential evaporation only partially depletes snowpack + ELSE + ! Evaporation depletes the amount of ice in the snowpack + ! (sublimation) + Pk_ice = Pk_ice - ez + + ! Change the pack conditions according to whether there is + ! any ice left in the snowpack + IF ( Pk_ice<0.0 ) THEN +!RAPCOMMENT - CHANGED TO CHECK FOR NEGATIVE PACK ICE + ! If all pack ice is removed, then there cannot be a + ! heat deficit + Pk_ice = 0.0 + Pk_def = 0.0 + Pk_temp = 0.0 + ELSE + ! Calculate the amount of heat deficit that is removed + ! by the sublimating ice + ! Note that this only changes the heat deficit if the + ! pack temperature is less than 0degC + cal = Pk_temp*ez*1.27 + Pk_def = Pk_def + cal + ENDIF + ! Remove the evaporated water from the pack water equivalent + Pkwater_equiv = Pkwater_equiv - ez + Snow_evap = ez + ENDIF + IF ( Snow_evap<0.0 ) THEN + Pkwater_equiv = Pkwater_equiv - DBLE(Snow_evap) + IF ( Pkwater_equiv<0.0D0 ) THEN + IF ( Print_debug>-1 ) THEN + IF ( Pkwater_equiv<-DNEARZERO ) & + & PRINT *, 'snowpack issue, negative pkwater_equiv in snowevap', Pkwater_equiv + Pkwater_equiv = 0.0D0 + ENDIF + ENDIF + Snow_evap = 0.0 + ENDIF + avail_et = Potet - Hru_intcpevap - Snow_evap + IF ( avail_et<0.0 ) THEN +! PRINT *, 'snow evap', snow_evap, avail_et, pkwater_equiv + Snow_evap = Snow_evap + avail_et + Pkwater_equiv = Pkwater_equiv - DBLE(avail_et) + IF ( Snow_evap<0.0 ) THEN + Pkwater_equiv = Pkwater_equiv - Snow_evap + IF ( Pkwater_equiv<0.0D0 ) THEN + IF ( Print_debug>-1 ) THEN + IF ( Pkwater_equiv<-DNEARZERO ) & + & PRINT *, 'snowpack issue 2, negative pkwater_equiv in snowevap', Pkwater_equiv + ENDIF + Pkwater_equiv = 0.0D0 ! to be sure negative snowpack is ignored + ENDIF + Snow_evap = 0.0 + ENDIF + ENDIF + + END SUBROUTINE snowevap + +!*********************************************************************** +! Subroutine to compute snow-covered area +!*********************************************************************** + SUBROUTINE snowcov(Iasw, Newsnow, Snowcov_area, Snarea_curve, & + & Pkwater_equiv, Pst, Snarea_thresh, Net_snow, & + & Scrv, Pksv, Snowcov_areasv, Ai, Frac_swe) + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Newsnow + INTEGER, INTENT(INOUT) :: Iasw + REAL, INTENT(IN) :: Snarea_thresh, Net_snow, Snarea_curve(11) + DOUBLE PRECISION, INTENT(IN) :: Pkwater_equiv + REAL, INTENT(INOUT) :: Snowcov_area + DOUBLE PRECISION, INTENT(OUT) :: Ai + REAL, INTENT(INOUT) :: Snowcov_areasv + DOUBLE PRECISION, INTENT(INOUT) :: Pst, Scrv, Pksv + REAL, INTENT(OUT) :: Frac_swe +! Functions + INTRINSIC DBLE, SNGL + EXTERNAL :: sca_deplcrv +! Local Variables + REAL :: snowcov_area_ante + DOUBLE PRECISION :: fracy, difx, dify +!*********************************************************************** + snowcov_area_ante = Snowcov_area + ! Reset snowcover area to the maximum + Snowcov_area = Snarea_curve(11) ! [fraction of area] + + ! Track the maximum pack water equivalent for the current + ! snow pack + IF ( Pkwater_equiv>Pst ) Pst = Pkwater_equiv ! [inches] + + ! Set ai to the maximum packwater equivalent, but no higher than + ! the threshold for complete snow cover + Ai = Pst ! [inches] + IF ( Ai>Snarea_thresh ) Ai = DBLE( Snarea_thresh ) ! [inches] + + ! calculate the ratio of the current packwater equivalent to + ! the maximum packwater equivalent for the given snowpack + Frac_swe = SNGL( Pkwater_equiv/Ai ) ! [fraction] + + ! There are 3 potential conditions for the snow area curve: + ! A. snow is accumulating and the pack is currently at its + ! maximum level + ! B. snow is depleting and the area is determined by the + ! snow area curve + ! C. new snow has occured on a depleting pack, temporarily + ! resetting to 100% cover. + ! For case (C), the snow covered area is linearly interpolated + ! between 100% and the snow covered area before the new snow. + ! In general, 1/4 of the new snow has to melt before the snow + ! covered area goes below 100%, and then the remaining 3/4 has + ! to melt to return to the previous snow covered area. + + ! First, the code decides whether snow is accumulating (A) + ! or not (B/C). + ! 2 options below (if-then, else) + + ! (1) The pack water equivalent is at the maximum + IF ( Pkwater_equiv>=Ai ) THEN + ! Stay on the snow area curve (it will be at the maximum + ! because the pack water equivalent is equal to ai + ! and it can't be higher) + Iasw = 0 + + ! (2) The pack water equivalent is less than the maximum + ELSE + + ! If the snowpack isn't accumulating to a new maximum, + ! it is either on the curve (condition B above) or being + ! interpolated between the previous place on the curve and + ! 100% (condition C above) + ! 2 options below (if-then, elseif) + + ! (2.1) There was new snow... + IF ( Newsnow/=0 ) THEN + + ! New snow will always reset the snow cover to 100%. + ! However, different states changes depending on whether + ! the previous snow area condition was on the curve or + ! being interpolated between the curve and 100% + ! 2 options below (if-then, else) + + ! (2.1.1) The snow area is being interpolated between 100% + ! and a previous location on the curve... + IF ( Iasw>0 ) THEN + ! The location on the interpolated line is based on how + ! much of the new snow has melted. Because the first 1/4 + ! of the new snow doesn't matter, it has to keep track of + ! the current snow pack plus 3/4 of the new snow. + Scrv = Scrv + (0.75D0*DBLE(Net_snow)) ! [inches] + ! Scrv = Pkwater_equiv - (0.25D0*DBLE(Net_snow))) ! [inches] +!RAPCOMMENT - CHANGED TO INCREMENT THE SCRV VALUE IF ALREADY +! INTERPOLATING BETWEEN CURVE AND 100% + + ! (2.1.2) The current snow area is on the curve... + ELSE + ! If switching from the snow area curve to interpolation + ! between the curve and 100%, the current state of the snow + ! pack has to be saved so that the interpolation can + ! continue until back to the original conditions. + ! First, set the flag to indicate interpolation between 100% + ! and the previous area should be done + Iasw = 1 ! [flag] + ! Save the current snow covered area + ! (before the new net snow) + Snowcov_areasv = snowcov_area_ante ! [inches] + ! Save the current pack water equivalent + ! (before the new net snow) + Pksv = Pkwater_equiv - DBLE( Net_snow ) ! [inches] + ! The location on the interpolated line is based on how much + ! of the new snow has melted. Because the first 1/4 + ! of the new snow doesn't matter, it has to keep track of + ! the current snow pack plus 3/4 of the new snow. + Scrv = Pkwater_equiv - (0.25D0*DBLE(Net_snow)) ! [inches] + ENDIF + ! The subroutine terminates here because the snow covered area + ! always starts at 100% if there is any new snow (no need to + ! reset it from the maximum value set at the beginning of the + ! subroutine). + RETURN + + ! (2.2) There was no new snow, but the snow covered area is + ! currently being interpolated between 100% + ! from a previous new snow and the snow covered area + ! before that previous new snow... + ELSEIF ( Iasw/=0 ) THEN + ! If the first 1/4 of the previous new snow has not melted, + ! yet, then the snow covered area is still + ! 100% and the subroutine can terminate. + IF ( Pkwater_equiv>Scrv ) RETURN + + ! At this point, the program is almost sure it is + ! interpolating between the previous snow covered area and + ! 100%, but it is possible that enough snow has melted to + ! return to the snow covered area curve instead. + ! 2 options below (if-then, else) + + ! (2.2.1) The snow pack still has a larger water equivalent + ! than before the previous new snow. I.e., new snow + ! has not melted back to original area... + IF ( Pkwater_equiv>=Pksv ) THEN + ! Do the interpolation between 100% and the snow covered + ! area before the previous new snow. + + ! Calculate the difference between the maximum snow + ! covered area (remember that Snowcov_area is always + ! set to the maximum value at this point) and the snow + ! covered area before the last new snow. + difx = DBLE( Snowcov_area - Snowcov_areasv ) + ! Calculate the difference between the water equivalent + ! before the last new snow and the previous water + ! equivalent plus 3/4 of the last new snow. + ! In effect, get the value of 3/4 of the previous + ! new snow. + dify = Scrv - Pksv ! [inches] !gl1098 + + ! If 3/4 of the previous new snow is significantly + ! different from zero, then calculate the ratio of the + ! unmelted amount of previous new snow in the snow pack + ! to the value of 3/4 of previous new snow. + ! In effect, this is the fraction of the previous new snow + ! that determines the current interpolation + ! of snow covered area. + fracy = 0.0D0 ! [fraction] !gl1098 + IF ( dify>0.0D0 ) fracy = (Pkwater_equiv-Pksv)/dify + ! [fraction] + ! Linearly interpolate the new snow covered area. + Snowcov_area = Snowcov_areasv + SNGL(fracy*difx) + ! [fraction of area] + ! Terminate the subroutine + RETURN + + ! (2.2.2) The snow pack has returned to the snow water + ! equivalent before the previous new snow. I.e. back to + ! original area before new snow. + ELSE + ! Reset the flag to use the snow area curve + Iasw = 0 ! [flag] + ENDIF + + ENDIF + + ! If this subroutine is still running at this point, then the + ! program knows that the snow covered area needs to be + ! adjusted according to the snow covered area curve. So at + ! this point it must interpolate between points on the snow + ! covered area curve (not the same as interpolating between + ! 100% and the previous spot on the snow area depletion curve). + + CALL sca_deplcrv(Snowcov_area, Snarea_curve, Frac_swe) + + ENDIF + + END SUBROUTINE snowcov + +!*********************************************************************** +! Interpolate along snow covered area depletion curve +!*********************************************************************** + SUBROUTINE sca_deplcrv(Snowcov_area, Snarea_curve, Frac_swe) + IMPLICIT NONE +! Functions + INTRINSIC :: INT, FLOAT +! Arguments + REAL, INTENT(OUT) :: Snowcov_area + REAL, INTENT(IN) :: Snarea_curve(11), Frac_swe +! Local Variables + INTEGER :: idx, jdx + REAL :: af, dify, difx +!*********************************************************************** + IF ( Frac_swe>1.0 ) THEN + Snowcov_area = Snarea_curve(11) + ELSE + + ! get the indices (as integers) of the depletion curve that + ! bracket the given Frac_swe (next highest and next lowest) + idx = INT( 10.0*(Frac_swe+0.2) ) ! [index] + jdx = idx - 1 ! [index] + IF ( idx>11 ) idx = 11 + ! calculate the fraction of the distance (from the next lowest) + ! the given Frac_swe is between the next highest and lowest + ! curve values + af = FLOAT( jdx-1 ) + dify = (Frac_swe*10.0) - af ! [fraction] + ! calculate the difference in snow covered area represented + ! by next highest and lowest curve values + difx = Snarea_curve(idx) - Snarea_curve(jdx) + ! linearly interpolate a snow covered area between those + ! represented by the next highest and lowest curve values + Snowcov_area = Snarea_curve(jdx) + dify*difx + ENDIF + END SUBROUTINE sca_deplcrv + +!*********************************************************************** +! Set all glacier states to 0 +!*********************************************************************** + SUBROUTINE glacr_states_to_zero(Ihru, active_layer_present) + USE PRMS_SNOW, ONLY: Glacr_freeh2o_cap, Glacr_freeh2o_capm, Glacr_pk_def, Glacr_pk_depth, & + & Glacr_layer, Glacr_pk_temp, Ann_tempc, Glacr_pkwater_equiv, Glacr_pk_den, & + & Glacr_pk_ice, Glacr_pkwater_ante, Glacr_freeh2o, Glacr_pss, Glacr_pk_den + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Ihru, active_layer_present +! Functions + INTRINSIC ATAN, SNGL +! Local Variables + REAL :: reduce +!*********************************************************************** + IF ( Glacr_layer(Ihru)==0.0 .OR. active_layer_present==0) THEN + Glacr_pk_depth(Ihru) = 1.0D5 + Glacr_pk_temp(Ihru) = 0.0 + Glacr_pk_def(Ihru) = 0.0 + Glacr_freeh2o_capm(Ihru) = 0.0 + reduce = 1.0 + ElSE + Glacr_pk_depth(Ihru) = DBLE(Glacr_layer(Ihru)) + Glacr_pk_temp(Ihru) = Ann_tempc(Ihru) !start at average last year temp like Oerlemans 1992 + IF ( Glacr_pk_temp(Ihru) > 0.0) Glacr_pk_temp(Ihru) = 0.0 + Glacr_freeh2o_capm(Ihru) = Glacr_freeh2o_cap(Ihru) + reduce = 0.8 !if start Glacr_pk_ice too close to Glacr_pk_depth can't grow with energy loss to free water gain + ENDIF + Glacr_pk_den(Ihru) = 0.917 + Glacr_pkwater_equiv(Ihru) = Glacr_pk_den(Ihru)*Glacr_pk_depth(Ihru) + Glacr_pkwater_ante(Ihru) = Glacr_pkwater_equiv(Ihru) + Glacr_pk_ice(Ihru) = reduce*SNGL(Glacr_pkwater_equiv(Ihru)-Glacr_freeh2o(Ihru))/0.9340 !density of pure ice + Glacr_pss(Ihru) = Glacr_pkwater_equiv(Ihru) + + END SUBROUTINE glacr_states_to_zero + +!*********************************************************************** +! snowcomp_restart - write or read snowcomp restart file +!*********************************************************************** + SUBROUTINE snowcomp_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Glacier_flag + USE PRMS_SNOW + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variable + CHARACTER(LEN=8) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Deninv, Denmaxinv, Basin_snowmelt, Basin_pweqv, Basin_snowcov, & + & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal, Basin_glacrb_melt, & + & Basin_snowicecov, Basin_glacrevap + WRITE ( Restart_outunit ) Int_alb + WRITE ( Restart_outunit ) Scrv + WRITE ( Restart_outunit ) Pksv + WRITE ( Restart_outunit ) Snowcov_areasv + WRITE ( Restart_outunit ) Salb + WRITE ( Restart_outunit ) Slst + WRITE ( Restart_outunit ) Lst + WRITE ( Restart_outunit ) Iasw + WRITE ( Restart_outunit ) Iso + WRITE ( Restart_outunit ) Mso + WRITE ( Restart_outunit ) Lso + WRITE ( Restart_outunit ) Albedo + WRITE ( Restart_outunit ) Pk_temp + WRITE ( Restart_outunit ) Pk_den + WRITE ( Restart_outunit ) Pk_def + WRITE ( Restart_outunit ) Pk_ice + WRITE ( Restart_outunit ) Freeh2o + WRITE ( Restart_outunit ) Snowcov_area + WRITE ( Restart_outunit ) Pss + WRITE ( Restart_outunit ) Pst + WRITE ( Restart_outunit ) Snsv + WRITE ( Restart_outunit ) Pk_depth + WRITE ( Restart_outunit ) Pkwater_ante + IF ( Glacier_flag==1 ) THEN + WRITE ( Restart_outunit ) Glacrmelt + WRITE ( Restart_outunit ) Glacr_evap + WRITE ( Restart_outunit ) Glacr_albedo + WRITE ( Restart_outunit ) Glacr_pk_den + WRITE ( Restart_outunit ) Glacr_pk_ice + WRITE ( Restart_outunit ) Glacr_freeh2o + WRITE ( Restart_outunit ) Glacrcov_area + WRITE ( Restart_outunit ) Glacr_pss + WRITE ( Restart_outunit ) Glacr_pst + WRITE ( Restart_outunit ) Glacr_pk_depth + WRITE ( Restart_outunit ) Glacr_pkwater_equiv + WRITE ( Restart_outunit ) Glacr_pkwater_ante + WRITE ( Restart_outunit ) Glacr_pk_temp + WRITE ( Restart_outunit ) Ann_tempc, Yrdays5, Prev_ann_tempc + WRITE ( Restart_outunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp + WRITE ( Restart_outunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow + WRITE ( Restart_outunit ) Glacr_pk_def + WRITE ( Restart_outunit ) Glacrb_melt + WRITE ( Restart_outunit ) Glacr_freeh2o_capm + ENDIF + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Deninv, Denmaxinv, Basin_snowmelt, Basin_pweqv, Basin_snowcov, & + & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal, Basin_glacrb_melt, & + & Basin_snowicecov, Basin_glacrevap + READ ( Restart_inunit ) Int_alb + READ ( Restart_inunit ) Scrv + READ ( Restart_inunit ) Pksv + READ ( Restart_inunit ) Snowcov_areasv + READ ( Restart_inunit ) Salb + READ ( Restart_inunit ) Slst + READ ( Restart_inunit ) Lst + READ ( Restart_inunit ) Iasw + READ ( Restart_inunit ) Iso + READ ( Restart_inunit ) Mso + READ ( Restart_inunit ) Lso + READ ( Restart_inunit ) Albedo + READ ( Restart_inunit ) Pk_temp + READ ( Restart_inunit ) Pk_den + READ ( Restart_inunit ) Pk_def + READ ( Restart_inunit ) Pk_ice + READ ( Restart_inunit ) Freeh2o + READ ( Restart_inunit ) Snowcov_area + READ ( Restart_inunit ) Pss + READ ( Restart_inunit ) Pst + READ ( Restart_inunit ) Snsv + READ ( Restart_inunit ) Pk_depth + READ ( Restart_inunit ) Pkwater_ante + IF ( Glacier_flag==1 ) THEN + READ ( Restart_inunit ) Glacrmelt + READ ( Restart_inunit ) Glacr_evap + READ ( Restart_inunit ) Glacr_albedo + READ ( Restart_inunit ) Glacr_pk_den + READ ( Restart_inunit ) Glacr_pk_ice + READ ( Restart_inunit ) Glacr_freeh2o + READ ( Restart_inunit ) Glacrcov_area + READ ( Restart_inunit ) Glacr_pss + READ ( Restart_inunit ) Glacr_pst + READ ( Restart_inunit ) Glacr_pk_depth + READ ( Restart_inunit ) Glacr_pkwater_equiv + READ ( Restart_inunit ) Glacr_pkwater_ante + READ ( Restart_inunit ) Glacr_pk_temp + READ ( Restart_inunit ) Ann_tempc, Yrdays5, Prev_ann_tempc + READ ( Restart_inunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp + READ ( Restart_inunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow + READ ( Restart_inunit ) Glacr_pk_def + READ ( Restart_inunit ) Glacrb_melt + READ ( Restart_inunit ) Glacr_freeh2o_capm + ENDIF + ENDIF + END SUBROUTINE snowcomp_restart diff --git a/prms/soilzoneCfgim.f90 b/prms/soilzoneCfgim.f90 new file mode 100644 index 00000000..6ff97d73 --- /dev/null +++ b/prms/soilzoneCfgim.f90 @@ -0,0 +1,1875 @@ +!*********************************************************************** +! Computes inflows to and outflows from soil zone of each HRU and +! includes inflows from infiltration, groundwater, and upslope HRUs, +! and outflows to gravity drainage, interflow, and surface runoff to +! downslope HRUs; merge of smbal_prms and ssflow_prms with enhancements +! +! Daily accounting for soil zone; +! adds infiltration +! computes et +! computes recharge of soil zone +! computes interflow to stream or cascade +! adjusts storage in soil zone +! sends dunnian runoff to stream or cascade by adding to sroff +! computes drainage to groundwater +!*********************************************************************** + MODULE PRMS_SOILZONE + IMPLICIT NONE +! Local Variables + INTEGER, SAVE :: DBGUNT + CHARACTER(LEN=8), SAVE :: MODNAME + INTEGER, SAVE :: Max_gvrs, Et_type, Pref_flag, Is_land + INTEGER, SAVE, ALLOCATABLE :: Soil2gw(:), Pref_flow_flag(:) + REAL, SAVE, ALLOCATABLE :: Gvr2pfr(:), Swale_limit(:) + REAL, SAVE, ALLOCATABLE :: Soil_lower_stor_max(:) + REAL, SAVE, ALLOCATABLE :: Soil_moist_ante(:), Ssres_stor_ante(:) + REAL, SAVE, ALLOCATABLE :: Grav_dunnian_flow(:), Pfr_dunnian_flow(:) + DOUBLE PRECISION, SAVE :: Last_soil_moist, Last_ssstor +! GSFLOW variables + INTEGER, SAVE, ALLOCATABLE :: Hru_gvr_count(:), Hru_gvr_index(:, :), Hrucheck(:) + REAL, SAVE, ALLOCATABLE :: Replenish_frac(:) + REAL, SAVE, ALLOCATABLE :: It0_soil_rechr(:), It0_soil_moist(:) + REAL, SAVE, ALLOCATABLE :: It0_pref_flow_stor(:), It0_ssres_stor(:) + REAL, SAVE, ALLOCATABLE :: It0_gravity_stor_res(:), It0_sroff(:) + REAL, SAVE, ALLOCATABLE :: It0_slow_stor(:), It0_potet(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: It0_strm_seg_in(:) + DOUBLE PRECISION, SAVE :: It0_basin_soil_moist, It0_basin_ssstor, Basin_sz_gwin + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Gvr_hru_pct_adjusted(:) +! Declared Variables + DOUBLE PRECISION, SAVE :: Basin_sz2gw, Basin_cap_infil_tot + DOUBLE PRECISION, SAVE :: Basin_interflow_max, Basin_sm2gvr_max ! this is the same as basin_sm2gvr + DOUBLE PRECISION, SAVE :: Basin_soil_rechr, Basin_dunnian_gvr + DOUBLE PRECISION, SAVE :: Basin_recharge, Basin_pref_flow_infil + DOUBLE PRECISION, SAVE :: Basin_ssin, Basin_dunnian_pfr + DOUBLE PRECISION, SAVE :: Basin_sm2gvr, Basin_dninterflow + DOUBLE PRECISION, SAVE :: Basin_dncascadeflow, Basin_dndunnianflow + DOUBLE PRECISION, SAVE :: Basin_capwaterin, Basin_dunnian + DOUBLE PRECISION, SAVE :: Basin_gvr2pfr, Basin_slowflow + DOUBLE PRECISION, SAVE :: Basin_pref_stor, Basin_slstor, Basin_prefflow + DOUBLE PRECISION, SAVE :: Basin_lakeinsz, Basin_lakeprecip + DOUBLE PRECISION, SAVE :: Basin_cap_up_max + DOUBLE PRECISION, SAVE :: Basin_soil_moist_tot + DOUBLE PRECISION, SAVE :: Basin_soil_lower_stor_frac, Basin_soil_rechr_stor_frac, Basin_sz_stor_frac + DOUBLE PRECISION, SAVE :: Basin_cpr_stor_frac, Basin_gvr_stor_frac, Basin_pfr_stor_frac + REAL, SAVE, ALLOCATABLE :: Perv_actet(:), Pref_flow_thrsh(:) + REAL, SAVE, ALLOCATABLE :: Soil_moist_tot(:), Recharge(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Upslope_interflow(:), Upslope_dunnianflow(:), Lakein_sz(:) + REAL, SAVE, ALLOCATABLE :: Dunnian_flow(:), Cap_infil_tot(:) + REAL, SAVE, ALLOCATABLE :: Pref_flow_stor(:), Pref_flow(:) + REAL, SAVE, ALLOCATABLE :: Pref_flow_infil(:), Pref_flow_in(:) + REAL, SAVE, ALLOCATABLE :: Hru_sz_cascadeflow(:), Swale_actet(:) + REAL, SAVE, ALLOCATABLE :: Pref_flow_max(:), Snow_free(:) + REAL, SAVE, ALLOCATABLE :: Cap_waterin(:), Soil_lower(:), Soil_zone_max(:) + REAL, SAVE, ALLOCATABLE :: Potet_lower(:), Potet_rechr(:), Soil_lower_ratio(:) + REAL, SAVE, ALLOCATABLE :: Unused_potet(:) +! REAL, SAVE, ALLOCATABLE :: Cascade_interflow(:), Cascade_dunnianflow(:), Interflow_max(:) +! REAL, SAVE, ALLOCATABLE :: Cpr_stor_frac(:), Pfr_stor_frac(:), Gvr_stor_frac(:), Soil_moist_frac(:) +! REAL, SAVE, ALLOCATABLE :: Soil_rechr_ratio(:), Snowevap_aet_frac(:), Perv_avail_et(:), Cap_upflow_max(:) +! GSFLOW Declared Variables + DOUBLE PRECISION, SAVE :: Basin_gvr2sm + REAL, SAVE, ALLOCATABLE :: Sm2gw_grav(:), Gw2sm_grav(:) + REAL, SAVE, ALLOCATABLE :: Gravity_stor_res(:), Gvr2sm(:), Grav_gwin(:) +! Declared Parameters + INTEGER, SAVE, ALLOCATABLE :: Soil_type(:), Gvr_hru_id(:) + REAL, SAVE, ALLOCATABLE :: Pref_flow_den(:) + REAL, SAVE, ALLOCATABLE :: Fastcoef_lin(:), Fastcoef_sq(:) + REAL, SAVE, ALLOCATABLE :: Slowcoef_lin(:), Slowcoef_sq(:) + REAL, SAVE, ALLOCATABLE :: Ssr2gw_rate(:), Ssr2gw_exp(:) + REAL, SAVE, ALLOCATABLE :: Soil2gw_max(:) + REAL, SAVE, ALLOCATABLE :: Lake_evap_adj(:, :) + END MODULE PRMS_SOILZONE + +!*********************************************************************** +! Main soilzone routine +!*********************************************************************** + INTEGER FUNCTION soilzone() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: szdecl, szinit, szrun + EXTERNAL :: soilzone_restart +!*********************************************************************** + soilzone = 0 + + IF ( Process(:3)=='run' ) THEN + soilzone = szrun() + ELSEIF ( Process(:4)=='decl' ) THEN + soilzone = szdecl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL soilzone_restart(1) + soilzone = szinit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL soilzone_restart(0) + ENDIF + + END FUNCTION soilzone + +!*********************************************************************** +! szdecl - set up parameters for soil zone computations +! Declared Parameters +! sat_threshold, ssstor_init_frac fastcoef_lin, fastcoef_sq +! ssr2gw_rate, ssr2gw_exp, soil2gw_max, soil_type +! soil_rechr_max_frac, soil_rechr_init_frac, soil_moist_max, soil_moist_init_frac +! pref_flow_den, slowcoef_lin, cov_type +! hru_area, slowcoef_sq, gvr_hru_id +!*********************************************************************** + INTEGER FUNCTION szdecl() + USE PRMS_SOILZONE + USE PRMS_MODULE, ONLY: Model, Nhru, Nsegment, Nlake, Nhrucell, Print_debug, Cascade_flag, GSFLOW_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar, getdim + EXTERNAL :: read_error, print_module, PRMS_open_module_file +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_soilzone +!*********************************************************************** + szdecl = 0 + + Version_soilzone = 'soilzone.f90 2019-03-05 11:11:00Z' + CALL print_module(Version_soilzone, 'Soil Zone Computations ', 90 ) + MODNAME = 'soilzone' + +! Declare Variables + IF ( declvar(MODNAME, 'basin_capwaterin', 'one', 1, 'double', & + & 'Basin area-weighted average infiltration,'// & + & ' cascading interflow and Dunnian flow added to capillary reservoir storage', & + & 'inches', Basin_capwaterin)/=0 ) CALL read_error(3, 'basin_capwaterin') + + IF ( declvar(MODNAME, 'basin_cap_infil_tot', 'one', 1, 'double', & + & 'Basin area-weighted average infiltration with cascading flow into capillary reservoirs', & + & 'inches', Basin_cap_infil_tot)/=0 ) CALL read_error(3, 'basin_cap_infil_tot') + + IF ( declvar(MODNAME, 'basin_cap_up_max', 'one', 1, 'double', & + & 'Basin area-weighted average maximum cascade flow that flows to capillary reservoirs', & + & 'inches', Basin_cap_up_max)/=0 ) CALL read_error(3, 'basin_cap_up_max') + + IF ( declvar(MODNAME, 'basin_pref_flow_infil', 'one', 1, 'double', & + & 'Basin area-weighted average infiltration to preferential-flow reservoir storage', & + & 'inches', Basin_pref_flow_infil)/=0 ) CALL read_error(3, 'basin_pref_flow_infil') + + IF ( declvar(MODNAME, 'basin_dunnian_pfr', 'one', 1, 'double', & + & 'Basin area-weighted average excess infiltration to'// & + & ' preferential-flow reservoirs from variable infil', & + & 'inches', Basin_dunnian_pfr)/=0 ) CALL read_error(3, 'basin_dunnian_pfr') + + IF ( declvar(MODNAME, 'basin_dunnian_gvr', 'one', 1, 'double', & + & 'Basin area-weighted average excess flow to preferential'// & + & '-flow reservoirs from gravity reservoirs', & + & 'inches', Basin_dunnian_gvr)/=0 ) CALL read_error(3, 'basin_dunnian_gvr') + + ALLOCATE ( Cap_infil_tot(Nhru) ) + IF ( declvar(MODNAME, 'cap_infil_tot', 'nhru', Nhru, 'real', & + & 'Infiltration and cascading interflow and Dunnian'// & + & ' flow added to capillary reservoir storage for each HRU', & + & 'inches', Cap_infil_tot)/=0 ) CALL read_error(3, 'cap_infil_tot') + + IF ( declvar(MODNAME, 'basin_soil_moist_tot', 'one', 1, 'double', & + & 'Basin area-weighted average total soil-zone water storage', & + & 'inches', Basin_soil_moist_tot)/=0 ) CALL read_error(3, 'basin_soil_moist_tot') + + ALLOCATE ( Soil_moist_tot(Nhru) ) + IF ( declvar(MODNAME, 'soil_moist_tot', 'nhru', Nhru, 'real', & + & 'Total soil-zone water storage (soil_moist + ssres_stor)', & + & 'inches', Soil_moist_tot)/=0 ) CALL read_error(3, 'soil_moist_tot') + + IF ( declvar(MODNAME, 'basin_cpr_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of capillary reservoir storage of the maximum storage', & + & 'decimal fraction', Basin_cpr_stor_frac)/=0 ) CALL read_error(3, 'basin_cpr_stor_frac') + + IF ( declvar(MODNAME, 'basin_gvr_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of gravity reservoir storage of the maximum storage', & + & 'decimal fraction', Basin_gvr_stor_frac)/=0 ) CALL read_error(3, 'basin_gvr_stor_frac') + + IF ( declvar(MODNAME, 'basin_pfr_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of preferential-flow reservoir storage of the maximum storage', & + & 'decimal fraction', Basin_pfr_stor_frac)/=0 ) CALL read_error(3, 'basin_pfr_stor_frac') + + IF ( declvar(MODNAME, 'basin_soil_lower_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of soil lower zone storage of the maximum storage', & + & 'decimal fraction', Basin_soil_lower_stor_frac)/=0 ) CALL read_error(3, 'basin_soil_lower_stor_frac') + + IF ( declvar(MODNAME, 'basin_soil_rechr_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of soil recharge zone storage of the maximum storage', & + & 'decimal fraction', Basin_soil_rechr_stor_frac)/=0 ) CALL read_error(3, 'basin_soil_rechr_stor_frac') + + IF ( declvar(MODNAME, 'basin_sz_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of soil zone storage of the maximum storage', & + & 'decimal fraction', Basin_sz_stor_frac)/=0 ) CALL read_error(3, 'basin_sz_stor_frac') + +! ALLOCATE ( Cpr_stor_frac(Nhru) ) +! IF ( declvar(MODNAME, 'cpr_stor_frac', 'nhru', Nhru, 'real', & +! & 'Fraction of capillary reservoir storage of the maximum storage for each HRU', & +! & 'decimal fraction', Cpr_stor_frac)/=0 ) CALL read_error(3, 'cpr_stor_frac') + +! ALLOCATE ( Pfr_stor_frac(Nhru) ) +! IF ( declvar(MODNAME, 'pfr_stor_frac', 'nhru', Nhru, 'real', & +! & 'Fraction of preferential flow reservoir storage of the maximum storage for each HRU', & +! & 'decimal fraction', Pfr_stor_frac)/=0 ) CALL read_error(3, 'pfr_stor_frac') + +! ALLOCATE ( Gvr_stor_frac(Nhru) ) +! IF ( declvar(MODNAME, 'gvr_stor_frac', 'nhru', Nhru, 'real', & +! & 'Fraction of gravity reservoir storage of the maximum storage for each HRU', & +! & 'decimal fraction', Gvr_stor_frac)/=0 ) CALL read_error(3, 'gvr_stor_frac') + +! ALLOCATE ( Soil_moist_frac(Nhru) ) +! IF ( declvar(MODNAME, 'soil_moist_frac', 'nhru', Nhru, 'real', & +! & 'Fraction of soil zone storage of the maximum storage for each HRU', & +! & 'decimal fraction', Soil_moist_frac)/=0 ) CALL read_error(3, 'soil_moist_frac') + + IF ( declvar(MODNAME, 'basin_sm2gvr', 'one', 1, 'double', & + & 'Basin area-weighted average excess flow from'// & + & ' capillary reservoirs to gravity reservoir storage', & + & 'inches', Basin_sm2gvr)/=0 ) CALL read_error(3, 'basin_sm2gvr') + + IF ( declvar(MODNAME, 'basin_gvr2pfr', 'one', 1, 'double', & + & 'Basin area-weighted average excess flow to'// & + & ' preferential-flow reservoir storage from gravity reservoirs', & + & 'inches', Basin_gvr2pfr)/=0 ) CALL read_error(3, 'basin_gvr2pfr') + + IF ( declvar(MODNAME, 'basin_slowflow', 'one', 1, 'double', & + & 'Basin area-weighted average interflow from gravity reservoirs to the stream network', & + & 'inches', Basin_slowflow)/=0 ) CALL read_error(3, 'basin_slowflow') + + IF ( declvar(MODNAME, 'basin_prefflow', 'one', 1, 'double', & + & 'Basin area-weighted average interflow from'// & + & ' preferential-flow reservoirs to the stream network', & + & 'inches', Basin_prefflow)/=0 ) CALL read_error(3, 'basin_prefflow') + + IF ( declvar(MODNAME, 'basin_slstor', 'one', 1, 'double', & + & 'Basin area-weighted average storage of gravity reservoirs', & + & 'inches', Basin_slstor)/=0 ) CALL read_error(3, 'basin_slstor') + + ALLOCATE ( Dunnian_flow(Nhru) ) + IF ( declvar(MODNAME, 'dunnian_flow', 'nhru', Nhru, 'real', & + & 'Dunnian surface runoff that flows to the stream network for each HRU', & + & 'inches', Dunnian_flow)/=0 ) CALL read_error(3, 'dunnian_flow') + + IF ( declvar(MODNAME, 'basin_dunnian', 'one', 1, 'double', & + & 'Basin area-weighted average Dunnian surface runoff that flows to the stream network', & + & 'inches', Basin_dunnian)/=0 ) CALL read_error(3, 'basin_dunnian') + + IF ( declvar(MODNAME, 'basin_soil_rechr', 'one', 1, 'double', & + & 'Basin area-weighted average storage for recharge zone;'// & + & ' upper portion of capillary reservoir where both'// & + & ' evaporation and transpiration occurs', & + & 'inches', Basin_soil_rechr)/=0 ) CALL read_error(3, 'basin_soil_rechr') + + IF ( declvar(MODNAME, 'basin_sz2gw', 'one', 1, 'double', & + & 'Basin area-weighted average drainage from gravity reservoirs to GWRs', & + & 'inches', Basin_sz2gw)/=0 ) CALL read_error(3, 'basin_sz2gw') + + ALLOCATE ( Pref_flow_in(Nhru) ) + IF ( declvar('soilzone', 'pref_flow_in', 'nhru', Nhru, 'real', & + & 'Infiltration and flow from gravity reservoir to the preferential-flow reservoir', & + & 'inches', Pref_flow_in)/=0 ) CALL read_error(3, 'pref_flow_in') + + IF ( declvar(MODNAME, 'basin_sm2gvr_maxin', 'one', 1, 'double', & + & 'Basin area-weighted average maximum excess flow from'// & + & ' capillary reservoirs that flows to gravity reservoirs', & + & 'inches', Basin_sm2gvr_max)/=0 ) CALL read_error(3, 'basin_sm2gvr_max') + + IF ( declvar(MODNAME, 'basin_interflow_max', 'one', 1, 'double', & + & 'Basin area-weighted average maximum interflow that flows from gravity reservoirs', & + & 'inches', Basin_interflow_max)/=0 ) CALL read_error(3, 'basin_interflow_max') + + ALLOCATE ( Perv_actet(Nhru) ) + IF ( declvar(MODNAME, 'perv_actet', 'nhru', Nhru, 'real', & + & 'Actual ET from the capillary reservoir of each HRU', & + & 'inches', Perv_actet)/=0 ) CALL read_error(3, 'perv_actet') + +! ALLOCATE ( Perv_avail_et(Nhru) ) +! IF ( declvar(MODNAME, 'perv_avail_et', 'nhru', Nhru, 'real', & +! & 'Unsatisfied ET available to the capillary reservoir of each HRU', & +! & 'inches', Perv_avail_et)/=0 ) CALL read_error(3, 'perv_avail_et') + + ! added to be compatible with ssflow_prms + IF ( declvar(MODNAME, 'basin_ssin', 'one', 1, 'double', & + & 'Basin area-weighted average inflow to gravity and preferential-flow reservoir storage', & + & 'inches', Basin_ssin)/=0 ) CALL read_error(3, 'basin_ssin') + +! ALLOCATE ( Interflow_max(Nhru) ) +! IF ( declvar(MODNAME, 'interflow_max', 'nhru', Nhru, 'real', & +! & 'Maximum interflow for each HRU', & +! & 'inches', Interflow_max)/=0 ) CALL read_error(3, 'interflow_max') + + IF ( Cascade_flag>0 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'basin_dndunnianflow', 'one', 1, 'double', & + & 'Basin area-weighted average cascading Dunnian flow', & + & 'inches', Basin_dndunnianflow)/=0 ) CALL read_error(3, 'basin_dndunnianflow') + + IF ( declvar(MODNAME, 'basin_dninterflow', 'one', 1, 'double', & + & 'Basin area-weighted average cascading interflow', & + & 'inches', Basin_dninterflow)/=0 ) CALL read_error(3, 'basin_dninterflow') + + IF ( declvar(MODNAME, 'basin_dncascadeflow', 'one', 1, 'double', & + & 'Basin area-weighted average cascading interflow and Dunnian surface runoff', & + & 'inches', Basin_dncascadeflow)/=0 ) CALL read_error(3, 'basin_dncascadeflow') + + ALLOCATE ( Upslope_interflow(Nhru) ) + IF ( declvar(MODNAME, 'upslope_interflow', 'nhru', Nhru, 'double', & + & 'Cascading interflow runoff that flows to'// & + & ' the capillary reservoir of each downslope HRU for each upslope HRU', & + & 'inches', Upslope_interflow)/=0 ) CALL read_error(3, 'upslope_interflow') + + ALLOCATE ( Upslope_dunnianflow(Nhru) ) + IF ( declvar(MODNAME, 'upslope_dunnianflow', 'nhru', Nhru, 'double', & + & 'Cascading Dunnian surface runoff that'// & + & ' flows to the capillary reservoir of each downslope HRU for each upslope HRU', & + & 'inches', Upslope_dunnianflow)/=0 ) CALL read_error(3, 'upslope_dunnianflow') + + ALLOCATE ( Hru_sz_cascadeflow(Nhru) ) + IF ( declvar(MODNAME, 'hru_sz_cascadeflow', 'nhru', Nhru, 'real', & + & 'Cascading interflow and Dunnian surface runoff from each HRU', & + & 'inches', Hru_sz_cascadeflow)/=0 ) CALL read_error(3, 'hru_sz_cascadeflow') + +! ALLOCATE ( Cap_upflow_max(Nhru) ) +! IF ( declvar(MODNAME, 'cap_upflow_max', 'nhru', Nhru, 'real', & +! & 'Maximum infiltration and any cascading interflow and'// & +! & ' Dunnian surface runoff that can be added to capillary reservoir storage for each HRU', & +! & 'inches', Cap_upflow_max)/=0 ) CALL read_error(3, 'cap_upflow_max') + +! ALLOCATE ( Cascade_interflow(Nhru) ) +! IF ( declvar(MODNAME, 'cascade_interflow', 'nhru', Nhru, 'real', & +! & 'Cascading interflow for each HRU', & +! & 'inches', Cascade_interflow)/=0 ) CALL read_error(3, 'cascade_interflow') + +! ALLOCATE ( Cascade_dunnianflow(Nhru) ) +! IF ( declvar(MODNAME, 'cascade_dunnianflow', 'nhru', Nhru, 'real', & +! & 'Cascading Dunnian flow for each HRU', & +! & 'inches', Cascade_dunnianflow)/=0 ) CALL read_error(3, 'cascade_dunnianflow') + + IF ( Nlake>0 ) THEN + ALLOCATE ( Lakein_sz(Nhru) ) + IF ( declvar(MODNAME, 'lakein_sz', 'nhru', Nhru, 'double', & + & 'Cascading interflow and Dunnian surface runoff to lake HRUs for each upslope HRU', & + & 'inches', Lakein_sz)/=0 ) CALL read_error(3, 'lakein_sz') + + IF ( declvar(MODNAME, 'basin_lakeinsz', 'one', 1, 'double', & + & 'Basin area-weighted average lake inflow from land HRUs', & + & 'inches', Basin_lakeinsz)/=0 ) CALL read_error(3, 'basin_lakeinsz') + ENDIF + ENDIF + + IF ( declvar(MODNAME, 'basin_pref_stor', 'one', 1, 'double', & + & 'Basin area-weighted average storage in preferential-flow reservoirs', & + & 'inches', Basin_pref_stor)/=0 ) CALL read_error(3, 'basin_pref_stor') + + ALLOCATE ( Pref_flow_infil(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow_infil', 'nhru', Nhru, 'real', & + & 'Infiltration to the preferential-flow reservoir storage for each HRU', & + & 'inches', Pref_flow_infil)/=0 ) CALL read_error(3, 'pref_flow_infil') + + ALLOCATE ( Pref_flow_stor(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow_stor', 'nhru', Nhru, 'real', & + & 'Storage in preferential-flow reservoir for each HRU', & + & 'inches', Pref_flow_stor)/=0 ) CALL read_error(3, 'pref_flow_stor') + + ALLOCATE ( Pref_flow(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow', 'nhru', Nhru, 'real', & + & 'Interflow from the preferential-flow reservoir that'// & + & ' flows to the stream network for each HRU', & + & 'inches', Pref_flow)/=0 ) CALL read_error(3, 'pref_flow') + + ALLOCATE ( Pref_flow_thrsh(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow_thrsh', 'nhru', Nhru, 'real', & + & 'Soil storage threshold defining storage between field'// & + & ' capacity and maximum soil saturation minus preferential-flow storage', & + & 'inches', Pref_flow_thrsh)/=0 ) CALL read_error(3, 'pref_flow_thrsh') + + ALLOCATE ( Pref_flow_max(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow_max', 'nhru', Nhru, 'real', & + & 'Maximum storage of the preferential-flow reservoir for each HRU', & + & 'inches', Pref_flow_max)/=0 ) CALL read_error(3, 'pref_flow_max') + + ALLOCATE ( Soil_zone_max(Nhru) ) +! IF ( declvar(MODNAME, 'soil_zone_max', 'nhru', Nhru, 'real', & +! & 'Maximum storage of all soil zone reservoirs', & +! & 'inches', Soil_zone_max)/=0 ) CALL read_error(3, 'soil_zone_max') + + IF ( declvar(MODNAME, 'basin_lakeprecip', 'one', 1, 'double', & + & 'Basin area-weighted average precipitation on lake HRUs', & + & 'inches', Basin_lakeprecip)/=0 ) CALL read_error(3, 'basin_lakeprecip') + + ALLOCATE ( Swale_actet(Nhru) ) + IF ( declvar(MODNAME, 'swale_actet', 'nhru', Nhru, 'real', & + & 'Evaporation from the gravity and preferential-flow reservoirs that exceeds sat_threshold', & + & 'inches', Swale_actet)/=0 ) CALL read_error(3, 'swale_actet') + + IF ( declvar(MODNAME, 'basin_recharge', 'one', 1, 'double', & + & 'Basin area-weighted average recharge to GWRs', & + & 'inches', Basin_recharge)/=0 ) CALL read_error(3, 'basin_recharge') + + ALLOCATE ( Recharge(Nhru) ) + IF ( declvar(MODNAME, 'recharge', 'nhru', Nhru, 'real', & + & 'Recharge to the associated GWR as sum of soil_to_gw and ssr_to_gw for each HRU', & + & 'inches', Recharge)/=0 ) CALL read_error(3, 'recharge') + + ALLOCATE ( Cap_waterin(Nhru) ) + IF ( declvar(MODNAME, 'cap_waterin', 'nhru', Nhru, 'real', & + & 'Infiltration and any cascading interflow and'// & + & ' Dunnian surface runoff added to capillary reservoir storage for each HRU', & + & 'inches', Cap_waterin)/=0 ) CALL read_error(3, 'cap_waterin') + + ALLOCATE ( Soil_lower(Nhru) ) + IF ( declvar(MODNAME, 'soil_lower', 'nhru', Nhru, 'real', & + & 'Storage in the lower zone of the capillary'// & + & ' reservoir that is only available for transpiration for each HRU', & + & 'inches', Soil_lower)/=0 ) CALL read_error(3, 'soil_lower') + + ALLOCATE ( Potet_lower(Nhru) ) + IF ( declvar(MODNAME, 'potet_lower', 'nhru', Nhru, 'real', & + & 'Potential ET in the lower zone of the capillary reservoir for each HRU', & + & 'inches', Potet_lower)/=0 ) CALL read_error(3, 'potet_lower') + + ALLOCATE ( Potet_rechr(Nhru) ) + IF ( declvar(MODNAME, 'potet_rechr', 'nhru', Nhru, 'real', & + & 'Potential ET in the recharge zone of the capillary reservoir for each HRU', & + & 'inches', Potet_rechr)/=0 ) CALL read_error(3, 'potet_rechr') + + ALLOCATE ( Soil_lower_ratio(Nhru), Soil_lower_stor_max(Nhru) ) + IF ( declvar(MODNAME, 'soil_lower_ratio', 'nhru', Nhru, 'real', & + & 'Water content ratio in the lower zone of the capillary reservoir for each HRU', & + & 'decimal fraction', Soil_lower_ratio)/=0 ) CALL read_error(3, 'soil_lower_ratio') + +! ALLOCATE ( Soil_rechr_ratio(Nhru) ) +! IF ( declvar(MODNAME, 'soil_rechr_ratio', 'nhru', Nhru, 'real', & +! & 'Water content ratio in the recharge zone of the capillary reservoir for each HRU', & +! & 'decimal fraction', Soil_rechr_ratio)/=0 ) CALL read_error(3, 'soil_rechr_ratio') + + ALLOCATE ( Snow_free(Nhru) ) + IF ( declvar(MODNAME, 'snow_free', 'nhru', Nhru, 'real', & + & 'Fraction of snow-free surface for each HRU', & + & 'decimal fraction', Snow_free)/=0 ) CALL read_error(3, 'snow_free') + + ALLOCATE ( Unused_potet(Nhru) ) + IF ( declvar(MODNAME, 'unused_potet', 'nhru', Nhru, 'real', & + & 'Unsatisfied potential evapotranspiration', & + & 'inches', Unused_potet)/=0 ) CALL read_error(3, 'unused_potet') + +! ALLOCATE ( Snowevap_aet_frac(Nhru) ) +! IF ( declvar(MODNAME, 'snowevap_aet_frac', 'nhru', Nhru, 'double', & +! & 'Fraction of sublimation of AET for each HRU', & +! & 'decimal fraction', Snowevap_aet_frac)/=0 ) CALL read_error(3, 'snowevap_aet_frac') + + IF ( GSFLOW_flag==1 .OR. Model==99 ) THEN + IF ( Nhrucell<-1 ) STOP 'ERROR, dimension nhrucell not specified > 0' + ALLOCATE ( Gravity_stor_res(Nhrucell) ) + IF ( declvar(MODNAME, 'gravity_stor_res', 'nhrucell', Nhrucell, 'real', & + & 'Storage in each gravity-flow reservoir', & + & 'inches', Gravity_stor_res)/=0 ) CALL read_error(3, 'gravity_stor_res') + + ALLOCATE ( Sm2gw_grav(Nhrucell) ) + IF ( declvar(MODNAME, 'sm2gw_grav', 'nhrucell', Nhrucell, 'real', & + & 'Drainage from each gravity reservoir to each MODFLOW cell', & + & 'inches', Sm2gw_grav)/=0 ) CALL read_error(3, 'sm2gw_grav') + + IF ( declvar(MODNAME, 'basin_gvr2sm', 'one', 1, 'double', & + & 'Basin area-weighted average gravity flow to capillary reservoirs', & + & 'inches', Basin_gvr2sm)/=0 ) CALL read_error(3, 'basin_gvr2sm') + + ALLOCATE ( Gvr2sm(Nhru) ) + IF ( declvar(MODNAME, 'gvr2sm', 'nhru', Nhru, 'real', & + & 'Gravity flow to soil moist replenishment for each HRU', & + & 'inches', Gvr2sm)/=0 ) CALL read_error(3, 'gvr2sm') + + ALLOCATE ( Gw2sm_grav(Nhrucell) ) + IF ( declvar(MODNAME, 'gw2sm_grav', 'nhrucell', Nhrucell, 'real', & + & 'Groundwater discharge to gravity-flow reservoirs', & + & 'inches', Gw2sm_grav)/=0 ) CALL read_error(3, 'gw2sm_grav') + + ALLOCATE ( Grav_gwin(Nhru) ) ! ??? + IF ( declvar(MODNAME, 'grav_gwin', 'nhru', Nhru, 'real', & + & 'Groundwater discharge to gravity-flow reservoirs for each HRU', & + & 'inches', Grav_gwin)/=0 ) CALL read_error(3, 'grav_gwin') + + ALLOCATE ( Gvr_hru_pct_adjusted(Nhrucell) ) + ALLOCATE ( Hru_gvr_count(Nhru), Hrucheck(Nhru) ) + ALLOCATE ( It0_pref_flow_stor(Nhru), It0_ssres_stor(Nhru), It0_soil_rechr(Nhru), It0_soil_moist(Nhru) ) + ALLOCATE ( It0_gravity_stor_res(Nhrucell), It0_sroff(Nhru), It0_slow_stor(Nhru) ) + ALLOCATE ( It0_strm_seg_in(Nsegment), It0_potet(Nhru), Replenish_frac(Nhru) ) + ENDIF + +! Allocate arrays for local and variables from other modules + ALLOCATE ( Soil2gw(Nhru), Gvr2pfr(Nhru), Swale_limit(Nhru), Pref_flow_flag(Nhru) ) + ALLOCATE ( Pfr_dunnian_flow(Nhru), Grav_dunnian_flow(Nhru) ) + IF ( Print_debug==1 ) ALLOCATE( Soil_moist_ante(Nhru), Ssres_stor_ante(Nhru) ) + + IF ( Print_debug==7 ) CALL PRMS_open_module_file(DBGUNT, 'soilzone.dbg') + +! Declare Parameters + IF ( GSFLOW_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Gvr_hru_id(Nhrucell) ) + IF ( Nhru/=Nhrucell ) THEN + IF ( declparam(MODNAME, 'gvr_hru_id', 'nhrucell', 'integer', & + & '0', 'bounded', 'nhru', & + & 'Corresponding HRU id of each GVR', & + & 'Index of the HRU associated with each gravity reservoir', & + & 'none')/=0 ) CALL read_error(1, 'gvr_hru_id') + ENDIF + ENDIF + + IF ( Nlake>0 ) THEN + ALLOCATE ( Lake_evap_adj(12,Nlake) ) + IF ( declparam(MODNAME, 'lake_evap_adj', 'nmonths,nlake', & + & 'real', '1.0', '0.5', '1.0', & + & 'Monthly potet factor to adjust potet on lakes', & + & 'Monthly (January to December) adjustment factor for potential ET for each lake', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'lake_evap_adj') + ENDIF + + ALLOCATE ( Slowcoef_lin(Nhru) ) + IF ( declparam(MODNAME, 'slowcoef_lin', 'nhru', 'real', & + & '0.015', '0.0', '1.0', & + & 'Linear gravity-flow reservoir routing coefficient', & + & 'Linear coefficient in equation to route gravity-reservoir storage downslope for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'slowcoef_lin') + + ALLOCATE ( Slowcoef_sq(Nhru) ) + IF ( declparam(MODNAME, 'slowcoef_sq', 'nhru', 'real', & + & '0.1', '0.0', '1.0', & + & 'Non-linear gravity-flow reservoir routing coefficient', & + & 'Non-linear coefficient in equation to route'// & + & ' gravity-reservoir storage downslope for each HRU', & + & 'none')/=0 ) CALL read_error(1, 'slowcoef_sq') + + ALLOCATE ( Pref_flow_den(Nhru) ) + IF ( declparam(MODNAME, 'pref_flow_den', 'nhru', 'real', & + & '0.0', '0.0', '0.5', & + & 'Fraction of the soil zone in which preferential flow occurs for each HRU', & + & 'Fraction of the soil zone in which preferential flow occurs for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1,'pref_flow_den') + + ALLOCATE ( Soil2gw_max(Nhru) ) + IF ( declparam(MODNAME, 'soil2gw_max', 'nhru', 'real', & + & '0.0', '0.0', '5.0', & + & 'Maximum value for capillary reservoir excess to GWR', & + & 'Maximum amount of the capillary reservoir excess that'// & + & ' is routed directly to the GWR for each HRU', & + & 'inches')/=0 ) CALL read_error(1, 'soil2gw_max') + + ALLOCATE ( Soil_type(Nhru) ) + IF ( declparam(MODNAME, 'soil_type', 'nhru', 'integer', & + & '2', '1', '3', & + & 'HRU soil type', 'Soil type of each HRU (1=sand; 2=loam; 3=clay)', & + & 'none')/=0 ) CALL read_error(1, 'soil_type') + + ALLOCATE ( Fastcoef_lin(Nhru) ) + IF ( declparam(MODNAME, 'fastcoef_lin', 'nhru', 'real', & + & '0.1', '0.0', '1.0', & + & 'Linear preferential-flow routing coefficient', & + & 'Linear coefficient in equation to route preferential-flow storage downslope for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'fastcoef_lin') + + ALLOCATE ( Fastcoef_sq(Nhru) ) + IF ( declparam(MODNAME, 'fastcoef_sq', 'nhru', 'real', & + & '0.8', '0.0', '1.0', & + & 'Non-linear preferential-flow routing coefficient', & + & 'Non-linear coefficient in equation used to route'// & + & ' preferential-flow storage downslope for each HRU', & + & 'none')/=0 ) CALL read_error(1, 'fastcoef_sq') + + ALLOCATE ( Ssr2gw_rate(Nhru) ) + IF ( declparam(MODNAME, 'ssr2gw_rate', 'nssr', 'real', & + & '0.1', '0.0001', '1.0', & + & 'Coefficient to route water from gravity reservoir to GWR', & + & 'Linear coefficient in equation used to route water from'// & + & ' the gravity reservoir to the GWR for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'ssr2gw_rate') + + ALLOCATE ( Ssr2gw_exp(Nhru) ) + IF ( declparam(MODNAME, 'ssr2gw_exp', 'nssr', 'real', & + & '1.0', '0.0', '3.0', & + & 'Coefficient to route water from subsurface to groundwater', & + & 'Non-linear coefficient in equation used to route water'// & + & ' from the gravity reservoir to the GWR for each HRU', & + & 'none')/=0 ) CALL read_error(1, 'ssr2gw_exp') + + END FUNCTION szdecl + +!*********************************************************************** +! szinit - Initialize soilzone module - get parameter values, +! set initial values and check parameter values +!*********************************************************************** + INTEGER FUNCTION szinit() + USE PRMS_SOILZONE + USE PRMS_MODULE, ONLY: Nhru, Nssr, Nlake, GSFLOW_flag, Nhrucell, & + & Parameter_check_flag, Cascade_flag, Init_vars_from_file, Inputerror_flag + USE PRMS_BASIN, ONLY: Hru_type, Hru_perv, & + & Basin_area_inv, Hru_area, Hru_frac_perv, Numlake_hrus + USE PRMS_FLOWVARS, ONLY: Soil_moist_max, Soil_rechr_max, & + & Ssres_stor, Basin_ssstor, Basin_soil_moist, Slow_stor, & + & Soil_moist, Sat_threshold, Soil_rechr + USE PRMS_SNOW, ONLY: Snowcov_area + IMPLICIT NONE +! Functions + EXTERNAL :: init_basin_vars, checkdim_bounded_limits + INTEGER, EXTERNAL :: getparam + INTRINSIC MIN, DBLE +! Local Variables + INTEGER :: i, ii, ihru, icnt + REAL :: hruarea, hruperv +!*********************************************************************** + szinit = 0 + + IF ( getparam(MODNAME, 'slowcoef_lin', Nhru, 'real', Slowcoef_lin)/=0 ) CALL read_error(2, 'slowcoef_lin') + IF ( getparam(MODNAME, 'slowcoef_sq', Nhru, 'real', Slowcoef_sq)/=0 ) CALL read_error(2, 'slowcoef_sq') + IF ( getparam(MODNAME, 'pref_flow_den', Nhru, 'real', Pref_flow_den)/=0 ) CALL read_error(2, 'pref_flow_den') + IF ( getparam(MODNAME, 'fastcoef_lin', Nhru, 'real', Fastcoef_lin)/=0 ) CALL read_error(2, 'fastcoef_lin') + IF ( getparam(MODNAME, 'fastcoef_sq', Nhru, 'real', Fastcoef_sq)/=0 ) CALL read_error(2, 'fastcoef_sq') + IF ( getparam(MODNAME, 'ssr2gw_rate', Nssr, 'real', Ssr2gw_rate)/=0 ) CALL read_error(2, 'ssr2gw_rate') + IF ( getparam(MODNAME, 'ssr2gw_exp', Nssr, 'real', Ssr2gw_exp)/=0 ) CALL read_error(2, 'ssr2gw_exp') + IF ( getparam(MODNAME, 'soil_type', Nhru, 'integer', Soil_type)/=0 ) CALL read_error(2, 'soil_type') + IF ( getparam(MODNAME, 'soil2gw_max', Nhru, 'real', Soil2gw_max)/=0 ) CALL read_error(2, 'soil2gw_max') + IF ( Nlake>0 ) THEN + IF ( getparam(MODNAME, 'lake_evap_adj', 12*Nlake, 'real', Lake_evap_adj)/=0 ) CALL read_error(2, 'lake_evap_adj') + ENDIF + + IF ( GSFLOW_flag==1 ) THEN + IF ( Nhru/=Nhrucell ) THEN + IF ( getparam(MODNAME, 'gvr_hru_id', Nhrucell, 'integer', Gvr_hru_id)/=0 ) CALL read_error(2, 'gvr_hru_id') + IF ( Parameter_check_flag==1 ) & + & CALL checkdim_bounded_limits('gvr_hru_id', 'nhru', Gvr_hru_id, Nhrucell, 1, Nhru, Inputerror_flag) + ELSE + DO i = 1, Nhru + Gvr_hru_id(i) = i + ENDDO + ENDIF + Grav_gwin = 0.0 ! dimension nhru + Gw2sm_grav = 0.0 + ENDIF + + Swale_limit = 0.0 + Soil2gw = 0 + Pref_flow_flag = 0 + Pref_flag = 0 + Pfr_dunnian_flow = 0.0 + Grav_dunnian_flow = 0.0 + Soil_lower_ratio = 0.0 + Pref_flow_thrsh = 0.0 + + Basin_soil_moist = 0.0D0 + Basin_slstor = 0.0D0 + Basin_ssstor = 0.0D0 + Basin_pref_stor = 0.0D0 + Basin_soil_rechr = 0.0D0 + Basin_soil_moist_tot = 0.0D0 + Basin_soil_lower_stor_frac = 0.0D0 + Basin_soil_rechr_stor_frac = 0.0D0 + Basin_sz_stor_frac = 0.0D0 + Basin_cpr_stor_frac = 0.0D0 + Basin_gvr_stor_frac = 0.0D0 + Basin_pfr_stor_frac = 0.0D0 +! Pfr_stor_frac = 0.0 +! Gvr_stor_frac = 0.0 +! Cpr_stor_frac = 0.0 +! Soil_moist_frac = 0.0 + + DO i = 1, Nhru + Snow_free(i) = 1.0 - Snowcov_area(i) + + IF ( Hru_type(i)==0 .OR. Hru_type(i)==2 ) THEN !if inactive or lake + Soil_rechr(i) = 0.0 + Soil_moist(i) = 0.0 + Ssres_stor(i) = 0.0 + Slow_stor(i) = 0.0 + Pref_flow_stor(i) = 0.0 + Soil_moist_tot(i) = 0.0 + Soil_lower(i) = 0.0 +! Soil_rechr_ratio(i) = 0.0 + Soil_zone_max(i) = 0.0 + Soil_lower_stor_max(i) = 0.0 + Sat_threshold(i) = 0.0 + Pref_flow_den(i) = 0.0 + Pref_flow_max(i) = 0.0 + CYCLE + ENDIF + + IF ( Hru_type(i)==3 ) THEN ! swale + Swale_limit(i) = 3.0*Sat_threshold(i) + Pref_flow_den(i) = 0.0 + Pref_flow_thrsh(i) = Sat_threshold(i) + Pref_flow_max(i) = 0.0 + ELSE ! land + Pref_flow_thrsh(i) = Sat_threshold(i)*(1.0-Pref_flow_den(i)) + Pref_flow_max(i) = Sat_threshold(i) - Pref_flow_thrsh(i) + ENDIF + + ! hru_type = 1 or 3 + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==5 ) THEN + Slow_stor(i) = MIN( Ssres_stor(i), Pref_flow_thrsh(i) ) + Pref_flow_stor(i) = Ssres_stor(i) - Slow_stor(i) + ENDIF + IF ( Soil2gw_max(i)>0.0 ) Soil2gw(i) = 1 + IF ( Hru_type(i)==1 .OR. Hru_type(i)==4 ) THEN ! interflow coefficient values don't matter unless land HRU + IF ( Pref_flow_den(i)>0.0 ) THEN + Pref_flow_flag(i) = 1 + Pref_flag = 1 + ENDIF + ENDIF + + hruarea = Hru_area(i) + hruperv = Hru_perv(i) + Soil_zone_max(i) = Sat_threshold(i) + Soil_moist_max(i)*Hru_frac_perv(i) + Soil_moist_tot(i) = Ssres_stor(i) + Soil_moist(i)*Hru_frac_perv(i) +! Soil_moist_frac(i) = Soil_moist_tot(i)/Soil_zone_max(i) +! Cpr_stor_frac(i) = Soil_moist(i)/Soil_moist_max(i) +! IF ( Pref_flow_thrsh(i)>0.0 ) Gvr_stor_frac(i) = Slow_stor(i)/Pref_flow_thrsh(i) +! Basin_cpr_stor_frac = Basin_cpr_stor_frac + DBLE( Cpr_stor_frac(i)*hruperv ) +! Basin_gvr_stor_frac = Basin_gvr_stor_frac + DBLE( Gvr_stor_frac(i)*hruarea ) + Basin_cpr_stor_frac = Basin_cpr_stor_frac + DBLE( Soil_moist(i)/Soil_moist_max(i)*hruperv ) + IF ( Pref_flow_thrsh(i)>0.0 ) Basin_gvr_stor_frac = Basin_gvr_stor_frac + DBLE( Slow_stor(i)/Pref_flow_thrsh(i)*hruarea ) + Soil_lower(i) = Soil_moist(i) - Soil_rechr(i) + Soil_lower_stor_max(i) = Soil_moist_max(i) - Soil_rechr_max(i) + IF ( Soil_lower_stor_max(i)>0.0 ) Soil_lower_ratio(i) = Soil_lower(i)/Soil_lower_stor_max(i) +! Soil_rechr_ratio(i) = Soil_rechr(i)/Soil_rechr_max(i) +! Basin_sz_stor_frac = Basin_sz_stor_frac + DBLE( Soil_moist_frac(i)*hruarea ) + Basin_sz_stor_frac = Basin_sz_stor_frac + DBLE( Soil_moist_tot(i)/Soil_zone_max(i)*hruarea ) + Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac + DBLE( Soil_lower_ratio(i)*hruperv ) +! Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + DBLE( Soil_rechr_ratio(i)*hruperv ) + Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + DBLE( Soil_rechr(i)/Soil_rechr_max(i)*hruperv ) + Basin_soil_moist = Basin_soil_moist + DBLE( Soil_moist(i)*Hru_perv(i) ) + Basin_soil_moist_tot = Basin_soil_moist_tot + DBLE( Soil_moist_tot(i)*hruarea ) + ! rsr, 6/12/2014 potential problem for GSFLOW if sum of slow_stor /= gravity_stor_res + Basin_slstor = Basin_slstor + DBLE( Slow_stor(i)*hruarea ) + Basin_ssstor = Basin_ssstor + DBLE( Ssres_stor(i)*hruarea ) + Basin_soil_rechr = Basin_soil_rechr + DBLE( Soil_rechr(i)*hruperv ) + IF ( Pref_flow_flag(i)==1 ) THEN + Basin_pref_stor = Basin_pref_stor + DBLE( Pref_flow_stor(i)*hruarea ) +! Pfr_stor_frac(i) = Pref_flow_stor(i)/Pref_flow_max(i) +! Basin_pfr_stor_frac = Basin_pfr_stor_frac + DBLE( Pfr_stor_frac(i)*hruarea ) + Basin_pfr_stor_frac = Basin_pfr_stor_frac + DBLE( Pref_flow_stor(i)/Pref_flow_max(i)*hruarea ) + ENDIF + ENDDO + Basin_soil_rechr = Basin_soil_rechr*Basin_area_inv + Basin_ssstor = Basin_ssstor*Basin_area_inv + Basin_slstor = Basin_slstor*Basin_area_inv + Basin_soil_moist = Basin_soil_moist*Basin_area_inv + Basin_soil_moist_tot = Basin_soil_moist_tot*Basin_area_inv + Basin_pref_stor = Basin_pref_stor*Basin_area_inv + Last_soil_moist = Basin_soil_moist + Last_ssstor = Basin_ssstor + Basin_cpr_stor_frac = Basin_cpr_stor_frac*Basin_area_inv + Basin_gvr_stor_frac = Basin_gvr_stor_frac*Basin_area_inv + Basin_pfr_stor_frac = Basin_pfr_stor_frac*Basin_area_inv + Basin_sz_stor_frac = Basin_sz_stor_frac*Basin_area_inv + Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac*Basin_area_inv + Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac*Basin_area_inv + +! initialize arrays (dimensioned Nhru) + Dunnian_flow = 0.0 + IF ( Cascade_flag>0 ) THEN + Upslope_interflow = 0.0D0 + Upslope_dunnianflow = 0.0D0 + Hru_sz_cascadeflow = 0.0 +! Cap_upflow_max = 0.0 +! Cascade_interflow = 0.0 +! Cascade_dunnianflow = 0.0 + IF ( Numlake_hrus>0 ) Lakein_sz = 0.0D0 + ENDIF + Cap_infil_tot = 0.0 + Pref_flow_infil = 0.0 + Pref_flow_in = 0.0 + Pref_flow = 0.0 + Gvr2pfr = 0.0 + Swale_actet = 0.0 + Perv_actet = 0.0 +! Perv_avail_et = 0.0 + Recharge = 0.0 + Cap_waterin = 0.0 + Potet_lower = 0.0 + Potet_rechr = 0.0 + Unused_potet = 0.0 ! dimension nhru +! Interflow_max = 0.0 +! Snowevap_aet_frac = 0.0 + + ! initialize scalers + IF ( Init_vars_from_file==0 ) CALL init_basin_vars() + +! initialize GSFLOW arrays + IF ( GSFLOW_flag==1 ) THEN + Gvr2sm = 0.0 ! dimension nhru + Sm2gw_grav = 0.0 ! dimension nhrucell + + Max_gvrs = 1 + Hrucheck = 1 + Hru_gvr_count = 0 + DO i = 1, Nhrucell + ihru = Gvr_hru_id(i) + IF ( Hru_type(ihru)==0 .OR. Hru_type(ihru)==2 ) THEN + Gravity_stor_res(i) = 0.0 + Hrucheck(ihru) = 0 + Replenish_frac(ihru) = 0.0 + ELSE + ! set only for cold start simulations + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==5 ) & + & Gravity_stor_res(i) = Ssres_stor(ihru) + Hru_gvr_count(ihru) = Hru_gvr_count(ihru) + 1 + IF ( Hru_gvr_count(ihru)>Max_gvrs ) Max_gvrs = Hru_gvr_count(ihru) + Replenish_frac(ihru) = Soil_rechr_max(ihru)/Soil_moist_max(ihru) + ENDIF + ENDDO + ALLOCATE ( Hru_gvr_index(Max_gvrs, Nhru) ) + IF ( Nhru==Nhrucell ) THEN + IF ( Max_gvrs/=1 ) THEN + PRINT *, 'ERROR, nhru=nhrucell, but, gvr_hru_id array specifies more than one GVR for an HRU' + STOP + ENDIF + DO i = 1, Nhru + Hru_gvr_index(1, i) = i + ENDDO + ELSE + Hru_gvr_index = 0 + DO i = 1, Nhru + IF ( Hru_type(i)==0 .OR. Hru_type(i)==2 ) CYCLE !if inactive or lake + icnt = 0 + DO ii = 1, Nhrucell + IF ( Gvr_hru_id(ii)==i ) THEN + icnt = icnt + 1 + Hru_gvr_index(icnt, i) = ii + IF ( icnt==Hru_gvr_count(i) ) EXIT + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + END FUNCTION szinit + +!*********************************************************************** +! szrun - Does soil water balance for each HRU, adds in infiltration +! then computes actual et and apportions remainder between +! recharge of soil moisture, soil storage available for +! interflow, excess routed to stream, +! and groundwater reservoirs +!*********************************************************************** + INTEGER FUNCTION szrun() + USE PRMS_SOILZONE + USE PRMS_MODULE, ONLY: Dprst_flag, Print_debug, Kkiter, & + & GSFLOW_flag, Nlake, Cascade_flag, Dprst_flag, Frozen_flag + USE PRMS_BASIN, ONLY: Hru_type, Hru_perv, Hru_frac_perv, & + & Hru_route_order, Active_hrus, Basin_area_inv, Hru_area, & + & NEARZERO, Lake_hru_id, Cov_type, Numlake_hrus, Hru_area_dble + USE PRMS_CLIMATEVARS, ONLY: Hru_ppt, Transp_on, Potet, Basin_potet +! WARNING!!! Sroff, Basin_sroff, and Strm_seg_in can be updated + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_actet, Hru_actet, & + & Ssres_flow, Soil_to_gw, Basin_soil_to_gw, Ssr_to_gw, & + & Soil_to_ssr, Basin_lakeevap, Basin_perv_et, Basin_swale_et, & + & Sroff, Soil_moist_max, Infil, Soil_rechr_max, Ssres_in, & + & Basin_soil_moist, Basin_ssstor, Slow_stor, Slow_flow, & + & Ssres_stor, Soil_moist, Sat_threshold, Soil_rechr, Basin_lake_stor + USE PRMS_CASCADE, ONLY: Ncascade_hru + USE PRMS_SET_TIME, ONLY: Nowmonth !, Nowday + USE PRMS_INTCP, ONLY: Hru_intcpevap + USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap + USE PRMS_SRUNOFF, ONLY: Basin_sroff, Hru_impervevap, Strm_seg_in, Dprst_evap_hru, & + & Dprst_seep_hru, Frozen, Thaw_depth, Frz_depth, Soil_depth + IMPLICIT NONE +! Functions + INTRINSIC MIN, ABS, MAX, SNGL, DBLE + EXTERNAL compute_soilmoist, compute_szactet, compute_cascades, compute_gravflow + EXTERNAL compute_interflow, compute_gwflow, init_basin_vars, print_date +! Local Variables + INTEGER :: i, k, update_potet + REAL :: dunnianflw, interflow, perv_area, harea + REAL :: dnslowflow, dnpreflow, dndunn, availh2o, avail_potet + REAL :: gvr_maxin, topfr !, tmp + REAL :: dunnianflw_pfr, dunnianflw_gvr, pref_flow_maxin + REAL :: perv_frac, capacity, capwater_maxin, ssresin + REAL :: cap_upflow_max, unsatisfied_et, pervactet, prefflow + REAL :: prefflowmax, soilmoistmax, soilrechrmax, thaw_frac ! frozen ground + REAL :: soil2gwmax, ssr2gwrate ! frozen ground + DOUBLE PRECISION :: gwin + INTEGER :: cfgi_frozen_hru +!*********************************************************************** + szrun = 0 + + IF ( GSFLOW_flag==1 ) THEN + IF ( Kkiter==0 ) STOP 'ERROR, problem with KKITER, equals 0' + + IF ( Kkiter==1 ) THEN +! It0 variables used with MODFLOW integration to save iteration states. + DO k = 1, Active_hrus + i = Hru_route_order(k) + It0_soil_rechr(i) = Soil_rechr(i) + It0_soil_moist(i) = Soil_moist(i) + It0_ssres_stor(i) = Ssres_stor(i) + It0_pref_flow_stor(i) = Pref_flow_stor(i) + It0_slow_stor(i) = Slow_stor(i) + It0_sroff(i) = Sroff(i) + It0_potet(i) = Potet(i) + ENDDO + It0_basin_soil_moist = Basin_soil_moist + It0_basin_ssstor = Basin_ssstor + It0_gravity_stor_res = Gravity_stor_res + It0_strm_seg_in = Strm_seg_in + Gw2sm_grav = 0.0 + ELSE + DO k = 1, Active_hrus + i = Hru_route_order(k) + Soil_rechr(i) = It0_soil_rechr(i) + Soil_moist(i) = It0_soil_moist(i) + Ssres_stor(i) = It0_ssres_stor(i) + Pref_flow_stor(i) = It0_pref_flow_stor(i) + Slow_stor(i) = It0_slow_stor(i) + Sroff(i) = It0_sroff(i) + Potet(i) = It0_potet(i) + ENDDO + Basin_soil_moist = It0_basin_soil_moist + Basin_ssstor = It0_basin_ssstor + Gravity_stor_res = It0_gravity_stor_res + Strm_seg_in = It0_strm_seg_in + ENDIF + Sm2gw_grav = 0.0 + ENDIF + + IF ( Cascade_flag>0 ) THEN + DO k = 1, Active_hrus + i = Hru_route_order(k) + Upslope_interflow(i) = 0.0D0 + Upslope_dunnianflow(i) = 0.0D0 + ENDDO + IF ( Numlake_hrus>0 ) THEN + Lakein_sz = 0.0D0 + Basin_lakeinsz = 0.0D0 + ENDIF + ENDIF + + IF ( Print_debug==1 ) THEN + Soil_moist_ante = Soil_moist + Ssres_stor_ante = Ssres_stor + Last_soil_moist = Basin_soil_moist + Last_ssstor = Basin_ssstor + ENDIF + CALL init_basin_vars() + gwin = 0.0D0 + Basin_soil_moist = 0.0D0 + Basin_slstor = 0.0D0 + Basin_ssstor = 0.0D0 + Basin_pref_stor = 0.0D0 + Basin_soil_rechr = 0.0D0 + Basin_soil_moist_tot = 0.0D0 + Basin_cpr_stor_frac = 0.0D0 + Basin_gvr_stor_frac = 0.0D0 + Basin_pfr_stor_frac = 0.0D0 + update_potet = 0 + DO k = 1, Active_hrus + i = Hru_route_order(k) + + Hru_actet(i) = Hru_impervevap(i) + Hru_intcpevap(i) + Snow_evap(i) + IF ( Dprst_flag==1 ) Hru_actet(i) = Hru_actet(i) + Dprst_evap_hru(i) + harea = Hru_area(i) + + IF ( Hru_type(i)==2 ) THEN ! lake or reservoir + !WARNING, RSR, if hru_actet>water in lake, then budget error + Hru_actet(i) = (Potet(i) - Hru_actet(i))*Lake_evap_adj(Nowmonth,Lake_hru_id(i)) + IF ( Hru_actet(i)>Potet(i) ) THEN + PRINT *, 'WARNING, lake evap > potet, for HRU:', i, ' potential ET increased to adjusted lake ET' + PRINT *, Hru_actet(i), Potet(i), Hru_actet(i) - Potet(i) + Basin_potet = Basin_potet - DBLE( Potet(i)*harea ) + Potet(i) = Hru_actet(i) ! this could be a problem when it happens + Basin_potet = Basin_potet + DBLE( Potet(i)*harea ) + update_potet = 1 + ENDIF + Unused_potet(i) = Potet(i) - Hru_actet(i) + Basin_actet = Basin_actet + DBLE( Hru_actet(i)*harea ) + Basin_lakeevap = Basin_lakeevap + DBLE( Hru_actet(i)*harea ) + Basin_lakeprecip = Basin_lakeprecip + DBLE( Hru_ppt(i)*harea ) + IF ( Cascade_flag>0 ) THEN + ! if lake HRU doesn't cascade, should we limit ET to + ! water entering the HRU to this point (no gwflow yet) + Lakein_sz(i) = Upslope_interflow(i) + Upslope_dunnianflow(i) + Basin_lakeinsz = Basin_lakeinsz + Lakein_sz(i)*Hru_area_dble(i) + ENDIF + CYCLE + ENDIF + + perv_area = Hru_perv(i) + perv_frac = Hru_frac_perv(i) + + ! Soil_to_gw for whole HRU + Soil_to_gw(i) = 0.0 + Ssr_to_gw(i) = 0.0 + Slow_flow(i) = 0.0 + Ssres_flow(i) = 0.0 + avail_potet = Potet(i) - Hru_actet(i) + IF ( avail_potet<0.0 ) avail_potet = 0.0 +! Snowevap_aet_frac(i) = 0.0 + + !Hru_type can be 1 (land) or 3 (swale) or 4 (glacier) + Is_land = 0 + IF ( Hru_type(i)==1 .OR. Hru_type(i)==4 ) Is_land = 1 + +!******Add infiltration to soil and compute excess + ! note, perv_area has to be > 0.0 + dunnianflw = 0.0 + dunnianflw_pfr = 0.0 + dunnianflw_gvr = 0.0 + interflow = 0.0 + pref_flow_maxin = 0.0 + +!******Add infiltration to soil and compute excess + !infil_tot is the depth in whole HRU + !capillary reservoir for pervious area + !preferential flow reservoir for whole HRU + !gravity reservoir for whole HRU + !upslope flow for whole HRU + +!******if cascading flow available from upslope cascades +!****** add soil excess (Dunnian flow) to infiltration + ! perv_frac has to be > 0.001 + ! infil for pervious portion of HRU + capwater_maxin = Infil(i) + + cfgi_frozen_hru = 0 + thaw_frac = 1.0 + !Frozen is HRU variable that says if frozen gravity reservoir + ! For CFGI all inflow is assumed to be Dunnian Flow when frozen + IF ( Frozen_flag==1 ) THEN + IF ( Frozen(i)>=1 ) THEN + IF ( Hru_type(i)==3 ) THEN + PRINT *, 'ERROR, a swale HRU cannot be frozen for CFGI, HRU:', i + STOP + ENDIF + cfgi_frozen_hru = Frozen(i) + IF ( cfgi_frozen_hru==1 ) THEN + thaw_frac = 0.0 + ELSEIF ( cfgi_frozen_hru==2 ) THEN + thaw_frac = Thaw_depth(i)/Soil_depth(i) + ENDIF + ENDIF + ENDIF + + ! compute preferential flow and storage, and any dunnian flow + prefflow = 0.0 + prefflowmax = Pref_flow_max(i)*thaw_frac + IF ( Pref_flow_flag(i)==1 ) THEN + Pref_flow_infil(i) = 0.0 + IF ( capwater_maxin>0.0 ) THEN + ! pref_flow for whole HRU + pref_flow_maxin = capwater_maxin*Pref_flow_den(i) + capwater_maxin = capwater_maxin - pref_flow_maxin + pref_flow_maxin = pref_flow_maxin*perv_frac + IF ( cfgi_frozen_hru==1 ) THEN !frozen to top + dunnianflw_pfr = pref_flow_maxin + Basin_dunnian_pfr = Basin_dunnian_pfr + dunnianflw_pfr*harea + ELSE + ! compute contribution to preferential-flow reservoir storage + Pref_flow_stor(i) = Pref_flow_stor(i) + pref_flow_maxin + dunnianflw_pfr = MAX( 0.0, Pref_flow_stor(i)-prefflowmax) + IF ( dunnianflw_pfr>0.0 ) THEN + Basin_dunnian_pfr = Basin_dunnian_pfr + dunnianflw_pfr*harea + Pref_flow_stor(i) = prefflowmax + ENDIF + Pref_flow_infil(i) = pref_flow_maxin - dunnianflw_pfr + Basin_pref_flow_infil = Basin_pref_flow_infil + Pref_flow_infil(i)*harea + ENDIF + Pfr_dunnian_flow(i) = dunnianflw_pfr + ENDIF + ENDIF + + IF ( Cascade_flag>0 ) THEN +! Cap_upflow_max(i) = SNGL(Upslope_dunnianflow(i)+Upslope_interflow(i))/perv_frac +! capwater_maxin = capwater_maxin + Cap_upflow_max(i) +! Basin_cap_up_max = Basin_cap_up_max + Cap_upflow_max(i)*perv_area + cap_upflow_max = SNGL(Upslope_dunnianflow(i)+Upslope_interflow(i))/perv_frac + capwater_maxin = capwater_maxin + cap_upflow_max + Basin_cap_up_max = Basin_cap_up_max + cap_upflow_max*perv_area + ENDIF + Cap_infil_tot(i) = capwater_maxin*perv_frac + Basin_cap_infil_tot = Basin_cap_infil_tot + DBLE( Cap_infil_tot(i)*harea ) + +!******Add infiltration to soil and compute excess + gvr_maxin = 0.0 + Cap_waterin(i) = capwater_maxin + soilmoistmax = Soil_moist_max(i)*thaw_frac + soilrechrmax = Soil_rechr_max(i)*thaw_frac + soil2gwmax = Soil2gw_max(i) + ssr2gwrate = Ssr2gw_rate(i) + IF ( cfgi_frozen_hru==3 ) THEN + soil2gwmax = 0.0 + Soil2gw(i) = 0 + ssr2gwrate = 0.0 + ENDIF + IF ( cfgi_frozen_hru/=1 ) THEN !some infiltration because not all the way frozen + ! call even if capwate_maxin = 0, just in case soil_moist now > Soil_moist_max + IF ( capwater_maxin+Soil_moist(i)>0.0 ) THEN + CALL compute_soilmoist(Cap_waterin(i), soilmoistmax, & + & soilrechrmax, soil2gwmax, gvr_maxin, & + & Soil_moist(i), Soil_rechr(i), Soil_to_gw(i), Soil2gw(i), perv_frac) + Cap_waterin(i) = Cap_waterin(i)*perv_frac + Basin_capwaterin = Basin_capwaterin + DBLE( Cap_waterin(i)*harea ) + Basin_soil_to_gw = Basin_soil_to_gw + DBLE( Soil_to_gw(i)*harea ) + Basin_sm2gvr_max = Basin_sm2gvr_max + DBLE( gvr_maxin*harea ) + ENDIF + ENDIF + ! Soil_to_ssr for whole HRU + Soil_to_ssr(i) = gvr_maxin + +! compute slow interflow and ssr_to_gw, changed to say effected by frozen state, already effected by reduced gvr_maxin if soil frozen + topfr = 0.0 + IF ( GSFLOW_flag==1 ) THEN + ! capacity for whole HRU + capacity = (soilmoistmax - Soil_moist(i))*perv_frac + CALL compute_gravflow(i, capacity, Slowcoef_lin(i), & + & Slowcoef_sq(i), ssr2gwrate, Ssr2gw_exp(i), & + & gvr_maxin, Pref_flow_thrsh(i), topfr, & + & Ssr_to_gw(i), Slow_flow(i), Slow_stor(i), & + & Gvr2sm(i), Soil_to_gw(i), gwin, Hru_type(i)) + ! adjust soil moisture with replenish amount + IF ( Gvr2sm(i)>0.0 ) THEN + Soil_moist(i) = Soil_moist(i) + Gvr2sm(i)/perv_frac +! IF ( Soil_moist(i)>soilmoistmax ) & +! & PRINT *, 'sm>max', Soil_moist(i), soilmoistmax, i + Soil_rechr(i) = Soil_rechr(i) + Gvr2sm(i)/perv_frac*Replenish_frac(i) + Soil_rechr(i) = MIN( soilrechrmax, Soil_rechr(i) ) + Basin_gvr2sm = Basin_gvr2sm + DBLE( Gvr2sm(i)*harea ) +! ELSEIF ( Gvr2sm(i)<-NEARZERO ) THEN +! PRINT *, 'negative gvr2sm, HRU:', i, Gvr2sm(i) +! Gvr2sm(i) = 0.0 + ENDIF + Grav_gwin(i) = SNGL( gwin ) + Basin_sz_gwin = Basin_sz_gwin + gwin*DBLE( harea ) + ELSEIF + availh2o = Slow_stor(i) + gvr_maxin + IF ( Hru_type(i)==1 ) THEN + topfr = MAX( 0.0, availh2o-Pref_flow_thrsh(i) ) + ssresin = gvr_maxin - topfr + Slow_stor(i) = availh2o - topfr + ! compute slow contribution to interflow, if any + IF ( Slow_stor(i)>0.0 ) & + & CALL compute_interflow(Slowcoef_lin(i), Slowcoef_sq(i), & + & ssresin, Slow_stor(i), Slow_flow(i)) + ELSEIF ( Hru_type(i)==3 ) THEN + Slow_stor(i) = availh2o + ENDIF + IF ( Slow_stor(i)>0.0 .AND. ssr2gwrate>0.0 ) & + & CALL compute_gwflow(ssr2gwrate, Ssr2gw_exp(i), Ssr_to_gw(i), Slow_stor(i)) + ENDIF + + ! compute contribution to Dunnian flow from PFR, if any + IF ( Pref_flow_flag(i)==1 ) THEN + availh2o = Pref_flow_stor(i) + topfr + dunnianflw_gvr = MAX( 0.0, availh2o-prefflowmax ) + IF ( dunnianflw_gvr>0.0 ) THEN + topfr = topfr - dunnianflw_gvr + IF ( topfr<0.0 ) THEN +! IF ( topfr<-NEARZERO .AND. Print_debug>-1 ) PRINT *, 'gvr2pfr<0', topfr, dunnianflw_gvr, & +! & prefflowmax, Pref_flow_stor(i), gvr_maxin + topfr = 0.0 + ENDIF + ENDIF + Pref_flow_in(i) = Pref_flow_infil(i) + topfr + Pref_flow_stor(i) = Pref_flow_stor(i) + topfr + IF ( Pref_flow_stor(i)>0.0 ) & + & CALL compute_interflow(Fastcoef_lin(i), Fastcoef_sq(i), & + & Pref_flow_in(i), Pref_flow_stor(i), prefflow) + Basin_pref_stor = Basin_pref_stor + DBLE( Pref_flow_stor(i)*harea ) + Pfr_stor_frac(i) = 0.0 +! IF ( thaw_frac>0.0 ) Pfr_stor_frac(i) = Pref_flow_stor(i)/prefflowmax +! Basin_pfr_stor_frac = Basin_pfr_stor_frac + Pfr_stor_frac(i)*harea + IF ( prefflowmax>0) Basin_pfr_stor_frac = Basin_pfr_stor_frac + Pref_flow_stor(i)/prefflowmax*harea + ELSEIF ( Hru_type(i)==1 ) THEN + dunnianflw_gvr = topfr !?? is this right + ENDIF + Gvr2pfr(i) = topfr + + Basin_sm2gvr = Basin_sm2gvr + DBLE( Soil_to_ssr(i)*harea ) + Basin_dunnian_gvr = Basin_dunnian_gvr + DBLE( dunnianflw_gvr*harea ) + Basin_sz2gw = Basin_sz2gw + DBLE( Ssr_to_gw(i)*harea ) + +!******Compute actual evapotranspiration + Snow_free(i) = 1.0 - Snowcov_area(i) + Potet_rechr(i) = 0.0 + Potet_lower(i) = 0.0 + pervactet = 0.0 + IF ( Soil_moist(i)>0.0 .AND. cfgi_frozen_hru==0 ) THEN + CALL compute_szactet(soilmoistmax, soilrechrmax, Transp_on(i), Cov_type(i), & + & Soil_type(i), Soil_moist(i), Soil_rechr(i), pervactet, & + & avail_potet, Snow_free(i), Potet_rechr(i), Potet_lower(i)) + ! sanity check +! IF ( pervactet>avail_potet ) THEN +! Soil_moist(i) = Soil_moist(i) + pervactet - avail_potet +! pervactet = avail_potet +! PRINT *, 'perv_et problem', pervactet, Avail_potet +! ENDIF + ENDIF +! Perv_avail_et(i) = avail_potet + + ! sanity check +! IF ( Soil_moist(i)<0.0 ) THEN +! IF ( Print_debug>-1 ) PRINT *, i, Soil_moist(i), ' negative' +! IF ( pervactet>=ABS(Soil_moist(i)) ) THEN +! pervactet = pervactet + Soil_moist(i) +! Soil_moist(i) = 0.0 +! ENDIF +! IF ( Soil_moist(i)<-NEARZERO ) THEN +! IF ( Print_debug>-1 ) PRINT *, 'HRU:', i, ' soil_moist<0.0', Soil_moist(i) +! ENDIF +! Soil_moist(i) = 0.0 +! ENDIF + + Hru_actet(i) = Hru_actet(i) + pervactet*perv_frac + avail_potet = Potet(i) - Hru_actet(i) + ! sanity check +! IF ( avail_potet<0.0 ) THEN +! IF ( Print_debug>-1 ) THEN +! IF ( avail_potet<-NEARZERO ) PRINT *, 'hru_actet>potet', i, & +! & Nowmonth, Nowday, Hru_actet(i), Potet(i), avail_potet +! ENDIF +! Hru_actet(i) = Potet(i) +! tmp = avail_potet/perv_frac +! pervactet = pervactet + tmp +! Soil_moist(i) = Soil_moist(i) - tmp +! Soil_rechr(i) = Soil_rechr(i) - tmp +! IF ( Soil_rechr(i)<0.0 ) Soil_rechr(i) = 0.0 +! IF ( Soil_moist(i)<0.0 ) Soil_moist(i) = 0.0 +! ENDIF + Perv_actet(i) = pervactet + +! soil_moist & soil_rechr multiplied by perv_area instead of harea + Soil_lower(i) = Soil_moist(i) - Soil_rechr(i) + Basin_soil_moist = Basin_soil_moist + DBLE( Soil_moist(i)*perv_area ) + Basin_soil_rechr = Basin_soil_rechr + DBLE( Soil_rechr(i)*perv_area ) + Basin_perv_et = Basin_perv_et + DBLE( Perv_actet(i)*perv_area ) + +! if HRU cascades, +! compute interflow and excess flow to each HRU or stream + IF ( Is_land==1 ) THEN + interflow = Slow_flow(i) + prefflow +! Interflow_max(i) = interflow + Basin_interflow_max = Basin_interflow_max + interflow*harea + dunnianflw = dunnianflw_gvr + dunnianflw_pfr + Dunnian_flow(i) = dunnianflw + IF ( Cascade_flag>0 ) THEN + IF ( Ncascade_hru(i)>0 ) THEN + dnslowflow = 0.0 + dnpreflow = 0.0 + dndunn = 0.0 + IF ( interflow+dunnianflw>0.0 ) THEN + CALL compute_cascades(i, Ncascade_hru(i), Slow_flow(i), & + & prefflow, Dunnian_flow(i), dnslowflow, & + & dnpreflow, dndunn) + Basin_dninterflow = Basin_dninterflow + DBLE( (dnslowflow+dnpreflow)*harea ) + Basin_dndunnianflow = Basin_dndunnianflow + DBLE( dndunn*harea ) + ENDIF + Hru_sz_cascadeflow(i) = dnslowflow + dnpreflow + dndunn +! Cascade_interflow(i) = dnslowflow + dnpreflow +! Cascade_dunnianflow(i) = dndunn + Basin_dncascadeflow = Basin_dncascadeflow + DBLE( Hru_sz_cascadeflow(i)*harea ) + ENDIF + ENDIF + +! treat pref_flow as interflow + Ssres_flow(i) = Slow_flow(i) + IF ( Pref_flow_flag(i)==1 ) THEN + Pref_flow(i) = prefflow + Ssres_flow(i) = Ssres_flow(i) + prefflow + Basin_prefflow = Basin_prefflow + DBLE( prefflow*harea ) + Basin_gvr2pfr = Basin_gvr2pfr + DBLE( Gvr2pfr(i)*harea ) + ENDIF + Basin_ssflow = Basin_ssflow + DBLE( Ssres_flow(i)*harea ) + Basin_slowflow = Basin_slowflow + DBLE( Slow_flow(i)*harea ) + +! treat dunnianflw as surface runoff to streams + Sroff(i) = Sroff(i) + Dunnian_flow(i) + Basin_sroff = Basin_sroff + DBLE( Sroff(i)*harea ) + Basin_dunnian = Basin_dunnian + DBLE( Dunnian_flow(i)*harea ) + Ssres_stor(i) = Slow_stor(i) + Pref_flow_stor(i) + + ELSE ! for swales + availh2o = Slow_stor(i) - Sat_threshold(i) + Swale_actet(i) = 0.0 + IF ( availh2o>0.0 ) THEN ! if ponding, as storage > sat_threshold + unsatisfied_et = Potet(i) - Hru_actet(i) + IF ( unsatisfied_et>0.0 ) THEN + availh2o = MIN ( availh2o, unsatisfied_et ) + Swale_actet(i) = availh2o + Hru_actet(i) = Hru_actet(i) + Swale_actet(i) + Slow_stor(i) = Slow_stor(i) - Swale_actet(i) + Basin_swale_et = Basin_swale_et + DBLE( Swale_actet(i)*harea ) + ENDIF + IF ( Print_debug==7 ) THEN + IF ( Slow_stor(i)>Swale_limit(i) ) THEN + WRITE ( DBGUNT, * ) 'Swale ponding, HRU:', i, & + & ' gravity reservoir is 3*sat_threshold', Slow_stor(i), Sat_threshold(i) + CALL print_date(DBGUNT) + ENDIF + ENDIF + ENDIF + Ssres_stor(i) = Slow_stor(i) + ENDIF + + IF ( Soil_lower_stor_max(i)>0.0 ) Soil_lower_ratio(i) = Soil_lower(i)/Soil_lower_stor_max(i) +! Soil_rechr_ratio(i) = 0.0 +! IF ( thaw_frac>0.0 ) Soil_rechr_ratio(i) = Soil_rechr(i)/soilrechrmax + Ssres_in(i) = Soil_to_ssr(i) + Pref_flow_infil(i) + SNGL( gwin ) + Basin_ssin = Basin_ssin + DBLE( Ssres_in(i)*harea ) + Basin_ssstor = Basin_ssstor + DBLE( Ssres_stor(i)*harea ) + Basin_slstor = Basin_slstor + DBLE( Slow_stor(i)*harea ) + Soil_moist_tot(i) = Ssres_stor(i) + Soil_moist(i)*perv_frac + Basin_soil_moist_tot = Basin_soil_moist_tot + DBLE( Soil_moist_tot(i)*harea ) +! Soil_moist_frac(i) = Soil_moist_tot(i)/Soil_zone_max(i) +! Cpr_stor_frac(i) = 0.0 +! IF ( thaw_frac>0.0 ) Cpr_stor_frac(i) = Soil_moist(i)/soilmoistmax +! IF ( Pref_flow_thrsh(i)>0.0 ) Gvr_stor_frac(i) = Slow_stor(i)/Pref_flow_thrsh(i) +! Basin_cpr_stor_frac = Basin_cpr_stor_frac + Cpr_stor_frac(i)*perv_area +! Basin_gvr_stor_frac = Basin_gvr_stor_frac + Gvr_stor_frac(i)*harea +! Basin_sz_stor_frac = Basin_sz_stor_frac + Soil_moist_frac(i)*harea + IF ( thaw_frac>0.0 ) Basin_cpr_stor_frac = Basin_cpr_stor_frac + Soil_moist(i)/soilmoistmax*perv_area + IF ( Pref_flow_thrsh(i)>0.0 ) Basin_gvr_stor_frac = Basin_gvr_stor_frac + Slow_stor(i)/Pref_flow_thrsh(i)*harea + Basin_sz_stor_frac = Basin_sz_stor_frac + Soil_moist_tot(i)/Soil_zone_max(i)*harea + Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac + Soil_lower_ratio(i)*perv_area +! Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + Soil_rechr_ratio(i)*perv_area + IF ( soilrechrmax>0 ) Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + Soil_rechr(i)/soilrechrmax*perv_area + Recharge(i) = Soil_to_gw(i) + Ssr_to_gw(i) + IF ( Dprst_flag==1 ) Recharge(i) = Recharge(i) + SNGL( Dprst_seep_hru(i) ) + Basin_recharge = Basin_recharge + DBLE( Recharge(i)*harea ) + Grav_dunnian_flow(i) = dunnianflw_gvr + Unused_potet(i) = Potet(i) - Hru_actet(i) + Basin_actet = Basin_actet + DBLE( Hru_actet(i)*harea ) +! IF ( Hru_actet(i)>0.0 ) Snowevap_aet_frac(i) = Snow_evap(i)/Hru_actet(i) + + ENDDO + Basin_actet = Basin_actet*Basin_area_inv + Basin_perv_et = Basin_perv_et*Basin_area_inv + Basin_swale_et = Basin_swale_et*Basin_area_inv + Basin_soil_rechr = Basin_soil_rechr*Basin_area_inv + Basin_soil_to_gw = Basin_soil_to_gw*Basin_area_inv + Basin_soil_moist = Basin_soil_moist*Basin_area_inv + IF ( update_potet==1 ) Basin_potet = Basin_potet*Basin_area_inv + Basin_soil_moist_tot = Basin_soil_moist_tot*Basin_area_inv + IF ( Nlake>0 ) THEN + Basin_lakeevap = Basin_lakeevap*Basin_area_inv + Basin_lakeprecip = Basin_lakeprecip*Basin_area_inv + Basin_lakeinsz = Basin_lakeinsz*Basin_area_inv + Basin_lake_stor = Basin_lake_stor + Basin_lakeprecip - Basin_lakeevap + ENDIF + IF ( Pref_flag==1 ) THEN + Basin_pref_stor = Basin_pref_stor*Basin_area_inv + Basin_pref_flow_infil = Basin_pref_flow_infil*Basin_area_inv + Basin_prefflow = Basin_prefflow*Basin_area_inv + Basin_dunnian_pfr = Basin_dunnian_pfr*Basin_area_inv + Basin_pfr_stor_frac = Basin_pfr_stor_frac*Basin_area_inv + ENDIF + Basin_dunnian_gvr = Basin_dunnian_gvr*Basin_area_inv + Basin_ssstor = Basin_ssstor*Basin_area_inv + Basin_ssflow = Basin_ssflow*Basin_area_inv + Basin_interflow_max = Basin_interflow_max*Basin_area_inv + Basin_sz2gw = Basin_sz2gw*Basin_area_inv + Basin_ssin = Basin_ssin*Basin_area_inv + Basin_slstor = Basin_slstor*Basin_area_inv + Basin_sroff = Basin_sroff*Basin_area_inv + Basin_dunnian = Basin_dunnian*Basin_area_inv + Basin_sm2gvr = Basin_sm2gvr*Basin_area_inv + Basin_sm2gvr_max = Basin_sm2gvr_max*Basin_area_inv + Basin_capwaterin = Basin_capwaterin*Basin_area_inv + Basin_cap_infil_tot = Basin_cap_infil_tot*Basin_area_inv + Basin_cap_up_max = Basin_cap_up_max*Basin_area_inv + Basin_dninterflow = Basin_dninterflow*Basin_area_inv + Basin_dndunnianflow = Basin_dndunnianflow*Basin_area_inv + Basin_dncascadeflow = Basin_dncascadeflow*Basin_area_inv + Basin_gvr2pfr = Basin_gvr2pfr*Basin_area_inv + Basin_slowflow = Basin_slowflow*Basin_area_inv + Basin_recharge = Basin_recharge*Basin_area_inv + Basin_gvr2sm = Basin_gvr2sm*Basin_area_inv + Basin_sz_gwin = Basin_sz_gwin*Basin_area_inv + Basin_cpr_stor_frac = Basin_cpr_stor_frac*Basin_area_inv + Basin_gvr_stor_frac = Basin_gvr_stor_frac*Basin_area_inv + Basin_sz_stor_frac = Basin_sz_stor_frac*Basin_area_inv + Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac*Basin_area_inv + Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac*Basin_area_inv + + END FUNCTION szrun + +!*********************************************************************** +! Add infiltration to soil and compute excess +! Soil_to_gw and Soil_to_ssr for whole HRU +!*********************************************************************** + SUBROUTINE compute_soilmoist(Infil, Soil_moist_max, & + & Soil_rechr_max, Soil2gw_max, Soil_to_ssr, Soil_moist, & + & Soil_rechr, Soil_to_gw, Soil2gw, Perv_frac) + IMPLICIT NONE + INTRINSIC MIN +! Arguments + INTEGER, INTENT(IN) :: Soil2gw + REAL, INTENT(IN) :: Perv_frac, Soil_moist_max, Soil_rechr_max, Soil2gw_max + REAL, INTENT(INOUT) :: Infil, Soil_moist, Soil_rechr, Soil_to_gw, Soil_to_ssr +! Local Variables + REAL :: excs +!*********************************************************************** + Soil_rechr = MIN( (Soil_rechr+Infil), Soil_rechr_max ) + ! soil_moist_max from previous time step or soil_moist_max has + ! changed for a restart simulation + excs = Soil_moist + Infil + Soil_moist = MIN( excs, Soil_moist_max ) + excs = (excs - Soil_moist_max)*Perv_frac + IF ( excs>0.0 ) THEN + IF ( Soil2gw==1 ) THEN + Soil_to_gw = MIN( Soil2gw_max, excs ) + excs = excs - Soil_to_gw + ENDIF + IF ( excs>Infil*Perv_frac ) THEN !probably dynamic + Infil = 0.0 + ELSE + Infil = Infil - excs/Perv_frac !???? what if Infil<0 ??? might happen with dynamic and small values, maybe ABS < NEARZERO = 0.0 +! IF ( Infil<0.0 ) THEN +! IF ( Infil<-0.0001 ) THEN +! PRINT *, 'negative infil', infil, soil_moist, excs +! Soil_moist = Soil_moist + Infil +! ENDIF +! Infil = 0.0 +! ENDIF + ENDIF + + Soil_to_ssr = excs + IF ( Soil_to_ssr<0.0 ) Soil_to_ssr = 0.0 + ENDIF + + END SUBROUTINE compute_soilmoist + +!*********************************************************************** +! Compute actual evapotranspiration +!*********************************************************************** + SUBROUTINE compute_szactet(Soil_moist_max, Soil_rechr_max, & + & Transp_on, Cov_type, Soil_type, & + & Soil_moist, Soil_rechr, Perv_actet, Avail_potet, & + & Snow_free, Potet_rechr, Potet_lower) + USE PRMS_SOILZONE, ONLY: Et_type + USE PRMS_BASIN, ONLY: NEARZERO + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Transp_on, Cov_type, Soil_type + REAL, INTENT(IN) :: Soil_moist_max, Soil_rechr_max, Snow_free + REAL, INTENT(INOUT) :: Soil_moist, Soil_rechr, Avail_potet, Potet_rechr, Potet_lower + REAL, INTENT(OUT) :: Perv_actet +! Local Variables + REAL, PARAMETER :: ONETHIRD = 1.0/3.0, TWOTHIRDS = 2.0/3.0 + REAL :: et, pcts, pctr +!*********************************************************************** +!******Determine if evaporation(Et_type = 2) or transpiration plus +!******evaporation(Et_type = 3) are active. if not, Et_type = 1 + + IF ( Avail_potet0 ) THEN + Et_type = 3 + ELSEIF ( Snow_free<0.01 ) THEN + Et_type = 1 + ELSE + Et_type = 2 + ENDIF + + IF ( Et_type>1 ) THEN + pcts = Soil_moist/Soil_moist_max + pctr = Soil_rechr/Soil_rechr_max + Potet_lower = Avail_potet + Potet_rechr = Avail_potet + +!******sandy soil + IF ( Soil_type==1 ) THEN + IF ( pcts<0.25 ) Potet_lower = 0.5*pcts*Avail_potet + IF ( pctr<0.25 ) Potet_rechr = 0.5*pctr*Avail_potet +!******loam soil + ELSEIF ( Soil_type==2 ) THEN + IF ( pcts<0.5 ) Potet_lower = pcts*Avail_potet + IF ( pctr<0.5 ) Potet_rechr = pctr*Avail_potet +!******clay soil + ELSEIF ( Soil_type==3 ) THEN + IF ( pctsONETHIRD ) THEN + Potet_lower = pcts*Avail_potet + ELSEIF ( pcts<=ONETHIRD ) THEN + Potet_lower = 0.5*pcts*Avail_potet + ENDIF + IF ( pctrONETHIRD ) THEN + Potet_rechr = pctr*Avail_potet + ELSEIF ( pctr<=ONETHIRD ) THEN + Potet_rechr = 0.5*pctr*Avail_potet + ENDIF + ENDIF + +!******Soil moisture accounting + IF ( Et_type==2 ) Potet_rechr = Potet_rechr*Snow_free + IF ( Potet_rechr>Soil_rechr ) THEN + Potet_rechr = Soil_rechr + Soil_rechr = 0.0 + ELSE + Soil_rechr = Soil_rechr - Potet_rechr + ENDIF + IF ( Et_type==2 .OR. Potet_rechr>=Potet_lower ) THEN + IF ( Potet_rechr>Soil_moist ) THEN + Potet_rechr = Soil_moist + Soil_moist = 0.0 + ELSE + Soil_moist = Soil_moist - Potet_rechr + ENDIF + et = Potet_rechr + ELSEIF ( Potet_lower>Soil_moist ) THEN + et = Soil_moist + Soil_moist = 0.0 + ELSE + Soil_moist = Soil_moist - Potet_lower + et = Potet_lower + ENDIF + IF ( Soil_rechr>Soil_moist ) Soil_rechr = Soil_moist + ELSE + et = 0.0 + ENDIF + Perv_actet = et + ! sanity check +! IF ( Perv_actet>Avail_potet ) THEN +! PRINT *, 'perv_et problem', Perv_actet, Avail_potet +! Soil_moist = Soil_moist + Perv_actet - Avail_potet +! Perv_actet = Avail_potet +! ENDIF + + END SUBROUTINE compute_szactet + +!*********************************************************************** +! compute interflow and flow to groundwater reservoir +!*********************************************************************** + SUBROUTINE compute_gwflow(Ssr2gw_rate, Ssr2gw_exp, Ssr_to_gw, Slow_stor) + IMPLICIT NONE +! Arguments + REAL, INTENT(IN) :: Ssr2gw_rate, Ssr2gw_exp + REAL, INTENT(INOUT) :: Slow_stor, Ssr_to_gw +!*********************************************************************** +!******compute flow to groundwater + Ssr_to_gw = Ssr2gw_rate*(Slow_stor**Ssr2gw_exp) + IF ( Ssr_to_gw<0.0 ) THEN + Ssr_to_gw = 0.0 + ELSEIF ( Ssr_to_gw>Slow_stor ) THEN + Ssr_to_gw = Slow_stor + ENDIF + Slow_stor = Slow_stor - Ssr_to_gw + + END SUBROUTINE compute_gwflow + +!*********************************************************************** +! Compute subsurface lateral flow +!*********************************************************************** + SUBROUTINE compute_interflow(Coef_lin, Coef_sq, Ssres_in, Storage, Inter_flow) +! USE PRMS_BASIN, ONLY: NEARZERO, CLOSEZERO + IMPLICIT NONE + INTRINSIC EXP, SQRT +! Arguments + REAL, INTENT(IN) :: Coef_lin, Coef_sq, Ssres_in + REAL, INTENT(INOUT) :: Storage, Inter_flow +! Local Variables + REAL :: c1, c2, c3, sos +!*********************************************************************** +! Inter_flow is in inches for the timestep +!******compute interflow + IF ( Coef_lin<=0.0 .AND. Ssres_in<=0.0 ) THEN + c1 = Coef_sq*Storage + Inter_flow = Storage*(c1/(1.0+c1)) + ELSEIF ( Coef_lin>0.0 .AND. Coef_sq<=0.0 ) THEN + c2 = 1.0 - EXP(-Coef_lin) + Inter_flow = Ssres_in*(1.0-c2/Coef_lin) + Storage*c2 + ELSEIF ( Coef_sq>0.0 ) THEN + c3 = SQRT(Coef_lin**2.0+4.0*Coef_sq*Ssres_in) + sos = Storage - ((c3-Coef_lin)/(2.0*Coef_sq)) + IF ( c3==0.0 ) STOP 'ERROR, in compute_interflow sos=0, please contact code developers' + c1 = Coef_sq*sos/c3 + c2 = 1.0 - EXP(-c3) + IF ( 1.0+c1*c2>0.0 ) THEN + Inter_flow = Ssres_in + (sos*(1.0+c1)*c2)/(1.0+c1*c2) + ELSE + Inter_flow = Ssres_in + ENDIF + ELSE + Inter_flow = 0.0 + ENDIF + +! sanity check + IF ( Inter_flow<0.0 ) THEN +! IF ( Inter_flow<-NEARZERO ) PRINT *, 'interflow<0', Inter_flow, Ssres_in, Storage + Inter_flow = 0.0 + ELSEIF ( Inter_flow>Storage ) THEN + Inter_flow = Storage + ENDIF + Storage = Storage - Inter_flow +! IF ( Storage<0.0 ) THEN +! IF ( Storage<-CLOSEZERO ) PRINT *, 'Sanity check, ssres_stor<0.0', Storage +! Storage = 0.0 +! rsr, if very small storage, add it to interflow +! ELSEIF ( Storage>0.0 .AND. Storage 0, cascade contributes to a downslope HRU + IF ( j>0 ) THEN + fracwt = Hru_down_fracwt(k, Ihru) + Upslope_interflow(j) = Upslope_interflow(j) + DBLE( (Slowflow+Preflow)*fracwt ) + Upslope_dunnianflow(j) = Upslope_dunnianflow(j) + DBLE( Dunnian*fracwt ) + Dnslowflow = Dnslowflow + Slowflow*frac + Dnpreflow = Dnpreflow + Preflow*frac + Dndunnflow = Dndunnflow + Dunnian*frac +! if hru_down(k, Ihru) < 0, cascade contributes to a stream + ELSEIF ( j<0 ) THEN + j = IABS(j) + Strm_seg_in(j) = Strm_seg_in(j) + DBLE( (Slowflow+Preflow+Dunnian)*Cascade_area(k, Ihru) )*Cfs_conv + ENDIF + ENDDO + +! reset Slowflow, Preflow, and Dunnian_flow as they accumulate flow to streams + Slowflow = Slowflow - Dnslowflow + Preflow = Preflow - Dnpreflow + Dunnian = Dunnian - Dndunnflow + + END SUBROUTINE compute_cascades + +!*********************************************************************** +! compute interflow and flow to groundwater reservoir +!*********************************************************************** + SUBROUTINE compute_gravflow(Ihru, Capacity, Slowcoef_lin, & + & Slowcoef_sq, Ssr2gw_rate, Ssr2gw_exp, Gvr_maxin, & + & Pref_flow_thrsh, Gvr2pfr, Ssr_to_gw, & + & Slow_flow, Slow_stor, Gvr2sm, Soil_to_gw, Gwin, Hru_type) + USE PRMS_SOILZONE, ONLY: Gravity_stor_res, Sm2gw_grav, Hru_gvr_count, Hru_gvr_index, & + & Gw2sm_grav, Gvr_hru_pct_adjusted + USE PRMS_MODULE, ONLY: Dprst_flag, Print_debug + USE PRMS_SRUNOFF, ONLY: Dprst_seep_hru + IMPLICIT NONE +! Functions + INTRINSIC MAX, DBLE, SNGL + EXTERNAL check_gvr_sm, compute_interflow +! Arguments + INTEGER, INTENT(IN) :: Ihru, Hru_type + REAL, INTENT(IN) :: Slowcoef_lin, Slowcoef_sq, Ssr2gw_rate, Ssr2gw_exp + REAL, INTENT(IN) :: Pref_flow_thrsh, Soil_to_gw, Gvr_maxin + REAL, INTENT(INOUT) :: Capacity + REAL, INTENT(OUT) :: Ssr_to_gw, Slow_stor, Slow_flow, Gvr2pfr, Gvr2sm + DOUBLE PRECISION, INTENT(OUT) :: Gwin +! Local Variables + INTEGER :: j, igvr + REAL :: perc, slowflow, extra_water, gvrin_actual, depth, input + DOUBLE PRECISION :: topfr, slflow, togw, slowstor, frac +!*********************************************************************** + !Capacity is for whole HRU + !Soil_to_gw is for whole HRU + !TO DO +! use VKS as a function of slope (vector analysis) instead of coef_lin +! coef_lin for pref_flow needs to be VKS lateral times a factor +! change slow to interflow +! in init, set an array dimensioned by nhrucell to vks*mfl_to_inch + + Gwin = 0.0D0 + Gvr2sm = 0.0 + topfr = 0.0D0 + slflow = 0.0D0 + togw = 0.0D0 + slowstor = 0.0D0 + DO j = 1, Hru_gvr_count(Ihru) + igvr = Hru_gvr_index(j, Ihru) + frac = Gvr_hru_pct_adjusted(igvr) + Gwin = Gwin + DBLE( Gw2sm_grav(igvr) )*frac + input = Gvr_maxin + Gw2sm_grav(igvr) + depth = Gravity_stor_res(igvr) + input + IF ( depth>0.0 .AND. Capacity>0.0 ) CALL check_gvr_sm(Capacity, depth, frac, Gvr2sm, input) + + IF ( Hru_type==1 ) THEN + extra_water = MAX( 0.0, depth-Pref_flow_thrsh ) + IF ( extra_water>0.0 ) THEN + !compute contribution to preferential-flow reservoir storage + topfr = topfr + DBLE( extra_water )*frac + depth = Pref_flow_thrsh + ENDIF + gvrin_actual = MAX(0.0, input-extra_water) + +! compute contribution to slow interflow, if any + IF ( depth>0.0 ) THEN + CALL compute_interflow(Slowcoef_lin, Slowcoef_sq, gvrin_actual, depth, slowflow) + slflow = slflow + DBLE( slowflow )*frac + ENDIF + ENDIF + +! compute flow to groundwater, if any + IF ( depth>0.0 ) THEN + IF ( Ssr2gw_rate>0.0 ) THEN +! use VKS instead of rate ??????????????? + perc = Ssr2gw_rate*(depth**Ssr2gw_exp) + IF ( perc<0.0 ) THEN + perc = 0.0 + ELSEIF ( perc>depth ) THEN + perc = depth + ENDIF + depth = depth - perc +! IF ( sm2gw_grav(igvr)>0.0 ) print*,'problem',sm2gw_grav(igvr),igvr + Sm2gw_grav(igvr) = perc + togw = togw + DBLE( perc )*frac + ENDIF +! ELSE ! GVRs can go negative if flux change in MODFLOW final iteration decreases, so don't set to 0 +! if(depth<0.0) print *, 'depth<0', depth, ihru +! depth = 0.0 + ENDIF + + Gravity_stor_res(igvr) = depth + slowstor = slowstor + DBLE(depth)*frac + +! add any direct recharge from soil infiltration + Sm2gw_grav(igvr) = Sm2gw_grav(igvr) + Soil_to_gw + IF ( Dprst_flag==1 ) Sm2gw_grav(igvr) = Sm2gw_grav(igvr) + SNGL( Dprst_seep_hru(Ihru) ) + + ENDDO ! end loop of GVRs in the HRU + + Gvr2pfr = SNGL( topfr ) + Slow_flow = SNGL( slflow ) + Ssr_to_gw = SNGL( togw ) + Slow_stor = SNGL( slowstor ) + IF ( Slow_stor>Pref_flow_thrsh ) THEN + IF ( Print_debug>-1 .AND. Hru_type==1 ) & + & PRINT *, 'slow_stor > thrsh', Slow_stor, Pref_flow_thrsh, ' HRU:', Ihru, ' type:', Hru_type + ENDIF + + END SUBROUTINE compute_gravflow + +!*********************************************************************** +! adjust soil moist based on being below field capacity (capacity) +! and preferential-flow threshold (Pref_flow_thrsh) +!*********************************************************************** + SUBROUTINE check_gvr_sm(Capacity, Depth, Frac, Gvr2sm, Input) +! USE PRMS_BASIN, ONLY: CLOSEZERO + IMPLICIT NONE +! Functions + INTRINSIC MAX, ABS, SNGL +! Arguments + DOUBLE PRECISION, INTENT(IN) :: Frac + REAL, INTENT(INOUT) :: Capacity, Gvr2sm, Depth, Input +! Local Variables + REAL :: to_sm, frac_sngl +!*********************************************************************** +! check to see if soil is below capacity, if so add up to field capacity +! Capacity is for whole HRU +! to_sm and Gvr2sm are for whole HRU + + frac_sngl = SNGL( Frac ) + ! fill up capillary with part of gravity water + to_sm = Capacity + ! take all gravity water and put in capillary + IF ( to_sm>Depth ) to_sm = Depth + +! compute adjusmtent to soil moist to get to field capacity + Capacity = Capacity - to_sm*frac_sngl + IF ( Capacity<0.0 ) THEN + to_sm = to_sm - Capacity*frac_sngl + Capacity = 0.0 + ENDIF + Gvr2sm = Gvr2sm + to_sm*frac_sngl + Depth = Depth - to_sm + !IF ( Depth<0.0 ) PRINT *, 'depth<0', depth +! IF ( Depth0 ) CALL srunoff_restart(1) + srunoff = srunoffinit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL srunoff_restart(0) + ENDIF + + END FUNCTION srunoff + +!*********************************************************************** +! srunoffdecl - set up parameters for surface runoff computations +! Declared Parameters +! smidx_coef, smidx_exp, carea_max, imperv_stor_max, snowinfil_max +! hru_area, soil_moist_max, soil_rechr_max, carea_min +! cfgi_thrshld, cfgi_decay, soil_depth, soil_den, porosity_hru +!*********************************************************************** + INTEGER FUNCTION srunoffdecl() + USE PRMS_SRUNOFF + USE PRMS_MODULE, ONLY: Model, Dprst_flag, Nhru, Nsegment, Print_debug, & + & Cascade_flag, Sroff_flag, Nlake, Init_vars_from_file, Call_cascade, PRMS4_flag, & + & Frozen_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declvar, declparam + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_srunoff +!*********************************************************************** + srunoffdecl = 0 + + Version_srunoff = 'srunoff.f90 2019-05-24 14:50:00Z' + IF ( Sroff_flag==1 ) THEN + MODNAME = 'srunoff_smidx' + ELSE + MODNAME = 'srunoff_carea' + ENDIF + Version_srunoff = MODNAME//'.f90 '//Version_srunoff(13:80) + CALL print_module(Version_srunoff, 'Surface Runoff ', 90) + + IF ( declvar(MODNAME, 'basin_imperv_evap', 'one', 1, 'double', & + & 'Basin area-weighted average evaporation from impervious area', & + & 'inches', Basin_imperv_evap)/=0 ) CALL read_error(3, 'basin_imperv_evap') + + IF ( declvar(MODNAME, 'basin_imperv_stor', 'one', 1, 'double', & + & 'Basin area-weighted average storage on impervious area', & + & 'inches', Basin_imperv_stor)/=0 ) CALL read_error(3, 'basin_imperv_stor') + + IF ( declvar(MODNAME, 'basin_infil', 'one', 1, 'double', & + & 'Basin area-weighted average infiltration to the capillary reservoirs', & + & 'inches', Basin_infil)/=0 ) CALL read_error(3, 'basin_infil') + + IF ( declvar(MODNAME, 'basin_sroff', 'one', 1, 'double', & + & 'Basin area-weighted average surface runoff to the stream network', & + & 'inches', Basin_sroff)/=0 ) CALL read_error(3, 'basin_sroff') + + IF ( declvar(MODNAME, 'basin_hortonian', 'one', 1, 'double', & + & 'Basin area-weighted average Hortonian runoff', & + & 'inches', Basin_hortonian)/=0 ) CALL read_error(3, 'basin_hortonian') + + IF ( declvar(MODNAME, 'basin_contrib_fraction', 'one', 1, 'double', & + & 'Basin area-weighted average contributing area of the pervious area of each HRU', & + & 'decimal fraction', Basin_contrib_fraction)/=0 ) CALL read_error(3, 'basin_contrib_fraction') + + ALLOCATE ( Contrib_fraction(Nhru) ) + IF ( declvar(MODNAME, 'contrib_fraction', 'nhru', Nhru, 'real', & + & 'Contributing area of each HRU pervious area', & + & 'decimal fraction', Contrib_fraction)/=0 ) CALL read_error(3, 'contrib_fraction') + + ALLOCATE ( Hru_impervevap(Nhru) ) + IF ( declvar(MODNAME, 'hru_impervevap', 'nhru', Nhru, 'real', & + & 'HRU area-weighted average evaporation from impervious area for each HRU', & + & 'inches', Hru_impervevap)/=0 ) CALL read_error(3, 'hru_impervevap') + + ALLOCATE ( Hru_impervstor(Nhru) ) + IF ( declvar(MODNAME, 'hru_impervstor', 'nhru', Nhru, 'real', & + & 'HRU area-weighted average storage on impervious area for each HRU', & + & 'inches', Hru_impervstor)/=0 ) CALL read_error(3, 'hru_impervstor') + + ALLOCATE ( Imperv_evap(Nhru) ) + IF ( declvar(MODNAME, 'imperv_evap', 'nhru', Nhru, 'real', & + & 'Evaporation from impervious area for each HRU', & + & 'inches', Imperv_evap)/=0 ) CALL read_error(3, 'imperv_evap') + + IF ( declvar(MODNAME, 'basin_sroffi', 'one', 1, 'double', & + & 'Basin area-weighted average surface runoff from impervious areas', & + & 'inches', Basin_sroffi)/=0 ) CALL read_error(3, 'basin_sroffi') + + IF ( declvar(MODNAME, 'basin_sroffp', 'one', 1, 'double', & + & 'Basin area-weighted average surface runoff from pervious areas', & + & 'inches', Basin_sroffp)/=0 ) CALL read_error(3, 'basin_sroffp') + + ALLOCATE ( Hru_sroffp(Nhru) ) + IF ( declvar(MODNAME, 'hru_sroffp', 'nhru', Nhru, 'real', & + & 'HRU area-weighted average surface runoff from pervious areas for each HRU', & + & 'inches', Hru_sroffp)/=0 ) CALL read_error(3, 'hru_sroffp') + + ALLOCATE ( Hru_sroffi(Nhru) ) + IF ( declvar(MODNAME, 'hru_sroffi', 'nhru', Nhru, 'real', & + & 'HRU area-weighted average surface runoff from impervious areas for each HRU', & + & 'inches', Hru_sroffi)/=0 ) CALL read_error(3, 'hru_sroffi') + +! Depression storage variables + IF ( Dprst_flag==1 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'basin_dprst_sroff', 'one', 1, 'double', & + & 'Basin area-weighted average surface runoff from open surface-depression storage', & + & 'inches', Basin_dprst_sroff)/=0 ) CALL read_error(3, 'basin_dprst_sroff') + + IF ( declvar(MODNAME, 'basin_dprst_evap', 'one', 1, 'double', & + & 'Basin area-weighted average evaporation from surface-depression storage', & + & 'inches', Basin_dprst_evap)/=0 ) CALL read_error(3, 'basin_dprst_evap') + + IF ( declvar(MODNAME, 'basin_dprst_seep', 'one', 1, 'double', & + & 'Basin area-weighted average seepage from surface-depression storage', & + & 'inches', Basin_dprst_seep)/=0 ) CALL read_error(3, 'basin_dprst_seep') + + IF ( declvar(MODNAME, 'basin_dprst_volop', 'one', 1, 'double', & + & 'Basin area-weighted average storage volume in open surface depressions', & + & 'inches', Basin_dprst_volop)/=0 ) CALL read_error(3, 'basin_dprst_volop') + + IF ( declvar(MODNAME, 'basin_dprst_volcl', 'one', 1, 'double', & + & 'Basin area-weighted average storage volume in closed surface depressions', & + & 'inches', Basin_dprst_volcl)/=0 ) CALL read_error(3, 'basin_dprst_volcl') + + ALLOCATE ( Dprst_sroff_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_sroff_hru', 'nhru', Nhru, 'double', & + & 'Surface runoff from open surface-depression storage for each HRU', & + & 'inches', Dprst_sroff_hru)/=0 ) CALL read_error(3, 'dprst_sroff_hru') + + ALLOCATE ( Dprst_insroff_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_insroff_hru', 'nhru', Nhru, 'real', & + & 'Surface runoff from pervious and impervious portions into open and closed surface-depression storage for each HRU', & + & 'inches', Dprst_insroff_hru)/=0 ) CALL read_error(3, 'dprst_insroff_hru') + + ALLOCATE ( Dprst_area_open(Nhru) ) + IF ( declvar(MODNAME, 'dprst_area_open', 'nhru', Nhru, 'real', & + & 'Surface area of open surface depressions based on storage volume for each HRU', & + & 'acres', Dprst_area_open)/=0 ) CALL read_error(3, 'dprst_area_open') + + ALLOCATE ( Dprst_area_clos(Nhru) ) + IF ( declvar(MODNAME, 'dprst_area_clos', 'nhru', Nhru, 'real', & + & 'Surface area of closed surface depressions based on storage volume for each HRU', & + & 'acres', Dprst_area_clos)/=0 ) CALL read_error(3, 'dprst_area_clos') + + ALLOCATE ( Dprst_stor_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_stor_hru', 'nhru', Nhru, 'double', & + & 'Surface-depression storage for each HRU', & + & 'inches', Dprst_stor_hru)/=0 ) CALL read_error(3, 'dprst_stor_hru') + + ALLOCATE ( Dprst_seep_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_seep_hru', 'nhru', Nhru, 'double', & + & 'Seepage from surface-depression storage to associated GWR for each HRU', & + & 'inches', Dprst_seep_hru)/=0 ) CALL read_error(3, 'dprst_seep_hru') + + ALLOCATE ( Dprst_evap_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_evap_hru', 'nhru', Nhru, 'real', & + & 'Evaporation from surface-depression storage for each HRU', & + & 'inches', Dprst_evap_hru)/=0 ) CALL read_error(3, 'dprst_evap_hru') + + ALLOCATE ( Dprst_vol_open_frac(Nhru) ) + IF ( declvar(MODNAME, 'dprst_vol_open_frac', 'nhru', Nhru, 'real', & + & 'Fraction of open surface-depression storage of the maximum storage for each HRU', & + & 'decimal fraction', Dprst_vol_open_frac)/=0 ) CALL read_error(3, 'dprst_vol_open_frac') + + ALLOCATE ( Dprst_vol_clos_frac(Nhru) ) + IF ( declvar(MODNAME, 'dprst_vol_clos_frac', 'nhru', Nhru, 'real', & + & 'Fraction of closed surface-depression storage of the maximum storage for each HRU', & + & 'decimal fraction', Dprst_vol_clos_frac)/=0 ) CALL read_error(3, 'dprst_vol_clos_frac') + + ALLOCATE ( Dprst_vol_frac(Nhru) ) + IF ( declvar(MODNAME, 'dprst_vol_frac', 'nhru', Nhru, 'real', & + & 'Fraction of surface-depression storage of the maximum storage for each HRU', & + & 'decimal fraction', Dprst_vol_frac)/=0 ) CALL read_error(3, 'dprst_vol_frac') + + ALLOCATE ( Dprst_vol_open_max(Nhru), Dprst_vol_clos_max(Nhru), Dprst_vol_thres_open(Nhru), Dprst_in(Nhru) ) + ENDIF + + ALLOCATE ( Hortonian_flow(Nhru) ) + IF ( declvar(MODNAME, 'hortonian_flow', 'nhru', Nhru, 'real', & + & 'Hortonian surface runoff reaching stream network for each HRU', & + & 'inches', Hortonian_flow)/=0 ) CALL read_error(3, 'hortonian_flow') + +! cascading variables and parameters + IF ( Cascade_flag>0 .OR. Model==99 ) THEN + ALLOCATE ( Upslope_hortonian(Nhru) ) + IF ( declvar(MODNAME, 'upslope_hortonian', 'nhru', Nhru, 'double', & + & 'Hortonian surface runoff received from upslope HRUs', & + & 'inches', Upslope_hortonian)/=0 ) CALL read_error(3, 'upslope_hortonian') + + IF ( declvar(MODNAME, 'basin_sroff_down', 'one', 1, 'double', & + & 'Basin area-weighted average of cascading surface runoff', & + & 'inches', Basin_sroff_down)/=0 ) CALL read_error(3, 'basin_sroff_down') + + IF ( declvar(MODNAME, 'basin_sroff_upslope', 'one', 1, 'double', & + & 'Basin area-weighted average of cascading surface runoff received from upslope HRUs', & + & 'inches', Basin_sroff_upslope)/=0 ) CALL read_error(3, 'basin_sroff_upslope') + + ALLOCATE ( Hru_hortn_cascflow(Nhru) ) + IF ( declvar(MODNAME, 'hru_hortn_cascflow', 'nhru', Nhru, 'double', & + & 'Cascading Hortonian surface runoff leaving each HRU', & + & 'inches', Hru_hortn_cascflow)/=0 ) CALL read_error(3, 'hru_hortn_cascflow') + + IF ( Nlake>0 ) THEN + IF ( declvar(MODNAME, 'basin_hortonian_lakes', 'one', 1, 'double', & + & 'Basin area-weighted average Hortonian surface runoff to lakes', & + & 'inches', Basin_hortonian_lakes)/=0 ) CALL read_error(3, 'basin_hortonian_lakes') + + ALLOCATE ( Hortonian_lakes(Nhru) ) + IF ( declvar(MODNAME, 'hortonian_lakes', 'nhru', Nhru, 'double', & + & 'Surface runoff to lakes for each HRU', & + & 'inches', Hortonian_lakes)/=0 ) CALL read_error(3, 'hortonian_lakes') + ENDIF + ENDIF + + IF ( Call_cascade==1 .OR. Model==99 ) THEN + ALLOCATE ( Strm_seg_in(Nsegment) ) + IF ( declvar(MODNAME, 'strm_seg_in', 'nsegment', Nsegment, 'double', & + & 'Flow in stream segments as a result of cascading flow in each stream segment', & + & 'cfs', Strm_seg_in)/=0 ) CALL read_error(3,'strm_seg_in') + ENDIF + +! frozen ground variables and parameters + IF ( Frozen_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Frozen(Nhru) ) + IF ( declvar(MODNAME, 'frozen', 'nhru', Nhru, 'integer', & + & 'Flag for frozen ground (0=no; 1=soil at surface; 2=soil below surf; 3=below soil)', & + & 'dimensionless', Frozen)/=0 ) CALL read_error(3, 'frozen') + + ALLOCATE ( Cfgi(Nhru) ) + IF ( declvar(MODNAME, 'cfgi', 'nhru', Nhru, 'real', & + & 'Continuous Frozen Ground Index', & + & 'index', Cfgi)/=0 ) CALL read_error(3, 'cfgi') + + ALLOCATE ( Cfgi_prev(Nhru) ) + IF ( declvar(MODNAME, 'cfgi_prev', 'nhru', Nhru, 'real', & + & 'Continuous Frozen Ground Index from previous day', & + & 'index', Cfgi_prev)/=0 ) CALL read_error(3, 'cfgi_prev') + + IF ( declparam(MODNAME, 'cfgi_decay', 'one', 'real', & + & '0.97', '0.01', '1.0', & + & 'CFGI daily decay of index, value of 1.0 is no decay', & + & 'CFGI daily decay of index, value of 1.0 is no decay', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'cfgi_decay') + + IF ( declparam(MODNAME, 'cfgi_thrshld', 'one', 'real', & + & '5.0', '5.0', '83.0', & + & 'CFGImod threshold value indicating frozen soil', & + & 'CFGImod threshold value indicating frozen soil', & + & 'index')/=0 ) CALL read_error(1, 'cfgi_thrshld') + + ALLOCATE ( Frz_depth(Nhru) ) + IF ( declvar(MODNAME, 'frz_depth', 'nhru', Nhru, 'real', & + & 'Maximum depth soil is frozen, may be thawed above', & + & 'inches', Frz_depth)/=0 ) CALL read_error(1, 'frz_depth') + + ALLOCATE ( Thaw_depth(Nhru) ) + IF ( declvar(MODNAME, 'thaw_depth', 'nhru', Nhru, 'real', & + & 'Depth soil is thawed from surface', & + & 'inches', Thaw_depth)/=0 ) CALL read_error(1, 'thaw_depth') + + ALLOCATE ( Soil_depth(Nhru) ) + IF ( declparam(MODNAME, 'soil_depth', 'nhru', 'real', & + & '19.685', '0.0', '60.0', & + & 'Depth of soil that could freeze', & + & 'Depth of soil that could freeze', & + & 'inches')/=0 ) CALL read_error(1, 'soil_depth') + + ALLOCATE ( Soil_den(Nhru) ) + IF ( declparam(MODNAME, 'soil_den', 'nhru', 'real', & + & '1.3', '0.1', '2.0', & + & 'Density of soil that could freeze', & + & 'Density of soil that could freeze, limits based on Alaska UNASM map', & + & 'gm/cm3')/=0 ) CALL read_error(1, 'soil_den') + + ALLOCATE ( Porosity_hru(Nhru) ) + IF ( declparam(MODNAME, 'porosity_hru', 'nhru', 'real', & + & '0.4', '0.15', '0.75', & + & 'Porosity of soil for frozen ground calculations', & + & 'Porosity of soil for frozen ground calculations', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'porosity_hru') + ENDIF + +! Declare parameters + IF ( Sroff_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Smidx_coef(Nhru) ) + IF ( declparam(MODNAME, 'smidx_coef', 'nhru', 'real', & + & '0.005', '0.0', '1.0', & + & 'Coefficient in contributing area computations', & + & 'Coefficient in non-linear contributing area algorithm for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'smidx_coef') + ALLOCATE ( Smidx_exp(Nhru) ) + IF ( declparam(MODNAME, 'smidx_exp', 'nhru', 'real', & + & '0.3', '0.0', '5.0', & + & 'Exponent in contributing area computations', & + & 'Exponent in non-linear contributing area algorithm for each HRU', & + & '1.0/inch')/=0 ) CALL read_error(1, 'smidx_exp') + ENDIF + + IF ( Sroff_flag==2 .OR. Model==99 ) THEN + ALLOCATE ( Carea_min(Nhru), Carea_dif(Nhru) ) + IF ( declparam(MODNAME, 'carea_min', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Minimum contributing area', & + & 'Minimum possible area contributing to surface runoff expressed as a portion of the area for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'carea_min') + ENDIF + + ALLOCATE ( Carea_max(Nhru) ) + IF ( declparam(MODNAME, 'carea_max', 'nhru', 'real', & + & '0.6', '0.0', '1.0', & + & 'Maximum contributing area', & + & 'Maximum possible area contributing to surface runoff expressed as a portion of the HRU area', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'carea_max') + +! Depression Storage parameters: + IF ( Dprst_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Dprst_depth_avg(Nhru) ) + IF ( declparam(MODNAME, 'dprst_depth_avg', 'nhru', 'real', & + & '132.0', '0.0', '500.0', & + & 'Average depth of surface depressions at maximum storage capacity', & + & 'Average depth of surface depressions at maximum storage capacity', & + & 'inches')/=0 ) CALL read_error(1, 'dprst_depth_avg') + + ALLOCATE ( Dprst_flow_coef(Nhru) ) + IF ( declparam(MODNAME, 'dprst_flow_coef', 'nhru', 'real', & + & '0.05', '0.00001', '0.5', & + & 'Coefficient in linear flow routing equation for open surface depressions', & + & 'Coefficient in linear flow routing equation for open surface depressions for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_flow_coef') + + ALLOCATE ( Dprst_seep_rate_open(Nhru) ) + IF ( declparam(MODNAME, 'dprst_seep_rate_open', 'nhru', 'real', & + & '0.02', '0.0', '0.2', & + & 'Coefficient used in linear seepage flow equation for open surface depressions', & + & 'Coefficient used in linear seepage flow equation for'// & + & ' open surface depressions for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_seep_rate_open') + + ALLOCATE ( Dprst_seep_rate_clos(Nhru) ) + IF ( declparam(MODNAME, 'dprst_seep_rate_clos', 'nhru', 'real', & + & '0.02', '0.0', '0.2', & + & 'Coefficient used in linear seepage flow equation for closed surface depressions', & + & 'Coefficient used in linear seepage flow equation for'// & + & ' closed surface depressions for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_seep_rate_clos') + + ALLOCATE ( Op_flow_thres(Nhru) ) + IF ( declparam(MODNAME, 'op_flow_thres', 'nhru', 'real', & + & '1.0', '0.01', '1.0', & + & 'Fraction of open depression storage above which surface runoff occurs for each timestep', & + & 'Fraction of open depression storage above'// & + & ' which surface runoff occurs; any water above'// & + & ' maximum open storage capacity spills as surface runoff', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'op_flow_thres') + + ALLOCATE ( Sro_to_dprst_perv(Nhru) ) + IF ( PRMS4_flag==1 ) THEN + IF ( declparam(MODNAME, 'sro_to_dprst', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of pervious surface runoff that flows into surface-depression storage', & + & 'Fraction of pervious surface runoff that'// & + & ' flows into surface-depression storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst') + ELSE + IF ( declparam(MODNAME, 'sro_to_dprst_perv', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of pervious surface runoff that flows into surface-depression storage', & + & 'Fraction of pervious surface runoff that'// & + & ' flows into surface-depression storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_perv') + ENDIF + + ALLOCATE ( Sro_to_dprst_imperv(Nhru) ) + IF ( declparam(MODNAME, 'sro_to_dprst_imperv', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of impervious surface runoff that flows into surface-depression storage', & + & 'Fraction of impervious surface runoff that'// & + & ' flows into surface-depression storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_imperv') + + ALLOCATE ( Dprst_et_coef(Nhru) ) + IF ( declparam(MODNAME, 'dprst_et_coef', 'nhru', 'real', & + & '1.0', '0.5', '1.5', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression storage', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'dprst_et_coef') + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN + ALLOCATE ( Dprst_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'dprst_frac_init', 'nhru', 'real', & + & '0.5', '0.0', '1.0', & + & 'Fraction of maximum storage that contains water at the start of a simulation', & + & 'Fraction of maximum surface-depression storage that'// & + & ' contains water at the start of a simulation', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'dprst_frac_init') + ENDIF + + ALLOCATE ( Va_open_exp(Nhru) ) + IF ( declparam(MODNAME, 'va_open_exp', 'nhru', 'real', & + & '0.001', '0.0001', '10.0', & + & 'Coefficient in the exponential equation to compute'// & + & ' current surface area of open surface-depression storage', & + & 'Coefficient in the exponential equation relating'// & + & ' maximum surface area to the fraction that open'// & + & ' depressions are full to compute current surface area for each HRU;'// & + & ' 0.001 is an approximate cylinder; 1.0 is a cone', & + & 'none')/=0 ) CALL read_error(1, 'va_open_exp') + + ALLOCATE ( Va_clos_exp(Nhru) ) + IF ( declparam(MODNAME, 'va_clos_exp', 'nhru', 'real', & + & '0.001', '0.0001', '10.0', & + & 'Coefficient in the exponential equation to compute'// & + & ' current surface area of closed surface-depression storage', & + & 'Coefficient in the exponential equation relating'// & + & ' maximum surface area to the fraction that closed'// & + & ' depressions are full to compute current surface area for each HRU;'// & + & ' 0.001 is an approximate cylinder; 1.0 is a cone', & + & 'none')/=0 ) CALL read_error(1, 'va_clos_exp') + ENDIF + + IF ( Print_debug==1 ) THEN + ALLOCATE ( Imperv_stor_ante(Nhru) ) + IF ( Dprst_flag==1 ) ALLOCATE ( Dprst_stor_ante(Nhru) ) + ENDIF + + END FUNCTION srunoffdecl + +!*********************************************************************** +! srunoffinit - Initialize srunoff module - get parameter values +!*********************************************************************** + INTEGER FUNCTION srunoffinit() + USE PRMS_SRUNOFF + USE PRMS_MODULE, ONLY: Dprst_flag, Nhru, Nlake, Cascade_flag, Sroff_flag, & + & Init_vars_from_file, Call_cascade, Water_use_flag, & + & Frozen_flag!, Parameter_check_flag + USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order +! USE PRMS_FLOWVARS, ONLY: Soil_moist_max + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: getparam + EXTERNAL read_error +! Local Variables + INTEGER :: i, j !, k, num_hrus +! REAL :: frac +!*********************************************************************** + srunoffinit = 0 + + Use_sroff_transfer = 0 + IF ( Water_use_flag==1 ) Use_sroff_transfer = 1 + + Imperv_evap = 0.0 + Hortonian_flow = 0.0 + Hru_sroffi = 0.0 + Hru_sroffp = 0.0 + Contrib_fraction = 0.0 + Hru_impervevap = 0.0 + Hru_impervstor = 0.0 + IF ( Call_cascade==1 ) Strm_seg_in = 0.0D0 + IF ( Cascade_flag>0 ) THEN + Upslope_hortonian = 0.0D0 + Hru_hortn_cascflow = 0.0D0 + IF ( Nlake>0 ) Hortonian_lakes = 0.0D0 + ENDIF + + IF ( Init_vars_from_file==0 ) THEN + Basin_sroffi = 0.0D0 + Basin_sroffp = 0.0D0 + Basin_infil = 0.0D0 + Basin_sroff = 0.0D0 + Basin_imperv_evap = 0.0D0 + Basin_imperv_stor = 0.0D0 + Basin_hortonian = 0.0D0 + Basin_dprst_sroff = 0.0D0 + Basin_dprst_evap = 0.0D0 + Basin_dprst_seep = 0.0D0 + Basin_dprst_volop = 0.0D0 + Basin_dprst_volcl = 0.0D0 + Basin_sroff_upslope = 0.0D0 + Basin_sroff_down = 0.0D0 + Basin_hortonian_lakes = 0.0D0 + Basin_contrib_fraction = 0.0D0 + Srp = 0.0 + Sri = 0.0 + IF ( Frozen_flag==1 ) THEN + Frozen = 0 + Cfgi = 0.0 + Cfgi_prev = 0.0 + Frz_depth = 0.0 + Thaw_depth = 0.0 + ENDIF + ENDIF + + IF ( getparam(MODNAME, 'carea_max', Nhru, 'real', Carea_max)/=0 ) CALL read_error(2, 'carea_max') + + IF ( Sroff_flag==1 ) THEN +! Smidx parameters + IF ( getparam(MODNAME, 'smidx_coef', Nhru, 'real', Smidx_coef)/=0 ) CALL read_error(2, 'smidx_coef') + IF ( getparam(MODNAME, 'smidx_exp', Nhru, 'real', Smidx_exp)/=0 ) CALL read_error(2, 'smidx_exp') + ELSE !IF ( Sroff_flag==2 ) THEN +! Carea parameters + IF ( getparam(MODNAME, 'carea_min', Nhru, 'real', Carea_min)/=0 ) CALL read_error(2, 'carea_min') + Carea_dif = 0.0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + Carea_dif(i) = Carea_max(i) - Carea_min(i) + ENDDO + ENDIF + +! num_hrus = 0 +! DO j = 1, Active_hrus +! i = Hru_route_order(j) +! IF ( Sroff_flag==2 ) THEN +! Carea_dif(i) = Carea_max(i) - Carea_min(i) +! ELSEIF ( Parameter_check_flag>0 ) THEN +! frac = Smidx_coef(i)*10**(Soil_moist_max(i)*Smidx_exp(i)) +! k = 0 +! IF ( frac>2.0 ) k = 1 +! IF ( frac>Carea_max(i)*2.0 ) k = k + 2 +! IF ( k>0 ) THEN +! num_hrus = num_hrus + 1 + !IF ( Print_debug>-1 ) THEN + ! PRINT *, ' ' + ! PRINT *, 'WARNING' + ! PRINT *, 'Contributing area based on smidx parameters and soil_moist_max:', frac + ! IF ( k==1 .OR. k==3 ) PRINT *, 'Maximum contributing area > 200%' + ! IF ( k>1 ) PRINT *, 'Maximum contributing area > carea_max:', Carea_max(i) + ! PRINT *, 'HRU:', i, '; soil_moist_max:', Soil_moist_max(i) + ! PRINT *, 'smidx_coef:', Smidx_coef(i), '; smidx_exp:', Smidx_exp(i) + ! PRINT *, 'This can make smidx parameters insensitive and carea_max very sensitive' + !ENDIF +! ENDIF +! ENDIF +! ENDDO +! IF ( num_hrus>0 .AND. Print_debug>-1 ) THEN +! WRITE (*, '(/,A,/,9X,A,/,9X,A,I7,/,9X,A,/,9X,A,/)') & +! & 'WARNING, maximum contributing area based on smidx coefficents and', & +! & 'soil_moist_max are > 200% of the HRU area and/or > 2*carea_max', & +! & 'number of HRUs for which this condition exists:', num_hrus, & +! & 'This means the smidx parameters are insensitive and', & +! & 'carea_max very sensitive for those HRUs' +! ENDIF + +! Frozen soil parameters + IF ( Frozen_flag==1 ) THEN + IF ( getparam(MODNAME, 'cfgi_thrshld', 1, 'real', Cfgi_thrshld)/=0 ) CALL read_error(2, 'cfgi_thrshld') + IF ( getparam(MODNAME, 'cfgi_decay', 1, 'real', Cfgi_decay)/=0 ) CALL read_error(2, 'cfgi_decay') + IF ( getparam(MODNAME, 'soil_depth', Nhru, 'real', Soil_depth)/=0 ) CALL read_error(2, 'soil_depth') + IF ( getparam(MODNAME, 'soil_den', Nhru, 'real', Soil_den)/=0 ) CALL read_error(2, 'soil_den') + IF ( getparam(MODNAME, 'porosity_hru', Nhru, 'real', Porosity_hru)/=0 ) CALL read_error(2, 'porosity_hru') + ENDIF + +! Depression Storage parameters and variables: + IF ( Dprst_flag==1 ) CALL dprst_init() + + END FUNCTION srunoffinit + +!*********************************************************************** +! srunoffrun - Computes surface runoff using contributing area +! computations using antecedent soil moisture. +!*********************************************************************** + INTEGER FUNCTION srunoffrun() + USE PRMS_SRUNOFF + USE PRMS_MODULE, ONLY: Dprst_flag, Cascade_flag, Call_cascade, Print_debug, Frozen_flag, Glacier_flag + USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, & + & Hru_perv, Hru_imperv, Hru_percent_imperv, Hru_frac_perv, & + & Dprst_area_max, Hru_area, Hru_type, Basin_area_inv, & + & Dprst_area_clos_max, Dprst_area_open_max, Hru_area_dble, Cov_type, INCH2M + USE PRMS_CLIMATEVARS, ONLY: Potet, Tavgc + USE PRMS_FLOWVARS, ONLY: Sroff, Infil, Imperv_stor, Pkwater_equiv, Dprst_vol_open, Dprst_vol_clos, & + & Imperv_stor_max, Snowinfil_max, Glacier_frac, Soil_moist + USE PRMS_CASCADE, ONLY: Ncascade_hru + USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Hru_intcpevap, Net_apply, Intcp_changeover + USE PRMS_SNOW, ONLY: Snow_evap, Snowcov_area, Snowmelt, Pk_depth, Glacrb_melt, & + & Tcal, Tcal_nosnow, Glacrcov_area, Prev_ann_tempc + IMPLICIT NONE + INTRINSIC SNGL, DBLE + EXTERNAL imperv_et, compute_infil, run_cascade_sroff, dprst_comp, perv_comp +! Local Variables + INTEGER :: i, k, dprst_chk, frzen, active_glacier + REAL :: srunoff, avail_et, hperv, sra, availh2o + DOUBLE PRECISION :: hru_sroff_down, runoff, apply_sroff, cfgi_sroff + REAL :: cfgi_k, depth_cm, nosnow_area, depthg_cm, trad, emiss, emisl ! frozen ground + REAL :: cfgi_kg, depthg_cm, soil_cond, latent_soil, nice, ice_cond ! frozen ground + REAL :: water_cond, sat_cond, mean_cond, lambda, omega, l5, l6, l8 ! frozen ground + REAL :: volumetric_soil, thermal_ratio_alp, fusion_param_mu, frz_height ! frozen ground + REAL :: glcrmltb, temp, temp2, trad, emiss, emisl ! glaciers + REAL, PARAMETER :: Freezepoint = 0.0 !deg C freezing point of soil moisture, could be below 0 in fine grained soil +!*********************************************************************** + srunoffrun = 0 + + IF ( Print_debug==1 ) THEN + Imperv_stor_ante = Hru_impervstor + IF ( Dprst_flag==1 ) Dprst_stor_ante = Dprst_stor_hru + ENDIF + Basin_sroffi = 0.0D0 + Basin_sroffp = 0.0D0 + Basin_sroff = 0.0D0 + Basin_infil = 0.0D0 + Basin_imperv_evap = 0.0D0 + Basin_imperv_stor = 0.0D0 + Basin_hortonian = 0.0D0 + Basin_contrib_fraction = 0.0D0 + Basin_cfgi_sroff = 0.0D0 + Basin_apply_sroff = 0.0D0 + + IF ( Call_cascade==1 ) Strm_seg_in = 0.0D0 + IF ( Cascade_flag>0 ) THEN + Basin_sroff_down = 0.0D0 + Basin_sroff_upslope = 0.0D0 + Basin_hortonian_lakes = 0.0D0 + Upslope_hortonian = 0.0D0 + ENDIF + + IF ( Dprst_flag==1 ) THEN + Basin_dprst_sroff = 0.0D0 + Basin_dprst_evap = 0.0D0 + Basin_dprst_seep = 0.0D0 + Basin_dprst_volop = 0.0D0 + Basin_dprst_volcl = 0.0D0 + ENDIF + + dprst_chk = 0 + DO k = 1, Active_hrus + i = Hru_route_order(k) + Hruarea = Hru_area(i) + Hruarea_dble = Hru_area_dble(i) + Ihru = i + runoff = 0.0D0 + glcrmltb = 0.0 ! glacier + Isglacier = 0 + active_glacier = -1 ! not an glacier + IF ( Glacier_flag>0 ) THEN + IF ( Hru_type(i)==4 ) THEN + IF ( Glacier_flag==1 ) THEN ! glacier + Isglacier = 1 + glcrmltb = Glacrb_melt(i) + IF ( Glacier_frac(i)>0.0 ) THEN + active_glacier = 1 + ELSE + active_glacier = 0 ! glacier capable HRU, but not glaciated + ENDIF + ENDIF + ENDIF + ENDIF + + IF ( Hru_type(i)==2 ) THEN +! HRU is a lake +! eventually add code for lake area less than hru_area +! that includes soil_moist for fraction of hru_area that is dry bank + ! Sanity check + IF ( Infil(i)+Sroff(i)+Imperv_stor(i)+Imperv_evap(i)>0.0 ) & + & PRINT *, 'srunoff lake ERROR', Infil(i), Sroff(i), Imperv_stor(i), Imperv_evap(i), i + IF ( Cascade_flag>0 ) THEN + Hortonian_lakes(i) = Upslope_hortonian(i) + Basin_hortonian_lakes = Basin_hortonian_lakes + Hortonian_lakes(i)*Hruarea_dble + ENDIF + CYCLE + ENDIF + + Infil(i) = 0.0 + hperv = Hru_perv(i) + Perv_frac = Hru_frac_perv(i) + Srp = 0.0 + Sri = 0.0 + Hru_sroffp(i) = 0.0 + Contrib_fraction(i) = 0.0 + Hruarea_imperv = Hru_imperv(i) + Imperv_frac = Hru_percent_imperv(i) + Hru_sroffi(i) = 0.0 + Imperv_evap(i) = 0.0 + Hru_impervevap(i) = 0.0 + + avail_et = Potet(i) - Snow_evap(i) - Hru_intcpevap(i) + + frzen = 0 + thaw_frac = 1.0 + IF ( Frozen_flag==1 ) THEN + ! modCFGI, following Follum et al 2018 + ! set emissivity, which is the fraction of perfect black-body + ! emission that is actually applied + ! Stefan Boltzmann/2 = (11.71E-8)/2 = 0.585E-7 because add for day and night + ! energy available to snowpack proxy temperature + emiss = 0.97 ! [fraction of radiation] snow + emisl = 0.95 ! [fraction of radiation] land based on Jin and Liang 2006 + nosnow_area = 1.0-Snowcov_area(i) + IF (Glacier_flag==1) nosnow_area = nosnow_area-Glacrcov_area(i) !there will only be permafrost if glacierettes + trad = ( Snowcov_area(i)*Tcal(i)/(emiss*0.585E-7) )**0.25 - 273.15 !energy that is available to heat land under snow + trad = trad+( nosnow_area*Tcal_nosnow(i)/(emisl*0.585E-7))**0.25 - 273.15 !energy that is available to heat land without snow + + cfgi_kg = 1.0 !From Follum et al 2018, could be a bit high + IF ( Tavgc(i)>0.0 ) THEN ![cal/cm^2] or [Langleys] + cfgi_k = 0.5 + ELSE + cfgi_k = 0.08 + ENDIF + ! depth over only snow covered area, so real depth of pack because considering land heat too now + depth_cm = SNGL(Pk_depth(i)/Snowcov_area(i))*2.54 + ! depth ground cover only, from Follum et al, 2018, but was in Vermont + If (Cov_type(i)==0) depthg_cm = 0.0 !bare soil (rock, may be mostly impervious already) + If (Cov_type(i)==1) depthg_cm = 4.0 !grasses (boreal grass, tundra) + If (Cov_type(i)==2) depthg_cm = 3.0 !shrub (tundra) + If (Cov_type(i)>=3) depthg_cm = 6.0 !trees + If (Cov_type(i)==4) depthg_cm = 2.0 !coniferous + +! Continuous frozen ground index + Cfgi(i) = Cfgi_decay*Cfgi_prev(i) - trad*( 2.71828**(-0.4*(cfgi_k*depth_cm+cfgi_kg*depthg_cm)) ) + IF ( active_glacier==1 ) THEN + Cfgi(i) = 0.0 !if glacier over, want ground completely unfrozen, or below threshold, infiltration + IF ( Glacier_frac(i)<1.0 ) Cfgi(i) = Cfgi_thrshld ! glacier with some open fraction + ENDIF + IF ( Cfgi(i)<0.0 ) Cfgi(i) = 0.0 +! If above the threshold to be frozen + IF ( Cfgi(i)>=Cfgi_thrshld ) THEN + ! Use modified Berggren formula to get a depth of frozen + ! volumetric heat of fusion of the soil + volumetric_soil = Soil_den(i)*(4.187*0.17 + 0.75*omega)/1.e6 ! J/m^3/K, specific heat of rock, water, ice =0.17, 1, 0.5 *4.187 J/g/K , density in g/cm3 + ! latent heat of fusion of the soil + latent_soil = 334.0*Soil_den(i)*omega/1.e6 ! J/m^3, latent heat of fusion of water = 334 J/g , density in g/cm3 */100 + thermal_ratio_alp = (Prev_ann_tempc(i) - Freezepoint)/(Cfgi(i) - Cfgi_thrshld) !degree K/ index Ti/Ts + IF ( thermal_ratio_alp<0.0 ) thermal_ratio_alp = 0.0 + fusion_param_mu =(Cfgi(i) - Cfgi_thrshld)*volumetric_soil/latent_soil !index/degree K St12 + ! lambda corrects the Stefan formula for the effects of volumetric heat which it neglected + beta = 1.0 !ranges between 0.95 and 1.3 depending on soil type and soil moisture + lambda = 1.0 !Graph in Aldrich 1956, says in Alaska this is usually 1 but if less northern, can be as low as 0.3 + lambda = ( 1.0 + 0.147*fusion_param_mu*((beta*thermal_ratio_alp)**2.0) + l5 = 1.0 -0.16*fusion_param_mu +0.038*(fusion_param_mu**2.0) !Kurylyk and Hayashi 2016, Ti = 0 + l6 = ( 1.0 + 0.147*fusion_param_mu*((beta*thermal_ratio_alp)**2.0)+ 0.535*(fusion_param_mu**0.5)*beta*thermal_ratio_alp )*l5 ! Kurylyk and Hayashi 2016, Ti < 0 + l8 = ( 1.0 + 0.061*(fusion_param_mu**0.88)*((thermal_ratio_alp/beta)**1.65)- 0.43*(fusion_param_mu**0.44)*((thermal_ratio_alp/beta)**0.825) )*l5 ! Kurylyk and Hayashi 2016, Ti > 0 + IF ( Cfgi(i)>Cfgi_prev(i) ) lambda = l8 !freezing + IF ( Cfgi(i)Frz_depth(i) ) Frz_depth(i) = frz_height + IF ( Frz_height==0.0 ) Frz_depth(i) = 0.0 ! everything thawed + Thaw_depth(i) = Frz_depth(i) - frz_height ! active layer is between Frz_depth and Thaw_depth + + ! Can frz_depth be greater than soil_depth? + IF (Frz_height>0.0) THEN + IF ( Thaw_depth(i)==0.0) THEN + frzen = 1 !soil frozen at top + thaw_frac = 0.0 + ELSEIF ( Thaw_depth(i)=Soil_depth(i) ) THEN ! Thaw_depth(i)>=Soil_depth(i)) + frzen = 3 !soil not frozen but below is, thaw_frac = 1.0 + ENDIF + ENDIF + ENDIF + + IF (frzen>0) THEN + ! depression storage states are not changed for frozen parts of soil + IF ( Cascade_flag>0 ) THEN + cfgi_sroff = (1.0-thaw_frac)*(Snowmelt(i) + Net_rain(i) + Upslope_hortonian(i) + glcrmltb)*Hruarea + ELSE + cfgi_sroff = (1.0-thaw_frac)*(Snowmelt(i) + Net_rain(i) + glcrmltb)*Hruarea + ENDIF + IF ( Use_sroff_transfer==1 ) cfgi_sroff = cfgi_sroff + Net_apply(i)*Hruarea + runoff = runoff + cfgi_sroff + Basin_cfgi_sroff = Basin_cfgi_sroff + cfgi_sroff + ELSE !not frozen + Frz_depth(i) = 0.0 + Thaw_depth(i) = 0.0 + ENDIF + Frozen(i) = frzen + Cfgi_prev(i) = Cfgi(i) + ENDIF + +!******Compute runoff for pervious, impervious, and depression storage area, only if not totally frozen ground + IF ( frzen/=1 ) THEN +! DO IRRIGATION APPLICATION, ONLY DONE HERE, ASSUMES NO SNOW and +! only for pervious areas (just like infiltration) + IF ( Use_sroff_transfer==1 ) THEN + IF ( Net_apply(i)>0.0 ) THEN + sra = 0.0 + Infil(i) = Infil(i) + Net_apply(i) + IF ( Hru_type(i)==1 ) THEN + CALL perv_comp(Net_apply(i), Net_apply(i), Infil(i), sra, thaw_frac) +! ** ADD in water from irrigation application and water-use transfer for pervious portion - sra (if any) + apply_sroff = DBLE( sra*hperv ) + Basin_apply_sroff = Basin_apply_sroff + apply_sroff + runoff = runoff + apply_sroff + ENDIF + ENDIF + ENDIF + + availh2o = Intcp_changeover(i) + Net_rain(i) + IF ( Isglacier==1 ) THEN ! glacier + temp = Snowmelt(i) + glcrmltb !Snowmelt or 0.0 + temp2 = availh2o*(1.0-Glacier_frac(i)) + CALL compute_infil(temp2, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), temp, & + & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i), thaw_frac) + ELSE + CALL compute_infil(availh2o, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), Snowmelt(i), & + & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i), thaw_frac) + ENDIF + + ENDIF + + IF ( Dprst_flag==1 ) THEN + Dprst_in(i) = 0.0D0 + dprst_chk = 0 + IF ( Dprst_area_max(i)>0.0 ) THEN + dprst_chk = 1 +! ******Compute the depression storage component +! only call if total depression surface area for each HRU is > 0.0 + IF ( frzen/=1 ) THEN + CALL dprst_comp(Dprst_vol_clos(i), Dprst_area_clos_max(i), Dprst_area_clos(i), & + & Dprst_vol_open_max(i), Dprst_vol_open(i), Dprst_area_open_max(i), Dprst_area_open(i), & + & Dprst_sroff_hru(i), Dprst_seep_hru(i), Sro_to_dprst_perv(i), Sro_to_dprst_imperv(i), & + & Dprst_evap_hru(i), avail_et, availh2o, Dprst_in(i), thaw_frac) + runoff = runoff + Dprst_sroff_hru(i)*Hruarea_dble + ENDIF + ENDIF + ENDIF +! ********************************************************** + + srunoff = 0.0 + IF ( Hru_type(i)==1 .OR. active_glacier==0 ) THEN ! could be an glacier-capable HRU with no ice +!******Compute runoff for pervious and impervious area, and depression storage area + runoff = runoff + DBLE( Srp*hperv + Sri*Hruarea_imperv ) + srunoff = SNGL( runoff/Hruarea_dble ) + +!******Compute HRU weighted average (to units of inches/dt) + IF ( Cascade_flag>0 ) THEN + hru_sroff_down = 0.0D0 + IF ( srunoff>0.0 ) THEN + IF ( Ncascade_hru(i)>0 ) CALL run_cascade_sroff(Ncascade_hru(i), srunoff, hru_sroff_down) + Hru_hortn_cascflow(i) = hru_sroff_down + !IF ( Hru_hortn_cascflow(i)<0.0D0 ) Hru_hortn_cascflow(i) = 0.0D0 + !IF ( Upslope_hortonian(i)<0.0D0 ) Upslope_hortonian(i) = 0.0D0 + Basin_sroff_upslope = Basin_sroff_upslope + Upslope_hortonian(i)*Hruarea_dble + Basin_sroff_down = Basin_sroff_down + hru_sroff_down*Hruarea_dble + ELSE + Hru_hortn_cascflow(i) = 0.0D0 + ENDIF + ENDIF + Hru_sroffp(i) = Srp*Perv_frac + Basin_sroffp = Basin_sroffp + Srp*hperv + ENDIF + + Basin_infil = Basin_infil + DBLE( Infil(i)*hperv ) + Basin_contrib_fraction = Basin_contrib_fraction + DBLE( Contrib_fraction(i)*hperv ) + +!******Compute evaporation from impervious area + IF ( frzen==0 ) THEN + IF ( Hruarea_imperv>0.0 ) THEN + IF ( Imperv_stor(i)>0.0 ) THEN + CALL imperv_et(Imperv_stor(i), Potet(i), Imperv_evap(i), Snowcov_area(i), avail_et) + Hru_impervevap(i) = Imperv_evap(i)*Imperv_frac + !IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 + avail_et = avail_et - Hru_impervevap(i) + IF ( avail_et<0.0 ) THEN + ! sanity check +! IF ( avail_et<-NEARZERO ) PRINT*, 'avail_et<0 in srunoff imperv', i, Nowmonth, Nowday, avail_et + Hru_impervevap(i) = Hru_impervevap(i) + avail_et + IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 + Imperv_evap(i) = Hru_impervevap(i)/Imperv_frac + Imperv_stor(i) = Imperv_stor(i) - avail_et/Imperv_frac + avail_et = 0.0 + ENDIF + Basin_imperv_evap = Basin_imperv_evap + DBLE( Hru_impervevap(i)*Hruarea ) + Hru_impervstor(i) = Imperv_stor(i)*Imperv_frac + Basin_imperv_stor = Basin_imperv_stor + DBLE(Imperv_stor(i)*Hruarea_imperv ) + ENDIF + Hru_sroffi(i) = Sri*Imperv_frac + Basin_sroffi = Basin_sroffi + DBLE( Sri*Hruarea_imperv ) + ENDIF + ENDIF + + IF ( dprst_chk==1 ) Dprst_stor_hru(i) = (Dprst_vol_open(i)+Dprst_vol_clos(i))/Hruarea_dble + + Sroff(i) = srunoff + Hortonian_flow(i) = srunoff + Basin_hortonian = Basin_hortonian + DBLE( srunoff*Hruarea ) + Basin_sroff = Basin_sroff + DBLE( srunoff*Hruarea ) + ENDDO + +!******Compute basin weighted averages (to units of inches/dt) + !rsr, should be land_area??? + Basin_sroff = Basin_sroff*Basin_area_inv + Basin_imperv_evap = Basin_imperv_evap*Basin_area_inv + Basin_imperv_stor = Basin_imperv_stor*Basin_area_inv + Basin_infil = Basin_infil*Basin_area_inv + ! doesn't include CFGI runoff + Basin_sroffp = Basin_sroffp*Basin_area_inv + Basin_sroffi = Basin_sroffi*Basin_area_inv + Basin_hortonian = Basin_hortonian*Basin_area_inv + Basin_contrib_fraction = Basin_contrib_fraction*Basin_area_inv + IF ( Cascade_flag>0 ) THEN + Basin_hortonian_lakes = Basin_hortonian_lakes*Basin_area_inv + Basin_sroff_down = Basin_sroff_down*Basin_area_inv + Basin_sroff_upslope = Basin_sroff_upslope*Basin_area_inv + ENDIF + + IF ( Dprst_flag==1 ) THEN + Basin_dprst_volop = Basin_dprst_volop*Basin_area_inv + Basin_dprst_volcl = Basin_dprst_volcl*Basin_area_inv + Basin_dprst_evap = Basin_dprst_evap*Basin_area_inv + Basin_dprst_seep = Basin_dprst_seep*Basin_area_inv + Basin_dprst_sroff = Basin_dprst_sroff*Basin_area_inv + ENDIF + + END FUNCTION srunoffrun + +!*********************************************************************** +! Subroutine to compute evaporation from impervious area at +! potential ET rate up to available ET +!*********************************************************************** + SUBROUTINE imperv_et(Imperv_stor, Potet, Imperv_evap, Sca, Avail_et) + USE PRMS_SRUNOFF, ONLY: Imperv_frac + IMPLICIT NONE +! Arguments + REAL, INTENT(IN) :: Potet, Sca, Avail_et + REAL, INTENT(INOUT) :: Imperv_stor, Imperv_evap +!*********************************************************************** + IF ( Sca<1.0 ) THEN + IF ( PotetAvail_et ) Imperv_evap = Avail_et/Imperv_frac + Imperv_stor = Imperv_stor - Imperv_evap + ENDIF + !rsr, sanity check +! IF ( Imperv_stor<0.0 ) THEN +! PRINT *, 'imperv_stor<0', Imperv_stor +! Imperv_stor = 0.0 +! ENDIF + + END SUBROUTINE imperv_et + +!*********************************************************************** +! Compute infiltration +!*********************************************************************** + SUBROUTINE compute_infil(Net_rain, Net_ppt, Imperv_stor, Imperv_stor_max, Snowmelt, & + & Snowinfil_max, Net_snow, Pkwater_equiv, Infil, Hru_type, Thaw_frac) + USE PRMS_SRUNOFF, ONLY: Sri, Hruarea_imperv, Upslope_hortonian, Ihru, Srp, Isglacier, & + USE PRMS_SNOW, ONLY: Pptmix_nopack + USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO + USE PRMS_MODULE, ONLY: Cascade_flag + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Hru_type + REAL, INTENT(IN) :: Net_rain, Net_ppt, Imperv_stor_max, Thaw_frac + REAL, INTENT(IN) :: Snowmelt, Snowinfil_max, Net_snow + DOUBLE PRECISION, INTENT(IN) :: Pkwater_equiv + REAL, INTENT(INOUT) :: Imperv_stor, Infil +! Functions + INTRINSIC SNGL + EXTERNAL perv_comp, check_capacity +! Local Variables + REAL :: avail_water + INTEGER :: hru_flag +!*********************************************************************** + hru_flag = 0 + IF ( Hru_type==1 .OR. Isglacier==1 ) hru_flag = 1 ! land or glacier +! compute runoff from cascading Hortonian flow + IF ( Cascade_flag>0 ) THEN + avail_water = SNGL( Upslope_hortonian(Ihru) ) + IF ( avail_water>0.0 ) THEN + Infil = avail_water + IF ( hru_flag==1 ) CALL perv_comp(avail_water, avail_water, Infil, Srp, Thaw_frac) + ENDIF + ELSE + avail_water = 0.0 + ENDIF + +!******if rain/snow event with no antecedent snowpack, +!******compute the runoff from the rain first and then proceed with the +!******snowmelt computations + + IF ( Pptmix_nopack(Ihru)==1 ) THEN + avail_water = avail_water + Net_rain + Infil = Infil + Net_rain + IF ( hru_flag==1 ) CALL perv_comp(Net_rain, Net_rain, Infil, Srp, Thaw_frac) + ENDIF + +!******If precipitation on snowpack, all water available to the surface is +!******considered to be snowmelt, and the snowmelt infiltration +!******procedure is used. If there is no snowpack and no precip, +!******then check for melt from last of snowpack. If rain/snow mix +!******with no antecedent snowpack, compute snowmelt portion of runoff. + + IF ( Snowmelt>0.0 ) THEN + avail_water = avail_water + Snowmelt + Infil = Infil + Snowmelt + IF ( hru_flag==1 ) THEN + IF ( Pkwater_equiv>0.0D0 .OR. Net_ppt-Net_snow0.0 ) THEN +! no snow, some rain + avail_water = avail_water + Net_rain + Infil = Infil + Net_rain + IF ( hru_flag==1 ) CALL perv_comp(Net_rain, Net_rain, Infil, Srp, Thaw_frac) + ENDIF + +!***** Snowpack exists, check to see if infil exceeds maximum daily +!***** snowmelt infiltration rate. Infil results from rain snow mix +!***** on a snowfree surface. + + ELSEIF ( Infil>0.0 ) THEN + IF ( hru_flag==1 ) CALL check_capacity(Snowinfil_max, Infil) + ENDIF + +!******Impervious area computations + IF ( Hruarea_imperv>0.0 ) THEN + Imperv_stor = Imperv_stor + avail_water + IF ( hru_flag==1 ) THEN + IF ( Imperv_stor>Imperv_stor_max ) THEN + Sri = Imperv_stor - Imperv_stor_max + Imperv_stor = Imperv_stor_max + ENDIF + ENDIF + ENDIF + + END SUBROUTINE compute_infil + +!*********************************************************************** + SUBROUTINE perv_comp(Pptp, Ptc, Infil, Srp, Thaw_frac) + USE PRMS_SRUNOFF, ONLY: Ihru, Smidx_coef, Smidx_exp, & + & Carea_max, Carea_min, Carea_dif, Contrib_fraction, Thaw_frac + USE PRMS_MODULE, ONLY: Sroff_flag +! USE PRMS_BASIN, ONLY: CLOSEZERO + USE PRMS_FLOWVARS, ONLY: Soil_moist, Soil_rechr, Soil_rechr_max + IMPLICIT NONE +! Arguments + REAL, INTENT(IN) :: Pptp, Ptc, Thaw_frac + REAL, INTENT(INOUT) :: Infil, Srp +! Local Variables + REAL :: smidx, srpp, ca_fraction +!*********************************************************************** +!******Pervious area computations + IF ( Sroff_flag==1 ) THEN + ! antecedent soil_moist + smidx = Soil_moist(Ihru) + (0.5*Ptc) + ca_fraction = Smidx_coef(Ihru)*10.0**(Smidx_exp(Ihru)*smidx) + ELSE + ! antecedent soil_rechr + ca_fraction = Carea_min(Ihru) + Carea_dif(Ihru)*(Soil_rechr(Ihru)/(Thaw_frac*Soil_rechr_max(Ihru))) + ENDIF + IF ( ca_fraction>Carea_max(Ihru) ) ca_fraction = Carea_max(Ihru) + srpp = ca_fraction*Pptp + Contrib_fraction(Ihru) = ca_fraction +! IF ( srpp<0.0 ) THEN +! PRINT *, 'negative srp', srpp +! srpp = 0.0 +! ENDIF + Infil = Infil - srpp + Srp = Srp + srpp + !IF ( Srp 0, cascade contributes to a downslope HRU + IF ( j>0 ) THEN + Upslope_hortonian(j) = Upslope_hortonian(j) + DBLE( Runoff*Hru_down_fracwt(k, Ihru) ) + Hru_sroff_down = Hru_sroff_down + DBLE( Runoff*Hru_down_frac(k,Ihru) ) + +! if hru_down(k, Ihru) < 0, cascade contributes to a stream + ELSEIF ( j<0 ) THEN + j = IABS( j ) + Strm_seg_in(j) = Strm_seg_in(j) + DBLE( Runoff*Cascade_area(k, Ihru) )*Cfs_conv + ENDIF + ENDDO + +! reset Sroff as it accumulates flow to streams + Runoff = Runoff - SNGL( Hru_sroff_down ) +! IF ( Runoff<0.0 ) THEN +! IF ( Runoff<-NEARZERO ) THEN +! IF ( Print_debug>-1 ) PRINT *, 'runoff < NEARZERO', Runoff +! IF ( Hru_sroff_down>ABS(Runoff) ) THEN +! Hru_sroff_down = Hru_sroff_down - Runoff +! ELSE +! DO k = 1, Ncascade_hru +! j = Hru_down(k, Ihru) +! IF ( Strm_seg_in(j)>ABS(Runoff) ) THEN +! Strm_seg_in(j) = Strm_seg_in(j) - Runoff +! EXIT +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! Runoff = 0.0 +! ENDIF + + END SUBROUTINE run_cascade_sroff + +!*********************************************************************** +! fill soil to soil_moist_max, if more than capacity restrict +! infiltration by snowinfil_max, with excess added to runoff +!*********************************************************************** + SUBROUTINE check_capacity(Snowinfil_max, Infil) + USE PRMS_FLOWVARS, ONLY: Soil_moist_max, Soil_moist + USE PRMS_SRUNOFF, ONLY: Ihru, Srp + IMPLICIT NONE +! Arguments + REAL, INTENT(IN) :: Snowinfil_max + REAL, INTENT(INOUT) :: Infil +! Local Variables + REAL :: capacity, excess +!*********************************************************************** + capacity = Soil_moist_max(Ihru) - Soil_moist(Ihru) + excess = Infil - capacity + IF ( excess>Snowinfil_max ) THEN + Srp = Srp + excess - Snowinfil_max + Infil = Snowinfil_max + capacity + ENDIF + + END SUBROUTINE check_capacity + +!*********************************************************************** +! Initialize depression storage area hydrology +!*********************************************************************** + SUBROUTINE dprst_init() + USE PRMS_SRUNOFF + USE PRMS_MODULE, ONLY: Init_vars_from_file, Nhru, PRMS4_flag, Inputerror_flag + USE PRMS_BASIN, ONLY: Dprst_clos_flag, NEARZERO, Dprst_frac, & + & Dprst_area_clos_max, Dprst_area_open_max, Basin_area_inv, & + & Hru_area_dble, Active_hrus, Hru_route_order, Dprst_open_flag + USE PRMS_FLOWVARS, ONLY: Dprst_vol_open, Dprst_vol_clos + IMPLICIT NONE +! Functions + INTRINSIC EXP, LOG, DBLE, SNGL + INTEGER, EXTERNAL :: getparam +! Local Variables + INTEGER :: i, j + REAL :: frac_op_ar, frac_cl_ar, open_vol_r, clos_vol_r +!*********************************************************************** + Dprst_evap_hru = 0.0 + Dprst_seep_hru = 0.0D0 + Dprst_sroff_hru = 0.0D0 + Dprst_insroff_hru = 0.0 + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN + IF ( getparam(MODNAME, 'dprst_frac_init', Nhru, 'real', Dprst_frac_init)/=0 ) CALL read_error(2, 'dprst_frac_init') + ENDIF + IF ( getparam(MODNAME, 'dprst_flow_coef', Nhru, 'real', Dprst_flow_coef)/=0 ) CALL read_error(2, 'dprst_flow_coef') + IF ( Dprst_open_flag==1 ) THEN + IF ( getparam(MODNAME, 'dprst_seep_rate_open', Nhru, 'real', Dprst_seep_rate_open)/=0 ) & + & CALL read_error(2, 'dprst_seep_rate_open') + IF ( getparam(MODNAME, 'va_open_exp', Nhru, 'real', Va_open_exp)/=0 ) CALL read_error(2, 'va_open_exp') + IF ( getparam(MODNAME, 'op_flow_thres', Nhru, 'real', Op_flow_thres)/=0 ) CALL read_error(2, 'op_flow_thres') + ELSE + Dprst_seep_rate_open = 0.0 + Va_open_exp = 0.0 + Op_flow_thres = 0.0 + ENDIF + IF ( PRMS4_flag==1 ) THEN + IF ( getparam(MODNAME, 'sro_to_dprst', Nhru, 'real', Sro_to_dprst_perv)/=0 ) CALL read_error(2, 'sro_to_dprst') + ELSE + IF ( getparam(MODNAME, 'sro_to_dprst_perv', Nhru, 'real', Sro_to_dprst_perv)/=0 ) CALL read_error(2, 'sro_to_dprst_perv') + ENDIF + IF ( getparam(MODNAME, 'sro_to_dprst_imperv', Nhru, 'real', Sro_to_dprst_imperv)/=0 ) & + & CALL read_error(2, 'sro_to_dprst_imperv') + IF ( getparam(MODNAME, 'dprst_depth_avg', Nhru, 'real', Dprst_depth_avg)/=0 ) CALL read_error(2, 'dprst_depth_avg') + IF ( getparam(MODNAME, 'dprst_et_coef', Nhru, 'real', Dprst_et_coef)/=0 ) CALL read_error(2, 'dprst_et_coef') + IF ( Dprst_clos_flag==1 ) THEN + IF ( getparam(MODNAME, 'dprst_seep_rate_clos', Nhru, 'real', Dprst_seep_rate_clos)/=0 ) & + & CALL read_error(2, 'dprst_seep_rate_clos') + IF ( getparam(MODNAME, 'va_clos_exp', Nhru, 'real', Va_clos_exp)/=0 ) CALL read_error(2, 'va_clos_exp') + ELSE + Dprst_seep_rate_clos = 0.0 + Va_clos_exp = 0.0 + ENDIF + Dprst_in = 0.0D0 + Dprst_area_open = 0.0 + Dprst_area_clos = 0.0 + Dprst_stor_hru = 0.0D0 + Dprst_vol_thres_open = 0.0D0 + Dprst_vol_open_max = 0.0D0 + Dprst_vol_clos_max = 0.0D0 + Dprst_vol_frac = 0.0 + Dprst_vol_open_frac = 0.0 + Dprst_vol_clos_frac = 0.0 + Basin_dprst_volop = 0.0D0 + Basin_dprst_volcl = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + + IF ( Dprst_frac(i)>0.0 ) THEN + IF ( Dprst_depth_avg(i)==0.0 ) THEN + PRINT *, 'ERROR, dprst_frac>0 and dprst_depth_avg==0 for HRU:', i, '; dprst_frac:', Dprst_frac(i) + Inputerror_flag = 1 + CYCLE + ENDIF +! calculate open and closed volumes (acre-inches) of depression storage by HRU +! Dprst_area_open_max is the maximum open depression area (acres) that can generate surface runoff: + IF ( Dprst_clos_flag==1 ) Dprst_vol_clos_max(i) = DBLE( Dprst_area_clos_max(i)*Dprst_depth_avg(i) ) + IF ( Dprst_open_flag==1 ) Dprst_vol_open_max(i) = DBLE( Dprst_area_open_max(i)*Dprst_depth_avg(i) ) + +! calculate the initial open and closed depression storage volume: + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN + IF ( Dprst_open_flag==1 ) Dprst_vol_open(i) = DBLE(Dprst_frac_init(i))*Dprst_vol_open_max(i) + IF ( Dprst_clos_flag==1 ) Dprst_vol_clos(i) = DBLE(Dprst_frac_init(i))*Dprst_vol_clos_max(i) + ENDIF + +! threshold volume is calculated as the % of maximum open +! depression storage above which flow occurs * total open depression storage volume + Dprst_vol_thres_open(i) = DBLE(Op_flow_thres(i))*Dprst_vol_open_max(i) + +! initial open and closed storage volume as fraction of total open and closed storage volume + +! Open depression surface area for each HRU: + IF ( Dprst_vol_open(i)>0.0D0 ) THEN + open_vol_r = SNGL( Dprst_vol_open(i)/Dprst_vol_open_max(i) ) + IF ( open_vol_r1.0 ) THEN + frac_op_ar = 1.0 + ELSE + frac_op_ar = EXP(Va_open_exp(i)*LOG(open_vol_r)) + ENDIF + Dprst_area_open(i) = Dprst_area_open_max(i)*frac_op_ar + IF ( Dprst_area_open(i)>Dprst_area_open_max(i) ) Dprst_area_open(i) = Dprst_area_open_max(i) +! IF ( Dprst_area_open(i)0.0D0 ) THEN + clos_vol_r = SNGL( Dprst_vol_clos(i)/Dprst_vol_clos_max(i) ) + IF ( clos_vol_r1.0 ) THEN + frac_cl_ar = 1.0 + ELSE + frac_cl_ar = EXP(Va_clos_exp(i)*LOG(clos_vol_r)) + ENDIF + Dprst_area_clos(i) = Dprst_area_clos_max(i)*frac_cl_ar + IF ( Dprst_area_clos(i)>Dprst_area_clos_max(i) ) Dprst_area_clos(i) = Dprst_area_clos_max(i) +! IF ( Dprst_area_clos(i)0.0 ) Dprst_vol_open_frac(i) = SNGL( Dprst_vol_open(i)/Dprst_vol_open_max(i) ) + IF ( Dprst_vol_clos_max(i)>0.0 ) Dprst_vol_clos_frac(i) = SNGL( Dprst_vol_clos(i)/Dprst_vol_clos_max(i) ) + Dprst_vol_frac(i) = SNGL( (Dprst_vol_open(i)+Dprst_vol_clos(i))/(Dprst_vol_open_max(i)+Dprst_vol_clos_max(i)) ) + ENDIF + ENDDO + Basin_dprst_volop = Basin_dprst_volop*Basin_area_inv + Basin_dprst_volcl = Basin_dprst_volcl*Basin_area_inv + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) DEALLOCATE ( Dprst_frac_init ) + + END SUBROUTINE dprst_init + +!*********************************************************************** +! Compute depression storage area hydrology +!*********************************************************************** + SUBROUTINE dprst_comp(Dprst_vol_clos, Dprst_area_clos_max, Dprst_area_clos, & + & Dprst_vol_open_max, Dprst_vol_open, Dprst_area_open_max, Dprst_area_open, & + & Dprst_sroff_hru, Dprst_seep_hru, Sro_to_dprst_perv, Sro_to_dprst_imperv, Dprst_evap_hru, & + & Avail_et, Net_rain, Dprst_in, Thaw_frac) + USE PRMS_SRUNOFF, ONLY: Srp, Sri, Ihru, Perv_frac, Imperv_frac, Hruarea, Dprst_et_coef, & + & Dprst_seep_rate_open, Dprst_seep_rate_clos, Va_clos_exp, Va_open_exp, Dprst_flow_coef, & + & Dprst_vol_thres_open, Dprst_vol_clos_max, Dprst_insroff_hru, Upslope_hortonian, & + & Basin_dprst_volop, Basin_dprst_volcl, Basin_dprst_evap, Basin_dprst_seep, Basin_dprst_sroff, & + & Dprst_vol_open_frac, Dprst_vol_clos_frac, Dprst_vol_frac, Dprst_stor_hru, Hruarea_dble + USE PRMS_MODULE, ONLY: Cascade_flag !, Print_debug + USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Dprst_frac_open, Dprst_frac_clos + USE PRMS_INTCP, ONLY: Net_snow + USE PRMS_CLIMATEVARS, ONLY: Potet + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv + USE PRMS_SNOW, ONLY: Snowmelt, Pptmix_nopack, Snowcov_area + IMPLICIT NONE + INTRINSIC EXP, LOG, MAX, DBLE, SNGL +! Arguments + REAL, INTENT(IN) :: Dprst_area_open_max, Dprst_area_clos_max, Net_rain, Thaw_frac + REAL, INTENT(IN) :: Sro_to_dprst_perv, Sro_to_dprst_imperv + DOUBLE PRECISION, INTENT(IN) :: Dprst_vol_open_max + DOUBLE PRECISION, INTENT(INOUT) :: Dprst_vol_open, Dprst_vol_clos, Dprst_in + REAL, INTENT(INOUT) :: Avail_et + REAL, INTENT(OUT) :: Dprst_area_open, Dprst_area_clos, Dprst_evap_hru + DOUBLE PRECISION, INTENT(OUT) :: Dprst_sroff_hru, Dprst_seep_hru +! Local Variables + REAL :: inflow, dprst_avail_et + REAL :: dprst_srp, dprst_sri + REAL :: dprst_srp_open, dprst_srp_clos, dprst_sri_open, dprst_sri_clos + REAL :: frac_op_ar, frac_cl_ar, open_vol_r, clos_vol_r, unsatisfied_et + REAL :: tmp, dprst_evap_open, dprst_evap_clos + DOUBLE PRECISION :: seep_open, seep_clos, tmp1 +!*********************************************************************** +! add the hortonian flow to the depression storage volumes: + IF ( Cascade_flag>0 ) THEN + inflow = SNGL( Upslope_hortonian(Ihru) ) + ELSE + inflow = 0.0 + ENDIF + + IF ( Pptmix_nopack(Ihru)==1 ) inflow = inflow + Net_rain + +!******If precipitation on snowpack all water available to the surface is considered to be snowmelt +!******If there is no snowpack and no precip,then check for melt from last of snowpack. +!******If rain/snow mix with no antecedent snowpack, compute snowmelt portion of runoff. + + IF ( Snowmelt(Ihru)>0.0 ) THEN + inflow = inflow + Snowmelt(Ihru) + +!******There was no snowmelt but a snowpack may exist. If there is +!******no snowpack then check for rain on a snowfree HRU. + ELSEIF ( Pkwater_equiv(Ihru)0.0 ) THEN + inflow = inflow + Net_rain + ENDIF + ENDIF + + Dprst_in = 0.0D0 + IF ( Dprst_area_open_max>0.0 ) THEN + Dprst_in = DBLE( inflow*Dprst_area_open_max*Thaw_frac ) ! inch-acres + Dprst_vol_open = Dprst_vol_open + Dprst_in + ENDIF + IF ( Dprst_area_clos_max>0.0 ) THEN + tmp1 = DBLE( inflow*Dprst_area_clos_max*Thaw_frac ) ! inch-acres + Dprst_vol_clos = Dprst_vol_clos + tmp1 + Dprst_in = Dprst_in + tmp1 + ENDIF + Dprst_in = Dprst_in/Hruarea_dble ! inches over HRU + + ! add any pervious surface runoff fraction to depressions + dprst_srp = 0.0 + dprst_sri = 0.0 + IF ( Srp>0.0 ) THEN + tmp = Srp*Perv_frac*Sro_to_dprst_perv*Hruarea + IF ( Dprst_area_open_max>0.0 ) THEN + dprst_srp_open = tmp*Dprst_frac_open(Ihru) ! acre-inches + dprst_srp = dprst_srp_open/Hruarea + Dprst_vol_open = Dprst_vol_open + DBLE( dprst_srp_open ) + ENDIF + IF ( Dprst_area_clos_max>0.0 ) THEN + dprst_srp_clos = tmp*Dprst_frac_clos(Ihru) + dprst_srp = dprst_srp + dprst_srp_clos/Hruarea + Dprst_vol_clos = Dprst_vol_clos + DBLE( dprst_srp_clos ) + ENDIF + Srp = Srp - dprst_srp/Perv_frac + IF ( Srp<0.0 ) THEN + IF ( Srp<-NEARZERO ) PRINT *, 'dprst srp<0.0', Srp, dprst_srp + ! may need to adjust dprst_srp and volumes + Srp = 0.0 + ENDIF + ENDIF + + IF ( Sri>0.0 ) THEN + tmp = Sri*Imperv_frac*Sro_to_dprst_imperv*Hruarea + IF ( Dprst_area_open_max>0.0 ) THEN + dprst_sri_open = tmp*Dprst_frac_open(Ihru) + dprst_sri = dprst_sri_open/Hruarea + Dprst_vol_open = Dprst_vol_open + DBLE( dprst_sri_open ) + ENDIF + IF ( Dprst_area_clos_max>0.0 ) THEN + dprst_sri_clos = tmp*Dprst_frac_clos(Ihru) + dprst_sri = dprst_sri + dprst_sri_clos/Hruarea + Dprst_vol_clos = Dprst_vol_clos + DBLE( dprst_sri_clos ) + ENDIF + Sri = Sri - dprst_sri/Imperv_frac + IF ( Sri<0.0 ) THEN + IF ( Sri<-NEARZERO ) PRINT *, 'dprst sri<0.0', Sri, dprst_sri + ! may need to adjust dprst_sri and volumes + Sri = 0.0 + ENDIF + ENDIF + + Dprst_insroff_hru(Ihru) = dprst_srp + dprst_sri + +! Open depression surface area for each HRU: + Dprst_area_open = 0.0 + IF ( Dprst_vol_open>0.0D0 ) THEN + open_vol_r = SNGL( Dprst_vol_open/(Dprst_vol_open_max*Thaw_frac) ) + IF ( open_vol_r1.0 ) THEN + frac_op_ar = 1.0 + ELSE + frac_op_ar = EXP(Va_open_exp(Ihru)*LOG(open_vol_r)) + ENDIF + Dprst_area_open = Dprst_area_open_max*Thaw_frac*frac_op_ar + IF ( Dprst_area_open>Dprst_area_open_max*Thaw_frac ) Dprst_area_open = Dprst_area_open_max*Thaw_frac +! IF ( Dprst_area_open0.0 ) THEN + Dprst_area_clos = 0.0 + IF ( Dprst_vol_clos>0.0D0 ) THEN + clos_vol_r = SNGL( Dprst_vol_clos/(Dprst_vol_clos_max(Ihru)*Thaw_frac) ) + IF ( clos_vol_r1.0 ) THEN + frac_cl_ar = 1.0 + ELSE + frac_cl_ar = EXP(Va_clos_exp(Ihru)*LOG(clos_vol_r)) + ENDIF + Dprst_area_clos = Dprst_area_clos_max*Thaw_frac*frac_cl_ar + IF ( Dprst_area_clos>Dprst_area_clos_max*Thaw_frac ) Dprst_area_clos = Dprst_area_clos_max*Thaw_frac +! IF ( Dprst_area_clos0.0 ) THEN + dprst_evap_open = 0.0 + dprst_evap_clos = 0.0 + IF ( Dprst_area_open>0.0 ) THEN + dprst_evap_open = MIN(Dprst_area_open*dprst_avail_et, SNGL(Dprst_vol_open)) + IF ( dprst_evap_open/Hruarea>unsatisfied_et ) THEN + !IF ( Print_debug>-1 ) THEN + ! PRINT *, 'Warning, open dprst evaporation > available ET, HRU:, ', Ihru, & +! & unsatisfied_et, dprst_evap_open*DBLE(Dprst_frac_open(Ihru)) + ! PRINT *, 'Set to available ET, perhaps dprst_et_coef specified too large' + ! PRINT *, 'Set print_debug to -1 to turn off message' + !ENDIF + dprst_evap_open = unsatisfied_et*Hruarea + ENDIF + !IF ( dprst_evap_open>SNGL(Dprst_vol_open) ) print *, '>', dprst_evap_open, dprst_vol_open + IF ( dprst_evap_open>SNGL(Dprst_vol_open) ) dprst_evap_open = SNGL( Dprst_vol_open ) + unsatisfied_et = unsatisfied_et - dprst_evap_open/Hruarea + Dprst_vol_open = Dprst_vol_open - DBLE( dprst_evap_open ) + ENDIF + IF ( Dprst_area_clos>0.0 ) THEN + dprst_evap_clos = MIN(Dprst_area_clos*dprst_avail_et, SNGL(Dprst_vol_clos)) + IF ( dprst_evap_clos/Hruarea>unsatisfied_et ) THEN + !IF ( Print_debug>-1 ) THEN + ! PRINT *, 'Warning, closed dprst evaporation > available ET, HRU:, ', Ihru, & +! & unsatisfied_et, dprst_evap_clos*Dprst_frac_clos(Ihru) + ! PRINT *, 'Set to available ET, perhaps dprst_et_coef specified too large' + ! PRINT *, 'Set print_debug to -1 to turn off message' + !ENDIF + dprst_evap_clos = unsatisfied_et*Hruarea + ENDIF + IF ( dprst_evap_clos>SNGL(Dprst_vol_clos) ) dprst_evap_clos = SNGL( Dprst_vol_clos ) + Dprst_vol_clos = Dprst_vol_clos - DBLE( dprst_evap_clos ) + ENDIF + Dprst_evap_hru = (dprst_evap_open + dprst_evap_clos)/Hruarea + ENDIF + + ! compute seepage + Dprst_seep_hru = 0.0D0 + IF ( Dprst_vol_open>0.0D0 ) THEN + seep_open = Dprst_vol_open*DBLE( Dprst_seep_rate_open(Ihru) ) + Dprst_vol_open = Dprst_vol_open - seep_open + IF ( Dprst_vol_open<0.0D0 ) THEN +! IF ( Dprst_vol_open<-DNEARZERO ) PRINT *, 'negative dprst_vol_open:', Dprst_vol_open, ' HRU:', Ihru + seep_open = seep_open + Dprst_vol_open + Dprst_vol_open = 0.0D0 + ENDIF + Dprst_seep_hru = seep_open/Hruarea_dble + ENDIF + + ! compute open surface runoff + Dprst_sroff_hru = 0.0D0 + IF ( Dprst_vol_open>0.0D0 ) THEN + Dprst_sroff_hru = MAX( 0.0D0, Dprst_vol_open-Dprst_vol_open_max*Thaw_frac ) + Dprst_sroff_hru = Dprst_sroff_hru + & + & MAX( 0.0D0, (Dprst_vol_open-Dprst_sroff_hru-Dprst_vol_thres_open(Ihru))*DBLE(Dprst_flow_coef(Ihru)) ) + Dprst_vol_open = Dprst_vol_open - Dprst_sroff_hru + Dprst_sroff_hru = Dprst_sroff_hru/Hruarea_dble + ! sanity checks + IF ( Dprst_vol_open<0.0D0 ) THEN +! IF ( Dprst_vol_open<-DNEARZERO ) PRINT *, 'issue, dprst_vol_open<0.0', Dprst_vol_open + Dprst_vol_open = 0.0D0 + ENDIF + ENDIF + + IF ( Dprst_area_clos_max>0.0 ) THEN + IF ( Dprst_area_clos>NEARZERO ) THEN + seep_clos = Dprst_vol_clos*DBLE( Dprst_seep_rate_clos(Ihru) ) + Dprst_vol_clos = Dprst_vol_clos - seep_clos + IF ( Dprst_vol_clos<0.0D0 ) THEN +! IF ( Dprst_vol_clos<-DNEARZERO ) PRINT *, 'issue, dprst_vol_clos<0.0', Dprst_vol_clos + seep_clos = seep_clos + Dprst_vol_clos + Dprst_vol_clos = 0.0D0 + ENDIF + Dprst_seep_hru = Dprst_seep_hru + seep_clos/Hruarea_dble + ENDIF + IF ( Dprst_vol_clos<0.0D0 ) THEN +! IF ( Dprst_vol_clos<-DNEARZERO ) PRINT *, 'issue, dprst_vol_clos<0.0', Dprst_vol_clos + Dprst_vol_clos = 0.0D0 + ENDIF + ENDIF + + Basin_dprst_volop = Basin_dprst_volop + Dprst_vol_open + Basin_dprst_volcl = Basin_dprst_volcl + Dprst_vol_clos + Basin_dprst_evap = Basin_dprst_evap + DBLE( Dprst_evap_hru*Hruarea ) + Basin_dprst_seep = Basin_dprst_seep + Dprst_seep_hru*Hruarea_dble + Basin_dprst_sroff = Basin_dprst_sroff + Dprst_sroff_hru*Hruarea_dble + Avail_et = Avail_et - Dprst_evap_hru + IF ( Dprst_vol_open_max>0.0 ) Dprst_vol_open_frac(Ihru) = SNGL( Dprst_vol_open/(Dprst_vol_open_max*Thaw_frac) ) + IF ( Dprst_vol_clos_max(Ihru)>0.0 ) Dprst_vol_clos_frac(Ihru) = SNGL( Dprst_vol_clos/(Dprst_vol_clos_max(Ihru)*Thaw_frac) ) + Dprst_vol_frac(Ihru) = SNGL( (Dprst_vol_open+Dprst_vol_clos)/((Dprst_vol_open_max+Dprst_vol_clos_max(Ihru))*Thaw_frac) ) + Dprst_stor_hru(Ihru) = (Dprst_vol_open+Dprst_vol_clos)/Hruarea_dble + + END SUBROUTINE dprst_comp + +!*********************************************************************** +! srunoff_restart - write or read srunoff restart file +!*********************************************************************** + SUBROUTINE srunoff_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Dprst_flag, & + & Frozen_flag + USE PRMS_SRUNOFF + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variable + CHARACTER(LEN=13) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Basin_sroff_down, Basin_sroff_upslope, Basin_sroffi, Basin_sroffp, & + & Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, Basin_infil, Basin_hortonian, & + & Sri, Srp, Basin_hortonian_lakes + WRITE ( Restart_outunit ) Basin_dprst_sroff, Basin_dprst_evap, Basin_dprst_seep, & + & Basin_dprst_volop, Basin_dprst_volcl, Basin_contrib_fraction + IF ( Dprst_flag==1 ) THEN + WRITE ( Restart_outunit ) Dprst_area_open + WRITE ( Restart_outunit ) Dprst_area_clos + WRITE ( Restart_outunit ) Dprst_stor_hru + WRITE ( Restart_outunit ) Dprst_vol_thres_open + ENDIF + IF ( Frozen_flag==1 ) THEN + WRITE ( Restart_outunit ) Frozen + WRITE ( Restart_outunit ) Cfgi + WRITE ( Restart_outunit ) Cfgi_prev + WRITE ( Restart_outunit ) Frz_depth, Thaw_depth + ENDIF + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Basin_sroff_down, Basin_sroff_upslope, Basin_sroffi, Basin_sroffp, & + & Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, Basin_infil, Basin_hortonian, & + & Sri, Srp, Basin_hortonian_lakes + READ ( Restart_inunit ) Basin_dprst_sroff, Basin_dprst_evap, Basin_dprst_seep, & + & Basin_dprst_volop, Basin_dprst_volcl, Basin_contrib_fraction + IF ( Dprst_flag==1 ) THEN + READ ( Restart_inunit ) Dprst_area_open + READ ( Restart_inunit ) Dprst_area_clos + READ ( Restart_inunit ) Dprst_stor_hru + READ ( Restart_inunit ) Dprst_vol_thres_open + ENDIF + IF ( Frozen_flag==1 ) THEN ! could be problem for restart + READ ( Restart_inunit ) Frozen + READ ( Restart_inunit ) Cfgi + READ ( Restart_inunit ) Cfgi_prev + READ ( Restart_inunit ) Frz_depth, Thaw_depth + ENDIF + ENDIF + END SUBROUTINE srunoff_restart From 810f312004fe78696ee14cfaa263bf9eb0a5d52f Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 6 Aug 2019 14:06:27 -0600 Subject: [PATCH 24/47] Separating out riparian and permafrost into own folder. --- Makefile | 19 +- makelist | 1 + prms/Makefile | 131 +- prms/call_modulesRip.f90 | 1315 ----------------- prms/mizurouteRip.f90 | 787 ---------- prms/muskingumRip.f90 | 473 ------ prms/routingRip.f90 | 1575 -------------------- prms/snowcompCfgim.f90 | 3027 -------------------------------------- prms/soilzoneCfgim.f90 | 1875 ----------------------- prms/srunoffCfgim.f90 | 1686 --------------------- 10 files changed, 21 insertions(+), 10868 deletions(-) delete mode 100644 prms/call_modulesRip.f90 delete mode 100644 prms/mizurouteRip.f90 delete mode 100644 prms/muskingumRip.f90 delete mode 100644 prms/routingRip.f90 delete mode 100644 prms/snowcompCfgim.f90 delete mode 100644 prms/soilzoneCfgim.f90 delete mode 100644 prms/srunoffCfgim.f90 diff --git a/Makefile b/Makefile index b2e5c039..dbc49f34 100755 --- a/Makefile +++ b/Makefile @@ -13,9 +13,24 @@ include ./makelist # Standard Targets for Users # -all: prmsglrip +all: prmsglrip prmsgl prmsglrip: +# Create lib directory, if necessary + @if [ ! -d $(MMFDIR) ] ; then \ + mkdir $(MMFDIR) ; \ + echo Created directory $(MMFDIR) ; \ + fi +# Create bin directory, if necessary + @if [ ! -d $(BINDIR) ] ; then \ + mkdir $(BINDIR) ; \ + echo Created directory $(BINDIR) ; \ + fi + cd $(MMFDIR); $(MAKE); + cd $(MIZUDIR); $(MAKE); + cd $(PRMSRDIR); $(MAKE); + +prmsgl: # Create lib directory, if necessary @if [ ! -d $(MMFDIR) ] ; then \ mkdir $(MMFDIR) ; \ @@ -30,8 +45,10 @@ prmsglrip: cd $(MIZUDIR); $(MAKE); cd $(PRMSDIR); $(MAKE); + clean: cd $(MMFDIR); $(MAKE) clean; cd $(MIZUDIR); $(MAKE) clean; cd $(PRMSDIR); $(MAKE) clean; + cd $(PRMSRDIR); $(MAKE) clean; $(RM) $(BINDIR)/prms*~ diff --git a/makelist b/makelist index 22c15e9f..da812aee 100644 --- a/makelist +++ b/makelist @@ -7,6 +7,7 @@ MMFDIR = $(F_MASTER)/mmf MIZUDIR = $(F_MASTER)/mizu LIBDIR = $(F_MASTER)/lib PRMSDIR = $(F_MASTER)/prms +PRMSRDIR = $(F_MASTER)/prmsRip BINDIR = $(F_MASTER)/bin MMFLIB = $(LIBDIR)/libmmf.a MIZULIB = $(LIBDIR)/libmizu.a diff --git a/prms/Makefile b/prms/Makefile index afa8a9b9..f5825b96 100644 --- a/prms/Makefile +++ b/prms/Makefile @@ -2,16 +2,11 @@ include ../makelist TARGET = $(BINDIR)/prms -TARGET2 = $(BINDIR)/prmsrip #################################################### # Rules for targets #################################################### -all: $(TARGET) $(TARGET2) - -orig: $(TARGET) - -rip: $(TARGET2) +all: $(TARGET) # # Define all object files which make up the library @@ -74,76 +69,18 @@ OBJS = \ stream_temp.o \ utils_prms.o -RIP = \ - call_modulesRip.o \ - basin.o \ - climateflow.o \ - cascade.o \ - soltab.o \ - setup_param.o \ - convert_params.o \ - prms_time.o \ - obs.o \ - climate_hru.o \ - potet_jh.o \ - potet_pt.o \ - potet_hs.o \ - potet_pm.o \ - potet_pm_sta.o \ - potet_pan.o \ - potet_hamon.o \ - ddsolrad.o \ - ccsolrad.o \ - ide_dist.o \ - xyz_dist.o \ - precip_1sta_laps.o \ - precip_dist2.o \ - temp_1sta_laps.o \ - temp_dist2.o \ - transp_frost.o \ - transp_tindex.o \ - frost_date.o \ - glacr_meltCopy.o \ - intcp.o \ - snowcompCfgim.o \ - srunoffCfgim.o \ - soilzoneCfgim.o \ - gwflowCopy.o \ - water_use_read.o \ - dynamic_param_readCopy.o \ - water_balanceCopy.o \ - routingRip.o \ - strmflowCopy.o \ - strmflow_in_outCopy.o \ - muskingumRip.o \ - muskingum_lakeCopy.o \ - mizurouteRip.o \ - subbasinCopy.o \ - map_results.o \ - nhru_summary.o \ - nsub_summary.o \ - nsegment_summary.o \ - basin_summary.o \ - write_climate_hru.o \ - prms_summaryCopy.o \ - basin_sumCopy.o \ - utils_prms.o \ - stream_tempCopy.o $(TARGET): $(OBJS) $(RM) $(TARGET) $(FC) $(LDFLAGS) -o $(TARGET) $(OBJS) $(MMFLIB) $(MIZULIB) $(INCMIZU) $(FLIBS) -$(TARGET2): $(RIP) - $(RM) $(TARGET2) - $(FC) $(LDFLAGS) -o $(TARGET2) $(RIP) $(MMFLIB) $(MIZULIB) $(INCMIZU) $(FLIBS) # # Define all object files which make up the library # clean: - $(RM) $(OBJS) $(RIP) *.mod *~ + $(RM) $(OBJS) *.mod *~ call_modules.o: call_modules.f90 $(FC) -c $(FFLAGS) call_modules.f90 @@ -310,76 +247,12 @@ routing.o: routing.f90 prms_module.mod prms_basin.mod prms_gwflow.mod prms_flowv mizuroute.o: mizuroute.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routing.mod prms_srunoff.mod prms_gwflow.mod prms_glacr.mod $(FC) -c $(FFLAGS) $(INCMIZU) mizuroute.f90 -muskingumRip.o: muskingumRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod prms_glacrCopy.mod - $(FC) -c $(FFLAGS) muskingumRip.f90 - -routingRip.o: routingRip.f90 prms_moduleRip.mod prms_basin.mod prms_gwflowCopy.mod prms_flowvars.mod prms_set_time.mod prms_water_use.mod prms_srunoffCfgim.mod prms_glacrCopy.mod - $(FC) -c $(FFLAGS) routingRip.f90 - -mizurouteRip.o: mizurouteRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod prms_glacrCopy.mod - $(FC) -c $(FFLAGS) $(INCMIZU) mizurouteRip.f90 - -basin_sumCopy.o: basin_sum.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod prms_climatevars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod - $(FC) -c $(FFLAGS) basin_sum.f90 - -muskingum_lakeCopy.o: muskingum_lake.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod prms_soilzoneCfgim.mod - $(FC) -c $(FFLAGS) muskingum_lake.f90 - -strmflow_in_outCopy.o: strmflow_in_out.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_routingRip.mod prms_obs.mod prms_srunoffCfgim.mod prms_gwflowCopy.mod - $(FC) -c $(FFLAGS) strmflow_in_out.f90 - -stream_tempCopy.o: stream_temp.f90 prms_module.mod prms_basin.mod prms_routingRip.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_soltab.mod prms_climatevars.mod prms_snowCfgim.mod - $(FC) -c $(FFLAGS) stream_temp.f90 - - -srunoffCfgim.o: srunoffCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_climatevars.mod prms_intcp.mod prms_snow.mod prms_cascade.mod prms_set_time.mod - $(FC) -c $(FFLAGS) srunoffCfgim.f90 - -soilzoneCfgim.o: soilzoneCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snowCfgim.mod prms_cascade.mod prms_climatevars.mod prms_set_time.mod prms_srunoffCfgim.mod - $(FC) -c $(FFLAGS) soilzoneCfgim.f90 - -snowcompCfgim.o: snowcompCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_climatevars.mod prms_set_time.mod prms_intcp.mod - $(FC) -c $(FFLAGS) snowcompCfgim.f90 - -prms_summaryCopy.o: prms_summary.f90 prms_module.mod prms_climatevars.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_gwflowCopy.mod - $(FC) -c $(FFLAGS) prms_summary.f90 - -subbasinCopy.o: subbasin.f90 prms_module.mod prms_basin.mod prms_gwflowCopy.mod prms_flowvars.mod prms_set_time.mod prms_intcp.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_muskingum_lake.mod prms_snowCfgim.mod prms_climatevars.mod - $(FC) -c $(FFLAGS) subbasin.f90 - - -water_balanceCopy.o: water_balance.f90 prms_module.mod prms_basin.mod prms_srunoffCfgim.mod prms_flowvars.mod prms_gwflowCopy.mod prms_climatevars.mod prms_set_time.mod prms_cascade.mod prms_intcp.mod prms_snowCfgim.mod prms_soilzoneCfgim.mod - $(FC) -c $(FFLAGS) water_balance.f90 - -dynamic_param_readCopy.o: dynamic_param_read.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_flowvars.mod prms_potet_jh.mod prms_potet_pm.mod prms_potet_hs.mod prms_potet_pt.mod prms_potet_hamon.mod transp_tindex.o transp_frost.o prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_climate_hru.mod - $(FC) -c $(FFLAGS) dynamic_param_read.f90 - - -gwflowCopy.o: gwflow.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_cascade.mod prms_set_time.mod - $(FC) -c $(FFLAGS) gwflow.f90 - - -strmflowCopy.o: strmflow.f90 prms_module.mod prms_basin.mod prms_gwflowCopy.mod prms_srunoffCfgim.mod prms_set_time.mod - $(FC) -c $(FFLAGS) strmflow.f90 - - -glacr_meltCopy.o: glacr_melt.f90 prms_snowCfgim.mod prms_intcp.mod prms_soltab.mod - $(FC) -c $(FFLAGS) glacr_melt.f90 - -prms_routingRip.mod: routingRip.o -prms_moduleRip.mod: call_modulesRip.o -prms_srunoffCfgim.mod: srunoffCfgim.o -prms_soilzoneCfgim.mod: soilzoneCfgim.o -prms_snowcompCfgim.mod: snowcompCfgim.o -prms_gwflowCopy.mod: gwflowCopy.o -prms_glacrCopy.mod: glacr_meltCopy.o prms_climatevars.mod: climateflow.o prms_flowvars.mod: climateflow.o prms_module.mod: call_modules.o prms_gwflow.mod: gwflow.o prms_basin.mod: basin.o prms_soltab.mod: soltab.o -prms_muskingum.mod: muskingum.o prms_intcp.mod: intcp.o prms_snow.mod: snowcomp.o prms_cascade.mod: cascade.o diff --git a/prms/call_modulesRip.f90 b/prms/call_modulesRip.f90 deleted file mode 100644 index 8face3a7..00000000 --- a/prms/call_modulesRip.f90 +++ /dev/null @@ -1,1315 +0,0 @@ -!*********************************************************************** -! Defines the computational sequence, valid modules, and dimensions -!*********************************************************************** - MODULE PRMS_MODULE - IMPLICIT NONE - INTEGER, PARAMETER :: MAXFILE_LENGTH = 256, MAXCONTROL_LENGTH = 32 - INTEGER, PARAMETER :: MAXDIM = 500 - CHARACTER(LEN=68), PARAMETER :: & - & EQULS = '====================================================================' - CHARACTER(LEN=12), PARAMETER :: MODNAME = 'call_modules' - CHARACTER(LEN=24), PARAMETER :: PRMS_VERSION = 'Version 5.0.1 06/20/2019' - CHARACTER(LEN=8), SAVE :: Process - CHARACTER(LEN=80), SAVE :: PRMS_versn - INTEGER, SAVE :: Model, Process_flag, Call_cascade, Ncascade, Ncascdgw - INTEGER, SAVE :: Nhru, Nssr, Ngw, Nsub, Nhrucell, Nlake, Ngwcell, Nlake_hrus - INTEGER, SAVE :: Ntemp, Nrain, Nsol, Nsegment, Ndepl, Nobs, Nevap, Ndeplval - INTEGER, SAVE :: Starttime(6), Endtime(6) - INTEGER, SAVE :: Start_year, Start_month, Start_day, End_year, End_month, End_day - INTEGER, SAVE :: Transp_flag, Sroff_flag, Solrad_flag, Et_flag - INTEGER, SAVE :: Climate_temp_flag, Climate_precip_flag, Climate_potet_flag, Climate_transp_flag - INTEGER, SAVE :: Lake_route_flag, Nratetbl, Strmflow_flag, Stream_order_flag - INTEGER, SAVE :: Temp_flag, Precip_flag, Climate_hru_flag, Climate_swrad_flag, Ripst_flag - INTEGER, SAVE :: Precip_combined_flag, Temp_combined_flag, Muskingum_flag - INTEGER, SAVE :: Inputerror_flag, Timestep - INTEGER, SAVE :: Humidity_cbh_flag, Windspeed_cbh_flag - INTEGER, SAVE :: Stream_temp_flag, Strmtemp_humidity_flag, PRMS4_flag - INTEGER, SAVE :: Grid_flag, Logunt - INTEGER, SAVE :: PRMS_flag, GSFLOW_flag - INTEGER, SAVE :: PRMS_output_unit, Restart_inunit, Restart_outunit - INTEGER, SAVE :: Dynamic_flag, Water_use_flag, Nwateruse, Nexternal, Nconsumed, Npoigages, Prms_warmup - INTEGER, SAVE :: Elapsed_time_start(8), Elapsed_time_end(8), Elapsed_time_minutes - REAL, SAVE :: Execution_time_start, Execution_time_end, Elapsed_time - INTEGER, SAVE :: Kkiter -! Precip_flag (1=precip_1sta; 2=precip_laps; 3=precip_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru -! Temp_flag (1=temp_1sta; 2=temp_laps; 3=temp_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru; 8=temp_sta -! Control parameters - INTEGER, SAVE :: Print_debug, MapOutON_OFF, CsvON_OFF, Dprst_flag, Subbasin_flag, Parameter_check_flag - INTEGER, SAVE :: Init_vars_from_file, Save_vars_to_file, Orad_flag, Cascade_flag, Cascadegw_flag - INTEGER, SAVE :: NhruOutON_OFF, Gwr_swale_flag, NsubOutON_OFF, BasinOutON_OFF, NsegmentOutON_OFF - CHARACTER(LEN=MAXFILE_LENGTH), SAVE :: Model_output_file, Var_init_file, Var_save_file - CHARACTER(LEN=MAXFILE_LENGTH), SAVE :: Csv_output_file, Model_control_file, Param_file - CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Temp_module, Srunoff_module, Et_module - CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Strmflow_module, Transp_module - CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Model_mode, Precip_module, Solrad_module - CHARACTER(LEN=8), SAVE :: Soilzone_module - INTEGER, SAVE :: Dyn_imperv_flag, Dyn_intcp_flag, Dyn_covden_flag, Dyn_covtype_flag, Dyn_transp_flag, Dyn_potet_flag - INTEGER, SAVE :: Dyn_soil_flag, Dyn_radtrncf_flag, Dyn_dprst_flag, Dprst_transferON_OFF - INTEGER, SAVE :: Dyn_snareathresh_flag, Dyn_transp_on_flag - INTEGER, SAVE :: Dyn_sro2dprst_perv_flag, Dyn_sro2dprst_imperv_flag, Dyn_fallfrost_flag, Dyn_springfrost_flag - INTEGER, SAVE :: Gwr_transferON_OFF, External_transferON_OFF, Segment_transferON_OFF, Lake_transferON_OFF - INTEGER, SAVE :: Frozen_flag, Glacier_flag - END MODULE PRMS_MODULE - -!*********************************************************************** - INTEGER FUNCTION call_modules(Arg) - USE PRMS_MODULE - IMPLICIT NONE -! Arguments - CHARACTER(LEN=*), INTENT(IN) :: Arg -! Functions - INTRINSIC :: DATE_AND_TIME, INT - INTEGER, EXTERNAL :: check_dims, basin, climateflow, prms_time, setup - INTEGER, EXTERNAL :: cascade, obs, soltab, transp_tindex - INTEGER, EXTERNAL :: transp_frost, frost_date, routing - INTEGER, EXTERNAL :: temp_1sta_laps, temp_dist2 - INTEGER, EXTERNAL :: precip_1sta_laps, climate_hru - INTEGER, EXTERNAL :: precip_dist2, xyz_dist, ide_dist - INTEGER, EXTERNAL :: ddsolrad, ccsolrad - INTEGER, EXTERNAL :: potet_pan, potet_jh, potet_hamon, potet_hs, potet_pt, potet_pm - INTEGER, EXTERNAL :: intcp, snowcomp, gwflow - INTEGER, EXTERNAL :: srunoff, soilzone, mizuroute - INTEGER, EXTERNAL :: strmflow, subbasin, basin_sum, map_results, write_climate_hru - INTEGER, EXTERNAL :: strmflow_in_out, muskingum, muskingum_lake, numchars - INTEGER, EXTERNAL :: water_use_read, dynamic_param_read, potet_pm_sta - INTEGER, EXTERNAL :: stream_temp - EXTERNAL :: module_error, print_module, PRMS_open_output_file - EXTERNAL :: call_modules_restart, water_balance, basin_summary, nsegment_summary - EXTERNAL :: prms_summary, nhru_summary, module_doc, convert_params, read_error, nsub_summary - INTEGER, EXTERNAL :: glacr -! Local Variables - INTEGER :: i, iret, nc -!*********************************************************************** - call_modules = 1 - - Process = Arg - - IF ( Process(:3)=='run' ) THEN - Process_flag = 0 !(0=run, 1=declare, 2=init, 3=clean, 4=setdims) - - ELSEIF ( Process(:4)=='decl' ) THEN - CALL DATE_AND_TIME(VALUES=Elapsed_time_start) - Execution_time_start = Elapsed_time_start(5)*3600 + Elapsed_time_start(6)*60 + & - & Elapsed_time_start(7) + Elapsed_time_start(8)*0.001 - - Process_flag = 1 - - PRMS_versn = 'call_modules.f90 2019-06-20 15:33:00Z' - - IF ( check_dims()/=0 ) STOP - - IF ( Print_debug>-2 ) THEN - PRINT 10, PRMS_VERSION - WRITE ( PRMS_output_unit, 10 ) PRMS_VERSION - ENDIF - 10 FORMAT (///, 25X, 'U.S. Geological Survey', /, 15X, & - & 'Precipitation-Runoff Modeling System (PRMS)', /, 24X, A) - 15 FORMAT (/, 8X, 'Process', 12X, 'Available Modules', /, 68('-'), /, & - & ' Basin Definition: basin', /, & - & ' Cascading Flow: cascade', /, & - & ' Time Series Data: obs, water_use_read, dynamic_param_read', /, & - & ' Potet Solar Rad: soltab', /, & - & ' Temperature Dist: temp_1sta, temp_laps, temp_dist2, climate_hru', /, & - & ' Precip Dist: precip_1sta, precip_laps, precip_dist2,', /, & - & ' climate_hru', /, & - & 'Temp & Precip Dist: xyz_dist, ide_dist', /, & - & ' Solar Rad Dist: ccsolrad, ddsolrad, climate_hru', /, & - & 'Transpiration Dist: transp_tindex, climate_hru, transp_frost', /, & - & ' Potential ET: potet_hamon, potet_jh, potet_pan, climate_hru,', /, & - & ' potet_hs, potet_pt, potet_pm, potet_pm_sta', /, & - & ' Interception: intcp', /, & - & 'Snow & Glacr Dynam: snowcomp, glacr', /, & - & ' Surface Runoff: srunoff_smidx, srunoff_carea', /, & - & ' Soil Zone: soilzone', /, & - & ' Groundwater: gwflow', /, & - & 'Streamflow Routing: strmflow, strmflow_in_out, muskingum,', /, & - & ' muskingum_lake, muskingum_mann, mizuroute,', /, & - & 'Stream Temperature: stream_temp', /, & - & ' Output Summary: basin_sum, subbasin, map_results, prms_summary,', /, & - & ' nhru_summary, nsub_summary, water_balance', /, & - & ' basin_summary, nsegment_summary', /, & - & ' Preprocessing: write_climate_hru, frost_date', /, 68('-')) - 16 FORMAT (//, 4X, 'Active modules listed in the order in which they are called', //, 8X, 'Process', 19X, & - & 'Module', 16X, 'Version Date', /, A) - IF ( Print_debug>-2 ) THEN - PRINT 15 - PRINT 9002 - WRITE ( PRMS_output_unit, 15 ) - PRINT 16, EQULS - WRITE ( PRMS_output_unit, 16 ) EQULS - ENDIF - CALL print_module(PRMS_versn, 'Computation Order ', 90) - - Kkiter = 1 ! set for PRMS-only mode - - Timestep = 0 - IF ( Init_vars_from_file>0 ) CALL call_modules_restart(1) - - ELSEIF ( Process(:4)=='init' ) THEN - Process_flag = 2 - - Grid_flag = 0 - IF ( Nhru==Nhrucell ) Grid_flag = 1 - - nc = numchars(Model_control_file) - IF ( Print_debug>-1 ) PRINT 9004, 'Using Control File: ', Model_control_file(:nc) - IF ( Print_debug>-2 ) WRITE ( PRMS_output_unit, 9004 ) 'Using Control File: ', Model_control_file(:nc) - - nc = numchars(Param_file) - IF ( Print_debug>-1 ) PRINT 9004, 'Using Parameter File: ', Param_file(:nc) - IF ( Print_debug>-2 ) WRITE ( PRMS_output_unit, 9004 ) 'Using Parameter File: ', Param_file(:nc) - - IF ( Init_vars_from_file>0 ) THEN - nc = numchars(Var_init_file) - IF ( Print_debug>-1 ) PRINT 9004, 'Using var_init_file: ', Var_init_file(:nc) - ENDIF - IF ( Save_vars_to_file==1 ) THEN - nc = numchars(Var_save_file) - IF ( Print_debug>-1 ) PRINT 9004, 'Using var_save_file: ', Var_save_file(:nc) - ENDIF - - IF ( Print_debug>-2 ) THEN - nc = numchars(Model_output_file) - PRINT 9004, 'Writing PRMS Water Budget File: ', Model_output_file(:nc) - ENDIF - - ELSEIF ( Process(:7)=='setdims' ) THEN - Process_flag = 4 - - ELSE !IF ( Process(:5)=='clean' ) THEN - Process_flag = 3 - IF ( Init_vars_from_file>0 ) CLOSE ( Restart_inunit ) - IF ( Save_vars_to_file==1 ) THEN - nc = numchars(Var_save_file) - CALL PRMS_open_output_file(Restart_outunit, Var_save_file(:nc), 'var_save_file', 1, iret) - IF ( iret/=0 ) STOP - CALL call_modules_restart(0) - ENDIF - ENDIF - - IF ( Model==99 ) THEN - IF ( Process_flag==4 .OR. Process_flag<2 ) THEN - Init_vars_from_file = 0 ! make sure this is set so all variables and parameters are declared - CALL module_doc() - call_modules = 0 - RETURN - ELSE - STOP - ENDIF - ENDIF - -! All modules must be called for setdims, declare, initialize, and cleanup - IF ( Process_flag/=0 ) THEN - call_modules = basin() - IF ( call_modules/=0 ) CALL module_error('basin', Arg, call_modules) - - IF ( Call_cascade==1 ) THEN - call_modules = cascade() - IF ( call_modules/=0 ) CALL module_error('cascade', Arg, call_modules) - ENDIF - - call_modules = climateflow() - IF ( call_modules/=0 ) CALL module_error('climateflow', Arg, call_modules) - - call_modules = soltab() - IF ( call_modules/=0 ) CALL module_error('soltab', Arg, call_modules) - - call_modules = setup() - IF ( call_modules/=0 ) CALL module_error('setup', Arg, call_modules) - ENDIF - - call_modules = prms_time() - IF ( call_modules/=0 ) CALL module_error('prms_time', Arg, call_modules) - - call_modules = obs() - IF ( call_modules/=0 ) CALL module_error('obs', Arg, call_modules) - - IF ( Water_use_flag==1 ) THEN - call_modules = water_use_read() - IF ( call_modules/=0 ) CALL module_error('water_use_read', Arg, call_modules) - ENDIF - - IF ( Dynamic_flag==1 ) THEN - call_modules = dynamic_param_read() - IF ( call_modules/=0 ) CALL module_error('dynamic_param_read', Arg, call_modules) - ENDIF - - IF ( Climate_hru_flag==1 ) THEN - call_modules = climate_hru() - IF ( call_modules/=0 ) CALL module_error('climate_hru', Arg, call_modules) - ENDIF - - IF ( Climate_temp_flag==0 ) THEN - IF ( Temp_combined_flag==1 ) THEN - call_modules = temp_1sta_laps() - ELSEIF ( Temp_flag==6 ) THEN - call_modules = xyz_dist() - ELSEIF ( Temp_flag==3 ) THEN - call_modules = temp_dist2() - ELSE !IF ( Temp_flag==5 ) THEN - call_modules = ide_dist() - ENDIF - IF ( call_modules/=0 ) CALL module_error(Temp_module, Arg, call_modules) - ENDIF - - IF ( Climate_precip_flag==0 ) THEN - IF ( Precip_combined_flag==1 ) THEN - call_modules = precip_1sta_laps() - ELSEIF ( Precip_flag==3 ) THEN - call_modules = precip_dist2() - ENDIF - IF ( call_modules/=0 ) CALL module_error(Precip_module, Arg, call_modules) - ENDIF - - IF ( Model==6 ) THEN - IF ( Process_flag==0 ) RETURN - ENDIF - -! frost_date is a pre-process module - IF ( Model==9 ) THEN - call_modules = frost_date() - IF ( call_modules/=0 ) CALL module_error('frost_date', Arg, call_modules) - IF ( Process_flag==0 ) RETURN - IF ( Process_flag==3 ) STOP - ENDIF - - IF ( Climate_swrad_flag==0 ) THEN - IF ( Solrad_flag==1 ) THEN - call_modules = ddsolrad() - ELSE !IF ( Solrad_flag==2 ) THEN - call_modules = ccsolrad() - ENDIF - IF ( call_modules/=0 ) CALL module_error(Solrad_module, Arg, call_modules) - ENDIF - - IF ( Transp_flag==1 ) THEN - call_modules = transp_tindex() - ELSEIF ( Transp_flag==2 ) THEN - call_modules = transp_frost() - ENDIF - IF ( call_modules/=0 ) CALL module_error(Transp_module, Arg, call_modules) - - IF ( Model==8 ) THEN - IF ( Process_flag==0 ) RETURN - ENDIF - - IF ( Climate_potet_flag==0 ) THEN - IF ( Et_flag==1 ) THEN - call_modules = potet_jh() - ELSEIF ( Et_flag==2 ) THEN - call_modules = potet_hamon() - ELSEIF ( Et_flag==4 ) THEN - call_modules = potet_pan() - ELSEIF ( Et_flag==5 ) THEN - call_modules = potet_pt() - ELSEIF ( Et_flag==6 ) THEN - call_modules = potet_pm_sta() - ELSEIF ( Et_flag==11 ) THEN - call_modules = potet_pm() - ELSE !IF ( Et_flag==10 ) THEN - call_modules = potet_hs() - ENDIF - IF ( call_modules/=0 ) CALL module_error(Et_module, Arg, call_modules) - ENDIF - - IF ( Model==4 ) THEN - call_modules = write_climate_hru() - IF ( call_modules/=0 ) CALL module_error('write_climate_hru', Arg, call_modules) - IF ( Process_flag==0 ) RETURN - ENDIF - - IF ( Model==7 ) THEN - IF ( Process_flag==0 ) RETURN - ENDIF - - call_modules = intcp() - IF ( call_modules/=0 ) CALL module_error('intcp', Arg, call_modules) - - call_modules = snowcomp() - IF ( call_modules/=0 ) CALL module_error('snowcomp', Arg, call_modules) - - IF ( Glacier_flag==1 ) THEN - call_modules = glacr() - IF ( call_modules/=0 ) CALL module_error('glacr', Arg, call_modules) - ENDIF - - call_modules = srunoff() - IF ( call_modules/=0 ) CALL module_error(Srunoff_module, Arg, call_modules) - - call_modules = soilzone() - IF ( call_modules/=0 ) CALL module_error(Soilzone_module, Arg, call_modules) - - call_modules = gwflow() - IF ( call_modules/=0 ) CALL module_error('gwflow', Arg, call_modules) - - IF ( Stream_order_flag==1 ) THEN - call_modules = routing() - IF ( call_modules/=0 ) CALL module_error('routing', Arg, call_modules) - ENDIF - - IF ( Strmflow_flag==1 ) THEN - call_modules = strmflow() - ELSEIF ( Muskingum_flag==1 ) THEN ! muskingum = 4; muskingum_mann = 7 - call_modules = muskingum() - ELSEIF ( Strmflow_flag==5 ) THEN - call_modules = strmflow_in_out() - ELSEIF ( Strmflow_flag==6 ) THEN - call_modules = mizuroute() - ELSEIF ( Strmflow_flag==3 ) THEN - call_modules = muskingum_lake() - ENDIF - IF ( call_modules/=0 ) CALL module_error(Strmflow_module, Arg, call_modules) - - IF ( Stream_temp_flag==1 ) call_modules = stream_temp() - - IF ( Print_debug>-2 ) THEN - call_modules = basin_sum() - IF ( call_modules/=0 ) CALL module_error('basin_sum', Arg, call_modules) - ENDIF - - IF ( Print_debug==1 ) CALL water_balance() - - IF ( MapOutON_OFF>0 ) THEN - call_modules = map_results() - IF ( call_modules/=0 ) CALL module_error('map_results', Arg, call_modules) - ENDIF - - IF ( Subbasin_flag==1 ) THEN - call_modules = subbasin() - IF ( call_modules/=0 ) CALL module_error('subbasin', Arg, call_modules) - ENDIF - - IF ( NhruOutON_OFF>0 ) CALL nhru_summary() - - IF ( NsubOutON_OFF==1 ) CALL nsub_summary() - - IF ( BasinOutON_OFF==1 ) CALL basin_summary() - - IF ( NsegmentOutON_OFF>0 ) CALL nsegment_summary() - - IF ( CsvON_OFF>0 ) CALL prms_summary() - - IF ( Process_flag==0 ) THEN - RETURN - ELSEIF ( Process_flag==3 ) THEN - CALL DATE_AND_TIME(VALUES=Elapsed_time_end) - Execution_time_end = Elapsed_time_end(5)*3600 + Elapsed_time_end(6)*60 + & - & Elapsed_time_end(7) + Elapsed_time_end(8)*0.001 - Elapsed_time = Execution_time_end - Execution_time_start - Elapsed_time_minutes = INT(Elapsed_time/60.0) - IF ( Print_debug>-1 ) THEN - PRINT 9001 - PRINT 9003, 'start', (Elapsed_time_start(i),i=1,3), (Elapsed_time_start(i),i=5,7) - PRINT 9003, 'end ', (Elapsed_time_end(i),i=1,3), (Elapsed_time_end(i),i=5,7) - PRINT '(A,I5,A,F6.2,A,/)', 'Execution elapsed time', Elapsed_time_minutes, ' minutes', & - & Elapsed_time - Elapsed_time_minutes*60.0, ' seconds' - ENDIF - IF ( Print_debug>-2 ) & - & WRITE ( PRMS_output_unit,'(A,I5,A,F6.2,A,/)') 'Execution elapsed time', Elapsed_time_minutes, ' minutes', & - & Elapsed_time - Elapsed_time_minutes*60.0, ' seconds' - IF ( Print_debug>-2 ) CLOSE ( PRMS_output_unit ) - IF ( Save_vars_to_file>0 ) CLOSE ( Restart_outunit ) - ELSEIF ( Process_flag==1 ) THEN - IF ( Print_debug>-2 ) THEN - PRINT '(A)', EQULS - WRITE ( PRMS_output_unit, '(A)' ) EQULS - ENDIF - IF ( Model==10 ) CALL convert_params() - ELSEIF ( Process_flag==2 ) THEN - IF ( Inputerror_flag==1 ) THEN - PRINT '(//,A,//,A,/,A,/,A)', '**Fix input errors in your Parameter File to continue**', & - & ' Set control parameter parameter_check_flag to 0 after', & - & ' all parameter values are valid.' - PRINT '(/,A,/,A,/,A,/,A,/,A,/)', & - & 'If input errors are related to paramters used for automated', & - & 'calibration processes, with CAUTION, set control parameter', & - & 'parameter_check_flag to 0. After calibration set the', & - & 'parameter_check_flag to 1 to verify that those calibration', & - & 'parameters have valid and compatible values.' - ENDIF - IF ( Parameter_check_flag==2 .OR. Inputerror_flag==1 ) STOP - IF ( Model==10 ) THEN - CALL convert_params() - STOP - ENDIF - IF ( Print_debug>-2 ) & - & PRINT 4, 'Simulation time period:', Start_year, Start_month, Start_day, ' -', End_year, End_month, End_day, EQULS - ENDIF - - 4 FORMAT (/, 2(A, I5, 2('/',I2.2)), //, A, /) - 9001 FORMAT (/, 26X, 25('='), /, 26X, 'Normal completion of PRMS', /, 26X, 25('='), /) - 9002 FORMAT (//, 74('='), /, 'Please give careful consideration to fixing all ERROR and WARNING messages', /, 74('=')) - 9003 FORMAT ('Execution ', A, ' date and time (yyyy/mm/dd hh:mm:ss)', I5, 2('/',I2.2), I3, 2(':',I2.2), /) - 9004 FORMAT (/, 2A) - - END FUNCTION call_modules - -!*********************************************************************** -! declare the dimensions -!*********************************************************************** - INTEGER FUNCTION setdims() - USE PRMS_MODULE - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: decldim, declfix, call_modules, control_integer_array, control_file_name - INTEGER, EXTERNAL :: control_string, control_integer - EXTERNAL :: read_error, PRMS_open_output_file, PRMS_open_input_file, check_module_names -! Local Variables - ! Maximum values are no longer limits -! Local Variables - INTEGER :: idim, iret, j -!*********************************************************************** - setdims = 1 - - Inputerror_flag = 0 - - ! debug print flag: - ! -1=quiet - reduced screen output - ! 0=none; 1=water balances; 2=basin; - ! 4=basin_sum; 5=soltab; 7=soil zone; - ! 9=snowcomp; 13=cascade; 14=subbasin tree - IF ( control_integer(Print_debug, 'print_debug')/=0 ) Print_debug = 0 - - IF ( control_integer(Parameter_check_flag, 'parameter_check_flag')/=0 ) Parameter_check_flag = 1 - - IF ( control_string(Model_mode, 'model_mode')/=0 ) CALL read_error(5, 'model_mode') - PRMS4_flag = 1 - IF ( Model_mode(:5)=='PRMS5' ) PRMS4_flag = 0 - PRMS_flag = 1 - GSFLOW_flag = 0 - ! Model (0=GSFLOW; 1=PRMS; 2=MODFLOW) - IF ( Model_mode(:4)=='PRMS' .OR. Model_mode(:4)==' ' .OR. Model_mode(:5)=='DAILY' ) THEN - Model = 1 - ELSEIF ( Model_mode(:5)=='FROST' ) THEN - Model = 9 - ELSEIF ( Model_mode(:13)=='WRITE_CLIMATE' ) THEN - Model = 4 - ELSEIF ( Model_mode(:7)=='CLIMATE' ) THEN - Model = 6 - ELSEIF ( Model_mode(:5)=='POTET' ) THEN - Model = 7 - ELSEIF ( Model_mode(:9)=='TRANSPIRE' ) THEN - Model = 8 - ELSEIF ( Model_mode(:7)=='CONVERT' ) THEN ! can be CONVERT4 or CONVERT5 or CONVERT (=CONVERT5) - Model = 10 - ELSEIF ( Model_mode(:13)=='DOCUMENTATION' ) THEN - Model = 99 - ELSE - PRINT '(/,2A)', 'ERROR, invalid model_mode value: ', Model_mode - STOP - ENDIF - - ! get simulation start_time and end_time - Starttime = -1 - DO j = 1, 6 - IF ( control_integer_array(Starttime(j), j, 'start_time')/=0 ) THEN - PRINT *, 'ERROR, start_time, index:', j, 'value: ', Starttime(j) - STOP - ENDIF - ENDDO - Start_year = Starttime(1) - IF ( Start_year<0 ) STOP 'ERROR, control parameter start_time must be specified' - Start_month = Starttime(2) - Start_day = Starttime(3) - Endtime = -1 - DO j = 1, 6 - IF ( control_integer_array(Endtime(j), j, 'end_time')/=0 ) THEN - PRINT *, 'ERROR, end_time, index:', j, 'value: ', Endtime(j) - STOP - ENDIF - ENDDO - End_year = Endtime(1) - IF ( End_year<0 ) STOP 'ERROR, control parameter start_time must be specified' - End_month = Endtime(2) - End_day = Endtime(3) - - IF ( control_integer(Init_vars_from_file, 'init_vars_from_file')/=0 ) Init_vars_from_file = 0 - IF ( control_integer(Save_vars_to_file, 'save_vars_to_file')/=0 ) Save_vars_to_file = 0 - - ! Open PRMS module output file - IF ( control_string(Model_output_file, 'model_output_file')/=0 ) CALL read_error(5, 'model_output_file') - IF ( Print_debug>-2 ) THEN - CALL PRMS_open_output_file(PRMS_output_unit, Model_output_file, 'model_output_file', 0, iret) - IF ( iret/=0 ) STOP - ENDIF - IF ( control_file_name(Model_control_file)/=0 ) CALL read_error(5, 'control_file_name') - IF ( control_string(Param_file, 'param_file')/=0 ) CALL read_error(5, 'param_file') - - ! Check for restart files - IF ( Init_vars_from_file>0 ) THEN - IF ( control_string(Var_init_file, 'var_init_file')/=0 ) CALL read_error(5, 'var_init_file') - CALL PRMS_open_input_file(Restart_inunit, Var_init_file, 'var_init_file', 1, iret) - IF ( iret/=0 ) STOP - ENDIF - IF ( Save_vars_to_file==1 ) THEN - IF ( control_string(Var_save_file, 'var_save_file')/=0 ) CALL read_error(5, 'var_save_file') - ENDIF - - Temp_module = ' ' - IF ( control_string(Temp_module, 'temp_module')/=0 ) CALL read_error(5, 'temp_module') - Precip_module = ' ' - IF ( control_string(Precip_module, 'precip_module')/=0 ) CALL read_error(5, 'precip_module') - Transp_module = ' ' - IF ( control_string(Transp_module, 'transp_module')/=0 ) CALL read_error(5, 'transp_module') - Et_module = ' ' - IF ( control_string(Et_module, 'et_module')/=0 ) CALL read_error(5, 'et_module') - Srunoff_module = ' ' - IF ( control_string(Srunoff_module, 'srunoff_module')/=0 ) CALL read_error(5, 'srunoff_module') - Solrad_module = ' ' - IF ( control_string(Solrad_module, 'solrad_module')/=0 ) CALL read_error(5, 'solrad_module') - Strmflow_module = 'strmflow' - IF ( control_string(Strmflow_module, 'strmflow_module')/=0 ) CALL read_error(5, 'strmflow_module') - - IF ( Parameter_check_flag>0 ) CALL check_module_names() - - Climate_precip_flag = 0 - Climate_temp_flag = 0 - Climate_transp_flag = 0 - Climate_potet_flag = 0 - Climate_swrad_flag = 0 - - IF ( Precip_module(:11)=='precip_1sta' .OR. Precip_module(:11)=='precip_prms') THEN - Precip_flag = 1 - ELSEIF ( Precip_module(:11)=='precip_laps' ) THEN - Precip_flag = 2 - ELSEIF ( Precip_module(:12)=='precip_dist2' ) THEN - Precip_flag = 3 - ELSEIF ( Precip_module(:8)=='ide_dist' ) THEN - Precip_flag = 5 - ELSEIF ( Precip_module(:11)=='climate_hru' ) THEN - Precip_flag = 7 - Climate_precip_flag = 1 - ELSEIF ( Precip_module(:8)=='xyz_dist' ) THEN - Precip_flag = 6 - ELSE - PRINT '(/,2A)', 'ERROR: invalid precip_module value: ', Precip_module - Inputerror_flag = 1 - ENDIF - Precip_combined_flag = 0 - IF ( Precip_flag==1 .OR. Precip_flag==2 ) Precip_combined_flag = 1 - - IF ( Temp_module(:9)=='temp_1sta' ) THEN - Temp_flag = 1 - ELSEIF ( Temp_module(:9)=='temp_laps' ) THEN - Temp_flag = 2 - ELSEIF ( Temp_module(:10)=='temp_dist2' ) THEN - Temp_flag = 3 - ELSEIF ( Temp_module(:8)=='ide_dist' ) THEN - Temp_flag = 5 - ELSEIF ( Temp_module(:11)=='climate_hru' ) THEN - Temp_flag = 7 - Climate_temp_flag = 1 - ELSEIF ( Temp_module(:8)=='xyz_dist' ) THEN - Temp_flag = 6 - ELSEIF ( Temp_module(:8)=='temp_sta' ) THEN - Temp_flag = 8 - ELSE - PRINT '(/,2A)', 'ERROR, invalid temp_module value: ', Temp_module - Inputerror_flag = 1 - ENDIF - Temp_combined_flag = 0 - IF ( Temp_flag==1 .OR. Temp_flag==2 .OR. Temp_flag==8 ) Temp_combined_flag = 1 - - IF ( Transp_module(:13)=='transp_tindex' ) THEN - Transp_flag = 1 - ELSEIF ( Transp_module(:12)=='transp_frost' ) THEN - Transp_flag = 2 - ELSEIF ( Transp_module(:11)=='climate_hru' ) THEN - Transp_flag = 3 - Climate_transp_flag = 1 - ELSE - PRINT '(/,2A)', 'ERROR, invalid transp_module value: ', Transp_module - Inputerror_flag = 1 - ENDIF - - IF ( Et_module(:8)=='potet_jh' ) THEN - Et_flag = 1 - ELSEIF ( Et_module(:11)=='potet_hamon' ) THEN - Et_flag = 2 - ELSEIF ( Et_module(:11)=='climate_hru' ) THEN - Et_flag = 7 - Climate_potet_flag = 1 - ELSEIF ( Et_module(:8)=='potet_hs' ) THEN - Et_flag = 10 - ELSEIF ( Et_module(:12)=='potet_pm_sta' ) THEN - Et_flag = 6 - ELSEIF ( Et_module(:8)=='potet_pm' ) THEN - Et_flag = 11 - ELSEIF ( Et_module(:8)=='potet_pt' ) THEN - Et_flag = 5 - ELSEIF ( Et_module(:9)=='potet_pan' ) THEN - Et_flag = 4 - ELSE - PRINT '(/,2A)', 'ERROR, invalid et_module value: ', Et_module - Inputerror_flag = 1 - ENDIF - - ! stream_temp - IF ( control_integer(Stream_temp_flag, 'stream_temp_flag')/=0 ) Stream_temp_flag = 0 - ! 0 = CBH File; 1 = specified constant; 2 = Stations - IF ( control_integer(Strmtemp_humidity_flag, 'strmtemp_humidity_flag')/=0 ) Strmtemp_humidity_flag = 0 - - Humidity_cbh_flag = 0 - Windspeed_cbh_flag = 0 - IF ( Et_flag==11 .OR. Et_flag==5 .OR. (Stream_temp_flag==1 .AND. Strmtemp_humidity_flag==0) ) Humidity_cbh_flag = 1 - IF ( Et_flag==11 ) Windspeed_cbh_flag = 1 - - IF ( Srunoff_module(:13)=='srunoff_smidx' ) THEN - Sroff_flag = 1 - ELSEIF ( Srunoff_module(:13)=='srunoff_carea' ) THEN - Sroff_flag = 2 - ELSE - PRINT '(/,2A)', 'ERROR, invalid srunoff_module value: ', Srunoff_module - Inputerror_flag = 1 - ENDIF - - Soilzone_module = 'soilzone' - - IF ( control_integer(Orad_flag, 'orad_flag')/=0 ) Orad_flag = 0 - IF ( Solrad_module(:8)=='ddsolrad' ) THEN - Solrad_flag = 1 - ELSEIF ( Solrad_module(:11)=='climate_hru' ) THEN - Solrad_flag = 7 - Climate_swrad_flag = 1 - ELSEIF ( Solrad_module(:8)=='ccsolrad' ) THEN - Solrad_flag = 2 - ELSE - PRINT '(/,2A)', 'ERROR, invalid solrad_module value: ', Solrad_module - Inputerror_flag = 1 - ENDIF - - Climate_hru_flag = 0 - IF ( Climate_temp_flag==1 .OR. Climate_precip_flag==1 .OR. Climate_potet_flag==1 .OR. & - & Climate_swrad_flag==1 .OR. Climate_transp_flag==1 .OR. & - & Humidity_cbh_flag==1 .OR. Windspeed_cbh_flag==1 ) Climate_hru_flag = 1 - - Muskingum_flag = 0 - IF ( Strmflow_module(:15)=='strmflow_in_out' ) THEN - Strmflow_flag = 5 - ELSEIF ( Strmflow_module(:14)=='muskingum_lake' ) THEN - Strmflow_flag = 3 - ELSEIF ( Strmflow_module(:13)=='strmflow_lake' ) THEN - PRINT '(/,2A)', 'ERROR, invalid strmflow_module value: ', Strmflow_module - Inputerror_flag = 1 - ELSEIF ( Strmflow_module(:8)=='strmflow' ) THEN - Strmflow_flag = 1 - ELSEIF ( Strmflow_module(:14)=='muskingum_mann' ) THEN - Strmflow_flag = 7 - Muskingum_flag = 1 - ELSEIF ( Strmflow_module(:9)=='muskingum' ) THEN - Strmflow_flag = 4 - Muskingum_flag = 1 - ELSEIF ( Strmflow_module(:9)=='mizuroute' ) THEN - Strmflow_flag = 6 - ELSE - PRINT '(/,2A)', 'ERROR, invalid strmflow_module value: ', Strmflow_module - Inputerror_flag = 1 - ENDIF - -! cascade dimensions - IF ( decldim('ncascade', 0, MAXDIM, & - & 'Number of HRU links for cascading flow')/=0 ) CALL read_error(7, 'ncascade') - IF ( decldim('ncascdgw', 0, MAXDIM, & - & 'Number of GWR links for cascading flow')/=0 ) CALL read_error(7, 'ncascdgw') - -! nsegment dimension - IF ( decldim('nsegment', 0, MAXDIM, 'Number of stream-channel segments')/=0 ) CALL read_error(7, 'nsegment') - -! subbasin dimensions - IF ( control_integer(Subbasin_flag, 'subbasin_flag')/=0 ) Subbasin_flag = 1 - IF ( decldim('nsub', 0, MAXDIM, 'Number of internal subbasins')/=0 ) CALL read_error(7, 'nsub') - - IF ( control_integer(Dprst_flag, 'dprst_flag')/=0 ) Dprst_flag = 0 - ! 0 = off, 1 = on, 2 = lauren version - IF ( control_integer(CsvON_OFF, 'csvON_OFF')/=0 ) CsvON_OFF = 0 - IF ( control_integer(Ripst_flag, 'ripst_flag')/=0 ) Ripst_flag = 0 - -! map results dimensions - IF ( control_integer(MapOutON_OFF, 'mapOutON_OFF')/=0 ) MapOutON_OFF = 0 - idim = 0 - IF ( GSFLOW_flag==1 .OR. MapOutON_OFF==1 ) idim = 1 - IF ( decldim('nhrucell', idim, MAXDIM, & - & 'Number of unique intersections between HRUs and spatial units of a target map for mapped results')/=0 ) & - & CALL read_error(7, 'nhrucell') - IF ( decldim('ngwcell', 0, MAXDIM, & - & 'Number of spatial units in the target map for mapped results')/=0 ) CALL read_error(7, 'ngwcell') - - IF ( control_integer(Glacier_flag, 'glacier_flag')/=0 ) Glacier_flag = 0 - IF ( control_integer(Frozen_flag, 'frozen_flag')/=0 ) Frozen_flag = 0 - IF ( control_integer(Dyn_imperv_flag, 'dyn_imperv_flag')/=0 ) Dyn_imperv_flag = 0 - IF ( control_integer(Dyn_intcp_flag, 'dyn_intcp_flag')/=0 ) Dyn_intcp_flag = 0 - IF ( control_integer(Dyn_covden_flag, 'dyn_covden_flag')/=0 ) Dyn_covden_flag = 0 - IF ( control_integer(Dyn_dprst_flag, 'dyn_dprst_flag')/=0 ) Dyn_dprst_flag = 0 - IF ( control_integer(Dyn_potet_flag, 'dyn_potet_flag')/=0 ) Dyn_potet_flag = 0 - IF ( control_integer(Dyn_covtype_flag, 'dyn_covtype_flag')/=0 ) Dyn_covtype_flag = 0 - IF ( control_integer(Dyn_transp_flag, 'dyn_transp_flag')/=0 ) Dyn_transp_flag = 0 - IF ( control_integer(Dyn_soil_flag, 'dyn_soil_flag')/=0 ) Dyn_soil_flag = 0 - IF ( control_integer(Dyn_radtrncf_flag, 'dyn_radtrncf_flag')/=0 ) Dyn_radtrncf_flag = 0 - IF ( control_integer(Dyn_sro2dprst_perv_flag, 'dyn_sro2dprst_perv_flag')/=0 ) Dyn_sro2dprst_perv_flag = 0 - IF ( control_integer(Dyn_sro2dprst_imperv_flag, 'dyn_sro2dprst_imperv_flag')/=0 ) Dyn_sro2dprst_imperv_flag = 0 - IF ( control_integer(Dyn_fallfrost_flag, 'dyn_fallfrost_flag')/=0 ) Dyn_fallfrost_flag = 0 - IF ( control_integer(Dyn_springfrost_flag, 'dyn_springfrost_flag')/=0 ) Dyn_springfrost_flag = 0 - IF ( control_integer(Dyn_snareathresh_flag, 'dyn_snareathresh_flag')/=0 ) Dyn_snareathresh_flag = 0 - IF ( control_integer(Dyn_transp_on_flag, 'dyn_transp_on_flag')/=0 ) Dyn_transp_on_flag = 0 - Dynamic_flag = 0 - IF ( Dyn_imperv_flag/=0 .OR. Dyn_intcp_flag/=0 .OR. Dyn_covden_flag/=0 .OR. Dyn_dprst_flag/=0 .OR. & - & Dyn_potet_flag/=0 .OR. Dyn_covtype_flag/=0 .OR. Dyn_transp_flag/=0 .OR. Dyn_soil_flag /=0 .OR. & - & Dyn_radtrncf_flag/=0 .OR. Dyn_sro2dprst_perv_flag/=0 .OR. Dyn_sro2dprst_imperv_flag/=0 .OR. & - & Dyn_fallfrost_flag/=0 .OR. Dyn_springfrost_flag/=0 .OR. Dyn_snareathresh_flag/=0 .OR. & - & Dyn_transp_on_flag/=0 ) Dynamic_flag = 1 - IF ( control_integer(Gwr_transferON_OFF, 'gwr_transferON_OFF')/=0) Gwr_transferON_OFF = 0 - IF ( control_integer(External_transferON_OFF, 'external_transferON_OFF')/=0 ) External_transferON_OFF = 0 - IF ( control_integer(Dprst_transferON_OFF, 'dprst_transferON_OFF')/=0 ) Dprst_transferON_OFF = 0 - IF ( control_integer(Segment_transferON_OFF, 'segment_transferON_OFF')/=0 ) Segment_transferON_OFF = 0 - IF ( control_integer(Lake_transferON_OFF, 'lake_transferON_OFF')/=0 ) Lake_transferON_OFF = 0 - IF ( control_integer(Gwr_swale_flag, 'gwr_swale_flag')/=0 ) Gwr_swale_flag = 0 - -! nhru_summary - IF ( control_integer(NhruOutON_OFF, 'nhruOutON_OFF')/=0 ) NhruOutON_OFF = 0 - -! nsub_summary - IF ( control_integer(NsubOutON_OFF, 'nsubOutON_OFF')/=0 ) NsubOutON_OFF = 0 - -! basin_summary - IF ( control_integer(BasinOutON_OFF, 'basinOutON_OFF')/=0 ) BasinOutON_OFF = 0 - -! nsegment_summary - IF ( control_integer(NsegmentOutON_OFF, 'nsegmentOutON_OFF')/=0 ) NsegmentOutON_OFF = 0 - - IF ( control_integer(Prms_warmup, 'prms_warmup')/=0 ) Prms_warmup = 0 - IF ( NhruOutON_OFF>0 .OR. NsubOutON_OFF>0 .OR. BasinOutON_OFF>0 .OR. NsegmentOutON_OFF>0 ) THEN - IF ( Start_year+Prms_warmup>End_year ) THEN ! change to start full date ??? - PRINT *, 'ERROR, prms_warmup > than simulation time period:', Prms_warmup - Inputerror_flag = 1 - ENDIF - ENDIF - -! cascade - ! if cascade_flag = 2, use hru_segment parameter for cascades, ncascade=ncascdgw=nhru (typical polygon HRUs) - IF ( control_integer(Cascade_flag, 'cascade_flag')/=0 ) Cascade_flag = 1 - ! if cascadegw_flag = 2, use same cascades as HRUs - IF ( control_integer(Cascadegw_flag, 'cascadegw_flag')/=0 ) Cascadegw_flag = 1 - -! spatial units - IF ( decldim('ngw', 1, MAXDIM, 'Number of GWRs')/=0 ) CALL read_error(7, 'ngw') - IF ( decldim('nhru', 1, MAXDIM, 'Number of HRUs')/=0 ) CALL read_error(7, 'nhru') - IF ( decldim('nssr', 1, MAXDIM, 'Number of subsurface reservoirs')/=0 ) CALL read_error(7, 'nssr') - IF ( decldim('nlake', 0, MAXDIM, 'Number of lakes')/=0 ) CALL read_error(7, 'nlake') - ! nlake_hrus to be added in 5.0.1 -! IF ( decldim('nlake_hrus', 0, MAXDIM, 'Number of lake HRUs')/=0 ) CALL read_error(7, 'nlake_hrus') - IF ( decldim('npoigages', 0, MAXDIM, 'Number of POI gages')/=0 ) CALL read_error(7, 'npoigages') - -! Time-series data stations, need to know if in Data File - IF ( decldim('nrain', 0, MAXDIM, 'Number of precipitation-measurement stations')/=0 ) CALL read_error(7, 'nrain') - IF ( decldim('nsol', 0, MAXDIM, 'Number of solar-radiation measurement stations')/=0 ) CALL read_error(7, 'nsol') - IF ( decldim('ntemp', 0, MAXDIM, 'Number of air-temperature-measurement stations')/=0 ) CALL read_error(7, 'ntemp') - IF ( decldim('nobs', 0, MAXDIM, 'Number of streamflow-measurement stations')/=0 ) CALL read_error(7, 'nobs') - IF ( decldim('nevap', 0, MAXDIM, 'Number of pan-evaporation data sets')/=0 ) CALL read_error(7, 'nevap') - IF ( decldim('nratetbl', 0, MAXDIM, 'Number of rating-table data sets for lake elevations') & - & /=0 ) CALL read_error(7, 'nratetbl') - -! depletion curves - IF ( decldim('ndepl', 1, MAXDIM, 'Number of snow-depletion curves')/=0 ) CALL read_error(7, 'ndelp') - IF ( decldim('ndeplval', 11, MAXDIM, 'Number of values in all snow-depletion curves (set to ndepl*11)')/=0 ) & - & CALL read_error(7, 'ndelplval') - -! water-use - IF ( decldim('nwateruse', 0, MAXDIM, 'Number of water-use data sets')/=0 ) CALL read_error(7, 'nwateruse') - IF ( decldim('nexternal', 0, MAXDIM, & - & 'Number of external water-use sources or destinations')/=0 ) CALL read_error(7, 'nexternal') - IF ( decldim('nconsumed', 0, MAXDIM, 'Number of consumptive water-use destinations')/=0 ) CALL read_error(7, 'nconsumed') - -! fixed dimensions - IF ( declfix('ndays', 366, 366, 'Maximum number of days in a year ')/=0 ) CALL read_error(7, 'ndays') - IF ( declfix('nmonths', 12, 12, 'Number of months in a year')/=0 ) CALL read_error(7, 'nmonths') - IF ( declfix('one', 1, 1, 'Number of values for scaler array')/=0 ) CALL read_error(7, 'one') - - IF ( call_modules('setdims')/=0 ) STOP 'ERROR, in setdims' - - IF ( Inputerror_flag==1 ) THEN - PRINT '(//,A,/,A)', '**FIX input errors in your Control File to continue**', & - & 'NOTE: some errors may be due to use of defalut values' - STOP - ENDIF - - setdims = 0 - END FUNCTION setdims - -!*********************************************************************** -! Get and check consistency of dimensions with flags -!*********************************************************************** - INTEGER FUNCTION check_dims() - USE PRMS_MODULE - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: getdim - EXTERNAL :: check_dimens -! Local Variables - INTEGER :: ierr -!*********************************************************************** - - Nhru = getdim('nhru') - IF ( Nhru==-1 ) CALL read_error(7, 'nhru') - - Nssr = getdim('nssr') - IF ( Nssr==-1 ) CALL read_error(7, 'nssr') - - Ngw = getdim('ngw') - IF ( Ngw==-1 ) CALL read_error(7, 'ngw') - - Ntemp = getdim('ntemp') - IF ( Ntemp==-1 ) CALL read_error(6, 'ntemp') - - Nrain = getdim('nrain') - IF ( Nrain==-1 ) CALL read_error(6, 'nrain') - - Nsol = getdim('nsol') - IF ( Nsol==-1 ) CALL read_error(6, 'nsol') - - Nobs = getdim('nobs') - IF ( Nobs==-1 ) CALL read_error(6, 'nobs') - - Nevap = getdim('nevap') - IF ( Nevap==-1 ) CALL read_error(6, 'nevap') - - Ncascade = getdim('ncascade') - IF ( Ncascade==-1 ) CALL read_error(7, 'ncascade') - Ncascdgw = getdim('ncascdgw') - IF ( Ncascdgw==-1 ) CALL read_error(7, 'ncascdgw') - IF ( Cascade_flag==2 ) THEN - Ncascade = Nhru - Cascadegw_flag = 2 - ENDIF - IF ( Cascadegw_flag==2 ) Ncascdgw = Ncascade - IF ( Ncascade==0 ) Cascade_flag = 0 - IF ( Ncascdgw==0 .OR. GSFLOW_flag==1 .OR. Model==2 ) Cascadegw_flag = 0 - IF ( (Cascade_flag>0 .OR. Cascadegw_flag>0) .AND. Model/=10 ) THEN ! don't call if model_mode = CONVERT - Call_cascade = 1 - ELSE - Call_cascade = 0 - ENDIF - - Nwateruse = getdim('nwateruse') - IF ( Nwateruse==-1 ) CALL read_error(7, 'nwateruse') - - Nexternal = getdim('nexternal') - IF ( Nexternal==-1 ) CALL read_error(6, 'nexternal') - - Nconsumed = getdim('nconsumed') - IF ( Nconsumed==-1 ) CALL read_error(6, 'nconsumed') - - Npoigages = getdim('npoigages') - IF ( Npoigages==-1 ) CALL read_error(6, 'npoigages') - - Nlake = getdim('nlake') - IF ( Nlake==-1 ) CALL read_error(7, 'nlake') - - ! Nlake_hrus will be added in version 5.0.1 -! Nlake_hrus = getdim('nlake_hrus') -! IF ( Nlake_hrus==-1 ) CALL read_error(7, 'nlake_hrus') -! IF ( Nlake>0 .AND. Nlake_hrus==0 ) Nlake_hrus = Nlake - Nlake_hrus = Nlake - - Ndepl = getdim('ndepl') - IF ( Ndepl==-1 ) CALL read_error(7, 'ndepl') - - Ndeplval = getdim('ndeplval') - IF ( Ndeplval==-1 ) CALL read_error(7, 'ndeplval') - - Nsub = getdim('nsub') - IF ( Nsub==-1 ) CALL read_error(7, 'nsub') - ! default = 1, turn off if no subbasins - IF ( Subbasin_flag==1 .AND. Nsub==0 ) Subbasin_flag = 0 - - Nsegment = getdim('nsegment') - IF ( Nsegment==-1 ) CALL read_error(7, 'nsegment') - - Nhrucell = getdim('nhrucell') - IF ( Nhrucell==-1 ) CALL read_error(6, 'nhrucell') - - Ngwcell = getdim('ngwcell') - IF ( Ngwcell==-1 ) CALL read_error(6, 'ngwcell') - - Nratetbl = getdim('nratetbl') - IF ( Nratetbl==-1 ) CALL read_error(6, 'nratetbl') - - Water_use_flag = 0 - IF ( Nwateruse>0 ) THEN - IF ( Segment_transferON_OFF==1 .OR. Gwr_transferON_OFF==1 .OR. External_transferON_OFF==1 .OR. & - & Dprst_transferON_OFF==1 .OR. Lake_transferON_OFF==1 .OR. Nconsumed>0 .OR. Nwateruse>0 ) Water_use_flag = 1 - ENDIF - - ierr = 0 - IF ( Segment_transferON_OFF==1 .OR. Gwr_transferON_OFF==1 .OR. External_transferON_OFF==1 .OR. & - & Dprst_transferON_OFF==1 .OR. Lake_transferON_OFF==1 .OR. Nconsumed>0 ) THEN - IF ( Dprst_transferON_OFF==1 .AND. Dprst_flag==0 ) THEN - PRINT *, 'ERROR, specified water-use event based dprst input and have dprst inactive' - ierr = 1 - ENDIF - IF ( Lake_transferON_OFF==1 .AND. Strmflow_flag/=3 ) THEN - PRINT *, 'ERROR, specified water-use event based lake input and have lake simulation inactive' - ierr = 1 - ENDIF - ENDIF - IF ( ierr==1 ) STOP - - Stream_order_flag = 0 - IF ( Nsegment>0 .AND. Strmflow_flag>1 .AND. Model/=0 ) THEN - Stream_order_flag = 1 ! strmflow_in_out, muskingum, muskingum_lake, muskingum_mann, mizuroute - ENDIF - - IF ( Nsegment<1 .AND. Model/=99 ) THEN - IF ( Stream_order_flag==1 .OR. Call_cascade==1 ) THEN - PRINT *, 'ERROR, streamflow and cascade routing require nsegment > 0, specified as:', Nsegment - STOP - ENDIF - ENDIF - - Lake_route_flag = 0 - IF ( Nlake>0 .AND. Strmflow_flag==3 .AND. Model/=0 ) Lake_route_flag = 1 ! muskingum_lake - - IF ( NsubOutON_OFF==1 .AND. Nsub==0 ) THEN - NsubOutON_OFF = 0 - IF ( Print_debug>-1 ) PRINT *, 'WARNING, nsubOutON_OFF = 1 and nsub = 0, thus nsub_summary not used' - ENDIF - - IF ( Model==99 .OR. Parameter_check_flag>0 ) CALL check_dimens() - - check_dims = Inputerror_flag - END FUNCTION check_dims - -!*********************************************************************** -! Check consistency of dimensions with flags -!*********************************************************************** - SUBROUTINE check_dimens() - USE PRMS_MODULE - IMPLICIT NONE -! Local Variables - INTEGER :: ierr -!*********************************************************************** - ierr = 0 - IF ( Nhru==0 .OR. Nssr==0 .OR. Ngw==0 ) THEN - PRINT *, 'ERROR, nhru, nssr, and ngw must be > 0: nhru=', Nhru, ', nssr=', Nssr, ', ngw=', Ngw - ierr = 1 - ELSEIF ( Nssr/=Nhru .OR. Ngw/=Nhru ) THEN - PRINT *, 'ERROR, nhru, nssr, and ngw must equal: nhru=', Nhru, ', nssr=', Nssr, ', ngw=', Ngw - ierr = 1 - ENDIF - IF ( Ndepl==0 ) THEN - PRINT *, 'ERROR, ndepl must be > 0: ndepl=', Ndepl - ierr = 1 - ENDIF - IF ( Ndeplval/=Ndepl*11 ) THEN - PRINT *, 'ERROR, ndeplval must be = ndepl*11: ndeplval:', Ndeplval, ', ndepl=', Ndepl - ierr = 1 - ENDIF - - IF ( ierr==1 ) STOP - - IF ( Model==99 ) THEN - IF ( Ntemp==0 ) Ntemp = 1 - IF ( Nrain==0 ) Nrain = 1 - IF ( Nlake==0 ) Nlake = 1 - IF ( Nlake_hrus==0 ) Nlake_hrus = 1 - IF ( Nsol==0 ) Nsol = 1 - IF ( Nobs==0 ) Nobs = 1 - IF ( Ncascade==0 ) Ncascade = 1 - IF ( Ncascdgw==0 ) Ncascdgw = 1 - IF ( Nsub==0 ) Nsub = 1 - IF ( Nevap==0 ) Nevap = 1 - IF ( Nhrucell==0 ) Nhrucell = 1 - IF ( Ngwcell==0 ) Ngwcell = 1 - IF ( Nsegment==0 ) Nsegment = 1 - IF ( Nratetbl==0 ) Nratetbl = 4 - IF ( Nwateruse==0 ) Nwateruse = 1 - IF ( Nexternal==0 ) Nexternal = 1 - IF ( Nconsumed==0 ) Nconsumed = 1 - IF ( Npoigages==0 ) Npoigages = 1 - Subbasin_flag = 1 - Cascade_flag = 1 - Cascadegw_flag = 1 - Call_cascade = 1 - Stream_order_flag = 1 - Climate_hru_flag = 1 - Lake_route_flag = 1 - Water_use_flag = 1 - Segment_transferON_OFF = 1 - Gwr_transferON_OFF = 1 - External_transferON_OFF = 1 - Dprst_transferON_OFF = 1 - Lake_transferON_OFF = 1 - ENDIF - - END SUBROUTINE check_dimens - -!********************************************************************** -! Module documentation -!********************************************************************** - SUBROUTINE module_doc() - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: basin, climateflow, prms_time - INTEGER, EXTERNAL :: cascade, obs, soltab, transp_tindex - INTEGER, EXTERNAL :: transp_frost, frost_date, routing - INTEGER, EXTERNAL :: temp_1sta_laps, temp_dist2 - INTEGER, EXTERNAL :: precip_1sta_laps, climate_hru - INTEGER, EXTERNAL :: precip_dist2, xyz_dist, ide_dist - INTEGER, EXTERNAL :: ddsolrad, ccsolrad - INTEGER, EXTERNAL :: potet_pan, potet_jh, potet_hamon, potet_hs, potet_pt, potet_pm - INTEGER, EXTERNAL :: intcp, snowcomp, gwflow, srunoff, soilzone, mizuroute - INTEGER, EXTERNAL :: strmflow, subbasin, basin_sum, map_results, strmflow_in_out - INTEGER, EXTERNAL :: write_climate_hru, muskingum, muskingum_lake - INTEGER, EXTERNAL :: stream_temp - EXTERNAL :: nhru_summary, prms_summary, water_balance, nsub_summary, basin_summary, nsegment_summary - INTEGER, EXTERNAL :: dynamic_param_read, water_use_read, setup, potet_pm_sta - INTEGER, EXTERNAL :: glacr -! Local variable - INTEGER :: test -!********************************************************************** - test = basin() - test = cascade() - test = climateflow() - test = soltab() - test = setup() - test = prms_time() - test = obs() - test = water_use_read() - test = dynamic_param_read() - test = temp_1sta_laps() - test = temp_dist2() - test = xyz_dist() - test = ide_dist() - test = climate_hru() - test = precip_1sta_laps() - test = precip_dist2() - test = ddsolrad() - test = ccsolrad() - test = transp_tindex() - test = frost_date() - test = transp_frost() - test = potet_jh() - test = potet_hamon() - test = potet_pan() - test = potet_hs() - test = potet_pt() - test = potet_pm() - test = potet_pm_sta() - test = write_climate_hru() - test = intcp() - test = snowcomp() - test = srunoff() - test = glacr() - test = soilzone() - test = gwflow() - test = routing() - test = strmflow() - test = strmflow_in_out() - test = muskingum() - test = mizuroute() - test = muskingum_lake() - test = stream_temp() - test = basin_sum() - test = map_results() - CALL nhru_summary() - CALL nsub_summary() - CALL basin_summary() - CALL nsegment_summary() - CALL prms_summary() - CALL water_balance() - test = subbasin() - - PRINT 9001 - 9001 FORMAT (//, ' All available modules have been called.', /, & - & ' All parameters have been declared.', /, & - & ' Note, no simulation was computed.', /) - - END SUBROUTINE module_doc - -!*********************************************************************** -! check module names -!*********************************************************************** - SUBROUTINE check_module_names() - USE PRMS_MODULE, ONLY: Temp_module, Precip_module, Et_module, Solrad_module, & - & Transp_module, Srunoff_module, Strmflow_module - IMPLICIT NONE -! Local Variables - INTEGER :: ierr -!*********************************************************************** - ierr = 0 - IF ( Temp_module(:14)=='temp_1sta_prms' ) THEN - PRINT *, 'WARNING, deprecated temp_module value, change temp_1sta_prms to temp_1sta' - Temp_module = 'temp_1sta' - ELSEIF ( Temp_module(:14)=='temp_laps_prms' ) THEN - PRINT *, 'WARNING, deprecated temp_module value, change temp_laps_prms to temp_laps' - Temp_module = 'temp_laps' - ELSEIF ( Temp_module(:15)=='temp_dist2_prms' ) THEN - PRINT *, 'WARNING, deprecated temp_module value, change temp_dist2_prms to temp_dist2' - Temp_module = 'temp_dist2' - ELSEIF ( Temp_module(:9)=='temp_2sta' ) THEN - PRINT *, 'ERROR, module temp_2sta_prms not available, use a different temp_module' - ierr = 1 - ENDIF - - IF ( Precip_module(:11)=='precip_prms' ) THEN - PRINT *, 'WARNING, deprecated precip_module value, change precip_prms to precip_1sta' - Precip_module = 'precip_1sta' - ELSEIF ( Precip_module(:16)=='precip_laps_prms' ) THEN - PRINT *, 'WARNING, deprecated precip_module value, change precip_laps_prms to precip_laps' - Precip_module = 'precip_laps' - ELSEIF ( Precip_module(:17)=='precip_dist2_prms' ) THEN - PRINT *, 'WARNING, deprecated precip_module value, change precip_dist2_prms to precip_dist2' - Precip_module = 'precip_dist2' - ENDIF - - IF ( Temp_module(:8)=='ide_dist' .AND. Precip_module(:8)/='ide_dist') THEN - PRINT '(/,A,/,2A)', 'ERROR, if ide_dist is specified for temp_module,', & - & 'it also must be specified for precip_module: ', Precip_module - ierr = 1 - ELSEIF ( Precip_module(:8)=='ide_dist' .AND. Temp_module(:8)/='ide_dist') THEN - PRINT '(/,A,/,2A)', 'ERROR, if ide_dist is specified for precip_module,', & - & 'it also must be specified for temp_module: ', Temp_module - ierr = 1 - ELSEIF ( Temp_module(:8)=='xyz_dist' .AND. Precip_module(:8)/='xyz_dist') THEN - PRINT '(/,A,/,2A)', 'ERROR, if xyz_dist is specified for temp_module,', & - & 'it also must be specified for precip_module: ', Precip_module - ierr = 1 - ELSEIF ( Precip_module(:8)=='xyz_dist' .AND. Temp_module(:8)/='xyz_dist') THEN - PRINT '(/,A,/,2A)', 'ERROR, if xyz_dist is specified for precip_module,', & - & 'it also must be specified for temp_module: ', Temp_module - ierr = 1 - ENDIF - - IF ( Transp_module(:18)=='transp_tindex_prms' ) THEN - PRINT *, 'WARNING, deprecated transp_module value, change transp_tindex_prms to transp_tindex' - Transp_module = 'transp_tindex' - ENDIF - - IF ( Et_module(:13)=='potet_jh_prms' ) THEN - PRINT *, 'WARNING, deprecated et_module value, change potet_jh_prms to potet_jh' - Et_module = 'potet_jh' - ELSEIF ( Et_module(:14)=='potet_pan_prms' ) THEN - PRINT *, 'WARNING, deprecated et_module value, change potet_pan_prms to potet_pan' - Et_module = 'potet_pan' - ELSEIF ( Et_module(:15)=='potet_epan_prms' ) THEN - PRINT *, 'ERROR, deprecated et_module value, change potet_epan_prms to potet_pan' - ierr = 1 - ELSEIF ( Et_module(:20)=='potet_hamon_hru_prms' ) THEN - PRINT *, 'WARNING, deprecated et_module value, change potet_hamon_hru_prms to potet_hamon_hru' - Et_module = 'potet_hamon' - ELSEIF ( Et_module(:16)=='potet_hamon_prms' ) THEN - PRINT *, 'WARNING, deprecated et_module value, change potet_hamon_prms to potet_hamon' - Et_module = 'potet_hamon' - ENDIF - - IF ( Solrad_module(:17)=='ddsolrad_hru_prms' ) THEN - PRINT *, 'WARNING, deprecated solrad_module value, change ddsolrad_hru_prms to ddsolrad' - Solrad_module = 'ddsolrad' - ELSEIF ( Solrad_module(:17)=='ccsolrad_hru_prms' ) THEN - PRINT *, 'WARNING, deprecated solrad_module value, change ccsolrad_hru_prms to ccsolrad' - Solrad_module = 'ccsolrad' - ELSEIF ( Solrad_module(:13)=='ddsolrad_prms' ) THEN - PRINT *, 'WARNING, deprecated solrad_module value, change ddsolrad_prms to ddsolrad' - Solrad_module = 'ddsolrad' - ELSEIF ( Solrad_module(:13)=='ccsolrad_prms' ) THEN - PRINT *, 'WARNING, deprecated solrad_module value, change ccsolrad_prms to ccsolrad' - Solrad_module = 'ccsolrad' - ENDIF - - IF ( Srunoff_module(:18)=='srunoff_carea_prms' ) THEN - PRINT *, 'WARNING, deprecated srunoff_module value, change srunoff_carea_prms to srunoff_carea' - Srunoff_module = 'srunoff_carea' - ELSEIF ( Srunoff_module(:18)=='srunoff_smidx_prms' ) THEN - PRINT *, 'WARNING, deprecated srunoff_module value, change srunoff_smidx_prms to srunoff_smidx' - Srunoff_module = 'srunoff_smidx' - ENDIF - - IF ( Strmflow_module(:13)=='strmflow_prms' ) THEN - PRINT *, 'WARNING, deprecated strmflow_module value, change strmflow_prms to strmflow' - Strmflow_module = 'strmflow' - ELSEIF ( Strmflow_module(:13)=='strmflow_lake' ) THEN - PRINT *, 'ERROR, module strmflow_lake not available, use a different strmflow_module, such as muskingum_lake' - ierr = 1 - ENDIF - IF ( ierr==1 ) STOP - END SUBROUTINE check_module_names - -!*********************************************************************** -! call_modules_restart - write or read restart file -!*********************************************************************** - SUBROUTINE call_modules_restart(In_out) - USE PRMS_MODULE - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - EXTERNAL check_restart, check_restart_dimen - ! Functions - INTRINSIC TRIM - ! Local Variables - INTEGER :: nhru_test, dprst_test, nsegment_test, temp_test, et_test, ierr, time_step - INTEGER :: cascade_test, cascdgw_test, nhrucell_test, nlake_test, transp_test, start_time(6), end_time(6) - CHARACTER(LEN=MAXCONTROL_LENGTH) :: model_test - CHARACTER(LEN=12) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Timestep, Nhru, Dprst_flag, Nsegment, Temp_flag, Et_flag, & - & Cascade_flag, Cascadegw_flag, Nhrucell, Nlake, Transp_flag, Model_mode - WRITE ( Restart_outunit ) Starttime, Endtime - ELSE - ierr = 0 - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) time_step, nhru_test, dprst_test, nsegment_test, temp_test, et_test, & - & cascade_test, cascdgw_test, nhrucell_test, nlake_test, transp_test, model_test - READ ( Restart_inunit ) start_time, end_time - IF ( Print_debug>-2 ) PRINT 4, EQULS, 'Simulation time period of Restart File:', & - & start_time(1), start_time(2), start_time(3), ' -', end_time(1), end_time(2), end_time(3), & - & 'Last time step of simulation: ', time_step, EQULS - 4 FORMAT (/, A, /, 2(A, I5, 2('/',I2.2)), /, A, I0, /, A, /) - IF ( TRIM(Model_mode)/=TRIM(model_test) ) THEN - PRINT *, 'ERROR, Initial Conditions File saved for model_mode=', model_test - PRINT *, ' Current model has model_mode=', Model_mode, ' they must be equal' - ierr = 1 - ENDIF - CALL check_restart_dimen('nhru', nhru_test, Nhru, ierr) - CALL check_restart_dimen('nhrucell', nhrucell_test, Nhrucell, ierr) - CALL check_restart_dimen('nlake', nlake_test, Nlake, ierr) - IF ( Dprst_flag/=dprst_test ) THEN - PRINT *, 'ERROR, Initial Conditions File saved for model with dprst_flag=', dprst_test - PRINT *, ' Current model has dprst_flag=', Dprst_flag, ' they must be equal' - ierr = 1 - ENDIF - IF ( Cascade_flag/=cascade_test ) THEN - PRINT *, 'ERROR, Initial Conditions File saved for model with cascade_flag=', cascade_test - PRINT *, ' Current model has cascade_flag=', Cascade_flag, ' they must be equal' - ierr = 1 - ENDIF - IF ( Cascadegw_flag/=cascdgw_test ) THEN - PRINT *, 'ERROR, Initial Conditions File saved for model with cascadegw_flag=', cascdgw_test - PRINT *, ' Current model has cascadegw_flag=', Cascadegw_flag, ' they must be equal' - ierr = 1 - ENDIF - CALL check_restart_dimen('nsegment', nsegment_test, Nsegment, ierr) - ! Temp_flag (1=temp_1sta; 2=temp_laps; 3=temp_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru; 8=temp_sta - IF ( Temp_flag/=temp_test ) THEN - IF ( Temp_flag<4 .OR. temp_test<4 ) THEN - PRINT *, 'ERROR, Initial Conditions File saved for model with different temperature module' - PRINT *, ' than current model, cannot switch to/from temp_1sta, temp_laps, or temp_dist2' - ierr = 1 - ENDIF - ENDIF - IF ( Et_flag/=et_test ) THEN - IF ( Et_flag==4 .OR. et_test==4 ) THEN - PRINT *, 'ERROR, Cannot switch to/from potet_pan module for restart simulations' - ierr = 1 - ENDIF - ENDIF - IF ( Transp_flag/=transp_test ) THEN - IF ( Transp_flag==1 .OR. transp_test==1 ) THEN - PRINT *, 'ERROR, Cannot switch to/from transp_tindex module for restart simulations' - ierr = 1 - ENDIF - ENDIF - IF ( ierr==1 ) STOP - ENDIF - END SUBROUTINE call_modules_restart diff --git a/prms/mizurouteRip.f90 b/prms/mizurouteRip.f90 deleted file mode 100644 index 8b6b0121..00000000 --- a/prms/mizurouteRip.f90 +++ /dev/null @@ -1,787 +0,0 @@ -!*********************************************************************** -! Defines stream and lake routing parameters and variables -!*********************************************************************** - MODULE PRMS_MIZUROUTE - IMPLICIT NONE -! Local Variables -! index for printing (set to negative to supress printing - integer,parameter :: ixPrint = -9999 ! index for printing -! useful constants - logical,parameter :: doKWTroute=.True. !.True. if switch off will do KWT - double precision,parameter :: verySmall=tiny(1.0D0) ! a very small number -! general guff - integer,parameter :: strLen=256 ! length of character string - integer :: ierr ! error code - character(len=strLen) :: cmessage ! error message of downwind routine - integer :: iTime ! loop through time - character(len=strLen) :: str ! miscellaneous string -! define stream segment information - integer,target :: nSeg ! number of all the stream segments - integer,pointer :: nSegRoute ! number of stream segments to be routed - integer :: nUpstream ! number of reaches upstream of each stream segment - integer :: iSeg ! index of stream segment - integer :: jSeg ! index of stream segment - integer :: iSegOut ! index of outlet stream segment - integer :: iSelect(1) ! index of desired stream segment (iSegOut) from the minloc operation - integer :: iSegDesire ! index of desired stream segment -- de-vectorized version of iSelect(1) - integer :: iUps ! index of upstream stream segment added by NM - integer :: iStart ! start index of the ragged array - integer,dimension(1) :: iDesire ! index of stream segment with maximum upstream area (vector) - integer :: ixDesire ! index of stream segment with maximum upstream area (scalar) -! define stream network information - integer,allocatable :: REACHIDGV(:) - integer,allocatable :: RCHIXLIST(:) - integer :: nTotal ! total number of upstream segments for all stream segments - integer :: iRchStart - integer :: iRchStart1 - integer,target :: nRchCount - integer :: nRchCount1 - integer :: iUpRchStart - integer :: nUpRchCount - integer,allocatable :: upStrmRchList(:) -! define metadata from model output file - integer :: iRch ! index in reach structures -! interpolate simulated runoff data to the basins - integer :: ibas ! index of the basins - integer :: iHRU ! index of the HRUs associated to the basin - integer :: nDrain ! number of HRUs that drain into a given stream segment - integer :: ix ! index of the HRU assigned to a given basin -! route delaied runoff through river network with St.Venant UH - integer :: nUH_DATA_MAX ! maximum number of elements in the UH data among all the upstreamfs for a segment -! compute total instantaneous runoff upstream of each reach - integer,allocatable :: iUpstream(:) ! indices for all reaches upstream - double precision,allocatable :: qUpstream(:) ! streamflow for all reaches upstream -! route kinematic waves through the river network - integer, parameter :: nens=1 ! number of ensemble members - integer :: iens ! index of ensemble member - double precision, save :: T0 ! start of the time step (seconds) - double precision :: T1 ! end of the time step (seconds) - integer :: LAKEFLAG ! >0 if processing lakes - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:) - CHARACTER(LEN=9), SAVE :: MODNAME - END MODULE PRMS_MIZUROUTE - -!*********************************************************************** -! Main mizuroute routine -!*********************************************************************** - INTEGER FUNCTION mizuroute() - USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: mizuroute_decl, mizuroute_init, mizuroute_run - EXTERNAL :: mizuroute_restart -!*********************************************************************** - mizuroute = 0 - - IF ( Process(:3)=='run' ) THEN - mizuroute = mizuroute_run() - ELSEIF ( Process(:4)=='decl' ) THEN - mizuroute = mizuroute_decl() - ELSEIF ( Process(:4)=='init' ) THEN - IF ( Init_vars_from_file>0 ) CALL mizuroute_restart(1) - mizuroute = mizuroute_init() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL mizuroute_restart(0) - ENDIF - - END FUNCTION mizuroute - -!*********************************************************************** -! mizuroute_decl - Declare parameters and variables and allocate arrays -! Declared Parameters -! tosegment, hru_segment, obsin_segment, K_coef, x_coef -!*********************************************************************** - INTEGER FUNCTION mizuroute_decl() - USE PRMS_MIZUROUTE - USE PRMS_MODULE, ONLY: Nsegment - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: declparam, declvar - EXTERNAL read_error, print_module -! Local Variables - CHARACTER(LEN=80), SAVE :: Version_mizuroute -!*********************************************************************** - mizuroute_decl = 0 - - Version_mizuroute = 'mizuroute.f90 2017-10-06 11:04:00Z' - CALL print_module(Version_mizuroute, 'Streamflow Routing ', 90) - MODNAME = 'mizuroute' - - ALLOCATE ( Outflow_ts(Nsegment) ) - - END FUNCTION mizuroute_decl - -!*********************************************************************** -! mizuroute_init - Get and check parameter values and initialize variables -!*********************************************************************** - INTEGER FUNCTION mizuroute_init() - USE PRMS_MIZUROUTE - USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file - USE PRMS_BASIN, ONLY: Basin_area_inv, FT2_PER_ACRE, FEET2METERS - USE PRMS_FLOWVARS, ONLY: Seg_outflow - USE PRMS_SET_TIME, ONLY: Cfs_conv - USE PRMS_ROUTING, ONLY: Basin_segment_storage, Tosegment, Segment_hruarea, & - & Segment_order, Obsin_segment, Obsout_segment, Seg_length, Seg_slope -! mizuroute specific modules - USE nrtype ! variable types, etc. - USE reachparam ! reach parameters - USE reachstate ! reach states - USE reach_flux ! fluxes in each reach - USE nrutil,only:arth ! use to build vectors with regular increments - USE lake_param ! lake parameters - USE lakes_flux ! fluxes in each lake -! **** - USE kwt_route,only:reachorder ! define the processing order for the stream segments - IMPLICIT NONE -! Functions - EXTERNAL :: read_error - INTEGER, EXTERNAL :: getparam -! Local Variables - INTEGER :: i, j, k, jj, toseg, iorder, reachStart(Nsegment), reachCount(Nsegment) - INTEGER :: upReachStart(Nsegment), upReachCount(Nsegment),reachListMat(Nsegment,Nsegment) - INTEGER :: reachList(Nsegment*Nsegment),upReachIndex(Nsegment*Nsegment), seg_id(Nsegment) - INTEGER :: upReachIndMat(Nsegment,Nsegment), ilake - DOUBLE PRECISION :: totalArea(Nsegment) -!*********************************************************************** - mizuroute_init = 0 - - IF ( Init_vars_from_file==0 ) THEN - Outflow_ts = 0.0D0 - ENDIF - - !Seg_outflow will have been initialized to Segment_flow_init in PRMS_ROUTING - Basin_segment_storage = 0.0D0 - DO i = 1, Nsegment - Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) - ENDDO - Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv - - DO i = 1, Nsegment - IF ( Tosegment(i)==0 ) iSegOut = i - seg_id(i) = i - ENDDO - - T0 = 0.D0 - nSeg = Nsegment - -! Calculate network topology information... - reachStart = 0 - reachCount = 1 - upReachStart = -9999 - upReachCount = 0 - reachListMat = 0 - reachList = 0 - upReachIndMat = 0 - upReachIndex = 0 - DO i = 1, Nsegment - iorder = Segment_order(i) - toseg = Tosegment(iorder) - reachListMat(iorder,iorder) = 1 - IF ( toseg>0 ) THEN - reachListMat(toseg,1:Nsegment) = reachListMat(toseg,1:Nsegment)+reachListMat(iorder,1:Nsegment) - upReachIndMat(toseg,iorder) = 1 - ENDIF - ENDDO - !Note, size of upReachIndex sUps = SUM(upReachIndex) - !Note, size of reachList sAll = SUM(reachListMat) - DO i = 1, Nsegment - reachCount(i) = SUM(reachListMat(i,1:Nsegment)) - upReachCount(i) = SUM(upReachIndMat(i,1:Nsegment)) - ENDDO - DO i = 1, Nsegment - reachStart(i) = SUM(reachCount(1:i)) - reachCount(i) + 1 - IF ( upReachCount(i)>0 ) upReachStart(i) = SUM(upReachCount(1:i)) - upReachCount(i) + 1 - j = reachStart(i) - jj = upReachStart(i) - DO k = 1,Nsegment - IF (reachListMat(i,k) == 1) THEN - reachList(j) = k - j = j+1 - ENDIF - IF (jj>0 .AND. upReachIndMat(i,k) == 1) THEN - upReachIndex(jj) = k - jj = jj+1 - ENDIF - ENDDO - iRchStart = reachStart(i) - nRchCount = reachCount(i) - totalArea(i) = DBLE(SUM(Segment_hruarea(reachList(iRchStart:(iRchStart+nRchCount-1))))) - totalArea(i) = totalArea(i)*FT2_PER_ACRE*(FEET2METERS**2.) - ENDDO - -! Read global reach id, allocate - allocate(REACHIDGV(Nsegment), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for REACHIDGV') - REACHIDGV = seg_id - if ( iSegOut /= -9999 ) then - !print*, 'Outlet segment = ', iSegOut -! Identify index of the desired stream segment from reachID vector (dimension size: Nsegment) - iSelect = minloc(abs(REACHIDGV - iSegOut)) - iSegDesire = iSelect(1) ! de-vectorize the desired stream segment - if(REACHIDGV(iSegDesire) /= iSegOut)& - call handle_err(20,'unable to find desired stream segment') - -! Start index and the count for lagged array - all the upstream segments, immediate upstream segment, immediate upstream HRUs - iRchStart = reachStart(iSegDesire) - nRchCount = reachCount(iSegDesire) - !print*,'iRchStart = ',iRchStart - !print*,'Number of upstream segment from outlet segment (nRchCount): ',nRchCount - -! Read reach list of index from global segments (all the upstream reachs for each segment) - allocate(upStrmRchList(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for upStrmRchList') - upStrmRchList = reachList(iRchStart:(iRchStart+nRchCount-1)) - -! Reach upstream segment and associated HRU infor from non-ragged vector - allocate(NETOPO(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO') - allocate(RPARAM(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RPARAM') - -! Create REACH index for local segments - NETOPO(:)%REACHIX=arth(1,1,nRchCount) - do iSeg=1,nRchCount - ! Reach reach topology and parameters (integer) - NETOPO(iSeg)%REACHID = seg_id(upStrmRchList(iSeg)) - NETOPO(iSeg)%DREACHK = Tosegment(upStrmRchList(iSeg)) - ! Reach reach topology and parameters (double precision precision) - RPARAM(iSeg)%R_SLOPE = DBLE(Seg_slope(upStrmRchList(iSeg))) - RPARAM(iSeg)%RLENGTH = DBLE(Seg_length(upStrmRchList(iSeg))) - RPARAM(iSeg)%TOTAREA = totalArea(upStrmRchList(iSeg)) - enddo - - ! Recompute downstream segment index as local segment list, NETOPO(:)%REACHID - do iSeg=1,nRchCount - ! Assign downstream segment ID = 0 at desired outlet segment - if (NETOPO(iSeg)%REACHID == iSegOut) then - NETOPO(iSeg)%DREACHK = 0 - else - ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) - iSelect = minloc(abs(NETOPO(:)%REACHID - NETOPO(iSeg)%DREACHK)) - NETOPO(iSeg)%DREACHI = iSelect(1) ! de-vectorize the desired stream segment - if (NETOPO(NETOPO(iSeg)%DREACHI)%REACHID /= NETOPO(iSeg)%DREACHK) then - !print*,'iSeg = ', iSeg - !print*,'NETOPO(iSeg)%DREACHK = ', NETOPO(iSeg)%DREACHK - !print*,'NETOPO(NETOPO(iSeg)%DREACHI)%REACHID = ', NETOPO(NETOPO(iSeg)%DREACHI)%REACHID - call handle_err(20,'unable to find desired downstream segment') - endif - endif - enddo - -! Reach upstream segment and associated HRU infor from ragged vector - nTotal=0 - do iSeg=1,nRchCount - ! sAll dimension - iRchStart1 = reachStart(upStrmRchList(iSeg)) - nRchCount1 = reachCount(upStrmRchList(iSeg)) - allocate(NETOPO(iSeg)%RCHLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%RCHLIST') - allocate(RCHIXLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RCHIXLIST(nRchCount)') - RCHIXLIST = reachList(iRchStart1:(iRchStart1+nRchCount1-1)) - - ! Recompute all the upstream segment indices as local segment list = NETOPO(:)%REACHID - nTotal = nTotal + nRchCount1 - do jSeg=1,nRchCount1 - ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) - iSelect = minloc( abs( NETOPO(:)%REACHID - REACHIDGV(RCHIXLIST(jSeg)) ) ) - NETOPO(iSeg)%RCHLIST(jSeg) = iSelect(1) ! de-vectorize the desired stream segment - enddo - !print*,'NETOPO(iSeg)%RCHLIST(:) = ',NETOPO(iSeg)%RCHLIST(:) - deallocate(RCHIXLIST, stat=ierr) - - ! sUps dimension - iUpRchStart = upReachStart(upStrmRchList(iSeg)) - nUpRchCount = upReachCount(upStrmRchList(iSeg)) - allocate(NETOPO(iSeg)%UREACHI(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHI') - allocate(NETOPO(iSeg)%UREACHK(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHK') - allocate(NETOPO(iSeg)%goodBas(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%goodBas') - if (nUpRchCount > 0) then - - NETOPO(iSeg)%UREACHK(:) = seg_id(upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1))) - do jSeg=1,nUpRchCount - ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) - iSelect = minloc(abs(NETOPO(:)%REACHID - NETOPO(iSeg)%UREACHK(jSeg))) - NETOPO(iSeg)%UREACHI(jSeg) = iSelect(1) ! de-vectorize the desired stream segment - ! check that we identify the correct upstream reach - if (NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID /= NETOPO(iSeg)%UREACHK(jSeg)) then - !print*,'iSeg = ', iSeg - !print*,'NETOPO(iSeg)%UREACHK(jSeg) = ', NETOPO(iSeg)%UREACHK(jSeg) - !print*,'NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID = ', NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID - call handle_err(20,'unable to find desired immediate upstream segment') - endif - - ! check that the upstream reach has a basin area > 0 - if(RPARAM(NETOPO(iSeg)%UREACHI(jSeg))%TOTAREA > verySmall)then - NETOPO(iSeg)%goodBas(jSeg) = .true. - else - NETOPO(iSeg)%goodBas(jSeg) = .false. - endif - - enddo ! looping through the immediate upstream reaches - endif ! if not a headwater - enddo ! looping through the stream segments within the model domain - nSegRoute => nRchCount - - else ! if the entire river network routing is selected - !print*, 'Route all the segments included in network topology' - ! Populate sSeg dimensioned variable - allocate(NETOPO(nSeg), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO') - allocate(RPARAM(nSeg), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RPARAM') - do iSeg=1,Nsegment - ! Reach reach topology and parameters (integer) - NETOPO(iSeg)%REACHIX = iSeg - NETOPO(iSeg)%REACHID = seg_id(iSeg) != to iSeg - NETOPO(iSeg)%DREACHI = Tosegment(iSeg) - NETOPO(iSeg)%DREACHK = Tosegment(iSeg) - ! Reach reach topology and parameters (double precision precision) - RPARAM(iSeg)%R_SLOPE = DBLE(Seg_slope(iSeg)) - RPARAM(iSeg)%RLENGTH = DBLE(Seg_length(iSeg)) - RPARAM(iSeg)%TOTAREA = totalArea(iSeg) - enddo - ! Populate sAll dimensioned variable - ! NETOPO%RCHLIST - upstream reach list - nTotal=0 - do iSeg=1,Nsegment - iRchStart1 = reachStart(iSeg) - nRchCount1 = reachCount(iSeg) - allocate(NETOPO(iSeg)%UPSLENG(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UPSLENG') - allocate(NETOPO(iSeg)%RCHLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%RCHLIST') - NETOPO(iSeg)%RCHLIST(:) = reachList(iRchStart1:(iRchStart1+nRchCount1-1)) - nTotal = nTotal + nRchCount1 - enddo - ! Populate sUps dimensioned variable - ! NETOPO%UREACHI - Immediate upstream reach index list - ! NETOPO%UREACHK - Immediate upstream reach ID list - do iSeg=1,Nsegment - iUpRchStart = upReachStart(iSeg) - nUpRchCount = upReachCount(iSeg) - allocate(NETOPO(iSeg)%UREACHI(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHI') - allocate(NETOPO(iSeg)%UREACHK(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHK') - allocate(NETOPO(iSeg)%goodBas(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%goodBas') - if (nUpRchCount > 0) then - NETOPO(iSeg)%UREACHK(:) = seg_id(upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1))) - NETOPO(iSeg)%UREACHI(:) = upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1)) - do jSeg=1,nUpRchCount - ! check that we identify the correct upstream reach - if (NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID /= NETOPO(iSeg)%UREACHK(jSeg)) then - !print*,'iSeg = ', iSeg - !print*,'NETOPO(iSeg)%UREACHK(jSeg) = ', NETOPO(iSeg)%UREACHK(jSeg) - !print*,'NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID = ', NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID - call handle_err(20,'unable to find desired immediate upstream segment') - endif - ! check that the upstream reach has a basin area > 0 - if(RPARAM(NETOPO(iSeg)%UREACHI(jSeg))%TOTAREA > verySmall)then - NETOPO(iSeg)%goodBas(jSeg) = .true. - else - NETOPO(iSeg)%goodBas(jSeg) = .false. - endif - enddo ! looping through the immediate upstream reaches - endif ! if not a headwater - enddo - nSegRoute => nSeg - endif ! outlet segment choice - - if (doKWTroute) then - ! define processing order of the reaches - call reachorder(nSegRoute, ierr, cmessage); call handle_err(ierr, cmessage) - end if - - ! identify the stream segment with the largest upstream area - iDesire = maxLoc(RPARAM(:)%TOTAREA) - ixDesire= iDesire(1) - !print*, 'maximum upstream area = ', RPARAM(ixDesire)%TOTAREA, size(NETOPO(ixDesire)%RCHLIST) - - ! set the downstream index of the outlet reach to negative (the outlet reach does not flow into anything) - NETOPO(ixDesire)%DREACHI = -9999 - - ! allocate space for the simulated runoff at reaches - allocate(RCHFLX(nens,nSegRoute), KROUTE(nens,nSegRoute), stat=ierr) - if(ierr/=0) call handle_err(ierr,'problem allocating space for simulated runoff at the basins') - - - ! setup streamflow replacement at segments if needed - ! using as fake lakes for now, FIX? - ! ************************************************** - ilake = 0 - DO i = iSeg, nSegRoute - IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) ilake = ilake+1 - IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) ilake = ilake+1 - ENDDO - NETOPO(:)%LAKE_IX = 0 - NETOPO(:)%LAKINLT = .FALSE. - allocate(LKTOPO(ilake), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for LKTOPO') - LKTOPO(:)%DREACHI = 0 - ! allocate space for the simulated flux at lakes - allocate(LAKFLX(nens,ilake), stat=ierr) - if(ierr/=0) call handle_err(ierr,'problem allocating space for simulated fluxes at the lakes') - LAKFLX(:,:)%LAKE_Q = 0.D0 - IF (ilake>0) THEN - LAKEFLAG = 1 - ilake = 0 - DO i = 1, nSegRoute - IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is outlet of lake with known 'lake' flow coming into reach - ilake= ilake+1 - NETOPO(iSeg)%LAKE_IX = ilake - LKTOPO(ilake)%DREACHI = NETOPO(iSeg)%REACHIX - ENDIF - IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach a lake with known 'lake' flow coming out reach and not routed in the reach - ilake= ilake+1 - NETOPO(iSeg)%LAKE_IX = ilake - LKTOPO(ilake)%DREACHI = NETOPO(iSeg)%REACHIX - RPARAM(iSeg)%RLENGTH = 0.D0 ! FIX: NOT SURE I CAN HAVE 0 LENGTH - ENDIF - ENDDO - ENDIF - ! initialize the routed elements - RCHFLX(:,:)%BASIN_QR(1) = 0.D0 - - END FUNCTION mizuroute_init - -!*********************************************************************** -! mizuroute_run - Compute routing summary values -!*********************************************************************** - INTEGER FUNCTION mizuroute_run() - USE PRMS_MIZUROUTE - USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag - USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, METERS2FEET, Active_hrus, Hru_route_order, & - & Basin_gl_cfs, Basin_gl_ice_cfs - USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & - & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & - & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out - USE PRMS_OBS, ONLY: Streamflow_cfs - USE PRMS_SET_TIME, ONLY: Cfs_conv, Timestep_seconds - USE PRMS_ROUTING, ONLY: Mann_n, Seg_Width, Obsin_segment, Tosegment, Obsout_segment, & - & Segment_delta_flow, Segment_type, Basin_segment_storage, Flow_in_great_lakes, & - & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Flow_terminus, & - & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, & - & Stage_ts, Stage_ante, Seg_bankflow, Seg_slope, Basin_bankflow, Bankst_seep_rate, & - & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, Basin_ripflow, & - & Basin_bankst_seep_rate, Basin_bankflow, Basin_bankst_seep, Basin_bankst_vol, & - & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_seep, Basin_ripst_evap, & - & Basin_ripst_vol, Bankst_seep_rate - USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt - USE PRMS_SRUNOFF, ONLY: Basin_sroff - USE PRMS_GWFLOW, ONLY: Basin_gwflow -! mizuroute specific modules - USE nrtype ! variable types, etc. - USE reachparam ! reach parameters - USE reachstate ! reach states - USE reach_flux ! fluxes in each reach - USE lake_param ! lake parameters - USE lakes_flux ! fluxes in each lake - USE kwt_route,only:qroute_rch ! route kinematic waves through the river network - - IMPLICIT NONE -! Functions - INTRINSIC MOD - EXTERNAL comp_bank_storage, drain_the_swamp -! Local Variables - INTEGER :: i, j, segtype, ilake, toseg - DOUBLE PRECISION :: area_fac, segout -!*********************************************************************** - mizuroute_run = 0 - -! compute the time-delay histogram (to route runoff within basins) - allocate(FRAC_FUTURE(1), stat=ierr) - FRAC_FUTURE(1) = 0.d0 - !call qtimedelay(dt, fshape, tscale, ierr, cmessage) - !call handle_err(ierr, cmessage) - -! ***** -! Prepare for the routing simulations... -! ******************************************* -! allocate space for the simulated runoff at the HRUs - - ! initialize the time-delay histogram - do iens=1,nens - do ibas=1,nSegRoute - ! allocate space for the delayed runoff - allocate(RCHFLX(iens,ibas)%QFUTURE(size(FRAC_FUTURE)), stat=ierr) - call handle_err(ierr, 'problem allocating space for QFUTURE element') - ! initialize to zeroes - RCHFLX(iens,ibas)%QFUTURE(:) = 0.D0 - end do - end do - - - ! define flags - !LAKEFLAG=0 ! no lakes in the river network, but putting in fake ones to add in observed streamflow - ! FIX: HOW DO WE DEAL WITH LAKES HERE, USE MUSKINGUM?? - - ! define time - T1 = T0+Timestep_seconds - -! ***** -! Perform the routing... -! ************************** - iTime=1 - - ! loop through ensemble members - do iens=1,nens - ! Interpolate simulated runoff to local basins... - do ibas=1,nSegRoute - RCHFLX(iens,ibas)%BASIN_QI = DBLE(Seg_lateral_inflow(NETOPO(ibas)%REACHID)*CFS2CMS_CONV) - end do ! (looping through basins) - !print*,'RCHFLX(iens,:)%BASIN_QI = ',RCHFLX(iens,:)%BASIN_QI! - - ! ***** - ! FIX ZERO OUT Delay runoff within local basins... IS THIS RIGHT?? - ! **************************************** - ! route streamflow through the basin - do ibas=1,nSegRoute ! place a fraction of runoff in future time steps - RCHFLX(iens,ibas)%QFUTURE(1) = RCHFLX(iens,ibas)%BASIN_QI - ! save the routed runoff - RCHFLX(iens,ibas)%BASIN_QR(0) = RCHFLX(iens,ibas)%BASIN_QR(1) ! (save the runoff from the previous time step) !CUT? - RCHFLX(iens,ibas)%BASIN_QR(1) = RCHFLX(iens,ibas)%QFUTURE(1) - RCHFLX(iens,ibas)%QFUTURE(1) = 0.D0 - end do ! (looping through basins) - - ! ***** - ! Replace streamflow at segments if needed - ! water-use removed/added in routing module - ! FIX DEAL WITH GAINING STREAMS will happen in depression storage type module - ! ************************************************** - ilake = 0 - DO iSeg = 1, nSegRoute - IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is outlet of lake with known 'lake' flow coming into reach - ilake= ilake+1 - LAKFLX(iens,ilake)%LAKE_Q = DBLE((Streamflow_cfs(Obsin_segment(NETOPO(iSeg)%REACHID))+Seg_lateral_inflow(NETOPO(iSeg)%REACHID))*CFS2CMS_CONV) - ENDIF - IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is inlet of lake with known 'lake' flow coming into reach - ilake= ilake+1 - LAKFLX(iens,ilake)%LAKE_Q = DBLE(Streamflow_cfs(Obsout_segment(NETOPO(iSeg)%REACHID))*CFS2CMS_CONV) - ENDIF - ENDDO - - ! ***** - ! Compute total instantaneous runoff from all upstream basins... - ! ******************************************************************* - ! compute the sum of all upstream runoff at each point in the river network - do iSeg=1,nSegRoute - ! identify how many reaches are upstream - nUpstream = size(NETOPO(iSeg)%RCHLIST) - ! allocate space for upstream vectors - allocate(iUpstream(nUpstream), qUpstream(nUpstream), stat=ierr) - if(ierr/=0) call handle_err(ierr,'problem allocating vectors for all upstream basins') - ! get indices for all reaches upstream - iUpstream = NETOPO(iSeg)%RCHLIST(1:nUpstream) - ! get streamflow for all reaches upstream - qUpstream = RCHFLX(iens,iUpstream(1:nUpstream))%BASIN_QR(1) - ! get mean streamflow - RCHFLX(IENS,iSeg)%UPSTREAM_QI = sum(qUpstream) - ! test - if(NETOPO(iSeg)%REACHID == ixPrint)then - print*, 'ixUpstream = ', NETOPO(iUpstream(1:nUpstream))%REACHIX - print*, 'idUpstream = ', NETOPO(iUpstream(1:nUpstream))%REACHID - print*, 'qUpstream = ', qUpstream - endif - ! deallocate space for upstream vectors - deallocate(iUpstream,qUpstream, stat=ierr) - if(ierr/=0) call handle_err(ierr,'problem deallocating vectors for all upstream basins') - end do ! looping through stream segments - - ! ***** - ! Route streamflow through the river network... - ! ************************************************** - Seg_inflow = 0.0D0 - Seg_outflow = 0.0D0 - Seg_upstream_inflow = 0.0D0 - IF ( Ripst_flag==1 ) Stage_ante =Stage_ts - if (doKWTroute) then - RPARAM(:)%R_WIDTH = DBLE(Seg_width) ! channel width (m) - RPARAM(:)%R_MAN_N = DBLE(Mann_n) ! Manning's "n" paramater (unitless) - - ! route streamflow through the river network - do iSeg=1,nSegRoute - ! identify reach to process - irch = NETOPO(iSeg)%RHORDER - !print*, 'irch, ixDesire = ', irch, ixDesire - ! route kinematic waves through the river network - CALL QROUTE_RCH(IENS,irch, & ! input: array indices - ixDesire, & ! input: index of the outlet reach - T0,T1, & ! input: start and end of the time step - LAKEFLAG, & ! input: flag if lakes are to be processed - ierr,cmessage) ! output: error control - call handle_err(ierr,cmessage) - !if(iRch==5) pause 'finished stream segment' - end do ! (looping through stream segments) - Seg_outflow(NETOPO(:)%REACHID)= RCHFLX(iens,:)%REACH_Q/CFS2CMS_CONV - - DO iSeg=1,nSegRoute - irch = NETOPO(iSeg)%RHORDER - toseg = Tosegment(irch) - IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Seg_outflow(irch) - ENDDO - Seg_inflow(NETOPO(:)%REACHID) = Seg_lateral_inflow(NETOPO(:)%REACHID) + & - & Seg_upstream_inflow(NETOPO(:)%REACHID) - - - Outflow_ts(NETOPO(:)%REACHID)= RCHFLX(iens,:)%REACH_Q/CFS2CMS_CONV - end if - end do ! (looping through ensemble members) - - ! for stage estimate - IF ( Ripst_flag==1 ) THEN - Basin_bankst_seep = 0.D0 - Basin_bankst_seep_rate = 0.0D0 - Basin_bankst_head = 0.0D0 - Basin_bankst_vol = 0.0D0 - Basin_ripst_area = 0.0D0 - Basin_ripst_seep = 0.0D0 - Basin_ripst_evap = 0.0D0 - Basin_ripst_vol = 0.0D0 - Bankst_seep_rate = 0.0 !collect by segment that HRUs go to - Seg_bankflow = 0.0D0 !collect by segment that HRUs go to - DO i = 1, Nsegment - Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & - & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) - IF (Stage_ts(i)>250.) Stage_ts(i) = 250. - ENDDO - DO j = 1, Active_hrus - i = Hru_route_order(j) - IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) & - & CALL comp_bank_storage(i) -! ******Compute the bank storage component -! transfers water between separate bank storage and stream depending on seepage - ENDDO - Basin_bankst_seep = Basin_bankst_seep*Basin_area_inv - Basin_bankst_head = Basin_bankst_head*Basin_area_inv - Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv - DO i = 1, Nsegment - Basin_bankst_seep_rate = Basin_bankst_seep_rate + Bankst_seep_rate(i) & - & *Seg_length(i)/SUM(Seg_length) !m2/day per stream ft length - Seg_outflow(i) = Seg_outflow(i)+Seg_bankflow(i) - IF (Seg_bankflow(i) < 0.0) THEN ! only could go negative because of bankflow if is negative - IF (Seg_outflow(i) < 0.0) THEN ! took out more than streamflow, this could also be a water_use problem - Seg_bankflow(i) = Seg_bankflow(i) - Seg_outflow(i) - Seg_outflow(i) = 0.0 - ENDIF - ENDIF - ENDDO - Bankst_seep_rate = 0.0 !collect by segment that HRUs go to - Seg_ripflow = 0.0D0 - DO j = 1, Active_hrus - i = Hru_route_order(j) - IF ( Hru_segment(i)>0 .AND. Ripst_areafr_max(i)>0.0) & - & CALL drain_the_swamp(i) -! ******Compute the overbank riparian storage component -! transfers water between separate riparian storage and stream depending on seepage - ENDDO - Basin_ripst_seep = Basin_ripst_seep*Basin_area_inv - Basin_ripst_evap = Basin_ripst_evap*Basin_area_inv - Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv - DO i = 1, Nsegment - Seg_outflow(i) = Seg_outflow(i)+Seg_ripflow(i) ! cannot go negative by design - Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & - & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) - IF (Stage_ts(i)>250.) Stage_ts(i) = 250. - ENDDO - ENDIF - - T0 = T1 - - Basin_segment_storage = 0.0D0 - Basin_bankflow = 0.0D0 - Basin_ripflow = 0.0D0 - Flow_out = 0.0D0 - Flow_to_lakes = 0.0D0 - Flow_to_ocean = 0.0D0 - Flow_to_great_lakes = 0.0D0 - Flow_out_region = 0.0D0 - Flow_out_NHM = 0.0D0 - Flow_in_region = 0.0D0 - Flow_terminus = 0.0D0 - Flow_in_nation = 0.0D0 - Flow_headwater = 0.0D0 - Flow_in_great_lakes = 0.0D0 - Flow_replacement = 0.0D0 - DO i = 1, Nsegment - segtype = Segment_type(i) - segout = Seg_outflow(i) -! Flow_out is the total flow out of the basin, which allows for multiple outlets -! includes closed basins (tosegment=0) - IF ( segtype==1 ) THEN - Flow_headwater = Flow_headwater + segout - ELSEIF ( segtype==2 ) THEN - Flow_to_lakes = Flow_to_lakes + segout - ELSEIF ( segtype==3 ) THEN - Flow_replacement = Flow_replacement + segout - ELSEIF ( segtype==4 ) THEN - Flow_in_nation = Flow_in_nation + segout - ELSEIF ( segtype==5 ) THEN - Flow_out_NHM = Flow_out_NHM + segout - ELSEIF ( segtype==6 ) THEN - Flow_in_region = Flow_in_region + segout - ELSEIF ( segtype==7 ) THEN - Flow_out_region = Flow_out_region + segout - ELSEIF ( segtype==8 ) THEN - Flow_to_ocean = Flow_to_ocean + segout - ELSEIF ( segtype==9 ) THEN - Flow_terminus = Flow_terminus + segout - ELSEIF ( segtype==10 ) THEN - Flow_in_great_lakes = Flow_in_great_lakes + segout - ELSEIF ( segtype==11 ) THEN - Flow_to_great_lakes = Flow_to_great_lakes + segout - ENDIF - IF ( Tosegment(i)==0 ) Flow_out = Flow_out + segout - - Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout -! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) - Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) - IF ( Ripst_flag==1 ) THEN - Basin_bankflow = Basin_bankflow + Seg_bankflow(i) - Basin_ripflow = Basin_ripflow + Seg_ripflow(i) - ENDIF - ENDDO - - area_fac = Cfs_conv/Basin_area_inv - Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows - Basin_cfs = Flow_out - Basin_stflow_out = Basin_cfs / area_fac - Basin_cms = Basin_cfs*CFS2CMS_CONV - IF ( Glacier_flag==1 ) THEN - Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt - Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac - Basin_gl_cfs = Basin_gl_top_melt*area_fac - ENDIF - Basin_sroff_cfs = Basin_sroff*area_fac - Basin_ssflow_cfs = Basin_ssflow*area_fac - Basin_gwflow_cfs = Basin_gwflow*area_fac - Basin_segment_storage = Basin_segment_storage/area_fac - IF ( Ripst_flag==1 ) THEN - Basin_bankflow = Basin_bankflow/area_fac - Basin_ripflow = Basin_ripflow/area_fac - ENDIF - - END FUNCTION mizuroute_run - -!*********************************************************************** - subroutine handle_err(err,message) - ! handle error codes - implicit none - integer,intent(in)::err ! error code - character(*),intent(in)::message ! error message - if(err/=0)then - print*,'FATAL ERROR: '//trim(message) - stop - endif - end subroutine handle_err - -!*********************************************************************** -! mizuroute_restart - write or read restart file -!*********************************************************************** - SUBROUTINE mizuroute_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit - USE PRMS_MIZUROUTE - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - ! Function - EXTERNAL :: check_restart - ! Local Variable - CHARACTER(LEN=9) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Outflow_ts - ELSE - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) Outflow_ts - ENDIF - END SUBROUTINE mizuroute_restart diff --git a/prms/muskingumRip.f90 b/prms/muskingumRip.f90 deleted file mode 100644 index 61035381..00000000 --- a/prms/muskingumRip.f90 +++ /dev/null @@ -1,473 +0,0 @@ -!*********************************************************************** -! Routes water between segments in the system using Muskingum routing -! -! The Muskingum equation is described in 'Hydrology for Engineers', 3rd ed. -! by Linsley, R.K, Kohler, M.A., and Paulhus, J.L.H., 1982 p. 275 and in -! 'Water in Environmental Planning' by Dunne, T., and Leopold, L.B. 1978 -! p. 357. -! -! Note that the Muskingum equation assumes a linear relation of storage -! to the inflow/outflow relation and therefore the relation is the same -! throughout the range of the hydrograph. The route_time parameter in -! the fixroute module is replaced by two new parameters, K_coef and -! x_coef, which are described below: -! -! The Muskingum method is based on the equation: S = K[xI + (1 - x)O] -! where S is storage, K is the storage coefficient, x is a coefficient -! between 0 and .5, I is inflow, and O is outflow. -! -! Solving for the outflow at day 2,O2; and knowing the inflow at day 1, -! I1; the inflow at day 2,I2; and the outflow at day 1, O1; the storage -! equation can be written as follows: -! -! O2 = czero*I2 + cone*I1 + ctwo*O1 -! -! where czero = -((Kx - 12) / (K - Kx + 12)) -! cone = (Kx + 12) / (K - Kx + 12) -! ctwo = (K - Kx - 12) / (K - Kx + 12) -! -! assuming a time step of one day and K is in units of hours -! -! This module is based on the "musroute.f" module. It differs in three -! basic ways: -! -! 1. This module uses an internal routing time step of one hour. -! The old muskingum module ran on the same daily time step as -! the rest of PRMS. The problem with this is that there is no -! ability to distinguish where the flood wave (front of the flow -! change) within the segment. For example, if there is a series -! of 4 1-day long segments, a flood wave will make it to the bottom -! of these in 1 day. If the same system is modeled as 1 4-day long -! segment, it will take 4 days. -! -! 2. The X parameter has been removed as a specified input and is now computed. To -! my knowledge, no modeler had ever set this to anything other than the default -! value (0.2) anyway. Always using the default value can lead to problems -! with the C coffecients which can result in mass balance problems or negative -! flow values. -! -! To solve this problem, I assume that the C coefficients must -! always be between 0 and 1. By setting the C coefficients equal to 0 and 1, -! various limits on the time step (ts), X, and K can be determined. There are -! two of these limits which are of interest: -! -! When C0 = 0: -! ts -! K = ----- -! 2X -! -! When C2 = 0: -! ts -! K = ----- -! 2(1-X) -! -! Determining a value of K half way between these two limits (by averaging) -! and solving for X using the quadratic formula results in: -! -! 1-sqrt(1-(ts/K)) -! X = ------------------ -! 2 -! -! So when ts is fixed at one hour and K is fixed as the average (or expected) -! travel time corresponding to the segment (for each segment in the stream -! network), a value of X can be computed (for each segment in the stream -! network) which will result in both conservation of mass and non-negative -! flows. Another benefit is that only one input parameter (K) needs to be -! input to the module. -! -! 3. If the travel time of a segment is less than or equal to the routing -! time step (one hour), then the outflow of the segment is set to the -! value of the inflow. -! -!*********************************************************************** - MODULE PRMS_MUSKINGUM - IMPLICIT NONE -! Local Variables - DOUBLE PRECISION, PARAMETER :: ONE_24TH = 1.0D0 / 24.0D0 - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Currinsum(:), Pastin(:), Pastout(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:), Inflow_ts(:) - CHARACTER(LEN=14), SAVE :: MODNAME - END MODULE PRMS_MUSKINGUM - -!*********************************************************************** -! Main muskingum routine -!*********************************************************************** - INTEGER FUNCTION muskingum() - USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: muskingum_decl, muskingum_init, muskingum_run - EXTERNAL :: muskingum_restart -!*********************************************************************** - muskingum = 0 - - IF ( Process(:3)=='run' ) THEN - muskingum = muskingum_run() - ELSEIF ( Process(:4)=='decl' ) THEN - muskingum = muskingum_decl() - ELSEIF ( Process(:4)=='init' ) THEN - IF ( Init_vars_from_file>0 ) CALL muskingum_restart(1) - muskingum = muskingum_init() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL muskingum_restart(0) - ENDIF - - END FUNCTION muskingum - -!*********************************************************************** -! muskingum_decl - Declare parameters and variables and allocate arrays -! Declared Parameters -! tosegment, hru_segment, obsin_segment, K_coef, x_coef -!*********************************************************************** - INTEGER FUNCTION muskingum_decl() - USE PRMS_MUSKINGUM - USE PRMS_MODULE, ONLY: Nsegment, Strmflow_flag - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: declparam - EXTERNAL read_error, print_module -! Local Variables - CHARACTER(LEN=80), SAVE :: Version_muskingum -!*********************************************************************** - muskingum_decl = 0 - - Version_muskingum = 'muskingum.f90 2019-06-05 17:18:00Z' - IF ( Strmflow_flag==4 ) THEN - MODNAME = 'muskingum' - ELSE - MODNAME = 'muskingum_mann' - ENDIF - CALL print_module(Version_muskingum, 'Streamflow Routing ', 90) - - ALLOCATE ( Currinsum(Nsegment) ) - ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) ) - ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) ) - - END FUNCTION muskingum_decl - -!*********************************************************************** -! muskingum_init - Get and check parameter values and initialize variables -!*********************************************************************** - INTEGER FUNCTION muskingum_init() - USE PRMS_MUSKINGUM - USE PRMS_MODULE, ONLY: Nsegment - USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv - USE PRMS_FLOWVARS, ONLY: Seg_outflow - USE PRMS_SET_TIME, ONLY: Cfs_conv - USE PRMS_ROUTING, ONLY: Basin_segment_storage - IMPLICIT NONE -! Functions - EXTERNAL :: read_error - INTEGER, EXTERNAL :: getparam -! Local Variables - INTEGER :: i -!*********************************************************************** - muskingum_init = 0 - - !Seg_outflow will have been initialized to Segment_flow_init in PRMS_ROUTING - Basin_segment_storage = 0.0D0 - DO i = 1, Nsegment - Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) - ENDDO - Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv - - END FUNCTION muskingum_init - -!*********************************************************************** -! muskingum_run - Compute routing summary values -!*********************************************************************** - INTEGER FUNCTION muskingum_run() - USE PRMS_MUSKINGUM - USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag - USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, Active_hrus, Hru_route_order, & - & Basin_gl_cfs, Basin_gl_ice_cfs - USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & - & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & - & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out - USE PRMS_OBS, ONLY: Streamflow_cfs - USE PRMS_SET_TIME, ONLY: Cfs_conv - USE PRMS_ROUTING, ONLY: Use_transfer_segment, Segment_delta_flow, Basin_segment_storage, & - & Obsin_segment, Segment_order, Tosegment, C0, C1, C2, Ts, Ts_i, Obsout_segment, & - & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Segment_type, Flow_terminus, & - & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes, & - & Flow_in_great_lakes, Stage_ts, Stage_ante, Seg_bankflow, Mann_n, Seg_width, Seg_slope, Basin_bankflow, & - & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, Basin_ripflow, & - & Basin_bankst_seep_rate, Basin_bankflow, Basin_bankst_seep, Basin_bankst_vol, & - & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_seep, Basin_ripst_evap, & - & Basin_ripst_vol, Bankst_seep_rate - USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt - USE PRMS_SRUNOFF, ONLY: Basin_sroff - USE PRMS_GWFLOW, ONLY: Basin_gwflow - IMPLICIT NONE -! Functions - INTRINSIC MOD - EXTERNAL comp_bank_storage, drain_the_swamp -! Local Variables - INTEGER :: i, j, iorder, toseg, imod, tspd, segtype - DOUBLE PRECISION :: area_fac, segout, currin -!*********************************************************************** - muskingum_run = 0 - -! SET yesterdays inflows and outflows into temp (past arrays) -! values may be 0.0 as intial, > 0.0 for runtime and dynamic -! initial condtions. Then set outlfow and inflow for this time -! step to 0.0 -! -! upstream_inflow and outflow will vary by hour -! lateral_inflow and everything else will vary by day -! -! Compute surface runoff, ssflow, and gwflow going to each segment -! This is todays "seg_inflow" before additional water is routed to -! a new (if any is routed) -! -! For each HRU if the lateral flow for this HRU goes to the -! segment being evaluated (segment i) then sum flows -! -! Do these calculations once for the current day, before the hourly -! routing starts. -! -! Out2 = In2*C0 + In1*C1 + Out1*C2 -! Seg_outflow = Seg_inflow*Czero + Pastinflow*Cone + Pastoutflow*Ctwo -! C0, C1, and C2: initialized in the "init" part of this module -! - Pastin = Seg_inflow - Pastout = Seg_outflow - Seg_inflow = 0.0D0 - Seg_outflow = 0.0D0 - Inflow_ts = 0.0D0 - Currinsum = 0.0D0 - IF ( Ripst_flag==1 ) Stage_ante =Stage_ts - -! 24 hourly timesteps per day - DO j = 1, 24 - - Seg_upstream_inflow = 0.0D0 - DO i = 1, Nsegment - iorder = Segment_order(i) - -! current inflow to the segment is the time weighted average of the outflow -! of the upstream segments plus the lateral HRU inflow plus any gains. - currin = Seg_lateral_inflow(iorder) !note, this routes to inlet and mizuroute routes to outlet - IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) - currin = currin + Seg_upstream_inflow(iorder) - Seg_inflow(iorder) = Seg_inflow(iorder) + currin - Inflow_ts(iorder) = Inflow_ts(iorder) + currin - Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder) - - ! Check to see if this segment is to be routed on this time step - tspd = Ts_i(iorder) - imod = MOD( j, tspd ) - IF ( imod==0 ) THEN - Inflow_ts(iorder) = (Inflow_ts(iorder) / Ts(iorder)) -! Compute routed streamflow - IF ( Ts_i(iorder)>0 ) THEN -! Muskingum routing equation - Outflow_ts(iorder) = Inflow_ts(iorder)*C0(iorder) + Pastin(iorder)*C1(iorder) + Outflow_ts(iorder)*C2(iorder) - ELSE -! If travel time (K_coef paremter) is less than or equal to -! time step (one hour), then the outflow is equal to the inflow -! Outflow_ts is the value from last hour - Outflow_ts(iorder) = Inflow_ts(iorder) - ENDIF - - ! pastin is equal to the Inflow_ts on the previous routed timestep - Pastin(iorder) = Inflow_ts(iorder) - -! because the upstream inflow from streams is used, reset it to zero so new average -! can be computed next routing timestep. - Inflow_ts(iorder) = 0.0D0 - ENDIF - - IF ( Obsout_segment(iorder)>0 ) Outflow_ts(iorder) = Streamflow_cfs(Obsout_segment(iorder)) - - ! water-use removed/added in routing module - ! check for negative flow - IF ( Outflow_ts(iorder)<0.0 ) THEN - IF ( Use_transfer_segment==1 ) THEN - PRINT *, 'ERROR, transfer(s) from stream segment:', iorder, ' causes outflow to be negative' - PRINT *, ' outflow =', Outflow_ts(iorder), ' must fix water-use stream segment transfer file' - ELSE - PRINT *, 'ERROR, outflow from segment:', iorder, ' is negative:', Outflow_ts(iorder) - PRINT *, ' routing parameters may be invalid' - ENDIF - STOP - ENDIF - - ! Seg_outflow (the mean daily flow rate for each segment) will be the average of the hourly values. - Seg_outflow(iorder) = Seg_outflow(iorder) + Outflow_ts(iorder) - ! pastout is equal to the Inflow_ts on the previous routed timestep - Pastout(iorder) = Outflow_ts(iorder) - -! Add current timestep's flow rate to sum the upstream flow rates. -! This can be thought of as a volume because it is a volumetric rate -! (cubic feet per second) over a time step of an hour. Down below when -! this value is used, it will be divided by the number of hours in the -! segment's simulation time step, giving the mean flow rate over that -! period of time. - toseg = Tosegment(iorder) - IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Outflow_ts(iorder) - - ENDDO ! segment - - ENDDO ! timestep - - DO i = 1, Nsegment - Seg_outflow(i) = Seg_outflow(i) * ONE_24TH - ENDDO - ! for stage estimate - IF ( Ripst_flag==1 ) THEN - Basin_bankst_seep = 0.D0 - Basin_bankst_seep_rate = 0.0D0 - Basin_bankst_head = 0.0D0 - Basin_bankst_vol = 0.0D0 - Basin_ripst_area = 0.0D0 - Basin_ripst_seep = 0.0D0 - Basin_ripst_evap = 0.0D0 - Basin_ripst_vol = 0.0D0 - Bankst_seep_rate = 0.0 !collect by segment that HRUs go to - Seg_bankflow = 0.0D0 !collect by segment that HRUs go to - DO i = 1, Nsegment - Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & - & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) - IF (Stage_ts(i)>250.) Stage_ts(i) = 250. - ENDDO - DO j = 1, Active_hrus - i = Hru_route_order(j) - IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) & - & CALL comp_bank_storage(i) -! ******Compute the bank storage component -! transfers water between separate bank storage and stream depending on seepage - ENDDO - Basin_bankst_seep = Basin_bankst_seep*Basin_area_inv - Basin_bankst_head = Basin_bankst_head*Basin_area_inv - Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv - DO i = 1, Nsegment - Basin_bankst_seep_rate = Basin_bankst_seep_rate + Bankst_seep_rate(i) & - & *Seg_length(i)/SUM(Seg_length) !m2/day per stream ft length - Seg_outflow(i) = Seg_outflow(i)+Seg_bankflow(i) - IF (Seg_bankflow(i) < 0.0) THEN ! only could go negative because of bankflow if is negative - IF (Seg_outflow(i) < 0.0) THEN ! took out more than streamflow, this could also be a water_use problem - Seg_bankflow(i) = Seg_bankflow(i) - Seg_outflow(i) - Seg_outflow(i) = 0.0 - ENDIF - ENDIF - ENDDO - Bankst_seep_rate = 0.0 !collect by segment that HRUs go to - Seg_ripflow = 0.0D0 - DO j = 1, Active_hrus - i = Hru_route_order(j) - IF ( Hru_segment(i)>0 .AND. Ripst_areafr_max(i)>0.0) & - & CALL drain_the_swamp(i) -! ******Compute the overbank riparian storage component -! transfers water between separate riparian storage and stream depending on seepage - ENDDO - Basin_ripst_seep = Basin_ripst_seep*Basin_area_inv - Basin_ripst_evap = Basin_ripst_evap*Basin_area_inv - Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv - DO i = 1, Nsegment - Seg_outflow(i) = Seg_outflow(i)+Seg_ripflow(i) ! cannot go negative by design - Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & - & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) - IF (Stage_ts(i)>250.) Stage_ts(i) = 250. - ENDDO - ENDIF - - Basin_segment_storage = 0.0D0 - Basin_bankflow = 0.0D0 - Basin_ripflow = 0.0D0 - Flow_out = 0.0D0 - Flow_to_lakes = 0.0D0 - Flow_to_ocean = 0.0D0 - Flow_to_great_lakes = 0.0D0 - Flow_out_region = 0.0D0 - Flow_out_NHM = 0.0D0 - Flow_in_region = 0.0D0 - Flow_terminus = 0.0D0 - Flow_in_nation = 0.0D0 - Flow_headwater = 0.0D0 - Flow_in_great_lakes = 0.0D0 - Flow_replacement = 0.0D0 - DO i = 1, Nsegment - segtype = Segment_type(i) - Seg_inflow(i) = Seg_inflow(i) * ONE_24TH - Seg_upstream_inflow(i) = Currinsum(i) * ONE_24TH - segout = Seg_outflow(i) -! Flow_out is the total flow out of the basin, which allows for multiple outlets -! includes closed basins (tosegment=0) - IF ( segtype==1 ) THEN - Flow_headwater = Flow_headwater + segout - ELSEIF ( segtype==2 ) THEN - Flow_to_lakes = Flow_to_lakes + segout - ELSEIF ( segtype==3 ) THEN - Flow_replacement = Flow_replacement + segout - ELSEIF ( segtype==4 ) THEN - Flow_in_nation = Flow_in_nation + segout - ELSEIF ( segtype==5 ) THEN - Flow_out_NHM = Flow_out_NHM + segout - ELSEIF ( segtype==6 ) THEN - Flow_in_region = Flow_in_region + segout - ELSEIF ( segtype==7 ) THEN - Flow_out_region = Flow_out_region + segout - ELSEIF ( segtype==8 ) THEN - Flow_to_ocean = Flow_to_ocean + segout - ELSEIF ( segtype==9 ) THEN - Flow_terminus = Flow_terminus + segout - ELSEIF ( segtype==10 ) THEN - Flow_in_great_lakes = Flow_in_great_lakes + segout - ELSEIF ( segtype==11 ) THEN - Flow_to_great_lakes = Flow_to_great_lakes + segout - ENDIF - IF ( Tosegment(i)==0 ) Flow_out = Flow_out + segout - Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout -! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) - Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) - IF ( Ripst_flag==1 ) THEN - Basin_bankflow = Basin_bankflow + Seg_bankflow(i) - Basin_ripflow = Basin_ripflow + Seg_ripflow(i) - ENDIF - ENDDO - - area_fac = Cfs_conv/Basin_area_inv - Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows - Basin_cfs = Flow_out - Basin_stflow_out = Basin_cfs / area_fac - Basin_cms = Basin_cfs*CFS2CMS_CONV - IF ( Glacier_flag==1 ) THEN - Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt - Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac - Basin_gl_cfs = Basin_gl_top_melt*area_fac - ENDIF - Basin_sroff_cfs = Basin_sroff*area_fac - Basin_ssflow_cfs = Basin_ssflow*area_fac - Basin_gwflow_cfs = Basin_gwflow*area_fac - Basin_segment_storage = Basin_segment_storage/area_fac - IF ( Ripst_flag==1 ) THEN - Basin_bankflow = Basin_bankflow/area_fac - Basin_ripflow = Basin_ripflow/area_fac - ENDIF - - END FUNCTION muskingum_run - -!*********************************************************************** -! muskingum_restart - write or read restart file -!*********************************************************************** - SUBROUTINE muskingum_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit - USE PRMS_MUSKINGUM - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - ! Function - EXTERNAL :: check_restart - ! Local Variable - CHARACTER(LEN=9) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Outflow_ts - ELSE - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) Outflow_ts - ENDIF - END SUBROUTINE muskingum_restart diff --git a/prms/routingRip.f90 b/prms/routingRip.f90 deleted file mode 100644 index ff638dd6..00000000 --- a/prms/routingRip.f90 +++ /dev/null @@ -1,1575 +0,0 @@ -!*********************************************************************** -! Defines stream and lake routing parameters and variables -!*********************************************************************** - MODULE PRMS_ROUTING - IMPLICIT NONE -! Local Variables - CHARACTER(LEN=7), SAVE :: MODNAME - DOUBLE PRECISION, SAVE :: Cfs2acft - DOUBLE PRECISION, SAVE :: Segment_area - INTEGER, SAVE :: Use_transfer_segment, Noarea_flag, Hru_seg_cascades - INTEGER, SAVE, ALLOCATABLE :: Segment_order(:), Segment_up(:), Seg_hru_num(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Segment_hruarea(:) - CHARACTER(LEN=80), SAVE :: Version_routing - !CHARACTER(LEN=32), SAVE :: Outfmt - INTEGER, SAVE, ALLOCATABLE :: Ts_i(:) - REAL, SAVE, ALLOCATABLE :: Ts(:), C0(:), C1(:), C2(:) - REAL, SAVE, ALLOCATABLE :: Ripst_area_max(:), Ripst_area(:), Ripst_depth(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_vol_max(:) -! Declared Variables - DOUBLE PRECISION, SAVE :: Basin_segment_storage - DOUBLE PRECISION, SAVE :: Flow_to_lakes, Flow_to_ocean, Flow_to_great_lakes, Flow_out_region - DOUBLE PRECISION, SAVE :: Flow_in_region, Flow_in_nation, Flow_headwater, Flow_out_NHM - DOUBLE PRECISION, SAVE :: Flow_in_great_lakes, Flow_replacement, Flow_terminus - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seginc_ssflow(:), Seginc_sroff(:), Segment_delta_flow(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seginc_gwflow(:), Seginc_swrad(:), Seginc_potet(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_outflow(:), Seg_ssflow(:), Seg_sroff(:), Seg_gwflow(:) -! Declared Parameters - INTEGER, SAVE, ALLOCATABLE :: Segment_type(:), Tosegment(:), Hru_segment(:), Obsin_segment(:), Obsout_segment(:) - REAL, SAVE, ALLOCATABLE :: Seg_depth(:), K_coef(:), X_coef(:), Mann_n(:), Seg_width(:), Segment_flow_init(:) - REAL, SAVE, ALLOCATABLE :: Seg_length(:), Seg_slope(:) -! Declared Parameters for Overbank and bank Storage - REAL, SAVE, ALLOCATABLE :: Transmiss_seg(:), Ripst_areafr_max(:) -! Declared Parameters for Overbank Storage - REAL, SAVE, ALLOCATABLE :: Tr_ratio(:), Porosity_seg(:), Ripst_et_coef(:), Ripst_frac_init(:) -! Declared Variables for Overbank Storage - DOUBLE PRECISION, SAVE :: Basin_ripst_evap, Basin_ripst_seep, Basin_ripflow, Basin_ripst_vol, Basin_ripst_area - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_stor_hru(:), Ripst_seep_hru(:), Ripst_vol(:), Seg_ripflow(:) - REAL, SAVE, ALLOCATABLE :: Ripst_evap_hru(:), Ripst_frac(:) -! Declared Parameters for Bank Storage - REAL, SAVE, ALLOCATABLE :: Specyield_seg(:), Bankst_head_init(:) - INTEGER, SAVE, ALLOCATABLE :: Bankfinite_hru(:) -! Declared Variables for Bank Storage - DOUBLE PRECISION, SAVE :: Basin_bankst_head, Basin_bankst_seep_rate, Basin_bankflow - DOUBLE PRECISION, SAVE :: Basin_bankst_seep, Basin_bankst_vol, Basin_bankst_area - REAL, SAVE, ALLOCATABLE :: Bankst_head(:), Bankst_seep_rate(:), Bankst_seep_hru(:) - REAL, SAVE, ALLOCATABLE :: Bankst_stor_hru(:), Bankst_head_pts(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Stage_ante(:), Stage_ts(:), Seg_bankflow(:) - END MODULE PRMS_ROUTING - -!*********************************************************************** -! Main routing routine -!*********************************************************************** - INTEGER FUNCTION routing() - USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: routingdecl, routinginit, route_run - EXTERNAL :: routing_restart -!*********************************************************************** - routing = 0 - - IF ( Process(:3)=='run' ) THEN - routing = route_run() - ELSEIF ( Process(:4)=='decl' ) THEN - routing = routingdecl() - ELSEIF ( Process(:4)=='init' ) THEN - IF ( Init_vars_from_file>0 ) CALL routing_restart(1) - routing = routinginit() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL routing_restart(0) - ENDIF - - END FUNCTION routing - -!*********************************************************************** -! routingdecl - set up parameters -!*********************************************************************** - INTEGER FUNCTION routingdecl() - USE PRMS_ROUTING - USE PRMS_MODULE, ONLY: Nhru, Nsegment, Model, Strmflow_flag, Cascade_flag, & - & Ripst_flag, Stream_temp_flag, Init_vars_from_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: declparam, declvar - EXTERNAL read_error, print_module -!*********************************************************************** - routingdecl = 0 - - Version_routing = 'routing.f90 2019-06-05 17:22:00Z' - CALL print_module(Version_routing, 'Routing Initialization ', 90) - MODNAME = 'routing' - -! Declared Variables - ALLOCATE ( Hru_outflow(Nhru) ) - IF ( declvar(MODNAME, 'hru_outflow', 'nhru', Nhru, 'double', & - & 'Total flow leaving each HRU', & - & 'cfs', Hru_outflow)/=0 ) CALL read_error(3, 'hru_outflow') - - IF ( declvar(MODNAME, 'flow_to_lakes', 'one', 1, 'double', & - & 'Total flow to lakes (segment_type=2)', & - & 'cfs', Flow_to_lakes)/=0 ) CALL read_error(3, 'flow_to_lakes') - - IF ( declvar(MODNAME, 'flow_terminus', 'one', 1, 'double', & - & 'Total flow to terminus segments (segment_type=9)', & - & 'cfs', Flow_terminus)/=0 ) CALL read_error(3, 'flow_terminus') - - IF ( declvar(MODNAME, 'flow_to_ocean', 'one', 1, 'double', & - & 'Total flow to oceans (segment_type=8)', & - & 'cfs', Flow_to_ocean)/=0 ) CALL read_error(3, 'flow_to_ocean') - - IF ( declvar(MODNAME, 'flow_to_great_lakes', 'one', 1, 'double', & - & 'Total flow to Great Lakes (segment_type=11)', & - & 'cfs', Flow_to_great_lakes)/=0 ) CALL read_error(3, 'Flow_to_great_lakes') - - IF ( declvar(MODNAME, 'flow_out_region', 'one', 1, 'double', & - & 'Total flow out of region (segment_type=7)', & - & 'cfs', Flow_out_region)/=0 ) CALL read_error(3, 'flow_out_region') - - IF ( declvar(MODNAME, 'flow_out_NHM', 'one', 1, 'double', & - & 'Total flow out of model domain to Mexico or Canada (segment_type=5)', & - & 'cfs', Flow_out_NHM)/=0 ) CALL read_error(3, 'flow_out_NHM') - - IF ( declvar(MODNAME, 'flow_in_region', 'one', 1, 'double', & - & 'Total flow into region (segment_type=6)', & - & 'cfs', Flow_in_region)/=0 ) CALL read_error(3, 'flow_in_region') - - IF ( declvar(MODNAME, 'flow_in_nation', 'one', 1, 'double', & - & 'Total flow into model domain from Mexico or Canada (segment_type=4)', & - & 'cfs', Flow_in_nation)/=0 ) CALL read_error(3, 'flow_in_nation') - - IF ( declvar(MODNAME, 'flow_headwater', 'one', 1, 'double', & - & 'Total flow out of headwater segments (segment_type=1)', & - & 'cfs', Flow_headwater)/=0 ) CALL read_error(3, 'flow_headwater') - - IF ( declvar(MODNAME, 'flow_in_great_lakes', 'one', 1, 'double', & - & 'Total flow out into model domain from Great Lakes (segment_type=10)', & - & 'cfs', Flow_in_great_lakes)/=0 ) CALL read_error(3, 'flow_in_great_lakes') - - IF ( declvar(MODNAME, 'flow_replacement', 'one', 1, 'double', & - & 'Total flow out from replacement flow (segment_type=3)', & - & 'cfs', Flow_replacement)/=0 ) CALL read_error(3, 'flow_replacement') - - ! 0 = normal; 1 = headwater; 2 = lake; 3 = replacement flow; 4 = inbound to nation; - ! 5 = outbound from nation; 6 = inbound to region; 7 = outbound from region; - ! 8 = drains to ocean; 9 = sink (terminus to soil); 10 = inbound from Great Lakes; - ! 11 = outbound to Great Lakes; 12 = ephemeral; + 100 user updated; 1000 user virtual segment - ! 100 = user normal; 101 - 108 = not used; 109 sink (tosegment used by Lumen) - - IF ( Ripst_flag==1 .OR. Model==99 ) THEN -! Overbank storage variables - IF ( declvar(MODNAME, 'basin_ripst_evap', 'one', 1, 'double', & - & 'Basin area-weighted average evaporation from riparian overbank flow storage', & - & 'inches', Basin_ripst_evap)/=0 ) CALL read_error(3, 'basin_ripst_evap') - - IF ( declvar(MODNAME, 'basin_ripst_seep', 'one', 1, 'double', & - & 'Basin area-weighted average seepage from riparian overbank flow storage', & - & 'inches', Basin_ripst_seep)/=0 ) CALL read_error(3, 'basin_ripst_seep') - - IF ( declvar(MODNAME, 'basin_ripst_vol', 'one', 1, 'double', & - & 'Basin area-weighted average storage volume in riparian overbank flow storage', & - & 'inches', Basin_ripst_vol)/=0 ) CALL read_error(3, 'basin_ripst_vol') - - IF ( declvar(MODNAME, 'basin_ripst_area', 'one', 1, 'double', & - & 'Basin area of riparian overbank flow storage', & - & 'acres', Basin_ripst_area)/=0 ) CALL read_error(3, 'basin_ripst_area') - - ALLOCATE ( Seg_ripflow(Nsegment) ) - IF ( declvar(MODNAME, 'seg_ripflow', 'nsegment', Nsegment, 'double', & - & 'Riparian area contribution to streamflow, negative if steam goes overbank', & - & 'cfs', Seg_ripflow)/=0 ) CALL read_error(3, 'seg_ripflow') - - ALLOCATE ( Ripst_stor_hru(Nhru) ) - IF ( declvar(MODNAME, 'ripst_stor_hru', 'nhru', Nhru, 'double', & - & 'Riparian overbank flow storage for each HRU', & - & 'inches', Ripst_stor_hru)/=0 ) CALL read_error(3, 'ripst_stor_hru') - - ALLOCATE ( Ripst_seep_hru(Nhru) ) - IF ( declvar(MODNAME, 'ripst_seep_hru', 'nhru', Nhru, 'double', & - & 'Seepage from riparian overbank flow storage to associated riparian-GWR for each HRU', & - & 'inches', Ripst_seep_hru)/=0 ) CALL read_error(3, 'ripst_seep_hru') - - ALLOCATE ( Ripst_evap_hru(Nhru) ) - IF ( declvar(MODNAME, 'ripst_evap_hru', 'nhru', Nhru, 'real', & - & 'Evaporation from riparian overbank flow storage for each HRU', & - & 'inches', Ripst_evap_hru)/=0 ) CALL read_error(3, 'ripst_evap_hru') - - ALLOCATE ( Ripst_vol(Nhru) ) - IF ( declvar(MODNAME, 'ripst_vol', 'nhru', Nhru, 'double', & - & 'Volume in riparian overbank flow storage for each HRU', & - & 'acre-inches', Ripst_vol)/=0 ) CALL read_error(3, 'ripst_vol') - - ALLOCATE ( Ripst_frac(Nhru) ) - IF ( declvar(MODNAME, 'ripst_frac', 'nhru', Nhru, 'real', & - & 'Volume and area fraction of riparian overbank flow storage of the maximum storage for each HRU', & - & 'decimal fraction', Ripst_frac)/=0 ) CALL read_error(3, 'ripst_frac') - - IF ( declvar(MODNAME, 'basin_ripflow', 'one', 1, 'double', & - & 'Basin riparian area contribution to streamflow, negative if steam goes overbank', & - & 'cfs', Basin_bankflow)/=0 ) CALL read_error(3, 'basin_ripflow') - - ALLOCATE ( Ripst_vol_max(Nhru), Ripst_area(Nhru), Ripst_area_max(Nhru), Ripst_depth(Nhru) ) - ALLOCATE ( Seg_hru_num(Nsegment) ) - -! Bank storage variables - IF ( declvar(MODNAME, 'basin_bankst_head', 'one', 1, 'double', & - & 'Basin bank storage area only area-weighted average head of bank storage above groundwater head', & - & 'meters', Basin_bankst_head)/=0 ) CALL read_error(3, 'basin_bankst_head') - - IF ( declvar(MODNAME, 'basin_bankst_seep', 'one', 1, 'double', & - & 'Basin area-weighted average seepage from bank storage to streams', & - & 'inches', Basin_bankst_seep)/=0 ) CALL read_error(3, 'basin_bankst_seep') - - IF ( declvar(MODNAME, 'basin_bankst_vol', 'one', 1, 'double', & - & 'Basin area-weighted average bank storage', & - & 'inches', Basin_bankst_vol)/=0 ) CALL read_error(3, 'basin_bankst_vol') - - IF ( declvar(MODNAME, 'basin_bankst_area', 'one', 1, 'double', & - & 'Basin area bank storage, if all semi-infinite will be area of basin', & - & 'acres', Basin_bankst_area)/=0 ) CALL read_error(3, 'basin_bankst_area') - - IF ( declvar(MODNAME, 'basin_bankst_seep_rate', 'one', 1, 'double', & - & 'Basin rate of seepage from bank storage into stream per unit length stream', & - & 'meter3/day/meter', Basin_bankst_seep_rate)/=0 ) CALL read_error(3, 'basin_bankst_seep_rate') - - IF ( declvar(MODNAME, 'basin_bankflow', 'one', 1, 'double', & - & 'Basin bank storage contribution to streamflow can be negative if steam losing water', & - & 'cfs', Basin_bankflow)/=0 ) CALL read_error(3, 'basin_bankflow') - - ALLOCATE ( Bankst_head(Nhru) ) - IF ( declvar(MODNAME, 'bankst_head', 'nhru', Nhru, 'real', & - & 'Bank storage area only average head of bank storage above groundwater head', & - & 'meters', Bankst_head)/=0 ) CALL read_error(3, 'bankst_head') - - ALLOCATE ( Seg_bankflow(Nsegment) ) - IF ( declvar(MODNAME, 'seg_bankflow', 'nsegment', Nsegment, 'double', & - & 'Bank storage area contribution to streamflow can be negative if steam losing water', & - & 'cfs', Seg_bankflow)/=0 ) CALL read_error(3, 'seg_bankflow') - - ALLOCATE ( Bankst_head_pts(Nhru) ) - IF ( declvar(MODNAME, 'bankst_head_pts', 'nhru', Nhru, 'real', & - & 'Head of bank storage above groundwater head: at half width away', & - & 'meters', Bankst_head_pts)/=0 ) CALL read_error(3, 'bankst_head_pts') - - ALLOCATE ( Stage_ante(Nsegment) ) - IF ( declvar(MODNAME, 'stage_ante', 'nsegment', Nsegment, 'double', & - & 'Antecedent stage height of segment, estimated with Manning Equation', & - & 'meters', stage_ante)/=0 ) CALL read_error(3, 'stage_ante') - - ALLOCATE ( Stage_ts(Nsegment) ) - IF ( declvar(MODNAME, 'stage_ts', 'nsegment', Nsegment, 'double', & - & 'Stage height of segment, estimated with Manning Equation', & - & 'meters', stage_ts)/=0 ) CALL read_error(3, 'stage_ts') - - ALLOCATE ( Bankst_seep_hru(Nhru) ) - IF ( declvar(MODNAME, 'bankst_seep_hru', 'nhru', Nhru, 'real', & - & 'HRU average seepage from bank storage to associated stream_segment for each HRU', & - & 'inches', Bankst_seep_hru)/=0 ) CALL read_error(3, 'bankst_seep_hru') - - ALLOCATE ( Bankst_stor_hru(Nhru) ) - IF ( declvar(MODNAME, 'bankst_stor_hru', 'nhru', Nhru, 'real', & - & 'HRU average bank storage for each HRU', & - & 'inches', Bankst_stor_hru)/=0 ) CALL read_error(3, 'bankst_stor_hru') - - ALLOCATE ( Bankst_seep_rate(Nsegment) ) - IF ( declvar(MODNAME, 'bankst_seep_rate', 'nsegment', Nsegment, 'real', & - & 'Seepage rate from bank storage into stream per unit length segment', & - & 'meter2/day', Bankst_seep_rate )/=0 ) CALL read_error(1, 'bankst_seep_rate') - - ENDIF - - IF (Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN - ALLOCATE ( Mann_n(Nsegment) ) - IF ( declparam( MODNAME, 'mann_n', 'nsegment', 'real', & - & '0.04', '0.001', '0.15', & - & 'Mannings roughness coefficient', & - & 'Mannings roughness coefficient for each segment', & - & 'dimensionless')/=0 ) CALL read_error(1, 'mann_n') - ENDIF - - IF (Stream_temp_flag==1 .OR. Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN - ALLOCATE ( Seg_slope(Nsegment) ) - IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & - & '0.0001', '0.0000001', '2.0', & - & 'Surface slope of each segment', & - & 'Surface slope of each segment as approximation for bed slope of stream', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'seg_slope') - - ALLOCATE ( Seg_length(Nsegment) ) - IF ( declparam( MODNAME, 'seg_length', 'nsegment', 'real', & - & '1000.0', '0.001', '200000.0', & - & 'Length of each segment', & - & 'Length of each segment, bounds based on CONUS', & - & 'meters')/=0 ) CALL read_error(1, 'seg_length') - ENDIF - - IF (Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Model==99 ) THEN - ALLOCATE ( Seg_width(Nsegment) ) - IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & - & '15.0', '0.18', '40000.0', & - & 'Segment river width', & - & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & - & 'meters')/=0 ) CALL read_error(1, 'seg_width') - ENDIF - - IF (Ripst_flag==1 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN - ALLOCATE ( Seg_depth(Nsegment) ) - IF ( declparam(MODNAME, 'seg_depth', 'nsegment', 'real', & - & '1.0', '0.03', '250.0', & - & 'Segment river depth', & - & 'Segment river depth at bankfull, shallowest from Blackburn-Lynch 2017,'//& - & 'Congo is deepest at 250 m but in the US it is probably the Hudson at 66 m', & - & 'meters')/=0 ) CALL read_error(1, 'seg_depth') - ENDIF - - ALLOCATE ( Segment_type(Nsegment) ) - IF ( declparam(MODNAME, 'segment_type', 'nsegment', 'integer', & - & '0', '0', '111', & - & 'Segment type', & - & 'Segment type (0=segment; 1=headwater; 2=lake; 3=replace inflow; 4=inbound to NHM;'// & - & ' 5=outbound from NHM; 6=inbound to region; 7=outbound from region; 8=drains to ocean;'// & - & ' 9=sink; 10=inbound from Great Lakes; 11=outbound to Great Lakes)', & - & 'none')/=0 ) CALL read_error(1, 'segment_type') - - ! user updated values if different than tosegment_orig - ! -5 = outbound from NHM; -6 = inbound from region; -7 = outbound from region; - ! -8 = drains to ocean; -11 = drains to Great Lake - ALLOCATE ( Tosegment(Nsegment) ) - IF ( declparam(MODNAME, 'tosegment', 'nsegment', 'integer', & - & '0', '-11', '1000000', & - & 'The index of the downstream segment', & - & 'Index of downstream segment to which the segment'// & - & ' streamflow flows, for segments that do not flow to another segment enter 0', & - & 'none')/=0 ) CALL read_error(1, 'tosegment') - - IF ( Cascade_flag==0 .OR. Cascade_flag==2 .OR. Model==99 ) THEN - Hru_seg_cascades = 1 - ALLOCATE ( Hru_segment(Nhru) ) - IF ( declparam(MODNAME, 'hru_segment', 'nhru', 'integer', & - & '0', 'bounded', 'nsegment', & - & 'Segment index for HRU lateral inflows', & - & 'Segment index to which an HRU contributes lateral flows'// & - & ' (surface runoff, interflow, and groundwater discharge)', & - & 'none')/=0 ) CALL read_error(1, 'hru_segment') - ELSE - Hru_seg_cascades = 0 - ENDIF - - ALLOCATE ( Obsin_segment(Nsegment) ) - IF ( declparam(MODNAME, 'obsin_segment', 'nsegment', 'integer', & - & '0', 'bounded', 'nobs', & - & 'Index of measured streamflow station that replaces inflow to a segment', & - & 'Index of measured streamflow station that replaces inflow to a segment', & - & 'none')/=0 ) CALL read_error(1, 'obsin_segment') - - ALLOCATE ( Obsout_segment(Nsegment) ) - IF ( declparam(MODNAME, 'obsout_segment', 'nsegment', 'integer', & - & '0', 'bounded', 'nobs', & - & 'Index of measured streamflow station that replaces outflow from a segment', & - & 'Index of measured streamflow station that replaces outflow from a segment', & - & 'none')/=0 ) CALL read_error(1, 'obsout_segment') - - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN - ALLOCATE ( Segment_flow_init(Nsegment) ) - IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & - & '0.0', '0.0', '1.0E7', & - & 'Initial flow in each stream segment', & - & 'Initial flow in each stream segment', & - & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') -! Bank Storage parameters: - IF ( Ripst_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Bankst_head_init(Nhru) ) - IF ( declparam(MODNAME, 'bankst_head_init', 'nhru', 'real', & - & '0.0', '0.0', '1000.0', & - & 'Bank storage area only average initial head of bank storage above groundwater head', & - & 'Bank storage area only average initial head of bank storage above groundwater head', & - & 'meters')/=0 ) CALL read_error(1, 'bankst_head_init') - -! Riparian Overbank Storage parameters: - ALLOCATE ( Ripst_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'ripst_frac_init', 'nhru', 'real', & - & '0.5', '0.0', '1.0', & - & 'Fraction of maximum storage that contains water at the start of a simulation', & - & 'Fraction of maximum riparian overbank flow storage that'// & - & ' contains water at the start of a simulation', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_frac_init') - - ENDIF - ENDIF - - IF ( Ripst_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Ripst_areafr_max(Nhru) ) - IF ( declparam(MODNAME, 'ripst_areafr_max', 'nhru', 'real', & - & '0.1', '0.0', '1.0', & - & 'Surface area fraction of HRU that has possible riparian overbank or bank storage', & - & 'Surface area fraction of HRU that has possible riparian overbank or bank storage;'// & - & ' if =0, then overbank storage is turned off, if also bankfinite_hru =1 bank storage is off', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_areafr_max') - - ALLOCATE ( Porosity_seg(Nsegment) ) - IF ( declparam(MODNAME, 'porosity_seg', 'nsegment', 'real', & - & '0.4', '0.15', '0.75', & - & 'Porosity of soil of riparian overbank flow storage', & - & 'Porosity of soil around segment involved in riparian overbank flow storage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'porosity_seg') - - ALLOCATE ( Ripst_et_coef(Nhru) ) - IF ( declparam(MODNAME, 'ripst_et_coef', 'nhru', 'real', & - & '1.0', '0.0', '1.0', & - & 'Fraction of unsatisfied potential evapotranspiration to apply to riparian overbank flow storage', & - & 'Fraction of unsatisfied potential evapotranspiration to apply to riparian overbank flow storage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_et_coef') - - ALLOCATE ( Tr_ratio(Nhru) ) - IF ( declparam(MODNAME, 'tr_ratio', 'nhru', 'real', & - & '0.5', '0.0', '1.0', & - & 'Triangle to rectangle ratio describing vertical cross-section'// & - & ' shape of riparian overbank flow storage', & - & 'Triangle to rectangle ratio describing vertical cross-section'// & - & ' shape of riparian overbank flow storage;'// & - & ' 1 is a triangle, 0 is a rectangle', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'tr_ratio') - - ALLOCATE ( Bankfinite_hru(Nhru) ) - IF ( declparam(MODNAME, 'bankfinite_hru', 'nhru', 'integer', & - & '0', '0', '1', & - & 'Bank storage is finite flag', & - & '1 means the bank storage is considered finite and not semi-infinite', & - & 'none')/=0 ) CALL read_error(1, 'bankfinite_hru') - - ALLOCATE ( Transmiss_seg(Nsegment) ) - IF ( declparam(MODNAME, 'transmiss_seg', 'nsegment', 'real', & - & '50.0', '0.00001', '100000', & - & 'Effective transmissivity of groundwater aquifer beneath segment', & - & 'Efective transmissivity of groundwater aquifer beneath segment;'// & - & ' 1.e-8 is unfractured basalt; 10000 is gravel', & - & 'm squared/day')/=0 ) CALL read_error(1, 'transmiss_seg') - - ALLOCATE ( Specyield_seg(Nsegment) ) !Storativity approximated as Specific yield since storativity hard to measure - IF ( declparam(MODNAME, 'specyield_seg', 'nsegment', 'real', & - & '0.2', '0.01', '0.5', & - & 'Volume of water released from storage per unit aquifer surface per unit head decline', & - & 'Volume of water released from storage per unit aquifer surface per unit head decline; '// & - & ' 0.01 is clay; 0.5 is peat', & - & 'none')/=0 ) CALL read_error(1, 'specyield_seg') - -! Not using at moment -! ALLOCATE ( Gwdepth_seg(Nsegment) ) -! IF ( declparam(MODNAME, 'gwdepth_seg', 'nsegment', 'real', & -! & '100.0', '-10.0', '10000.0', & -! & 'Depth to groundwater aquifer beneath segment', & -! & 'Depth to groundwater aquifer beneath segment;'// & -! & ' CONUS goes to ~300 m, but worldwide higher', & -! & 'meters')/=0 ) CALL read_error(1, 'gwdepth_seg') - - ENDIF - - - IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Strmflow_flag==7 ) ALLOCATE ( K_coef(Nsegment) ) - IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Model==99 ) THEN - IF ( declparam(MODNAME, 'K_coef', 'nsegment', 'real', & - & '1.0', '0.01', '24.0', & - & 'Muskingum storage coefficient', & - & 'Travel time of flood wave from one segment to the next downstream segment,'// & - & ' called the Muskingum storage coefficient; enter 1.0 for reservoirs,'// & - & ' diversions, and segment(s) flowing out of the basin', & - & 'hours')/=0 ) CALL read_error(1, 'K_coef') - ENDIF - - IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN - ALLOCATE ( X_coef(Nsegment) ) - IF ( declparam(MODNAME, 'x_coef', 'nsegment', 'real', & - & '0.2', '0.0', '0.5', & - & 'Routing weighting factor', & - & 'The amount of attenuation of the flow wave, called the'// & - & ' Muskingum routing weighting factor; enter 0.0 for'// & - & ' reservoirs, diversions, and segment(s) flowing out of the basin', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'x_coef') - ENDIF - - IF ( Hru_seg_cascades==1 .OR. Model==99 ) THEN - ALLOCATE ( Seginc_potet(Nsegment) ) - IF ( declvar(MODNAME, 'seginc_potet', 'nsegment', Nsegment, 'double', & - & 'Area-weighted average potential ET for each segment'// & - & ' from HRUs contributing flow to the segment', & - & 'inches', Seginc_potet)/=0 ) CALL read_error(3, 'seginc_potet') - - ALLOCATE ( Seginc_swrad(Nsegment) ) - IF ( declvar(MODNAME, 'seginc_swrad', 'nsegment', Nsegment, 'double', & - & 'Area-weighted average solar radiation for each segment'// & - & ' from HRUs contributing flow to the segment', & - & 'Langleys', Seginc_swrad)/=0 ) CALL read_error(3, 'seginc_swrad') - - ALLOCATE ( Seginc_ssflow(Nsegment) ) - IF ( declvar(MODNAME, 'seginc_ssflow', 'nsegment', Nsegment, 'double', & - & 'Area-weighted average interflow for each segment from'// & - & ' HRUs contributing flow to the segment', & - & 'cfs', Seginc_ssflow)/=0 ) CALL read_error(3, 'seginc_ssflow') - - ALLOCATE ( Seginc_gwflow(Nsegment) ) - IF ( declvar(MODNAME, 'seginc_gwflow', 'nsegment', Nsegment, 'double', & - & 'Area-weighted average groundwater discharge for each'// & - & ' segment from HRUs contributing flow to the segment', & - & 'cfs', Seginc_gwflow)/=0 ) CALL read_error(3, 'seginc_gwflow') - - ALLOCATE ( Seginc_sroff(Nsegment) ) - IF ( declvar(MODNAME, 'seginc_sroff', 'nsegment', Nsegment, 'double', & - & 'Area-weighted average surface runoff for each'// & - & ' segment from HRUs contributing flow to the segment', & - & 'cfs', Seginc_sroff)/=0 ) CALL read_error(3, 'seginc_sroff') - - ALLOCATE ( Seg_ssflow(Nsegment) ) - IF ( declvar(MODNAME, 'seg_ssflow', 'nsegment', Nsegment, 'double', & - & 'Area-weighted average interflow for each segment from'// & - & ' HRUs contributing flow to the segment and upstream HRUs', & - & 'inches', Seg_ssflow)/=0 ) CALL read_error(3, 'seg_ssflow') - - ALLOCATE ( Seg_gwflow(Nsegment) ) - IF ( declvar(MODNAME, 'seg_gwflow', 'nsegment', Nsegment, 'double', & - & 'Area-weighted average groundwater discharge for each segment from'// & - & ' HRUs contributing flow to the segment and upstream HRUs', & - & 'inches', Seg_gwflow)/=0 ) CALL read_error(3, 'seg_gwflow') - - ALLOCATE ( Seg_sroff(Nsegment) ) - IF ( declvar(MODNAME, 'seg_sroff', 'nsegment', Nsegment, 'double', & - & 'Area-weighted average surface runoff for each segment from'// & - & ' HRUs contributing flow to the segment and upstream HRUs', & - & 'inches', Seg_sroff)/=0 ) CALL read_error(3, 'seg_sroff') - ENDIF - - IF ( declvar(MODNAME, 'basin_segment_storage', 'one', 1, 'double', & - & 'Basin area-weighted average storage in the stream network', & - & 'inches', Basin_segment_storage)/=0 ) CALL read_error(3, 'basin_segment_storage') - - ALLOCATE ( Segment_delta_flow(Nsegment) ) - IF ( declvar(MODNAME, 'segment_delta_flow', 'nsegment', Nsegment, 'double', & - & 'Cummulative flow in minus flow out for each stream segment', & - & 'cfs', Segment_delta_flow)/=0 ) CALL read_error(3, 'segment_delta_flow') - - ! local arrays - ALLOCATE ( Segment_order(Nsegment), Segment_up(Nsegment), Segment_hruarea(Nsegment) ) - - END FUNCTION routingdecl - -!********************************************************************** -! routinginit - check for validity of parameters -!********************************************************************** - INTEGER FUNCTION routinginit() - USE PRMS_ROUTING - USE PRMS_MODULE, ONLY: Nsegment, Nhru, Init_vars_from_file, Strmflow_flag, & - & Water_use_flag, Segment_transferON_OFF, Inputerror_flag, Parameter_check_flag , & - & Ripst_flag, Stream_temp_flag !, Print_debug - USE PRMS_SET_TIME, ONLY: Timestep_seconds - USE PRMS_BASIN, ONLY: FT2_PER_ACRE, DNEARZERO, Active_hrus, Hru_route_order, Hru_area_dble, NEARZERO, & - & Hru_area, FEET2METERS, CFS2CMS_CONV !, Active_area - USE PRMS_FLOWVARS, ONLY: Seg_outflow - IMPLICIT NONE -! Functions - INTRINSIC MOD, DBLE - INTEGER, EXTERNAL :: getparam - EXTERNAL :: read_error -! Local Variable - INTEGER :: i, j, test, lval, toseg, iseg, isegerr, ierr, eseg - REAL :: k, x, d, x_max, velocity - DOUBLE PRECISION :: flow - INTEGER, ALLOCATABLE :: x_off(:) - CHARACTER(LEN=10) :: buffer -!********************************************************************** - routinginit = 0 - - Use_transfer_segment = 0 - IF ( Water_use_flag==1 .AND. Segment_transferON_OFF==1 ) Use_transfer_segment = 1 - - IF ( Init_vars_from_file==0 ) THEN - Basin_segment_storage = 0.0D0 - Segment_delta_flow = 0.0D0 - ENDIF - - IF ( Hru_seg_cascades==1 ) THEN - Seginc_potet = 0.0D0 - Seginc_gwflow = 0.0D0 - Seginc_ssflow = 0.0D0 - Seginc_sroff = 0.0D0 - Seginc_swrad = 0.0D0 - Seg_gwflow = 0.0D0 - Seg_ssflow = 0.0D0 - Seg_sroff = 0.0D0 - ENDIF - Hru_outflow = 0.0D0 - Flow_to_ocean = 0.0D0 - Flow_to_great_lakes = 0.0D0 - Flow_out_region = 0.0D0 - Flow_out_NHM = 0.0D0 - Flow_terminus = 0.0D0 - Flow_to_lakes = 0.0D0 - Flow_in_nation = 0.0D0 - Flow_in_region = 0.0D0 - Flow_headwater = 0.0D0 - Flow_in_great_lakes = 0.0D0 - Flow_replacement = 0.0D0 - - Cfs2acft = Timestep_seconds/FT2_PER_ACRE - - IF ( getparam(MODNAME, 'segment_type', Nsegment, 'integer', Segment_type)/=0 ) CALL read_error(2, 'segment_type') - DO i = 1, Nsegment - Segment_type(i) = MOD( Segment_type(i), 100 ) - ENDDO - - IF ( Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN - IF ( getparam(MODNAME, 'mann_n', Nsegment, 'real', Mann_n)/=0 ) CALL read_error(2, 'mann_n') - ENDIF - IF ( Stream_temp_flag==1 .OR. Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN - IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') - IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') -! find segments that are too short and print them out as they are found - ierr = 0 - DO i = 1, Nsegment - IF ( Seg_length(i)0 ) Segment_hruarea(iseg) = Segment_hruarea(iseg) + Hru_area_dble(i) - ENDDO - Segment_area = 0.0D0 - DO j = 1, Nsegment - Segment_area = Segment_area + Segment_hruarea(j) - IF ( Segment_hruarea(j)0 ) THEN - WRITE ( buffer, '(I10)' ) j - CALL write_outfile('WARNING, No HRUs are associated with segment:'//buffer) - IF ( Tosegment(j)==0 ) PRINT *, 'WARNING, No HRUs and tosegment=0 for segment:', j - ENDIF - ENDIF - ENDDO -! IF ( Active_area/=Segment_area ) PRINT *, 'Not all area in model domain included with segments, basin area =', & -! & Active_area, ' segment area = ', Segment_area - ENDIF - - IF ( Ripst_flag==1 ) THEN - IF ( getparam(MODNAME, 'ripst_areafr_max', Nhru, 'real', Ripst_areafr_max)/=0 ) CALL read_error(2, 'ripst_areafr_max') - IF ( getparam(MODNAME, 'ripst_et_coef', Nhru, 'real', Ripst_et_coef)/=0 ) CALL read_error(2, 'ripst_et_coef') - IF ( getparam(MODNAME, 'tr_ratio', Nhru, 'real', Tr_ratio)/=0 ) CALL read_error(2, 'tr_ratio') - IF ( getparam(MODNAME, 'bankfinite_hru', Nhru, 'integer', Bankfinite_hru)/=0 ) CALL read_error(2, 'bankfinite_hru') - ! might be able to calculate if want bankfinite_hru = 1 or 0 based on ripst_areafr_max and transmiss_seg - IF ( getparam(MODNAME, 'transmiss_seg', Nsegment, 'real', Transmiss_seg)/=0 ) CALL read_error(2, 'transmiss_seg') - IF ( getparam(MODNAME, 'specyield_seg', Nsegment, 'real', Specyield_seg)/=0 ) CALL read_error(2, 'specyield_seg') - IF ( getparam(MODNAME, 'porosity_seg', Nsegment, 'real', Porosity_seg)/=0 ) CALL read_error(2, 'porosity_seg') - Seg_hru_num = 0 - DO i = 1, Active_hrus - IF ( Hru_segment(i)>0) THEN - IF (Bankfinite_hru(i)==1) Basin_bankst_area = Basin_bankst_area+Ripst_areafr_max(i)*Hru_area_dble(i) ! in inches - IF (Bankfinite_hru(i)==0) Basin_bankst_area = Basin_bankst_area+Hru_area_dble(i) ! in inches - Ripst_area_max(i) = Ripst_areafr_max(i)*Hru_area(i) -! depth of hyporheic estimated at stream depth/porosity, Harvey and Wagner (2000) ?? - Ripst_depth(i) = Seg_depth(Hru_segment(i)) / Porosity_seg(Hru_segment(i)) - IF (Ripst_areafr_max(i)==0.0) Ripst_depth(i) = 0.0 - Ripst_vol_max(i) = DBLE( Ripst_area_max(i)*Ripst_depth(i)*(1.0-0.5*Tr_ratio(i)) ) - Seg_hru_num(Hru_segment(i)) =Seg_hru_num(Hru_segment(i)) +1 - ENDIF - ENDDO - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN - IF ( getparam(MODNAME, 'ripst_frac_init', Nhru, 'real', Ripst_frac_init)/=0 ) CALL read_error(2, 'ripst_frac_init') - IF ( getparam(MODNAME, 'bankst_head_init', Nhru, 'real', Bankst_head_init)/=0 ) CALL read_error(2, 'bankst_head_init') - CALL init_the_swamp() - CALL init_bank_storage() - DEALLOCATE ( Bankst_head_init, Ripst_frac_init ) - ENDIF - ENDIF - - isegerr = 0 - Segment_up = 0 - ! Begin the loops for ordering segments - DO j = 1, Nsegment - iseg = Obsin_segment(j) - toseg = Tosegment(j) - IF ( toseg==j ) THEN - PRINT *, 'ERROR, tosegment value (', toseg, ') equals itself for segment:', j - isegerr = 1 - ELSEIF ( toseg>0 ) THEN - IF ( Tosegment(toseg)==j ) THEN - PRINT *, 'ERROR, circle found, segment:', j, ' sends flow to segment:', toseg, ' that sends it flow' - isegerr = 1 - ELSE - ! load segment_up with last stream segment that flows into a segment - Segment_up(toseg) = j - ENDIF - ENDIF - ENDDO - - IF ( Parameter_check_flag>0 ) THEN - DO i = 1, Nsegment - IF ( Segment_up(i)==0 .AND. Tosegment(i)==0 ) & - & PRINT *, 'WARNING, no other segment flows into segment:', i, ' and tosegment=0' - ENDDO - ENDIF - - IF ( isegerr==1 ) THEN - Inputerror_flag = 1 - RETURN - ENDIF - - ! Begin the loops for ordering segments - ALLOCATE ( x_off(Nsegment) ) - x_off = 0 - Segment_order = 0 - lval = 0 - iseg = 0 - eseg = 0 - DO WHILE ( lval0 - Ts = 1.0 - ierr = 0 - DO i = 1, Nsegment - IF ( Strmflow_flag==7 ) THEN ! muskingum_mann - velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth - K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped length - !K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours - ENDIF - - IF ( Segment_type(i)==2 .AND. K_coef(i)<24.0 ) K_coef(i) = 24.0 !K_coef must be specified = 24.0 for lake segments' - IF ( K_coef(i)<0.01 ) K_coef(i) = 0.01 !make compliant with old version of K_coef - IF ( K_coef(i)>24.0 ) K_coef(i) = 24.0 - k = K_coef(i) - x = X_coef(i) - -! check the values of k and x to make sure that Muskingum routing is stable - - IF ( k<1.0 ) THEN - IF ( Parameter_check_flag>0 ) THEN - PRINT '(/,A,I6,A,F6.2,/,9X,A,/)', 'WARNING, segment ', i, ' has K_coef < 1.0,', k, & - & 'this may produce unstable results' -! ierr = 1 - ENDIF -! Ts(i) = 0.0 ! not sure why this was set to zero, causes divide by 0 if K_coef < 1, BUG FIX 10/18/2016 RSR - Ts_i(i) = -1 - - ELSEIF ( k<2.0 ) THEN - Ts(i) = 1.0 - Ts_i(i) = 1 - - ELSEIF ( k<3.0 ) THEN - Ts(i) = 2.0 - Ts_i(i) = 2 - - ELSEIF ( k<4.0 ) THEN - Ts(i) = 3.0 - Ts_i(i) = 3 - - ELSEIF ( k<6.0 ) THEN - Ts(i) = 4.0 - Ts_i(i) = 4 - - ELSEIF ( k<8.0 ) THEN - Ts(i) = 6.0 - Ts_i(i) = 6 - - ELSEIF ( k<12.0 ) THEN - Ts(i) = 8.0 - Ts_i(i) = 8 - - ELSEIF ( k<24.0 ) THEN - Ts(i) = 12.0 - Ts_i(i) = 12 - - ELSE - Ts(i) = 24.0 - Ts_i(i) = 24 - - ENDIF - -! x must be <= t/(2K) the C coefficents will be negative. Check for this for all segments -! with Ts >= minimum Ts (1 hour). - IF ( Ts(i)>0.1 ) THEN - x_max = Ts(i) / (2.0 * k) - IF ( x>x_max ) THEN - PRINT *, 'ERROR, x_coef value is too large for stable routing for segment:', i, ' x_coef:', x - PRINT *, ' a maximum value of:', x_max, ' is suggested' - Inputerror_flag = 1 - CYCLE - ENDIF - ENDIF - - d = k - (k * x) + (0.5 * Ts(i)) - IF ( ABS(d)0 ) PRINT *, 'WARNING, segment ', i, ' computed value d <', NEARZERO, ', set to 0.0001' - d = 0.0001 - ENDIF - C0(i) = (-(k * x) + (0.5 * Ts(i))) / d - C1(i) = ((k * x) + (0.5 * Ts(i))) / d - C2(i) = (k - (k * x) - (0.5 * Ts(i))) / d - - ! the following code was in the original musroute, but, not in Linsley and others - ! rsr, 3/1/2016 - having < 0 coefficient can cause negative flows as found by Jacob in GCPO headwater -! if c2 is <= 0.0 then short travel time though reach (less daily -! flows), thus outflow is mainly = inflow w/ small influence of previous -! inflow. Therefore, keep c0 as is, and lower c1 by c2, set c2=0 - -! if c0 is <= 0.0 then long travel time through reach (greater than daily -! flows), thus mainly dependent on yesterdays flows. Therefore, keep -! c2 as is, reduce c1 by c0 and set c0=0 -! SHORT travel time - IF ( C2(i)<0.0 ) THEN - IF ( Parameter_check_flag>0 ) THEN - PRINT '(/,A)', 'WARNING, c2 < 0, set to 0, c1 set to c1 + c2' - PRINT *, ' old c2:', C2(i), '; old c1:', C1(i), '; new c1:', C1(i) + C2(i) - PRINT *, ' K_coef:', K_coef(i), '; x_coef:', x_coef(i) - ENDIF - C1(i) = C1(i) + C2(i) - C2(i) = 0.0 - ENDIF - -! LONG travel time - IF ( C0(i)<0.0 ) THEN - IF ( Parameter_check_flag>0 ) THEN - PRINT '(/,A)', 'WARNING, c0 < 0, set to 0, c0 set to c1 + c0' - PRINT *, ' old c0:', C0(i), 'old c1:', C1(i), 'new c1:', C1(i) + C0(i) - PRINT *, ' K_coef:', K_coef(i), '; x_coef:', x_coef(i) - ENDIF - C1(i) = C1(i) + C0(i) - C0(i) = 0.0 - ENDIF - - ENDDO - IF ( ierr==1 ) PRINT '(/,A,/)', '***Recommend that the Muskingum parameters be adjusted in the Parameter File' - DEALLOCATE ( K_coef, X_coef) - - END FUNCTION routinginit - -!*********************************************************************** -! route_run - Computes segment flow states and fluxes -!*********************************************************************** - INTEGER FUNCTION route_run() - USE PRMS_ROUTING - USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag, Glacier_flag - USE PRMS_BASIN, ONLY: Hru_area, Hru_route_order, Active_hrus, NEARZERO, FT2_PER_ACRE - USE PRMS_CLIMATEVARS, ONLY: Swrad, Potet - USE PRMS_SET_TIME, ONLY: Timestep_seconds, Cfs_conv - USE PRMS_FLOWVARS, ONLY: Ssres_flow, Sroff, Seg_lateral_inflow !, Seg_outflow - USE PRMS_WATER_USE, ONLY: Segment_transfer, Segment_gain - USE PRMS_GWFLOW, ONLY: Gwres_flow - USE PRMS_SRUNOFF, ONLY: Strm_seg_in - USE PRMS_GLACR, ONLY: Glacr_flow - IMPLICIT NONE -! Functions - INTRINSIC DBLE -! Local Variables - INTEGER :: i, j, jj, this_seg - DOUBLE PRECISION :: tocfs - LOGICAL :: found -!*********************************************************************** - route_run = 0 - - Cfs2acft = Timestep_seconds/FT2_PER_ACRE - -! seg variables are not computed if cascades are active as hru_segment is ignored - IF ( Hru_seg_cascades==1 ) THEN - ! add hru_ppt, hru_actet - Seginc_gwflow = 0.0D0 - Seginc_ssflow = 0.0D0 - Seginc_sroff = 0.0D0 - Seginc_swrad = 0.0D0 - Seginc_potet = 0.0D0 - Seg_gwflow = 0.0D0 - Seg_sroff = 0.0D0 - Seg_ssflow = 0.0D0 - ENDIF - IF ( Cascade_flag==0 ) THEN - Seg_lateral_inflow = 0.0D0 - ELSE ! use strm_seg_in for cascade_flag = 1 or 2 - Seg_lateral_inflow = Strm_seg_in - ENDIF - - DO jj = 1, Active_hrus - j = Hru_route_order(jj) - tocfs = DBLE( Hru_area(j) )*Cfs_conv - Hru_outflow(j) = DBLE( (Sroff(j) + Ssres_flow(j) + Gwres_flow(j)) )*tocfs - ! Note: glacr_flow (from glacier or snowfield) is added as a gain, outside stream network addition - ! glacr_flow in inch^3, 1728=12^3 - IF ( Glacier_flag==1 ) Hru_outflow(j) = Hru_outflow(j) + Glacr_flow(j)/1728.0/Timestep_seconds - IF ( Hru_seg_cascades==1 ) THEN - i = Hru_segment(j) - IF ( i>0 ) THEN - Seg_gwflow(i) = Seg_gwflow(i) + Gwres_flow(j) - Seg_sroff(i) = Seg_sroff(i) + Sroff(j) - Seg_ssflow(i) = Seg_ssflow(i) + Ssres_flow(j) - ! if cascade_flag = 2, seg_lateral_inflow set with strm_seg_in - IF ( Cascade_flag==0 ) Seg_lateral_inflow(i) = Seg_lateral_inflow(i) + Hru_outflow(j) - Seginc_sroff(i) = Seginc_sroff(i) + DBLE( Sroff(j) )*tocfs - Seginc_ssflow(i) = Seginc_ssflow(i) + DBLE( Ssres_flow(j) )*tocfs - Seginc_gwflow(i) = Seginc_gwflow(i) + DBLE( Gwres_flow(j) )*tocfs - Seginc_swrad(i) = Seginc_swrad(i) + DBLE( Swrad(j)*Hru_area(j) ) - Seginc_potet(i) = Seginc_potet(i) + DBLE( Potet(j)*Hru_area(j) ) - ENDIF - ENDIF - ENDDO - - IF ( Use_transfer_segment==1 ) THEN - DO i = 1, Nsegment - Seg_lateral_inflow(i) = Seg_lateral_inflow(i) + DBLE( Segment_gain(i) - Segment_transfer(i) ) - ENDDO - ENDIF - - IF ( Cascade_flag==1 ) RETURN - -! Divide solar radiation and PET by sum of HRU area to get avarage - IF ( Noarea_flag==0 ) THEN - DO i = 1, Nsegment - Seginc_swrad(i) = Seginc_swrad(i)/Segment_hruarea(i) - Seginc_potet(i) = Seginc_potet(i)/Segment_hruarea(i) - ENDDO - -! If there are no HRUs associated with a segment, then figure out some -! other way to get the solar radiation, the following is not great - ELSE ! IF ( Noarea_flag==1 ) THEN - DO i = 1, Nsegment -! This reworked by markstrom - IF ( Segment_hruarea(i)>NEARZERO ) THEN - Seginc_swrad(i) = Seginc_swrad(i)/Segment_hruarea(i) - Seginc_potet(i) = Seginc_potet(i)/Segment_hruarea(i) - ELSE - -! Segment does not have any HRUs, check upstream segments. - this_seg = i - found = .false. - do - if (Segment_hruarea(this_seg) <= NEARZERO) then - - ! Hit the headwater segment without finding any HRUs (i.e. sources of streamflow) - if (segment_up(this_seg) .eq. 0) then - found = .false. - exit - endif - - ! There is an upstream segment, check that segment for HRUs - this_seg = segment_up(this_seg) - else - ! This segment has HRUs so there will be swrad and potet - Seginc_swrad(i) = Seginc_swrad(this_seg)/Segment_hruarea(this_seg) - Seginc_potet(i) = Seginc_potet(this_seg)/Segment_hruarea(this_seg) - found = .true. - exit - endif - enddo - - if (.not. found) then -! Segment does not have any upstream segments with HRUs, check downstream segments. - - this_seg = i - found = .false. - do - if (Segment_hruarea(this_seg) <= NEARZERO) then - - ! Hit the terminal segment without finding any HRUs (i.e. sources of streamflow) - if (tosegment(this_seg) .eq. 0) then - found = .false. - exit - endif - - ! There is a downstream segment, check that segment for HRUs - this_seg = tosegment(this_seg) - else - ! This segment has HRUs so there will be swrad and potet - Seginc_swrad(i) = Seginc_swrad(this_seg)/Segment_hruarea(this_seg) - Seginc_potet(i) = Seginc_potet(this_seg)/Segment_hruarea(this_seg) - found = .true. - exit - endif - enddo - - if (.not. found) then -! write(*,*) "route_run: no upstream or downstream HRU found for segment ", i -! write(*,*) " no values for seginc_swrad and seginc_potet" - Seginc_swrad(i) = -99.9 - Seginc_potet(i) = -99.9 - endif - endif - ENDIF - ENDDO - ENDIF - - END FUNCTION route_run - -!*********************************************************************** -! Initialize overbank riparian (swamp) hydrology -!*********************************************************************** - SUBROUTINE init_the_swamp() - USE PRMS_BASIN, ONLY: Basin_area_inv, Hru_area_dble, Active_hrus - USE PRMS_ROUTING, ONLY: Basin_ripst_vol, Basin_ripst_area, Ripst_vol, Ripst_frac, & - & Hru_segment, Ripst_frac_init, Basin_ripst_vol, Ripst_area, Ripst_area_max, & - & Ripst_vol_max, Ripst_stor_hru - IMPLICIT NONE -! Functions - INTRINSIC SNGL, DBLE -! Local Variables - INTEGER :: i -!*********************************************************************** - DO i = 1, Active_hrus - IF ( Hru_segment(i)>0) THEN - Ripst_frac(i) = Ripst_frac_init(i) - Ripst_vol(i) = DBLE(Ripst_frac(i))*Ripst_vol_max(i) - Ripst_stor_hru(i) = Ripst_vol(i)/Hru_area_dble(i) -! Filled riparian storage surface area for each HRU: -! Fills outward from the river with one edge on river and with same depth and same side shape -! this works out to keeping fraction same for area and volume filled - Ripst_area(i) = Ripst_area_max(i)*Ripst_frac(i) !area -! calculate the basin riparian storage volumes - Basin_ripst_vol = Basin_ripst_vol + Ripst_vol(i) - Basin_ripst_area = Basin_ripst_area + Ripst_area(i) - ENDIF - ENDDO - Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv - - END SUBROUTINE init_the_swamp - -!*********************************************************************** -! Compute overbank area (swamp) fill and drain -! Treat like a closed surface depression in that it can't spill. -! Right now, not getting water from anywhere but stream, and losing only -! to ET and seep. Possibly should take water in from precipitation, -! runoff, and interflow. -! This is called after bank storage has been removed, so not inside -! hourly routing. -!*********************************************************************** - SUBROUTINE drain_the_swamp(Ihru) - USE PRMS_ROUTING, ONLY: Seg_width, Seg_depth, Seg_width, Hru_segment, Mann_n, & - & Transmiss_seg, Tr_ratio, Ripst_vol_max, Ripst_et_coef, Ripst_evap_hru, & - & Basin_ripst_vol, Basin_ripst_evap, Basin_ripst_seep, Ripst_stor_hru, & - & Ripst_frac, Ripst_vol, Ripst_area_max, Ripst_area, Ripst_seep_hru, Seg_slope, & - & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area, Seg_length - USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Hru_area, Hru_area_dble, FEET2METERS, & - & FT2_PER_ACRE, CFS2CMS_CONV - USE PRMS_FLOWVARS, ONLY: Seg_outflow - USE PRMS_CLIMATEVARS, ONLY: Potet - USE PRMS_SET_TIME, ONLY: Timestep_seconds - USE PRMS_SRUNOFF, ONLY: Hru_impervevap, Dprst_evap_hru - USE PRMS_INTCP, ONLY: Hru_intcpevap - USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap - IMPLICIT NONE -! Functions - INTRINSIC EXP, LOG, MIN, DBLE, SNGL -! Arguments - INTEGER, INTENT(IN) :: Ihru -! Local Variables - REAL :: ripst_avail_et, unsatisfied_et, ripst_evap, ripst_wid - REAL :: inflow, inflow_in, max_depth - DOUBLE PRECISION :: seep, ripst_grnd, poss, seep_in -!*********************************************************************** -!It won't get deeper than this depth, should be Seg_depth but not accurate or Seg_width and other terms not accurate - !max_depth = Seg_depth(Hru_segment(Ihru))*10.0 - max_depth = Seg_depth(Hru_segment(Ihru))*1e30 -! amount possible in cfs given a river depth - poss = Seg_width(Hru_segment(Ihru))*SQRT(Seg_slope(Hru_segment(Ihru)))* & - & max_depth**(3./5.)/ ( CFS2CMS_CONV*Mann_n(Hru_segment(Ihru)) ) -!inflow is water over bank, remove from Seg_outflow(Hru_segment(Ihru)) and give half to -! each side of bank, in acre inches - inflow = 0.0 -! in cfs, amount over amount possible - IF ( poss < Seg_outflow(Hru_segment(Ihru)) ) inflow = SNGL(Seg_outflow(Hru_segment(Ihru)) - poss) -! give it equally to each HRU surrounding it - inflow = inflow/REAL(Seg_hru_num(Hru_segment(Ihru))) -!negative flow is out of stream into riparian - Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru)) - inflow - inflow_in = SNGL(inflow*Timestep_seconds/(FT2_PER_ACRE*12.0)) - Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow_in - Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) -! Filled riparian storage surface area for each HRU: -! Fills outward from the river with one edge on river and with same depth and same side shape -! this works out to keeping fraction same for area and volume filled - Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) - - ! evaporate water from riparian area based on snowcov_area - ! ripst_evap_open & ripst_evap_clos = inches-acres on the HRU - unsatisfied_et = Potet(Ihru) - Snow_evap(Ihru) - Hru_intcpevap(Ihru) & - & - Hru_impervevap(Ihru) - Dprst_evap_hru(Ihru) - ripst_avail_et = Potet(Ihru)*(1.0-Snowcov_area(Ihru))*Ripst_et_coef(Ihru) - Ripst_evap_hru(Ihru) = 0.0 - IF ( ripst_avail_et>0.0 ) THEN - ripst_evap = 0.0 - IF ( Ripst_area(Ihru)>0.0 ) THEN - ripst_evap = MIN(Ripst_area(Ihru)*ripst_avail_et, SNGL(Ripst_vol(Ihru))) - IF ( ripst_evap/Hru_area(Ihru)>unsatisfied_et ) THEN - !IF ( Print_debug>-1 ) THEN - ! PRINT *, 'Warning, ripst evaporation > available ET, HRU:, ', Ihru, & -! & unsatisfied_et, ripst_evap*Ripst_frac(Ihru) - ! PRINT *, 'Set to available ET, perhaps ripst_et_coef specified too large' - ! PRINT *, 'Set print_debug to -1 to turn off message' - !ENDIF - ripst_evap = unsatisfied_et*Hru_area(Ihru) - ENDIF - IF ( ripst_evap>SNGL(Ripst_vol(Ihru)) ) ripst_evap = SNGL( Ripst_vol(Ihru) ) - Ripst_vol(Ihru) = Ripst_vol(Ihru) - DBLE( ripst_evap ) - ENDIF - Ripst_evap_hru(Ihru) = ripst_evap/Hru_area(Ihru) - ENDIF - - ! compute seepage - Ripst_seep_hru(Ihru) = 0.0D0 - seep = 0.0 - IF ( Ripst_vol(Ihru)>NEARZERO ) THEN - ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters -!assumed it was a one sided stream, here a headwater with both sides in one HRU - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 -! Stream ground area is stream side area (flat wall) and other side area (fraction of triangle (1) to rectangle (0)) - ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle - & (SQRT( ripst_wid**2.0 + Ripst_depth(Ihru)**2.0 )- Ripst_depth(Ihru))*Tr_ratio(Ihru) + & !triangle - & 2.0*Ripst_depth(Ihru) ) ) !stream and other side -!assumed it was a one sided stream, here a headwater with both sides in one HRU - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 -!seep in a day through ground surface area of riparian, m^3 into ft^3 to acre_in -!Transmissivity would be way too big, maybe ssr2gw_rate - seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) - !seep = 0.0 !if want to turn off seep - seep_in = seep*FT2_PER_ACRE*12.0 - Ripst_vol(Ihru) = Ripst_vol(Ihru) - seep_in - IF ( Ripst_vol(Ihru)<0.0D0 ) THEN - !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) - seep_in = seep_in + Ripst_vol(Ihru) - seep = seep_in/(FT2_PER_ACRE*12.0) - Ripst_vol(Ihru) = 0.0D0 - ENDIF - Ripst_seep_hru(Ihru) = seep_in/Hru_area_dble(Ihru) !inch per HRU - ENDIF - IF ( Ripst_vol(Ihru)<0.0D0 ) THEN - !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) - Ripst_vol(Ihru) = 0.0D0 - ENDIF - - ! seep goes back in stream as positive flow, cfs - Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru))+ seep/Timestep_seconds - !Seg_ripflow(Hru_segment(Ihru)) = 0.0 !if want to turn off overbank flow - -! print*, Ihru, Hru_segment(Ihru), poss, Seg_outflow(Hru_segment(Ihru)), Seg_ripflow(Hru_segment(Ihru)), Seg_depth(Hru_segment(Ihru)),& -! & Stage_ts(Hru_segment(Ihru)) - - Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) - Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) - Ripst_stor_hru(Ihru) = Ripst_vol(Ihru)/Hru_area_dble(Ihru) - Basin_ripst_vol = Basin_ripst_vol + Ripst_vol(Ihru) - Basin_ripst_evap = Basin_ripst_evap + DBLE(Ripst_evap_hru(Ihru))*Hru_area_dble(Ihru) - Basin_ripst_seep = Basin_ripst_seep + Ripst_seep_hru(Ihru)*Hru_area_dble(Ihru) - Basin_ripst_area = Basin_ripst_area + Ripst_area(Ihru) - - END SUBROUTINE drain_the_swamp - -!*********************************************************************** -! Initialize bank storage hydrology -!*********************************************************************** - SUBROUTINE init_bank_storage() - USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_area_dble, Active_hrus, & - & FT2_PER_ACRE, FEET2METERS, CFS2CMS_CONV - USE PRMS_ROUTING, ONLY: Basin_bankst_head, Bankst_head_init, Basin_bankst_area, & - & Basin_bankst_vol, Bankst_head, Hru_segment, Seg_width, Seg_length, & - & Bankst_stor_hru, Bankst_head_pts, Ripst_areafr_max, Bankfinite_hru - USE PRMS_FLOWVARS, ONLY: Seg_outflow - IMPLICIT NONE -! Functions - INTRINSIC SNGL -! Local Variables - INTEGER :: i -!*********************************************************************** - DO i = 1, Active_hrus - IF ( Hru_segment(i)>0) THEN - Bankst_head(i) = Bankst_head_init(i) - Bankst_head_pts(i) =SNGL(Seg_outflow(Hru_segment(i))*CFS2CMS_CONV)*60.*60.*24. & - & /Seg_width(Hru_segment(i))/Seg_length(Hru_segment(i)) - IF (Bankfinite_hru(i)==1) THEN - Bankst_stor_hru(i) = Ripst_areafr_max(i)*12.0*Bankst_head(i)/FEET2METERS !in inches - Basin_bankst_head = Basin_bankst_head + Ripst_areafr_max(i)*Bankst_head(i)*Hru_area_dble(i) ! in meters - ELSE - Bankst_stor_hru(i) = 12.0*Bankst_head(i)/FEET2METERS !in inches - Basin_bankst_head = Basin_bankst_head + Bankst_head(i)*Hru_area_dble(i) ! in meters - ENDIF - Basin_bankst_vol = Basin_bankst_vol+Bankst_stor_hru(i)*Hru_area_dble(i) ! in inches - ENDIF - ENDDO - Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv - Basin_bankst_head = Basin_bankst_head/Basin_bankst_area - - END SUBROUTINE init_bank_storage - -!*********************************************************************** -! Compute bank storage hydrology -! For the linear boundary-value problems discussed by Moench and Barlow (2000), the total -! response of a stream–aquifer system to a time series of individual stresses (stream-stage -! fluctuations or recharge) can be determined by superposition (or convolution) of the -! system’s response to the individual stresses. -! Assume no layer of semi-pervious bank sediments, so storage right at the bank. Use a -! finite confined aquifer with no overlying aquitard, or a finite water table aquifer -! (swamp) with a specific yield of aquifer = 0, or ~ 0. -! This is saying very little water is released by the aquifer from the water table lowering -! and the unsaturated zone is thin. This is true for shallow water table aquifers; see -! Barlow et al (2000). -!*********************************************************************** - SUBROUTINE comp_bank_storage(Ihru) - USE PRMS_ROUTING, ONLY: Bankst_seep_rate, Bankst_head, Bankst_head_pts, Hru_segment, & - & Bankst_seep_hru, Bankst_stor_hru, Stage_ts, Stage_ante, Seg_bankflow, Ripst_areafr_max, & - & Transmiss_seg, Seg_width, Seg_length, Specyield_seg, Bankfinite_hru, Seg_hru_num, & - & Basin_bankst_seep, Basin_bankst_head, Basin_bankst_vol - USE PRMS_BASIN, ONLY: CFS2CMS_CONV, FT2_PER_ACRE, FEET2METERS, Hru_area, Hru_area_dble - USE PRMS_FLOWVARS, ONLY: Gwres_stor - IMPLICIT NONE -! Functions - INTRINSIC SUM, SNGL, SQRT - EXTERNAL LTST1 -! Arguments - INTEGER, INTENT(IN) :: Ihru - ! Local Variables - INTEGER :: h, t0 - INTEGER, PARAMETER :: nbankd = 2 - REAL, PARAMETER :: PI = 3.14159 - REAL :: area, str_wid, tot_wid, bank_wid, trans, a, xd, t, td - REAL :: delt, delta_input(nbankd), delta_diff(nbankd), head(nbankd), seep(nbankd) - REAL :: bank(nbankd), bankv(nbankd), ripfrac - DOUBLE PRECISION :: input_net(nbankd), diff_net(nbankd), recharge(nbankd), stage(nbankd) - DOUBLE PRECISION :: head_step, head_step_grad, seep_sum, head_sum -!*********************************************************************** - area = Ripst_areafr_max(Ihru)*Hru_area(Ihru) !acres - trans = Transmiss_seg(Hru_segment(Ihru)) -!aquifer diffusivity, ratio of the transmissivity/storativity of the aquifer - a = trans/Specyield_seg(Hru_segment(Ihru)) - str_wid = Seg_width(Hru_segment(Ihru))/2.0 - bank_wid = SNGL(area*FT2_PER_ACRE*(FEET2METERS**2.)/Seg_length(Hru_segment(Ihru))/str_wid) !dimensionless - tot_wid = bank_wid+1.0 !dimensionless - delt = 1.0 !fraction of day -! might want to interpolate a curve, so leaving nbankd as a dimension -- sh - stage(1) = Stage_ante(Hru_segment(Ihru)) - stage(2) = Stage_ts(Hru_segment(Ihru)) - ! changes in a day - DO h = 1, nbankd - seep(h) = 0.0 - bank(h) = 0.0 - bankv(h) = 0.0 - recharge(h) = (h-1)*delt*Gwres_stor(Ihru)*FEET2METERS/12.D0 ! in meters, currently ignoring ET -! Can only use recharge change if say it's a leaky aquifer overlain by a water table aquitard. -! might want to do that. Also might want to go other way and make simpler, make it semi-infinite so then -! no numerical Laplace inverse, just can solve - input_net(h) = stage(h) !+ recharge(h) - diff_net(h) = stage(h) !- recharge(h) !FIX What is this vs input_net - ENDDO -!Make head ideal flood wave for volume change and recharge ideal observed response at a well for vol change?? - DO h = 2,nbankd - delta_input(h-1) = SNGL( (input_net(h)-input_net(h-1))/delt ) - delta_diff(h-1) = SNGL((diff_net(h)-diff_net(h-1))/delt ) - ENDDO - Bankst_seep_hru(Ihru) = 0.0 - xd = 1.0+ bank_wid/2.0 ! at x = 1.0 is stage which already know, calc at middle of bank storage area - head=Bankst_head_pts(Ihru) !set at last height for initial -! Calculate heads, seepage, and bank storage using convolution - ripfrac = Ripst_areafr_max(Ihru) - IF (Bankfinite_hru(Ihru)==0) ripfrac = 1.0 - DO h = 1, (nbankd-1) - head_sum = 0.0 - seep_sum = 0.0 - DO t0 = 1,h - t = t0*delt - td = t*a/(str_wid**2.0) !dimensionless - IF (Bankfinite_hru(Ihru)==1) then !finite solution if transmissivity high, COMPUTATIONALLY EXPENSIVE, might eliminate - CALL LTST1(td, xd, tot_wid, bank_wid, head_step, head_step_grad) - ELSE IF (Bankfinite_hru(Ihru)==0) then !semi-infinite solution - head_step = ERFC( (xd - 1.0)/SQRT((4.0*td)) ) - head_step_grad = -( 1.0/SQRT((PI*td)) ) - ENDIF - !head is a function of xd - head_sum = delta_input(h-t0+1)*head_step + head_sum - !seep is per unit segment length rate goes out, not a function of xd - seep_sum = delta_diff(h-t0+1)*head_step_grad + seep_sum - ENDDO - head(h+1)=head(h+1) + SNGL(head_sum*delt) - seep(h+1)=SNGL((trans/str_wid)*seep_sum*delt) - bank(h+1)=bank(h) - seep(h+1)*delt - bankv(h+1)=bank(h+1)*Seg_length(Hru_segment(Ihru)) - !IF (Ihru==1) print*,h+1,stage(h+1),bank(h+1),seep(h+1),bankv(h+1) !for plotting daily pattern - ENDDO - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) THEN -!assumed it was a one sided stream, here a headwater with both sides in one HRU - seep = seep*2.0 - bank = bank*2.0 - bankv = bankv*2.0 - ENDIF - Bankst_head_pts(Ihru) = head(nbankd) ! meters - !linear interpolation for total average head over bank storage area, meters - Bankst_head(Ihru) = 0.5*(SNGL(stage(nbankd))+Bankst_head_pts(Ihru)) - ! Bankst_head_pts at finite edge of bank storage area is 0 (xd = 1, so head_step = 0) - ! is only saved at the end of the timestep - Bankst_head(Ihru) = Bankst_head(Ihru) + 0.5*Bankst_head_pts(Ihru) - ! m2 per 24 hr per stream segment for both sides of stream - ! seep hru is inch over hru seeping out per day - Bankst_seep_hru(Ihru) = -12.0*bankv(nbankd)/SNGL(CFS2CMS_CONV*Hru_area(Ihru)*FT2_PER_ACRE) - Bankst_seep_rate(Hru_segment(Ihru)) = Bankst_seep_rate(Hru_segment(Ihru)) - bank(nbankd) - Bankst_stor_hru(Ihru) = Bankst_stor_hru(Ihru)- Bankst_seep_hru(Ihru) !inch over hru - Seg_bankflow(Hru_segment(Ihru)) = Seg_bankflow(Hru_segment(Ihru))-bankv(nbankd)/(24.*60.*60.)/CFS2CMS_CONV - !FIX area change?? no I don't think so - Basin_bankst_seep = Basin_bankst_seep + Bankst_seep_hru(Ihru)*Hru_area_dble(Ihru) - Basin_bankst_head = Basin_bankst_head + ripfrac*Bankst_head(Ihru)* Hru_area_dble(Ihru) - Basin_bankst_vol = Basin_bankst_vol+Bankst_stor_hru(Ihru)*Hru_area_dble(Ihru) - - END SUBROUTINE comp_bank_storage - -!*********************************************************************** -! Laplace transform leakage equation -!*********************************************************************** - SUBROUTINE LTST1(td, xd, tot_wid, bank_wid, head_step, head_step_grad) - IMPLICIT NONE -! Functions - INTRINSIC EXP, LOG, DBLE - EXTERNAL LINVST -! Arguments - REAL, INTENT(IN) :: td, xd, tot_wid, bank_wid - DOUBLE PRECISION, INTENT(OUT) :: head_step, head_step_grad -! Local Variables - INTEGER, PARAMETER :: NS=12 ! Number of Stehfest terms, 8 usually sufficient but Barlow uses 12 - INTEGER :: expmax, i, NH - DOUBLE PRECISION :: c1, c2, c3, c4, ff, fnum, fden, xLN2, p - DOUBLE PRECISION :: caq, ca, re0, re0q, pdl, pdlq, xp, xpq, V(NS) -!*********************************************************************** - NH=NS/2 - CALL LINVST(NS,NH,V) - xLN2=LOG(2.0) -!expmax is the maximum allowable absolute value of the exponential arguments - expmax=708 - xp=0.0 - xpq=0.0 - DO i=1,NS - p=xLN2*i/td -!calculate coeficients - c1 = SQRT(p) - c2 = p - fnum = EXP(DBLE( -2.0*SQRT(p)*(tot_wid-xd) )) +1.0 - fden = EXP(DBLE( -2.0*SQRT(p)*bank_wid )) +1.0 - ff = fnum/fden - c3 = fden - c4 = c2*c3 - caq = -(c1/c4)*(EXP(DBLE( -2.0*SQRT(p)*bank_wid )) -1.0) - ca = c1*(xd-1.0) - IF (ca > expmax) ca = expmax -!calculate head and seepage terms - re0 = ff*EXP(-ca) - re0q = caq - pdl = re0/c2 - pdlq = re0q - xp = xp + V(i)*pdl - xpq = xpq + V(i)*pdlq - ENDDO - head_step = xp*xLN2/td - head_step_grad = xpq*xLN2/td - - END SUBROUTINE LTST1 - -!*********************************************************************** -! Stehfest coefficients for Laplace transform -!*********************************************************************** - SUBROUTINE LINVST(NS, NH, V) - IMPLICIT NONE -! Functions - INTRINSIC FLOOR -! Arguments - INTEGER, INTENT(IN) :: NS,NH - DOUBLE PRECISION, INTENT(OUT) :: V(NS) -! Local Variables - INTEGER :: i, j, FI, SN, K1,K2 - DOUBLE PRECISION :: G(NS), HS(NH) -!*********************************************************************** - G(1)=1.0 - DO i=2,NS - G(i)=G(i-1)*i - ENDDO - HS(1)=2.0/G(NH-1) - DO i = 2,NH - FI=i - IF (i== NH) THEN - HS(i)=(FI**NH)*G(2*i)/(G(i)*G(i-1)) - ELSE - HS(i)=(FI**NH)*G(2*i)/(G(NH-i)*G(i)*G(i-1)) - ENDIF - ENDDO - SN=2*(NH-NH/2*2)-1 - DO i=1,NS - V(i)=0.0 - K1=FLOOR((i+1)/2.0) - K2=i - IF (K2 > NH) K2 = NH - DO j=K1,K2 - IF (2*j-i == 0) THEN - V(i)=V(i)+HS(j)/(G(i-j)) - ELSEIF (i == j) THEN - V(i)=V(i)+HS(j)/G(2*j-i) - ELSE - V(i)=V(i)+HS(j)/(G(i-j)*G(2*j-i)) - ENDIF - ENDDO - V(i)=SN*V(i) - SN=-SN - ENDDO - - END SUBROUTINE LINVST - -!*********************************************************************** -! routing_restart - write or read restart file -!*********************************************************************** - SUBROUTINE routing_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Ripst_flag - USE PRMS_ROUTING - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - EXTERNAL check_restart - ! Local Variables - CHARACTER(LEN=7) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Basin_segment_storage - WRITE ( Restart_outunit ) Segment_delta_flow - IF ( Ripst_flag==1 ) THEN - WRITE ( Restart_outunit ) Basin_bankst_head - WRITE ( Restart_outunit ) Basin_bankst_vol - WRITE ( Restart_outunit ) Basin_bankst_seep_rate - WRITE ( Restart_outunit ) Basin_bankst_seep, Basin_bankflow - WRITE ( Restart_outunit ) Bankst_head, Seg_bankflow - WRITE ( Restart_outunit ) Bankst_head_pts - WRITE ( Restart_outunit ) Bankst_stor_hru - WRITE ( Restart_outunit ) Stage_ante, Stage_ts - WRITE ( Restart_outunit ) Basin_ripflow - WRITE ( Restart_outunit ) Basin_ripst_evap, Basin_ripst_seep - WRITE ( Restart_outunit ) Basin_ripst_vol, Basin_ripst_area - WRITE ( Restart_outunit ) Ripst_stor_hru, Ripst_seep_hru, Ripst_vol - WRITE ( Restart_outunit ) Seg_ripflow, Ripst_evap_hru, Ripst_frac - ENDIF - ELSE - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) Basin_segment_storage - READ ( Restart_inunit ) Segment_delta_flow - IF ( Ripst_flag==1 ) THEN - READ ( Restart_inunit ) Basin_segment_storage - READ ( Restart_inunit ) Segment_delta_flow - READ ( Restart_inunit ) Basin_bankst_head - READ ( Restart_inunit ) Basin_bankst_vol - READ ( Restart_inunit ) Basin_bankst_seep_rate - READ ( Restart_inunit ) Basin_bankst_seep, Basin_bankflow - READ ( Restart_inunit ) Bankst_head, Seg_bankflow - READ ( Restart_inunit ) Bankst_head_pts - READ ( Restart_inunit ) Bankst_stor_hru - READ ( Restart_inunit ) Stage_ante, Stage_ts - READ ( Restart_inunit ) Basin_ripflow - READ ( Restart_inunit ) Basin_ripst_evap, Basin_ripst_seep - READ ( Restart_inunit ) Basin_ripst_vol, Basin_ripst_area - READ ( Restart_inunit ) Ripst_stor_hru, Ripst_seep_hru, Ripst_vol - READ ( Restart_inunit ) Seg_ripflow, Ripst_evap_hru, Ripst_frac - ENDIF - ENDIF - END SUBROUTINE routing_restart diff --git a/prms/snowcompCfgim.f90 b/prms/snowcompCfgim.f90 deleted file mode 100644 index 87149d2f..00000000 --- a/prms/snowcompCfgim.f90 +++ /dev/null @@ -1,3027 +0,0 @@ -!*********************************************************************** -! Initiates development of a snowpack and simulates snow accumulation -! and depletion processes using an energy-budget approach -! -! Modified glacier melt and glacier basal melt -! These modifications includes albedo info for saving between runs 2/00 -!*********************************************************************** - -! PRMS_SNOW module for defining stateful variables - - MODULE PRMS_SNOW - - IMPLICIT NONE - !**************************************************************** - ! Local Constants - - INTEGER, PARAMETER :: MAXALB = 15 - - !**************************************************************** - ! Local Variables - - REAL, PARAMETER :: PI = 3.1415927 - INTEGER, SAVE :: Active_glacier, Active_freezing - INTEGER, SAVE, ALLOCATABLE :: Int_alb(:) - DOUBLE PRECISION, SAVE :: Deninv, Denmaxinv, Settle_const_dble - ! REAL, SAVE :: Setden, Set1 - REAL, SAVE :: Acum(MAXALB), Amlt(MAXALB) - REAL, SAVE, ALLOCATABLE :: Snowcov_areasv(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Scrv(:), Pss(:), Pksv(:), Pst(:) - REAL, SAVE, ALLOCATABLE :: Salb(:), Slst(:) - CHARACTER(LEN=8), SAVE :: MODNAME - - !**************************************************************** - ! Declared Variables - - INTEGER :: Yrdays5 - INTEGER, SAVE, ALLOCATABLE :: Pptmix_nopack(:), Lst(:) - INTEGER, SAVE, ALLOCATABLE :: Iasw(:), Iso(:), Mso(:), Lso(:) - DOUBLE PRECISION, SAVE :: Basin_snowmelt, Basin_pweqv, Basin_tcal - DOUBLE PRECISION, SAVE :: Basin_snowcov, Basin_snowevap - DOUBLE PRECISION, SAVE :: Basin_snowdepth, Basin_pk_precip - REAL, SAVE, ALLOCATABLE :: Snowmelt(:), Snow_evap(:) - REAL, SAVE, ALLOCATABLE :: Albedo(:), Pk_temp(:), Pk_den(:) - REAL, SAVE, ALLOCATABLE :: Pk_def(:), Pk_ice(:), Freeh2o(:) - REAL, SAVE, ALLOCATABLE :: Snowcov_area(:), Tcal(:) - REAL, SAVE, ALLOCATABLE :: Snsv(:), Pk_precip(:), Frac_swe(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Pk_depth(:), Pkwater_ante(:), Ai(:) -! Frozen ground variables - REAL, SAVE, ALLOCATABLE :: Tcal_nosnow(:), Land_albedo(:) -! Glacier variables - DOUBLE PRECISION, SAVE :: Basin_glacrevap, Basin_snowicecov - DOUBLE PRECISION, SAVE :: Basin_glacrb_melt - REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_capm(:), Prev_ann_tempc(:) - REAL, SAVE, ALLOCATABLE :: Glacrmelt(:), Glacr_evap(:), Glacr_albedo(:), Glacr_pk_den(:) - REAL, SAVE, ALLOCATABLE :: Glacr_pk_ice(:), Glacr_freeh2o(:), Glacrcov_area(:) - REAL, SAVE, ALLOCATABLE :: Glacrb_melt(:), Glacr_pk_def(:), Glacr_pk_temp(:), Ann_tempc(:) - REAL, SAVE, ALLOCATABLE :: Glacr_air_5avtemp1(:), Glacr_air_deltemp(:), Glacr_air_5avtemp(:) - REAL, SAVE, ALLOCATABLE :: Glacr_5avsnow1(:), Glacr_5avsnow(:),Glacr_delsnow(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pkwater_ante(:), Glacr_pkwater_equiv(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pk_depth(:), Glacr_pss(:), Glacr_pst(:) - !**************************************************************** - ! Declared Parameters - - INTEGER, SAVE, ALLOCATABLE :: Melt_look(:), Melt_force(:), Tstorm_mo(:, :) - INTEGER, SAVE, ALLOCATABLE :: Hru_deplcrv(:) - REAL, SAVE :: Albset_rnm, Albset_rna, Albset_snm, Albset_sna - REAL, SAVE, ALLOCATABLE :: Emis_noppt(:), Freeh2o_cap(:), Cecn_coef(:, :) - REAL, SAVE :: Den_init, Settle_const, Den_max - REAL, SAVE, ALLOCATABLE :: Rad_trncf(:), Snarea_thresh(:), Snowpack_init(:) - REAL, SAVE, ALLOCATABLE :: Snarea_curve(:, :) -! Glacier parameters - REAL, SAVE, ALLOCATABLE :: Glacr_layer(:), Albedo_coef(:), Albedo_ice(:) - REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_cap(:), Glacier_frac_init(:), Glrette_frac_init(:) - - END MODULE PRMS_SNOW - -!*********************************************************************** -! Main snowcomp routine -!*********************************************************************** - INTEGER FUNCTION snowcomp() - USE PRMS_MODULE, ONLY: Process, Save_vars_to_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: snodecl, snoinit, snorun - EXTERNAL :: snowcomp_restart -!*********************************************************************** - snowcomp = 0 - - IF ( Process(:3)=='run' ) THEN - snowcomp = snorun() - ELSEIF ( Process(:4)=='decl' ) THEN - snowcomp = snodecl() - ELSEIF ( Process(:4)=='init' ) THEN - snowcomp = snoinit() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL snowcomp_restart(0) - ENDIF - - END FUNCTION snowcomp - -!*********************************************************************** -! snodecl - set up parameters for snowmelt computations -! Declared Parameters -! den_init, settle_const, den_max, melt_look -! melt_force, rad_trncf, hru_deplcrv, snarea_curve, snarea_thresh -! albset_rnm, albset_rna, albset_snm, albset_sna, potet_sublim -! emis_noppt, cecn_coef, freeh2o_cap, tstorm_mo, tmax_allsnow -! hru_area, cov_type, covden_win -! glacr_freeh2o_cap, glacr_layer -!*********************************************************************** - INTEGER FUNCTION snodecl() - USE PRMS_SNOW - USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag, Model, & - & Frozen_flag - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: declparam, declvar - EXTERNAL read_error, print_module -! Local Variables - CHARACTER(LEN=80) :: Version_snowcomp -!*********************************************************************** - snodecl = 0 - - Version_snowcomp = 'snowcomp.f90 2018-05-04 09:41:00Z' - CALL print_module(Version_snowcomp, 'Snow Dynamics ', 90) - MODNAME = 'snowcomp' - -! declare variables - ALLOCATE ( Scrv(Nhru) ) - IF ( declvar(MODNAME, 'scrv', 'nhru', Nhru, 'double', & - & 'Snowpack water equivalent plus a portion of new snow on each HRU', & - & 'inches', Scrv)/=0 ) CALL read_error(3, 'scrv') - - ALLOCATE ( Pksv(Nhru) ) - IF ( declvar(MODNAME, 'pksv', 'nhru', Nhru, 'double', & - & 'Snowpack water equivalent when there is new snow and in melt phase;'// & - & ' used to interpolate between depletion curve and 100 percent on each HRU', & - & 'inches', Pksv)/=0 ) CALL read_error(3, 'pksv') - - ALLOCATE ( Snowcov_areasv(Nhru) ) - IF ( declvar(MODNAME, 'snowcov_areasv', 'nhru', Nhru, 'real', & - & 'Snow cover fraction when there is new snow and in melt phase;'// & - & ' used to interpolate between depletion curve and 100 percent on each HRU', & - & 'decimal fraction', Snowcov_areasv)/=0 ) CALL read_error(3, 'snowcov_areasv') - - ALLOCATE ( Salb(Nhru) ) - IF ( declvar(MODNAME, 'salb', 'nhru', Nhru, 'real', & - & 'Days since last new snow to reset albedo for each HRU', & - & 'days', Salb)/=0 ) CALL read_error(3, 'salb') - - ALLOCATE ( Slst(Nhru) ) - IF ( declvar(MODNAME, 'slst', 'nhru', Nhru, 'real', & - & 'Days since last new snow for each HRU', & - & 'days', Slst)/=0 ) CALL read_error(3, 'slst') - - ALLOCATE ( Int_alb(Nhru) ) - IF ( declvar(MODNAME, 'int_alb', 'nhru', Nhru, 'integer', & - & 'Flag to indicate (1: accumulation season curve; 2: use of the melt season curve)', & - & 'none', Int_alb)/=0 ) CALL read_error(3, 'int_alb') - -! Glacier declares - IF ( Glacier_flag==1 .OR. Frozen_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Ann_tempc(Nhru) ) - IF ( declvar(MODNAME, 'ann_tempc', 'nhru', Nhru, 'real', & - & 'Current average year air temperature over HRU', & - & 'degrees Celsius', Ann_tempc)/=0 ) CALL read_error(3, 'ann_tempc') - ALLOCATE ( Prev_ann_tempc(Nhru) ) - ENDIF - - IF ( Glacier_flag==1 .OR. Model==99 ) THEN - IF ( declvar(MODNAME, 'yrdays5', 'one', 1, 'integer', & - & 'Number of days since last 5 year mark', & - & 'none', Yrdays5)/=0 ) CALL read_error(3, 'yrdays5') - - ALLOCATE ( Glacr_freeh2o_capm(Nhru) ) - IF ( declvar(MODNAME, 'glacr_freeh2o_capm', 'nhru', Nhru, 'real', & - & 'Free-water holding capacity of glacier ice, changes to 0 if active layer melts', & - & 'decimal fraction', Glacr_freeh2o_capm)/=0 ) CALL read_error(3, 'glacr_freeh2o_capm') - - ALLOCATE ( Glacrb_melt(Nhru) ) - IF ( declvar(MODNAME, 'glacrb_melt', 'nhru', Nhru, 'real', & - 'Glacier basal melt, goes to soil', & - 'inches/day', Glacrb_melt)/=0 ) CALL read_error(3, 'glacrb_melt') - - ALLOCATE ( Glacr_air_5avtemp(Nhru) ) - IF ( declvar(MODNAME, 'glacr_air_5avtemp', 'nhru', Nhru, 'real', & - & 'Current 5-yr average summer (June July Aug) air temperature over glacier or glrette HRU', & - & 'degrees Celsius', Glacr_air_5avtemp)/=0 ) CALL read_error(3, 'glacr_air_5avtemp') - - ALLOCATE ( Glacr_air_5avtemp1(Nhru) ) - IF ( declvar(MODNAME, 'glacr_air_5avtemp1', 'nhru', Nhru, 'real', & - & 'First 5-yr average summer temperature over glacier or glrette HRU', & - & 'degrees Celsius', Glacr_air_5avtemp1)/=0 ) CALL read_error(3, 'glacr_air_5avtemp1') - - ALLOCATE ( Glacr_air_deltemp(Nhru) ) - IF ( declvar(MODNAME, 'glacr_air_deltemp', 'nhru', Nhru, 'real', & - & 'Change in 5-yr average air temperature over glacier or glrette HRU from first', & - & 'degrees Celsius', Glacr_air_deltemp)/=0 ) CALL read_error(3, 'glacr_air_deltemp') - - ALLOCATE ( Glacr_5avsnow(Nhru) ) - IF ( declvar(MODNAME, 'glacr_5avsnow', 'nhru', Nhru, 'real', & - & 'Current 5-yr average snow over glacier or glrette HRU', & - & 'inches/yr', Glacr_5avsnow)/=0 ) CALL read_error(3, 'glacr_5avsnow') - - ALLOCATE ( Glacr_5avsnow1(Nhru) ) - IF ( declvar(MODNAME, 'glacr_5avsnow1', 'nhru', Nhru, 'real', & - & 'First 5-yr average snow over glacier or glrette HRU', & - & 'inches/yr', Glacr_5avsnow1)/=0 ) CALL read_error(3, 'glacr_5avsnow1') - - ALLOCATE ( Glacr_delsnow(Nhru) ) - IF ( declvar(MODNAME, 'glacr_delsnow', 'nhru', Nhru, 'real', & - & 'Change in 5-yr average snow over glacier or glrette HRU from first', & - & 'inches/yr', Glacr_delsnow)/=0 ) CALL read_error(3, 'glacr_delsnow') - - ALLOCATE ( Glacr_pk_temp(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pk_temp', 'nhru', Nhru, 'real', & - & 'Temperature of the glacier on each HRU', & - & 'degrees Celsius', Glacr_pk_temp)/=0 ) CALL read_error(3, 'glacr_pk_temp') - - ALLOCATE ( Glacr_pk_def(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pk_def', 'nhru', Nhru, 'real', & - & 'Heat deficit, amount of heat necessary to make the glacier snowpack isothermal at 0 degrees Celsius', & - & 'Langleys', Glacr_pk_def)/=0 ) CALL read_error(3, 'glacr_pk_def') - - ALLOCATE ( Glacr_pk_den(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pk_den', 'nhru', Nhru, 'real', & - & 'Density of the icepack on each glacier HRU, hard-coded to equal 0.917', & - & 'gm/cm3', Glacr_pk_den)/=0 ) CALL read_error(3, 'glacr_pk_den') - - ALLOCATE ( Glacr_albedo(Nhru) ) - IF ( declvar(MODNAME, 'glacr_albedo', 'nhru', Nhru, 'real', & - & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier HRU', & - & 'decimal fraction', Glacr_albedo)/=0 ) CALL read_error(3, 'glacr_albedo') - - ALLOCATE ( Glacr_evap(Nhru) ) - IF ( declvar(MODNAME, 'glacr_evap', 'nhru', Nhru, 'real', & - & 'Evaporation and sublimation from icepack on each glacier HRU', & - & 'inches', Glacr_evap)/=0 ) CALL read_error(3, 'glacr_evap') - - ALLOCATE ( Glacrmelt(Nhru) ) - IF ( declvar(MODNAME, 'glacrmelt', 'nhru', Nhru, 'real', & - & 'Melt from icepack on each glacier HRU, includes rain water that does not absorb', & - & 'inches', Glacrmelt)/=0 ) CALL read_error(3, 'glacrmelt') - - ALLOCATE ( Glacr_pkwater_equiv(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pkwater_equiv', 'nhru', Nhru, 'double', & - & 'Icepack water equivalent on each glacier HRU', & - & 'inches', Glacr_pkwater_equiv)/=0 ) CALL read_error(3, 'glacr_pkwater_equiv') - - ALLOCATE ( Glacr_pkwater_ante(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pkwater_ante', 'nhru', Nhru, 'double', & - & 'Antecedent icepack water equivalent on each glacier HRU', & - & 'inches', Glacr_pkwater_ante)/=0 ) CALL read_error(3, 'glacr_pkwater_ante') - - ALLOCATE ( Glacrcov_area(Nhru) ) - IF ( declvar(MODNAME, 'glacrcov_area', 'nhru', Nhru, 'real', & - & 'Ice-covered area on each glacier HRU or HRU with glacierette at start of step', & - & 'decimal fraction', Glacrcov_area)/=0 ) CALL read_error(3, 'glacrcov_area') - - ALLOCATE ( Glacr_pk_ice(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pk_ice', 'nhru', Nhru, 'real', & - & 'Storage of frozen water in the icepack on each glacier HRU', & - & 'inches', Glacr_pk_ice)/=0 ) CALL read_error(3, 'glacr_pk_ice') - - ALLOCATE ( Glacr_freeh2o(Nhru) ) - IF ( declvar(MODNAME, 'glacr_freeh2o', 'nhru', Nhru, 'real', & - & 'Storage of free liquid water in the icepack on each glacier HRU', & - & 'inches', Glacr_freeh2o)/=0 ) CALL read_error(3, 'glacr_freeh2o') - - ALLOCATE ( Glacr_pk_depth(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pk_depth', 'nhru', Nhru, 'double', & - & 'Depth of icepack on each glacier HRU, make essentially infinite', & - & 'inches', Glacr_pk_depth)/=0 ) CALL read_error(3, 'glacr_pk_depth') - - ALLOCATE ( Glacr_pss(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pss', 'nhru', Nhru, 'double', & - & 'Previous glacier pack water equivalent plus new ice', & - & 'inches', Glacr_pss)/=0 ) CALL read_error(3, 'glacr_pss') - - ALLOCATE ( Glacr_pst(Nhru) ) - IF ( declvar(MODNAME, 'glacr_pst', 'nhru', Nhru, 'double', & - & 'While a icepack exists, glacr_pst tracks the maximum ice water equivalent of that icepack', & - & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') - - IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & - & 'Basin area-weighted average snow and glacier and glrette covered area', & - & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') - - ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) - IF ( declparam(MODNAME, 'glacr_freeh2o_cap', 'nhru', 'real', & - & '0.002', '0.0', '0.01', & - & 'Free-water holding capacity of glacier ice', & - & 'Free-water holding capacity of glacier ice expressed as a' // & - & ' decimal fraction of the frozen water content of the glacier ice (glacr_pk_ice)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glacr_freeh2o_cap') - - ALLOCATE ( Glacr_layer(Nhru) ) - IF ( declparam(MODNAME, 'glacr_layer', 'nhru', 'real', & - & '3.94', '0.0', '590.6', & - & 'Active layer on glacier', & - & 'Active layer is 0 to 15 m (590.6 inches) thick at start of year, when' // & - & ' melts will set daily glacr_pk_temp to 0', & - & 'inches')/=0 ) CALL read_error(1, 'glacr_layer') - - IF ( Init_vars_from_file==0 ) THEN - ALLOCATE ( Glacier_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & - & '0.0', '0.0', '1.0', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') - - ALLOCATE ( Glrette_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'glrette_frac_init', 'nhru', 'real', & - & '0.0', '0.0', '1.0', & - & 'Initial fraction of glacierette (too small for glacier dynamics)', & - & 'Initial fraction of glacierette (too small for glacier dynamics)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glrette_frac_init') - - ENDIF - ENDIF - - IF ( Frozen_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Tcal_nosnow(Nhru) ) - IF ( declvar(MODNAME, 'tcal_nosnow', 'nhru', Nhru, 'real', & - & 'Net energy balance on each HRU without snow or glacier', & - & 'Langleys', Tcal_nosnow)/=0 ) CALL read_error(3, 'tcal_nosnow') - - ALLOCATE ( Land_albedo(Nhru) ) - IF ( declvar(MODNAME, 'land_albedo', 'nhru', Nhru, 'real', & - & 'Land surface albedo or the fraction of radiation reflected from the'// & - & ' land surface for each HRU', & - & 'decimal fraction', land_albedo)/=0 ) CALL read_error(3, 'land_albedo') - - ENDIF - - - IF ( declvar(MODNAME, 'basin_snowdepth', 'one', 1, 'double', & - & 'Basin area-weighted average snow depth', & - & 'inches', Basin_snowdepth)/=0 ) CALL read_error(3, 'basin_snowdepth') - - ALLOCATE ( Pk_precip(Nhru) ) - IF ( declvar(MODNAME, 'pk_precip', 'nhru', Nhru, 'real', & - & 'Precipitation added to snowpack for each HRU', & - & 'inches', Pk_precip)/=0 ) CALL read_error(3, 'pk_precip') - - IF ( declvar(MODNAME, 'basin_pk_precip', 'one', 1, 'double', & - & 'Basin area-weighted average precipitation added to snowpack', & - & 'inches', Basin_pk_precip)/=0 ) CALL read_error(3, 'basin_pk_precip') - - ALLOCATE ( Albedo(Nhru) ) - IF ( declvar(MODNAME, 'albedo', 'nhru', Nhru, 'real', & - & 'Snow surface albedo or the fraction of radiation reflected from the'// & - & ' snowpack surface for each HRU', & - & 'decimal fraction', Albedo)/=0 ) CALL read_error(3, 'albedo') - - ALLOCATE ( Pk_temp(Nhru) ) - IF ( declvar(MODNAME, 'pk_temp', 'nhru', Nhru, 'real', & - & 'Temperature of the snowpack on each HRU', & - & 'degrees Celsius', Pk_temp)/=0 ) CALL read_error(3, 'pk_temp') - - ALLOCATE ( Pk_den(Nhru) ) - IF ( declvar(MODNAME, 'pk_den', 'nhru', Nhru, 'real', & - & 'Density of the snowpack on each HRU', & - & 'gm/cm3', Pk_den)/=0 ) CALL read_error(3, 'pk_den') - - IF ( declvar(MODNAME, 'basin_tcal', 'one', 1, 'double', & - & 'Basin area-weighted average net snowpack energy balance', & - & 'Langleys', Basin_tcal)/=0 ) CALL read_error(3, 'basin_tcal') - - ALLOCATE ( Tcal(Nhru) ) - IF ( declvar(MODNAME, 'tcal', 'nhru', Nhru, 'real', & - & 'Net snowpack energy balance on each HRU', & - & 'Langleys', Tcal)/=0 ) CALL read_error(3, 'tcal') - - ALLOCATE ( Snow_evap(Nhru) ) - IF ( declvar(MODNAME, 'snow_evap', 'nhru', Nhru, 'real', & - & 'Evaporation and sublimation from snowpack on each HRU', & - & 'inches', Snow_evap)/=0 ) CALL read_error(3, 'snow_evap') - - ALLOCATE ( Snowmelt(Nhru) ) - IF ( declvar(MODNAME, 'snowmelt', 'nhru', Nhru, 'real', & - & 'Snowmelt from snowpack on each HRU (not including snow on glacier)', & - & 'inches', Snowmelt)/=0 ) CALL read_error(3, 'snowmelt') - - IF ( declvar(MODNAME, 'basin_snowmelt', 'one', 1, 'double', & - & 'Basin area-weighted average snowmelt (not on including snow on glacier)', & - & 'inches', Basin_snowmelt)/=0 ) CALL read_error(3, 'basin_snowmelt') - - IF ( declvar(MODNAME, 'basin_pweqv', 'one', 1, 'double', & - & 'Basin area-weighted average snowpack water equivalent not including glacier', & - & 'inches', Basin_pweqv)/=0 ) CALL read_error(3, 'basin_pweqv') - - ALLOCATE ( Pkwater_ante(Nhru) ) - IF ( declvar(MODNAME, 'pkwater_ante', 'nhru', Nhru, 'double', & - & 'Antecedent snowpack water equivalent on each HRU', & - & 'inches', Pkwater_ante)/=0 ) CALL read_error(3, 'pkwater_ante') - - ALLOCATE ( Snowcov_area(Nhru) ) - IF ( declvar(MODNAME, 'snowcov_area', 'nhru', Nhru, 'real', & - & 'Snow-covered area on each HRU prior to melt and sublimation unless snowpack depleted', & - & 'decimal fraction', Snowcov_area)/=0 ) CALL read_error(3, 'snowcov_area') - - IF ( declvar(MODNAME, 'basin_snowevap', 'one', 1, 'double', & - & 'Basin area-weighted average evaporation and sublimation not including glacier', & - & 'inches', Basin_snowevap)/=0 ) CALL read_error(3, 'basin_snowevap') - - IF ( declvar(MODNAME, 'basin_snowcov', 'one', 1, 'double', & - & 'Basin area-weighted average snow-covered area', & - & 'decimal fraction', Basin_snowcov)/=0 ) CALL read_error(3, 'basin_snowcov') - - IF ( declvar(MODNAME, 'basin_glacrb_melt', 'one', 1, 'double', & - & 'Basin area-weighted average basal melt of glacier, goes to soil', & - & 'inches', Basin_glacrb_melt)/=0 ) CALL read_error(3, 'basin_glacrb_melt') - - IF ( declvar(MODNAME, 'basin_glacrevap', 'one', 1, 'double', & - & 'Basin area-weighted average glacier ice evaporation and sublimation', & - & 'inches', Basin_glacrevap)/=0 ) CALL read_error(3, 'basin_glacrevap') - - !rpayn commented - ALLOCATE ( Pptmix_nopack(Nhru) ) - IF ( declvar(MODNAME, 'pptmix_nopack', 'nhru', Nhru, 'integer', & - & 'Flag indicating that a mixed precipitation event has'// & - & ' occurred with no snowpack present on an HRU (1), otherwise (0)', & - & 'none', Pptmix_nopack)/=0 ) CALL read_error(3, 'pptmix_nopack') - - !rpayn commented - ALLOCATE ( Iasw(Nhru) ) - IF ( declvar(MODNAME, 'iasw', 'nhru', Nhru, 'integer', & - & 'Flag indicating that snow covered area is'// & - & ' interpolated between previous location on curve and'// & - & ' maximum (1), or is on the defined curve (0)', & - & 'none', Iasw)/=0 ) CALL read_error(3, 'iasw') - - !rpayn commented - ALLOCATE ( Iso(Nhru) ) - IF ( declvar(MODNAME, 'iso', 'nhru', Nhru, 'integer', & - & 'Flag to indicate if time is before (1) or after (2)'// & - & ' the day to force melt season (melt_force)', & - & 'none', Iso)/=0 ) CALL read_error(3, 'iso') - - !rpayn commented - ALLOCATE ( Mso(Nhru) ) - IF ( declvar(MODNAME, 'mso', 'nhru', Nhru, 'integer', & - & 'Flag to indicate if time is before (1) or after (2)'// & - & ' the first potential day for melt season (melt_look)', & - & 'none', Mso)/=0 ) CALL read_error(3, 'mso') - - !rpayn commented - ALLOCATE ( Lso(Nhru) ) - IF ( declvar(MODNAME, 'lso', 'nhru', Nhru, 'integer', & - & 'Counter for tracking the number of days the snowpack'// & - & ' is at or above 0 degrees Celsius', & - & 'number of iterations', Lso)/=0 ) CALL read_error(3, 'lso') - - !rpayn commented - ALLOCATE ( Lst(Nhru) ) - IF ( declvar(MODNAME, 'lst', 'nhru', Nhru, 'integer', & - & 'Flag indicating whether there was new snow that'// & - & ' was insufficient to reset the albedo curve (1)'// & - & ' (albset_snm or albset_sna), otherwise (0)', & - & 'none', Lst)/=0 ) CALL read_error(3, 'lst') - - !rpayn commented - ALLOCATE ( Pk_def(Nhru) ) - IF ( declvar(MODNAME, 'pk_def', 'nhru', Nhru, 'real', & - & 'Heat deficit, amount of heat necessary to make'// & - & ' the snowpack isothermal at 0 degrees Celsius', & - & 'Langleys', Pk_def)/=0 ) CALL read_error(3, 'pk_def') - - !rpayn commented - ALLOCATE ( Pk_ice(Nhru) ) - IF ( declvar(MODNAME, 'pk_ice', 'nhru', Nhru, 'real', & - & 'Storage of frozen water in the snowpack on each HRU', & - & 'inches', Pk_ice)/=0 ) CALL read_error(3, 'pk_ice') - - !rpayn commented - ALLOCATE ( Freeh2o(Nhru) ) - IF ( declvar(MODNAME, 'freeh2o', 'nhru', Nhru, 'real', & - & 'Storage of free liquid water in the snowpack on each HRU', & - & 'inches', Freeh2o)/=0 ) CALL read_error(3, 'freeh2o') - - !rpayn commented - ALLOCATE ( Pk_depth(Nhru) ) - IF ( declvar(MODNAME, 'pk_depth', 'nhru', Nhru, 'double', & - & 'Depth of snowpack on each HRU', & - & 'inches', Pk_depth)/=0 ) CALL read_error(3, 'pk_depth') - - !rpayn commented - ALLOCATE ( Pss(Nhru) ) - IF ( declvar(MODNAME, 'pss', 'nhru', Nhru, 'double', & - & 'Previous snowpack water equivalent plus new snow', & - & 'inches', Pss)/=0 ) CALL read_error(3, 'pss') - - !rpayn commented - ALLOCATE ( Pst(Nhru) ) - IF ( declvar(MODNAME, 'pst', 'nhru', Nhru, 'double', & - & 'While a snowpack exists, pst tracks the maximum'// & - & ' snow water equivalent of that snowpack', & - & 'inches', Pst)/=0 ) CALL read_error(3, 'pst') - - !rpayn commented - ALLOCATE ( Snsv(Nhru) ) - IF ( declvar(MODNAME, 'snsv', 'nhru', Nhru, 'real', & - & 'Tracks the cumulative amount of new snow until'// & - & ' there is enough to reset the albedo curve (albset_snm or albset_sna)', & - & 'inches', Snsv)/=0 ) CALL read_error(3, 'snsv') - - ALLOCATE ( Ai(Nhru) ) - IF ( declvar(MODNAME, 'ai', 'nhru', Nhru, 'double', & - & 'Maximum snowpack for each HRU', & - & 'inches', Ai)/=0 ) CALL read_error(3, 'ai') - - ALLOCATE ( Frac_swe(Nhru) ) - IF ( declvar(MODNAME, 'frac_swe', 'nhru', Nhru, 'real', & - & 'Fraction of maximum snow-water equivalent (snarea_thresh) on each HRU', & - & 'decimal fraction', Frac_swe)/=0 ) CALL read_error(3, 'frac_swe') - -! declare parameters - IF ( Glacier_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Albedo_coef(Nhru) ) - IF ( declparam(MODNAME, 'albedo_coef', 'nhru', 'real', & - & '0.137', '0.1', '0.3', & - & 'Coefficient in calculation of ice albedo', & - & 'Coefficient in calculation of ice albedo', & - & 'none')/=0 ) CALL read_error(1, 'albedo_coef') - - ALLOCATE ( Albedo_ice(Nhru) ) - IF ( declparam(MODNAME, 'albedo_ice', 'nhru', 'real', & - & '0.344', '0.2', '0.6', & - & 'Ice albedo 300 meters below ELA', & - & 'Ice albedo 300 meters below ELA', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo_ice') - ENDIF - - IF ( declparam(MODNAME, 'den_init', 'one', 'real', & - & '0.10', '0.01', '0.5', & - & 'Initial density of new-fallen snow', & - & 'Initial density of new-fallen snow', & - & 'gm/cm3')/=0 ) CALL read_error(1, 'den_init') - - IF ( declparam(MODNAME, 'settle_const', 'one', 'real', & - & '0.10', '0.01', '0.5', & - & 'Snowpack settlement time constant', & - & 'Snowpack settlement time constant', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'settle_const') - - IF ( declparam(MODNAME, 'den_max', 'one', 'real', & - & '0.6', '0.1', '0.8', & - & 'Average maximum snowpack density', & - & 'Average maximum snowpack density', & - & 'gm/cm3')/=0 ) CALL read_error(1, 'den_max') - - ALLOCATE ( Melt_look(Nhru) ) - IF ( declparam(MODNAME, 'melt_look', 'nhru', 'integer', & - & '90', '1', '366', & - & 'Julian date to start looking for spring snowmelt for each HRU', & - & 'Julian date to start looking for spring snowmelt stage for each HRU;'// & - & ' varies with region depending on length of time that'// & - & ' permanent snowpack exists', & - & 'Julian day')/=0 ) CALL read_error(1, 'melt_look') - - ALLOCATE ( Melt_force(Nhru) ) - IF ( declparam(MODNAME, 'melt_force', 'nhru', 'integer', & - & '140', '1', '366', & - & 'Julian date to force snowpack to spring snowmelt stage for each HRU', & - & 'Julian date to force snowpack to spring snowmelt stage for each HRU;'// & - & ' varies with region depending on length of time that'// & - & ' permanent snowpack exists', & - & 'Julian day')/=0 ) CALL read_error(1, 'melt_force') - - ALLOCATE ( Rad_trncf(Nhru) ) - IF ( declparam(MODNAME, 'rad_trncf', 'nhru', 'real', & - & '0.5', '0.0', '1.0', & - & 'Solar radiation transmission coefficient', & - & 'Transmission coefficient for short-wave radiation through'// & - & ' the winter vegetation canopy', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'rad_trncf') - - ALLOCATE ( Hru_deplcrv(Nhru) ) - IF ( declparam(MODNAME, 'hru_deplcrv', 'nhru', 'integer', & - & '1', 'bounded', 'ndepl', & - & 'Index number for snowpack areal depletion curve', & - & 'Index number for the snowpack areal depletion curve associated with each HRU', & - & 'none')/=0 ) CALL read_error(1, 'hru_deplcrv') - - ALLOCATE ( Snarea_curve(11, Ndepl) ) - IF ( declparam(MODNAME, 'snarea_curve', 'ndeplval', 'real', & - & '1.0', '0.0', '1.0', & - & 'Snow area depletion curve values', & - & 'Snow area depletion curve values, 11 values for each'// & - & ' curve (0.0 to 1.0 in 0.1 increments)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'snarea_curve') - - ALLOCATE ( Snarea_thresh(Nhru) ) - IF ( declparam(MODNAME, 'snarea_thresh', 'nhru', 'real', & - & '50.0', '0.0', '200.0', & - & 'Maximum threshold water equivalent for snow depletion', & - & 'Maximum threshold snowpack water equivalent below'// & - & ' which the snow-covered-area curve is applied', & - & 'inches')/=0 ) CALL read_error(1, 'snarea_thresh') - - IF ( declparam(MODNAME, 'albset_rnm', 'one', 'real', & - & '0.6', '0.4', '1.0', & - & 'Albedo reset - rain, melt stage', & - & 'Fraction of rain in a mixed precipitation event'// & - & ' above which the snow albedo is not reset; applied during'// & - & ' the snowpack melt stage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'albset_rnm') - - IF ( declparam(MODNAME, 'albset_rna', 'one', 'real', & - & '0.8', '0.5', '1.0', & - & 'Albedo reset - rain, accumulation stage', & - & 'Fraction of rain in a mixed precipitation event'// & - & ' above which the snow albedo is not reset; applied during'// & - & ' the snowpack accumulation stage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'albset_rna') - - IF ( declparam(MODNAME, 'albset_snm', 'one', 'real', & - & '0.2', '0.1', '1.0', & - & 'Albedo reset - snow, melt stage', & - & 'Minimum snowfall, in water equivalent, needed to reset'// & - & ' snow albedo during the snowpack melt stage', & - & 'inches')/=0 ) CALL read_error(1, 'albset_snm') - - IF ( declparam(MODNAME, 'albset_sna', 'one', 'real', & - & '0.05', '0.01', '1.0', & - & 'Albedo reset - snow, accumulation stage', & - & 'Minimum snowfall, in water equivalent, needed to reset'// & - & ' snow albedo during the snowpack accumulation stage', & - & 'inches')/=0 ) CALL read_error(1, 'albset_sna') - - ALLOCATE ( Emis_noppt(Nhru) ) - IF ( declparam(MODNAME, 'emis_noppt', 'nhru', 'real', & - & '0.757', '0.757', '1.0', & - & 'Emissivity of air on days without precipitation for each HRU', & - & 'Average emissivity of air on days without precipitation for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'emis_noppt') - - ALLOCATE ( Cecn_coef(Nhru,12) ) - IF ( declparam(MODNAME, 'cecn_coef', 'nhru,nmonths', 'real', & - & '5.0', '0.02', '20.0', & - & 'Monthly convection condensation energy coefficient for each HRU', & - & 'Monthly (January to December) convection condensation energy coefficient for each HRU', & - & 'calories per degree Celsius above 0')/=0 ) CALL read_error(1, 'cecn_coef') - - ALLOCATE ( Freeh2o_cap(Nhru) ) - IF ( declparam(MODNAME, 'freeh2o_cap', 'nhru', 'real', & - & '0.05', '0.01', '0.2', & - & 'Free-water holding capacity of snowpack for each HRU', & - & 'Free-water holding capacity of snowpack for each HRU, expressed as a'// & - & ' decimal fraction of the frozen water content of the snowpack (pk_ice)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'freeh2o_cap') - - ALLOCATE ( Tstorm_mo(Nhru,12) ) - IF ( declparam(MODNAME, 'tstorm_mo', 'nhru,nmonths', 'integer', & - & '0', '0', '1', & - & 'Set to 1 if thunderstorms prevalent during month for each HRU', & - & 'Monthly flag (January to December) for prevalent storm'// & - & ' type for each HRU (0=frontal storms; 1=convective storms)', & - & 'none')/=0 ) CALL read_error(1, 'tstorm_mo') - - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==3 ) THEN - ALLOCATE ( Snowpack_init(Nhru) ) - IF ( declparam(MODNAME, 'snowpack_init', 'nhru', 'real', & - & '0.0', '0.0', '5000.0', & - & 'Initial snowpack water equivalent in each HRU', & - & 'Storage of snowpack in each HRU at the beginning of a simulation', & - & 'inches')/=0 ) CALL read_error(1, 'snowpack_init') - ENDIF - - END FUNCTION snodecl - -!*********************************************************************** -! snoinit - Initialize snowcomp module - get parameter values, -! compute initial values -!*********************************************************************** - INTEGER FUNCTION snoinit() - USE PRMS_SNOW - USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag, Frozen_flag - USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_route_order, Active_hrus, Hru_area_dble, & - & FEET2METERS, Elev_units, Hru_type -! USE PRMS_BASIN, ONLY: Hru_elev_feet - USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Glrette_frac, Alt_above_ela - IMPLICIT NONE -! Functions - INTRINSIC :: DBLE, ATAN, SNGL - INTEGER, EXTERNAL :: getparam - EXTERNAL :: read_error, snowcomp_restart, sca_deplcrv, glacr_states_to_zero -! Local Variables - INTEGER :: i, j -! Save Variables - REAL, SAVE :: acum_init(MAXALB), amlt_init(MAXALB) - DATA acum_init/.80, .77, .75, .72, .70, .69, .68, .67, .66, .65, .64, .63, .62, .61, .60/ - DATA amlt_init/.72, .65, .60, .58, .56, .54, .52, .50, .48, .46, .44, .43, .42, .41, .40/ -!*********************************************************************** - snoinit = 0 - - IF ( Init_vars_from_file>0 ) CALL snowcomp_restart(1) - - IF ( Glacier_flag==1 ) THEN - IF ( getparam(MODNAME, 'glacr_freeh2o_cap', Nhru, 'real', Glacr_freeh2o_cap)/=0 ) CALL read_error(2, 'glacr_freeh2o_cap') - IF ( getparam(MODNAME, 'albedo_ice', Nhru, 'real', Albedo_ice)/=0 ) CALL read_error(2, 'albedo_ice') - IF ( getparam(MODNAME, 'albedo_coef', Nhru, 'real', Albedo_coef)/=0 ) CALL read_error(2, 'albedo_coef') - IF ( getparam(MODNAME, 'glacr_layer', Nhru, 'real', Glacr_layer)/=0 ) CALL read_error(2, 'glacr_layer') - - ENDIF - - IF ( getparam(MODNAME, 'den_init', 1, 'real', Den_init)/=0 ) CALL read_error(2, 'den_init') - Deninv = 1.0D0/DBLE(Den_init) - IF ( getparam(MODNAME, 'den_max', 1, 'real', Den_max)/=0 ) CALL read_error(2, 'den_max') - Denmaxinv = 1.0D0/DBLE(Den_max) - - IF ( getparam(MODNAME, 'settle_const', 1, 'real', Settle_const)/=0 ) CALL read_error(2, 'settle_const') - Settle_const_dble = DBLE( Settle_const ) -! Set1 = 1.0/(1.0+Settle_const) -! Setden = Settle_const/Den_max - - IF ( getparam(MODNAME, 'melt_look', Nhru, 'integer', Melt_look)/=0 ) CALL read_error(2, 'melt_look') - IF ( getparam(MODNAME, 'melt_force', Nhru, 'integer', Melt_force)/=0 ) CALL read_error(2, 'melt_force') - IF ( getparam(MODNAME, 'rad_trncf', Nhru, 'real', Rad_trncf)/=0 ) CALL read_error(2, 'rad_trncf') - IF ( getparam(MODNAME, 'hru_deplcrv', Nhru, 'integer', Hru_deplcrv)/=0 ) CALL read_error(2, 'hru_deplcrv') - IF ( getparam(MODNAME, 'snarea_curve', Ndepl*11, 'real', Snarea_curve)/=0 ) CALL read_error(2, 'snarea_curve') - IF ( getparam(MODNAME, 'snarea_thresh', Nhru, 'real', Snarea_thresh)/=0 ) CALL read_error(2, 'snarea_thresh') - IF ( getparam(MODNAME, 'albset_rnm', 1, 'real', Albset_rnm)/=0 ) CALL read_error(2, 'albset_rnm') - IF ( getparam(MODNAME, 'albset_rna', 1, 'real', Albset_rna)/=0 ) CALL read_error(2, 'albset_rna') - IF ( getparam(MODNAME, 'albset_sna', 1, 'real', Albset_sna)/=0 ) CALL read_error(2, 'albset_sna') - IF ( getparam(MODNAME, 'albset_snm', 1, 'real', Albset_snm)/=0 ) CALL read_error(2, 'albset_snm') - IF ( getparam(MODNAME, 'emis_noppt', Nhru, 'real', Emis_noppt)/=0 ) CALL read_error(2, 'emis_noppt') - IF ( getparam(MODNAME, 'cecn_coef', Nhru*12, 'real', Cecn_coef)/=0 ) CALL read_error(2, 'cecn_coef') - IF ( getparam(MODNAME, 'freeh2o_cap', Nhru, 'real', Freeh2o_cap)/=0 ) CALL read_error(2, 'freeh2o_cap') - IF ( getparam(MODNAME, 'tstorm_mo', Nhru*12, 'integer', Tstorm_mo)/=0 ) CALL read_error(2, 'tstorm_mo') - - Pk_precip = 0.0 - Snowmelt = 0.0 - Snow_evap = 0.0 - Pptmix_nopack = 0 - Tcal = 0.0 - Frac_swe = 0.0 - Acum = acum_init - Amlt = amlt_init - IF (Frozen_flag==1) THEN - Tcal_nosnow = 0.0 - Land_albedo = 0.0 - ENDIF - - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==3 ) THEN - IF ( getparam(MODNAME, 'snowpack_init', Nhru, 'real', Snowpack_init)/=0 ) CALL read_error(2, 'snowpack_init') - Pkwater_equiv = 0.0D0 - Pk_depth = 0.0D0 - Pk_den = 0.0 - Pk_ice = 0.0 - Freeh2o = 0.0 - Ai = 0.0D0 - Snowcov_area = 0.0 - Basin_pweqv = 0.0D0 - Basin_snowdepth = 0.0D0 - Basin_snowcov = 0.0D0 - Basin_snowicecov = 0.0D0 - DO j = 1, Active_hrus - i = Hru_route_order(j) - Pkwater_equiv(i) = DBLE( Snowpack_init(i) ) - IF ( Pkwater_equiv(i)>0.0D0 ) THEN - Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*Hru_area_dble(i) - Pk_depth(i) = Pkwater_equiv(i)*Deninv - Pk_den(i) = SNGL( Pkwater_equiv(i)/Pk_depth(i) ) - Pk_ice(i) = SNGL( Pkwater_equiv(i) ) - Freeh2o(i) = Pk_ice(i)*Freeh2o_cap(i) - Ai(i) = Pkwater_equiv(i) ! [inches] - IF ( Ai(i)>Snarea_thresh(i) ) Ai(i) = DBLE( Snarea_thresh(i) ) ! [inches] - Frac_swe(i) = SNGL( Pkwater_equiv(i)/Ai(i) ) ! [fraction] - CALL sca_deplcrv(Snowcov_area(i), Snarea_curve(1,Hru_deplcrv(i)), Frac_swe(i)) - Basin_snowcov = Basin_snowcov + DBLE(Snowcov_area(i))*Hru_area_dble(i) - Basin_snowdepth = Basin_snowdepth + Pk_depth(i)*Hru_area_dble(i) - ENDIF - ENDDO - Basin_pweqv = Basin_pweqv*Basin_area_inv - Basin_snowcov = Basin_snowcov*Basin_area_inv - Basin_snowdepth = Basin_snowdepth*Basin_area_inv - DEALLOCATE ( Snowpack_init ) - Pkwater_ante = Pkwater_equiv - Pss = Pkwater_equiv - Pst = Pkwater_equiv - - IF ( Glacier_flag==1 ) THEN ! do here when not a restart simulation - IF ( getparam(MODNAME, 'glacier_frac_init', Nhru, 'real', Glacier_frac_init)/=0 ) CALL read_error(2, 'glacier_frac_init') - Glacr_albedo = 0.0 - Glacier_frac = Glacier_frac_init - IF ( getparam(MODNAME, 'glrette_frac_init', Nhru, 'real', Glrette_frac_init)/=0 ) CALL read_error(2, 'glrette_frac_init') - Glrette_frac = Glrette_frac_init - DO j = 1, Active_hrus - i = Hru_route_order(j) - IF ( Glacier_frac(i)>0.0 ) THEN - IF ( Hru_type(i)==4 ) THEN - IF ( Elev_units==0 ) THEN !from Oerlemans 1992 - Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)*FEET2METERS+300.0)/200.0 ) - ELSE - Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) - ENDIF - ELSE - PRINT *, 'Warning, glacier_frac > 0, but hru_type not equal to 4, glacier_frac set to 0' - PRINT *, 'in HRU ', i, 'glacier_frac_init = ',Glacier_frac_init(i) - Glacier_frac(i) = 0.0 - ENDIF - ENDIF - IF ( Glrette_frac(i)>0.0 ) THEN - IF ( Hru_type(i)==1 ) THEN - Glacr_albedo(i) = Albedo_ice(i) - ELSE - PRINT *, 'Warning, glrette_frac > 0, but hru_type not equal to 1, glrette_frac set to 0' - PRINT *, 'in HRU ', i, 'glrette_frac_init = ',Glrette_frac_init(i) - Glrette_frac(i) = 0.0 - ENDIF - ENDIF - ENDDO - DEALLOCATE ( Glacier_frac_init ) - ENDIF - ENDIF - - IF ( Init_vars_from_file>0 ) RETURN - Basin_tcal = 0.0D0 - Iasw = 0 - Iso = 1 - Mso = 1 - Lso = 0 - Pk_def = 0.0 - Pk_temp = 0.0 - Albedo = 0.0 - Snsv = 0.0 - Lst = 0 - Int_alb = 1 - Salb = 0.0 - Slst = 0.0 - Snowcov_areasv = 0.0 - Scrv = 0.0D0 - Pksv = 0.0D0 - Basin_snowmelt = 0.0D0 - Basin_snowevap = 0.0D0 - Basin_pk_precip = 0.0D0 - - Yrdays5 = 0 - Basin_glacrb_melt = 0.0D0 - Basin_glacrevap = 0.0D0 - IF ( Glacier_flag==1 .OR. Frozen_flag==1) THEN - Ann_tempc = 0.0 - Prev_ann_tempc = 0.0 - ENDIF - IF ( Glacier_flag==1 ) THEN - Alt_above_ela = 0.0 - Glacr_air_5avtemp = 0.0 - Glacr_air_5avtemp1 = 0.0 - Glacr_air_deltemp = 0.0 - Glacr_5avsnow = 0.0 - Glacr_5avsnow1 = 0.0 - Glacr_delsnow = 0.0 - Glacrb_melt = 0.0 - Glacrmelt = 0.0 - Glacr_pk_den = 0.0 - Glacr_pk_temp = 0.0 - Glacr_pk_ice = 0.0 - Glacr_pk_def = 0.0 - Glacr_pkwater_equiv = 0.0D0 - Glacr_pkwater_ante = 0.0D0 - Glacr_evap = 0.0 - Glacr_freeh2o = 0.0 - Glacr_pk_depth = 0.0D0 - Glacr_pst = 0.0D0 - Glacr_pss = 0.0D0 - Glacrcov_area = 0.0 - Glacr_freeh2o_capm = Glacr_freeh2o_cap - DO j = 1, Active_hrus - i = Hru_route_order(j) - IF ( Glacier_frac(i)>0.0 .AND. Hru_type(i)==4 ) CALL glacr_states_to_zero(i,1) - ENDDO - ENDIF - - END FUNCTION snoinit - -!*********************************************************************** -! snorun - daily mode snow estimates -!*********************************************************************** - INTEGER FUNCTION snorun() - USE PRMS_SNOW - USE PRMS_MODULE, ONLY: Nhru, Print_debug, Glacier_flag, Starttime, Frozen_flag - USE PRMS_BASIN, ONLY: DNEARZERO, Hru_area, Active_hrus, Hru_type, & - & Basin_area_inv, Hru_route_order, Cov_type, INCH2M, FEET2METERS, Elev_units - USE PRMS_CLIMATEVARS, ONLY: Newsnow, Pptmix, Orad, Basin_horad, Potet_sublim, & - & Hru_ppt, Prmx, Tmaxc, Tminc, Tavgc, Swrad, Potet, Transp_on, Tmax_allsnow_c - USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Glrette_frac, Alt_above_ela - USE PRMS_SET_TIME, ONLY: Jday, Nowmonth, Julwater, Nowyear - USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Canopy_covden, Hru_intcpevap - IMPLICIT NONE -! Functions - EXTERNAL ppt_to_pack, snowcov, snalbedo, snowbal, snowevap, glacr_states_to_zero - INTRINSIC ABS, SQRT, DBLE, SNGL, EXP, DABS, MOD, ATAN -! Local Variables - INTEGER :: i, j, k, niteda, isglacier, ijunk - REAL :: trd, sw, effk, cst, temp, cals, emis, esv, swn, cec - REAL :: ieffk, icst, icals, isw, iswn, frac, lswn, lsw, rjunk - DOUBLE PRECISION :: dpt1, dpt_before_settle, djunk -!*********************************************************************** - snorun = 0 - - ! Set the basin totals to 0 - ! (recalculated at the end of the time step) - Basin_snowmelt = 0.0D0 - Basin_pweqv = 0.0D0 - Basin_snowevap = 0.0D0 - Basin_snowcov = 0.0D0 - Basin_snowicecov = 0.0D0 - Basin_pk_precip = 0.0D0 - Basin_snowdepth = 0.0D0 - Basin_tcal = 0.0D0 - IF ( Glacier_flag==1 ) THEN - Basin_glacrb_melt = 0.0D0 - Basin_glacrevap = 0.0D0 - ENDIF - - ! Calculate the ratio of measured radiation to potential radiation - ! (used as a cumulative indicator of cloud cover) - trd = Orad/SNGL(Basin_horad) ! [dimensionless ratio] - IF ( Julwater==1 .AND. MOD(Nowyear-Starttime(1),5)==0 ) Yrdays5 = 0 - - ! Loop through all the active HRUs, in routing order - DO j = 1, Active_hrus - i = Hru_route_order(j) ! [counter] - - ! Skip the HRU if it is a lake - IF ( Hru_type(i)==2 ) CYCLE !AVB 7/18/19 we want to do frozen ground under lakes? - - Active_glacier = 0 - Active_frozen = 0 - isglacier = 0 - IF (Frozen_flag==1) Active_frozen = 1 - IF ( Hru_type(i)==4 .OR. Hru_type(i)==1 ) THEN - IF ( Glacier_flag==1 ) THEN - Glacrmelt(i) = 0.0 ! [inches] - Glacrb_melt(i) = 0.0 ! [inches] - Glacr_evap(i) = 0.0 ! [inches] - Glacr_pkwater_ante(i) = Glacr_pkwater_equiv(i) - IF ( Glacier_frac(i)==1.0 .OR. Glrette_frac(i)==1.0 ) Active_frozen = 0 !no need to separately calculate energy if glacier - IF ( Glacier_frac(i)>0.0 .OR. Glrette_frac(i)>0.0 ) THEN - IF (Glacier_frac(i)>0.0) Active_glacier = 1 - IF (Glrette_frac(i)>0.0) Active_glacier = 2 - Glacr_pk_den(i) = 0.917 - ! if no active layer make 0 deg and no holding capacity at start of each day - IF ( Glacr_layer(i)==0.0 .OR. Glacr_pk_depth(i)>1.0D3 ) THEN - Glacr_pk_def(i) = 0.0 - Glacr_pk_temp(i) = 0.0 - Glacr_freeh2o_capm(i) = 0.0 - ENDIF - ELSE !zero out states for glacier if gone (glacier state changes in glacier module, not here) - Glacr_pkwater_equiv(i) = 0.D0 - Glacrcov_area(i) = 0.0 - Glacr_pk_def(i) = 0.0 - Glacr_pk_temp(i) = 0.0 - Glacr_pk_ice(i) = 0.0 - Glacr_freeh2o(i) = 0.0 - Glacr_pk_depth(i) = 0.D0 - Glacr_pss = 0.0D0 - Glacr_pst(i) = 0.0D0 - Glacr_pk_den(i) = 0.0 - Glacr_freeh2o_capm(i) = 0.0 - Glacr_albedo(i) = 0.0 - ENDIF - isglacier = 1 - ENDIF - ENDIF - - ! If it's the first julian day of the water year, several - ! variables need to be reset - ! - reset the previous snow water eqivalent plus new snow to 0 - ! - reset flags to indicate it is not melt season or potetential melt season - ! - reset the counter for the number of days a snowpack is at 0 deg Celsius - !rsr, do we want to reset all HRUs, what about Southern Hemisphere - IF ( Julwater==1 ) THEN - Pss(i) = 0.0D0 ! [inches] - Iso(i) = 1 ! [flag] - Mso(i) = 1 ! [flag] - Lso(i) = 0 ! [counter] - - - IF ( Active_glacier>=1 ) CALL glacr_states_to_zero(i,1) !all snow on glacier becomes firn, reset active layer thickness - IF ( Active_glacier==1 ) THEN -! If Active_glacier>=1 we are zeroing out snowpack if have glacierettes even though possibly a lot of HRU is not glacierized. -! If Active_glacier==1 do not zero out glacierettes, but then will maybe never melt ice on glacierettes. If the climate is -! correct the snowpack will deplete quick because there is a lot of lower elevation than the glacierette included in the HRU. -! Choice does not effect runoff much, but will effect Basin_pweqv and things like that - ! if terminus glacier, and has snow will disappear off glacier but that is likely anyhow - Pkwater_equiv(i) = 0.0 - Pk_depth(i) = 0.0D0 - Pss(i) = 0.0D0 - Snsv(i) = 0.0 - Lst(i) = 0 - Pst(i) = 0.0D0 - Iasw(i) = 0 - Pk_den(i) = 0.0 - Snowcov_area(i) = 0.0 - Pk_def(i) = 0.0 - Pk_temp(i) = 0.0 - Pk_ice(i) = 0.0 - Freeh2o(i) = 0.0 - Snowcov_areasv(i) = 0.0 ! rsr, not in original code - Ai(i) = 0.0D0 - Frac_swe(i) = 0.0 - IF ( Elev_units==0 ) THEN !from Oerlemans 1992 - Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)*FEET2METERS+300.0)/200.0 ) - ELSE - Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) - ENDIF - ENDIF - IF ( Active_glacier==2 ) Glacr_albedo(i) = Albedo_ice(i) !glacr_albedo doesn't change if glacierette but could get zeroed out - IF ( isglacier==1 ) THEN - IF (Nowyear >= Starttime(1)+10 .AND. MOD(Nowyear-Starttime(1),5)==0 ) THEN - Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 5 years of data - Glacr_delsnow(i) = 10.0*(Glacr_5avsnow1(i) - Glacr_5avsnow(i))/Glacr_5avsnow1(i) !number of 10 percent (*100.0/10.0) changes - ENDIF - !keep before restart - IF ( MOD(Nowyear-Starttime(1),5)==0 ) THEN - IF ( Nowyear-Starttime(1)==5 ) THEN - Glacr_air_5avtemp1(i) = Glacr_air_5avtemp(i) - Glacr_5avsnow1(i) = Glacr_5avsnow(i) - ENDIF - Glacr_air_5avtemp(i) = 0.0 !zero out for new year restart - Glacr_5avsnow(i) = 0.0 !zero out for new year restart - ENDIF - ENDIF - Prev_ann_tempc(i) = Ann_tempc(i) - Ann_tempc(i) = 0.0 !zero out for new year restart - ENDIF !end start of year calculations - -! Do for summer - IF ( isglacier==1 ) THEN - IF (Julwater>151 .AND. Julwater<244) THEN ! Now following McGrath et al 2017, temp June-August, 92 days - Yrdays5 = Yrdays5 + 1 - Glacr_air_5avtemp(i) = ( Glacr_air_5avtemp(i)*(Yrdays5-1)+ Tavgc(i) )/Yrdays5 - ENDIF -! Do for every time step - Glacr_5avsnow(i) = Glacr_5avsnow(i) + Net_snow(i)/5.0 - ENDIF - Ann_tempc(i) = ( Ann_tempc(i)*(Julwater-1)+ Tavgc(i) )/Julwater - - ! HRU SET-UP - SET DEFAULT VALUES AND/OR BASE - ! CONDITIONS FOR THIS TIME PERIOD - !************************************************************** - - ! Keep track of the pack water equivalent before it is changed - ! by precipitation during this time step - Pkwater_ante(i) = Pkwater_equiv(i) - - ! By default, the precipitation added to snowpack, snowmelt, - ! and snow evaporation are 0 - Pk_precip(i) = 0.0 ! [inches] - Snowmelt(i) = 0.0 ! [inches] - Snow_evap(i) = 0.0 ! [inches] - Frac_swe(i) = 0.0 - Ai(i) = 0.0D0 - Tcal(i) = 0.0 - IF (Frozen_flag==1) Tcal_nosnow(i) = 0.0 - - ! By default, there has not been a mixed event without a - ! snowpack - Pptmix_nopack(i) = 0 ! [flag] - - ! If the day of the water year is beyond the forced melt day - ! indicated by the parameter, then set the flag indicating - ! melt season - !rsr, need to rethink this at some point -!rsr10 IF ( Iso(i)/=2 ) THEN - IF ( Jday==Melt_force(i) ) Iso(i) = 2 ! [flag] -!rsr10 ENDIF - - ! If the day of the water year is beyond the first day to - ! look for melt season indicated by the parameter, - ! then set the flag indicating to watch for melt season - !rsr, need to rethink this at some point -!rsr10 IF ( Mso(i)/=2 ) THEN - IF ( Jday==Melt_look(i) ) Mso(i) = 2 ! [flag] -!rsr10 ENDIF - - ! Skip the HRU if there is no snowpack and no new snow and not a glacier and no frozen ground - IF ( Pkwater_equiv(i)0.0D0.AND.Net_ppt(i)>0.0) .OR. Net_snow(i)>0.0 ) & - & CALL ppt_to_pack(Pptmix(i), Iasw(i), Tmaxc(i), Tminc(i), & - & Tavgc(i), Pkwater_equiv(i), Net_rain(i), Pk_def(i), & - & Pk_temp(i), Pk_ice(i), Freeh2o(i), Snowcov_area(i), & - & Snowmelt(i), Pk_depth(i), Pss(i), Pst(i), Net_snow(i), & - & Pk_den(i), Pptmix_nopack(i), Pk_precip(i), Tmax_allsnow_c(i,Nowmonth), Freeh2o_cap(i), -1) - IF ( Active_glacier>=1 ) THEN - IF ( Glacrcov_area(i)>0.0.AND.Glacr_pkwater_ante(i)>0.0D0.AND.Net_ppt(i)>0.0 & - & .AND.Pptmix(i)==0.AND.Net_snow(i)==0.0 ) THEN - CALL ppt_to_pack(0, Iasw(i), Tmaxc(i), Tminc(i), & - & Tavgc(i), Glacr_Pkwater_equiv(i), Net_rain(i), Glacr_pk_def(i), & - & Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), Glacrcov_area(i), & - & Glacrmelt(i), Glacr_pk_depth(i), Glacr_pss(i), Glacr_pst(i), 0.0, & - & Glacr_pk_den(i), Pptmix_nopack(i), Pk_precip(i), Tmax_allsnow_c(i,Nowmonth), Glacr_freeh2o_capm(i), i) - ENDIF - ENDIF - -! FOLLOWING does basal melt on glacier -!Paterson 2010 says 12 mm/yr for friction and geothermal heating - IF ( Active_glacier==1 ) Glacrb_melt(i) = 12.0*0.03937/365.242*Glacier_frac(i) - IF ( Active_glacier==2 ) Glacrb_melt(i) = 12.0*0.03937/365.242*Glrette_frac(i) !since not moving much, maybe =0 - - ! If there is still a snowpack - IF ( Pkwater_equiv(i)>0.0D0 ) THEN - - ! HRU STEP 2 - CALCULATE THE NEW SNOW COVERED AREA - !********************************************************** - ! Compute snow-covered area from depletion curve - k = Hru_deplcrv(i) - ! calculate the new snow covered area - CALL snowcov(Iasw(i), Newsnow(i), Snowcov_area(i), & - & Snarea_curve(1, k), Pkwater_equiv(i), Pst(i), & - & Snarea_thresh(i), Net_snow(i), Scrv(i), & - & Pksv(i), Snowcov_areasv(i), Ai(i), Frac_swe(i)) - - ! HRU STEP 3 - COMPUTE THE NEW ALBEDO - !********************************************************** - - ! Compute albedo if there is any snowpack - CALL snalbedo(Newsnow(i), Iso(i), Lst(i), Snsv(i), & - & Prmx(i), Pptmix(i), Albset_rnm, Net_snow(i), & - & Albset_snm, Albset_rna, Albset_sna, Albedo(i), & - & Int_alb(i), Salb(i), Slst(i)) - ENDIF - IF ( Active_glacier==1 ) Glacrcov_area(i) =(1.0-Snowcov_area(i))*Glacier_frac(i) - IF ( Active_glacier==2 ) Glacrcov_area(i) =(1.0-Snowcov_area(i))*Glrette_frac(i) - IF ( Snowcov_area(i)==1.0 .OR. Glacrcov_area(i)==1.0) Active_frozen=0 !no need to separately calculate energy if snow or glacier - - IF ( Active_glacier>=1 ) THEN -! Albedo so transition snow to ice smooothly, see Oerlemans 1992, this is albedo if snowcovered ice too - Albedo(i) = Albedo(i) - (Albedo(i)-Glacr_albedo(i))*EXP(-5.0*SNGL(Pkwater_equiv(i))*INCH2M) - IF ( Albedo(i)<0.08 ) Albedo(i)=0.08 !See Brock 2000 - IF ( Albedo(i)>0.92 ) Albedo(i)=0.92 !See Brock 2000 - ENDIF - - IF ( Active_frozen==1 ) THEN -! Use land albedo based on geographic areas there is frozen ground, from Euskirchen et al 2016 -! Assumes canopy is assumed to be a perfect blackbody so only want albedo of land under canopy - If (Cov_type(i)==0) Land_albedo(i) = 0.12 !bare soil (rock, may be mostly impervious already) - If (Cov_type(i)>=1) Land_albedo(i) = 0.25 !grasses (boreal grass, tundra) possibly under trees - ENDIF - - ! If there is still a snowpack or glacier - IF ( Pkwater_equiv(i)>0.0D0 .OR. Active_glacier>=1 .OR. Active_frozen==1) THEN - - ! HRU STEP 4 - DETERMINE RADIATION FLUXES AND SNOWPACK - ! STATES NECESSARY FOR ENERGY BALANCE - !********************************************************** - - ! Set the emissivity of the air to the emissivity when there - ! is no precipitation - emis = Emis_noppt(i) ! [fraction of radiation] - ! Could use equation from Swinbank 63 using Temp, a is -13.638, b is 6.148 - !emis = ((temp+273.15)**(Emis_coefb-4.0))*(10.0**(Emis_coefa+1.0))/5.670373E−8 ! /by Stefan Boltzmann in SI units - ! If there is any precipitation in the HRU, reset the - ! emissivity to 1 - IF ( Hru_ppt(i)>0.0 ) emis = 1.0 ! [fraction of radiation] - ! Save the current value of emissivity - esv = emis ! [fraction of radiation] - ! Set the convection-condensation for a half-day interval - cec = Cecn_coef(i, Nowmonth)*0.5 ! [cal/(cm^2 degC)] - ! or [Langleys / degC] - ! If the land cover is trees, reduce the convection- - ! condensation parameter by half - IF ( Cov_type(i)>2 ) cec = cec*0.5 ! [cal/(cm^2 degC)] RSR: cov_type=4 is valid for trees (coniferous) - ! or [Langleys / degC] - ! Check whether to force spring melt - ! Spring melt is forced if time is before the melt-force - ! day and after the melt-look day (parameters) - ! If between these dates, the spring melt applies if the - ! snowpack temperature is above or equal to 0 - ! for more than 4 cycles of the snorun function - - ! If before the first melt-force day - IF ( Iso(i)==1 ) THEN - ! If after the first melt-look day - IF ( Mso(i)==2 ) THEN - - ! Melt season is determined by the number of days the - ! snowpack is above 0 degrees C. The first time that - ! the snowpack is isothermal at 0 degrees C for more - ! than 4 days is the beginning of snowmelt season. - ! 2 options below (if-then, else) - - ! (1) The snowpack temperature is 0 degrees - IF ( Pk_temp(i)>=0.0 ) THEN - ! Increment the number of days that the snowpack - ! has been isothermal at 0 degrees C - Lso(i) = Lso(i) + 1 ! [days] - ! If the snowpack temperature has been 0 or greater - ! for more than 4 cycles - IF ( Lso(i)>4 ) THEN - ! Set the melt-force flag and reset counter - Iso(i) = 2 ! [flag] - Lso(i) = 0 ! [days] - ENDIF - - ! (2) The snowpack temperature is less than 0 degrees - ELSE - ! Reset the counter for days snowpack temperature is above 0 - Lso(i) = 0 ! [days] - ENDIF - ENDIF - ENDIF - - ! Compute energy balance for night period - ! niteda is a flag indicating nighttime (1) or daytime (2) - ! set the flag indicating night time - niteda = 1 ! [flag] - ! temparature is halfway between the minimum and average temperature - ! for the day - temp = (Tminc(i)+Tavgc(i))*0.5 - - IF ( Pkwater_equiv(i)>0.0D0 ) THEN - ! The incoming shortwave radiation is the HRU radiation - ! adjusted by the albedo (some is reflected back into the - ! atmoshphere) and the transmission coefficient (some is - ! intercepted by the winter vegetative canopy) - swn = Swrad(i)*(1.0-Albedo(i))*Rad_trncf(i) ! [cal/cm^2] - ! or [Langleys] - ! Calculate the new snow depth (Riley et al. 1973) - ! RSR: the following 3 lines of code were developed by Rob Payn, 7/10/2013 - ! The snow depth depends on the previous snow pack water - ! equivalent plus the new net snow - Pss(i) = Pss(i) + DBLE( Net_snow(i) ) ! [inches] - dpt_before_settle = Pk_depth(i) + DBLE(Net_snow(i))*Deninv - dpt1 = dpt_before_settle + Settle_const_dble * ((Pss(i)*Denmaxinv) - dpt_before_settle) - ! dpt1 = Pk_depth(i) + (Net_snow(i)*Deninv) + & - ! Settle_const * ((Pss(i)*Denmaxinv) - Pk_depth(i)) - ! dpt1 = ((Net_snow(i)*Deninv)+ (Setden*Pss(i))+Pk_depth(i))*Set1 ! [inches] - ! RAPCOMMENT - CHANGED TO THE APPROPRIATE FINITE DIFFERENCE - ! APPROXIMATION OF SNOW DEPTH - Pk_depth(i) = dpt1 ! [inches] - - ! Calculate the snowpack density - IF ( dpt1>0.0D0 ) THEN - Pk_den(i) = SNGL( Pkwater_equiv(i)/dpt1 ) - ELSE - Pk_den(i) = 0.0 - ENDIF - ! [inch water equiv / inch depth] - - ! The effective thermal conductivity is approximated - ! (empirically) as 0.0077 times (snowpack density)^2 - ! [cal / (sec g degC)] Therefore, the effective - ! conductivity term (inside the square root) in the - ! equation for conductive heat exchange can be - ! calculated as follows (0.0077*pk_den^2)/(pk_den*0.5) - ! where 0.5 is the specific heat of ice [cal / (g degC)] - ! this simplifies to the following - effk = 0.0154*Pk_den(i) ! [unitless] - ! 13751 is the number of seconds in 12 hours over pi - ! So for a half day, to calculate the conductive heat - ! exchange per cm snow per cm^2 area per degree - ! temperature difference is the following - ! In effect, multiplying cst times the temperature - ! gradient gives the heatexchange by heat conducted - ! (calories) per square cm of snowpack - cst = Pk_den(i)*(SQRT(effk*13751.0)) ! [cal/(cm^2 degC)] - ! or [Langleys / degC] - - - ! no shortwave (solar) radiation at night - sw = 0.0 ! [cal / cm^2] or [Langleys] - ! calculate the night time energy balance - CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & - & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & - & Canopy_covden(i), cec, Pkwater_equiv(i), & - & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & - & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & - & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) - ! track total heat flux from both night and day periods - Tcal(i) = cals ! [cal/cm^2] or [Langleys] - ENDIF - iswn = 0.0 - IF ( Active_glacier>=1 ) THEN - IF ( Glacrcov_area(i)>0.0 ) THEN - iswn = Swrad(i)*(1.0-Glacr_albedo(i))*Rad_trncf(i) ! [cal/cm^2] !want bare ice albedo - ! or [Langleys] - ! Calculate the Glacier icepack density - ! - ! The effective thermal conductivity is approximated - ! (empirically) as 0.0077 times (snowpack density)^2 cal/(cm sec degC) - ! from Oke 1987 - ! ice is 2.1 W/(m degC) = 0.021 W/(cm deg C) = 0.00502 cal/(cm sec degC) - ! = 0.00597 times (0.917**2), - ! firn (old snow density .5) is closer to 0.0042 W/(cm deg C) = 0.00401 times (0.5**2) - ! Therefore, the effective - ! conductivity term (inside the square root) in the - ! equation for conductive heat exchange can be - ! calculated as follows (0.0597*pk_den^2)/(pk_den*0.5) - ! where 0.5 is the specific heat of ice [cal / (g degC)] - ! this simplifies to the following - ! might want to use 0.005*2 = 0.01 half way between if doing mix of firn and ice - ieffk = 0.01194*Glacr_pk_den(i) ! [unitless] - icst = Glacr_pk_den(i)*(SQRT(ieffk*13751.0)) ! [cal/(cm^2 degC)] - ! or [Langleys / degC] - isw = 0.0 ! [cal / cm^2] or [Langleys] - CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & - & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & - & Canopy_covden(i), cec, Glacr_pkwater_equiv(i), & - & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & - & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & - & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) - ENDIF - ENDIF - IF ( Active_frozen==1 ) THEN - lswn = Swrad(i)*(1.0-Land_albedo(i))*Rad_trncf(i) ! [cal/cm^2] - ! or [Langleys] - lsw = 0.0 ! [cal / cm^2] or [Langleys] - ijunk = 0 - rjunk = 0.0 - djunk = 0.D0 - ! only call for calories to frozen ground - CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), ijunk, & - & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & - & Canopy_covden(i), cec, djunk, & - & rjunk, rjunk, rjunk, rjunk, & - & rjunk, rjunk, djunk, & - & djunk, djunk, rjunk, cst, cals, lsw, rjunk,-100) - ! track total heat flux from both night and day periods - Tcal_nosnow(i) = cals ! [cal/cm^2] or [Langleys] - ENDIF - - ! Compute energy balance for day period - ! set the flag indicating daytime - niteda = 2 ! [flag] - ! temparature is halfway between the maximum and average - ! temperature for the day - temp = (Tmaxc(i)+Tavgc(i))*0.5 ! [degrees C] - - IF ( Pkwater_equiv(i)>0.0D0 ) THEN !(if the snowpack still exists) - ! set shortwave radiation as calculated earlier - sw = swn ! [cal/cm^2] or [Langleys] - CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & - & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & - & Canopy_covden(i), cec, Pkwater_equiv(i), & - & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & - & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & - & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) - ! track total heat flux from both night and day periods - Tcal(i) = Tcal(i) + cals ! [cal/cm^2] or [Langleys] - ENDIF - ! Compute energy balance for day period (if glacier exists) - IF ( Active_glacier>=1 ) THEN - IF ( Glacrcov_area(i)>0.0 ) THEN - ! set shortwave radiation as calculated earlier - isw = iswn ! [cal/cm^2] or [Langleys] - CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & - & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & - & Canopy_covden(i), cec, Glacr_pkwater_equiv(i), & - & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & - & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & - & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) - ENDIF - ENDIF - IF ( Active_frozen==1 ) THEN - lsw = lswn ! [cal / cm^2] or [Langleys] - ijunk = 0 - rjunk = 0.0 - djunk = 0.D0 - ! only call for calories to frozen ground - CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), ijunk, & - & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & - & Canopy_covden(i), cec, djunk, & - & rjunk, rjunk, rjunk, rjunk, & - & rjunk, rjunk, djunk, & - & djunk, djunk, rjunk, cst, cals, lsw, rjunk,-100) - ! track total heat flux from both night and day periods - Tcal_nosnow(i) = cals ! [cal/cm^2] or [Langleys] - ENDIF - - ! HRU STEP 5 - CALCULATE SNOWPACK LOSS TO EVAPORATION - !******************************************************** - - ! Compute snow evaporation (if there is still a snowpack) - ! Some of the calculated evaporation can come from interception - ! rather than the snowpack. Therefore, the effects of - ! interception must be evaluated. - IF ( Pkwater_equiv(i)>0.0D0 ) THEN - ! Snow can evaporate when transpiration is not occuring - ! or when transpiration is occuring with cover types of - ! bare soil or grass - IF ( Transp_on(i)==0 .OR. (Transp_on(i)==1 .AND. Cov_type(i)<2) ) & - & CALL snowevap(Potet_sublim(i), Potet(i), Snowcov_area(i), & - & Snow_evap(i), Pkwater_equiv(i), Pk_ice(i), & - & Pk_def(i), Freeh2o(i), Pk_temp(i), Hru_intcpevap(i)) - ELSEIF ( Pkwater_equiv(i)<0.0D0 ) THEN - IF ( Print_debug>-1 ) THEN - IF ( Pkwater_equiv(i)<-DNEARZERO ) PRINT *, 'snowpack issue 3, negative pkwater_equiv, & - & HRU:', i, ' value:', Pkwater_equiv(i) - ENDIF - Pkwater_equiv(i) = 0.0D0 ! just to be sure negative values are ignored - ENDIF - IF ( Active_glacier>=1 ) THEN - IF ( Glacrcov_area(i)>0.0 ) & - & CALL snowevap(Potet_sublim(i), Potet(i), Glacrcov_area(i), & - & Glacr_evap(i), Glacr_pkwater_equiv(i), Glacr_pk_ice(i), & - & Glacr_pk_def(i), Glacr_freeh2o(i), Glacr_pk_temp(i), Hru_intcpevap(i)) - ENDIF - - ! HRU CLEAN-UP - ADJUST FINAL HRU SNOWPACK STATES AND - ! INCREMENT THE BASIN TOTALS - !********************************************************* - - ! Final state of the snowpack depends on whether it still - ! exists after all the processing above - ! 2 options below (if-then, else) - - ! (1) Snow pack still exists - IF ( Pkwater_equiv(i)>0.0D0 ) THEN - ! Snowpack still exists - IF ( Pk_den(i)>0.0 ) THEN - Pk_depth(i) = Pkwater_equiv(i)/DBLE(Pk_den(i)) - ELSE - Pk_den(i) = Den_max - Pk_depth(i) = Pkwater_equiv(i)*Denmaxinv - ENDIF - Pss(i) = Pkwater_equiv(i) - ! If it is during the melt period and snowfall was - ! insufficient to reset albedo, then reduce the cumulative - ! new snow by the amount melted during the period - ! (but don't let it be negative) - IF ( Lst(i)>0 ) THEN - Snsv(i) = Snsv(i) - Snowmelt(i) - IF ( Snsv(i)<0.0 ) Snsv(i) = 0.0 - ENDIF - ENDIF - - ENDIF - -! LAST check to clear out all arrays if packwater is gone - IF ( Pkwater_equiv(i)<=0.0D0 ) THEN - IF ( Print_debug>-1 ) THEN - IF ( Pkwater_equiv(i)<-DNEARZERO ) & - & PRINT *, 'Snowpack problem, pkwater_equiv negative, HRU:', i, ' value:', Pkwater_equiv(i) - ENDIF - Pkwater_equiv(i) = 0.0D0 ! just to be sure negative values are ignored - ! Snowpack has been completely depleted, reset all states - ! to no-snowpack values - Pk_depth(i) = 0.0D0 - Pss(i) = 0.0D0 - Snsv(i) = 0.0 - Lst(i) = 0 - Pst(i) = 0.0D0 - Iasw(i) = 0 - Albedo(i) = 0.0 - Pk_den(i) = 0.0 - Snowcov_area(i) = 0.0 - Pk_def(i) = 0.0 - Pk_temp(i) = 0.0 - Pk_ice(i) = 0.0 - Freeh2o(i) = 0.0 - Snowcov_areasv(i) = 0.0 ! rsr, not in original code - Ai(i) = 0.0D0 - Frac_swe(i) = 0.0 - ENDIF - IF ( Active_glacier>=1 ) THEN - IF ( Glacr_pkwater_equiv(i)>0.0D0 ) THEN - Glacr_pk_depth(i) = Glacr_pkwater_equiv(i)/DBLE(Glacr_pk_den(i)) - ELSE - CALL glacr_states_to_zero(i,0) - ENDIF - ENDIF - - frac = 1.0 - IF ( Active_glacier==1 ) frac = (1.0 - Glacier_frac(i)) - IF ( Active_glacier==2 ) frac = (1.0 - Glrette_frac(i)) - ! Sum volumes for basin totals - Basin_snowmelt = Basin_snowmelt + DBLE( Snowmelt(i)*Hru_area(i)*frac ) !don't include stuff melting into glacier - Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*DBLE( Hru_area(i) ) - Basin_snowevap = Basin_snowevap + DBLE( Snow_evap(i)*Hru_area(i) ) - Basin_snowcov = Basin_snowcov + DBLE( Snowcov_area(i)*Hru_area(i) ) - Basin_pk_precip = Basin_pk_precip + DBLE( Pk_precip(i)*Hru_area(i) ) - Basin_snowdepth = Basin_snowdepth + Pk_depth(i)*DBLE(Hru_area(i)) - Basin_tcal = Basin_tcal + DBLE( Tcal(i)*Hru_area(i) ) - IF ( Active_glacier>=1 ) THEN - Basin_glacrb_melt = Basin_glacrb_melt + Glacrb_melt(i)*Hru_area(i) - Basin_glacrevap = Basin_glacrevap + Glacr_evap(i)*Hru_area(i) - ENDIF - - ENDDO - - ! Area normalize basin totals - Basin_snowmelt = Basin_snowmelt*Basin_area_inv - Basin_pweqv = Basin_pweqv*Basin_area_inv - Basin_snowevap = Basin_snowevap*Basin_area_inv - Basin_snowcov = Basin_snowcov*Basin_area_inv - Basin_snowicecov = Basin_snowcov - Basin_pk_precip = Basin_pk_precip*Basin_area_inv - Basin_snowdepth = Basin_snowdepth*Basin_area_inv - Basin_tcal = Basin_tcal*Basin_area_inv - IF ( Glacier_flag==1 ) THEN - Basin_glacrb_melt = Basin_glacrb_melt*Basin_area_inv - Basin_glacrevap = Basin_glacrevap*Basin_area_inv - ENDIF - - - IF ( Print_debug==9 ) THEN - PRINT 9001, Jday, (Net_rain(i), i=1, Nhru) - PRINT 9001, Jday, (Net_snow(i), i=1, Nhru) - PRINT 9001, Jday, (Snowmelt(i), i=1, Nhru) - ENDIF - - 9001 FORMAT (I5, 177F6.3) - - END FUNCTION snorun - -!*********************************************************************** -! Subroutine to add rain and/or snow to snowpack -!*********************************************************************** - SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & - & Pkwater_equiv, Net_rain, Pk_def, Pk_temp, Pk_ice, & - & Freeh2o, Snowcov_area, Snowmelt, Pk_depth, Pss, Pst, & - & Net_snow, Pk_den, Pptmix_nopack, Pk_precip, Tmax_allsnow_c, Freeh2o_cap, Ihru_gl) - USE PRMS_BASIN, ONLY: CLOSEZERO, INCH2CM !, DNEARZERO - IMPLICIT NONE - REAL, EXTERNAL :: f_to_c - EXTERNAL calin - INTRINSIC ABS, DBLE, SNGL -! Arguments - INTEGER, INTENT(IN) :: Pptmix, Ihru_gl - INTEGER, INTENT(INOUT) :: Iasw, Pptmix_nopack - REAL, INTENT(IN) :: Tmaxc, Tminc, Tavgc, Net_rain, Net_snow - REAL, INTENT(IN) :: Freeh2o_cap, Tmax_allsnow_c - REAL, INTENT(INOUT) :: Snowmelt, Freeh2o, Pk_precip - REAL, INTENT(INOUT) :: Pk_def, Pk_ice, Pk_den, Snowcov_area, Pk_temp - DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv, Pk_depth, Pst, Pss -! Local Variables - REAL :: train, tsnow, caln, pndz, calpr, calps -!*********************************************************************** - - ! The temperature of precipitation will be different if it is mixed or - ! all rain or snow 2 options below (if-then, else) - - ! If there is any snow, the snow temperature is the average - ! temperature - tsnow = Tavgc ! [degrees C] - ! (1) If precipitation is mixed... - IF ( Pptmix==1 ) THEN - ! If there is any rain, the rain temperature is halfway between the maximum - ! temperature and the allsnow temperature - train = (Tmaxc+Tmax_allsnow_c)*0.5 ! [degrees C] - - ! Temperatures will be different, depending on if there is an - ! existing snowpack or not - - ! If there is a snowpack, snow temperature is halfway between - ! the minimum daily temperature and maximum temperature for - ! which all precipitation is snow - IF ( Pkwater_equiv>0.0D0 ) THEN - tsnow = (Tminc+Tmax_allsnow_c)*0.5 ! [degrees C] - - ! If there is no existing snowpack, snow temperature is the - ! average temperature for the day - ELSEIF ( Pkwater_equiv<0.0D0 ) THEN -! IF ( Pkwater_equiv<-DNEARZERO ) & -! & PRINT *, 'snowpack issue in ppt_to_pack, negative pkwater_equiv', Pkwater_equiv - Pkwater_equiv = 0.0D0 ! to be sure negative snowpack is ignored - ENDIF - - ! (2) If precipitation is all snow or all rain... - ELSE ! on glacier ice goes in here only - ! If there is any rain, the rain temperature is the average - ! temperature - train = Tavgc ! [degrees C] - ! If average temperature is close to freezing, the rain - ! temperature is halfway between the maximum daily temperature - ! and maximum temperature for which all precipitation is snow - IF ( train0.0 ) tsnow = 0.0 ! [degrees C] ! tsnow can't be > 0 - - ! Leavesley comments... - ! If snowpack already exists, add rain first, then add - ! snow. If no antecedent snowpack, rain is already taken care - ! of, so start snowpack with snow. This SUBROUTINE assumes - ! that in a mixed event, the rain will be first and turn to - ! snow as the temperature drops. - - ! Rain can only add to the snowpack if a previous snowpack - ! exists, so rain or a mixed event is processed differently - ! when a snowpack exists - ! 2 options below (if-then, elseif) - - ! (1) If there is net rain on an existing snowpack... - IF ( Pkwater_equiv>0.0D0 ) THEN - IF ( Net_rain>0.0 ) THEN ! on glacier ice goes in here only - ! Add rain water to pack (rain on snow) and increment the - ! precipitation on the snowpack by the rain water - Pkwater_equiv = Pkwater_equiv + DBLE(Net_rain) ! [inches] - Pk_precip = Pk_precip + Net_rain ! [inches] - - ! Incoming rain water carries heat that must be added to - ! the snowpack. - ! This heat could both warm the snowpack and melt snow. - ! Handling of this heat depends on the current thermal - ! condition of the snowpack. - ! 2 options below (if-then, else) - - ! (1.1) If the snowpack is colder than freezing it has a - ! heat deficit (requires heat to be brought to isothermal - ! at 0 degC)... - IF ( Pk_def>0.0 ) THEN - ! Calculate the number of calories given up per inch of - ! rain when cooling it from the current rain temperature - ! to 0 deg C and then freezing it (liquid to solid state - ! latent heat) - ! This calculation assumes a volume of an inch of rain - ! over a square cm of area - ! 80 cal come from freezing 1 cm3 at 0 C - ! (latent heat of fusion is 80 cal/cm^3), - ! 1 cal from cooling 1cm3 for every degree C - ! (specific heat of water is 1 cal/(cm^3 degC)), - ! convert from 1 cm depth over 1 square cm to - ! 1 inch depth over 1 square cm (INCH2CM = 2.54 cm/in) - caln = (80.0+train)*INCH2CM ! [cal / (in cm^2)] - ! calculate the amount of rain in inches - ! (at the current rain temperature) - ! needed to bring the snowpack to isothermal at 0 - pndz = Pk_def/caln ! [inches] - - ! The effect of rain on the snowpack depends on if there - ! is not enough, enough, or more than enough heat in the - ! rain to bring the snowpack to isothermal at 0 degC or not - ! 3 options below (if-then, elseif, else) - - ! (1.1.1) Exactly enough rain to bring pack to isothermal... - IF ( ABS(Net_rain-pndz)0.0 ) THEN - ! Be careful with the code here. - ! If this subroutine is called when there is an all-rain day - ! on no existing snowpack (currently, it will not), - ! then the flag here will be set inappropriately. - Pptmix_nopack = 1 ! [flag] - ENDIF - - ! At this point, the subroutine has handled all conditions - ! where there is net rain, so if there is net snow - ! (doesn't matter if there is a pack or not)... - IF ( Net_snow>0.0 ) THEN - ! add the new snow to the pack water equivalent, precip, and ice - Pkwater_equiv = Pkwater_equiv + DBLE(Net_snow) - Pk_precip = Pk_precip + Net_snow - Pk_ice = Pk_ice + Net_snow - - ! The temperature of the new snow will determine its effect on - ! snowpack heat deficit - ! 2 options below (if-then, else) - - ! (1) if the new snow is at 0 degC... - IF ( tsnow>=0.0 ) THEN - ! incoming snow does not change the overall heat content of - ! the snowpack. - ! However, the temperature will change, because the total heat - ! content of the snowpack will be "spread out" among - ! more snow. Calculate the snow pack temperature from the - ! heat deficit, specific heat of snow, - ! and the new total snowpack water content - Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] - - ! (2) if the new snow is colder than 0 degC... - ELSE - ! calculate the amount of heat the new snow will absorb if - ! warming it to 0C (negative number). - ! This is the negative of the heat deficit of the new snow. - calps = tsnow*Net_snow*1.27 ! [cal/cm^2] - - ! The heat to warm the new snow can come from different - ! sources depending on the state of the snowpack - ! 2 options below (if-then, else) - - ! (2.1) if there is free water in the pack - ! (at least some of it is going to freeze)... - IF ( Freeh2o>0.0 ) THEN - CALL caloss(calps, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) - - ! (2.2) if there is no free water (snow pack has a - ! heat deficit greater than or equal to 0)... - ELSE - ! heat deficit increases because snow is colder than - ! pack (minus a negative number = plus) - ! and calculate the new pack temperature - Pk_def = Pk_def - calps ! [cal/cm^2] - Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] - ENDIF - ENDIF - ENDIF - - END SUBROUTINE ppt_to_pack - -!*********************************************************************** -! Subroutine to compute change in snowpack when a net loss in -! heat energy has occurred. -!*********************************************************************** - SUBROUTINE caloss(Cal, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) - USE PRMS_BASIN, ONLY: CLOSEZERO !, DNEARZERO - IMPLICIT NONE - INTRINSIC SNGL -! Arguments - INTEGER, INTENT(IN) :: Ihru_gl - REAL, INTENT(IN) :: Cal - DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv - REAL, INTENT(INOUT) :: Pk_def, Pk_ice, Freeh2o, Pk_temp -! Functions - EXTERNAL glacr_states_to_zero -! Local Variables - REAL :: calnd, dif -!*********************************************************************** - - ! Loss of heat is handled differently if there is liquid water in - ! the snowpack or not - ! 2 options below (if-then, else) - - ! (1) No free water exists in pack - IF ( Freeh2o0.0 ) THEN - ! the calories absorbed by the new snow freezes some - ! of the free water - ! (increase in ice, decrease in free water) - Pk_ice = Pk_ice + (-Cal/203.2) ! [inches] - Freeh2o = Freeh2o - (-Cal/203.2) ! [inches] - RETURN - ! (1) All free water freezes - ELSE ! IF ( dif<=0.0 ) THEN - ! if all the water freezes, then the remaining heat - ! that can be absorbed by new snow (that which is not - ! provided by freezing free water) becomes the new pack - ! heat deficit - IF ( dif<0.0 ) Pk_def = -dif ! [cal/cm^2] - ! free pack water becomes ice - Pk_ice = Pk_ice + Freeh2o ! [inches] - Freeh2o = 0.0 ! [inches] - - ENDIF - ENDIF - - ! if there is still a snowpack, calculate the new temperature - IF ( Pkwater_equiv>0.0D0 ) THEN - Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] - ELSEIF ( Pkwater_equiv<0.0D0 ) THEN -! IF ( Pkwater_equiv<-DNEARZERO ) & -! & PRINT *, 'snowpack issue 4, negative pkwater_equiv', Pkwater_equiv - Pkwater_equiv = 0.0D0 - ! If on melting glacier ice/firn, Ihru_gl >0, so melted active layer (won't melt infinite ice layer) - If (Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl,0) - ENDIF - - END SUBROUTINE caloss - -!*********************************************************************** -! Subroutine to compute changes in snowpack when a net gain in -! heat energy has occurred. -!*********************************************************************** - SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & - & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & - & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) - USE PRMS_SNOW, ONLY: Denmaxinv, Den_max, Active_glacier - USE PRMS_MODULE, ONLY: Print_debug - USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO - IMPLICIT NONE -! Arguments - INTEGER, INTENT(INOUT) :: Iasw - INTEGER, INTENT(IN) :: Ihru_gl - REAL, INTENT(IN) :: Cal, Freeh2o_cap, Snowcov_area - REAL, INTENT(INOUT) :: Freeh2o - DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv - REAL, INTENT(INOUT) :: Pk_def, Pk_temp, Pk_ice, Pk_den, Snowmelt - DOUBLE PRECISION, INTENT(INOUT) :: Pss, Pst, Pk_depth -! Functions - INTRINSIC SNGL, DBLE - EXTERNAL :: print_date, glacr_states_to_zero -! Local Variables - REAL :: dif, pmlt, apmlt, apk_ice, pwcap - DOUBLE PRECISION :: dif_dble -!*********************************************************************** - - ! Calculate the difference between the incoming calories and the - ! calories needed to bring the pack to isothermal - ! at 0 (heat deficit) - dif = Cal - Pk_def ! [cal/cm^2] - - ! The way incoming heat is handled depends on whether there is - ! not enough, just enough, or more than enough heat to overcome - ! the heat deficit of the snowpack. - ! 3 choices below (if-then, elseif, else) - - ! (1) Not enough heat to overcome heat deficit... - IF ( dif<0.0 ) THEN - ! Reduce the heat deficit by the amount of incoming calories - ! and adjust to the new temperature based on new heat deficit - Pk_def = Pk_def - Cal ! [cal/cm^2] - Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] - - ! (3) More than enough heat to overcome heat deficit - ! (melt ice)... - ELSEIF ( dif>0.0 ) THEN - ! calculate the potential amount of snowmelt from excess - ! heat in rain it takes 203.2 calories / (in cm^2) to melt snow - ! (latent heat of fusion) - ! convert from 1 cm depth over 1 square cm to - ! 1 inch depth over 1 square cm 80.0*(INCH2CM = 2.54 cm/in) = 203.2 - pmlt = dif/203.2 ! [inches] - ! Actual snowmelt can only come from snow covered area, so to - ! calculate the actual potential snowmelt, the potential - ! snowmelt from snowcovered area must be re-normalized to - ! HRU area (rather than snowcover area) - ! In effect, the potential snowmelt per area is reduced by the - ! fraction of the watershed that is actually covered by snow - apmlt = pmlt*Snowcov_area ! [inches] - ! Set the heat deficit and temperature of the remaining - ! snowpack to 0 - Pk_def = 0.0 ! [cal/cm^2] - Pk_temp = 0.0 ! [degrees C] - ! The only pack ice that is melted is in the snow covered area, - ! so the pack ice needs to be re-normalized to the snowcovered - ! area (rather than HRU area) - ! In effect, the pack ice per area is increased by the fraction - ! of the watershed that is actually covered by snow - IF ( Snowcov_area>0.0 ) THEN - apk_ice = Pk_ice/Snowcov_area ! [inches] - ELSE -! PRINT *, 'snowcov_area really small, melt all ice', snowcov_area, ' pmlt:', pmlt, ' dif:', dif, ' pk_ice:', Pk_ice - apk_ice = 0.0 - ENDIF - - ! If snow is melting, the heat is handled based on whether all - ! or only part of the pack ice melts - ! 2 options below (if-then, else) - - ! (3.1) Heat applied to snow covered area is sufficient - ! to melt all the ice in that snow pack... - ! if on snow over glacier or active_layer and have excess energy from day over - ! depth can melt from layer thickness, add depth to that layer - IF ( pmlt>apk_ice .AND. Active_glacier>=1 ) THEN - !fractionate density with snow/active layer melting vs extra ice underneath melting - Pk_den = Pk_den*SNGL(apk_ice/pmlt) + 0.917*SNGL((pmlt-apk_ice)/pmlt) - apk_ice = pmlt - Pk_ice = apmlt - Pkwater_equiv = apmlt - Freeh2o = 0.0 ! [inches] - Iasw = 0 - Pk_def = 0.0 ! [cal / cm^2] - Pk_temp = 0.0 ! [degreees C] - Pst = 0.0D0 ! [inches] - ENDIF - - IF ( pmlt>apk_ice ) THEN ! will not happen if Active_glacier>=1 because of above - ! All pack water equivalent becomes meltwater - Snowmelt = Snowmelt + SNGL( Pkwater_equiv ) ! [inches] - Pkwater_equiv = 0.0D0 ! [inches] - Iasw = 0 ! snow area does not change - ! Set all snowpack states to 0 - ! Snowcov_area = 0.0 ! [fraction of area] ! shouldn't be changed with melt - Pk_def = 0.0 ! [cal / cm^2] - Pk_temp = 0.0 ! [degreees C] - Pk_ice = 0.0 ! [inches] - Freeh2o = 0.0 ! [inches] - Pk_depth = 0.0D0 ! [inches] - Pss = 0.0D0 ! [inches] - Pst = 0.0D0 ! [inches] - Pk_den = 0.0 ! [fraction of depth] - - ! (3.2) Heat only melts part of the ice in the snow pack... - ELSE - ! Remove actual melt from frozen water and add melt to - ! free water - Pk_ice = Pk_ice - apmlt ! [inches] - Freeh2o = Freeh2o + apmlt ! [inches] - ! Calculate the capacity of the snowpack to hold free water - ! according to its current level of frozen water - pwcap = Freeh2o_cap*Pk_ice ! [inches] - ! Calculate the amount of free water in excess of the - ! capacity to hold free water - dif_dble = DBLE( Freeh2o - pwcap ) ! [inches] - ! If there is more free water than the snowpack can hold, - ! then there is going to be melt... - IF ( dif_dble>0.0D0 ) THEN - IF ( dif_dble>Pkwater_equiv ) dif_dble = Pkwater_equiv - ! total packwater decreases by the excess and a new depth - ! is calculated based on density - Pkwater_equiv = Pkwater_equiv - dif_dble ! [inches] - ! free water is at the current capacity - Freeh2o = pwcap ! [inches] - IF ( Pk_den>0.0 ) THEN - Pk_depth = Pkwater_equiv/DBLE(Pk_den) ! [inches] - ! RAPCOMMENT - added the conditional statement to make - ! sure there is no division by zero (this can happen - ! if there is a mixed event on no existing snowpack - ! because a pack density has not been calculated, yet - ELSE - !rsr, this should not happen, remove later - IF ( Print_debug>-1 ) THEN - PRINT *, 'snow density problem', Pk_depth, Pk_den, Pss, Pkwater_equiv - CALL print_date(1) - ENDIF - IF ( Active_glacier==0 ) Pk_den = Den_max - Pk_depth = Pkwater_equiv*Denmaxinv ! [inches] - ENDIF - - ! snowmelt increases by the excess free water - Snowmelt = Snowmelt + SNGL( dif_dble ) ! [inches] - ! reset the previous-snowpack-plus-new-snow to the - ! current pack water equivalent - Pss = Pkwater_equiv ! [inches] - ENDIF - ENDIF - ! (2) Just enough heat to overcome heat deficit - ELSE ! IF ( dif==0.0 ) THEN ! rsr 1/27/2016 why not set all snow states to 0 ??? - ! Set temperature and heat deficit to zero - Pk_temp = 0.0 ! [degrees C] - Pk_def = 0.0 ! [cal/cm^2] - ENDIF - IF ( Pkwater_equiv<=0.0D0 ) Pk_den = 0.0 - ! If on melting glacier ice/firn, Ihru_gl >0, so melted active layer (won't melt infinite ice layer) - IF ( Pkwater_equiv<=0.0D0 .AND. Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl,0) - - END SUBROUTINE calin - -!*********************************************************************** -! Subroutine to compute snowpack albedo -!*********************************************************************** - SUBROUTINE snalbedo(Newsnow, Iso, Lst, Snsv, Prmx, Pptmix, Albset_rnm, & - & Net_snow, Albset_snm, Albset_rna, Albset_sna, Albedo, & - & Int_alb, Salb, Slst) - USE PRMS_SNOW, ONLY: MAXALB, Acum, Amlt - IMPLICIT NONE - INTRINSIC INT -! Arguments - INTEGER, INTENT(IN) :: Newsnow, Iso, Pptmix - INTEGER, INTENT(INOUT) :: Int_alb, Lst - REAL, INTENT(IN) :: Albset_rnm, Albset_snm, Albset_rna, Albset_sna, Prmx, Net_snow - REAL, INTENT(INOUT) :: Salb, Slst, Snsv - REAL, INTENT(OUT) :: Albedo -! Local Variables - INTEGER :: l -!*********************************************************************** - - ! The albedo is always reset to a new initial (high) value when - ! there is new snow above a threshold (parameter). Albedo - ! is then a function of the number of days since the last new snow - ! Intermediate conditions apply when there is new snow - ! below the threshold to reset the albedo to its highest value. - ! The curve for albedo change (decreasing) is different for the - ! snow accumulation season and the snow melt season. - ! The albedo first depends on if there is no new snow during the - ! current time step, if there is new snow during accumulation - ! season, or if there is new snow during melt season. - ! 3 options below (if-then, elseif, else) - - ! (1) There is no new snow - IF ( Newsnow==0 ) THEN - ! If no new snow, check if there was previous new snow that - ! was not sufficient to reset the albedo (Lst=1) - ! Lst can only be greater than 0 during melt season (see below) - IF ( Lst>0 ) THEN - ! Slst is the number of days (float) since the last - ! new snowfall - ! Set the albedo curve back three days from the number - ! of days since the previous snowfall - ! (see Salb assignment below) - ! (note that "shallow new snow" indicates new snow that - ! is insufficient to completely reset the albedo curve) - ! In effect, a shallow new snow sets the albedo curve back - ! a few days, rather than resetting it entirely. - Slst = Salb - 3.0 ! [days] - ! Make sure the number of days since last new snow - ! isn't less than 1 - IF ( Slst<1.0 ) Slst = 1.0 ! [days] - ! If not in melt season - IF ( Iso/=2 ) THEN - ! Note that this code is unreachable in its current state. - ! This code is only run during melt season due to the - ! fact that Lst can only be set to 1 in the melt season. - ! Therefore, Iso is always going to be equal to 2. - ! Make sure the maximum point on the albedo curve is 5 - ! In effect, if there is any new snow, the albedo can - ! only get so low in accumulation season, even if the - ! new snow is insufficient to reset albedo entirely - IF ( Slst>5.0 ) Slst = 5.0 ! [days] - ENDIF - ! Reset the shallow new snow flag and cumulative shallow - ! snow variable (see below) - Lst = 0 ! [flag] - Snsv = 0.0 ! [inches] - ENDIF - - ! (2) New snow during the melt season - ELSEIF ( Iso==2 ) THEN -! RAPCOMMENT - CHANGED TO ISO FROM MSO - - ! If there is too much rain in a precipitation mix, - ! albedo will not be reset - ! New snow changes albedo only if the fraction rain - ! is less than the threshold above which albedo is not reset - IF ( PrmxAlbset_snm ) THEN - ! Reset number of days since last new snow to 0 - Slst = 0.0 ! [days] - Lst = 0 ! [flag] - ! Reset the saved new snow to 0 - Snsv = 0.0 ! [inches] - - ! (2.2) If there is not enough new snow this time period - ! to reset the albedo on its own - ELSE - ! Snsv tracks the amount of snow that has fallen as long - ! as the total new snow is not - ! enough to reset the albedo. - Snsv = Snsv + Net_snow ! [inches] - - ! Even if the new snow during this time period is - ! insufficient to reset the albedo, it may still reset the - ! albedo if it adds enough to previous shallow snow - ! accumulation. The change in Albedo depends on if the - ! total amount of accumulated shallow snow has become enough - ! to reset the albedo or not. - ! 2 options below (if-then, else) - - ! (2.2.1) If accumulated shallow snow is enough to reset - ! the albedo - IF ( Snsv>Albset_snm ) THEN - ! Reset the albedo states. - Slst = 0.0 ! [days] - Lst = 0 ! [flag] - Snsv = 0.0 ! [inches] - - ! (2.2.2) If the accumulated shallow snow is not enough to - ! reset the albedo curve - ELSE - ! Salb records the number of days since the last new snow - ! that reset albedo - IF ( Lst==0 ) Salb = Slst ! [days] - ! Reset the number of days since new snow - Slst = 0.0 ! [days] - ! set the flag indicating that there is shallow new snow - ! (i.e. not enough new snow to reset albedo) - Lst = 1 ! [flag] - ENDIF - ENDIF - ENDIF - - ! (3) New snow during the accumulation season - ELSE - - ! The change in albedo depends on if the precipitation is a mix, - ! if the rain is above a threshold, or if the snow is above - ! a threshold. - ! 4 options below (if-then, elseif, elseif, else) - - ! (3.1) If it is not a mixed event... - IF ( Pptmix<1 ) THEN - ! During the accumulation season, the threshold for resetting - ! the albedo does not apply if there is a snow-only event. - ! Therefore, no matter how little snow there is, it will - ! always reset the albedo curve the the maximum, if it - ! occurs during the accumulation season. - ! reset the time since last snow to 0 - Slst = 0.0 ! [days] - ! there is no new shallow snow - Lst = 0 ! [flag] - - ! (3.2) If it is a mixed event and the fraction rain is above - ! the threshold above which albedo is not reset... - ELSEIF ( Prmx>=Albset_rna ) THEN - ! there is no new shallow snow - Lst = 0 ! [flag] - ! albedo continues to decrease on the curve - - ! (3.3) If it is a mixed event and there is enough new snow - ! to reset albedo... - ELSEIF ( Net_snow>=Albset_sna ) THEN - ! reset the albedo - Slst = 0.0 ! [days] - ! there is no new shallow snow - Lst = 0 ! [flag] - - ! (3.4) If it is a mixed event and the new snow was not - ! enough to reset the albedo... - ELSE - ! set the albedo curve back 3 days (increasing the albedo) - Slst = Slst - 3.0 ! [days] - ! Make sure the number of days since last new snow is not - ! less than 0 - IF ( Slst<0.0 ) Slst = 0.0 ! [days] - ! Make sure the number of days since last new snow is not - ! greater than 5 - ! In effect, if there is any new snow, the albedo can - ! only get so low in accumulation season, even if the - ! new snow is insufficient to reset albedo entirely - IF ( Slst>5.0 ) Slst = 5.0 ! [days] - Lst = 0 ! [flag] - ENDIF - Snsv = 0.0 ! [inches] - ENDIF - ! At this point, the subroutine knows where on the curve the - ! albedo should be based on current conditions and the - ! new snow (determined by value of Slst variable) - - ! Get the integer value for days (or effective days) - ! since last snowfall - l = INT(Slst+0.5) ! [days] - - ! Increment the state variable for days since the - ! last snowfall - Slst = Slst + 1.0 ! [days] - - !******Compute albedo - ! Albedo will only be different from the max (default value) - ! if it has been more than 0 days since the last new snow - ! capable of resetting the albedo. If albedo is at the - ! maximum, the maximum is different for accumulation and - ! melt season. - ! 3 options below (if-then, elseif, else) - - ! (1) It has been more than 0 days since the last new snow - IF ( l>0 ) THEN - - ! Albedo depends on whether it is currently on the - ! accumulation season curve or on the melt season curve. - ! 3 options below (if-then, elseif, else) - - ! (1.1) Currently using the melt season curve - ! (Old snow - Spring melt period)... - IF ( Int_alb==2 ) THEN - ! Don't go past the last possible albedo value - IF ( l>MAXALB ) l = MAXALB ! [days] - ! Get the albedo number from the melt season curve - Albedo = Amlt(l) ! [fraction of radiation] - - ! (1.2) Currently using the accumulation season curve - ! (Old snow - Winter accumulation period)... - ! and not past the maximum curve index - ELSEIF ( l<=MAXALB ) THEN - ! Get the albedo number from the accumulation season curve - Albedo = Acum(l) ! [fraction of radiation] - - ! (1.3) Currently using the accumulation season curve and - ! past the maximum curve index... - ELSE - ! start using the the MELT season curve at 12 days - ! previous to the current number of days since the last - ! new snow - l = l - 12 ! [days] - ! keep using the melt season curve until its minimum - ! value (maximum index) is reached or until there is new snow - IF ( l>MAXALB ) l = MAXALB ! [days] - ! get the albedo value from the melt season curve - Albedo = Amlt(l) ! [fraction of radiation] - ENDIF - - ! (2) New snow has reset the albedo and it is melt season - ELSEIF ( Iso==2 ) THEN -! RAPCOMMENT - CHANGED TO ISO FROM MSO - ! Set albedo to initial value during melt season - Albedo = 0.72 ! [fraction of radiation] value Rob suggested -! Albedo = 0.81 ! [fraction of radiation] original value - ! Int_alb is a flag to indicate use of the melt season curve (2) - ! or accumulation season curve (1) - ! Set flag to indicate melt season curve - Int_alb = 2 ! [flag] - - ! (3) New snow has reset the albedo and it is accumulation season - ELSE - ! Set albedo to initial value during accumulation season - Albedo = 0.91 ! [fraction of radiation] - ! Set flag to indicate accumulation season curve - Int_alb = 1 ! [flag] - ENDIF - - END SUBROUTINE snalbedo - -!*********************************************************************** -! Subroutine to compute energy balance of snowpack -! 1st call is for night period, 2nd call for day period -!*********************************************************************** - SUBROUTINE snowbal(Niteda, Tstorm_mo, Iasw, Temp, Esv, Hru_ppt, & - & Trd, Emis_noppt, Canopy_covden, Cec, Pkwater_equiv, & - & Pk_def, Pk_temp, Pk_ice, Freeh2o, Snowcov_area, & - & Snowmelt, Pk_depth, Pss, Pst, Pk_den, Cst, Cal, Sw, Freeh2o_cap, Ihru_gl) - USE PRMS_BASIN, ONLY: CLOSEZERO - IMPLICIT NONE - INTRINSIC SNGL - EXTERNAL calin, caloss -! Arguments - INTEGER, INTENT(IN) :: Niteda, Tstorm_mo, Ihru_gl - INTEGER, INTENT(INOUT) :: Iasw - REAL, INTENT(IN) :: Temp, Esv, Trd, Cec, Cst, Canopy_covden - REAL, INTENT(IN) :: Emis_noppt, Sw, Freeh2o_cap - REAL, INTENT(IN) :: Hru_ppt, Snowcov_area - DOUBLE PRECISION, INTENT(OUT) :: Pst, Pss - REAL, INTENT(OUT) :: Cal - REAL, INTENT(INOUT) :: Pk_den, Pk_def, Pk_temp, Pk_ice - REAL, INTENT(INOUT) :: Freeh2o, Snowmelt - DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv, Pk_depth -! Local Variables - REAL :: air, ts, emis, sno, sky, can, cecsub, qcond, pk_defsub, pkt, pks - REAL, PARAMETER :: ONETHIRD = 1.0/3.0 -!*********************************************************************** - ! Calculate the potential long wave energy from air based on - ! temperature (assuming perfect black-body emission) - ! Stefan Boltzmann/2 = (11.71E-8)/2 = 0.585E-7 because add for day and night - air = 0.585E-7*((Temp+273.15)**4.0) ! [cal/cm^2] or [Langleys] - ! set emissivity, which is the fraction of perfect black-body - ! emission that is actually applied - emis = Esv ! [fraction of radiation] - - ! The snowpack surface temperature and long-wave radiation - ! FROM the snowpack depend on the air temperature (effectively, - ! snowpack temperature cannot be larger than 0 degC) - ! 2 options below (if-then, else) - - ! (1) If the temperature is below freezing, surface snow - ! temperature and long wave energy are determined - ! by temperature... - IF ( Temp<0.0 ) THEN - ts = Temp ! [degrees C] - sno = air ! [cal/cm^2] or [Langleys] - - ! (2) If the temperature is at or above freezing, snow - ! temperature and long wave energy are set to values - ! corresponding to a temperature of 0 degC... - ELSE - ts = 0.0 ! [degrees C] - sno = 325.7 ! [cal/cm^2] or [Langleys] - ENDIF - IF ( Ihru_gl==-100 ) sno=0.0 !frozen ground energy computation - - ! If precipitation over the time period was due to - ! convective thunderstorms, then the emissivity should be reset - IF ( Hru_ppt>0.0 ) THEN - IF ( Tstorm_mo==1 ) THEN - - ! The emissivity of air depends on if it is day or night - ! and the fraction of measured short wave radiation to - ! potential short wave radiation is used as a surrogate - ! to the duration of the convective storms - ! 2 options below (if-then, else) - - ! (1) Night - IF ( Niteda==1 ) THEN - ! set the default emissivity - emis = 0.85 ! [fraction of radiation] - ! if measured radiation is greater than 1/3 potential - ! radiation through the time period, then the emissivity - ! is set to the "no precipitation" value - IF ( Trd>ONETHIRD ) emis = Emis_noppt ![fraction of radiation] - - ! (2) Day - ELSE - ! if measured radiation is greater than 1/3 potential - ! radiation but less than 1/2, then the emissivity is - ! interpolated between 1.0 and 0.85 - ! if measured radiation is greater than 1/2 potential - ! radiation, then the emissivity is interpolated between - ! 0.85 and 0.75 - IF ( Trd>ONETHIRD ) emis = 1.29 - (0.882*Trd) - ! [fraction of radiation] - IF ( Trd>=0.5 ) emis = 0.95 - (0.2*Trd) - ! [fraction of radiation] - ENDIF - ENDIF - ENDIF - - ! Calculate the net incoming long wave radiation coming from the - ! sky or canopy in the uncovered or covered portions of the - ! snowpack, respectively. - ! Note that the canopy is assumed to be a perfect blackbody - ! (emissivity = 1) and the air has emissivity as determined - ! from previous calculations - sky = (1.0-Canopy_covden)*((emis*air)-sno) ! [cal/cm^2] or [Langleys] - can = Canopy_covden*(air-sno) ! [cal/cm^2] or [Langleys] -!RAPCOMMENT - CHECK THE INTERECEPT MODULE FOR CHANGE. What if the land -! cover is grass? Is this automatically covered by canopy_covden being zero -! if the cover type is grass? - - ! If air temperature is above 0 degC then set the energy from - ! condensation and convection, otherwise there is - ! no energy from convection or condensation - cecsub = 0.0 ! [cal/cm^2] or [Langleys] - IF ( Temp>0.0 ) THEN - IF ( Hru_ppt>0.0 ) cecsub = Cec*Temp ! [cal/cm^2] - ! or [Langleys] - ENDIF - - ! Total energy potentially available from atmosphere: longwave, - ! shortwave, and condensation/convection - Cal = sky + can + cecsub + Sw ! [cal/cm^2] or [Langleys] - - IF ( Ihru_gl==-100 ) RETURN !frozen ground energy computation, do not need more - ! If the surface temperature of the snow is 0 degC, and there - ! is net incoming energy, then energy conduction has to be from - ! the surface into the snowpack. - ! Therefore, the energy from the atmosphere is applied to the - ! snowpack and subroutine terminates - IF ( ts>=0.0 ) THEN - IF ( Cal>0.0 ) THEN - CALL calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & - & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & - & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) - RETURN - ENDIF - ENDIF - - ! If the program gets to this point, then either the surface - ! temperature is less than 0 degC, or the total energy from the - ! atmosphere is not providing energy to the snowpack - - ! Because the temperature of the surface of the snowpack is - ! assumed to be controlled by air temperature, there is a - ! potential heat flux due to conduction between the deeper - ! snowpack and its surface. - ! Calculate conductive heat flux as a function of the - ! temperature gradient then set new snowpack conditions - ! depending on the direction of heat flow - qcond = Cst*(ts-Pk_temp) ! [cal/cm^2] or [Langleys] -!RAPCOMMENT - The original equation in the paper implies that the -! this equation should be relative to the temperature gradient -! in degF, not degC (Anderson 1968). Which is correct? - - ! The energy flow depends on the direction of conduction and the - ! temperature of the surface of the snowpack. The total energy - ! from the atmosphere can only penetrate into the snow pack if - ! the temperature gradient allows conduction from the surface - ! into the snowpack. - ! 4 options below (if-then, elseif, elseif, else) - - ! (1) Heat is conducted from the snowpack to the surface - ! (atmospheric energy is NOT applied to snowpack)... - IF ( qcond<0.0 ) THEN - ! If the temperature of the snowpack is below 0 degC, - ! add to the heat deficit. Otherwise, remove heat - ! from the 0 degC isothermal snow pack. - IF ( Pk_temp<0.0 ) THEN - ! increase the heat deficit (minus a negative) - ! and adjust temperature - Pk_def = Pk_def - qcond ! [cal/cm^2] or [Langleys] - Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] - ELSE - ! remove heat from the snowpack - CALL caloss(qcond, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) - ENDIF - ! Even though Cal is not applied to the snowpack under this - ! condition, it maintains its value and the referencing code - ! uses it to calculate the total energy balance of the snowpack. - ! Right, now, Cal isn't used for anything outside this subroutine, - ! but care should be taken if it is. - - ! (2) There is no heat conduction, qcond = 0.0 - ELSEIF ( qcond=0.0 ) THEN - ! It does not appear that the interior of the following if - ! statement is reachable in its current form, because if these - ! conditions are true, then the code for surface temperature=0 - ! and cal=positive number would have run and the subroutine - ! will have terminated - IF ( Cal>0.0 ) CALL calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & - & Pk_ice, Freeh2o, Snowcov_area, & - & Snowmelt, Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) - ENDIF - - ! (3) conduction is from the surface to the snowpack and the - ! surface temperature is 0 degrees C... - ELSEIF ( ts>=0.0 ) THEN - ! note that Cal must be <= 0 for this condition to apply. - ! Otherwise, the program wouldn't have gotten to this point. - - ! determine if the conductive heat is enough to overcome the - ! current heat deficit - pk_defsub = Pk_def - qcond - IF ( pk_defsub<0.0 ) THEN - ! deficit is overcome and snowpack becomes - ! isothermal at 0 degC - Pk_def = 0.0 ! [cal/cm^2] or [Langleys] - Pk_temp = 0.0 ! [degrees C] - ELSE - ! deficit is decreased by conducted heat and temperature - ! is recalculated - Pk_def = pk_defsub ! [cal/cm^2] or [Langleys] - Pk_temp = -pk_defsub/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] - ENDIF - - ! (4) conduction is from the surface to the snowpack and the - ! surface temperature is less than 0 degrees C... - ELSE - ! calculate the pack deficit if the snowpack was all at the - ! surface temperature, then calculate how many calories to - ! shift the pack to that deficit (pks will be a positive - ! number because the conduction direction is from the surface - ! into the snowpack) - pkt = -ts*SNGL(Pkwater_equiv*1.27D0) ! [cal/cm^2] or [Langleys] - pks = Pk_def - pkt ! [cal/cm^2] or [Langleys] - ! determine if the conducted heat is enough to shift the - ! pack to the deficit relative to the surface temperature - pk_defsub = pks - qcond ! [cal/cm^2] or [Langleys] - - ! The effect of incoming conducted heat depends on whether - ! it is enough to bring the snowpack to the same temperature - ! as the surface or not - ! 2 options below (if-then, else) - - ! (4.1) There is enough conducted heat to bring the deep - ! snowpack to the surface temperature... - IF ( pk_defsub<0.0 ) THEN - ! there is enough conduction to change to the new pack deficit - Pk_def = pkt ! [cal/cm^2] or [Langleys] - Pk_temp = ts ! [degrees C] - - ! (4.2) There is not enough conducted heat to bring the deep - ! snowpack to the surface temperature... - ELSE - ! the pack deficit doesn't make it all the way to the surface - ! deficit, but is decreased relative to the conducted heat - ! note that the next statement is equivalent to - ! Pk_def = Pk_def - qcond - Pk_def = pk_defsub + pkt ! [cal/cm^2] or [Langleys] - Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] - ENDIF - ENDIF - - END SUBROUTINE snowbal - -!*********************************************************************** -! Subroutine to compute evaporation from snowpack -!*********************************************************************** - SUBROUTINE snowevap(Potet_sublim, Potet, Snowcov_area, Snow_evap, & - & Pkwater_equiv, Pk_ice, Freeh2o, Pk_def, Pk_temp, Hru_intcpevap) - USE PRMS_SNOW, ONLY: Active_glacier - USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO - USE PRMS_MODULE, ONLY: Print_debug - IMPLICIT NONE - INTRINSIC DBLE, SNGL -! Arguments - REAL, INTENT(IN) :: Potet_sublim, Potet, Snowcov_area, Hru_intcpevap - REAL, INTENT(INOUT) :: Pk_ice, Pk_def, Pk_temp - DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv - REAL, INTENT(OUT) :: Snow_evap, Freeh2o -! Local Variables - REAL :: avail_et, cal, ez -!*********************************************************************** - ! the amount of evaporation affecting the snowpack is the - ! total evaporation potential minus the evaporation from - ! the interception storage - ez = Potet_sublim*Potet*Snowcov_area - Hru_intcpevap ! [inches] - - ! The effects of evaporation depend on whether there is any - ! potential for evaporation, and if the potential evapotation - ! is enough to completely deplete the snow pack or not - ! 3 options below (if-then, elseif, else) - - ! (1) There is no potential for evaporation... - ! if on snow over glacier or active_layer and have excess energy from day over - ! depth can evap from layer thickness, add depth to that layer - IF ( ez>Pkwater_equiv .AND. Active_glacier>=1 ) Pkwater_equiv = DBLE(ez) - IF ( ez=Pkwater_equiv ) THEN - ! Set the evaporation to the pack water equivalent and set - ! all snowpack variables to no-snowpack values - Snow_evap = SNGL(Pkwater_equiv) ! [inches] - Pkwater_equiv = 0.0D0 ! [inches] - Pk_ice = 0.0 ! [inches] - Pk_def = 0.0 ! [cal/cm^2] - Freeh2o = 0.0 ! [inches] - Pk_temp = 0.0 ! [degrees C] - - ! (3) Potential evaporation only partially depletes snowpack - ELSE - ! Evaporation depletes the amount of ice in the snowpack - ! (sublimation) - Pk_ice = Pk_ice - ez - - ! Change the pack conditions according to whether there is - ! any ice left in the snowpack - IF ( Pk_ice<0.0 ) THEN -!RAPCOMMENT - CHANGED TO CHECK FOR NEGATIVE PACK ICE - ! If all pack ice is removed, then there cannot be a - ! heat deficit - Pk_ice = 0.0 - Pk_def = 0.0 - Pk_temp = 0.0 - ELSE - ! Calculate the amount of heat deficit that is removed - ! by the sublimating ice - ! Note that this only changes the heat deficit if the - ! pack temperature is less than 0degC - cal = Pk_temp*ez*1.27 - Pk_def = Pk_def + cal - ENDIF - ! Remove the evaporated water from the pack water equivalent - Pkwater_equiv = Pkwater_equiv - ez - Snow_evap = ez - ENDIF - IF ( Snow_evap<0.0 ) THEN - Pkwater_equiv = Pkwater_equiv - DBLE(Snow_evap) - IF ( Pkwater_equiv<0.0D0 ) THEN - IF ( Print_debug>-1 ) THEN - IF ( Pkwater_equiv<-DNEARZERO ) & - & PRINT *, 'snowpack issue, negative pkwater_equiv in snowevap', Pkwater_equiv - Pkwater_equiv = 0.0D0 - ENDIF - ENDIF - Snow_evap = 0.0 - ENDIF - avail_et = Potet - Hru_intcpevap - Snow_evap - IF ( avail_et<0.0 ) THEN -! PRINT *, 'snow evap', snow_evap, avail_et, pkwater_equiv - Snow_evap = Snow_evap + avail_et - Pkwater_equiv = Pkwater_equiv - DBLE(avail_et) - IF ( Snow_evap<0.0 ) THEN - Pkwater_equiv = Pkwater_equiv - Snow_evap - IF ( Pkwater_equiv<0.0D0 ) THEN - IF ( Print_debug>-1 ) THEN - IF ( Pkwater_equiv<-DNEARZERO ) & - & PRINT *, 'snowpack issue 2, negative pkwater_equiv in snowevap', Pkwater_equiv - ENDIF - Pkwater_equiv = 0.0D0 ! to be sure negative snowpack is ignored - ENDIF - Snow_evap = 0.0 - ENDIF - ENDIF - - END SUBROUTINE snowevap - -!*********************************************************************** -! Subroutine to compute snow-covered area -!*********************************************************************** - SUBROUTINE snowcov(Iasw, Newsnow, Snowcov_area, Snarea_curve, & - & Pkwater_equiv, Pst, Snarea_thresh, Net_snow, & - & Scrv, Pksv, Snowcov_areasv, Ai, Frac_swe) - IMPLICIT NONE -! Arguments - INTEGER, INTENT(IN) :: Newsnow - INTEGER, INTENT(INOUT) :: Iasw - REAL, INTENT(IN) :: Snarea_thresh, Net_snow, Snarea_curve(11) - DOUBLE PRECISION, INTENT(IN) :: Pkwater_equiv - REAL, INTENT(INOUT) :: Snowcov_area - DOUBLE PRECISION, INTENT(OUT) :: Ai - REAL, INTENT(INOUT) :: Snowcov_areasv - DOUBLE PRECISION, INTENT(INOUT) :: Pst, Scrv, Pksv - REAL, INTENT(OUT) :: Frac_swe -! Functions - INTRINSIC DBLE, SNGL - EXTERNAL :: sca_deplcrv -! Local Variables - REAL :: snowcov_area_ante - DOUBLE PRECISION :: fracy, difx, dify -!*********************************************************************** - snowcov_area_ante = Snowcov_area - ! Reset snowcover area to the maximum - Snowcov_area = Snarea_curve(11) ! [fraction of area] - - ! Track the maximum pack water equivalent for the current - ! snow pack - IF ( Pkwater_equiv>Pst ) Pst = Pkwater_equiv ! [inches] - - ! Set ai to the maximum packwater equivalent, but no higher than - ! the threshold for complete snow cover - Ai = Pst ! [inches] - IF ( Ai>Snarea_thresh ) Ai = DBLE( Snarea_thresh ) ! [inches] - - ! calculate the ratio of the current packwater equivalent to - ! the maximum packwater equivalent for the given snowpack - Frac_swe = SNGL( Pkwater_equiv/Ai ) ! [fraction] - - ! There are 3 potential conditions for the snow area curve: - ! A. snow is accumulating and the pack is currently at its - ! maximum level - ! B. snow is depleting and the area is determined by the - ! snow area curve - ! C. new snow has occured on a depleting pack, temporarily - ! resetting to 100% cover. - ! For case (C), the snow covered area is linearly interpolated - ! between 100% and the snow covered area before the new snow. - ! In general, 1/4 of the new snow has to melt before the snow - ! covered area goes below 100%, and then the remaining 3/4 has - ! to melt to return to the previous snow covered area. - - ! First, the code decides whether snow is accumulating (A) - ! or not (B/C). - ! 2 options below (if-then, else) - - ! (1) The pack water equivalent is at the maximum - IF ( Pkwater_equiv>=Ai ) THEN - ! Stay on the snow area curve (it will be at the maximum - ! because the pack water equivalent is equal to ai - ! and it can't be higher) - Iasw = 0 - - ! (2) The pack water equivalent is less than the maximum - ELSE - - ! If the snowpack isn't accumulating to a new maximum, - ! it is either on the curve (condition B above) or being - ! interpolated between the previous place on the curve and - ! 100% (condition C above) - ! 2 options below (if-then, elseif) - - ! (2.1) There was new snow... - IF ( Newsnow/=0 ) THEN - - ! New snow will always reset the snow cover to 100%. - ! However, different states changes depending on whether - ! the previous snow area condition was on the curve or - ! being interpolated between the curve and 100% - ! 2 options below (if-then, else) - - ! (2.1.1) The snow area is being interpolated between 100% - ! and a previous location on the curve... - IF ( Iasw>0 ) THEN - ! The location on the interpolated line is based on how - ! much of the new snow has melted. Because the first 1/4 - ! of the new snow doesn't matter, it has to keep track of - ! the current snow pack plus 3/4 of the new snow. - Scrv = Scrv + (0.75D0*DBLE(Net_snow)) ! [inches] - ! Scrv = Pkwater_equiv - (0.25D0*DBLE(Net_snow))) ! [inches] -!RAPCOMMENT - CHANGED TO INCREMENT THE SCRV VALUE IF ALREADY -! INTERPOLATING BETWEEN CURVE AND 100% - - ! (2.1.2) The current snow area is on the curve... - ELSE - ! If switching from the snow area curve to interpolation - ! between the curve and 100%, the current state of the snow - ! pack has to be saved so that the interpolation can - ! continue until back to the original conditions. - ! First, set the flag to indicate interpolation between 100% - ! and the previous area should be done - Iasw = 1 ! [flag] - ! Save the current snow covered area - ! (before the new net snow) - Snowcov_areasv = snowcov_area_ante ! [inches] - ! Save the current pack water equivalent - ! (before the new net snow) - Pksv = Pkwater_equiv - DBLE( Net_snow ) ! [inches] - ! The location on the interpolated line is based on how much - ! of the new snow has melted. Because the first 1/4 - ! of the new snow doesn't matter, it has to keep track of - ! the current snow pack plus 3/4 of the new snow. - Scrv = Pkwater_equiv - (0.25D0*DBLE(Net_snow)) ! [inches] - ENDIF - ! The subroutine terminates here because the snow covered area - ! always starts at 100% if there is any new snow (no need to - ! reset it from the maximum value set at the beginning of the - ! subroutine). - RETURN - - ! (2.2) There was no new snow, but the snow covered area is - ! currently being interpolated between 100% - ! from a previous new snow and the snow covered area - ! before that previous new snow... - ELSEIF ( Iasw/=0 ) THEN - ! If the first 1/4 of the previous new snow has not melted, - ! yet, then the snow covered area is still - ! 100% and the subroutine can terminate. - IF ( Pkwater_equiv>Scrv ) RETURN - - ! At this point, the program is almost sure it is - ! interpolating between the previous snow covered area and - ! 100%, but it is possible that enough snow has melted to - ! return to the snow covered area curve instead. - ! 2 options below (if-then, else) - - ! (2.2.1) The snow pack still has a larger water equivalent - ! than before the previous new snow. I.e., new snow - ! has not melted back to original area... - IF ( Pkwater_equiv>=Pksv ) THEN - ! Do the interpolation between 100% and the snow covered - ! area before the previous new snow. - - ! Calculate the difference between the maximum snow - ! covered area (remember that Snowcov_area is always - ! set to the maximum value at this point) and the snow - ! covered area before the last new snow. - difx = DBLE( Snowcov_area - Snowcov_areasv ) - ! Calculate the difference between the water equivalent - ! before the last new snow and the previous water - ! equivalent plus 3/4 of the last new snow. - ! In effect, get the value of 3/4 of the previous - ! new snow. - dify = Scrv - Pksv ! [inches] !gl1098 - - ! If 3/4 of the previous new snow is significantly - ! different from zero, then calculate the ratio of the - ! unmelted amount of previous new snow in the snow pack - ! to the value of 3/4 of previous new snow. - ! In effect, this is the fraction of the previous new snow - ! that determines the current interpolation - ! of snow covered area. - fracy = 0.0D0 ! [fraction] !gl1098 - IF ( dify>0.0D0 ) fracy = (Pkwater_equiv-Pksv)/dify - ! [fraction] - ! Linearly interpolate the new snow covered area. - Snowcov_area = Snowcov_areasv + SNGL(fracy*difx) - ! [fraction of area] - ! Terminate the subroutine - RETURN - - ! (2.2.2) The snow pack has returned to the snow water - ! equivalent before the previous new snow. I.e. back to - ! original area before new snow. - ELSE - ! Reset the flag to use the snow area curve - Iasw = 0 ! [flag] - ENDIF - - ENDIF - - ! If this subroutine is still running at this point, then the - ! program knows that the snow covered area needs to be - ! adjusted according to the snow covered area curve. So at - ! this point it must interpolate between points on the snow - ! covered area curve (not the same as interpolating between - ! 100% and the previous spot on the snow area depletion curve). - - CALL sca_deplcrv(Snowcov_area, Snarea_curve, Frac_swe) - - ENDIF - - END SUBROUTINE snowcov - -!*********************************************************************** -! Interpolate along snow covered area depletion curve -!*********************************************************************** - SUBROUTINE sca_deplcrv(Snowcov_area, Snarea_curve, Frac_swe) - IMPLICIT NONE -! Functions - INTRINSIC :: INT, FLOAT -! Arguments - REAL, INTENT(OUT) :: Snowcov_area - REAL, INTENT(IN) :: Snarea_curve(11), Frac_swe -! Local Variables - INTEGER :: idx, jdx - REAL :: af, dify, difx -!*********************************************************************** - IF ( Frac_swe>1.0 ) THEN - Snowcov_area = Snarea_curve(11) - ELSE - - ! get the indices (as integers) of the depletion curve that - ! bracket the given Frac_swe (next highest and next lowest) - idx = INT( 10.0*(Frac_swe+0.2) ) ! [index] - jdx = idx - 1 ! [index] - IF ( idx>11 ) idx = 11 - ! calculate the fraction of the distance (from the next lowest) - ! the given Frac_swe is between the next highest and lowest - ! curve values - af = FLOAT( jdx-1 ) - dify = (Frac_swe*10.0) - af ! [fraction] - ! calculate the difference in snow covered area represented - ! by next highest and lowest curve values - difx = Snarea_curve(idx) - Snarea_curve(jdx) - ! linearly interpolate a snow covered area between those - ! represented by the next highest and lowest curve values - Snowcov_area = Snarea_curve(jdx) + dify*difx - ENDIF - END SUBROUTINE sca_deplcrv - -!*********************************************************************** -! Set all glacier states to 0 -!*********************************************************************** - SUBROUTINE glacr_states_to_zero(Ihru, active_layer_present) - USE PRMS_SNOW, ONLY: Glacr_freeh2o_cap, Glacr_freeh2o_capm, Glacr_pk_def, Glacr_pk_depth, & - & Glacr_layer, Glacr_pk_temp, Ann_tempc, Glacr_pkwater_equiv, Glacr_pk_den, & - & Glacr_pk_ice, Glacr_pkwater_ante, Glacr_freeh2o, Glacr_pss, Glacr_pk_den - IMPLICIT NONE -! Arguments - INTEGER, INTENT(IN) :: Ihru, active_layer_present -! Functions - INTRINSIC ATAN, SNGL -! Local Variables - REAL :: reduce -!*********************************************************************** - IF ( Glacr_layer(Ihru)==0.0 .OR. active_layer_present==0) THEN - Glacr_pk_depth(Ihru) = 1.0D5 - Glacr_pk_temp(Ihru) = 0.0 - Glacr_pk_def(Ihru) = 0.0 - Glacr_freeh2o_capm(Ihru) = 0.0 - reduce = 1.0 - ElSE - Glacr_pk_depth(Ihru) = DBLE(Glacr_layer(Ihru)) - Glacr_pk_temp(Ihru) = Ann_tempc(Ihru) !start at average last year temp like Oerlemans 1992 - IF ( Glacr_pk_temp(Ihru) > 0.0) Glacr_pk_temp(Ihru) = 0.0 - Glacr_freeh2o_capm(Ihru) = Glacr_freeh2o_cap(Ihru) - reduce = 0.8 !if start Glacr_pk_ice too close to Glacr_pk_depth can't grow with energy loss to free water gain - ENDIF - Glacr_pk_den(Ihru) = 0.917 - Glacr_pkwater_equiv(Ihru) = Glacr_pk_den(Ihru)*Glacr_pk_depth(Ihru) - Glacr_pkwater_ante(Ihru) = Glacr_pkwater_equiv(Ihru) - Glacr_pk_ice(Ihru) = reduce*SNGL(Glacr_pkwater_equiv(Ihru)-Glacr_freeh2o(Ihru))/0.9340 !density of pure ice - Glacr_pss(Ihru) = Glacr_pkwater_equiv(Ihru) - - END SUBROUTINE glacr_states_to_zero - -!*********************************************************************** -! snowcomp_restart - write or read snowcomp restart file -!*********************************************************************** - SUBROUTINE snowcomp_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Glacier_flag - USE PRMS_SNOW - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - EXTERNAL check_restart - ! Local Variable - CHARACTER(LEN=8) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Deninv, Denmaxinv, Basin_snowmelt, Basin_pweqv, Basin_snowcov, & - & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal, Basin_glacrb_melt, & - & Basin_snowicecov, Basin_glacrevap - WRITE ( Restart_outunit ) Int_alb - WRITE ( Restart_outunit ) Scrv - WRITE ( Restart_outunit ) Pksv - WRITE ( Restart_outunit ) Snowcov_areasv - WRITE ( Restart_outunit ) Salb - WRITE ( Restart_outunit ) Slst - WRITE ( Restart_outunit ) Lst - WRITE ( Restart_outunit ) Iasw - WRITE ( Restart_outunit ) Iso - WRITE ( Restart_outunit ) Mso - WRITE ( Restart_outunit ) Lso - WRITE ( Restart_outunit ) Albedo - WRITE ( Restart_outunit ) Pk_temp - WRITE ( Restart_outunit ) Pk_den - WRITE ( Restart_outunit ) Pk_def - WRITE ( Restart_outunit ) Pk_ice - WRITE ( Restart_outunit ) Freeh2o - WRITE ( Restart_outunit ) Snowcov_area - WRITE ( Restart_outunit ) Pss - WRITE ( Restart_outunit ) Pst - WRITE ( Restart_outunit ) Snsv - WRITE ( Restart_outunit ) Pk_depth - WRITE ( Restart_outunit ) Pkwater_ante - IF ( Glacier_flag==1 ) THEN - WRITE ( Restart_outunit ) Glacrmelt - WRITE ( Restart_outunit ) Glacr_evap - WRITE ( Restart_outunit ) Glacr_albedo - WRITE ( Restart_outunit ) Glacr_pk_den - WRITE ( Restart_outunit ) Glacr_pk_ice - WRITE ( Restart_outunit ) Glacr_freeh2o - WRITE ( Restart_outunit ) Glacrcov_area - WRITE ( Restart_outunit ) Glacr_pss - WRITE ( Restart_outunit ) Glacr_pst - WRITE ( Restart_outunit ) Glacr_pk_depth - WRITE ( Restart_outunit ) Glacr_pkwater_equiv - WRITE ( Restart_outunit ) Glacr_pkwater_ante - WRITE ( Restart_outunit ) Glacr_pk_temp - WRITE ( Restart_outunit ) Ann_tempc, Yrdays5, Prev_ann_tempc - WRITE ( Restart_outunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp - WRITE ( Restart_outunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow - WRITE ( Restart_outunit ) Glacr_pk_def - WRITE ( Restart_outunit ) Glacrb_melt - WRITE ( Restart_outunit ) Glacr_freeh2o_capm - ENDIF - ELSE - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) Deninv, Denmaxinv, Basin_snowmelt, Basin_pweqv, Basin_snowcov, & - & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal, Basin_glacrb_melt, & - & Basin_snowicecov, Basin_glacrevap - READ ( Restart_inunit ) Int_alb - READ ( Restart_inunit ) Scrv - READ ( Restart_inunit ) Pksv - READ ( Restart_inunit ) Snowcov_areasv - READ ( Restart_inunit ) Salb - READ ( Restart_inunit ) Slst - READ ( Restart_inunit ) Lst - READ ( Restart_inunit ) Iasw - READ ( Restart_inunit ) Iso - READ ( Restart_inunit ) Mso - READ ( Restart_inunit ) Lso - READ ( Restart_inunit ) Albedo - READ ( Restart_inunit ) Pk_temp - READ ( Restart_inunit ) Pk_den - READ ( Restart_inunit ) Pk_def - READ ( Restart_inunit ) Pk_ice - READ ( Restart_inunit ) Freeh2o - READ ( Restart_inunit ) Snowcov_area - READ ( Restart_inunit ) Pss - READ ( Restart_inunit ) Pst - READ ( Restart_inunit ) Snsv - READ ( Restart_inunit ) Pk_depth - READ ( Restart_inunit ) Pkwater_ante - IF ( Glacier_flag==1 ) THEN - READ ( Restart_inunit ) Glacrmelt - READ ( Restart_inunit ) Glacr_evap - READ ( Restart_inunit ) Glacr_albedo - READ ( Restart_inunit ) Glacr_pk_den - READ ( Restart_inunit ) Glacr_pk_ice - READ ( Restart_inunit ) Glacr_freeh2o - READ ( Restart_inunit ) Glacrcov_area - READ ( Restart_inunit ) Glacr_pss - READ ( Restart_inunit ) Glacr_pst - READ ( Restart_inunit ) Glacr_pk_depth - READ ( Restart_inunit ) Glacr_pkwater_equiv - READ ( Restart_inunit ) Glacr_pkwater_ante - READ ( Restart_inunit ) Glacr_pk_temp - READ ( Restart_inunit ) Ann_tempc, Yrdays5, Prev_ann_tempc - READ ( Restart_inunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp - READ ( Restart_inunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow - READ ( Restart_inunit ) Glacr_pk_def - READ ( Restart_inunit ) Glacrb_melt - READ ( Restart_inunit ) Glacr_freeh2o_capm - ENDIF - ENDIF - END SUBROUTINE snowcomp_restart diff --git a/prms/soilzoneCfgim.f90 b/prms/soilzoneCfgim.f90 deleted file mode 100644 index 6ff97d73..00000000 --- a/prms/soilzoneCfgim.f90 +++ /dev/null @@ -1,1875 +0,0 @@ -!*********************************************************************** -! Computes inflows to and outflows from soil zone of each HRU and -! includes inflows from infiltration, groundwater, and upslope HRUs, -! and outflows to gravity drainage, interflow, and surface runoff to -! downslope HRUs; merge of smbal_prms and ssflow_prms with enhancements -! -! Daily accounting for soil zone; -! adds infiltration -! computes et -! computes recharge of soil zone -! computes interflow to stream or cascade -! adjusts storage in soil zone -! sends dunnian runoff to stream or cascade by adding to sroff -! computes drainage to groundwater -!*********************************************************************** - MODULE PRMS_SOILZONE - IMPLICIT NONE -! Local Variables - INTEGER, SAVE :: DBGUNT - CHARACTER(LEN=8), SAVE :: MODNAME - INTEGER, SAVE :: Max_gvrs, Et_type, Pref_flag, Is_land - INTEGER, SAVE, ALLOCATABLE :: Soil2gw(:), Pref_flow_flag(:) - REAL, SAVE, ALLOCATABLE :: Gvr2pfr(:), Swale_limit(:) - REAL, SAVE, ALLOCATABLE :: Soil_lower_stor_max(:) - REAL, SAVE, ALLOCATABLE :: Soil_moist_ante(:), Ssres_stor_ante(:) - REAL, SAVE, ALLOCATABLE :: Grav_dunnian_flow(:), Pfr_dunnian_flow(:) - DOUBLE PRECISION, SAVE :: Last_soil_moist, Last_ssstor -! GSFLOW variables - INTEGER, SAVE, ALLOCATABLE :: Hru_gvr_count(:), Hru_gvr_index(:, :), Hrucheck(:) - REAL, SAVE, ALLOCATABLE :: Replenish_frac(:) - REAL, SAVE, ALLOCATABLE :: It0_soil_rechr(:), It0_soil_moist(:) - REAL, SAVE, ALLOCATABLE :: It0_pref_flow_stor(:), It0_ssres_stor(:) - REAL, SAVE, ALLOCATABLE :: It0_gravity_stor_res(:), It0_sroff(:) - REAL, SAVE, ALLOCATABLE :: It0_slow_stor(:), It0_potet(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: It0_strm_seg_in(:) - DOUBLE PRECISION, SAVE :: It0_basin_soil_moist, It0_basin_ssstor, Basin_sz_gwin - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Gvr_hru_pct_adjusted(:) -! Declared Variables - DOUBLE PRECISION, SAVE :: Basin_sz2gw, Basin_cap_infil_tot - DOUBLE PRECISION, SAVE :: Basin_interflow_max, Basin_sm2gvr_max ! this is the same as basin_sm2gvr - DOUBLE PRECISION, SAVE :: Basin_soil_rechr, Basin_dunnian_gvr - DOUBLE PRECISION, SAVE :: Basin_recharge, Basin_pref_flow_infil - DOUBLE PRECISION, SAVE :: Basin_ssin, Basin_dunnian_pfr - DOUBLE PRECISION, SAVE :: Basin_sm2gvr, Basin_dninterflow - DOUBLE PRECISION, SAVE :: Basin_dncascadeflow, Basin_dndunnianflow - DOUBLE PRECISION, SAVE :: Basin_capwaterin, Basin_dunnian - DOUBLE PRECISION, SAVE :: Basin_gvr2pfr, Basin_slowflow - DOUBLE PRECISION, SAVE :: Basin_pref_stor, Basin_slstor, Basin_prefflow - DOUBLE PRECISION, SAVE :: Basin_lakeinsz, Basin_lakeprecip - DOUBLE PRECISION, SAVE :: Basin_cap_up_max - DOUBLE PRECISION, SAVE :: Basin_soil_moist_tot - DOUBLE PRECISION, SAVE :: Basin_soil_lower_stor_frac, Basin_soil_rechr_stor_frac, Basin_sz_stor_frac - DOUBLE PRECISION, SAVE :: Basin_cpr_stor_frac, Basin_gvr_stor_frac, Basin_pfr_stor_frac - REAL, SAVE, ALLOCATABLE :: Perv_actet(:), Pref_flow_thrsh(:) - REAL, SAVE, ALLOCATABLE :: Soil_moist_tot(:), Recharge(:) - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Upslope_interflow(:), Upslope_dunnianflow(:), Lakein_sz(:) - REAL, SAVE, ALLOCATABLE :: Dunnian_flow(:), Cap_infil_tot(:) - REAL, SAVE, ALLOCATABLE :: Pref_flow_stor(:), Pref_flow(:) - REAL, SAVE, ALLOCATABLE :: Pref_flow_infil(:), Pref_flow_in(:) - REAL, SAVE, ALLOCATABLE :: Hru_sz_cascadeflow(:), Swale_actet(:) - REAL, SAVE, ALLOCATABLE :: Pref_flow_max(:), Snow_free(:) - REAL, SAVE, ALLOCATABLE :: Cap_waterin(:), Soil_lower(:), Soil_zone_max(:) - REAL, SAVE, ALLOCATABLE :: Potet_lower(:), Potet_rechr(:), Soil_lower_ratio(:) - REAL, SAVE, ALLOCATABLE :: Unused_potet(:) -! REAL, SAVE, ALLOCATABLE :: Cascade_interflow(:), Cascade_dunnianflow(:), Interflow_max(:) -! REAL, SAVE, ALLOCATABLE :: Cpr_stor_frac(:), Pfr_stor_frac(:), Gvr_stor_frac(:), Soil_moist_frac(:) -! REAL, SAVE, ALLOCATABLE :: Soil_rechr_ratio(:), Snowevap_aet_frac(:), Perv_avail_et(:), Cap_upflow_max(:) -! GSFLOW Declared Variables - DOUBLE PRECISION, SAVE :: Basin_gvr2sm - REAL, SAVE, ALLOCATABLE :: Sm2gw_grav(:), Gw2sm_grav(:) - REAL, SAVE, ALLOCATABLE :: Gravity_stor_res(:), Gvr2sm(:), Grav_gwin(:) -! Declared Parameters - INTEGER, SAVE, ALLOCATABLE :: Soil_type(:), Gvr_hru_id(:) - REAL, SAVE, ALLOCATABLE :: Pref_flow_den(:) - REAL, SAVE, ALLOCATABLE :: Fastcoef_lin(:), Fastcoef_sq(:) - REAL, SAVE, ALLOCATABLE :: Slowcoef_lin(:), Slowcoef_sq(:) - REAL, SAVE, ALLOCATABLE :: Ssr2gw_rate(:), Ssr2gw_exp(:) - REAL, SAVE, ALLOCATABLE :: Soil2gw_max(:) - REAL, SAVE, ALLOCATABLE :: Lake_evap_adj(:, :) - END MODULE PRMS_SOILZONE - -!*********************************************************************** -! Main soilzone routine -!*********************************************************************** - INTEGER FUNCTION soilzone() - USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: szdecl, szinit, szrun - EXTERNAL :: soilzone_restart -!*********************************************************************** - soilzone = 0 - - IF ( Process(:3)=='run' ) THEN - soilzone = szrun() - ELSEIF ( Process(:4)=='decl' ) THEN - soilzone = szdecl() - ELSEIF ( Process(:4)=='init' ) THEN - IF ( Init_vars_from_file>0 ) CALL soilzone_restart(1) - soilzone = szinit() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL soilzone_restart(0) - ENDIF - - END FUNCTION soilzone - -!*********************************************************************** -! szdecl - set up parameters for soil zone computations -! Declared Parameters -! sat_threshold, ssstor_init_frac fastcoef_lin, fastcoef_sq -! ssr2gw_rate, ssr2gw_exp, soil2gw_max, soil_type -! soil_rechr_max_frac, soil_rechr_init_frac, soil_moist_max, soil_moist_init_frac -! pref_flow_den, slowcoef_lin, cov_type -! hru_area, slowcoef_sq, gvr_hru_id -!*********************************************************************** - INTEGER FUNCTION szdecl() - USE PRMS_SOILZONE - USE PRMS_MODULE, ONLY: Model, Nhru, Nsegment, Nlake, Nhrucell, Print_debug, Cascade_flag, GSFLOW_flag - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: declparam, declvar, getdim - EXTERNAL :: read_error, print_module, PRMS_open_module_file -! Local Variables - CHARACTER(LEN=80), SAVE :: Version_soilzone -!*********************************************************************** - szdecl = 0 - - Version_soilzone = 'soilzone.f90 2019-03-05 11:11:00Z' - CALL print_module(Version_soilzone, 'Soil Zone Computations ', 90 ) - MODNAME = 'soilzone' - -! Declare Variables - IF ( declvar(MODNAME, 'basin_capwaterin', 'one', 1, 'double', & - & 'Basin area-weighted average infiltration,'// & - & ' cascading interflow and Dunnian flow added to capillary reservoir storage', & - & 'inches', Basin_capwaterin)/=0 ) CALL read_error(3, 'basin_capwaterin') - - IF ( declvar(MODNAME, 'basin_cap_infil_tot', 'one', 1, 'double', & - & 'Basin area-weighted average infiltration with cascading flow into capillary reservoirs', & - & 'inches', Basin_cap_infil_tot)/=0 ) CALL read_error(3, 'basin_cap_infil_tot') - - IF ( declvar(MODNAME, 'basin_cap_up_max', 'one', 1, 'double', & - & 'Basin area-weighted average maximum cascade flow that flows to capillary reservoirs', & - & 'inches', Basin_cap_up_max)/=0 ) CALL read_error(3, 'basin_cap_up_max') - - IF ( declvar(MODNAME, 'basin_pref_flow_infil', 'one', 1, 'double', & - & 'Basin area-weighted average infiltration to preferential-flow reservoir storage', & - & 'inches', Basin_pref_flow_infil)/=0 ) CALL read_error(3, 'basin_pref_flow_infil') - - IF ( declvar(MODNAME, 'basin_dunnian_pfr', 'one', 1, 'double', & - & 'Basin area-weighted average excess infiltration to'// & - & ' preferential-flow reservoirs from variable infil', & - & 'inches', Basin_dunnian_pfr)/=0 ) CALL read_error(3, 'basin_dunnian_pfr') - - IF ( declvar(MODNAME, 'basin_dunnian_gvr', 'one', 1, 'double', & - & 'Basin area-weighted average excess flow to preferential'// & - & '-flow reservoirs from gravity reservoirs', & - & 'inches', Basin_dunnian_gvr)/=0 ) CALL read_error(3, 'basin_dunnian_gvr') - - ALLOCATE ( Cap_infil_tot(Nhru) ) - IF ( declvar(MODNAME, 'cap_infil_tot', 'nhru', Nhru, 'real', & - & 'Infiltration and cascading interflow and Dunnian'// & - & ' flow added to capillary reservoir storage for each HRU', & - & 'inches', Cap_infil_tot)/=0 ) CALL read_error(3, 'cap_infil_tot') - - IF ( declvar(MODNAME, 'basin_soil_moist_tot', 'one', 1, 'double', & - & 'Basin area-weighted average total soil-zone water storage', & - & 'inches', Basin_soil_moist_tot)/=0 ) CALL read_error(3, 'basin_soil_moist_tot') - - ALLOCATE ( Soil_moist_tot(Nhru) ) - IF ( declvar(MODNAME, 'soil_moist_tot', 'nhru', Nhru, 'real', & - & 'Total soil-zone water storage (soil_moist + ssres_stor)', & - & 'inches', Soil_moist_tot)/=0 ) CALL read_error(3, 'soil_moist_tot') - - IF ( declvar(MODNAME, 'basin_cpr_stor_frac', 'one', 1, 'double', & - & 'Basin area-weighted average fraction of capillary reservoir storage of the maximum storage', & - & 'decimal fraction', Basin_cpr_stor_frac)/=0 ) CALL read_error(3, 'basin_cpr_stor_frac') - - IF ( declvar(MODNAME, 'basin_gvr_stor_frac', 'one', 1, 'double', & - & 'Basin area-weighted average fraction of gravity reservoir storage of the maximum storage', & - & 'decimal fraction', Basin_gvr_stor_frac)/=0 ) CALL read_error(3, 'basin_gvr_stor_frac') - - IF ( declvar(MODNAME, 'basin_pfr_stor_frac', 'one', 1, 'double', & - & 'Basin area-weighted average fraction of preferential-flow reservoir storage of the maximum storage', & - & 'decimal fraction', Basin_pfr_stor_frac)/=0 ) CALL read_error(3, 'basin_pfr_stor_frac') - - IF ( declvar(MODNAME, 'basin_soil_lower_stor_frac', 'one', 1, 'double', & - & 'Basin area-weighted average fraction of soil lower zone storage of the maximum storage', & - & 'decimal fraction', Basin_soil_lower_stor_frac)/=0 ) CALL read_error(3, 'basin_soil_lower_stor_frac') - - IF ( declvar(MODNAME, 'basin_soil_rechr_stor_frac', 'one', 1, 'double', & - & 'Basin area-weighted average fraction of soil recharge zone storage of the maximum storage', & - & 'decimal fraction', Basin_soil_rechr_stor_frac)/=0 ) CALL read_error(3, 'basin_soil_rechr_stor_frac') - - IF ( declvar(MODNAME, 'basin_sz_stor_frac', 'one', 1, 'double', & - & 'Basin area-weighted average fraction of soil zone storage of the maximum storage', & - & 'decimal fraction', Basin_sz_stor_frac)/=0 ) CALL read_error(3, 'basin_sz_stor_frac') - -! ALLOCATE ( Cpr_stor_frac(Nhru) ) -! IF ( declvar(MODNAME, 'cpr_stor_frac', 'nhru', Nhru, 'real', & -! & 'Fraction of capillary reservoir storage of the maximum storage for each HRU', & -! & 'decimal fraction', Cpr_stor_frac)/=0 ) CALL read_error(3, 'cpr_stor_frac') - -! ALLOCATE ( Pfr_stor_frac(Nhru) ) -! IF ( declvar(MODNAME, 'pfr_stor_frac', 'nhru', Nhru, 'real', & -! & 'Fraction of preferential flow reservoir storage of the maximum storage for each HRU', & -! & 'decimal fraction', Pfr_stor_frac)/=0 ) CALL read_error(3, 'pfr_stor_frac') - -! ALLOCATE ( Gvr_stor_frac(Nhru) ) -! IF ( declvar(MODNAME, 'gvr_stor_frac', 'nhru', Nhru, 'real', & -! & 'Fraction of gravity reservoir storage of the maximum storage for each HRU', & -! & 'decimal fraction', Gvr_stor_frac)/=0 ) CALL read_error(3, 'gvr_stor_frac') - -! ALLOCATE ( Soil_moist_frac(Nhru) ) -! IF ( declvar(MODNAME, 'soil_moist_frac', 'nhru', Nhru, 'real', & -! & 'Fraction of soil zone storage of the maximum storage for each HRU', & -! & 'decimal fraction', Soil_moist_frac)/=0 ) CALL read_error(3, 'soil_moist_frac') - - IF ( declvar(MODNAME, 'basin_sm2gvr', 'one', 1, 'double', & - & 'Basin area-weighted average excess flow from'// & - & ' capillary reservoirs to gravity reservoir storage', & - & 'inches', Basin_sm2gvr)/=0 ) CALL read_error(3, 'basin_sm2gvr') - - IF ( declvar(MODNAME, 'basin_gvr2pfr', 'one', 1, 'double', & - & 'Basin area-weighted average excess flow to'// & - & ' preferential-flow reservoir storage from gravity reservoirs', & - & 'inches', Basin_gvr2pfr)/=0 ) CALL read_error(3, 'basin_gvr2pfr') - - IF ( declvar(MODNAME, 'basin_slowflow', 'one', 1, 'double', & - & 'Basin area-weighted average interflow from gravity reservoirs to the stream network', & - & 'inches', Basin_slowflow)/=0 ) CALL read_error(3, 'basin_slowflow') - - IF ( declvar(MODNAME, 'basin_prefflow', 'one', 1, 'double', & - & 'Basin area-weighted average interflow from'// & - & ' preferential-flow reservoirs to the stream network', & - & 'inches', Basin_prefflow)/=0 ) CALL read_error(3, 'basin_prefflow') - - IF ( declvar(MODNAME, 'basin_slstor', 'one', 1, 'double', & - & 'Basin area-weighted average storage of gravity reservoirs', & - & 'inches', Basin_slstor)/=0 ) CALL read_error(3, 'basin_slstor') - - ALLOCATE ( Dunnian_flow(Nhru) ) - IF ( declvar(MODNAME, 'dunnian_flow', 'nhru', Nhru, 'real', & - & 'Dunnian surface runoff that flows to the stream network for each HRU', & - & 'inches', Dunnian_flow)/=0 ) CALL read_error(3, 'dunnian_flow') - - IF ( declvar(MODNAME, 'basin_dunnian', 'one', 1, 'double', & - & 'Basin area-weighted average Dunnian surface runoff that flows to the stream network', & - & 'inches', Basin_dunnian)/=0 ) CALL read_error(3, 'basin_dunnian') - - IF ( declvar(MODNAME, 'basin_soil_rechr', 'one', 1, 'double', & - & 'Basin area-weighted average storage for recharge zone;'// & - & ' upper portion of capillary reservoir where both'// & - & ' evaporation and transpiration occurs', & - & 'inches', Basin_soil_rechr)/=0 ) CALL read_error(3, 'basin_soil_rechr') - - IF ( declvar(MODNAME, 'basin_sz2gw', 'one', 1, 'double', & - & 'Basin area-weighted average drainage from gravity reservoirs to GWRs', & - & 'inches', Basin_sz2gw)/=0 ) CALL read_error(3, 'basin_sz2gw') - - ALLOCATE ( Pref_flow_in(Nhru) ) - IF ( declvar('soilzone', 'pref_flow_in', 'nhru', Nhru, 'real', & - & 'Infiltration and flow from gravity reservoir to the preferential-flow reservoir', & - & 'inches', Pref_flow_in)/=0 ) CALL read_error(3, 'pref_flow_in') - - IF ( declvar(MODNAME, 'basin_sm2gvr_maxin', 'one', 1, 'double', & - & 'Basin area-weighted average maximum excess flow from'// & - & ' capillary reservoirs that flows to gravity reservoirs', & - & 'inches', Basin_sm2gvr_max)/=0 ) CALL read_error(3, 'basin_sm2gvr_max') - - IF ( declvar(MODNAME, 'basin_interflow_max', 'one', 1, 'double', & - & 'Basin area-weighted average maximum interflow that flows from gravity reservoirs', & - & 'inches', Basin_interflow_max)/=0 ) CALL read_error(3, 'basin_interflow_max') - - ALLOCATE ( Perv_actet(Nhru) ) - IF ( declvar(MODNAME, 'perv_actet', 'nhru', Nhru, 'real', & - & 'Actual ET from the capillary reservoir of each HRU', & - & 'inches', Perv_actet)/=0 ) CALL read_error(3, 'perv_actet') - -! ALLOCATE ( Perv_avail_et(Nhru) ) -! IF ( declvar(MODNAME, 'perv_avail_et', 'nhru', Nhru, 'real', & -! & 'Unsatisfied ET available to the capillary reservoir of each HRU', & -! & 'inches', Perv_avail_et)/=0 ) CALL read_error(3, 'perv_avail_et') - - ! added to be compatible with ssflow_prms - IF ( declvar(MODNAME, 'basin_ssin', 'one', 1, 'double', & - & 'Basin area-weighted average inflow to gravity and preferential-flow reservoir storage', & - & 'inches', Basin_ssin)/=0 ) CALL read_error(3, 'basin_ssin') - -! ALLOCATE ( Interflow_max(Nhru) ) -! IF ( declvar(MODNAME, 'interflow_max', 'nhru', Nhru, 'real', & -! & 'Maximum interflow for each HRU', & -! & 'inches', Interflow_max)/=0 ) CALL read_error(3, 'interflow_max') - - IF ( Cascade_flag>0 .OR. Model==99 ) THEN - IF ( declvar(MODNAME, 'basin_dndunnianflow', 'one', 1, 'double', & - & 'Basin area-weighted average cascading Dunnian flow', & - & 'inches', Basin_dndunnianflow)/=0 ) CALL read_error(3, 'basin_dndunnianflow') - - IF ( declvar(MODNAME, 'basin_dninterflow', 'one', 1, 'double', & - & 'Basin area-weighted average cascading interflow', & - & 'inches', Basin_dninterflow)/=0 ) CALL read_error(3, 'basin_dninterflow') - - IF ( declvar(MODNAME, 'basin_dncascadeflow', 'one', 1, 'double', & - & 'Basin area-weighted average cascading interflow and Dunnian surface runoff', & - & 'inches', Basin_dncascadeflow)/=0 ) CALL read_error(3, 'basin_dncascadeflow') - - ALLOCATE ( Upslope_interflow(Nhru) ) - IF ( declvar(MODNAME, 'upslope_interflow', 'nhru', Nhru, 'double', & - & 'Cascading interflow runoff that flows to'// & - & ' the capillary reservoir of each downslope HRU for each upslope HRU', & - & 'inches', Upslope_interflow)/=0 ) CALL read_error(3, 'upslope_interflow') - - ALLOCATE ( Upslope_dunnianflow(Nhru) ) - IF ( declvar(MODNAME, 'upslope_dunnianflow', 'nhru', Nhru, 'double', & - & 'Cascading Dunnian surface runoff that'// & - & ' flows to the capillary reservoir of each downslope HRU for each upslope HRU', & - & 'inches', Upslope_dunnianflow)/=0 ) CALL read_error(3, 'upslope_dunnianflow') - - ALLOCATE ( Hru_sz_cascadeflow(Nhru) ) - IF ( declvar(MODNAME, 'hru_sz_cascadeflow', 'nhru', Nhru, 'real', & - & 'Cascading interflow and Dunnian surface runoff from each HRU', & - & 'inches', Hru_sz_cascadeflow)/=0 ) CALL read_error(3, 'hru_sz_cascadeflow') - -! ALLOCATE ( Cap_upflow_max(Nhru) ) -! IF ( declvar(MODNAME, 'cap_upflow_max', 'nhru', Nhru, 'real', & -! & 'Maximum infiltration and any cascading interflow and'// & -! & ' Dunnian surface runoff that can be added to capillary reservoir storage for each HRU', & -! & 'inches', Cap_upflow_max)/=0 ) CALL read_error(3, 'cap_upflow_max') - -! ALLOCATE ( Cascade_interflow(Nhru) ) -! IF ( declvar(MODNAME, 'cascade_interflow', 'nhru', Nhru, 'real', & -! & 'Cascading interflow for each HRU', & -! & 'inches', Cascade_interflow)/=0 ) CALL read_error(3, 'cascade_interflow') - -! ALLOCATE ( Cascade_dunnianflow(Nhru) ) -! IF ( declvar(MODNAME, 'cascade_dunnianflow', 'nhru', Nhru, 'real', & -! & 'Cascading Dunnian flow for each HRU', & -! & 'inches', Cascade_dunnianflow)/=0 ) CALL read_error(3, 'cascade_dunnianflow') - - IF ( Nlake>0 ) THEN - ALLOCATE ( Lakein_sz(Nhru) ) - IF ( declvar(MODNAME, 'lakein_sz', 'nhru', Nhru, 'double', & - & 'Cascading interflow and Dunnian surface runoff to lake HRUs for each upslope HRU', & - & 'inches', Lakein_sz)/=0 ) CALL read_error(3, 'lakein_sz') - - IF ( declvar(MODNAME, 'basin_lakeinsz', 'one', 1, 'double', & - & 'Basin area-weighted average lake inflow from land HRUs', & - & 'inches', Basin_lakeinsz)/=0 ) CALL read_error(3, 'basin_lakeinsz') - ENDIF - ENDIF - - IF ( declvar(MODNAME, 'basin_pref_stor', 'one', 1, 'double', & - & 'Basin area-weighted average storage in preferential-flow reservoirs', & - & 'inches', Basin_pref_stor)/=0 ) CALL read_error(3, 'basin_pref_stor') - - ALLOCATE ( Pref_flow_infil(Nhru) ) - IF ( declvar(MODNAME, 'pref_flow_infil', 'nhru', Nhru, 'real', & - & 'Infiltration to the preferential-flow reservoir storage for each HRU', & - & 'inches', Pref_flow_infil)/=0 ) CALL read_error(3, 'pref_flow_infil') - - ALLOCATE ( Pref_flow_stor(Nhru) ) - IF ( declvar(MODNAME, 'pref_flow_stor', 'nhru', Nhru, 'real', & - & 'Storage in preferential-flow reservoir for each HRU', & - & 'inches', Pref_flow_stor)/=0 ) CALL read_error(3, 'pref_flow_stor') - - ALLOCATE ( Pref_flow(Nhru) ) - IF ( declvar(MODNAME, 'pref_flow', 'nhru', Nhru, 'real', & - & 'Interflow from the preferential-flow reservoir that'// & - & ' flows to the stream network for each HRU', & - & 'inches', Pref_flow)/=0 ) CALL read_error(3, 'pref_flow') - - ALLOCATE ( Pref_flow_thrsh(Nhru) ) - IF ( declvar(MODNAME, 'pref_flow_thrsh', 'nhru', Nhru, 'real', & - & 'Soil storage threshold defining storage between field'// & - & ' capacity and maximum soil saturation minus preferential-flow storage', & - & 'inches', Pref_flow_thrsh)/=0 ) CALL read_error(3, 'pref_flow_thrsh') - - ALLOCATE ( Pref_flow_max(Nhru) ) - IF ( declvar(MODNAME, 'pref_flow_max', 'nhru', Nhru, 'real', & - & 'Maximum storage of the preferential-flow reservoir for each HRU', & - & 'inches', Pref_flow_max)/=0 ) CALL read_error(3, 'pref_flow_max') - - ALLOCATE ( Soil_zone_max(Nhru) ) -! IF ( declvar(MODNAME, 'soil_zone_max', 'nhru', Nhru, 'real', & -! & 'Maximum storage of all soil zone reservoirs', & -! & 'inches', Soil_zone_max)/=0 ) CALL read_error(3, 'soil_zone_max') - - IF ( declvar(MODNAME, 'basin_lakeprecip', 'one', 1, 'double', & - & 'Basin area-weighted average precipitation on lake HRUs', & - & 'inches', Basin_lakeprecip)/=0 ) CALL read_error(3, 'basin_lakeprecip') - - ALLOCATE ( Swale_actet(Nhru) ) - IF ( declvar(MODNAME, 'swale_actet', 'nhru', Nhru, 'real', & - & 'Evaporation from the gravity and preferential-flow reservoirs that exceeds sat_threshold', & - & 'inches', Swale_actet)/=0 ) CALL read_error(3, 'swale_actet') - - IF ( declvar(MODNAME, 'basin_recharge', 'one', 1, 'double', & - & 'Basin area-weighted average recharge to GWRs', & - & 'inches', Basin_recharge)/=0 ) CALL read_error(3, 'basin_recharge') - - ALLOCATE ( Recharge(Nhru) ) - IF ( declvar(MODNAME, 'recharge', 'nhru', Nhru, 'real', & - & 'Recharge to the associated GWR as sum of soil_to_gw and ssr_to_gw for each HRU', & - & 'inches', Recharge)/=0 ) CALL read_error(3, 'recharge') - - ALLOCATE ( Cap_waterin(Nhru) ) - IF ( declvar(MODNAME, 'cap_waterin', 'nhru', Nhru, 'real', & - & 'Infiltration and any cascading interflow and'// & - & ' Dunnian surface runoff added to capillary reservoir storage for each HRU', & - & 'inches', Cap_waterin)/=0 ) CALL read_error(3, 'cap_waterin') - - ALLOCATE ( Soil_lower(Nhru) ) - IF ( declvar(MODNAME, 'soil_lower', 'nhru', Nhru, 'real', & - & 'Storage in the lower zone of the capillary'// & - & ' reservoir that is only available for transpiration for each HRU', & - & 'inches', Soil_lower)/=0 ) CALL read_error(3, 'soil_lower') - - ALLOCATE ( Potet_lower(Nhru) ) - IF ( declvar(MODNAME, 'potet_lower', 'nhru', Nhru, 'real', & - & 'Potential ET in the lower zone of the capillary reservoir for each HRU', & - & 'inches', Potet_lower)/=0 ) CALL read_error(3, 'potet_lower') - - ALLOCATE ( Potet_rechr(Nhru) ) - IF ( declvar(MODNAME, 'potet_rechr', 'nhru', Nhru, 'real', & - & 'Potential ET in the recharge zone of the capillary reservoir for each HRU', & - & 'inches', Potet_rechr)/=0 ) CALL read_error(3, 'potet_rechr') - - ALLOCATE ( Soil_lower_ratio(Nhru), Soil_lower_stor_max(Nhru) ) - IF ( declvar(MODNAME, 'soil_lower_ratio', 'nhru', Nhru, 'real', & - & 'Water content ratio in the lower zone of the capillary reservoir for each HRU', & - & 'decimal fraction', Soil_lower_ratio)/=0 ) CALL read_error(3, 'soil_lower_ratio') - -! ALLOCATE ( Soil_rechr_ratio(Nhru) ) -! IF ( declvar(MODNAME, 'soil_rechr_ratio', 'nhru', Nhru, 'real', & -! & 'Water content ratio in the recharge zone of the capillary reservoir for each HRU', & -! & 'decimal fraction', Soil_rechr_ratio)/=0 ) CALL read_error(3, 'soil_rechr_ratio') - - ALLOCATE ( Snow_free(Nhru) ) - IF ( declvar(MODNAME, 'snow_free', 'nhru', Nhru, 'real', & - & 'Fraction of snow-free surface for each HRU', & - & 'decimal fraction', Snow_free)/=0 ) CALL read_error(3, 'snow_free') - - ALLOCATE ( Unused_potet(Nhru) ) - IF ( declvar(MODNAME, 'unused_potet', 'nhru', Nhru, 'real', & - & 'Unsatisfied potential evapotranspiration', & - & 'inches', Unused_potet)/=0 ) CALL read_error(3, 'unused_potet') - -! ALLOCATE ( Snowevap_aet_frac(Nhru) ) -! IF ( declvar(MODNAME, 'snowevap_aet_frac', 'nhru', Nhru, 'double', & -! & 'Fraction of sublimation of AET for each HRU', & -! & 'decimal fraction', Snowevap_aet_frac)/=0 ) CALL read_error(3, 'snowevap_aet_frac') - - IF ( GSFLOW_flag==1 .OR. Model==99 ) THEN - IF ( Nhrucell<-1 ) STOP 'ERROR, dimension nhrucell not specified > 0' - ALLOCATE ( Gravity_stor_res(Nhrucell) ) - IF ( declvar(MODNAME, 'gravity_stor_res', 'nhrucell', Nhrucell, 'real', & - & 'Storage in each gravity-flow reservoir', & - & 'inches', Gravity_stor_res)/=0 ) CALL read_error(3, 'gravity_stor_res') - - ALLOCATE ( Sm2gw_grav(Nhrucell) ) - IF ( declvar(MODNAME, 'sm2gw_grav', 'nhrucell', Nhrucell, 'real', & - & 'Drainage from each gravity reservoir to each MODFLOW cell', & - & 'inches', Sm2gw_grav)/=0 ) CALL read_error(3, 'sm2gw_grav') - - IF ( declvar(MODNAME, 'basin_gvr2sm', 'one', 1, 'double', & - & 'Basin area-weighted average gravity flow to capillary reservoirs', & - & 'inches', Basin_gvr2sm)/=0 ) CALL read_error(3, 'basin_gvr2sm') - - ALLOCATE ( Gvr2sm(Nhru) ) - IF ( declvar(MODNAME, 'gvr2sm', 'nhru', Nhru, 'real', & - & 'Gravity flow to soil moist replenishment for each HRU', & - & 'inches', Gvr2sm)/=0 ) CALL read_error(3, 'gvr2sm') - - ALLOCATE ( Gw2sm_grav(Nhrucell) ) - IF ( declvar(MODNAME, 'gw2sm_grav', 'nhrucell', Nhrucell, 'real', & - & 'Groundwater discharge to gravity-flow reservoirs', & - & 'inches', Gw2sm_grav)/=0 ) CALL read_error(3, 'gw2sm_grav') - - ALLOCATE ( Grav_gwin(Nhru) ) ! ??? - IF ( declvar(MODNAME, 'grav_gwin', 'nhru', Nhru, 'real', & - & 'Groundwater discharge to gravity-flow reservoirs for each HRU', & - & 'inches', Grav_gwin)/=0 ) CALL read_error(3, 'grav_gwin') - - ALLOCATE ( Gvr_hru_pct_adjusted(Nhrucell) ) - ALLOCATE ( Hru_gvr_count(Nhru), Hrucheck(Nhru) ) - ALLOCATE ( It0_pref_flow_stor(Nhru), It0_ssres_stor(Nhru), It0_soil_rechr(Nhru), It0_soil_moist(Nhru) ) - ALLOCATE ( It0_gravity_stor_res(Nhrucell), It0_sroff(Nhru), It0_slow_stor(Nhru) ) - ALLOCATE ( It0_strm_seg_in(Nsegment), It0_potet(Nhru), Replenish_frac(Nhru) ) - ENDIF - -! Allocate arrays for local and variables from other modules - ALLOCATE ( Soil2gw(Nhru), Gvr2pfr(Nhru), Swale_limit(Nhru), Pref_flow_flag(Nhru) ) - ALLOCATE ( Pfr_dunnian_flow(Nhru), Grav_dunnian_flow(Nhru) ) - IF ( Print_debug==1 ) ALLOCATE( Soil_moist_ante(Nhru), Ssres_stor_ante(Nhru) ) - - IF ( Print_debug==7 ) CALL PRMS_open_module_file(DBGUNT, 'soilzone.dbg') - -! Declare Parameters - IF ( GSFLOW_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Gvr_hru_id(Nhrucell) ) - IF ( Nhru/=Nhrucell ) THEN - IF ( declparam(MODNAME, 'gvr_hru_id', 'nhrucell', 'integer', & - & '0', 'bounded', 'nhru', & - & 'Corresponding HRU id of each GVR', & - & 'Index of the HRU associated with each gravity reservoir', & - & 'none')/=0 ) CALL read_error(1, 'gvr_hru_id') - ENDIF - ENDIF - - IF ( Nlake>0 ) THEN - ALLOCATE ( Lake_evap_adj(12,Nlake) ) - IF ( declparam(MODNAME, 'lake_evap_adj', 'nmonths,nlake', & - & 'real', '1.0', '0.5', '1.0', & - & 'Monthly potet factor to adjust potet on lakes', & - & 'Monthly (January to December) adjustment factor for potential ET for each lake', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'lake_evap_adj') - ENDIF - - ALLOCATE ( Slowcoef_lin(Nhru) ) - IF ( declparam(MODNAME, 'slowcoef_lin', 'nhru', 'real', & - & '0.015', '0.0', '1.0', & - & 'Linear gravity-flow reservoir routing coefficient', & - & 'Linear coefficient in equation to route gravity-reservoir storage downslope for each HRU', & - & 'fraction/day')/=0 ) CALL read_error(1, 'slowcoef_lin') - - ALLOCATE ( Slowcoef_sq(Nhru) ) - IF ( declparam(MODNAME, 'slowcoef_sq', 'nhru', 'real', & - & '0.1', '0.0', '1.0', & - & 'Non-linear gravity-flow reservoir routing coefficient', & - & 'Non-linear coefficient in equation to route'// & - & ' gravity-reservoir storage downslope for each HRU', & - & 'none')/=0 ) CALL read_error(1, 'slowcoef_sq') - - ALLOCATE ( Pref_flow_den(Nhru) ) - IF ( declparam(MODNAME, 'pref_flow_den', 'nhru', 'real', & - & '0.0', '0.0', '0.5', & - & 'Fraction of the soil zone in which preferential flow occurs for each HRU', & - & 'Fraction of the soil zone in which preferential flow occurs for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1,'pref_flow_den') - - ALLOCATE ( Soil2gw_max(Nhru) ) - IF ( declparam(MODNAME, 'soil2gw_max', 'nhru', 'real', & - & '0.0', '0.0', '5.0', & - & 'Maximum value for capillary reservoir excess to GWR', & - & 'Maximum amount of the capillary reservoir excess that'// & - & ' is routed directly to the GWR for each HRU', & - & 'inches')/=0 ) CALL read_error(1, 'soil2gw_max') - - ALLOCATE ( Soil_type(Nhru) ) - IF ( declparam(MODNAME, 'soil_type', 'nhru', 'integer', & - & '2', '1', '3', & - & 'HRU soil type', 'Soil type of each HRU (1=sand; 2=loam; 3=clay)', & - & 'none')/=0 ) CALL read_error(1, 'soil_type') - - ALLOCATE ( Fastcoef_lin(Nhru) ) - IF ( declparam(MODNAME, 'fastcoef_lin', 'nhru', 'real', & - & '0.1', '0.0', '1.0', & - & 'Linear preferential-flow routing coefficient', & - & 'Linear coefficient in equation to route preferential-flow storage downslope for each HRU', & - & 'fraction/day')/=0 ) CALL read_error(1, 'fastcoef_lin') - - ALLOCATE ( Fastcoef_sq(Nhru) ) - IF ( declparam(MODNAME, 'fastcoef_sq', 'nhru', 'real', & - & '0.8', '0.0', '1.0', & - & 'Non-linear preferential-flow routing coefficient', & - & 'Non-linear coefficient in equation used to route'// & - & ' preferential-flow storage downslope for each HRU', & - & 'none')/=0 ) CALL read_error(1, 'fastcoef_sq') - - ALLOCATE ( Ssr2gw_rate(Nhru) ) - IF ( declparam(MODNAME, 'ssr2gw_rate', 'nssr', 'real', & - & '0.1', '0.0001', '1.0', & - & 'Coefficient to route water from gravity reservoir to GWR', & - & 'Linear coefficient in equation used to route water from'// & - & ' the gravity reservoir to the GWR for each HRU', & - & 'fraction/day')/=0 ) CALL read_error(1, 'ssr2gw_rate') - - ALLOCATE ( Ssr2gw_exp(Nhru) ) - IF ( declparam(MODNAME, 'ssr2gw_exp', 'nssr', 'real', & - & '1.0', '0.0', '3.0', & - & 'Coefficient to route water from subsurface to groundwater', & - & 'Non-linear coefficient in equation used to route water'// & - & ' from the gravity reservoir to the GWR for each HRU', & - & 'none')/=0 ) CALL read_error(1, 'ssr2gw_exp') - - END FUNCTION szdecl - -!*********************************************************************** -! szinit - Initialize soilzone module - get parameter values, -! set initial values and check parameter values -!*********************************************************************** - INTEGER FUNCTION szinit() - USE PRMS_SOILZONE - USE PRMS_MODULE, ONLY: Nhru, Nssr, Nlake, GSFLOW_flag, Nhrucell, & - & Parameter_check_flag, Cascade_flag, Init_vars_from_file, Inputerror_flag - USE PRMS_BASIN, ONLY: Hru_type, Hru_perv, & - & Basin_area_inv, Hru_area, Hru_frac_perv, Numlake_hrus - USE PRMS_FLOWVARS, ONLY: Soil_moist_max, Soil_rechr_max, & - & Ssres_stor, Basin_ssstor, Basin_soil_moist, Slow_stor, & - & Soil_moist, Sat_threshold, Soil_rechr - USE PRMS_SNOW, ONLY: Snowcov_area - IMPLICIT NONE -! Functions - EXTERNAL :: init_basin_vars, checkdim_bounded_limits - INTEGER, EXTERNAL :: getparam - INTRINSIC MIN, DBLE -! Local Variables - INTEGER :: i, ii, ihru, icnt - REAL :: hruarea, hruperv -!*********************************************************************** - szinit = 0 - - IF ( getparam(MODNAME, 'slowcoef_lin', Nhru, 'real', Slowcoef_lin)/=0 ) CALL read_error(2, 'slowcoef_lin') - IF ( getparam(MODNAME, 'slowcoef_sq', Nhru, 'real', Slowcoef_sq)/=0 ) CALL read_error(2, 'slowcoef_sq') - IF ( getparam(MODNAME, 'pref_flow_den', Nhru, 'real', Pref_flow_den)/=0 ) CALL read_error(2, 'pref_flow_den') - IF ( getparam(MODNAME, 'fastcoef_lin', Nhru, 'real', Fastcoef_lin)/=0 ) CALL read_error(2, 'fastcoef_lin') - IF ( getparam(MODNAME, 'fastcoef_sq', Nhru, 'real', Fastcoef_sq)/=0 ) CALL read_error(2, 'fastcoef_sq') - IF ( getparam(MODNAME, 'ssr2gw_rate', Nssr, 'real', Ssr2gw_rate)/=0 ) CALL read_error(2, 'ssr2gw_rate') - IF ( getparam(MODNAME, 'ssr2gw_exp', Nssr, 'real', Ssr2gw_exp)/=0 ) CALL read_error(2, 'ssr2gw_exp') - IF ( getparam(MODNAME, 'soil_type', Nhru, 'integer', Soil_type)/=0 ) CALL read_error(2, 'soil_type') - IF ( getparam(MODNAME, 'soil2gw_max', Nhru, 'real', Soil2gw_max)/=0 ) CALL read_error(2, 'soil2gw_max') - IF ( Nlake>0 ) THEN - IF ( getparam(MODNAME, 'lake_evap_adj', 12*Nlake, 'real', Lake_evap_adj)/=0 ) CALL read_error(2, 'lake_evap_adj') - ENDIF - - IF ( GSFLOW_flag==1 ) THEN - IF ( Nhru/=Nhrucell ) THEN - IF ( getparam(MODNAME, 'gvr_hru_id', Nhrucell, 'integer', Gvr_hru_id)/=0 ) CALL read_error(2, 'gvr_hru_id') - IF ( Parameter_check_flag==1 ) & - & CALL checkdim_bounded_limits('gvr_hru_id', 'nhru', Gvr_hru_id, Nhrucell, 1, Nhru, Inputerror_flag) - ELSE - DO i = 1, Nhru - Gvr_hru_id(i) = i - ENDDO - ENDIF - Grav_gwin = 0.0 ! dimension nhru - Gw2sm_grav = 0.0 - ENDIF - - Swale_limit = 0.0 - Soil2gw = 0 - Pref_flow_flag = 0 - Pref_flag = 0 - Pfr_dunnian_flow = 0.0 - Grav_dunnian_flow = 0.0 - Soil_lower_ratio = 0.0 - Pref_flow_thrsh = 0.0 - - Basin_soil_moist = 0.0D0 - Basin_slstor = 0.0D0 - Basin_ssstor = 0.0D0 - Basin_pref_stor = 0.0D0 - Basin_soil_rechr = 0.0D0 - Basin_soil_moist_tot = 0.0D0 - Basin_soil_lower_stor_frac = 0.0D0 - Basin_soil_rechr_stor_frac = 0.0D0 - Basin_sz_stor_frac = 0.0D0 - Basin_cpr_stor_frac = 0.0D0 - Basin_gvr_stor_frac = 0.0D0 - Basin_pfr_stor_frac = 0.0D0 -! Pfr_stor_frac = 0.0 -! Gvr_stor_frac = 0.0 -! Cpr_stor_frac = 0.0 -! Soil_moist_frac = 0.0 - - DO i = 1, Nhru - Snow_free(i) = 1.0 - Snowcov_area(i) - - IF ( Hru_type(i)==0 .OR. Hru_type(i)==2 ) THEN !if inactive or lake - Soil_rechr(i) = 0.0 - Soil_moist(i) = 0.0 - Ssres_stor(i) = 0.0 - Slow_stor(i) = 0.0 - Pref_flow_stor(i) = 0.0 - Soil_moist_tot(i) = 0.0 - Soil_lower(i) = 0.0 -! Soil_rechr_ratio(i) = 0.0 - Soil_zone_max(i) = 0.0 - Soil_lower_stor_max(i) = 0.0 - Sat_threshold(i) = 0.0 - Pref_flow_den(i) = 0.0 - Pref_flow_max(i) = 0.0 - CYCLE - ENDIF - - IF ( Hru_type(i)==3 ) THEN ! swale - Swale_limit(i) = 3.0*Sat_threshold(i) - Pref_flow_den(i) = 0.0 - Pref_flow_thrsh(i) = Sat_threshold(i) - Pref_flow_max(i) = 0.0 - ELSE ! land - Pref_flow_thrsh(i) = Sat_threshold(i)*(1.0-Pref_flow_den(i)) - Pref_flow_max(i) = Sat_threshold(i) - Pref_flow_thrsh(i) - ENDIF - - ! hru_type = 1 or 3 - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==5 ) THEN - Slow_stor(i) = MIN( Ssres_stor(i), Pref_flow_thrsh(i) ) - Pref_flow_stor(i) = Ssres_stor(i) - Slow_stor(i) - ENDIF - IF ( Soil2gw_max(i)>0.0 ) Soil2gw(i) = 1 - IF ( Hru_type(i)==1 .OR. Hru_type(i)==4 ) THEN ! interflow coefficient values don't matter unless land HRU - IF ( Pref_flow_den(i)>0.0 ) THEN - Pref_flow_flag(i) = 1 - Pref_flag = 1 - ENDIF - ENDIF - - hruarea = Hru_area(i) - hruperv = Hru_perv(i) - Soil_zone_max(i) = Sat_threshold(i) + Soil_moist_max(i)*Hru_frac_perv(i) - Soil_moist_tot(i) = Ssres_stor(i) + Soil_moist(i)*Hru_frac_perv(i) -! Soil_moist_frac(i) = Soil_moist_tot(i)/Soil_zone_max(i) -! Cpr_stor_frac(i) = Soil_moist(i)/Soil_moist_max(i) -! IF ( Pref_flow_thrsh(i)>0.0 ) Gvr_stor_frac(i) = Slow_stor(i)/Pref_flow_thrsh(i) -! Basin_cpr_stor_frac = Basin_cpr_stor_frac + DBLE( Cpr_stor_frac(i)*hruperv ) -! Basin_gvr_stor_frac = Basin_gvr_stor_frac + DBLE( Gvr_stor_frac(i)*hruarea ) - Basin_cpr_stor_frac = Basin_cpr_stor_frac + DBLE( Soil_moist(i)/Soil_moist_max(i)*hruperv ) - IF ( Pref_flow_thrsh(i)>0.0 ) Basin_gvr_stor_frac = Basin_gvr_stor_frac + DBLE( Slow_stor(i)/Pref_flow_thrsh(i)*hruarea ) - Soil_lower(i) = Soil_moist(i) - Soil_rechr(i) - Soil_lower_stor_max(i) = Soil_moist_max(i) - Soil_rechr_max(i) - IF ( Soil_lower_stor_max(i)>0.0 ) Soil_lower_ratio(i) = Soil_lower(i)/Soil_lower_stor_max(i) -! Soil_rechr_ratio(i) = Soil_rechr(i)/Soil_rechr_max(i) -! Basin_sz_stor_frac = Basin_sz_stor_frac + DBLE( Soil_moist_frac(i)*hruarea ) - Basin_sz_stor_frac = Basin_sz_stor_frac + DBLE( Soil_moist_tot(i)/Soil_zone_max(i)*hruarea ) - Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac + DBLE( Soil_lower_ratio(i)*hruperv ) -! Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + DBLE( Soil_rechr_ratio(i)*hruperv ) - Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + DBLE( Soil_rechr(i)/Soil_rechr_max(i)*hruperv ) - Basin_soil_moist = Basin_soil_moist + DBLE( Soil_moist(i)*Hru_perv(i) ) - Basin_soil_moist_tot = Basin_soil_moist_tot + DBLE( Soil_moist_tot(i)*hruarea ) - ! rsr, 6/12/2014 potential problem for GSFLOW if sum of slow_stor /= gravity_stor_res - Basin_slstor = Basin_slstor + DBLE( Slow_stor(i)*hruarea ) - Basin_ssstor = Basin_ssstor + DBLE( Ssres_stor(i)*hruarea ) - Basin_soil_rechr = Basin_soil_rechr + DBLE( Soil_rechr(i)*hruperv ) - IF ( Pref_flow_flag(i)==1 ) THEN - Basin_pref_stor = Basin_pref_stor + DBLE( Pref_flow_stor(i)*hruarea ) -! Pfr_stor_frac(i) = Pref_flow_stor(i)/Pref_flow_max(i) -! Basin_pfr_stor_frac = Basin_pfr_stor_frac + DBLE( Pfr_stor_frac(i)*hruarea ) - Basin_pfr_stor_frac = Basin_pfr_stor_frac + DBLE( Pref_flow_stor(i)/Pref_flow_max(i)*hruarea ) - ENDIF - ENDDO - Basin_soil_rechr = Basin_soil_rechr*Basin_area_inv - Basin_ssstor = Basin_ssstor*Basin_area_inv - Basin_slstor = Basin_slstor*Basin_area_inv - Basin_soil_moist = Basin_soil_moist*Basin_area_inv - Basin_soil_moist_tot = Basin_soil_moist_tot*Basin_area_inv - Basin_pref_stor = Basin_pref_stor*Basin_area_inv - Last_soil_moist = Basin_soil_moist - Last_ssstor = Basin_ssstor - Basin_cpr_stor_frac = Basin_cpr_stor_frac*Basin_area_inv - Basin_gvr_stor_frac = Basin_gvr_stor_frac*Basin_area_inv - Basin_pfr_stor_frac = Basin_pfr_stor_frac*Basin_area_inv - Basin_sz_stor_frac = Basin_sz_stor_frac*Basin_area_inv - Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac*Basin_area_inv - Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac*Basin_area_inv - -! initialize arrays (dimensioned Nhru) - Dunnian_flow = 0.0 - IF ( Cascade_flag>0 ) THEN - Upslope_interflow = 0.0D0 - Upslope_dunnianflow = 0.0D0 - Hru_sz_cascadeflow = 0.0 -! Cap_upflow_max = 0.0 -! Cascade_interflow = 0.0 -! Cascade_dunnianflow = 0.0 - IF ( Numlake_hrus>0 ) Lakein_sz = 0.0D0 - ENDIF - Cap_infil_tot = 0.0 - Pref_flow_infil = 0.0 - Pref_flow_in = 0.0 - Pref_flow = 0.0 - Gvr2pfr = 0.0 - Swale_actet = 0.0 - Perv_actet = 0.0 -! Perv_avail_et = 0.0 - Recharge = 0.0 - Cap_waterin = 0.0 - Potet_lower = 0.0 - Potet_rechr = 0.0 - Unused_potet = 0.0 ! dimension nhru -! Interflow_max = 0.0 -! Snowevap_aet_frac = 0.0 - - ! initialize scalers - IF ( Init_vars_from_file==0 ) CALL init_basin_vars() - -! initialize GSFLOW arrays - IF ( GSFLOW_flag==1 ) THEN - Gvr2sm = 0.0 ! dimension nhru - Sm2gw_grav = 0.0 ! dimension nhrucell - - Max_gvrs = 1 - Hrucheck = 1 - Hru_gvr_count = 0 - DO i = 1, Nhrucell - ihru = Gvr_hru_id(i) - IF ( Hru_type(ihru)==0 .OR. Hru_type(ihru)==2 ) THEN - Gravity_stor_res(i) = 0.0 - Hrucheck(ihru) = 0 - Replenish_frac(ihru) = 0.0 - ELSE - ! set only for cold start simulations - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==5 ) & - & Gravity_stor_res(i) = Ssres_stor(ihru) - Hru_gvr_count(ihru) = Hru_gvr_count(ihru) + 1 - IF ( Hru_gvr_count(ihru)>Max_gvrs ) Max_gvrs = Hru_gvr_count(ihru) - Replenish_frac(ihru) = Soil_rechr_max(ihru)/Soil_moist_max(ihru) - ENDIF - ENDDO - ALLOCATE ( Hru_gvr_index(Max_gvrs, Nhru) ) - IF ( Nhru==Nhrucell ) THEN - IF ( Max_gvrs/=1 ) THEN - PRINT *, 'ERROR, nhru=nhrucell, but, gvr_hru_id array specifies more than one GVR for an HRU' - STOP - ENDIF - DO i = 1, Nhru - Hru_gvr_index(1, i) = i - ENDDO - ELSE - Hru_gvr_index = 0 - DO i = 1, Nhru - IF ( Hru_type(i)==0 .OR. Hru_type(i)==2 ) CYCLE !if inactive or lake - icnt = 0 - DO ii = 1, Nhrucell - IF ( Gvr_hru_id(ii)==i ) THEN - icnt = icnt + 1 - Hru_gvr_index(icnt, i) = ii - IF ( icnt==Hru_gvr_count(i) ) EXIT - ENDIF - ENDDO - ENDDO - ENDIF - ENDIF - - END FUNCTION szinit - -!*********************************************************************** -! szrun - Does soil water balance for each HRU, adds in infiltration -! then computes actual et and apportions remainder between -! recharge of soil moisture, soil storage available for -! interflow, excess routed to stream, -! and groundwater reservoirs -!*********************************************************************** - INTEGER FUNCTION szrun() - USE PRMS_SOILZONE - USE PRMS_MODULE, ONLY: Dprst_flag, Print_debug, Kkiter, & - & GSFLOW_flag, Nlake, Cascade_flag, Dprst_flag, Frozen_flag - USE PRMS_BASIN, ONLY: Hru_type, Hru_perv, Hru_frac_perv, & - & Hru_route_order, Active_hrus, Basin_area_inv, Hru_area, & - & NEARZERO, Lake_hru_id, Cov_type, Numlake_hrus, Hru_area_dble - USE PRMS_CLIMATEVARS, ONLY: Hru_ppt, Transp_on, Potet, Basin_potet -! WARNING!!! Sroff, Basin_sroff, and Strm_seg_in can be updated - USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_actet, Hru_actet, & - & Ssres_flow, Soil_to_gw, Basin_soil_to_gw, Ssr_to_gw, & - & Soil_to_ssr, Basin_lakeevap, Basin_perv_et, Basin_swale_et, & - & Sroff, Soil_moist_max, Infil, Soil_rechr_max, Ssres_in, & - & Basin_soil_moist, Basin_ssstor, Slow_stor, Slow_flow, & - & Ssres_stor, Soil_moist, Sat_threshold, Soil_rechr, Basin_lake_stor - USE PRMS_CASCADE, ONLY: Ncascade_hru - USE PRMS_SET_TIME, ONLY: Nowmonth !, Nowday - USE PRMS_INTCP, ONLY: Hru_intcpevap - USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap - USE PRMS_SRUNOFF, ONLY: Basin_sroff, Hru_impervevap, Strm_seg_in, Dprst_evap_hru, & - & Dprst_seep_hru, Frozen, Thaw_depth, Frz_depth, Soil_depth - IMPLICIT NONE -! Functions - INTRINSIC MIN, ABS, MAX, SNGL, DBLE - EXTERNAL compute_soilmoist, compute_szactet, compute_cascades, compute_gravflow - EXTERNAL compute_interflow, compute_gwflow, init_basin_vars, print_date -! Local Variables - INTEGER :: i, k, update_potet - REAL :: dunnianflw, interflow, perv_area, harea - REAL :: dnslowflow, dnpreflow, dndunn, availh2o, avail_potet - REAL :: gvr_maxin, topfr !, tmp - REAL :: dunnianflw_pfr, dunnianflw_gvr, pref_flow_maxin - REAL :: perv_frac, capacity, capwater_maxin, ssresin - REAL :: cap_upflow_max, unsatisfied_et, pervactet, prefflow - REAL :: prefflowmax, soilmoistmax, soilrechrmax, thaw_frac ! frozen ground - REAL :: soil2gwmax, ssr2gwrate ! frozen ground - DOUBLE PRECISION :: gwin - INTEGER :: cfgi_frozen_hru -!*********************************************************************** - szrun = 0 - - IF ( GSFLOW_flag==1 ) THEN - IF ( Kkiter==0 ) STOP 'ERROR, problem with KKITER, equals 0' - - IF ( Kkiter==1 ) THEN -! It0 variables used with MODFLOW integration to save iteration states. - DO k = 1, Active_hrus - i = Hru_route_order(k) - It0_soil_rechr(i) = Soil_rechr(i) - It0_soil_moist(i) = Soil_moist(i) - It0_ssres_stor(i) = Ssres_stor(i) - It0_pref_flow_stor(i) = Pref_flow_stor(i) - It0_slow_stor(i) = Slow_stor(i) - It0_sroff(i) = Sroff(i) - It0_potet(i) = Potet(i) - ENDDO - It0_basin_soil_moist = Basin_soil_moist - It0_basin_ssstor = Basin_ssstor - It0_gravity_stor_res = Gravity_stor_res - It0_strm_seg_in = Strm_seg_in - Gw2sm_grav = 0.0 - ELSE - DO k = 1, Active_hrus - i = Hru_route_order(k) - Soil_rechr(i) = It0_soil_rechr(i) - Soil_moist(i) = It0_soil_moist(i) - Ssres_stor(i) = It0_ssres_stor(i) - Pref_flow_stor(i) = It0_pref_flow_stor(i) - Slow_stor(i) = It0_slow_stor(i) - Sroff(i) = It0_sroff(i) - Potet(i) = It0_potet(i) - ENDDO - Basin_soil_moist = It0_basin_soil_moist - Basin_ssstor = It0_basin_ssstor - Gravity_stor_res = It0_gravity_stor_res - Strm_seg_in = It0_strm_seg_in - ENDIF - Sm2gw_grav = 0.0 - ENDIF - - IF ( Cascade_flag>0 ) THEN - DO k = 1, Active_hrus - i = Hru_route_order(k) - Upslope_interflow(i) = 0.0D0 - Upslope_dunnianflow(i) = 0.0D0 - ENDDO - IF ( Numlake_hrus>0 ) THEN - Lakein_sz = 0.0D0 - Basin_lakeinsz = 0.0D0 - ENDIF - ENDIF - - IF ( Print_debug==1 ) THEN - Soil_moist_ante = Soil_moist - Ssres_stor_ante = Ssres_stor - Last_soil_moist = Basin_soil_moist - Last_ssstor = Basin_ssstor - ENDIF - CALL init_basin_vars() - gwin = 0.0D0 - Basin_soil_moist = 0.0D0 - Basin_slstor = 0.0D0 - Basin_ssstor = 0.0D0 - Basin_pref_stor = 0.0D0 - Basin_soil_rechr = 0.0D0 - Basin_soil_moist_tot = 0.0D0 - Basin_cpr_stor_frac = 0.0D0 - Basin_gvr_stor_frac = 0.0D0 - Basin_pfr_stor_frac = 0.0D0 - update_potet = 0 - DO k = 1, Active_hrus - i = Hru_route_order(k) - - Hru_actet(i) = Hru_impervevap(i) + Hru_intcpevap(i) + Snow_evap(i) - IF ( Dprst_flag==1 ) Hru_actet(i) = Hru_actet(i) + Dprst_evap_hru(i) - harea = Hru_area(i) - - IF ( Hru_type(i)==2 ) THEN ! lake or reservoir - !WARNING, RSR, if hru_actet>water in lake, then budget error - Hru_actet(i) = (Potet(i) - Hru_actet(i))*Lake_evap_adj(Nowmonth,Lake_hru_id(i)) - IF ( Hru_actet(i)>Potet(i) ) THEN - PRINT *, 'WARNING, lake evap > potet, for HRU:', i, ' potential ET increased to adjusted lake ET' - PRINT *, Hru_actet(i), Potet(i), Hru_actet(i) - Potet(i) - Basin_potet = Basin_potet - DBLE( Potet(i)*harea ) - Potet(i) = Hru_actet(i) ! this could be a problem when it happens - Basin_potet = Basin_potet + DBLE( Potet(i)*harea ) - update_potet = 1 - ENDIF - Unused_potet(i) = Potet(i) - Hru_actet(i) - Basin_actet = Basin_actet + DBLE( Hru_actet(i)*harea ) - Basin_lakeevap = Basin_lakeevap + DBLE( Hru_actet(i)*harea ) - Basin_lakeprecip = Basin_lakeprecip + DBLE( Hru_ppt(i)*harea ) - IF ( Cascade_flag>0 ) THEN - ! if lake HRU doesn't cascade, should we limit ET to - ! water entering the HRU to this point (no gwflow yet) - Lakein_sz(i) = Upslope_interflow(i) + Upslope_dunnianflow(i) - Basin_lakeinsz = Basin_lakeinsz + Lakein_sz(i)*Hru_area_dble(i) - ENDIF - CYCLE - ENDIF - - perv_area = Hru_perv(i) - perv_frac = Hru_frac_perv(i) - - ! Soil_to_gw for whole HRU - Soil_to_gw(i) = 0.0 - Ssr_to_gw(i) = 0.0 - Slow_flow(i) = 0.0 - Ssres_flow(i) = 0.0 - avail_potet = Potet(i) - Hru_actet(i) - IF ( avail_potet<0.0 ) avail_potet = 0.0 -! Snowevap_aet_frac(i) = 0.0 - - !Hru_type can be 1 (land) or 3 (swale) or 4 (glacier) - Is_land = 0 - IF ( Hru_type(i)==1 .OR. Hru_type(i)==4 ) Is_land = 1 - -!******Add infiltration to soil and compute excess - ! note, perv_area has to be > 0.0 - dunnianflw = 0.0 - dunnianflw_pfr = 0.0 - dunnianflw_gvr = 0.0 - interflow = 0.0 - pref_flow_maxin = 0.0 - -!******Add infiltration to soil and compute excess - !infil_tot is the depth in whole HRU - !capillary reservoir for pervious area - !preferential flow reservoir for whole HRU - !gravity reservoir for whole HRU - !upslope flow for whole HRU - -!******if cascading flow available from upslope cascades -!****** add soil excess (Dunnian flow) to infiltration - ! perv_frac has to be > 0.001 - ! infil for pervious portion of HRU - capwater_maxin = Infil(i) - - cfgi_frozen_hru = 0 - thaw_frac = 1.0 - !Frozen is HRU variable that says if frozen gravity reservoir - ! For CFGI all inflow is assumed to be Dunnian Flow when frozen - IF ( Frozen_flag==1 ) THEN - IF ( Frozen(i)>=1 ) THEN - IF ( Hru_type(i)==3 ) THEN - PRINT *, 'ERROR, a swale HRU cannot be frozen for CFGI, HRU:', i - STOP - ENDIF - cfgi_frozen_hru = Frozen(i) - IF ( cfgi_frozen_hru==1 ) THEN - thaw_frac = 0.0 - ELSEIF ( cfgi_frozen_hru==2 ) THEN - thaw_frac = Thaw_depth(i)/Soil_depth(i) - ENDIF - ENDIF - ENDIF - - ! compute preferential flow and storage, and any dunnian flow - prefflow = 0.0 - prefflowmax = Pref_flow_max(i)*thaw_frac - IF ( Pref_flow_flag(i)==1 ) THEN - Pref_flow_infil(i) = 0.0 - IF ( capwater_maxin>0.0 ) THEN - ! pref_flow for whole HRU - pref_flow_maxin = capwater_maxin*Pref_flow_den(i) - capwater_maxin = capwater_maxin - pref_flow_maxin - pref_flow_maxin = pref_flow_maxin*perv_frac - IF ( cfgi_frozen_hru==1 ) THEN !frozen to top - dunnianflw_pfr = pref_flow_maxin - Basin_dunnian_pfr = Basin_dunnian_pfr + dunnianflw_pfr*harea - ELSE - ! compute contribution to preferential-flow reservoir storage - Pref_flow_stor(i) = Pref_flow_stor(i) + pref_flow_maxin - dunnianflw_pfr = MAX( 0.0, Pref_flow_stor(i)-prefflowmax) - IF ( dunnianflw_pfr>0.0 ) THEN - Basin_dunnian_pfr = Basin_dunnian_pfr + dunnianflw_pfr*harea - Pref_flow_stor(i) = prefflowmax - ENDIF - Pref_flow_infil(i) = pref_flow_maxin - dunnianflw_pfr - Basin_pref_flow_infil = Basin_pref_flow_infil + Pref_flow_infil(i)*harea - ENDIF - Pfr_dunnian_flow(i) = dunnianflw_pfr - ENDIF - ENDIF - - IF ( Cascade_flag>0 ) THEN -! Cap_upflow_max(i) = SNGL(Upslope_dunnianflow(i)+Upslope_interflow(i))/perv_frac -! capwater_maxin = capwater_maxin + Cap_upflow_max(i) -! Basin_cap_up_max = Basin_cap_up_max + Cap_upflow_max(i)*perv_area - cap_upflow_max = SNGL(Upslope_dunnianflow(i)+Upslope_interflow(i))/perv_frac - capwater_maxin = capwater_maxin + cap_upflow_max - Basin_cap_up_max = Basin_cap_up_max + cap_upflow_max*perv_area - ENDIF - Cap_infil_tot(i) = capwater_maxin*perv_frac - Basin_cap_infil_tot = Basin_cap_infil_tot + DBLE( Cap_infil_tot(i)*harea ) - -!******Add infiltration to soil and compute excess - gvr_maxin = 0.0 - Cap_waterin(i) = capwater_maxin - soilmoistmax = Soil_moist_max(i)*thaw_frac - soilrechrmax = Soil_rechr_max(i)*thaw_frac - soil2gwmax = Soil2gw_max(i) - ssr2gwrate = Ssr2gw_rate(i) - IF ( cfgi_frozen_hru==3 ) THEN - soil2gwmax = 0.0 - Soil2gw(i) = 0 - ssr2gwrate = 0.0 - ENDIF - IF ( cfgi_frozen_hru/=1 ) THEN !some infiltration because not all the way frozen - ! call even if capwate_maxin = 0, just in case soil_moist now > Soil_moist_max - IF ( capwater_maxin+Soil_moist(i)>0.0 ) THEN - CALL compute_soilmoist(Cap_waterin(i), soilmoistmax, & - & soilrechrmax, soil2gwmax, gvr_maxin, & - & Soil_moist(i), Soil_rechr(i), Soil_to_gw(i), Soil2gw(i), perv_frac) - Cap_waterin(i) = Cap_waterin(i)*perv_frac - Basin_capwaterin = Basin_capwaterin + DBLE( Cap_waterin(i)*harea ) - Basin_soil_to_gw = Basin_soil_to_gw + DBLE( Soil_to_gw(i)*harea ) - Basin_sm2gvr_max = Basin_sm2gvr_max + DBLE( gvr_maxin*harea ) - ENDIF - ENDIF - ! Soil_to_ssr for whole HRU - Soil_to_ssr(i) = gvr_maxin - -! compute slow interflow and ssr_to_gw, changed to say effected by frozen state, already effected by reduced gvr_maxin if soil frozen - topfr = 0.0 - IF ( GSFLOW_flag==1 ) THEN - ! capacity for whole HRU - capacity = (soilmoistmax - Soil_moist(i))*perv_frac - CALL compute_gravflow(i, capacity, Slowcoef_lin(i), & - & Slowcoef_sq(i), ssr2gwrate, Ssr2gw_exp(i), & - & gvr_maxin, Pref_flow_thrsh(i), topfr, & - & Ssr_to_gw(i), Slow_flow(i), Slow_stor(i), & - & Gvr2sm(i), Soil_to_gw(i), gwin, Hru_type(i)) - ! adjust soil moisture with replenish amount - IF ( Gvr2sm(i)>0.0 ) THEN - Soil_moist(i) = Soil_moist(i) + Gvr2sm(i)/perv_frac -! IF ( Soil_moist(i)>soilmoistmax ) & -! & PRINT *, 'sm>max', Soil_moist(i), soilmoistmax, i - Soil_rechr(i) = Soil_rechr(i) + Gvr2sm(i)/perv_frac*Replenish_frac(i) - Soil_rechr(i) = MIN( soilrechrmax, Soil_rechr(i) ) - Basin_gvr2sm = Basin_gvr2sm + DBLE( Gvr2sm(i)*harea ) -! ELSEIF ( Gvr2sm(i)<-NEARZERO ) THEN -! PRINT *, 'negative gvr2sm, HRU:', i, Gvr2sm(i) -! Gvr2sm(i) = 0.0 - ENDIF - Grav_gwin(i) = SNGL( gwin ) - Basin_sz_gwin = Basin_sz_gwin + gwin*DBLE( harea ) - ELSEIF - availh2o = Slow_stor(i) + gvr_maxin - IF ( Hru_type(i)==1 ) THEN - topfr = MAX( 0.0, availh2o-Pref_flow_thrsh(i) ) - ssresin = gvr_maxin - topfr - Slow_stor(i) = availh2o - topfr - ! compute slow contribution to interflow, if any - IF ( Slow_stor(i)>0.0 ) & - & CALL compute_interflow(Slowcoef_lin(i), Slowcoef_sq(i), & - & ssresin, Slow_stor(i), Slow_flow(i)) - ELSEIF ( Hru_type(i)==3 ) THEN - Slow_stor(i) = availh2o - ENDIF - IF ( Slow_stor(i)>0.0 .AND. ssr2gwrate>0.0 ) & - & CALL compute_gwflow(ssr2gwrate, Ssr2gw_exp(i), Ssr_to_gw(i), Slow_stor(i)) - ENDIF - - ! compute contribution to Dunnian flow from PFR, if any - IF ( Pref_flow_flag(i)==1 ) THEN - availh2o = Pref_flow_stor(i) + topfr - dunnianflw_gvr = MAX( 0.0, availh2o-prefflowmax ) - IF ( dunnianflw_gvr>0.0 ) THEN - topfr = topfr - dunnianflw_gvr - IF ( topfr<0.0 ) THEN -! IF ( topfr<-NEARZERO .AND. Print_debug>-1 ) PRINT *, 'gvr2pfr<0', topfr, dunnianflw_gvr, & -! & prefflowmax, Pref_flow_stor(i), gvr_maxin - topfr = 0.0 - ENDIF - ENDIF - Pref_flow_in(i) = Pref_flow_infil(i) + topfr - Pref_flow_stor(i) = Pref_flow_stor(i) + topfr - IF ( Pref_flow_stor(i)>0.0 ) & - & CALL compute_interflow(Fastcoef_lin(i), Fastcoef_sq(i), & - & Pref_flow_in(i), Pref_flow_stor(i), prefflow) - Basin_pref_stor = Basin_pref_stor + DBLE( Pref_flow_stor(i)*harea ) - Pfr_stor_frac(i) = 0.0 -! IF ( thaw_frac>0.0 ) Pfr_stor_frac(i) = Pref_flow_stor(i)/prefflowmax -! Basin_pfr_stor_frac = Basin_pfr_stor_frac + Pfr_stor_frac(i)*harea - IF ( prefflowmax>0) Basin_pfr_stor_frac = Basin_pfr_stor_frac + Pref_flow_stor(i)/prefflowmax*harea - ELSEIF ( Hru_type(i)==1 ) THEN - dunnianflw_gvr = topfr !?? is this right - ENDIF - Gvr2pfr(i) = topfr - - Basin_sm2gvr = Basin_sm2gvr + DBLE( Soil_to_ssr(i)*harea ) - Basin_dunnian_gvr = Basin_dunnian_gvr + DBLE( dunnianflw_gvr*harea ) - Basin_sz2gw = Basin_sz2gw + DBLE( Ssr_to_gw(i)*harea ) - -!******Compute actual evapotranspiration - Snow_free(i) = 1.0 - Snowcov_area(i) - Potet_rechr(i) = 0.0 - Potet_lower(i) = 0.0 - pervactet = 0.0 - IF ( Soil_moist(i)>0.0 .AND. cfgi_frozen_hru==0 ) THEN - CALL compute_szactet(soilmoistmax, soilrechrmax, Transp_on(i), Cov_type(i), & - & Soil_type(i), Soil_moist(i), Soil_rechr(i), pervactet, & - & avail_potet, Snow_free(i), Potet_rechr(i), Potet_lower(i)) - ! sanity check -! IF ( pervactet>avail_potet ) THEN -! Soil_moist(i) = Soil_moist(i) + pervactet - avail_potet -! pervactet = avail_potet -! PRINT *, 'perv_et problem', pervactet, Avail_potet -! ENDIF - ENDIF -! Perv_avail_et(i) = avail_potet - - ! sanity check -! IF ( Soil_moist(i)<0.0 ) THEN -! IF ( Print_debug>-1 ) PRINT *, i, Soil_moist(i), ' negative' -! IF ( pervactet>=ABS(Soil_moist(i)) ) THEN -! pervactet = pervactet + Soil_moist(i) -! Soil_moist(i) = 0.0 -! ENDIF -! IF ( Soil_moist(i)<-NEARZERO ) THEN -! IF ( Print_debug>-1 ) PRINT *, 'HRU:', i, ' soil_moist<0.0', Soil_moist(i) -! ENDIF -! Soil_moist(i) = 0.0 -! ENDIF - - Hru_actet(i) = Hru_actet(i) + pervactet*perv_frac - avail_potet = Potet(i) - Hru_actet(i) - ! sanity check -! IF ( avail_potet<0.0 ) THEN -! IF ( Print_debug>-1 ) THEN -! IF ( avail_potet<-NEARZERO ) PRINT *, 'hru_actet>potet', i, & -! & Nowmonth, Nowday, Hru_actet(i), Potet(i), avail_potet -! ENDIF -! Hru_actet(i) = Potet(i) -! tmp = avail_potet/perv_frac -! pervactet = pervactet + tmp -! Soil_moist(i) = Soil_moist(i) - tmp -! Soil_rechr(i) = Soil_rechr(i) - tmp -! IF ( Soil_rechr(i)<0.0 ) Soil_rechr(i) = 0.0 -! IF ( Soil_moist(i)<0.0 ) Soil_moist(i) = 0.0 -! ENDIF - Perv_actet(i) = pervactet - -! soil_moist & soil_rechr multiplied by perv_area instead of harea - Soil_lower(i) = Soil_moist(i) - Soil_rechr(i) - Basin_soil_moist = Basin_soil_moist + DBLE( Soil_moist(i)*perv_area ) - Basin_soil_rechr = Basin_soil_rechr + DBLE( Soil_rechr(i)*perv_area ) - Basin_perv_et = Basin_perv_et + DBLE( Perv_actet(i)*perv_area ) - -! if HRU cascades, -! compute interflow and excess flow to each HRU or stream - IF ( Is_land==1 ) THEN - interflow = Slow_flow(i) + prefflow -! Interflow_max(i) = interflow - Basin_interflow_max = Basin_interflow_max + interflow*harea - dunnianflw = dunnianflw_gvr + dunnianflw_pfr - Dunnian_flow(i) = dunnianflw - IF ( Cascade_flag>0 ) THEN - IF ( Ncascade_hru(i)>0 ) THEN - dnslowflow = 0.0 - dnpreflow = 0.0 - dndunn = 0.0 - IF ( interflow+dunnianflw>0.0 ) THEN - CALL compute_cascades(i, Ncascade_hru(i), Slow_flow(i), & - & prefflow, Dunnian_flow(i), dnslowflow, & - & dnpreflow, dndunn) - Basin_dninterflow = Basin_dninterflow + DBLE( (dnslowflow+dnpreflow)*harea ) - Basin_dndunnianflow = Basin_dndunnianflow + DBLE( dndunn*harea ) - ENDIF - Hru_sz_cascadeflow(i) = dnslowflow + dnpreflow + dndunn -! Cascade_interflow(i) = dnslowflow + dnpreflow -! Cascade_dunnianflow(i) = dndunn - Basin_dncascadeflow = Basin_dncascadeflow + DBLE( Hru_sz_cascadeflow(i)*harea ) - ENDIF - ENDIF - -! treat pref_flow as interflow - Ssres_flow(i) = Slow_flow(i) - IF ( Pref_flow_flag(i)==1 ) THEN - Pref_flow(i) = prefflow - Ssres_flow(i) = Ssres_flow(i) + prefflow - Basin_prefflow = Basin_prefflow + DBLE( prefflow*harea ) - Basin_gvr2pfr = Basin_gvr2pfr + DBLE( Gvr2pfr(i)*harea ) - ENDIF - Basin_ssflow = Basin_ssflow + DBLE( Ssres_flow(i)*harea ) - Basin_slowflow = Basin_slowflow + DBLE( Slow_flow(i)*harea ) - -! treat dunnianflw as surface runoff to streams - Sroff(i) = Sroff(i) + Dunnian_flow(i) - Basin_sroff = Basin_sroff + DBLE( Sroff(i)*harea ) - Basin_dunnian = Basin_dunnian + DBLE( Dunnian_flow(i)*harea ) - Ssres_stor(i) = Slow_stor(i) + Pref_flow_stor(i) - - ELSE ! for swales - availh2o = Slow_stor(i) - Sat_threshold(i) - Swale_actet(i) = 0.0 - IF ( availh2o>0.0 ) THEN ! if ponding, as storage > sat_threshold - unsatisfied_et = Potet(i) - Hru_actet(i) - IF ( unsatisfied_et>0.0 ) THEN - availh2o = MIN ( availh2o, unsatisfied_et ) - Swale_actet(i) = availh2o - Hru_actet(i) = Hru_actet(i) + Swale_actet(i) - Slow_stor(i) = Slow_stor(i) - Swale_actet(i) - Basin_swale_et = Basin_swale_et + DBLE( Swale_actet(i)*harea ) - ENDIF - IF ( Print_debug==7 ) THEN - IF ( Slow_stor(i)>Swale_limit(i) ) THEN - WRITE ( DBGUNT, * ) 'Swale ponding, HRU:', i, & - & ' gravity reservoir is 3*sat_threshold', Slow_stor(i), Sat_threshold(i) - CALL print_date(DBGUNT) - ENDIF - ENDIF - ENDIF - Ssres_stor(i) = Slow_stor(i) - ENDIF - - IF ( Soil_lower_stor_max(i)>0.0 ) Soil_lower_ratio(i) = Soil_lower(i)/Soil_lower_stor_max(i) -! Soil_rechr_ratio(i) = 0.0 -! IF ( thaw_frac>0.0 ) Soil_rechr_ratio(i) = Soil_rechr(i)/soilrechrmax - Ssres_in(i) = Soil_to_ssr(i) + Pref_flow_infil(i) + SNGL( gwin ) - Basin_ssin = Basin_ssin + DBLE( Ssres_in(i)*harea ) - Basin_ssstor = Basin_ssstor + DBLE( Ssres_stor(i)*harea ) - Basin_slstor = Basin_slstor + DBLE( Slow_stor(i)*harea ) - Soil_moist_tot(i) = Ssres_stor(i) + Soil_moist(i)*perv_frac - Basin_soil_moist_tot = Basin_soil_moist_tot + DBLE( Soil_moist_tot(i)*harea ) -! Soil_moist_frac(i) = Soil_moist_tot(i)/Soil_zone_max(i) -! Cpr_stor_frac(i) = 0.0 -! IF ( thaw_frac>0.0 ) Cpr_stor_frac(i) = Soil_moist(i)/soilmoistmax -! IF ( Pref_flow_thrsh(i)>0.0 ) Gvr_stor_frac(i) = Slow_stor(i)/Pref_flow_thrsh(i) -! Basin_cpr_stor_frac = Basin_cpr_stor_frac + Cpr_stor_frac(i)*perv_area -! Basin_gvr_stor_frac = Basin_gvr_stor_frac + Gvr_stor_frac(i)*harea -! Basin_sz_stor_frac = Basin_sz_stor_frac + Soil_moist_frac(i)*harea - IF ( thaw_frac>0.0 ) Basin_cpr_stor_frac = Basin_cpr_stor_frac + Soil_moist(i)/soilmoistmax*perv_area - IF ( Pref_flow_thrsh(i)>0.0 ) Basin_gvr_stor_frac = Basin_gvr_stor_frac + Slow_stor(i)/Pref_flow_thrsh(i)*harea - Basin_sz_stor_frac = Basin_sz_stor_frac + Soil_moist_tot(i)/Soil_zone_max(i)*harea - Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac + Soil_lower_ratio(i)*perv_area -! Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + Soil_rechr_ratio(i)*perv_area - IF ( soilrechrmax>0 ) Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + Soil_rechr(i)/soilrechrmax*perv_area - Recharge(i) = Soil_to_gw(i) + Ssr_to_gw(i) - IF ( Dprst_flag==1 ) Recharge(i) = Recharge(i) + SNGL( Dprst_seep_hru(i) ) - Basin_recharge = Basin_recharge + DBLE( Recharge(i)*harea ) - Grav_dunnian_flow(i) = dunnianflw_gvr - Unused_potet(i) = Potet(i) - Hru_actet(i) - Basin_actet = Basin_actet + DBLE( Hru_actet(i)*harea ) -! IF ( Hru_actet(i)>0.0 ) Snowevap_aet_frac(i) = Snow_evap(i)/Hru_actet(i) - - ENDDO - Basin_actet = Basin_actet*Basin_area_inv - Basin_perv_et = Basin_perv_et*Basin_area_inv - Basin_swale_et = Basin_swale_et*Basin_area_inv - Basin_soil_rechr = Basin_soil_rechr*Basin_area_inv - Basin_soil_to_gw = Basin_soil_to_gw*Basin_area_inv - Basin_soil_moist = Basin_soil_moist*Basin_area_inv - IF ( update_potet==1 ) Basin_potet = Basin_potet*Basin_area_inv - Basin_soil_moist_tot = Basin_soil_moist_tot*Basin_area_inv - IF ( Nlake>0 ) THEN - Basin_lakeevap = Basin_lakeevap*Basin_area_inv - Basin_lakeprecip = Basin_lakeprecip*Basin_area_inv - Basin_lakeinsz = Basin_lakeinsz*Basin_area_inv - Basin_lake_stor = Basin_lake_stor + Basin_lakeprecip - Basin_lakeevap - ENDIF - IF ( Pref_flag==1 ) THEN - Basin_pref_stor = Basin_pref_stor*Basin_area_inv - Basin_pref_flow_infil = Basin_pref_flow_infil*Basin_area_inv - Basin_prefflow = Basin_prefflow*Basin_area_inv - Basin_dunnian_pfr = Basin_dunnian_pfr*Basin_area_inv - Basin_pfr_stor_frac = Basin_pfr_stor_frac*Basin_area_inv - ENDIF - Basin_dunnian_gvr = Basin_dunnian_gvr*Basin_area_inv - Basin_ssstor = Basin_ssstor*Basin_area_inv - Basin_ssflow = Basin_ssflow*Basin_area_inv - Basin_interflow_max = Basin_interflow_max*Basin_area_inv - Basin_sz2gw = Basin_sz2gw*Basin_area_inv - Basin_ssin = Basin_ssin*Basin_area_inv - Basin_slstor = Basin_slstor*Basin_area_inv - Basin_sroff = Basin_sroff*Basin_area_inv - Basin_dunnian = Basin_dunnian*Basin_area_inv - Basin_sm2gvr = Basin_sm2gvr*Basin_area_inv - Basin_sm2gvr_max = Basin_sm2gvr_max*Basin_area_inv - Basin_capwaterin = Basin_capwaterin*Basin_area_inv - Basin_cap_infil_tot = Basin_cap_infil_tot*Basin_area_inv - Basin_cap_up_max = Basin_cap_up_max*Basin_area_inv - Basin_dninterflow = Basin_dninterflow*Basin_area_inv - Basin_dndunnianflow = Basin_dndunnianflow*Basin_area_inv - Basin_dncascadeflow = Basin_dncascadeflow*Basin_area_inv - Basin_gvr2pfr = Basin_gvr2pfr*Basin_area_inv - Basin_slowflow = Basin_slowflow*Basin_area_inv - Basin_recharge = Basin_recharge*Basin_area_inv - Basin_gvr2sm = Basin_gvr2sm*Basin_area_inv - Basin_sz_gwin = Basin_sz_gwin*Basin_area_inv - Basin_cpr_stor_frac = Basin_cpr_stor_frac*Basin_area_inv - Basin_gvr_stor_frac = Basin_gvr_stor_frac*Basin_area_inv - Basin_sz_stor_frac = Basin_sz_stor_frac*Basin_area_inv - Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac*Basin_area_inv - Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac*Basin_area_inv - - END FUNCTION szrun - -!*********************************************************************** -! Add infiltration to soil and compute excess -! Soil_to_gw and Soil_to_ssr for whole HRU -!*********************************************************************** - SUBROUTINE compute_soilmoist(Infil, Soil_moist_max, & - & Soil_rechr_max, Soil2gw_max, Soil_to_ssr, Soil_moist, & - & Soil_rechr, Soil_to_gw, Soil2gw, Perv_frac) - IMPLICIT NONE - INTRINSIC MIN -! Arguments - INTEGER, INTENT(IN) :: Soil2gw - REAL, INTENT(IN) :: Perv_frac, Soil_moist_max, Soil_rechr_max, Soil2gw_max - REAL, INTENT(INOUT) :: Infil, Soil_moist, Soil_rechr, Soil_to_gw, Soil_to_ssr -! Local Variables - REAL :: excs -!*********************************************************************** - Soil_rechr = MIN( (Soil_rechr+Infil), Soil_rechr_max ) - ! soil_moist_max from previous time step or soil_moist_max has - ! changed for a restart simulation - excs = Soil_moist + Infil - Soil_moist = MIN( excs, Soil_moist_max ) - excs = (excs - Soil_moist_max)*Perv_frac - IF ( excs>0.0 ) THEN - IF ( Soil2gw==1 ) THEN - Soil_to_gw = MIN( Soil2gw_max, excs ) - excs = excs - Soil_to_gw - ENDIF - IF ( excs>Infil*Perv_frac ) THEN !probably dynamic - Infil = 0.0 - ELSE - Infil = Infil - excs/Perv_frac !???? what if Infil<0 ??? might happen with dynamic and small values, maybe ABS < NEARZERO = 0.0 -! IF ( Infil<0.0 ) THEN -! IF ( Infil<-0.0001 ) THEN -! PRINT *, 'negative infil', infil, soil_moist, excs -! Soil_moist = Soil_moist + Infil -! ENDIF -! Infil = 0.0 -! ENDIF - ENDIF - - Soil_to_ssr = excs - IF ( Soil_to_ssr<0.0 ) Soil_to_ssr = 0.0 - ENDIF - - END SUBROUTINE compute_soilmoist - -!*********************************************************************** -! Compute actual evapotranspiration -!*********************************************************************** - SUBROUTINE compute_szactet(Soil_moist_max, Soil_rechr_max, & - & Transp_on, Cov_type, Soil_type, & - & Soil_moist, Soil_rechr, Perv_actet, Avail_potet, & - & Snow_free, Potet_rechr, Potet_lower) - USE PRMS_SOILZONE, ONLY: Et_type - USE PRMS_BASIN, ONLY: NEARZERO - IMPLICIT NONE -! Arguments - INTEGER, INTENT(IN) :: Transp_on, Cov_type, Soil_type - REAL, INTENT(IN) :: Soil_moist_max, Soil_rechr_max, Snow_free - REAL, INTENT(INOUT) :: Soil_moist, Soil_rechr, Avail_potet, Potet_rechr, Potet_lower - REAL, INTENT(OUT) :: Perv_actet -! Local Variables - REAL, PARAMETER :: ONETHIRD = 1.0/3.0, TWOTHIRDS = 2.0/3.0 - REAL :: et, pcts, pctr -!*********************************************************************** -!******Determine if evaporation(Et_type = 2) or transpiration plus -!******evaporation(Et_type = 3) are active. if not, Et_type = 1 - - IF ( Avail_potet0 ) THEN - Et_type = 3 - ELSEIF ( Snow_free<0.01 ) THEN - Et_type = 1 - ELSE - Et_type = 2 - ENDIF - - IF ( Et_type>1 ) THEN - pcts = Soil_moist/Soil_moist_max - pctr = Soil_rechr/Soil_rechr_max - Potet_lower = Avail_potet - Potet_rechr = Avail_potet - -!******sandy soil - IF ( Soil_type==1 ) THEN - IF ( pcts<0.25 ) Potet_lower = 0.5*pcts*Avail_potet - IF ( pctr<0.25 ) Potet_rechr = 0.5*pctr*Avail_potet -!******loam soil - ELSEIF ( Soil_type==2 ) THEN - IF ( pcts<0.5 ) Potet_lower = pcts*Avail_potet - IF ( pctr<0.5 ) Potet_rechr = pctr*Avail_potet -!******clay soil - ELSEIF ( Soil_type==3 ) THEN - IF ( pctsONETHIRD ) THEN - Potet_lower = pcts*Avail_potet - ELSEIF ( pcts<=ONETHIRD ) THEN - Potet_lower = 0.5*pcts*Avail_potet - ENDIF - IF ( pctrONETHIRD ) THEN - Potet_rechr = pctr*Avail_potet - ELSEIF ( pctr<=ONETHIRD ) THEN - Potet_rechr = 0.5*pctr*Avail_potet - ENDIF - ENDIF - -!******Soil moisture accounting - IF ( Et_type==2 ) Potet_rechr = Potet_rechr*Snow_free - IF ( Potet_rechr>Soil_rechr ) THEN - Potet_rechr = Soil_rechr - Soil_rechr = 0.0 - ELSE - Soil_rechr = Soil_rechr - Potet_rechr - ENDIF - IF ( Et_type==2 .OR. Potet_rechr>=Potet_lower ) THEN - IF ( Potet_rechr>Soil_moist ) THEN - Potet_rechr = Soil_moist - Soil_moist = 0.0 - ELSE - Soil_moist = Soil_moist - Potet_rechr - ENDIF - et = Potet_rechr - ELSEIF ( Potet_lower>Soil_moist ) THEN - et = Soil_moist - Soil_moist = 0.0 - ELSE - Soil_moist = Soil_moist - Potet_lower - et = Potet_lower - ENDIF - IF ( Soil_rechr>Soil_moist ) Soil_rechr = Soil_moist - ELSE - et = 0.0 - ENDIF - Perv_actet = et - ! sanity check -! IF ( Perv_actet>Avail_potet ) THEN -! PRINT *, 'perv_et problem', Perv_actet, Avail_potet -! Soil_moist = Soil_moist + Perv_actet - Avail_potet -! Perv_actet = Avail_potet -! ENDIF - - END SUBROUTINE compute_szactet - -!*********************************************************************** -! compute interflow and flow to groundwater reservoir -!*********************************************************************** - SUBROUTINE compute_gwflow(Ssr2gw_rate, Ssr2gw_exp, Ssr_to_gw, Slow_stor) - IMPLICIT NONE -! Arguments - REAL, INTENT(IN) :: Ssr2gw_rate, Ssr2gw_exp - REAL, INTENT(INOUT) :: Slow_stor, Ssr_to_gw -!*********************************************************************** -!******compute flow to groundwater - Ssr_to_gw = Ssr2gw_rate*(Slow_stor**Ssr2gw_exp) - IF ( Ssr_to_gw<0.0 ) THEN - Ssr_to_gw = 0.0 - ELSEIF ( Ssr_to_gw>Slow_stor ) THEN - Ssr_to_gw = Slow_stor - ENDIF - Slow_stor = Slow_stor - Ssr_to_gw - - END SUBROUTINE compute_gwflow - -!*********************************************************************** -! Compute subsurface lateral flow -!*********************************************************************** - SUBROUTINE compute_interflow(Coef_lin, Coef_sq, Ssres_in, Storage, Inter_flow) -! USE PRMS_BASIN, ONLY: NEARZERO, CLOSEZERO - IMPLICIT NONE - INTRINSIC EXP, SQRT -! Arguments - REAL, INTENT(IN) :: Coef_lin, Coef_sq, Ssres_in - REAL, INTENT(INOUT) :: Storage, Inter_flow -! Local Variables - REAL :: c1, c2, c3, sos -!*********************************************************************** -! Inter_flow is in inches for the timestep -!******compute interflow - IF ( Coef_lin<=0.0 .AND. Ssres_in<=0.0 ) THEN - c1 = Coef_sq*Storage - Inter_flow = Storage*(c1/(1.0+c1)) - ELSEIF ( Coef_lin>0.0 .AND. Coef_sq<=0.0 ) THEN - c2 = 1.0 - EXP(-Coef_lin) - Inter_flow = Ssres_in*(1.0-c2/Coef_lin) + Storage*c2 - ELSEIF ( Coef_sq>0.0 ) THEN - c3 = SQRT(Coef_lin**2.0+4.0*Coef_sq*Ssres_in) - sos = Storage - ((c3-Coef_lin)/(2.0*Coef_sq)) - IF ( c3==0.0 ) STOP 'ERROR, in compute_interflow sos=0, please contact code developers' - c1 = Coef_sq*sos/c3 - c2 = 1.0 - EXP(-c3) - IF ( 1.0+c1*c2>0.0 ) THEN - Inter_flow = Ssres_in + (sos*(1.0+c1)*c2)/(1.0+c1*c2) - ELSE - Inter_flow = Ssres_in - ENDIF - ELSE - Inter_flow = 0.0 - ENDIF - -! sanity check - IF ( Inter_flow<0.0 ) THEN -! IF ( Inter_flow<-NEARZERO ) PRINT *, 'interflow<0', Inter_flow, Ssres_in, Storage - Inter_flow = 0.0 - ELSEIF ( Inter_flow>Storage ) THEN - Inter_flow = Storage - ENDIF - Storage = Storage - Inter_flow -! IF ( Storage<0.0 ) THEN -! IF ( Storage<-CLOSEZERO ) PRINT *, 'Sanity check, ssres_stor<0.0', Storage -! Storage = 0.0 -! rsr, if very small storage, add it to interflow -! ELSEIF ( Storage>0.0 .AND. Storage 0, cascade contributes to a downslope HRU - IF ( j>0 ) THEN - fracwt = Hru_down_fracwt(k, Ihru) - Upslope_interflow(j) = Upslope_interflow(j) + DBLE( (Slowflow+Preflow)*fracwt ) - Upslope_dunnianflow(j) = Upslope_dunnianflow(j) + DBLE( Dunnian*fracwt ) - Dnslowflow = Dnslowflow + Slowflow*frac - Dnpreflow = Dnpreflow + Preflow*frac - Dndunnflow = Dndunnflow + Dunnian*frac -! if hru_down(k, Ihru) < 0, cascade contributes to a stream - ELSEIF ( j<0 ) THEN - j = IABS(j) - Strm_seg_in(j) = Strm_seg_in(j) + DBLE( (Slowflow+Preflow+Dunnian)*Cascade_area(k, Ihru) )*Cfs_conv - ENDIF - ENDDO - -! reset Slowflow, Preflow, and Dunnian_flow as they accumulate flow to streams - Slowflow = Slowflow - Dnslowflow - Preflow = Preflow - Dnpreflow - Dunnian = Dunnian - Dndunnflow - - END SUBROUTINE compute_cascades - -!*********************************************************************** -! compute interflow and flow to groundwater reservoir -!*********************************************************************** - SUBROUTINE compute_gravflow(Ihru, Capacity, Slowcoef_lin, & - & Slowcoef_sq, Ssr2gw_rate, Ssr2gw_exp, Gvr_maxin, & - & Pref_flow_thrsh, Gvr2pfr, Ssr_to_gw, & - & Slow_flow, Slow_stor, Gvr2sm, Soil_to_gw, Gwin, Hru_type) - USE PRMS_SOILZONE, ONLY: Gravity_stor_res, Sm2gw_grav, Hru_gvr_count, Hru_gvr_index, & - & Gw2sm_grav, Gvr_hru_pct_adjusted - USE PRMS_MODULE, ONLY: Dprst_flag, Print_debug - USE PRMS_SRUNOFF, ONLY: Dprst_seep_hru - IMPLICIT NONE -! Functions - INTRINSIC MAX, DBLE, SNGL - EXTERNAL check_gvr_sm, compute_interflow -! Arguments - INTEGER, INTENT(IN) :: Ihru, Hru_type - REAL, INTENT(IN) :: Slowcoef_lin, Slowcoef_sq, Ssr2gw_rate, Ssr2gw_exp - REAL, INTENT(IN) :: Pref_flow_thrsh, Soil_to_gw, Gvr_maxin - REAL, INTENT(INOUT) :: Capacity - REAL, INTENT(OUT) :: Ssr_to_gw, Slow_stor, Slow_flow, Gvr2pfr, Gvr2sm - DOUBLE PRECISION, INTENT(OUT) :: Gwin -! Local Variables - INTEGER :: j, igvr - REAL :: perc, slowflow, extra_water, gvrin_actual, depth, input - DOUBLE PRECISION :: topfr, slflow, togw, slowstor, frac -!*********************************************************************** - !Capacity is for whole HRU - !Soil_to_gw is for whole HRU - !TO DO -! use VKS as a function of slope (vector analysis) instead of coef_lin -! coef_lin for pref_flow needs to be VKS lateral times a factor -! change slow to interflow -! in init, set an array dimensioned by nhrucell to vks*mfl_to_inch - - Gwin = 0.0D0 - Gvr2sm = 0.0 - topfr = 0.0D0 - slflow = 0.0D0 - togw = 0.0D0 - slowstor = 0.0D0 - DO j = 1, Hru_gvr_count(Ihru) - igvr = Hru_gvr_index(j, Ihru) - frac = Gvr_hru_pct_adjusted(igvr) - Gwin = Gwin + DBLE( Gw2sm_grav(igvr) )*frac - input = Gvr_maxin + Gw2sm_grav(igvr) - depth = Gravity_stor_res(igvr) + input - IF ( depth>0.0 .AND. Capacity>0.0 ) CALL check_gvr_sm(Capacity, depth, frac, Gvr2sm, input) - - IF ( Hru_type==1 ) THEN - extra_water = MAX( 0.0, depth-Pref_flow_thrsh ) - IF ( extra_water>0.0 ) THEN - !compute contribution to preferential-flow reservoir storage - topfr = topfr + DBLE( extra_water )*frac - depth = Pref_flow_thrsh - ENDIF - gvrin_actual = MAX(0.0, input-extra_water) - -! compute contribution to slow interflow, if any - IF ( depth>0.0 ) THEN - CALL compute_interflow(Slowcoef_lin, Slowcoef_sq, gvrin_actual, depth, slowflow) - slflow = slflow + DBLE( slowflow )*frac - ENDIF - ENDIF - -! compute flow to groundwater, if any - IF ( depth>0.0 ) THEN - IF ( Ssr2gw_rate>0.0 ) THEN -! use VKS instead of rate ??????????????? - perc = Ssr2gw_rate*(depth**Ssr2gw_exp) - IF ( perc<0.0 ) THEN - perc = 0.0 - ELSEIF ( perc>depth ) THEN - perc = depth - ENDIF - depth = depth - perc -! IF ( sm2gw_grav(igvr)>0.0 ) print*,'problem',sm2gw_grav(igvr),igvr - Sm2gw_grav(igvr) = perc - togw = togw + DBLE( perc )*frac - ENDIF -! ELSE ! GVRs can go negative if flux change in MODFLOW final iteration decreases, so don't set to 0 -! if(depth<0.0) print *, 'depth<0', depth, ihru -! depth = 0.0 - ENDIF - - Gravity_stor_res(igvr) = depth - slowstor = slowstor + DBLE(depth)*frac - -! add any direct recharge from soil infiltration - Sm2gw_grav(igvr) = Sm2gw_grav(igvr) + Soil_to_gw - IF ( Dprst_flag==1 ) Sm2gw_grav(igvr) = Sm2gw_grav(igvr) + SNGL( Dprst_seep_hru(Ihru) ) - - ENDDO ! end loop of GVRs in the HRU - - Gvr2pfr = SNGL( topfr ) - Slow_flow = SNGL( slflow ) - Ssr_to_gw = SNGL( togw ) - Slow_stor = SNGL( slowstor ) - IF ( Slow_stor>Pref_flow_thrsh ) THEN - IF ( Print_debug>-1 .AND. Hru_type==1 ) & - & PRINT *, 'slow_stor > thrsh', Slow_stor, Pref_flow_thrsh, ' HRU:', Ihru, ' type:', Hru_type - ENDIF - - END SUBROUTINE compute_gravflow - -!*********************************************************************** -! adjust soil moist based on being below field capacity (capacity) -! and preferential-flow threshold (Pref_flow_thrsh) -!*********************************************************************** - SUBROUTINE check_gvr_sm(Capacity, Depth, Frac, Gvr2sm, Input) -! USE PRMS_BASIN, ONLY: CLOSEZERO - IMPLICIT NONE -! Functions - INTRINSIC MAX, ABS, SNGL -! Arguments - DOUBLE PRECISION, INTENT(IN) :: Frac - REAL, INTENT(INOUT) :: Capacity, Gvr2sm, Depth, Input -! Local Variables - REAL :: to_sm, frac_sngl -!*********************************************************************** -! check to see if soil is below capacity, if so add up to field capacity -! Capacity is for whole HRU -! to_sm and Gvr2sm are for whole HRU - - frac_sngl = SNGL( Frac ) - ! fill up capillary with part of gravity water - to_sm = Capacity - ! take all gravity water and put in capillary - IF ( to_sm>Depth ) to_sm = Depth - -! compute adjusmtent to soil moist to get to field capacity - Capacity = Capacity - to_sm*frac_sngl - IF ( Capacity<0.0 ) THEN - to_sm = to_sm - Capacity*frac_sngl - Capacity = 0.0 - ENDIF - Gvr2sm = Gvr2sm + to_sm*frac_sngl - Depth = Depth - to_sm - !IF ( Depth<0.0 ) PRINT *, 'depth<0', depth -! IF ( Depth0 ) CALL srunoff_restart(1) - srunoff = srunoffinit() - ELSEIF ( Process(:5)=='clean' ) THEN - IF ( Save_vars_to_file==1 ) CALL srunoff_restart(0) - ENDIF - - END FUNCTION srunoff - -!*********************************************************************** -! srunoffdecl - set up parameters for surface runoff computations -! Declared Parameters -! smidx_coef, smidx_exp, carea_max, imperv_stor_max, snowinfil_max -! hru_area, soil_moist_max, soil_rechr_max, carea_min -! cfgi_thrshld, cfgi_decay, soil_depth, soil_den, porosity_hru -!*********************************************************************** - INTEGER FUNCTION srunoffdecl() - USE PRMS_SRUNOFF - USE PRMS_MODULE, ONLY: Model, Dprst_flag, Nhru, Nsegment, Print_debug, & - & Cascade_flag, Sroff_flag, Nlake, Init_vars_from_file, Call_cascade, PRMS4_flag, & - & Frozen_flag - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: declvar, declparam - EXTERNAL read_error, print_module -! Local Variables - CHARACTER(LEN=80), SAVE :: Version_srunoff -!*********************************************************************** - srunoffdecl = 0 - - Version_srunoff = 'srunoff.f90 2019-05-24 14:50:00Z' - IF ( Sroff_flag==1 ) THEN - MODNAME = 'srunoff_smidx' - ELSE - MODNAME = 'srunoff_carea' - ENDIF - Version_srunoff = MODNAME//'.f90 '//Version_srunoff(13:80) - CALL print_module(Version_srunoff, 'Surface Runoff ', 90) - - IF ( declvar(MODNAME, 'basin_imperv_evap', 'one', 1, 'double', & - & 'Basin area-weighted average evaporation from impervious area', & - & 'inches', Basin_imperv_evap)/=0 ) CALL read_error(3, 'basin_imperv_evap') - - IF ( declvar(MODNAME, 'basin_imperv_stor', 'one', 1, 'double', & - & 'Basin area-weighted average storage on impervious area', & - & 'inches', Basin_imperv_stor)/=0 ) CALL read_error(3, 'basin_imperv_stor') - - IF ( declvar(MODNAME, 'basin_infil', 'one', 1, 'double', & - & 'Basin area-weighted average infiltration to the capillary reservoirs', & - & 'inches', Basin_infil)/=0 ) CALL read_error(3, 'basin_infil') - - IF ( declvar(MODNAME, 'basin_sroff', 'one', 1, 'double', & - & 'Basin area-weighted average surface runoff to the stream network', & - & 'inches', Basin_sroff)/=0 ) CALL read_error(3, 'basin_sroff') - - IF ( declvar(MODNAME, 'basin_hortonian', 'one', 1, 'double', & - & 'Basin area-weighted average Hortonian runoff', & - & 'inches', Basin_hortonian)/=0 ) CALL read_error(3, 'basin_hortonian') - - IF ( declvar(MODNAME, 'basin_contrib_fraction', 'one', 1, 'double', & - & 'Basin area-weighted average contributing area of the pervious area of each HRU', & - & 'decimal fraction', Basin_contrib_fraction)/=0 ) CALL read_error(3, 'basin_contrib_fraction') - - ALLOCATE ( Contrib_fraction(Nhru) ) - IF ( declvar(MODNAME, 'contrib_fraction', 'nhru', Nhru, 'real', & - & 'Contributing area of each HRU pervious area', & - & 'decimal fraction', Contrib_fraction)/=0 ) CALL read_error(3, 'contrib_fraction') - - ALLOCATE ( Hru_impervevap(Nhru) ) - IF ( declvar(MODNAME, 'hru_impervevap', 'nhru', Nhru, 'real', & - & 'HRU area-weighted average evaporation from impervious area for each HRU', & - & 'inches', Hru_impervevap)/=0 ) CALL read_error(3, 'hru_impervevap') - - ALLOCATE ( Hru_impervstor(Nhru) ) - IF ( declvar(MODNAME, 'hru_impervstor', 'nhru', Nhru, 'real', & - & 'HRU area-weighted average storage on impervious area for each HRU', & - & 'inches', Hru_impervstor)/=0 ) CALL read_error(3, 'hru_impervstor') - - ALLOCATE ( Imperv_evap(Nhru) ) - IF ( declvar(MODNAME, 'imperv_evap', 'nhru', Nhru, 'real', & - & 'Evaporation from impervious area for each HRU', & - & 'inches', Imperv_evap)/=0 ) CALL read_error(3, 'imperv_evap') - - IF ( declvar(MODNAME, 'basin_sroffi', 'one', 1, 'double', & - & 'Basin area-weighted average surface runoff from impervious areas', & - & 'inches', Basin_sroffi)/=0 ) CALL read_error(3, 'basin_sroffi') - - IF ( declvar(MODNAME, 'basin_sroffp', 'one', 1, 'double', & - & 'Basin area-weighted average surface runoff from pervious areas', & - & 'inches', Basin_sroffp)/=0 ) CALL read_error(3, 'basin_sroffp') - - ALLOCATE ( Hru_sroffp(Nhru) ) - IF ( declvar(MODNAME, 'hru_sroffp', 'nhru', Nhru, 'real', & - & 'HRU area-weighted average surface runoff from pervious areas for each HRU', & - & 'inches', Hru_sroffp)/=0 ) CALL read_error(3, 'hru_sroffp') - - ALLOCATE ( Hru_sroffi(Nhru) ) - IF ( declvar(MODNAME, 'hru_sroffi', 'nhru', Nhru, 'real', & - & 'HRU area-weighted average surface runoff from impervious areas for each HRU', & - & 'inches', Hru_sroffi)/=0 ) CALL read_error(3, 'hru_sroffi') - -! Depression storage variables - IF ( Dprst_flag==1 .OR. Model==99 ) THEN - IF ( declvar(MODNAME, 'basin_dprst_sroff', 'one', 1, 'double', & - & 'Basin area-weighted average surface runoff from open surface-depression storage', & - & 'inches', Basin_dprst_sroff)/=0 ) CALL read_error(3, 'basin_dprst_sroff') - - IF ( declvar(MODNAME, 'basin_dprst_evap', 'one', 1, 'double', & - & 'Basin area-weighted average evaporation from surface-depression storage', & - & 'inches', Basin_dprst_evap)/=0 ) CALL read_error(3, 'basin_dprst_evap') - - IF ( declvar(MODNAME, 'basin_dprst_seep', 'one', 1, 'double', & - & 'Basin area-weighted average seepage from surface-depression storage', & - & 'inches', Basin_dprst_seep)/=0 ) CALL read_error(3, 'basin_dprst_seep') - - IF ( declvar(MODNAME, 'basin_dprst_volop', 'one', 1, 'double', & - & 'Basin area-weighted average storage volume in open surface depressions', & - & 'inches', Basin_dprst_volop)/=0 ) CALL read_error(3, 'basin_dprst_volop') - - IF ( declvar(MODNAME, 'basin_dprst_volcl', 'one', 1, 'double', & - & 'Basin area-weighted average storage volume in closed surface depressions', & - & 'inches', Basin_dprst_volcl)/=0 ) CALL read_error(3, 'basin_dprst_volcl') - - ALLOCATE ( Dprst_sroff_hru(Nhru) ) - IF ( declvar(MODNAME, 'dprst_sroff_hru', 'nhru', Nhru, 'double', & - & 'Surface runoff from open surface-depression storage for each HRU', & - & 'inches', Dprst_sroff_hru)/=0 ) CALL read_error(3, 'dprst_sroff_hru') - - ALLOCATE ( Dprst_insroff_hru(Nhru) ) - IF ( declvar(MODNAME, 'dprst_insroff_hru', 'nhru', Nhru, 'real', & - & 'Surface runoff from pervious and impervious portions into open and closed surface-depression storage for each HRU', & - & 'inches', Dprst_insroff_hru)/=0 ) CALL read_error(3, 'dprst_insroff_hru') - - ALLOCATE ( Dprst_area_open(Nhru) ) - IF ( declvar(MODNAME, 'dprst_area_open', 'nhru', Nhru, 'real', & - & 'Surface area of open surface depressions based on storage volume for each HRU', & - & 'acres', Dprst_area_open)/=0 ) CALL read_error(3, 'dprst_area_open') - - ALLOCATE ( Dprst_area_clos(Nhru) ) - IF ( declvar(MODNAME, 'dprst_area_clos', 'nhru', Nhru, 'real', & - & 'Surface area of closed surface depressions based on storage volume for each HRU', & - & 'acres', Dprst_area_clos)/=0 ) CALL read_error(3, 'dprst_area_clos') - - ALLOCATE ( Dprst_stor_hru(Nhru) ) - IF ( declvar(MODNAME, 'dprst_stor_hru', 'nhru', Nhru, 'double', & - & 'Surface-depression storage for each HRU', & - & 'inches', Dprst_stor_hru)/=0 ) CALL read_error(3, 'dprst_stor_hru') - - ALLOCATE ( Dprst_seep_hru(Nhru) ) - IF ( declvar(MODNAME, 'dprst_seep_hru', 'nhru', Nhru, 'double', & - & 'Seepage from surface-depression storage to associated GWR for each HRU', & - & 'inches', Dprst_seep_hru)/=0 ) CALL read_error(3, 'dprst_seep_hru') - - ALLOCATE ( Dprst_evap_hru(Nhru) ) - IF ( declvar(MODNAME, 'dprst_evap_hru', 'nhru', Nhru, 'real', & - & 'Evaporation from surface-depression storage for each HRU', & - & 'inches', Dprst_evap_hru)/=0 ) CALL read_error(3, 'dprst_evap_hru') - - ALLOCATE ( Dprst_vol_open_frac(Nhru) ) - IF ( declvar(MODNAME, 'dprst_vol_open_frac', 'nhru', Nhru, 'real', & - & 'Fraction of open surface-depression storage of the maximum storage for each HRU', & - & 'decimal fraction', Dprst_vol_open_frac)/=0 ) CALL read_error(3, 'dprst_vol_open_frac') - - ALLOCATE ( Dprst_vol_clos_frac(Nhru) ) - IF ( declvar(MODNAME, 'dprst_vol_clos_frac', 'nhru', Nhru, 'real', & - & 'Fraction of closed surface-depression storage of the maximum storage for each HRU', & - & 'decimal fraction', Dprst_vol_clos_frac)/=0 ) CALL read_error(3, 'dprst_vol_clos_frac') - - ALLOCATE ( Dprst_vol_frac(Nhru) ) - IF ( declvar(MODNAME, 'dprst_vol_frac', 'nhru', Nhru, 'real', & - & 'Fraction of surface-depression storage of the maximum storage for each HRU', & - & 'decimal fraction', Dprst_vol_frac)/=0 ) CALL read_error(3, 'dprst_vol_frac') - - ALLOCATE ( Dprst_vol_open_max(Nhru), Dprst_vol_clos_max(Nhru), Dprst_vol_thres_open(Nhru), Dprst_in(Nhru) ) - ENDIF - - ALLOCATE ( Hortonian_flow(Nhru) ) - IF ( declvar(MODNAME, 'hortonian_flow', 'nhru', Nhru, 'real', & - & 'Hortonian surface runoff reaching stream network for each HRU', & - & 'inches', Hortonian_flow)/=0 ) CALL read_error(3, 'hortonian_flow') - -! cascading variables and parameters - IF ( Cascade_flag>0 .OR. Model==99 ) THEN - ALLOCATE ( Upslope_hortonian(Nhru) ) - IF ( declvar(MODNAME, 'upslope_hortonian', 'nhru', Nhru, 'double', & - & 'Hortonian surface runoff received from upslope HRUs', & - & 'inches', Upslope_hortonian)/=0 ) CALL read_error(3, 'upslope_hortonian') - - IF ( declvar(MODNAME, 'basin_sroff_down', 'one', 1, 'double', & - & 'Basin area-weighted average of cascading surface runoff', & - & 'inches', Basin_sroff_down)/=0 ) CALL read_error(3, 'basin_sroff_down') - - IF ( declvar(MODNAME, 'basin_sroff_upslope', 'one', 1, 'double', & - & 'Basin area-weighted average of cascading surface runoff received from upslope HRUs', & - & 'inches', Basin_sroff_upslope)/=0 ) CALL read_error(3, 'basin_sroff_upslope') - - ALLOCATE ( Hru_hortn_cascflow(Nhru) ) - IF ( declvar(MODNAME, 'hru_hortn_cascflow', 'nhru', Nhru, 'double', & - & 'Cascading Hortonian surface runoff leaving each HRU', & - & 'inches', Hru_hortn_cascflow)/=0 ) CALL read_error(3, 'hru_hortn_cascflow') - - IF ( Nlake>0 ) THEN - IF ( declvar(MODNAME, 'basin_hortonian_lakes', 'one', 1, 'double', & - & 'Basin area-weighted average Hortonian surface runoff to lakes', & - & 'inches', Basin_hortonian_lakes)/=0 ) CALL read_error(3, 'basin_hortonian_lakes') - - ALLOCATE ( Hortonian_lakes(Nhru) ) - IF ( declvar(MODNAME, 'hortonian_lakes', 'nhru', Nhru, 'double', & - & 'Surface runoff to lakes for each HRU', & - & 'inches', Hortonian_lakes)/=0 ) CALL read_error(3, 'hortonian_lakes') - ENDIF - ENDIF - - IF ( Call_cascade==1 .OR. Model==99 ) THEN - ALLOCATE ( Strm_seg_in(Nsegment) ) - IF ( declvar(MODNAME, 'strm_seg_in', 'nsegment', Nsegment, 'double', & - & 'Flow in stream segments as a result of cascading flow in each stream segment', & - & 'cfs', Strm_seg_in)/=0 ) CALL read_error(3,'strm_seg_in') - ENDIF - -! frozen ground variables and parameters - IF ( Frozen_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Frozen(Nhru) ) - IF ( declvar(MODNAME, 'frozen', 'nhru', Nhru, 'integer', & - & 'Flag for frozen ground (0=no; 1=soil at surface; 2=soil below surf; 3=below soil)', & - & 'dimensionless', Frozen)/=0 ) CALL read_error(3, 'frozen') - - ALLOCATE ( Cfgi(Nhru) ) - IF ( declvar(MODNAME, 'cfgi', 'nhru', Nhru, 'real', & - & 'Continuous Frozen Ground Index', & - & 'index', Cfgi)/=0 ) CALL read_error(3, 'cfgi') - - ALLOCATE ( Cfgi_prev(Nhru) ) - IF ( declvar(MODNAME, 'cfgi_prev', 'nhru', Nhru, 'real', & - & 'Continuous Frozen Ground Index from previous day', & - & 'index', Cfgi_prev)/=0 ) CALL read_error(3, 'cfgi_prev') - - IF ( declparam(MODNAME, 'cfgi_decay', 'one', 'real', & - & '0.97', '0.01', '1.0', & - & 'CFGI daily decay of index, value of 1.0 is no decay', & - & 'CFGI daily decay of index, value of 1.0 is no decay', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'cfgi_decay') - - IF ( declparam(MODNAME, 'cfgi_thrshld', 'one', 'real', & - & '5.0', '5.0', '83.0', & - & 'CFGImod threshold value indicating frozen soil', & - & 'CFGImod threshold value indicating frozen soil', & - & 'index')/=0 ) CALL read_error(1, 'cfgi_thrshld') - - ALLOCATE ( Frz_depth(Nhru) ) - IF ( declvar(MODNAME, 'frz_depth', 'nhru', Nhru, 'real', & - & 'Maximum depth soil is frozen, may be thawed above', & - & 'inches', Frz_depth)/=0 ) CALL read_error(1, 'frz_depth') - - ALLOCATE ( Thaw_depth(Nhru) ) - IF ( declvar(MODNAME, 'thaw_depth', 'nhru', Nhru, 'real', & - & 'Depth soil is thawed from surface', & - & 'inches', Thaw_depth)/=0 ) CALL read_error(1, 'thaw_depth') - - ALLOCATE ( Soil_depth(Nhru) ) - IF ( declparam(MODNAME, 'soil_depth', 'nhru', 'real', & - & '19.685', '0.0', '60.0', & - & 'Depth of soil that could freeze', & - & 'Depth of soil that could freeze', & - & 'inches')/=0 ) CALL read_error(1, 'soil_depth') - - ALLOCATE ( Soil_den(Nhru) ) - IF ( declparam(MODNAME, 'soil_den', 'nhru', 'real', & - & '1.3', '0.1', '2.0', & - & 'Density of soil that could freeze', & - & 'Density of soil that could freeze, limits based on Alaska UNASM map', & - & 'gm/cm3')/=0 ) CALL read_error(1, 'soil_den') - - ALLOCATE ( Porosity_hru(Nhru) ) - IF ( declparam(MODNAME, 'porosity_hru', 'nhru', 'real', & - & '0.4', '0.15', '0.75', & - & 'Porosity of soil for frozen ground calculations', & - & 'Porosity of soil for frozen ground calculations', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'porosity_hru') - ENDIF - -! Declare parameters - IF ( Sroff_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Smidx_coef(Nhru) ) - IF ( declparam(MODNAME, 'smidx_coef', 'nhru', 'real', & - & '0.005', '0.0', '1.0', & - & 'Coefficient in contributing area computations', & - & 'Coefficient in non-linear contributing area algorithm for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'smidx_coef') - ALLOCATE ( Smidx_exp(Nhru) ) - IF ( declparam(MODNAME, 'smidx_exp', 'nhru', 'real', & - & '0.3', '0.0', '5.0', & - & 'Exponent in contributing area computations', & - & 'Exponent in non-linear contributing area algorithm for each HRU', & - & '1.0/inch')/=0 ) CALL read_error(1, 'smidx_exp') - ENDIF - - IF ( Sroff_flag==2 .OR. Model==99 ) THEN - ALLOCATE ( Carea_min(Nhru), Carea_dif(Nhru) ) - IF ( declparam(MODNAME, 'carea_min', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Minimum contributing area', & - & 'Minimum possible area contributing to surface runoff expressed as a portion of the area for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'carea_min') - ENDIF - - ALLOCATE ( Carea_max(Nhru) ) - IF ( declparam(MODNAME, 'carea_max', 'nhru', 'real', & - & '0.6', '0.0', '1.0', & - & 'Maximum contributing area', & - & 'Maximum possible area contributing to surface runoff expressed as a portion of the HRU area', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'carea_max') - -! Depression Storage parameters: - IF ( Dprst_flag==1 .OR. Model==99 ) THEN - ALLOCATE ( Dprst_depth_avg(Nhru) ) - IF ( declparam(MODNAME, 'dprst_depth_avg', 'nhru', 'real', & - & '132.0', '0.0', '500.0', & - & 'Average depth of surface depressions at maximum storage capacity', & - & 'Average depth of surface depressions at maximum storage capacity', & - & 'inches')/=0 ) CALL read_error(1, 'dprst_depth_avg') - - ALLOCATE ( Dprst_flow_coef(Nhru) ) - IF ( declparam(MODNAME, 'dprst_flow_coef', 'nhru', 'real', & - & '0.05', '0.00001', '0.5', & - & 'Coefficient in linear flow routing equation for open surface depressions', & - & 'Coefficient in linear flow routing equation for open surface depressions for each HRU', & - & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_flow_coef') - - ALLOCATE ( Dprst_seep_rate_open(Nhru) ) - IF ( declparam(MODNAME, 'dprst_seep_rate_open', 'nhru', 'real', & - & '0.02', '0.0', '0.2', & - & 'Coefficient used in linear seepage flow equation for open surface depressions', & - & 'Coefficient used in linear seepage flow equation for'// & - & ' open surface depressions for each HRU', & - & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_seep_rate_open') - - ALLOCATE ( Dprst_seep_rate_clos(Nhru) ) - IF ( declparam(MODNAME, 'dprst_seep_rate_clos', 'nhru', 'real', & - & '0.02', '0.0', '0.2', & - & 'Coefficient used in linear seepage flow equation for closed surface depressions', & - & 'Coefficient used in linear seepage flow equation for'// & - & ' closed surface depressions for each HRU', & - & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_seep_rate_clos') - - ALLOCATE ( Op_flow_thres(Nhru) ) - IF ( declparam(MODNAME, 'op_flow_thres', 'nhru', 'real', & - & '1.0', '0.01', '1.0', & - & 'Fraction of open depression storage above which surface runoff occurs for each timestep', & - & 'Fraction of open depression storage above'// & - & ' which surface runoff occurs; any water above'// & - & ' maximum open storage capacity spills as surface runoff', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'op_flow_thres') - - ALLOCATE ( Sro_to_dprst_perv(Nhru) ) - IF ( PRMS4_flag==1 ) THEN - IF ( declparam(MODNAME, 'sro_to_dprst', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Fraction of pervious surface runoff that flows into surface-depression storage', & - & 'Fraction of pervious surface runoff that'// & - & ' flows into surface-depression storage; the remainder'// & - & ' flows to a stream network for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst') - ELSE - IF ( declparam(MODNAME, 'sro_to_dprst_perv', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Fraction of pervious surface runoff that flows into surface-depression storage', & - & 'Fraction of pervious surface runoff that'// & - & ' flows into surface-depression storage; the remainder'// & - & ' flows to a stream network for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_perv') - ENDIF - - ALLOCATE ( Sro_to_dprst_imperv(Nhru) ) - IF ( declparam(MODNAME, 'sro_to_dprst_imperv', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Fraction of impervious surface runoff that flows into surface-depression storage', & - & 'Fraction of impervious surface runoff that'// & - & ' flows into surface-depression storage; the remainder'// & - & ' flows to a stream network for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_imperv') - - ALLOCATE ( Dprst_et_coef(Nhru) ) - IF ( declparam(MODNAME, 'dprst_et_coef', 'nhru', 'real', & - & '1.0', '0.5', '1.5', & - & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression storage', & - & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression storage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'dprst_et_coef') - - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN - ALLOCATE ( Dprst_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'dprst_frac_init', 'nhru', 'real', & - & '0.5', '0.0', '1.0', & - & 'Fraction of maximum storage that contains water at the start of a simulation', & - & 'Fraction of maximum surface-depression storage that'// & - & ' contains water at the start of a simulation', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'dprst_frac_init') - ENDIF - - ALLOCATE ( Va_open_exp(Nhru) ) - IF ( declparam(MODNAME, 'va_open_exp', 'nhru', 'real', & - & '0.001', '0.0001', '10.0', & - & 'Coefficient in the exponential equation to compute'// & - & ' current surface area of open surface-depression storage', & - & 'Coefficient in the exponential equation relating'// & - & ' maximum surface area to the fraction that open'// & - & ' depressions are full to compute current surface area for each HRU;'// & - & ' 0.001 is an approximate cylinder; 1.0 is a cone', & - & 'none')/=0 ) CALL read_error(1, 'va_open_exp') - - ALLOCATE ( Va_clos_exp(Nhru) ) - IF ( declparam(MODNAME, 'va_clos_exp', 'nhru', 'real', & - & '0.001', '0.0001', '10.0', & - & 'Coefficient in the exponential equation to compute'// & - & ' current surface area of closed surface-depression storage', & - & 'Coefficient in the exponential equation relating'// & - & ' maximum surface area to the fraction that closed'// & - & ' depressions are full to compute current surface area for each HRU;'// & - & ' 0.001 is an approximate cylinder; 1.0 is a cone', & - & 'none')/=0 ) CALL read_error(1, 'va_clos_exp') - ENDIF - - IF ( Print_debug==1 ) THEN - ALLOCATE ( Imperv_stor_ante(Nhru) ) - IF ( Dprst_flag==1 ) ALLOCATE ( Dprst_stor_ante(Nhru) ) - ENDIF - - END FUNCTION srunoffdecl - -!*********************************************************************** -! srunoffinit - Initialize srunoff module - get parameter values -!*********************************************************************** - INTEGER FUNCTION srunoffinit() - USE PRMS_SRUNOFF - USE PRMS_MODULE, ONLY: Dprst_flag, Nhru, Nlake, Cascade_flag, Sroff_flag, & - & Init_vars_from_file, Call_cascade, Water_use_flag, & - & Frozen_flag!, Parameter_check_flag - USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order -! USE PRMS_FLOWVARS, ONLY: Soil_moist_max - IMPLICIT NONE -! Functions - INTEGER, EXTERNAL :: getparam - EXTERNAL read_error -! Local Variables - INTEGER :: i, j !, k, num_hrus -! REAL :: frac -!*********************************************************************** - srunoffinit = 0 - - Use_sroff_transfer = 0 - IF ( Water_use_flag==1 ) Use_sroff_transfer = 1 - - Imperv_evap = 0.0 - Hortonian_flow = 0.0 - Hru_sroffi = 0.0 - Hru_sroffp = 0.0 - Contrib_fraction = 0.0 - Hru_impervevap = 0.0 - Hru_impervstor = 0.0 - IF ( Call_cascade==1 ) Strm_seg_in = 0.0D0 - IF ( Cascade_flag>0 ) THEN - Upslope_hortonian = 0.0D0 - Hru_hortn_cascflow = 0.0D0 - IF ( Nlake>0 ) Hortonian_lakes = 0.0D0 - ENDIF - - IF ( Init_vars_from_file==0 ) THEN - Basin_sroffi = 0.0D0 - Basin_sroffp = 0.0D0 - Basin_infil = 0.0D0 - Basin_sroff = 0.0D0 - Basin_imperv_evap = 0.0D0 - Basin_imperv_stor = 0.0D0 - Basin_hortonian = 0.0D0 - Basin_dprst_sroff = 0.0D0 - Basin_dprst_evap = 0.0D0 - Basin_dprst_seep = 0.0D0 - Basin_dprst_volop = 0.0D0 - Basin_dprst_volcl = 0.0D0 - Basin_sroff_upslope = 0.0D0 - Basin_sroff_down = 0.0D0 - Basin_hortonian_lakes = 0.0D0 - Basin_contrib_fraction = 0.0D0 - Srp = 0.0 - Sri = 0.0 - IF ( Frozen_flag==1 ) THEN - Frozen = 0 - Cfgi = 0.0 - Cfgi_prev = 0.0 - Frz_depth = 0.0 - Thaw_depth = 0.0 - ENDIF - ENDIF - - IF ( getparam(MODNAME, 'carea_max', Nhru, 'real', Carea_max)/=0 ) CALL read_error(2, 'carea_max') - - IF ( Sroff_flag==1 ) THEN -! Smidx parameters - IF ( getparam(MODNAME, 'smidx_coef', Nhru, 'real', Smidx_coef)/=0 ) CALL read_error(2, 'smidx_coef') - IF ( getparam(MODNAME, 'smidx_exp', Nhru, 'real', Smidx_exp)/=0 ) CALL read_error(2, 'smidx_exp') - ELSE !IF ( Sroff_flag==2 ) THEN -! Carea parameters - IF ( getparam(MODNAME, 'carea_min', Nhru, 'real', Carea_min)/=0 ) CALL read_error(2, 'carea_min') - Carea_dif = 0.0 - DO j = 1, Active_hrus - i = Hru_route_order(j) - Carea_dif(i) = Carea_max(i) - Carea_min(i) - ENDDO - ENDIF - -! num_hrus = 0 -! DO j = 1, Active_hrus -! i = Hru_route_order(j) -! IF ( Sroff_flag==2 ) THEN -! Carea_dif(i) = Carea_max(i) - Carea_min(i) -! ELSEIF ( Parameter_check_flag>0 ) THEN -! frac = Smidx_coef(i)*10**(Soil_moist_max(i)*Smidx_exp(i)) -! k = 0 -! IF ( frac>2.0 ) k = 1 -! IF ( frac>Carea_max(i)*2.0 ) k = k + 2 -! IF ( k>0 ) THEN -! num_hrus = num_hrus + 1 - !IF ( Print_debug>-1 ) THEN - ! PRINT *, ' ' - ! PRINT *, 'WARNING' - ! PRINT *, 'Contributing area based on smidx parameters and soil_moist_max:', frac - ! IF ( k==1 .OR. k==3 ) PRINT *, 'Maximum contributing area > 200%' - ! IF ( k>1 ) PRINT *, 'Maximum contributing area > carea_max:', Carea_max(i) - ! PRINT *, 'HRU:', i, '; soil_moist_max:', Soil_moist_max(i) - ! PRINT *, 'smidx_coef:', Smidx_coef(i), '; smidx_exp:', Smidx_exp(i) - ! PRINT *, 'This can make smidx parameters insensitive and carea_max very sensitive' - !ENDIF -! ENDIF -! ENDIF -! ENDDO -! IF ( num_hrus>0 .AND. Print_debug>-1 ) THEN -! WRITE (*, '(/,A,/,9X,A,/,9X,A,I7,/,9X,A,/,9X,A,/)') & -! & 'WARNING, maximum contributing area based on smidx coefficents and', & -! & 'soil_moist_max are > 200% of the HRU area and/or > 2*carea_max', & -! & 'number of HRUs for which this condition exists:', num_hrus, & -! & 'This means the smidx parameters are insensitive and', & -! & 'carea_max very sensitive for those HRUs' -! ENDIF - -! Frozen soil parameters - IF ( Frozen_flag==1 ) THEN - IF ( getparam(MODNAME, 'cfgi_thrshld', 1, 'real', Cfgi_thrshld)/=0 ) CALL read_error(2, 'cfgi_thrshld') - IF ( getparam(MODNAME, 'cfgi_decay', 1, 'real', Cfgi_decay)/=0 ) CALL read_error(2, 'cfgi_decay') - IF ( getparam(MODNAME, 'soil_depth', Nhru, 'real', Soil_depth)/=0 ) CALL read_error(2, 'soil_depth') - IF ( getparam(MODNAME, 'soil_den', Nhru, 'real', Soil_den)/=0 ) CALL read_error(2, 'soil_den') - IF ( getparam(MODNAME, 'porosity_hru', Nhru, 'real', Porosity_hru)/=0 ) CALL read_error(2, 'porosity_hru') - ENDIF - -! Depression Storage parameters and variables: - IF ( Dprst_flag==1 ) CALL dprst_init() - - END FUNCTION srunoffinit - -!*********************************************************************** -! srunoffrun - Computes surface runoff using contributing area -! computations using antecedent soil moisture. -!*********************************************************************** - INTEGER FUNCTION srunoffrun() - USE PRMS_SRUNOFF - USE PRMS_MODULE, ONLY: Dprst_flag, Cascade_flag, Call_cascade, Print_debug, Frozen_flag, Glacier_flag - USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, & - & Hru_perv, Hru_imperv, Hru_percent_imperv, Hru_frac_perv, & - & Dprst_area_max, Hru_area, Hru_type, Basin_area_inv, & - & Dprst_area_clos_max, Dprst_area_open_max, Hru_area_dble, Cov_type, INCH2M - USE PRMS_CLIMATEVARS, ONLY: Potet, Tavgc - USE PRMS_FLOWVARS, ONLY: Sroff, Infil, Imperv_stor, Pkwater_equiv, Dprst_vol_open, Dprst_vol_clos, & - & Imperv_stor_max, Snowinfil_max, Glacier_frac, Soil_moist - USE PRMS_CASCADE, ONLY: Ncascade_hru - USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Hru_intcpevap, Net_apply, Intcp_changeover - USE PRMS_SNOW, ONLY: Snow_evap, Snowcov_area, Snowmelt, Pk_depth, Glacrb_melt, & - & Tcal, Tcal_nosnow, Glacrcov_area, Prev_ann_tempc - IMPLICIT NONE - INTRINSIC SNGL, DBLE - EXTERNAL imperv_et, compute_infil, run_cascade_sroff, dprst_comp, perv_comp -! Local Variables - INTEGER :: i, k, dprst_chk, frzen, active_glacier - REAL :: srunoff, avail_et, hperv, sra, availh2o - DOUBLE PRECISION :: hru_sroff_down, runoff, apply_sroff, cfgi_sroff - REAL :: cfgi_k, depth_cm, nosnow_area, depthg_cm, trad, emiss, emisl ! frozen ground - REAL :: cfgi_kg, depthg_cm, soil_cond, latent_soil, nice, ice_cond ! frozen ground - REAL :: water_cond, sat_cond, mean_cond, lambda, omega, l5, l6, l8 ! frozen ground - REAL :: volumetric_soil, thermal_ratio_alp, fusion_param_mu, frz_height ! frozen ground - REAL :: glcrmltb, temp, temp2, trad, emiss, emisl ! glaciers - REAL, PARAMETER :: Freezepoint = 0.0 !deg C freezing point of soil moisture, could be below 0 in fine grained soil -!*********************************************************************** - srunoffrun = 0 - - IF ( Print_debug==1 ) THEN - Imperv_stor_ante = Hru_impervstor - IF ( Dprst_flag==1 ) Dprst_stor_ante = Dprst_stor_hru - ENDIF - Basin_sroffi = 0.0D0 - Basin_sroffp = 0.0D0 - Basin_sroff = 0.0D0 - Basin_infil = 0.0D0 - Basin_imperv_evap = 0.0D0 - Basin_imperv_stor = 0.0D0 - Basin_hortonian = 0.0D0 - Basin_contrib_fraction = 0.0D0 - Basin_cfgi_sroff = 0.0D0 - Basin_apply_sroff = 0.0D0 - - IF ( Call_cascade==1 ) Strm_seg_in = 0.0D0 - IF ( Cascade_flag>0 ) THEN - Basin_sroff_down = 0.0D0 - Basin_sroff_upslope = 0.0D0 - Basin_hortonian_lakes = 0.0D0 - Upslope_hortonian = 0.0D0 - ENDIF - - IF ( Dprst_flag==1 ) THEN - Basin_dprst_sroff = 0.0D0 - Basin_dprst_evap = 0.0D0 - Basin_dprst_seep = 0.0D0 - Basin_dprst_volop = 0.0D0 - Basin_dprst_volcl = 0.0D0 - ENDIF - - dprst_chk = 0 - DO k = 1, Active_hrus - i = Hru_route_order(k) - Hruarea = Hru_area(i) - Hruarea_dble = Hru_area_dble(i) - Ihru = i - runoff = 0.0D0 - glcrmltb = 0.0 ! glacier - Isglacier = 0 - active_glacier = -1 ! not an glacier - IF ( Glacier_flag>0 ) THEN - IF ( Hru_type(i)==4 ) THEN - IF ( Glacier_flag==1 ) THEN ! glacier - Isglacier = 1 - glcrmltb = Glacrb_melt(i) - IF ( Glacier_frac(i)>0.0 ) THEN - active_glacier = 1 - ELSE - active_glacier = 0 ! glacier capable HRU, but not glaciated - ENDIF - ENDIF - ENDIF - ENDIF - - IF ( Hru_type(i)==2 ) THEN -! HRU is a lake -! eventually add code for lake area less than hru_area -! that includes soil_moist for fraction of hru_area that is dry bank - ! Sanity check - IF ( Infil(i)+Sroff(i)+Imperv_stor(i)+Imperv_evap(i)>0.0 ) & - & PRINT *, 'srunoff lake ERROR', Infil(i), Sroff(i), Imperv_stor(i), Imperv_evap(i), i - IF ( Cascade_flag>0 ) THEN - Hortonian_lakes(i) = Upslope_hortonian(i) - Basin_hortonian_lakes = Basin_hortonian_lakes + Hortonian_lakes(i)*Hruarea_dble - ENDIF - CYCLE - ENDIF - - Infil(i) = 0.0 - hperv = Hru_perv(i) - Perv_frac = Hru_frac_perv(i) - Srp = 0.0 - Sri = 0.0 - Hru_sroffp(i) = 0.0 - Contrib_fraction(i) = 0.0 - Hruarea_imperv = Hru_imperv(i) - Imperv_frac = Hru_percent_imperv(i) - Hru_sroffi(i) = 0.0 - Imperv_evap(i) = 0.0 - Hru_impervevap(i) = 0.0 - - avail_et = Potet(i) - Snow_evap(i) - Hru_intcpevap(i) - - frzen = 0 - thaw_frac = 1.0 - IF ( Frozen_flag==1 ) THEN - ! modCFGI, following Follum et al 2018 - ! set emissivity, which is the fraction of perfect black-body - ! emission that is actually applied - ! Stefan Boltzmann/2 = (11.71E-8)/2 = 0.585E-7 because add for day and night - ! energy available to snowpack proxy temperature - emiss = 0.97 ! [fraction of radiation] snow - emisl = 0.95 ! [fraction of radiation] land based on Jin and Liang 2006 - nosnow_area = 1.0-Snowcov_area(i) - IF (Glacier_flag==1) nosnow_area = nosnow_area-Glacrcov_area(i) !there will only be permafrost if glacierettes - trad = ( Snowcov_area(i)*Tcal(i)/(emiss*0.585E-7) )**0.25 - 273.15 !energy that is available to heat land under snow - trad = trad+( nosnow_area*Tcal_nosnow(i)/(emisl*0.585E-7))**0.25 - 273.15 !energy that is available to heat land without snow - - cfgi_kg = 1.0 !From Follum et al 2018, could be a bit high - IF ( Tavgc(i)>0.0 ) THEN ![cal/cm^2] or [Langleys] - cfgi_k = 0.5 - ELSE - cfgi_k = 0.08 - ENDIF - ! depth over only snow covered area, so real depth of pack because considering land heat too now - depth_cm = SNGL(Pk_depth(i)/Snowcov_area(i))*2.54 - ! depth ground cover only, from Follum et al, 2018, but was in Vermont - If (Cov_type(i)==0) depthg_cm = 0.0 !bare soil (rock, may be mostly impervious already) - If (Cov_type(i)==1) depthg_cm = 4.0 !grasses (boreal grass, tundra) - If (Cov_type(i)==2) depthg_cm = 3.0 !shrub (tundra) - If (Cov_type(i)>=3) depthg_cm = 6.0 !trees - If (Cov_type(i)==4) depthg_cm = 2.0 !coniferous - -! Continuous frozen ground index - Cfgi(i) = Cfgi_decay*Cfgi_prev(i) - trad*( 2.71828**(-0.4*(cfgi_k*depth_cm+cfgi_kg*depthg_cm)) ) - IF ( active_glacier==1 ) THEN - Cfgi(i) = 0.0 !if glacier over, want ground completely unfrozen, or below threshold, infiltration - IF ( Glacier_frac(i)<1.0 ) Cfgi(i) = Cfgi_thrshld ! glacier with some open fraction - ENDIF - IF ( Cfgi(i)<0.0 ) Cfgi(i) = 0.0 -! If above the threshold to be frozen - IF ( Cfgi(i)>=Cfgi_thrshld ) THEN - ! Use modified Berggren formula to get a depth of frozen - ! volumetric heat of fusion of the soil - volumetric_soil = Soil_den(i)*(4.187*0.17 + 0.75*omega)/1.e6 ! J/m^3/K, specific heat of rock, water, ice =0.17, 1, 0.5 *4.187 J/g/K , density in g/cm3 - ! latent heat of fusion of the soil - latent_soil = 334.0*Soil_den(i)*omega/1.e6 ! J/m^3, latent heat of fusion of water = 334 J/g , density in g/cm3 */100 - thermal_ratio_alp = (Prev_ann_tempc(i) - Freezepoint)/(Cfgi(i) - Cfgi_thrshld) !degree K/ index Ti/Ts - IF ( thermal_ratio_alp<0.0 ) thermal_ratio_alp = 0.0 - fusion_param_mu =(Cfgi(i) - Cfgi_thrshld)*volumetric_soil/latent_soil !index/degree K St12 - ! lambda corrects the Stefan formula for the effects of volumetric heat which it neglected - beta = 1.0 !ranges between 0.95 and 1.3 depending on soil type and soil moisture - lambda = 1.0 !Graph in Aldrich 1956, says in Alaska this is usually 1 but if less northern, can be as low as 0.3 - lambda = ( 1.0 + 0.147*fusion_param_mu*((beta*thermal_ratio_alp)**2.0) - l5 = 1.0 -0.16*fusion_param_mu +0.038*(fusion_param_mu**2.0) !Kurylyk and Hayashi 2016, Ti = 0 - l6 = ( 1.0 + 0.147*fusion_param_mu*((beta*thermal_ratio_alp)**2.0)+ 0.535*(fusion_param_mu**0.5)*beta*thermal_ratio_alp )*l5 ! Kurylyk and Hayashi 2016, Ti < 0 - l8 = ( 1.0 + 0.061*(fusion_param_mu**0.88)*((thermal_ratio_alp/beta)**1.65)- 0.43*(fusion_param_mu**0.44)*((thermal_ratio_alp/beta)**0.825) )*l5 ! Kurylyk and Hayashi 2016, Ti > 0 - IF ( Cfgi(i)>Cfgi_prev(i) ) lambda = l8 !freezing - IF ( Cfgi(i)Frz_depth(i) ) Frz_depth(i) = frz_height - IF ( Frz_height==0.0 ) Frz_depth(i) = 0.0 ! everything thawed - Thaw_depth(i) = Frz_depth(i) - frz_height ! active layer is between Frz_depth and Thaw_depth - - ! Can frz_depth be greater than soil_depth? - IF (Frz_height>0.0) THEN - IF ( Thaw_depth(i)==0.0) THEN - frzen = 1 !soil frozen at top - thaw_frac = 0.0 - ELSEIF ( Thaw_depth(i)=Soil_depth(i) ) THEN ! Thaw_depth(i)>=Soil_depth(i)) - frzen = 3 !soil not frozen but below is, thaw_frac = 1.0 - ENDIF - ENDIF - ENDIF - - IF (frzen>0) THEN - ! depression storage states are not changed for frozen parts of soil - IF ( Cascade_flag>0 ) THEN - cfgi_sroff = (1.0-thaw_frac)*(Snowmelt(i) + Net_rain(i) + Upslope_hortonian(i) + glcrmltb)*Hruarea - ELSE - cfgi_sroff = (1.0-thaw_frac)*(Snowmelt(i) + Net_rain(i) + glcrmltb)*Hruarea - ENDIF - IF ( Use_sroff_transfer==1 ) cfgi_sroff = cfgi_sroff + Net_apply(i)*Hruarea - runoff = runoff + cfgi_sroff - Basin_cfgi_sroff = Basin_cfgi_sroff + cfgi_sroff - ELSE !not frozen - Frz_depth(i) = 0.0 - Thaw_depth(i) = 0.0 - ENDIF - Frozen(i) = frzen - Cfgi_prev(i) = Cfgi(i) - ENDIF - -!******Compute runoff for pervious, impervious, and depression storage area, only if not totally frozen ground - IF ( frzen/=1 ) THEN -! DO IRRIGATION APPLICATION, ONLY DONE HERE, ASSUMES NO SNOW and -! only for pervious areas (just like infiltration) - IF ( Use_sroff_transfer==1 ) THEN - IF ( Net_apply(i)>0.0 ) THEN - sra = 0.0 - Infil(i) = Infil(i) + Net_apply(i) - IF ( Hru_type(i)==1 ) THEN - CALL perv_comp(Net_apply(i), Net_apply(i), Infil(i), sra, thaw_frac) -! ** ADD in water from irrigation application and water-use transfer for pervious portion - sra (if any) - apply_sroff = DBLE( sra*hperv ) - Basin_apply_sroff = Basin_apply_sroff + apply_sroff - runoff = runoff + apply_sroff - ENDIF - ENDIF - ENDIF - - availh2o = Intcp_changeover(i) + Net_rain(i) - IF ( Isglacier==1 ) THEN ! glacier - temp = Snowmelt(i) + glcrmltb !Snowmelt or 0.0 - temp2 = availh2o*(1.0-Glacier_frac(i)) - CALL compute_infil(temp2, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), temp, & - & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i), thaw_frac) - ELSE - CALL compute_infil(availh2o, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), Snowmelt(i), & - & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i), thaw_frac) - ENDIF - - ENDIF - - IF ( Dprst_flag==1 ) THEN - Dprst_in(i) = 0.0D0 - dprst_chk = 0 - IF ( Dprst_area_max(i)>0.0 ) THEN - dprst_chk = 1 -! ******Compute the depression storage component -! only call if total depression surface area for each HRU is > 0.0 - IF ( frzen/=1 ) THEN - CALL dprst_comp(Dprst_vol_clos(i), Dprst_area_clos_max(i), Dprst_area_clos(i), & - & Dprst_vol_open_max(i), Dprst_vol_open(i), Dprst_area_open_max(i), Dprst_area_open(i), & - & Dprst_sroff_hru(i), Dprst_seep_hru(i), Sro_to_dprst_perv(i), Sro_to_dprst_imperv(i), & - & Dprst_evap_hru(i), avail_et, availh2o, Dprst_in(i), thaw_frac) - runoff = runoff + Dprst_sroff_hru(i)*Hruarea_dble - ENDIF - ENDIF - ENDIF -! ********************************************************** - - srunoff = 0.0 - IF ( Hru_type(i)==1 .OR. active_glacier==0 ) THEN ! could be an glacier-capable HRU with no ice -!******Compute runoff for pervious and impervious area, and depression storage area - runoff = runoff + DBLE( Srp*hperv + Sri*Hruarea_imperv ) - srunoff = SNGL( runoff/Hruarea_dble ) - -!******Compute HRU weighted average (to units of inches/dt) - IF ( Cascade_flag>0 ) THEN - hru_sroff_down = 0.0D0 - IF ( srunoff>0.0 ) THEN - IF ( Ncascade_hru(i)>0 ) CALL run_cascade_sroff(Ncascade_hru(i), srunoff, hru_sroff_down) - Hru_hortn_cascflow(i) = hru_sroff_down - !IF ( Hru_hortn_cascflow(i)<0.0D0 ) Hru_hortn_cascflow(i) = 0.0D0 - !IF ( Upslope_hortonian(i)<0.0D0 ) Upslope_hortonian(i) = 0.0D0 - Basin_sroff_upslope = Basin_sroff_upslope + Upslope_hortonian(i)*Hruarea_dble - Basin_sroff_down = Basin_sroff_down + hru_sroff_down*Hruarea_dble - ELSE - Hru_hortn_cascflow(i) = 0.0D0 - ENDIF - ENDIF - Hru_sroffp(i) = Srp*Perv_frac - Basin_sroffp = Basin_sroffp + Srp*hperv - ENDIF - - Basin_infil = Basin_infil + DBLE( Infil(i)*hperv ) - Basin_contrib_fraction = Basin_contrib_fraction + DBLE( Contrib_fraction(i)*hperv ) - -!******Compute evaporation from impervious area - IF ( frzen==0 ) THEN - IF ( Hruarea_imperv>0.0 ) THEN - IF ( Imperv_stor(i)>0.0 ) THEN - CALL imperv_et(Imperv_stor(i), Potet(i), Imperv_evap(i), Snowcov_area(i), avail_et) - Hru_impervevap(i) = Imperv_evap(i)*Imperv_frac - !IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 - avail_et = avail_et - Hru_impervevap(i) - IF ( avail_et<0.0 ) THEN - ! sanity check -! IF ( avail_et<-NEARZERO ) PRINT*, 'avail_et<0 in srunoff imperv', i, Nowmonth, Nowday, avail_et - Hru_impervevap(i) = Hru_impervevap(i) + avail_et - IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 - Imperv_evap(i) = Hru_impervevap(i)/Imperv_frac - Imperv_stor(i) = Imperv_stor(i) - avail_et/Imperv_frac - avail_et = 0.0 - ENDIF - Basin_imperv_evap = Basin_imperv_evap + DBLE( Hru_impervevap(i)*Hruarea ) - Hru_impervstor(i) = Imperv_stor(i)*Imperv_frac - Basin_imperv_stor = Basin_imperv_stor + DBLE(Imperv_stor(i)*Hruarea_imperv ) - ENDIF - Hru_sroffi(i) = Sri*Imperv_frac - Basin_sroffi = Basin_sroffi + DBLE( Sri*Hruarea_imperv ) - ENDIF - ENDIF - - IF ( dprst_chk==1 ) Dprst_stor_hru(i) = (Dprst_vol_open(i)+Dprst_vol_clos(i))/Hruarea_dble - - Sroff(i) = srunoff - Hortonian_flow(i) = srunoff - Basin_hortonian = Basin_hortonian + DBLE( srunoff*Hruarea ) - Basin_sroff = Basin_sroff + DBLE( srunoff*Hruarea ) - ENDDO - -!******Compute basin weighted averages (to units of inches/dt) - !rsr, should be land_area??? - Basin_sroff = Basin_sroff*Basin_area_inv - Basin_imperv_evap = Basin_imperv_evap*Basin_area_inv - Basin_imperv_stor = Basin_imperv_stor*Basin_area_inv - Basin_infil = Basin_infil*Basin_area_inv - ! doesn't include CFGI runoff - Basin_sroffp = Basin_sroffp*Basin_area_inv - Basin_sroffi = Basin_sroffi*Basin_area_inv - Basin_hortonian = Basin_hortonian*Basin_area_inv - Basin_contrib_fraction = Basin_contrib_fraction*Basin_area_inv - IF ( Cascade_flag>0 ) THEN - Basin_hortonian_lakes = Basin_hortonian_lakes*Basin_area_inv - Basin_sroff_down = Basin_sroff_down*Basin_area_inv - Basin_sroff_upslope = Basin_sroff_upslope*Basin_area_inv - ENDIF - - IF ( Dprst_flag==1 ) THEN - Basin_dprst_volop = Basin_dprst_volop*Basin_area_inv - Basin_dprst_volcl = Basin_dprst_volcl*Basin_area_inv - Basin_dprst_evap = Basin_dprst_evap*Basin_area_inv - Basin_dprst_seep = Basin_dprst_seep*Basin_area_inv - Basin_dprst_sroff = Basin_dprst_sroff*Basin_area_inv - ENDIF - - END FUNCTION srunoffrun - -!*********************************************************************** -! Subroutine to compute evaporation from impervious area at -! potential ET rate up to available ET -!*********************************************************************** - SUBROUTINE imperv_et(Imperv_stor, Potet, Imperv_evap, Sca, Avail_et) - USE PRMS_SRUNOFF, ONLY: Imperv_frac - IMPLICIT NONE -! Arguments - REAL, INTENT(IN) :: Potet, Sca, Avail_et - REAL, INTENT(INOUT) :: Imperv_stor, Imperv_evap -!*********************************************************************** - IF ( Sca<1.0 ) THEN - IF ( PotetAvail_et ) Imperv_evap = Avail_et/Imperv_frac - Imperv_stor = Imperv_stor - Imperv_evap - ENDIF - !rsr, sanity check -! IF ( Imperv_stor<0.0 ) THEN -! PRINT *, 'imperv_stor<0', Imperv_stor -! Imperv_stor = 0.0 -! ENDIF - - END SUBROUTINE imperv_et - -!*********************************************************************** -! Compute infiltration -!*********************************************************************** - SUBROUTINE compute_infil(Net_rain, Net_ppt, Imperv_stor, Imperv_stor_max, Snowmelt, & - & Snowinfil_max, Net_snow, Pkwater_equiv, Infil, Hru_type, Thaw_frac) - USE PRMS_SRUNOFF, ONLY: Sri, Hruarea_imperv, Upslope_hortonian, Ihru, Srp, Isglacier, & - USE PRMS_SNOW, ONLY: Pptmix_nopack - USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO - USE PRMS_MODULE, ONLY: Cascade_flag - IMPLICIT NONE -! Arguments - INTEGER, INTENT(IN) :: Hru_type - REAL, INTENT(IN) :: Net_rain, Net_ppt, Imperv_stor_max, Thaw_frac - REAL, INTENT(IN) :: Snowmelt, Snowinfil_max, Net_snow - DOUBLE PRECISION, INTENT(IN) :: Pkwater_equiv - REAL, INTENT(INOUT) :: Imperv_stor, Infil -! Functions - INTRINSIC SNGL - EXTERNAL perv_comp, check_capacity -! Local Variables - REAL :: avail_water - INTEGER :: hru_flag -!*********************************************************************** - hru_flag = 0 - IF ( Hru_type==1 .OR. Isglacier==1 ) hru_flag = 1 ! land or glacier -! compute runoff from cascading Hortonian flow - IF ( Cascade_flag>0 ) THEN - avail_water = SNGL( Upslope_hortonian(Ihru) ) - IF ( avail_water>0.0 ) THEN - Infil = avail_water - IF ( hru_flag==1 ) CALL perv_comp(avail_water, avail_water, Infil, Srp, Thaw_frac) - ENDIF - ELSE - avail_water = 0.0 - ENDIF - -!******if rain/snow event with no antecedent snowpack, -!******compute the runoff from the rain first and then proceed with the -!******snowmelt computations - - IF ( Pptmix_nopack(Ihru)==1 ) THEN - avail_water = avail_water + Net_rain - Infil = Infil + Net_rain - IF ( hru_flag==1 ) CALL perv_comp(Net_rain, Net_rain, Infil, Srp, Thaw_frac) - ENDIF - -!******If precipitation on snowpack, all water available to the surface is -!******considered to be snowmelt, and the snowmelt infiltration -!******procedure is used. If there is no snowpack and no precip, -!******then check for melt from last of snowpack. If rain/snow mix -!******with no antecedent snowpack, compute snowmelt portion of runoff. - - IF ( Snowmelt>0.0 ) THEN - avail_water = avail_water + Snowmelt - Infil = Infil + Snowmelt - IF ( hru_flag==1 ) THEN - IF ( Pkwater_equiv>0.0D0 .OR. Net_ppt-Net_snow0.0 ) THEN -! no snow, some rain - avail_water = avail_water + Net_rain - Infil = Infil + Net_rain - IF ( hru_flag==1 ) CALL perv_comp(Net_rain, Net_rain, Infil, Srp, Thaw_frac) - ENDIF - -!***** Snowpack exists, check to see if infil exceeds maximum daily -!***** snowmelt infiltration rate. Infil results from rain snow mix -!***** on a snowfree surface. - - ELSEIF ( Infil>0.0 ) THEN - IF ( hru_flag==1 ) CALL check_capacity(Snowinfil_max, Infil) - ENDIF - -!******Impervious area computations - IF ( Hruarea_imperv>0.0 ) THEN - Imperv_stor = Imperv_stor + avail_water - IF ( hru_flag==1 ) THEN - IF ( Imperv_stor>Imperv_stor_max ) THEN - Sri = Imperv_stor - Imperv_stor_max - Imperv_stor = Imperv_stor_max - ENDIF - ENDIF - ENDIF - - END SUBROUTINE compute_infil - -!*********************************************************************** - SUBROUTINE perv_comp(Pptp, Ptc, Infil, Srp, Thaw_frac) - USE PRMS_SRUNOFF, ONLY: Ihru, Smidx_coef, Smidx_exp, & - & Carea_max, Carea_min, Carea_dif, Contrib_fraction, Thaw_frac - USE PRMS_MODULE, ONLY: Sroff_flag -! USE PRMS_BASIN, ONLY: CLOSEZERO - USE PRMS_FLOWVARS, ONLY: Soil_moist, Soil_rechr, Soil_rechr_max - IMPLICIT NONE -! Arguments - REAL, INTENT(IN) :: Pptp, Ptc, Thaw_frac - REAL, INTENT(INOUT) :: Infil, Srp -! Local Variables - REAL :: smidx, srpp, ca_fraction -!*********************************************************************** -!******Pervious area computations - IF ( Sroff_flag==1 ) THEN - ! antecedent soil_moist - smidx = Soil_moist(Ihru) + (0.5*Ptc) - ca_fraction = Smidx_coef(Ihru)*10.0**(Smidx_exp(Ihru)*smidx) - ELSE - ! antecedent soil_rechr - ca_fraction = Carea_min(Ihru) + Carea_dif(Ihru)*(Soil_rechr(Ihru)/(Thaw_frac*Soil_rechr_max(Ihru))) - ENDIF - IF ( ca_fraction>Carea_max(Ihru) ) ca_fraction = Carea_max(Ihru) - srpp = ca_fraction*Pptp - Contrib_fraction(Ihru) = ca_fraction -! IF ( srpp<0.0 ) THEN -! PRINT *, 'negative srp', srpp -! srpp = 0.0 -! ENDIF - Infil = Infil - srpp - Srp = Srp + srpp - !IF ( Srp 0, cascade contributes to a downslope HRU - IF ( j>0 ) THEN - Upslope_hortonian(j) = Upslope_hortonian(j) + DBLE( Runoff*Hru_down_fracwt(k, Ihru) ) - Hru_sroff_down = Hru_sroff_down + DBLE( Runoff*Hru_down_frac(k,Ihru) ) - -! if hru_down(k, Ihru) < 0, cascade contributes to a stream - ELSEIF ( j<0 ) THEN - j = IABS( j ) - Strm_seg_in(j) = Strm_seg_in(j) + DBLE( Runoff*Cascade_area(k, Ihru) )*Cfs_conv - ENDIF - ENDDO - -! reset Sroff as it accumulates flow to streams - Runoff = Runoff - SNGL( Hru_sroff_down ) -! IF ( Runoff<0.0 ) THEN -! IF ( Runoff<-NEARZERO ) THEN -! IF ( Print_debug>-1 ) PRINT *, 'runoff < NEARZERO', Runoff -! IF ( Hru_sroff_down>ABS(Runoff) ) THEN -! Hru_sroff_down = Hru_sroff_down - Runoff -! ELSE -! DO k = 1, Ncascade_hru -! j = Hru_down(k, Ihru) -! IF ( Strm_seg_in(j)>ABS(Runoff) ) THEN -! Strm_seg_in(j) = Strm_seg_in(j) - Runoff -! EXIT -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! Runoff = 0.0 -! ENDIF - - END SUBROUTINE run_cascade_sroff - -!*********************************************************************** -! fill soil to soil_moist_max, if more than capacity restrict -! infiltration by snowinfil_max, with excess added to runoff -!*********************************************************************** - SUBROUTINE check_capacity(Snowinfil_max, Infil) - USE PRMS_FLOWVARS, ONLY: Soil_moist_max, Soil_moist - USE PRMS_SRUNOFF, ONLY: Ihru, Srp - IMPLICIT NONE -! Arguments - REAL, INTENT(IN) :: Snowinfil_max - REAL, INTENT(INOUT) :: Infil -! Local Variables - REAL :: capacity, excess -!*********************************************************************** - capacity = Soil_moist_max(Ihru) - Soil_moist(Ihru) - excess = Infil - capacity - IF ( excess>Snowinfil_max ) THEN - Srp = Srp + excess - Snowinfil_max - Infil = Snowinfil_max + capacity - ENDIF - - END SUBROUTINE check_capacity - -!*********************************************************************** -! Initialize depression storage area hydrology -!*********************************************************************** - SUBROUTINE dprst_init() - USE PRMS_SRUNOFF - USE PRMS_MODULE, ONLY: Init_vars_from_file, Nhru, PRMS4_flag, Inputerror_flag - USE PRMS_BASIN, ONLY: Dprst_clos_flag, NEARZERO, Dprst_frac, & - & Dprst_area_clos_max, Dprst_area_open_max, Basin_area_inv, & - & Hru_area_dble, Active_hrus, Hru_route_order, Dprst_open_flag - USE PRMS_FLOWVARS, ONLY: Dprst_vol_open, Dprst_vol_clos - IMPLICIT NONE -! Functions - INTRINSIC EXP, LOG, DBLE, SNGL - INTEGER, EXTERNAL :: getparam -! Local Variables - INTEGER :: i, j - REAL :: frac_op_ar, frac_cl_ar, open_vol_r, clos_vol_r -!*********************************************************************** - Dprst_evap_hru = 0.0 - Dprst_seep_hru = 0.0D0 - Dprst_sroff_hru = 0.0D0 - Dprst_insroff_hru = 0.0 - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN - IF ( getparam(MODNAME, 'dprst_frac_init', Nhru, 'real', Dprst_frac_init)/=0 ) CALL read_error(2, 'dprst_frac_init') - ENDIF - IF ( getparam(MODNAME, 'dprst_flow_coef', Nhru, 'real', Dprst_flow_coef)/=0 ) CALL read_error(2, 'dprst_flow_coef') - IF ( Dprst_open_flag==1 ) THEN - IF ( getparam(MODNAME, 'dprst_seep_rate_open', Nhru, 'real', Dprst_seep_rate_open)/=0 ) & - & CALL read_error(2, 'dprst_seep_rate_open') - IF ( getparam(MODNAME, 'va_open_exp', Nhru, 'real', Va_open_exp)/=0 ) CALL read_error(2, 'va_open_exp') - IF ( getparam(MODNAME, 'op_flow_thres', Nhru, 'real', Op_flow_thres)/=0 ) CALL read_error(2, 'op_flow_thres') - ELSE - Dprst_seep_rate_open = 0.0 - Va_open_exp = 0.0 - Op_flow_thres = 0.0 - ENDIF - IF ( PRMS4_flag==1 ) THEN - IF ( getparam(MODNAME, 'sro_to_dprst', Nhru, 'real', Sro_to_dprst_perv)/=0 ) CALL read_error(2, 'sro_to_dprst') - ELSE - IF ( getparam(MODNAME, 'sro_to_dprst_perv', Nhru, 'real', Sro_to_dprst_perv)/=0 ) CALL read_error(2, 'sro_to_dprst_perv') - ENDIF - IF ( getparam(MODNAME, 'sro_to_dprst_imperv', Nhru, 'real', Sro_to_dprst_imperv)/=0 ) & - & CALL read_error(2, 'sro_to_dprst_imperv') - IF ( getparam(MODNAME, 'dprst_depth_avg', Nhru, 'real', Dprst_depth_avg)/=0 ) CALL read_error(2, 'dprst_depth_avg') - IF ( getparam(MODNAME, 'dprst_et_coef', Nhru, 'real', Dprst_et_coef)/=0 ) CALL read_error(2, 'dprst_et_coef') - IF ( Dprst_clos_flag==1 ) THEN - IF ( getparam(MODNAME, 'dprst_seep_rate_clos', Nhru, 'real', Dprst_seep_rate_clos)/=0 ) & - & CALL read_error(2, 'dprst_seep_rate_clos') - IF ( getparam(MODNAME, 'va_clos_exp', Nhru, 'real', Va_clos_exp)/=0 ) CALL read_error(2, 'va_clos_exp') - ELSE - Dprst_seep_rate_clos = 0.0 - Va_clos_exp = 0.0 - ENDIF - Dprst_in = 0.0D0 - Dprst_area_open = 0.0 - Dprst_area_clos = 0.0 - Dprst_stor_hru = 0.0D0 - Dprst_vol_thres_open = 0.0D0 - Dprst_vol_open_max = 0.0D0 - Dprst_vol_clos_max = 0.0D0 - Dprst_vol_frac = 0.0 - Dprst_vol_open_frac = 0.0 - Dprst_vol_clos_frac = 0.0 - Basin_dprst_volop = 0.0D0 - Basin_dprst_volcl = 0.0D0 - DO j = 1, Active_hrus - i = Hru_route_order(j) - - IF ( Dprst_frac(i)>0.0 ) THEN - IF ( Dprst_depth_avg(i)==0.0 ) THEN - PRINT *, 'ERROR, dprst_frac>0 and dprst_depth_avg==0 for HRU:', i, '; dprst_frac:', Dprst_frac(i) - Inputerror_flag = 1 - CYCLE - ENDIF -! calculate open and closed volumes (acre-inches) of depression storage by HRU -! Dprst_area_open_max is the maximum open depression area (acres) that can generate surface runoff: - IF ( Dprst_clos_flag==1 ) Dprst_vol_clos_max(i) = DBLE( Dprst_area_clos_max(i)*Dprst_depth_avg(i) ) - IF ( Dprst_open_flag==1 ) Dprst_vol_open_max(i) = DBLE( Dprst_area_open_max(i)*Dprst_depth_avg(i) ) - -! calculate the initial open and closed depression storage volume: - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN - IF ( Dprst_open_flag==1 ) Dprst_vol_open(i) = DBLE(Dprst_frac_init(i))*Dprst_vol_open_max(i) - IF ( Dprst_clos_flag==1 ) Dprst_vol_clos(i) = DBLE(Dprst_frac_init(i))*Dprst_vol_clos_max(i) - ENDIF - -! threshold volume is calculated as the % of maximum open -! depression storage above which flow occurs * total open depression storage volume - Dprst_vol_thres_open(i) = DBLE(Op_flow_thres(i))*Dprst_vol_open_max(i) - -! initial open and closed storage volume as fraction of total open and closed storage volume - -! Open depression surface area for each HRU: - IF ( Dprst_vol_open(i)>0.0D0 ) THEN - open_vol_r = SNGL( Dprst_vol_open(i)/Dprst_vol_open_max(i) ) - IF ( open_vol_r1.0 ) THEN - frac_op_ar = 1.0 - ELSE - frac_op_ar = EXP(Va_open_exp(i)*LOG(open_vol_r)) - ENDIF - Dprst_area_open(i) = Dprst_area_open_max(i)*frac_op_ar - IF ( Dprst_area_open(i)>Dprst_area_open_max(i) ) Dprst_area_open(i) = Dprst_area_open_max(i) -! IF ( Dprst_area_open(i)0.0D0 ) THEN - clos_vol_r = SNGL( Dprst_vol_clos(i)/Dprst_vol_clos_max(i) ) - IF ( clos_vol_r1.0 ) THEN - frac_cl_ar = 1.0 - ELSE - frac_cl_ar = EXP(Va_clos_exp(i)*LOG(clos_vol_r)) - ENDIF - Dprst_area_clos(i) = Dprst_area_clos_max(i)*frac_cl_ar - IF ( Dprst_area_clos(i)>Dprst_area_clos_max(i) ) Dprst_area_clos(i) = Dprst_area_clos_max(i) -! IF ( Dprst_area_clos(i)0.0 ) Dprst_vol_open_frac(i) = SNGL( Dprst_vol_open(i)/Dprst_vol_open_max(i) ) - IF ( Dprst_vol_clos_max(i)>0.0 ) Dprst_vol_clos_frac(i) = SNGL( Dprst_vol_clos(i)/Dprst_vol_clos_max(i) ) - Dprst_vol_frac(i) = SNGL( (Dprst_vol_open(i)+Dprst_vol_clos(i))/(Dprst_vol_open_max(i)+Dprst_vol_clos_max(i)) ) - ENDIF - ENDDO - Basin_dprst_volop = Basin_dprst_volop*Basin_area_inv - Basin_dprst_volcl = Basin_dprst_volcl*Basin_area_inv - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) DEALLOCATE ( Dprst_frac_init ) - - END SUBROUTINE dprst_init - -!*********************************************************************** -! Compute depression storage area hydrology -!*********************************************************************** - SUBROUTINE dprst_comp(Dprst_vol_clos, Dprst_area_clos_max, Dprst_area_clos, & - & Dprst_vol_open_max, Dprst_vol_open, Dprst_area_open_max, Dprst_area_open, & - & Dprst_sroff_hru, Dprst_seep_hru, Sro_to_dprst_perv, Sro_to_dprst_imperv, Dprst_evap_hru, & - & Avail_et, Net_rain, Dprst_in, Thaw_frac) - USE PRMS_SRUNOFF, ONLY: Srp, Sri, Ihru, Perv_frac, Imperv_frac, Hruarea, Dprst_et_coef, & - & Dprst_seep_rate_open, Dprst_seep_rate_clos, Va_clos_exp, Va_open_exp, Dprst_flow_coef, & - & Dprst_vol_thres_open, Dprst_vol_clos_max, Dprst_insroff_hru, Upslope_hortonian, & - & Basin_dprst_volop, Basin_dprst_volcl, Basin_dprst_evap, Basin_dprst_seep, Basin_dprst_sroff, & - & Dprst_vol_open_frac, Dprst_vol_clos_frac, Dprst_vol_frac, Dprst_stor_hru, Hruarea_dble - USE PRMS_MODULE, ONLY: Cascade_flag !, Print_debug - USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Dprst_frac_open, Dprst_frac_clos - USE PRMS_INTCP, ONLY: Net_snow - USE PRMS_CLIMATEVARS, ONLY: Potet - USE PRMS_FLOWVARS, ONLY: Pkwater_equiv - USE PRMS_SNOW, ONLY: Snowmelt, Pptmix_nopack, Snowcov_area - IMPLICIT NONE - INTRINSIC EXP, LOG, MAX, DBLE, SNGL -! Arguments - REAL, INTENT(IN) :: Dprst_area_open_max, Dprst_area_clos_max, Net_rain, Thaw_frac - REAL, INTENT(IN) :: Sro_to_dprst_perv, Sro_to_dprst_imperv - DOUBLE PRECISION, INTENT(IN) :: Dprst_vol_open_max - DOUBLE PRECISION, INTENT(INOUT) :: Dprst_vol_open, Dprst_vol_clos, Dprst_in - REAL, INTENT(INOUT) :: Avail_et - REAL, INTENT(OUT) :: Dprst_area_open, Dprst_area_clos, Dprst_evap_hru - DOUBLE PRECISION, INTENT(OUT) :: Dprst_sroff_hru, Dprst_seep_hru -! Local Variables - REAL :: inflow, dprst_avail_et - REAL :: dprst_srp, dprst_sri - REAL :: dprst_srp_open, dprst_srp_clos, dprst_sri_open, dprst_sri_clos - REAL :: frac_op_ar, frac_cl_ar, open_vol_r, clos_vol_r, unsatisfied_et - REAL :: tmp, dprst_evap_open, dprst_evap_clos - DOUBLE PRECISION :: seep_open, seep_clos, tmp1 -!*********************************************************************** -! add the hortonian flow to the depression storage volumes: - IF ( Cascade_flag>0 ) THEN - inflow = SNGL( Upslope_hortonian(Ihru) ) - ELSE - inflow = 0.0 - ENDIF - - IF ( Pptmix_nopack(Ihru)==1 ) inflow = inflow + Net_rain - -!******If precipitation on snowpack all water available to the surface is considered to be snowmelt -!******If there is no snowpack and no precip,then check for melt from last of snowpack. -!******If rain/snow mix with no antecedent snowpack, compute snowmelt portion of runoff. - - IF ( Snowmelt(Ihru)>0.0 ) THEN - inflow = inflow + Snowmelt(Ihru) - -!******There was no snowmelt but a snowpack may exist. If there is -!******no snowpack then check for rain on a snowfree HRU. - ELSEIF ( Pkwater_equiv(Ihru)0.0 ) THEN - inflow = inflow + Net_rain - ENDIF - ENDIF - - Dprst_in = 0.0D0 - IF ( Dprst_area_open_max>0.0 ) THEN - Dprst_in = DBLE( inflow*Dprst_area_open_max*Thaw_frac ) ! inch-acres - Dprst_vol_open = Dprst_vol_open + Dprst_in - ENDIF - IF ( Dprst_area_clos_max>0.0 ) THEN - tmp1 = DBLE( inflow*Dprst_area_clos_max*Thaw_frac ) ! inch-acres - Dprst_vol_clos = Dprst_vol_clos + tmp1 - Dprst_in = Dprst_in + tmp1 - ENDIF - Dprst_in = Dprst_in/Hruarea_dble ! inches over HRU - - ! add any pervious surface runoff fraction to depressions - dprst_srp = 0.0 - dprst_sri = 0.0 - IF ( Srp>0.0 ) THEN - tmp = Srp*Perv_frac*Sro_to_dprst_perv*Hruarea - IF ( Dprst_area_open_max>0.0 ) THEN - dprst_srp_open = tmp*Dprst_frac_open(Ihru) ! acre-inches - dprst_srp = dprst_srp_open/Hruarea - Dprst_vol_open = Dprst_vol_open + DBLE( dprst_srp_open ) - ENDIF - IF ( Dprst_area_clos_max>0.0 ) THEN - dprst_srp_clos = tmp*Dprst_frac_clos(Ihru) - dprst_srp = dprst_srp + dprst_srp_clos/Hruarea - Dprst_vol_clos = Dprst_vol_clos + DBLE( dprst_srp_clos ) - ENDIF - Srp = Srp - dprst_srp/Perv_frac - IF ( Srp<0.0 ) THEN - IF ( Srp<-NEARZERO ) PRINT *, 'dprst srp<0.0', Srp, dprst_srp - ! may need to adjust dprst_srp and volumes - Srp = 0.0 - ENDIF - ENDIF - - IF ( Sri>0.0 ) THEN - tmp = Sri*Imperv_frac*Sro_to_dprst_imperv*Hruarea - IF ( Dprst_area_open_max>0.0 ) THEN - dprst_sri_open = tmp*Dprst_frac_open(Ihru) - dprst_sri = dprst_sri_open/Hruarea - Dprst_vol_open = Dprst_vol_open + DBLE( dprst_sri_open ) - ENDIF - IF ( Dprst_area_clos_max>0.0 ) THEN - dprst_sri_clos = tmp*Dprst_frac_clos(Ihru) - dprst_sri = dprst_sri + dprst_sri_clos/Hruarea - Dprst_vol_clos = Dprst_vol_clos + DBLE( dprst_sri_clos ) - ENDIF - Sri = Sri - dprst_sri/Imperv_frac - IF ( Sri<0.0 ) THEN - IF ( Sri<-NEARZERO ) PRINT *, 'dprst sri<0.0', Sri, dprst_sri - ! may need to adjust dprst_sri and volumes - Sri = 0.0 - ENDIF - ENDIF - - Dprst_insroff_hru(Ihru) = dprst_srp + dprst_sri - -! Open depression surface area for each HRU: - Dprst_area_open = 0.0 - IF ( Dprst_vol_open>0.0D0 ) THEN - open_vol_r = SNGL( Dprst_vol_open/(Dprst_vol_open_max*Thaw_frac) ) - IF ( open_vol_r1.0 ) THEN - frac_op_ar = 1.0 - ELSE - frac_op_ar = EXP(Va_open_exp(Ihru)*LOG(open_vol_r)) - ENDIF - Dprst_area_open = Dprst_area_open_max*Thaw_frac*frac_op_ar - IF ( Dprst_area_open>Dprst_area_open_max*Thaw_frac ) Dprst_area_open = Dprst_area_open_max*Thaw_frac -! IF ( Dprst_area_open0.0 ) THEN - Dprst_area_clos = 0.0 - IF ( Dprst_vol_clos>0.0D0 ) THEN - clos_vol_r = SNGL( Dprst_vol_clos/(Dprst_vol_clos_max(Ihru)*Thaw_frac) ) - IF ( clos_vol_r1.0 ) THEN - frac_cl_ar = 1.0 - ELSE - frac_cl_ar = EXP(Va_clos_exp(Ihru)*LOG(clos_vol_r)) - ENDIF - Dprst_area_clos = Dprst_area_clos_max*Thaw_frac*frac_cl_ar - IF ( Dprst_area_clos>Dprst_area_clos_max*Thaw_frac ) Dprst_area_clos = Dprst_area_clos_max*Thaw_frac -! IF ( Dprst_area_clos0.0 ) THEN - dprst_evap_open = 0.0 - dprst_evap_clos = 0.0 - IF ( Dprst_area_open>0.0 ) THEN - dprst_evap_open = MIN(Dprst_area_open*dprst_avail_et, SNGL(Dprst_vol_open)) - IF ( dprst_evap_open/Hruarea>unsatisfied_et ) THEN - !IF ( Print_debug>-1 ) THEN - ! PRINT *, 'Warning, open dprst evaporation > available ET, HRU:, ', Ihru, & -! & unsatisfied_et, dprst_evap_open*DBLE(Dprst_frac_open(Ihru)) - ! PRINT *, 'Set to available ET, perhaps dprst_et_coef specified too large' - ! PRINT *, 'Set print_debug to -1 to turn off message' - !ENDIF - dprst_evap_open = unsatisfied_et*Hruarea - ENDIF - !IF ( dprst_evap_open>SNGL(Dprst_vol_open) ) print *, '>', dprst_evap_open, dprst_vol_open - IF ( dprst_evap_open>SNGL(Dprst_vol_open) ) dprst_evap_open = SNGL( Dprst_vol_open ) - unsatisfied_et = unsatisfied_et - dprst_evap_open/Hruarea - Dprst_vol_open = Dprst_vol_open - DBLE( dprst_evap_open ) - ENDIF - IF ( Dprst_area_clos>0.0 ) THEN - dprst_evap_clos = MIN(Dprst_area_clos*dprst_avail_et, SNGL(Dprst_vol_clos)) - IF ( dprst_evap_clos/Hruarea>unsatisfied_et ) THEN - !IF ( Print_debug>-1 ) THEN - ! PRINT *, 'Warning, closed dprst evaporation > available ET, HRU:, ', Ihru, & -! & unsatisfied_et, dprst_evap_clos*Dprst_frac_clos(Ihru) - ! PRINT *, 'Set to available ET, perhaps dprst_et_coef specified too large' - ! PRINT *, 'Set print_debug to -1 to turn off message' - !ENDIF - dprst_evap_clos = unsatisfied_et*Hruarea - ENDIF - IF ( dprst_evap_clos>SNGL(Dprst_vol_clos) ) dprst_evap_clos = SNGL( Dprst_vol_clos ) - Dprst_vol_clos = Dprst_vol_clos - DBLE( dprst_evap_clos ) - ENDIF - Dprst_evap_hru = (dprst_evap_open + dprst_evap_clos)/Hruarea - ENDIF - - ! compute seepage - Dprst_seep_hru = 0.0D0 - IF ( Dprst_vol_open>0.0D0 ) THEN - seep_open = Dprst_vol_open*DBLE( Dprst_seep_rate_open(Ihru) ) - Dprst_vol_open = Dprst_vol_open - seep_open - IF ( Dprst_vol_open<0.0D0 ) THEN -! IF ( Dprst_vol_open<-DNEARZERO ) PRINT *, 'negative dprst_vol_open:', Dprst_vol_open, ' HRU:', Ihru - seep_open = seep_open + Dprst_vol_open - Dprst_vol_open = 0.0D0 - ENDIF - Dprst_seep_hru = seep_open/Hruarea_dble - ENDIF - - ! compute open surface runoff - Dprst_sroff_hru = 0.0D0 - IF ( Dprst_vol_open>0.0D0 ) THEN - Dprst_sroff_hru = MAX( 0.0D0, Dprst_vol_open-Dprst_vol_open_max*Thaw_frac ) - Dprst_sroff_hru = Dprst_sroff_hru + & - & MAX( 0.0D0, (Dprst_vol_open-Dprst_sroff_hru-Dprst_vol_thres_open(Ihru))*DBLE(Dprst_flow_coef(Ihru)) ) - Dprst_vol_open = Dprst_vol_open - Dprst_sroff_hru - Dprst_sroff_hru = Dprst_sroff_hru/Hruarea_dble - ! sanity checks - IF ( Dprst_vol_open<0.0D0 ) THEN -! IF ( Dprst_vol_open<-DNEARZERO ) PRINT *, 'issue, dprst_vol_open<0.0', Dprst_vol_open - Dprst_vol_open = 0.0D0 - ENDIF - ENDIF - - IF ( Dprst_area_clos_max>0.0 ) THEN - IF ( Dprst_area_clos>NEARZERO ) THEN - seep_clos = Dprst_vol_clos*DBLE( Dprst_seep_rate_clos(Ihru) ) - Dprst_vol_clos = Dprst_vol_clos - seep_clos - IF ( Dprst_vol_clos<0.0D0 ) THEN -! IF ( Dprst_vol_clos<-DNEARZERO ) PRINT *, 'issue, dprst_vol_clos<0.0', Dprst_vol_clos - seep_clos = seep_clos + Dprst_vol_clos - Dprst_vol_clos = 0.0D0 - ENDIF - Dprst_seep_hru = Dprst_seep_hru + seep_clos/Hruarea_dble - ENDIF - IF ( Dprst_vol_clos<0.0D0 ) THEN -! IF ( Dprst_vol_clos<-DNEARZERO ) PRINT *, 'issue, dprst_vol_clos<0.0', Dprst_vol_clos - Dprst_vol_clos = 0.0D0 - ENDIF - ENDIF - - Basin_dprst_volop = Basin_dprst_volop + Dprst_vol_open - Basin_dprst_volcl = Basin_dprst_volcl + Dprst_vol_clos - Basin_dprst_evap = Basin_dprst_evap + DBLE( Dprst_evap_hru*Hruarea ) - Basin_dprst_seep = Basin_dprst_seep + Dprst_seep_hru*Hruarea_dble - Basin_dprst_sroff = Basin_dprst_sroff + Dprst_sroff_hru*Hruarea_dble - Avail_et = Avail_et - Dprst_evap_hru - IF ( Dprst_vol_open_max>0.0 ) Dprst_vol_open_frac(Ihru) = SNGL( Dprst_vol_open/(Dprst_vol_open_max*Thaw_frac) ) - IF ( Dprst_vol_clos_max(Ihru)>0.0 ) Dprst_vol_clos_frac(Ihru) = SNGL( Dprst_vol_clos/(Dprst_vol_clos_max(Ihru)*Thaw_frac) ) - Dprst_vol_frac(Ihru) = SNGL( (Dprst_vol_open+Dprst_vol_clos)/((Dprst_vol_open_max+Dprst_vol_clos_max(Ihru))*Thaw_frac) ) - Dprst_stor_hru(Ihru) = (Dprst_vol_open+Dprst_vol_clos)/Hruarea_dble - - END SUBROUTINE dprst_comp - -!*********************************************************************** -! srunoff_restart - write or read srunoff restart file -!*********************************************************************** - SUBROUTINE srunoff_restart(In_out) - USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Dprst_flag, & - & Frozen_flag - USE PRMS_SRUNOFF - IMPLICIT NONE - ! Argument - INTEGER, INTENT(IN) :: In_out - EXTERNAL check_restart - ! Local Variable - CHARACTER(LEN=13) :: module_name -!*********************************************************************** - IF ( In_out==0 ) THEN - WRITE ( Restart_outunit ) MODNAME - WRITE ( Restart_outunit ) Basin_sroff_down, Basin_sroff_upslope, Basin_sroffi, Basin_sroffp, & - & Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, Basin_infil, Basin_hortonian, & - & Sri, Srp, Basin_hortonian_lakes - WRITE ( Restart_outunit ) Basin_dprst_sroff, Basin_dprst_evap, Basin_dprst_seep, & - & Basin_dprst_volop, Basin_dprst_volcl, Basin_contrib_fraction - IF ( Dprst_flag==1 ) THEN - WRITE ( Restart_outunit ) Dprst_area_open - WRITE ( Restart_outunit ) Dprst_area_clos - WRITE ( Restart_outunit ) Dprst_stor_hru - WRITE ( Restart_outunit ) Dprst_vol_thres_open - ENDIF - IF ( Frozen_flag==1 ) THEN - WRITE ( Restart_outunit ) Frozen - WRITE ( Restart_outunit ) Cfgi - WRITE ( Restart_outunit ) Cfgi_prev - WRITE ( Restart_outunit ) Frz_depth, Thaw_depth - ENDIF - ELSE - READ ( Restart_inunit ) module_name - CALL check_restart(MODNAME, module_name) - READ ( Restart_inunit ) Basin_sroff_down, Basin_sroff_upslope, Basin_sroffi, Basin_sroffp, & - & Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, Basin_infil, Basin_hortonian, & - & Sri, Srp, Basin_hortonian_lakes - READ ( Restart_inunit ) Basin_dprst_sroff, Basin_dprst_evap, Basin_dprst_seep, & - & Basin_dprst_volop, Basin_dprst_volcl, Basin_contrib_fraction - IF ( Dprst_flag==1 ) THEN - READ ( Restart_inunit ) Dprst_area_open - READ ( Restart_inunit ) Dprst_area_clos - READ ( Restart_inunit ) Dprst_stor_hru - READ ( Restart_inunit ) Dprst_vol_thres_open - ENDIF - IF ( Frozen_flag==1 ) THEN ! could be problem for restart - READ ( Restart_inunit ) Frozen - READ ( Restart_inunit ) Cfgi - READ ( Restart_inunit ) Cfgi_prev - READ ( Restart_inunit ) Frz_depth, Thaw_depth - ENDIF - ENDIF - END SUBROUTINE srunoff_restart From 11b6c6cab4b5656083f6748cd99eb152d991b9c6 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 6 Aug 2019 14:26:41 -0600 Subject: [PATCH 25/47] separating out riparian and permafrost files for Makefile purposes --- prmsRip/Makefile | 261 +++ prmsRip/call_modulesRip.f90 | 1315 +++++++++++++++ prmsRip/mizurouteRip.f90 | 787 +++++++++ prmsRip/muskingumRip.f90 | 473 ++++++ prmsRip/routingRip.f90 | 1575 ++++++++++++++++++ prmsRip/snowcompCfgim.f90 | 3074 +++++++++++++++++++++++++++++++++++ prmsRip/soilzoneCfgim.f90 | 1875 +++++++++++++++++++++ prmsRip/srunoffCfgim.f90 | 1707 +++++++++++++++++++ 8 files changed, 11067 insertions(+) create mode 100644 prmsRip/Makefile create mode 100644 prmsRip/call_modulesRip.f90 create mode 100644 prmsRip/mizurouteRip.f90 create mode 100644 prmsRip/muskingumRip.f90 create mode 100644 prmsRip/routingRip.f90 create mode 100644 prmsRip/snowcompCfgim.f90 create mode 100644 prmsRip/soilzoneCfgim.f90 create mode 100644 prmsRip/srunoffCfgim.f90 diff --git a/prmsRip/Makefile b/prmsRip/Makefile new file mode 100644 index 00000000..97891cde --- /dev/null +++ b/prmsRip/Makefile @@ -0,0 +1,261 @@ +# PRMS V makefile + +include ../makelist +TARGET2 = $(BINDIR)/prmsrip + +#################################################### +# Rules for targets +#################################################### +all: $(TARGET2) + +# +# Define all object files which make up the library +# + + +RIP = \ + call_modulesRip.o \ + basin.o \ + climateflow.o \ + cascade.o \ + soltab.o \ + setup_param.o \ + convert_params.o \ + prms_time.o \ + obs.o \ + climate_hru.o \ + potet_jh.o \ + potet_pt.o \ + potet_hs.o \ + potet_pm.o \ + potet_pm_sta.o \ + potet_pan.o \ + potet_hamon.o \ + ddsolrad.o \ + ccsolrad.o \ + ide_dist.o \ + xyz_dist.o \ + precip_1sta_laps.o \ + precip_dist2.o \ + temp_1sta_laps.o \ + temp_dist2.o \ + transp_frost.o \ + transp_tindex.o \ + frost_date.o \ + glacr_melt.o \ + intcp.o \ + snowcompCfgim.o \ + srunoffCfgim.o \ + soilzoneCfgim.o \ + gwflow.o \ + water_use_read.o \ + dynamic_param_read.o \ + water_balance.o \ + routingRip.o \ + strmflow.o \ + strmflow_in_out.o \ + muskingumRip.o \ + muskingum_lake.o \ + mizurouteRip.o \ + subbasin.o \ + map_results.o \ + nhru_summary.o \ + nsub_summary.o \ + nsegment_summary.o \ + basin_summary.o \ + write_climate_hru.o \ + prms_summary.o \ + basin_sum.o \ + utils_prms.o \ + stream_temp.o + + +$(TARGET2):$(RIP) + $(RM) $(TARGET2) + $(FC) $(LDFLAGS) -o $(TARGET2) $(RIP) $(MMFLIB) $(MIZULIB) $(INCMIZU) $(FLIBS) + +# +# Define all object files which make up the library +# + +clean: + $(RM) $(RIP) *.mod *~ + +setup_param.o: $(PRMSDIR)/setup_param.f90 prms_module.mod prms_basin.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/setup_param.f90 + +ddsolrad.o: $(PRMSDIR)/ddsolrad.f90 prms_module.mod prms_climatevars.mod prms_soltab.mod prms_set_time.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/ddsolrad.f90 + +ccsolrad.o: $(PRMSDIR)/ccsolrad.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_soltab.mod prms_set_time.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/ccsolrad.f90 + +intcp.o: $(PRMSDIR)/intcp.f90 prms_obs.mod prms_climatevars.mod prms_flowvars.mod prms_module.mod prms_basin.mod prms_water_use.mod prms_set_time.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/intcp.f90 + +nhru_summary.o: $(PRMSDIR)/nhru_summary.f90 prms_module.mod prms_basin.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/nhru_summary.f90 + +nsub_summary.o: $(PRMSDIR)/nsub_summary.f90 prms_module.mod prms_basin.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/nsub_summary.f90 + +nsegment_summary.o: $(PRMSDIR)/nsegment_summary.f90 prms_module.mod prms_basin.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/nsegment_summary.f90 + +basin_summary.o: $(PRMSDIR)/basin_summary.f90 prms_module.mod prms_basin.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/basin_summary.f90 + +precip_1sta_laps.o: $(PRMSDIR)/precip_1sta_laps.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/precip_1sta_laps.f90 + +climate_hru.o: $(PRMSDIR)/climate_hru.f90 prms_module.mod prms_basin.mod prms_soltab.mod prms_set_time.mod prms_climatevars.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/climate_hru.f90 + +cascade.o: $(PRMSDIR)/cascade.f90 prms_module.mod prms_basin.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/cascade.f90 + +basin.o: $(PRMSDIR)/basin.f90 prms_module.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/basin.f90 + +climateflow.o: $(PRMSDIR)/climateflow.f90 prms_module.mod prms_basin.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/climateflow.f90 + +water_use_read.o: $(PRMSDIR)/water_use_read.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_flowvars.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/water_use_read.f90 + +utils_prms.o: $(PRMSDIR)/utils_prms.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/utils_prms.f90 + +map_results.o: $(PRMSDIR)/map_results.f90 prms_module.mod prms_basin.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/map_results.f90 + +frost_date.o: $(PRMSDIR)/frost_date.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/frost_date.f90 + +transp_tindex.o: $(PRMSDIR)/transp_tindex.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/transp_tindex.f90 + +transp_frost.o: $(PRMSDIR)/transp_frost.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/transp_frost.f90 + +temp_1sta_laps.o: $(PRMSDIR)/temp_1sta_laps.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/temp_1sta_laps.f90 + +temp_dist2.o: $(PRMSDIR)/temp_dist2.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/temp_dist2.f90 + +precip_dist2.o: $(PRMSDIR)/precip_dist2.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_obs.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/precip_dist2.f90 + +potet_jh.o: $(PRMSDIR)/potet_jh.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/potet_jh.f90 + +potet_pt.o: $(PRMSDIR)/potet_pt.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_climate_hru.mod prms_soltab.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/potet_pt.f90 + +potet_hs.o: $(PRMSDIR)/potet_hs.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/potet_hs.f90 + +potet_pm.o: $(PRMSDIR)/potet_pm.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_set_time.mod prms_climate_hru.mod prms_soltab.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/potet_pm.f90 + +potet_pm_sta.o: $(PRMSDIR)/potet_pm_sta.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_obs.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/potet_pm_sta.f90 + +potet_pan.o: $(PRMSDIR)/potet_pan.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_set_time.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/potet_pan.f90 + +potet_hamon.o: $(PRMSDIR)/potet_hamon.f90 prms_module.mod prms_basin.mod prms_climatevars.mod prms_soltab.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/potet_hamon.f90 + +write_climate_hru.o: $(PRMSDIR)/write_climate_hru.f90 prms_module.mod prms_set_time.mod prms_climatevars.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/write_climate_hru.f90 + +prms_time.o: $(PRMSDIR)/prms_time.f90 prms_module.mod prms_basin.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/prms_time.f90 + +soltab.o: $(PRMSDIR)/soltab.f90 prms_module.mod prms_basin.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/soltab.f90 + +convert_params.o: $(PRMSDIR)/convert_params.f90 prms_module.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/convert_params.f90 + +obs.o: $(PRMSDIR)/obs.f90 prms_module.mod prms_basin.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/obs.f90 + +ide_dist.o: $(PRMSDIR)/ide_dist.f prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/ide_dist.f + +xyz_dist.o: $(PRMSDIR)/xyz_dist.f prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_obs.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/xyz_dist.f + +call_modulesRip.o: call_modulesRip.f90 + $(FC) -c $(FFLAGS) call_modulesRip.f90 + +muskingumRip.o: muskingumRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflow.mod prms_glacr.mod + $(FC) -c $(FFLAGS) muskingumRip.f90 + +routingRip.o: routingRip.f90 prms_moduleRip.mod prms_basin.mod prms_gwflow.mod prms_flowvars.mod prms_set_time.mod prms_water_use.mod prms_srunoffCfgim.mod prms_glacr.mod + $(FC) -c $(FFLAGS) routingRip.f90 + +mizurouteRip.o: mizurouteRip.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflow.mod prms_glacr.mod + $(FC) -c $(FFLAGS) $(INCMIZU) mizurouteRip.f90 + +basin_sum.o: $(PRMSDIR)/basin_sum.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_gwflow.mod prms_climatevars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/basin_sum.f90 + +muskingum_lake.o: $(PRMSDIR)/muskingum_lake.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_routingRip.mod prms_srunoffCfgim.mod prms_gwflow.mod prms_soilzoneCfgim.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/muskingum_lake.f90 + +strmflow_in_out.o: $(PRMSDIR)/strmflow_in_out.f90 prms_moduleRip.mod prms_basin.mod prms_flowvars.mod prms_set_time.mod prms_routingRip.mod prms_obs.mod prms_srunoffCfgim.mod prms_gwflow.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/strmflow_in_out.f90 + +stream_temp.o: $(PRMSDIR)/stream_temp.f90 prms_module.mod prms_basin.mod prms_routingRip.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_soltab.mod prms_climatevars.mod prms_snowCfgim.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/stream_temp.f90 + +srunoffCfgim.o: srunoffCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_climatevars.mod prms_intcp.mod prms_snow.mod prms_cascade.mod prms_set_time.mod + $(FC) -c $(FFLAGS) srunoffCfgim.f90 + +soilzoneCfgim.o: soilzoneCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_snowCfgim.mod prms_cascade.mod prms_climatevars.mod prms_set_time.mod prms_srunoffCfgim.mod + $(FC) -c $(FFLAGS) soilzoneCfgim.f90 + +snowcompCfgim.o: snowcompCfgim.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_climatevars.mod prms_set_time.mod prms_intcp.mod + $(FC) -c $(FFLAGS) snowcompCfgim.f90 + +prms_summary.o: $(PRMSDIR)/prms_summary.f90 prms_module.mod prms_climatevars.mod prms_flowvars.mod prms_set_time.mod prms_obs.mod prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_gwflow.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/prms_summary.f90 + +subbasin.o: $(PRMSDIR)/subbasin.f90 prms_module.mod prms_basin.mod prms_gwflow.mod prms_flowvars.mod prms_set_time.mod prms_intcp.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_muskingum_lake.mod prms_snowCfgim.mod prms_climatevars.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/subbasin.f90 + +water_balance.o: $(PRMSDIR)/water_balance.f90 prms_module.mod prms_basin.mod prms_srunoffCfgim.mod prms_flowvars.mod prms_gwflow.mod prms_climatevars.mod prms_set_time.mod prms_cascade.mod prms_intcp.mod prms_snowCfgim.mod prms_soilzoneCfgim.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/water_balance.f90 + +dynamic_param_read.o: $(PRMSDIR)/dynamic_param_read.f90 prms_module.mod prms_basin.mod prms_set_time.mod prms_climatevars.mod prms_flowvars.mod prms_potet_jh.mod prms_potet_pm.mod prms_potet_hs.mod prms_potet_pt.mod prms_potet_hamon.mod transp_tindex.o transp_frost.o prms_intcp.mod prms_snowCfgim.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_climate_hru.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/dynamic_param_read.f90 + +gwflow.o: $(PRMSDIR)/gwflow.f90 prms_module.mod prms_basin.mod prms_flowvars.mod prms_intcp.mod prms_srunoffCfgim.mod prms_soilzoneCfgim.mod prms_cascade.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/gwflow.f90 + +strmflow.o: $(PRMSDIR)/strmflow.f90 prms_module.mod prms_basin.mod prms_gwflow.mod prms_srunoffCfgim.mod prms_set_time.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/strmflow.f90 + +glacr_melt.o: $(PRMSDIR)/glacr_melt.f90 prms_snowCfgim.mod prms_intcp.mod prms_soltab.mod + $(FC) -c $(FFLAGS) $(PRMSDIR)/glacr_melt.f90 + +prms_routingRip.mod: routingRip.o +prms_moduleRip.mod: call_modulesRip.o +prms_srunoffCfgim.mod: srunoffCfgim.o +prms_soilzoneCfgim.mod: soilzoneCfgim.o +prms_snowCfgim.mod: snowcompCfgim.o +prms_climatevars.mod: climateflow.o +prms_flowvars.mod: climateflow.o +prms_gwflow.mod: gwflow.o +prms_basin.mod: basin.o +prms_soltab.mod: soltab.o +prms_intcp.mod: intcp.o +prms_cascade.mod: cascade.o +prms_water_use.mod: water_use_read.o +prms_obs.mod: obs.o +prms_set_time.mod: prms_time.o +prms_glacr.mod: glacr_melt.o diff --git a/prmsRip/call_modulesRip.f90 b/prmsRip/call_modulesRip.f90 new file mode 100644 index 00000000..8face3a7 --- /dev/null +++ b/prmsRip/call_modulesRip.f90 @@ -0,0 +1,1315 @@ +!*********************************************************************** +! Defines the computational sequence, valid modules, and dimensions +!*********************************************************************** + MODULE PRMS_MODULE + IMPLICIT NONE + INTEGER, PARAMETER :: MAXFILE_LENGTH = 256, MAXCONTROL_LENGTH = 32 + INTEGER, PARAMETER :: MAXDIM = 500 + CHARACTER(LEN=68), PARAMETER :: & + & EQULS = '====================================================================' + CHARACTER(LEN=12), PARAMETER :: MODNAME = 'call_modules' + CHARACTER(LEN=24), PARAMETER :: PRMS_VERSION = 'Version 5.0.1 06/20/2019' + CHARACTER(LEN=8), SAVE :: Process + CHARACTER(LEN=80), SAVE :: PRMS_versn + INTEGER, SAVE :: Model, Process_flag, Call_cascade, Ncascade, Ncascdgw + INTEGER, SAVE :: Nhru, Nssr, Ngw, Nsub, Nhrucell, Nlake, Ngwcell, Nlake_hrus + INTEGER, SAVE :: Ntemp, Nrain, Nsol, Nsegment, Ndepl, Nobs, Nevap, Ndeplval + INTEGER, SAVE :: Starttime(6), Endtime(6) + INTEGER, SAVE :: Start_year, Start_month, Start_day, End_year, End_month, End_day + INTEGER, SAVE :: Transp_flag, Sroff_flag, Solrad_flag, Et_flag + INTEGER, SAVE :: Climate_temp_flag, Climate_precip_flag, Climate_potet_flag, Climate_transp_flag + INTEGER, SAVE :: Lake_route_flag, Nratetbl, Strmflow_flag, Stream_order_flag + INTEGER, SAVE :: Temp_flag, Precip_flag, Climate_hru_flag, Climate_swrad_flag, Ripst_flag + INTEGER, SAVE :: Precip_combined_flag, Temp_combined_flag, Muskingum_flag + INTEGER, SAVE :: Inputerror_flag, Timestep + INTEGER, SAVE :: Humidity_cbh_flag, Windspeed_cbh_flag + INTEGER, SAVE :: Stream_temp_flag, Strmtemp_humidity_flag, PRMS4_flag + INTEGER, SAVE :: Grid_flag, Logunt + INTEGER, SAVE :: PRMS_flag, GSFLOW_flag + INTEGER, SAVE :: PRMS_output_unit, Restart_inunit, Restart_outunit + INTEGER, SAVE :: Dynamic_flag, Water_use_flag, Nwateruse, Nexternal, Nconsumed, Npoigages, Prms_warmup + INTEGER, SAVE :: Elapsed_time_start(8), Elapsed_time_end(8), Elapsed_time_minutes + REAL, SAVE :: Execution_time_start, Execution_time_end, Elapsed_time + INTEGER, SAVE :: Kkiter +! Precip_flag (1=precip_1sta; 2=precip_laps; 3=precip_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru +! Temp_flag (1=temp_1sta; 2=temp_laps; 3=temp_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru; 8=temp_sta +! Control parameters + INTEGER, SAVE :: Print_debug, MapOutON_OFF, CsvON_OFF, Dprst_flag, Subbasin_flag, Parameter_check_flag + INTEGER, SAVE :: Init_vars_from_file, Save_vars_to_file, Orad_flag, Cascade_flag, Cascadegw_flag + INTEGER, SAVE :: NhruOutON_OFF, Gwr_swale_flag, NsubOutON_OFF, BasinOutON_OFF, NsegmentOutON_OFF + CHARACTER(LEN=MAXFILE_LENGTH), SAVE :: Model_output_file, Var_init_file, Var_save_file + CHARACTER(LEN=MAXFILE_LENGTH), SAVE :: Csv_output_file, Model_control_file, Param_file + CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Temp_module, Srunoff_module, Et_module + CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Strmflow_module, Transp_module + CHARACTER(LEN=MAXCONTROL_LENGTH), SAVE :: Model_mode, Precip_module, Solrad_module + CHARACTER(LEN=8), SAVE :: Soilzone_module + INTEGER, SAVE :: Dyn_imperv_flag, Dyn_intcp_flag, Dyn_covden_flag, Dyn_covtype_flag, Dyn_transp_flag, Dyn_potet_flag + INTEGER, SAVE :: Dyn_soil_flag, Dyn_radtrncf_flag, Dyn_dprst_flag, Dprst_transferON_OFF + INTEGER, SAVE :: Dyn_snareathresh_flag, Dyn_transp_on_flag + INTEGER, SAVE :: Dyn_sro2dprst_perv_flag, Dyn_sro2dprst_imperv_flag, Dyn_fallfrost_flag, Dyn_springfrost_flag + INTEGER, SAVE :: Gwr_transferON_OFF, External_transferON_OFF, Segment_transferON_OFF, Lake_transferON_OFF + INTEGER, SAVE :: Frozen_flag, Glacier_flag + END MODULE PRMS_MODULE + +!*********************************************************************** + INTEGER FUNCTION call_modules(Arg) + USE PRMS_MODULE + IMPLICIT NONE +! Arguments + CHARACTER(LEN=*), INTENT(IN) :: Arg +! Functions + INTRINSIC :: DATE_AND_TIME, INT + INTEGER, EXTERNAL :: check_dims, basin, climateflow, prms_time, setup + INTEGER, EXTERNAL :: cascade, obs, soltab, transp_tindex + INTEGER, EXTERNAL :: transp_frost, frost_date, routing + INTEGER, EXTERNAL :: temp_1sta_laps, temp_dist2 + INTEGER, EXTERNAL :: precip_1sta_laps, climate_hru + INTEGER, EXTERNAL :: precip_dist2, xyz_dist, ide_dist + INTEGER, EXTERNAL :: ddsolrad, ccsolrad + INTEGER, EXTERNAL :: potet_pan, potet_jh, potet_hamon, potet_hs, potet_pt, potet_pm + INTEGER, EXTERNAL :: intcp, snowcomp, gwflow + INTEGER, EXTERNAL :: srunoff, soilzone, mizuroute + INTEGER, EXTERNAL :: strmflow, subbasin, basin_sum, map_results, write_climate_hru + INTEGER, EXTERNAL :: strmflow_in_out, muskingum, muskingum_lake, numchars + INTEGER, EXTERNAL :: water_use_read, dynamic_param_read, potet_pm_sta + INTEGER, EXTERNAL :: stream_temp + EXTERNAL :: module_error, print_module, PRMS_open_output_file + EXTERNAL :: call_modules_restart, water_balance, basin_summary, nsegment_summary + EXTERNAL :: prms_summary, nhru_summary, module_doc, convert_params, read_error, nsub_summary + INTEGER, EXTERNAL :: glacr +! Local Variables + INTEGER :: i, iret, nc +!*********************************************************************** + call_modules = 1 + + Process = Arg + + IF ( Process(:3)=='run' ) THEN + Process_flag = 0 !(0=run, 1=declare, 2=init, 3=clean, 4=setdims) + + ELSEIF ( Process(:4)=='decl' ) THEN + CALL DATE_AND_TIME(VALUES=Elapsed_time_start) + Execution_time_start = Elapsed_time_start(5)*3600 + Elapsed_time_start(6)*60 + & + & Elapsed_time_start(7) + Elapsed_time_start(8)*0.001 + + Process_flag = 1 + + PRMS_versn = 'call_modules.f90 2019-06-20 15:33:00Z' + + IF ( check_dims()/=0 ) STOP + + IF ( Print_debug>-2 ) THEN + PRINT 10, PRMS_VERSION + WRITE ( PRMS_output_unit, 10 ) PRMS_VERSION + ENDIF + 10 FORMAT (///, 25X, 'U.S. Geological Survey', /, 15X, & + & 'Precipitation-Runoff Modeling System (PRMS)', /, 24X, A) + 15 FORMAT (/, 8X, 'Process', 12X, 'Available Modules', /, 68('-'), /, & + & ' Basin Definition: basin', /, & + & ' Cascading Flow: cascade', /, & + & ' Time Series Data: obs, water_use_read, dynamic_param_read', /, & + & ' Potet Solar Rad: soltab', /, & + & ' Temperature Dist: temp_1sta, temp_laps, temp_dist2, climate_hru', /, & + & ' Precip Dist: precip_1sta, precip_laps, precip_dist2,', /, & + & ' climate_hru', /, & + & 'Temp & Precip Dist: xyz_dist, ide_dist', /, & + & ' Solar Rad Dist: ccsolrad, ddsolrad, climate_hru', /, & + & 'Transpiration Dist: transp_tindex, climate_hru, transp_frost', /, & + & ' Potential ET: potet_hamon, potet_jh, potet_pan, climate_hru,', /, & + & ' potet_hs, potet_pt, potet_pm, potet_pm_sta', /, & + & ' Interception: intcp', /, & + & 'Snow & Glacr Dynam: snowcomp, glacr', /, & + & ' Surface Runoff: srunoff_smidx, srunoff_carea', /, & + & ' Soil Zone: soilzone', /, & + & ' Groundwater: gwflow', /, & + & 'Streamflow Routing: strmflow, strmflow_in_out, muskingum,', /, & + & ' muskingum_lake, muskingum_mann, mizuroute,', /, & + & 'Stream Temperature: stream_temp', /, & + & ' Output Summary: basin_sum, subbasin, map_results, prms_summary,', /, & + & ' nhru_summary, nsub_summary, water_balance', /, & + & ' basin_summary, nsegment_summary', /, & + & ' Preprocessing: write_climate_hru, frost_date', /, 68('-')) + 16 FORMAT (//, 4X, 'Active modules listed in the order in which they are called', //, 8X, 'Process', 19X, & + & 'Module', 16X, 'Version Date', /, A) + IF ( Print_debug>-2 ) THEN + PRINT 15 + PRINT 9002 + WRITE ( PRMS_output_unit, 15 ) + PRINT 16, EQULS + WRITE ( PRMS_output_unit, 16 ) EQULS + ENDIF + CALL print_module(PRMS_versn, 'Computation Order ', 90) + + Kkiter = 1 ! set for PRMS-only mode + + Timestep = 0 + IF ( Init_vars_from_file>0 ) CALL call_modules_restart(1) + + ELSEIF ( Process(:4)=='init' ) THEN + Process_flag = 2 + + Grid_flag = 0 + IF ( Nhru==Nhrucell ) Grid_flag = 1 + + nc = numchars(Model_control_file) + IF ( Print_debug>-1 ) PRINT 9004, 'Using Control File: ', Model_control_file(:nc) + IF ( Print_debug>-2 ) WRITE ( PRMS_output_unit, 9004 ) 'Using Control File: ', Model_control_file(:nc) + + nc = numchars(Param_file) + IF ( Print_debug>-1 ) PRINT 9004, 'Using Parameter File: ', Param_file(:nc) + IF ( Print_debug>-2 ) WRITE ( PRMS_output_unit, 9004 ) 'Using Parameter File: ', Param_file(:nc) + + IF ( Init_vars_from_file>0 ) THEN + nc = numchars(Var_init_file) + IF ( Print_debug>-1 ) PRINT 9004, 'Using var_init_file: ', Var_init_file(:nc) + ENDIF + IF ( Save_vars_to_file==1 ) THEN + nc = numchars(Var_save_file) + IF ( Print_debug>-1 ) PRINT 9004, 'Using var_save_file: ', Var_save_file(:nc) + ENDIF + + IF ( Print_debug>-2 ) THEN + nc = numchars(Model_output_file) + PRINT 9004, 'Writing PRMS Water Budget File: ', Model_output_file(:nc) + ENDIF + + ELSEIF ( Process(:7)=='setdims' ) THEN + Process_flag = 4 + + ELSE !IF ( Process(:5)=='clean' ) THEN + Process_flag = 3 + IF ( Init_vars_from_file>0 ) CLOSE ( Restart_inunit ) + IF ( Save_vars_to_file==1 ) THEN + nc = numchars(Var_save_file) + CALL PRMS_open_output_file(Restart_outunit, Var_save_file(:nc), 'var_save_file', 1, iret) + IF ( iret/=0 ) STOP + CALL call_modules_restart(0) + ENDIF + ENDIF + + IF ( Model==99 ) THEN + IF ( Process_flag==4 .OR. Process_flag<2 ) THEN + Init_vars_from_file = 0 ! make sure this is set so all variables and parameters are declared + CALL module_doc() + call_modules = 0 + RETURN + ELSE + STOP + ENDIF + ENDIF + +! All modules must be called for setdims, declare, initialize, and cleanup + IF ( Process_flag/=0 ) THEN + call_modules = basin() + IF ( call_modules/=0 ) CALL module_error('basin', Arg, call_modules) + + IF ( Call_cascade==1 ) THEN + call_modules = cascade() + IF ( call_modules/=0 ) CALL module_error('cascade', Arg, call_modules) + ENDIF + + call_modules = climateflow() + IF ( call_modules/=0 ) CALL module_error('climateflow', Arg, call_modules) + + call_modules = soltab() + IF ( call_modules/=0 ) CALL module_error('soltab', Arg, call_modules) + + call_modules = setup() + IF ( call_modules/=0 ) CALL module_error('setup', Arg, call_modules) + ENDIF + + call_modules = prms_time() + IF ( call_modules/=0 ) CALL module_error('prms_time', Arg, call_modules) + + call_modules = obs() + IF ( call_modules/=0 ) CALL module_error('obs', Arg, call_modules) + + IF ( Water_use_flag==1 ) THEN + call_modules = water_use_read() + IF ( call_modules/=0 ) CALL module_error('water_use_read', Arg, call_modules) + ENDIF + + IF ( Dynamic_flag==1 ) THEN + call_modules = dynamic_param_read() + IF ( call_modules/=0 ) CALL module_error('dynamic_param_read', Arg, call_modules) + ENDIF + + IF ( Climate_hru_flag==1 ) THEN + call_modules = climate_hru() + IF ( call_modules/=0 ) CALL module_error('climate_hru', Arg, call_modules) + ENDIF + + IF ( Climate_temp_flag==0 ) THEN + IF ( Temp_combined_flag==1 ) THEN + call_modules = temp_1sta_laps() + ELSEIF ( Temp_flag==6 ) THEN + call_modules = xyz_dist() + ELSEIF ( Temp_flag==3 ) THEN + call_modules = temp_dist2() + ELSE !IF ( Temp_flag==5 ) THEN + call_modules = ide_dist() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Temp_module, Arg, call_modules) + ENDIF + + IF ( Climate_precip_flag==0 ) THEN + IF ( Precip_combined_flag==1 ) THEN + call_modules = precip_1sta_laps() + ELSEIF ( Precip_flag==3 ) THEN + call_modules = precip_dist2() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Precip_module, Arg, call_modules) + ENDIF + + IF ( Model==6 ) THEN + IF ( Process_flag==0 ) RETURN + ENDIF + +! frost_date is a pre-process module + IF ( Model==9 ) THEN + call_modules = frost_date() + IF ( call_modules/=0 ) CALL module_error('frost_date', Arg, call_modules) + IF ( Process_flag==0 ) RETURN + IF ( Process_flag==3 ) STOP + ENDIF + + IF ( Climate_swrad_flag==0 ) THEN + IF ( Solrad_flag==1 ) THEN + call_modules = ddsolrad() + ELSE !IF ( Solrad_flag==2 ) THEN + call_modules = ccsolrad() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Solrad_module, Arg, call_modules) + ENDIF + + IF ( Transp_flag==1 ) THEN + call_modules = transp_tindex() + ELSEIF ( Transp_flag==2 ) THEN + call_modules = transp_frost() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Transp_module, Arg, call_modules) + + IF ( Model==8 ) THEN + IF ( Process_flag==0 ) RETURN + ENDIF + + IF ( Climate_potet_flag==0 ) THEN + IF ( Et_flag==1 ) THEN + call_modules = potet_jh() + ELSEIF ( Et_flag==2 ) THEN + call_modules = potet_hamon() + ELSEIF ( Et_flag==4 ) THEN + call_modules = potet_pan() + ELSEIF ( Et_flag==5 ) THEN + call_modules = potet_pt() + ELSEIF ( Et_flag==6 ) THEN + call_modules = potet_pm_sta() + ELSEIF ( Et_flag==11 ) THEN + call_modules = potet_pm() + ELSE !IF ( Et_flag==10 ) THEN + call_modules = potet_hs() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Et_module, Arg, call_modules) + ENDIF + + IF ( Model==4 ) THEN + call_modules = write_climate_hru() + IF ( call_modules/=0 ) CALL module_error('write_climate_hru', Arg, call_modules) + IF ( Process_flag==0 ) RETURN + ENDIF + + IF ( Model==7 ) THEN + IF ( Process_flag==0 ) RETURN + ENDIF + + call_modules = intcp() + IF ( call_modules/=0 ) CALL module_error('intcp', Arg, call_modules) + + call_modules = snowcomp() + IF ( call_modules/=0 ) CALL module_error('snowcomp', Arg, call_modules) + + IF ( Glacier_flag==1 ) THEN + call_modules = glacr() + IF ( call_modules/=0 ) CALL module_error('glacr', Arg, call_modules) + ENDIF + + call_modules = srunoff() + IF ( call_modules/=0 ) CALL module_error(Srunoff_module, Arg, call_modules) + + call_modules = soilzone() + IF ( call_modules/=0 ) CALL module_error(Soilzone_module, Arg, call_modules) + + call_modules = gwflow() + IF ( call_modules/=0 ) CALL module_error('gwflow', Arg, call_modules) + + IF ( Stream_order_flag==1 ) THEN + call_modules = routing() + IF ( call_modules/=0 ) CALL module_error('routing', Arg, call_modules) + ENDIF + + IF ( Strmflow_flag==1 ) THEN + call_modules = strmflow() + ELSEIF ( Muskingum_flag==1 ) THEN ! muskingum = 4; muskingum_mann = 7 + call_modules = muskingum() + ELSEIF ( Strmflow_flag==5 ) THEN + call_modules = strmflow_in_out() + ELSEIF ( Strmflow_flag==6 ) THEN + call_modules = mizuroute() + ELSEIF ( Strmflow_flag==3 ) THEN + call_modules = muskingum_lake() + ENDIF + IF ( call_modules/=0 ) CALL module_error(Strmflow_module, Arg, call_modules) + + IF ( Stream_temp_flag==1 ) call_modules = stream_temp() + + IF ( Print_debug>-2 ) THEN + call_modules = basin_sum() + IF ( call_modules/=0 ) CALL module_error('basin_sum', Arg, call_modules) + ENDIF + + IF ( Print_debug==1 ) CALL water_balance() + + IF ( MapOutON_OFF>0 ) THEN + call_modules = map_results() + IF ( call_modules/=0 ) CALL module_error('map_results', Arg, call_modules) + ENDIF + + IF ( Subbasin_flag==1 ) THEN + call_modules = subbasin() + IF ( call_modules/=0 ) CALL module_error('subbasin', Arg, call_modules) + ENDIF + + IF ( NhruOutON_OFF>0 ) CALL nhru_summary() + + IF ( NsubOutON_OFF==1 ) CALL nsub_summary() + + IF ( BasinOutON_OFF==1 ) CALL basin_summary() + + IF ( NsegmentOutON_OFF>0 ) CALL nsegment_summary() + + IF ( CsvON_OFF>0 ) CALL prms_summary() + + IF ( Process_flag==0 ) THEN + RETURN + ELSEIF ( Process_flag==3 ) THEN + CALL DATE_AND_TIME(VALUES=Elapsed_time_end) + Execution_time_end = Elapsed_time_end(5)*3600 + Elapsed_time_end(6)*60 + & + & Elapsed_time_end(7) + Elapsed_time_end(8)*0.001 + Elapsed_time = Execution_time_end - Execution_time_start + Elapsed_time_minutes = INT(Elapsed_time/60.0) + IF ( Print_debug>-1 ) THEN + PRINT 9001 + PRINT 9003, 'start', (Elapsed_time_start(i),i=1,3), (Elapsed_time_start(i),i=5,7) + PRINT 9003, 'end ', (Elapsed_time_end(i),i=1,3), (Elapsed_time_end(i),i=5,7) + PRINT '(A,I5,A,F6.2,A,/)', 'Execution elapsed time', Elapsed_time_minutes, ' minutes', & + & Elapsed_time - Elapsed_time_minutes*60.0, ' seconds' + ENDIF + IF ( Print_debug>-2 ) & + & WRITE ( PRMS_output_unit,'(A,I5,A,F6.2,A,/)') 'Execution elapsed time', Elapsed_time_minutes, ' minutes', & + & Elapsed_time - Elapsed_time_minutes*60.0, ' seconds' + IF ( Print_debug>-2 ) CLOSE ( PRMS_output_unit ) + IF ( Save_vars_to_file>0 ) CLOSE ( Restart_outunit ) + ELSEIF ( Process_flag==1 ) THEN + IF ( Print_debug>-2 ) THEN + PRINT '(A)', EQULS + WRITE ( PRMS_output_unit, '(A)' ) EQULS + ENDIF + IF ( Model==10 ) CALL convert_params() + ELSEIF ( Process_flag==2 ) THEN + IF ( Inputerror_flag==1 ) THEN + PRINT '(//,A,//,A,/,A,/,A)', '**Fix input errors in your Parameter File to continue**', & + & ' Set control parameter parameter_check_flag to 0 after', & + & ' all parameter values are valid.' + PRINT '(/,A,/,A,/,A,/,A,/,A,/)', & + & 'If input errors are related to paramters used for automated', & + & 'calibration processes, with CAUTION, set control parameter', & + & 'parameter_check_flag to 0. After calibration set the', & + & 'parameter_check_flag to 1 to verify that those calibration', & + & 'parameters have valid and compatible values.' + ENDIF + IF ( Parameter_check_flag==2 .OR. Inputerror_flag==1 ) STOP + IF ( Model==10 ) THEN + CALL convert_params() + STOP + ENDIF + IF ( Print_debug>-2 ) & + & PRINT 4, 'Simulation time period:', Start_year, Start_month, Start_day, ' -', End_year, End_month, End_day, EQULS + ENDIF + + 4 FORMAT (/, 2(A, I5, 2('/',I2.2)), //, A, /) + 9001 FORMAT (/, 26X, 25('='), /, 26X, 'Normal completion of PRMS', /, 26X, 25('='), /) + 9002 FORMAT (//, 74('='), /, 'Please give careful consideration to fixing all ERROR and WARNING messages', /, 74('=')) + 9003 FORMAT ('Execution ', A, ' date and time (yyyy/mm/dd hh:mm:ss)', I5, 2('/',I2.2), I3, 2(':',I2.2), /) + 9004 FORMAT (/, 2A) + + END FUNCTION call_modules + +!*********************************************************************** +! declare the dimensions +!*********************************************************************** + INTEGER FUNCTION setdims() + USE PRMS_MODULE + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: decldim, declfix, call_modules, control_integer_array, control_file_name + INTEGER, EXTERNAL :: control_string, control_integer + EXTERNAL :: read_error, PRMS_open_output_file, PRMS_open_input_file, check_module_names +! Local Variables + ! Maximum values are no longer limits +! Local Variables + INTEGER :: idim, iret, j +!*********************************************************************** + setdims = 1 + + Inputerror_flag = 0 + + ! debug print flag: + ! -1=quiet - reduced screen output + ! 0=none; 1=water balances; 2=basin; + ! 4=basin_sum; 5=soltab; 7=soil zone; + ! 9=snowcomp; 13=cascade; 14=subbasin tree + IF ( control_integer(Print_debug, 'print_debug')/=0 ) Print_debug = 0 + + IF ( control_integer(Parameter_check_flag, 'parameter_check_flag')/=0 ) Parameter_check_flag = 1 + + IF ( control_string(Model_mode, 'model_mode')/=0 ) CALL read_error(5, 'model_mode') + PRMS4_flag = 1 + IF ( Model_mode(:5)=='PRMS5' ) PRMS4_flag = 0 + PRMS_flag = 1 + GSFLOW_flag = 0 + ! Model (0=GSFLOW; 1=PRMS; 2=MODFLOW) + IF ( Model_mode(:4)=='PRMS' .OR. Model_mode(:4)==' ' .OR. Model_mode(:5)=='DAILY' ) THEN + Model = 1 + ELSEIF ( Model_mode(:5)=='FROST' ) THEN + Model = 9 + ELSEIF ( Model_mode(:13)=='WRITE_CLIMATE' ) THEN + Model = 4 + ELSEIF ( Model_mode(:7)=='CLIMATE' ) THEN + Model = 6 + ELSEIF ( Model_mode(:5)=='POTET' ) THEN + Model = 7 + ELSEIF ( Model_mode(:9)=='TRANSPIRE' ) THEN + Model = 8 + ELSEIF ( Model_mode(:7)=='CONVERT' ) THEN ! can be CONVERT4 or CONVERT5 or CONVERT (=CONVERT5) + Model = 10 + ELSEIF ( Model_mode(:13)=='DOCUMENTATION' ) THEN + Model = 99 + ELSE + PRINT '(/,2A)', 'ERROR, invalid model_mode value: ', Model_mode + STOP + ENDIF + + ! get simulation start_time and end_time + Starttime = -1 + DO j = 1, 6 + IF ( control_integer_array(Starttime(j), j, 'start_time')/=0 ) THEN + PRINT *, 'ERROR, start_time, index:', j, 'value: ', Starttime(j) + STOP + ENDIF + ENDDO + Start_year = Starttime(1) + IF ( Start_year<0 ) STOP 'ERROR, control parameter start_time must be specified' + Start_month = Starttime(2) + Start_day = Starttime(3) + Endtime = -1 + DO j = 1, 6 + IF ( control_integer_array(Endtime(j), j, 'end_time')/=0 ) THEN + PRINT *, 'ERROR, end_time, index:', j, 'value: ', Endtime(j) + STOP + ENDIF + ENDDO + End_year = Endtime(1) + IF ( End_year<0 ) STOP 'ERROR, control parameter start_time must be specified' + End_month = Endtime(2) + End_day = Endtime(3) + + IF ( control_integer(Init_vars_from_file, 'init_vars_from_file')/=0 ) Init_vars_from_file = 0 + IF ( control_integer(Save_vars_to_file, 'save_vars_to_file')/=0 ) Save_vars_to_file = 0 + + ! Open PRMS module output file + IF ( control_string(Model_output_file, 'model_output_file')/=0 ) CALL read_error(5, 'model_output_file') + IF ( Print_debug>-2 ) THEN + CALL PRMS_open_output_file(PRMS_output_unit, Model_output_file, 'model_output_file', 0, iret) + IF ( iret/=0 ) STOP + ENDIF + IF ( control_file_name(Model_control_file)/=0 ) CALL read_error(5, 'control_file_name') + IF ( control_string(Param_file, 'param_file')/=0 ) CALL read_error(5, 'param_file') + + ! Check for restart files + IF ( Init_vars_from_file>0 ) THEN + IF ( control_string(Var_init_file, 'var_init_file')/=0 ) CALL read_error(5, 'var_init_file') + CALL PRMS_open_input_file(Restart_inunit, Var_init_file, 'var_init_file', 1, iret) + IF ( iret/=0 ) STOP + ENDIF + IF ( Save_vars_to_file==1 ) THEN + IF ( control_string(Var_save_file, 'var_save_file')/=0 ) CALL read_error(5, 'var_save_file') + ENDIF + + Temp_module = ' ' + IF ( control_string(Temp_module, 'temp_module')/=0 ) CALL read_error(5, 'temp_module') + Precip_module = ' ' + IF ( control_string(Precip_module, 'precip_module')/=0 ) CALL read_error(5, 'precip_module') + Transp_module = ' ' + IF ( control_string(Transp_module, 'transp_module')/=0 ) CALL read_error(5, 'transp_module') + Et_module = ' ' + IF ( control_string(Et_module, 'et_module')/=0 ) CALL read_error(5, 'et_module') + Srunoff_module = ' ' + IF ( control_string(Srunoff_module, 'srunoff_module')/=0 ) CALL read_error(5, 'srunoff_module') + Solrad_module = ' ' + IF ( control_string(Solrad_module, 'solrad_module')/=0 ) CALL read_error(5, 'solrad_module') + Strmflow_module = 'strmflow' + IF ( control_string(Strmflow_module, 'strmflow_module')/=0 ) CALL read_error(5, 'strmflow_module') + + IF ( Parameter_check_flag>0 ) CALL check_module_names() + + Climate_precip_flag = 0 + Climate_temp_flag = 0 + Climate_transp_flag = 0 + Climate_potet_flag = 0 + Climate_swrad_flag = 0 + + IF ( Precip_module(:11)=='precip_1sta' .OR. Precip_module(:11)=='precip_prms') THEN + Precip_flag = 1 + ELSEIF ( Precip_module(:11)=='precip_laps' ) THEN + Precip_flag = 2 + ELSEIF ( Precip_module(:12)=='precip_dist2' ) THEN + Precip_flag = 3 + ELSEIF ( Precip_module(:8)=='ide_dist' ) THEN + Precip_flag = 5 + ELSEIF ( Precip_module(:11)=='climate_hru' ) THEN + Precip_flag = 7 + Climate_precip_flag = 1 + ELSEIF ( Precip_module(:8)=='xyz_dist' ) THEN + Precip_flag = 6 + ELSE + PRINT '(/,2A)', 'ERROR: invalid precip_module value: ', Precip_module + Inputerror_flag = 1 + ENDIF + Precip_combined_flag = 0 + IF ( Precip_flag==1 .OR. Precip_flag==2 ) Precip_combined_flag = 1 + + IF ( Temp_module(:9)=='temp_1sta' ) THEN + Temp_flag = 1 + ELSEIF ( Temp_module(:9)=='temp_laps' ) THEN + Temp_flag = 2 + ELSEIF ( Temp_module(:10)=='temp_dist2' ) THEN + Temp_flag = 3 + ELSEIF ( Temp_module(:8)=='ide_dist' ) THEN + Temp_flag = 5 + ELSEIF ( Temp_module(:11)=='climate_hru' ) THEN + Temp_flag = 7 + Climate_temp_flag = 1 + ELSEIF ( Temp_module(:8)=='xyz_dist' ) THEN + Temp_flag = 6 + ELSEIF ( Temp_module(:8)=='temp_sta' ) THEN + Temp_flag = 8 + ELSE + PRINT '(/,2A)', 'ERROR, invalid temp_module value: ', Temp_module + Inputerror_flag = 1 + ENDIF + Temp_combined_flag = 0 + IF ( Temp_flag==1 .OR. Temp_flag==2 .OR. Temp_flag==8 ) Temp_combined_flag = 1 + + IF ( Transp_module(:13)=='transp_tindex' ) THEN + Transp_flag = 1 + ELSEIF ( Transp_module(:12)=='transp_frost' ) THEN + Transp_flag = 2 + ELSEIF ( Transp_module(:11)=='climate_hru' ) THEN + Transp_flag = 3 + Climate_transp_flag = 1 + ELSE + PRINT '(/,2A)', 'ERROR, invalid transp_module value: ', Transp_module + Inputerror_flag = 1 + ENDIF + + IF ( Et_module(:8)=='potet_jh' ) THEN + Et_flag = 1 + ELSEIF ( Et_module(:11)=='potet_hamon' ) THEN + Et_flag = 2 + ELSEIF ( Et_module(:11)=='climate_hru' ) THEN + Et_flag = 7 + Climate_potet_flag = 1 + ELSEIF ( Et_module(:8)=='potet_hs' ) THEN + Et_flag = 10 + ELSEIF ( Et_module(:12)=='potet_pm_sta' ) THEN + Et_flag = 6 + ELSEIF ( Et_module(:8)=='potet_pm' ) THEN + Et_flag = 11 + ELSEIF ( Et_module(:8)=='potet_pt' ) THEN + Et_flag = 5 + ELSEIF ( Et_module(:9)=='potet_pan' ) THEN + Et_flag = 4 + ELSE + PRINT '(/,2A)', 'ERROR, invalid et_module value: ', Et_module + Inputerror_flag = 1 + ENDIF + + ! stream_temp + IF ( control_integer(Stream_temp_flag, 'stream_temp_flag')/=0 ) Stream_temp_flag = 0 + ! 0 = CBH File; 1 = specified constant; 2 = Stations + IF ( control_integer(Strmtemp_humidity_flag, 'strmtemp_humidity_flag')/=0 ) Strmtemp_humidity_flag = 0 + + Humidity_cbh_flag = 0 + Windspeed_cbh_flag = 0 + IF ( Et_flag==11 .OR. Et_flag==5 .OR. (Stream_temp_flag==1 .AND. Strmtemp_humidity_flag==0) ) Humidity_cbh_flag = 1 + IF ( Et_flag==11 ) Windspeed_cbh_flag = 1 + + IF ( Srunoff_module(:13)=='srunoff_smidx' ) THEN + Sroff_flag = 1 + ELSEIF ( Srunoff_module(:13)=='srunoff_carea' ) THEN + Sroff_flag = 2 + ELSE + PRINT '(/,2A)', 'ERROR, invalid srunoff_module value: ', Srunoff_module + Inputerror_flag = 1 + ENDIF + + Soilzone_module = 'soilzone' + + IF ( control_integer(Orad_flag, 'orad_flag')/=0 ) Orad_flag = 0 + IF ( Solrad_module(:8)=='ddsolrad' ) THEN + Solrad_flag = 1 + ELSEIF ( Solrad_module(:11)=='climate_hru' ) THEN + Solrad_flag = 7 + Climate_swrad_flag = 1 + ELSEIF ( Solrad_module(:8)=='ccsolrad' ) THEN + Solrad_flag = 2 + ELSE + PRINT '(/,2A)', 'ERROR, invalid solrad_module value: ', Solrad_module + Inputerror_flag = 1 + ENDIF + + Climate_hru_flag = 0 + IF ( Climate_temp_flag==1 .OR. Climate_precip_flag==1 .OR. Climate_potet_flag==1 .OR. & + & Climate_swrad_flag==1 .OR. Climate_transp_flag==1 .OR. & + & Humidity_cbh_flag==1 .OR. Windspeed_cbh_flag==1 ) Climate_hru_flag = 1 + + Muskingum_flag = 0 + IF ( Strmflow_module(:15)=='strmflow_in_out' ) THEN + Strmflow_flag = 5 + ELSEIF ( Strmflow_module(:14)=='muskingum_lake' ) THEN + Strmflow_flag = 3 + ELSEIF ( Strmflow_module(:13)=='strmflow_lake' ) THEN + PRINT '(/,2A)', 'ERROR, invalid strmflow_module value: ', Strmflow_module + Inputerror_flag = 1 + ELSEIF ( Strmflow_module(:8)=='strmflow' ) THEN + Strmflow_flag = 1 + ELSEIF ( Strmflow_module(:14)=='muskingum_mann' ) THEN + Strmflow_flag = 7 + Muskingum_flag = 1 + ELSEIF ( Strmflow_module(:9)=='muskingum' ) THEN + Strmflow_flag = 4 + Muskingum_flag = 1 + ELSEIF ( Strmflow_module(:9)=='mizuroute' ) THEN + Strmflow_flag = 6 + ELSE + PRINT '(/,2A)', 'ERROR, invalid strmflow_module value: ', Strmflow_module + Inputerror_flag = 1 + ENDIF + +! cascade dimensions + IF ( decldim('ncascade', 0, MAXDIM, & + & 'Number of HRU links for cascading flow')/=0 ) CALL read_error(7, 'ncascade') + IF ( decldim('ncascdgw', 0, MAXDIM, & + & 'Number of GWR links for cascading flow')/=0 ) CALL read_error(7, 'ncascdgw') + +! nsegment dimension + IF ( decldim('nsegment', 0, MAXDIM, 'Number of stream-channel segments')/=0 ) CALL read_error(7, 'nsegment') + +! subbasin dimensions + IF ( control_integer(Subbasin_flag, 'subbasin_flag')/=0 ) Subbasin_flag = 1 + IF ( decldim('nsub', 0, MAXDIM, 'Number of internal subbasins')/=0 ) CALL read_error(7, 'nsub') + + IF ( control_integer(Dprst_flag, 'dprst_flag')/=0 ) Dprst_flag = 0 + ! 0 = off, 1 = on, 2 = lauren version + IF ( control_integer(CsvON_OFF, 'csvON_OFF')/=0 ) CsvON_OFF = 0 + IF ( control_integer(Ripst_flag, 'ripst_flag')/=0 ) Ripst_flag = 0 + +! map results dimensions + IF ( control_integer(MapOutON_OFF, 'mapOutON_OFF')/=0 ) MapOutON_OFF = 0 + idim = 0 + IF ( GSFLOW_flag==1 .OR. MapOutON_OFF==1 ) idim = 1 + IF ( decldim('nhrucell', idim, MAXDIM, & + & 'Number of unique intersections between HRUs and spatial units of a target map for mapped results')/=0 ) & + & CALL read_error(7, 'nhrucell') + IF ( decldim('ngwcell', 0, MAXDIM, & + & 'Number of spatial units in the target map for mapped results')/=0 ) CALL read_error(7, 'ngwcell') + + IF ( control_integer(Glacier_flag, 'glacier_flag')/=0 ) Glacier_flag = 0 + IF ( control_integer(Frozen_flag, 'frozen_flag')/=0 ) Frozen_flag = 0 + IF ( control_integer(Dyn_imperv_flag, 'dyn_imperv_flag')/=0 ) Dyn_imperv_flag = 0 + IF ( control_integer(Dyn_intcp_flag, 'dyn_intcp_flag')/=0 ) Dyn_intcp_flag = 0 + IF ( control_integer(Dyn_covden_flag, 'dyn_covden_flag')/=0 ) Dyn_covden_flag = 0 + IF ( control_integer(Dyn_dprst_flag, 'dyn_dprst_flag')/=0 ) Dyn_dprst_flag = 0 + IF ( control_integer(Dyn_potet_flag, 'dyn_potet_flag')/=0 ) Dyn_potet_flag = 0 + IF ( control_integer(Dyn_covtype_flag, 'dyn_covtype_flag')/=0 ) Dyn_covtype_flag = 0 + IF ( control_integer(Dyn_transp_flag, 'dyn_transp_flag')/=0 ) Dyn_transp_flag = 0 + IF ( control_integer(Dyn_soil_flag, 'dyn_soil_flag')/=0 ) Dyn_soil_flag = 0 + IF ( control_integer(Dyn_radtrncf_flag, 'dyn_radtrncf_flag')/=0 ) Dyn_radtrncf_flag = 0 + IF ( control_integer(Dyn_sro2dprst_perv_flag, 'dyn_sro2dprst_perv_flag')/=0 ) Dyn_sro2dprst_perv_flag = 0 + IF ( control_integer(Dyn_sro2dprst_imperv_flag, 'dyn_sro2dprst_imperv_flag')/=0 ) Dyn_sro2dprst_imperv_flag = 0 + IF ( control_integer(Dyn_fallfrost_flag, 'dyn_fallfrost_flag')/=0 ) Dyn_fallfrost_flag = 0 + IF ( control_integer(Dyn_springfrost_flag, 'dyn_springfrost_flag')/=0 ) Dyn_springfrost_flag = 0 + IF ( control_integer(Dyn_snareathresh_flag, 'dyn_snareathresh_flag')/=0 ) Dyn_snareathresh_flag = 0 + IF ( control_integer(Dyn_transp_on_flag, 'dyn_transp_on_flag')/=0 ) Dyn_transp_on_flag = 0 + Dynamic_flag = 0 + IF ( Dyn_imperv_flag/=0 .OR. Dyn_intcp_flag/=0 .OR. Dyn_covden_flag/=0 .OR. Dyn_dprst_flag/=0 .OR. & + & Dyn_potet_flag/=0 .OR. Dyn_covtype_flag/=0 .OR. Dyn_transp_flag/=0 .OR. Dyn_soil_flag /=0 .OR. & + & Dyn_radtrncf_flag/=0 .OR. Dyn_sro2dprst_perv_flag/=0 .OR. Dyn_sro2dprst_imperv_flag/=0 .OR. & + & Dyn_fallfrost_flag/=0 .OR. Dyn_springfrost_flag/=0 .OR. Dyn_snareathresh_flag/=0 .OR. & + & Dyn_transp_on_flag/=0 ) Dynamic_flag = 1 + IF ( control_integer(Gwr_transferON_OFF, 'gwr_transferON_OFF')/=0) Gwr_transferON_OFF = 0 + IF ( control_integer(External_transferON_OFF, 'external_transferON_OFF')/=0 ) External_transferON_OFF = 0 + IF ( control_integer(Dprst_transferON_OFF, 'dprst_transferON_OFF')/=0 ) Dprst_transferON_OFF = 0 + IF ( control_integer(Segment_transferON_OFF, 'segment_transferON_OFF')/=0 ) Segment_transferON_OFF = 0 + IF ( control_integer(Lake_transferON_OFF, 'lake_transferON_OFF')/=0 ) Lake_transferON_OFF = 0 + IF ( control_integer(Gwr_swale_flag, 'gwr_swale_flag')/=0 ) Gwr_swale_flag = 0 + +! nhru_summary + IF ( control_integer(NhruOutON_OFF, 'nhruOutON_OFF')/=0 ) NhruOutON_OFF = 0 + +! nsub_summary + IF ( control_integer(NsubOutON_OFF, 'nsubOutON_OFF')/=0 ) NsubOutON_OFF = 0 + +! basin_summary + IF ( control_integer(BasinOutON_OFF, 'basinOutON_OFF')/=0 ) BasinOutON_OFF = 0 + +! nsegment_summary + IF ( control_integer(NsegmentOutON_OFF, 'nsegmentOutON_OFF')/=0 ) NsegmentOutON_OFF = 0 + + IF ( control_integer(Prms_warmup, 'prms_warmup')/=0 ) Prms_warmup = 0 + IF ( NhruOutON_OFF>0 .OR. NsubOutON_OFF>0 .OR. BasinOutON_OFF>0 .OR. NsegmentOutON_OFF>0 ) THEN + IF ( Start_year+Prms_warmup>End_year ) THEN ! change to start full date ??? + PRINT *, 'ERROR, prms_warmup > than simulation time period:', Prms_warmup + Inputerror_flag = 1 + ENDIF + ENDIF + +! cascade + ! if cascade_flag = 2, use hru_segment parameter for cascades, ncascade=ncascdgw=nhru (typical polygon HRUs) + IF ( control_integer(Cascade_flag, 'cascade_flag')/=0 ) Cascade_flag = 1 + ! if cascadegw_flag = 2, use same cascades as HRUs + IF ( control_integer(Cascadegw_flag, 'cascadegw_flag')/=0 ) Cascadegw_flag = 1 + +! spatial units + IF ( decldim('ngw', 1, MAXDIM, 'Number of GWRs')/=0 ) CALL read_error(7, 'ngw') + IF ( decldim('nhru', 1, MAXDIM, 'Number of HRUs')/=0 ) CALL read_error(7, 'nhru') + IF ( decldim('nssr', 1, MAXDIM, 'Number of subsurface reservoirs')/=0 ) CALL read_error(7, 'nssr') + IF ( decldim('nlake', 0, MAXDIM, 'Number of lakes')/=0 ) CALL read_error(7, 'nlake') + ! nlake_hrus to be added in 5.0.1 +! IF ( decldim('nlake_hrus', 0, MAXDIM, 'Number of lake HRUs')/=0 ) CALL read_error(7, 'nlake_hrus') + IF ( decldim('npoigages', 0, MAXDIM, 'Number of POI gages')/=0 ) CALL read_error(7, 'npoigages') + +! Time-series data stations, need to know if in Data File + IF ( decldim('nrain', 0, MAXDIM, 'Number of precipitation-measurement stations')/=0 ) CALL read_error(7, 'nrain') + IF ( decldim('nsol', 0, MAXDIM, 'Number of solar-radiation measurement stations')/=0 ) CALL read_error(7, 'nsol') + IF ( decldim('ntemp', 0, MAXDIM, 'Number of air-temperature-measurement stations')/=0 ) CALL read_error(7, 'ntemp') + IF ( decldim('nobs', 0, MAXDIM, 'Number of streamflow-measurement stations')/=0 ) CALL read_error(7, 'nobs') + IF ( decldim('nevap', 0, MAXDIM, 'Number of pan-evaporation data sets')/=0 ) CALL read_error(7, 'nevap') + IF ( decldim('nratetbl', 0, MAXDIM, 'Number of rating-table data sets for lake elevations') & + & /=0 ) CALL read_error(7, 'nratetbl') + +! depletion curves + IF ( decldim('ndepl', 1, MAXDIM, 'Number of snow-depletion curves')/=0 ) CALL read_error(7, 'ndelp') + IF ( decldim('ndeplval', 11, MAXDIM, 'Number of values in all snow-depletion curves (set to ndepl*11)')/=0 ) & + & CALL read_error(7, 'ndelplval') + +! water-use + IF ( decldim('nwateruse', 0, MAXDIM, 'Number of water-use data sets')/=0 ) CALL read_error(7, 'nwateruse') + IF ( decldim('nexternal', 0, MAXDIM, & + & 'Number of external water-use sources or destinations')/=0 ) CALL read_error(7, 'nexternal') + IF ( decldim('nconsumed', 0, MAXDIM, 'Number of consumptive water-use destinations')/=0 ) CALL read_error(7, 'nconsumed') + +! fixed dimensions + IF ( declfix('ndays', 366, 366, 'Maximum number of days in a year ')/=0 ) CALL read_error(7, 'ndays') + IF ( declfix('nmonths', 12, 12, 'Number of months in a year')/=0 ) CALL read_error(7, 'nmonths') + IF ( declfix('one', 1, 1, 'Number of values for scaler array')/=0 ) CALL read_error(7, 'one') + + IF ( call_modules('setdims')/=0 ) STOP 'ERROR, in setdims' + + IF ( Inputerror_flag==1 ) THEN + PRINT '(//,A,/,A)', '**FIX input errors in your Control File to continue**', & + & 'NOTE: some errors may be due to use of defalut values' + STOP + ENDIF + + setdims = 0 + END FUNCTION setdims + +!*********************************************************************** +! Get and check consistency of dimensions with flags +!*********************************************************************** + INTEGER FUNCTION check_dims() + USE PRMS_MODULE + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: getdim + EXTERNAL :: check_dimens +! Local Variables + INTEGER :: ierr +!*********************************************************************** + + Nhru = getdim('nhru') + IF ( Nhru==-1 ) CALL read_error(7, 'nhru') + + Nssr = getdim('nssr') + IF ( Nssr==-1 ) CALL read_error(7, 'nssr') + + Ngw = getdim('ngw') + IF ( Ngw==-1 ) CALL read_error(7, 'ngw') + + Ntemp = getdim('ntemp') + IF ( Ntemp==-1 ) CALL read_error(6, 'ntemp') + + Nrain = getdim('nrain') + IF ( Nrain==-1 ) CALL read_error(6, 'nrain') + + Nsol = getdim('nsol') + IF ( Nsol==-1 ) CALL read_error(6, 'nsol') + + Nobs = getdim('nobs') + IF ( Nobs==-1 ) CALL read_error(6, 'nobs') + + Nevap = getdim('nevap') + IF ( Nevap==-1 ) CALL read_error(6, 'nevap') + + Ncascade = getdim('ncascade') + IF ( Ncascade==-1 ) CALL read_error(7, 'ncascade') + Ncascdgw = getdim('ncascdgw') + IF ( Ncascdgw==-1 ) CALL read_error(7, 'ncascdgw') + IF ( Cascade_flag==2 ) THEN + Ncascade = Nhru + Cascadegw_flag = 2 + ENDIF + IF ( Cascadegw_flag==2 ) Ncascdgw = Ncascade + IF ( Ncascade==0 ) Cascade_flag = 0 + IF ( Ncascdgw==0 .OR. GSFLOW_flag==1 .OR. Model==2 ) Cascadegw_flag = 0 + IF ( (Cascade_flag>0 .OR. Cascadegw_flag>0) .AND. Model/=10 ) THEN ! don't call if model_mode = CONVERT + Call_cascade = 1 + ELSE + Call_cascade = 0 + ENDIF + + Nwateruse = getdim('nwateruse') + IF ( Nwateruse==-1 ) CALL read_error(7, 'nwateruse') + + Nexternal = getdim('nexternal') + IF ( Nexternal==-1 ) CALL read_error(6, 'nexternal') + + Nconsumed = getdim('nconsumed') + IF ( Nconsumed==-1 ) CALL read_error(6, 'nconsumed') + + Npoigages = getdim('npoigages') + IF ( Npoigages==-1 ) CALL read_error(6, 'npoigages') + + Nlake = getdim('nlake') + IF ( Nlake==-1 ) CALL read_error(7, 'nlake') + + ! Nlake_hrus will be added in version 5.0.1 +! Nlake_hrus = getdim('nlake_hrus') +! IF ( Nlake_hrus==-1 ) CALL read_error(7, 'nlake_hrus') +! IF ( Nlake>0 .AND. Nlake_hrus==0 ) Nlake_hrus = Nlake + Nlake_hrus = Nlake + + Ndepl = getdim('ndepl') + IF ( Ndepl==-1 ) CALL read_error(7, 'ndepl') + + Ndeplval = getdim('ndeplval') + IF ( Ndeplval==-1 ) CALL read_error(7, 'ndeplval') + + Nsub = getdim('nsub') + IF ( Nsub==-1 ) CALL read_error(7, 'nsub') + ! default = 1, turn off if no subbasins + IF ( Subbasin_flag==1 .AND. Nsub==0 ) Subbasin_flag = 0 + + Nsegment = getdim('nsegment') + IF ( Nsegment==-1 ) CALL read_error(7, 'nsegment') + + Nhrucell = getdim('nhrucell') + IF ( Nhrucell==-1 ) CALL read_error(6, 'nhrucell') + + Ngwcell = getdim('ngwcell') + IF ( Ngwcell==-1 ) CALL read_error(6, 'ngwcell') + + Nratetbl = getdim('nratetbl') + IF ( Nratetbl==-1 ) CALL read_error(6, 'nratetbl') + + Water_use_flag = 0 + IF ( Nwateruse>0 ) THEN + IF ( Segment_transferON_OFF==1 .OR. Gwr_transferON_OFF==1 .OR. External_transferON_OFF==1 .OR. & + & Dprst_transferON_OFF==1 .OR. Lake_transferON_OFF==1 .OR. Nconsumed>0 .OR. Nwateruse>0 ) Water_use_flag = 1 + ENDIF + + ierr = 0 + IF ( Segment_transferON_OFF==1 .OR. Gwr_transferON_OFF==1 .OR. External_transferON_OFF==1 .OR. & + & Dprst_transferON_OFF==1 .OR. Lake_transferON_OFF==1 .OR. Nconsumed>0 ) THEN + IF ( Dprst_transferON_OFF==1 .AND. Dprst_flag==0 ) THEN + PRINT *, 'ERROR, specified water-use event based dprst input and have dprst inactive' + ierr = 1 + ENDIF + IF ( Lake_transferON_OFF==1 .AND. Strmflow_flag/=3 ) THEN + PRINT *, 'ERROR, specified water-use event based lake input and have lake simulation inactive' + ierr = 1 + ENDIF + ENDIF + IF ( ierr==1 ) STOP + + Stream_order_flag = 0 + IF ( Nsegment>0 .AND. Strmflow_flag>1 .AND. Model/=0 ) THEN + Stream_order_flag = 1 ! strmflow_in_out, muskingum, muskingum_lake, muskingum_mann, mizuroute + ENDIF + + IF ( Nsegment<1 .AND. Model/=99 ) THEN + IF ( Stream_order_flag==1 .OR. Call_cascade==1 ) THEN + PRINT *, 'ERROR, streamflow and cascade routing require nsegment > 0, specified as:', Nsegment + STOP + ENDIF + ENDIF + + Lake_route_flag = 0 + IF ( Nlake>0 .AND. Strmflow_flag==3 .AND. Model/=0 ) Lake_route_flag = 1 ! muskingum_lake + + IF ( NsubOutON_OFF==1 .AND. Nsub==0 ) THEN + NsubOutON_OFF = 0 + IF ( Print_debug>-1 ) PRINT *, 'WARNING, nsubOutON_OFF = 1 and nsub = 0, thus nsub_summary not used' + ENDIF + + IF ( Model==99 .OR. Parameter_check_flag>0 ) CALL check_dimens() + + check_dims = Inputerror_flag + END FUNCTION check_dims + +!*********************************************************************** +! Check consistency of dimensions with flags +!*********************************************************************** + SUBROUTINE check_dimens() + USE PRMS_MODULE + IMPLICIT NONE +! Local Variables + INTEGER :: ierr +!*********************************************************************** + ierr = 0 + IF ( Nhru==0 .OR. Nssr==0 .OR. Ngw==0 ) THEN + PRINT *, 'ERROR, nhru, nssr, and ngw must be > 0: nhru=', Nhru, ', nssr=', Nssr, ', ngw=', Ngw + ierr = 1 + ELSEIF ( Nssr/=Nhru .OR. Ngw/=Nhru ) THEN + PRINT *, 'ERROR, nhru, nssr, and ngw must equal: nhru=', Nhru, ', nssr=', Nssr, ', ngw=', Ngw + ierr = 1 + ENDIF + IF ( Ndepl==0 ) THEN + PRINT *, 'ERROR, ndepl must be > 0: ndepl=', Ndepl + ierr = 1 + ENDIF + IF ( Ndeplval/=Ndepl*11 ) THEN + PRINT *, 'ERROR, ndeplval must be = ndepl*11: ndeplval:', Ndeplval, ', ndepl=', Ndepl + ierr = 1 + ENDIF + + IF ( ierr==1 ) STOP + + IF ( Model==99 ) THEN + IF ( Ntemp==0 ) Ntemp = 1 + IF ( Nrain==0 ) Nrain = 1 + IF ( Nlake==0 ) Nlake = 1 + IF ( Nlake_hrus==0 ) Nlake_hrus = 1 + IF ( Nsol==0 ) Nsol = 1 + IF ( Nobs==0 ) Nobs = 1 + IF ( Ncascade==0 ) Ncascade = 1 + IF ( Ncascdgw==0 ) Ncascdgw = 1 + IF ( Nsub==0 ) Nsub = 1 + IF ( Nevap==0 ) Nevap = 1 + IF ( Nhrucell==0 ) Nhrucell = 1 + IF ( Ngwcell==0 ) Ngwcell = 1 + IF ( Nsegment==0 ) Nsegment = 1 + IF ( Nratetbl==0 ) Nratetbl = 4 + IF ( Nwateruse==0 ) Nwateruse = 1 + IF ( Nexternal==0 ) Nexternal = 1 + IF ( Nconsumed==0 ) Nconsumed = 1 + IF ( Npoigages==0 ) Npoigages = 1 + Subbasin_flag = 1 + Cascade_flag = 1 + Cascadegw_flag = 1 + Call_cascade = 1 + Stream_order_flag = 1 + Climate_hru_flag = 1 + Lake_route_flag = 1 + Water_use_flag = 1 + Segment_transferON_OFF = 1 + Gwr_transferON_OFF = 1 + External_transferON_OFF = 1 + Dprst_transferON_OFF = 1 + Lake_transferON_OFF = 1 + ENDIF + + END SUBROUTINE check_dimens + +!********************************************************************** +! Module documentation +!********************************************************************** + SUBROUTINE module_doc() + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: basin, climateflow, prms_time + INTEGER, EXTERNAL :: cascade, obs, soltab, transp_tindex + INTEGER, EXTERNAL :: transp_frost, frost_date, routing + INTEGER, EXTERNAL :: temp_1sta_laps, temp_dist2 + INTEGER, EXTERNAL :: precip_1sta_laps, climate_hru + INTEGER, EXTERNAL :: precip_dist2, xyz_dist, ide_dist + INTEGER, EXTERNAL :: ddsolrad, ccsolrad + INTEGER, EXTERNAL :: potet_pan, potet_jh, potet_hamon, potet_hs, potet_pt, potet_pm + INTEGER, EXTERNAL :: intcp, snowcomp, gwflow, srunoff, soilzone, mizuroute + INTEGER, EXTERNAL :: strmflow, subbasin, basin_sum, map_results, strmflow_in_out + INTEGER, EXTERNAL :: write_climate_hru, muskingum, muskingum_lake + INTEGER, EXTERNAL :: stream_temp + EXTERNAL :: nhru_summary, prms_summary, water_balance, nsub_summary, basin_summary, nsegment_summary + INTEGER, EXTERNAL :: dynamic_param_read, water_use_read, setup, potet_pm_sta + INTEGER, EXTERNAL :: glacr +! Local variable + INTEGER :: test +!********************************************************************** + test = basin() + test = cascade() + test = climateflow() + test = soltab() + test = setup() + test = prms_time() + test = obs() + test = water_use_read() + test = dynamic_param_read() + test = temp_1sta_laps() + test = temp_dist2() + test = xyz_dist() + test = ide_dist() + test = climate_hru() + test = precip_1sta_laps() + test = precip_dist2() + test = ddsolrad() + test = ccsolrad() + test = transp_tindex() + test = frost_date() + test = transp_frost() + test = potet_jh() + test = potet_hamon() + test = potet_pan() + test = potet_hs() + test = potet_pt() + test = potet_pm() + test = potet_pm_sta() + test = write_climate_hru() + test = intcp() + test = snowcomp() + test = srunoff() + test = glacr() + test = soilzone() + test = gwflow() + test = routing() + test = strmflow() + test = strmflow_in_out() + test = muskingum() + test = mizuroute() + test = muskingum_lake() + test = stream_temp() + test = basin_sum() + test = map_results() + CALL nhru_summary() + CALL nsub_summary() + CALL basin_summary() + CALL nsegment_summary() + CALL prms_summary() + CALL water_balance() + test = subbasin() + + PRINT 9001 + 9001 FORMAT (//, ' All available modules have been called.', /, & + & ' All parameters have been declared.', /, & + & ' Note, no simulation was computed.', /) + + END SUBROUTINE module_doc + +!*********************************************************************** +! check module names +!*********************************************************************** + SUBROUTINE check_module_names() + USE PRMS_MODULE, ONLY: Temp_module, Precip_module, Et_module, Solrad_module, & + & Transp_module, Srunoff_module, Strmflow_module + IMPLICIT NONE +! Local Variables + INTEGER :: ierr +!*********************************************************************** + ierr = 0 + IF ( Temp_module(:14)=='temp_1sta_prms' ) THEN + PRINT *, 'WARNING, deprecated temp_module value, change temp_1sta_prms to temp_1sta' + Temp_module = 'temp_1sta' + ELSEIF ( Temp_module(:14)=='temp_laps_prms' ) THEN + PRINT *, 'WARNING, deprecated temp_module value, change temp_laps_prms to temp_laps' + Temp_module = 'temp_laps' + ELSEIF ( Temp_module(:15)=='temp_dist2_prms' ) THEN + PRINT *, 'WARNING, deprecated temp_module value, change temp_dist2_prms to temp_dist2' + Temp_module = 'temp_dist2' + ELSEIF ( Temp_module(:9)=='temp_2sta' ) THEN + PRINT *, 'ERROR, module temp_2sta_prms not available, use a different temp_module' + ierr = 1 + ENDIF + + IF ( Precip_module(:11)=='precip_prms' ) THEN + PRINT *, 'WARNING, deprecated precip_module value, change precip_prms to precip_1sta' + Precip_module = 'precip_1sta' + ELSEIF ( Precip_module(:16)=='precip_laps_prms' ) THEN + PRINT *, 'WARNING, deprecated precip_module value, change precip_laps_prms to precip_laps' + Precip_module = 'precip_laps' + ELSEIF ( Precip_module(:17)=='precip_dist2_prms' ) THEN + PRINT *, 'WARNING, deprecated precip_module value, change precip_dist2_prms to precip_dist2' + Precip_module = 'precip_dist2' + ENDIF + + IF ( Temp_module(:8)=='ide_dist' .AND. Precip_module(:8)/='ide_dist') THEN + PRINT '(/,A,/,2A)', 'ERROR, if ide_dist is specified for temp_module,', & + & 'it also must be specified for precip_module: ', Precip_module + ierr = 1 + ELSEIF ( Precip_module(:8)=='ide_dist' .AND. Temp_module(:8)/='ide_dist') THEN + PRINT '(/,A,/,2A)', 'ERROR, if ide_dist is specified for precip_module,', & + & 'it also must be specified for temp_module: ', Temp_module + ierr = 1 + ELSEIF ( Temp_module(:8)=='xyz_dist' .AND. Precip_module(:8)/='xyz_dist') THEN + PRINT '(/,A,/,2A)', 'ERROR, if xyz_dist is specified for temp_module,', & + & 'it also must be specified for precip_module: ', Precip_module + ierr = 1 + ELSEIF ( Precip_module(:8)=='xyz_dist' .AND. Temp_module(:8)/='xyz_dist') THEN + PRINT '(/,A,/,2A)', 'ERROR, if xyz_dist is specified for precip_module,', & + & 'it also must be specified for temp_module: ', Temp_module + ierr = 1 + ENDIF + + IF ( Transp_module(:18)=='transp_tindex_prms' ) THEN + PRINT *, 'WARNING, deprecated transp_module value, change transp_tindex_prms to transp_tindex' + Transp_module = 'transp_tindex' + ENDIF + + IF ( Et_module(:13)=='potet_jh_prms' ) THEN + PRINT *, 'WARNING, deprecated et_module value, change potet_jh_prms to potet_jh' + Et_module = 'potet_jh' + ELSEIF ( Et_module(:14)=='potet_pan_prms' ) THEN + PRINT *, 'WARNING, deprecated et_module value, change potet_pan_prms to potet_pan' + Et_module = 'potet_pan' + ELSEIF ( Et_module(:15)=='potet_epan_prms' ) THEN + PRINT *, 'ERROR, deprecated et_module value, change potet_epan_prms to potet_pan' + ierr = 1 + ELSEIF ( Et_module(:20)=='potet_hamon_hru_prms' ) THEN + PRINT *, 'WARNING, deprecated et_module value, change potet_hamon_hru_prms to potet_hamon_hru' + Et_module = 'potet_hamon' + ELSEIF ( Et_module(:16)=='potet_hamon_prms' ) THEN + PRINT *, 'WARNING, deprecated et_module value, change potet_hamon_prms to potet_hamon' + Et_module = 'potet_hamon' + ENDIF + + IF ( Solrad_module(:17)=='ddsolrad_hru_prms' ) THEN + PRINT *, 'WARNING, deprecated solrad_module value, change ddsolrad_hru_prms to ddsolrad' + Solrad_module = 'ddsolrad' + ELSEIF ( Solrad_module(:17)=='ccsolrad_hru_prms' ) THEN + PRINT *, 'WARNING, deprecated solrad_module value, change ccsolrad_hru_prms to ccsolrad' + Solrad_module = 'ccsolrad' + ELSEIF ( Solrad_module(:13)=='ddsolrad_prms' ) THEN + PRINT *, 'WARNING, deprecated solrad_module value, change ddsolrad_prms to ddsolrad' + Solrad_module = 'ddsolrad' + ELSEIF ( Solrad_module(:13)=='ccsolrad_prms' ) THEN + PRINT *, 'WARNING, deprecated solrad_module value, change ccsolrad_prms to ccsolrad' + Solrad_module = 'ccsolrad' + ENDIF + + IF ( Srunoff_module(:18)=='srunoff_carea_prms' ) THEN + PRINT *, 'WARNING, deprecated srunoff_module value, change srunoff_carea_prms to srunoff_carea' + Srunoff_module = 'srunoff_carea' + ELSEIF ( Srunoff_module(:18)=='srunoff_smidx_prms' ) THEN + PRINT *, 'WARNING, deprecated srunoff_module value, change srunoff_smidx_prms to srunoff_smidx' + Srunoff_module = 'srunoff_smidx' + ENDIF + + IF ( Strmflow_module(:13)=='strmflow_prms' ) THEN + PRINT *, 'WARNING, deprecated strmflow_module value, change strmflow_prms to strmflow' + Strmflow_module = 'strmflow' + ELSEIF ( Strmflow_module(:13)=='strmflow_lake' ) THEN + PRINT *, 'ERROR, module strmflow_lake not available, use a different strmflow_module, such as muskingum_lake' + ierr = 1 + ENDIF + IF ( ierr==1 ) STOP + END SUBROUTINE check_module_names + +!*********************************************************************** +! call_modules_restart - write or read restart file +!*********************************************************************** + SUBROUTINE call_modules_restart(In_out) + USE PRMS_MODULE + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart, check_restart_dimen + ! Functions + INTRINSIC TRIM + ! Local Variables + INTEGER :: nhru_test, dprst_test, nsegment_test, temp_test, et_test, ierr, time_step + INTEGER :: cascade_test, cascdgw_test, nhrucell_test, nlake_test, transp_test, start_time(6), end_time(6) + CHARACTER(LEN=MAXCONTROL_LENGTH) :: model_test + CHARACTER(LEN=12) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Timestep, Nhru, Dprst_flag, Nsegment, Temp_flag, Et_flag, & + & Cascade_flag, Cascadegw_flag, Nhrucell, Nlake, Transp_flag, Model_mode + WRITE ( Restart_outunit ) Starttime, Endtime + ELSE + ierr = 0 + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) time_step, nhru_test, dprst_test, nsegment_test, temp_test, et_test, & + & cascade_test, cascdgw_test, nhrucell_test, nlake_test, transp_test, model_test + READ ( Restart_inunit ) start_time, end_time + IF ( Print_debug>-2 ) PRINT 4, EQULS, 'Simulation time period of Restart File:', & + & start_time(1), start_time(2), start_time(3), ' -', end_time(1), end_time(2), end_time(3), & + & 'Last time step of simulation: ', time_step, EQULS + 4 FORMAT (/, A, /, 2(A, I5, 2('/',I2.2)), /, A, I0, /, A, /) + IF ( TRIM(Model_mode)/=TRIM(model_test) ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model_mode=', model_test + PRINT *, ' Current model has model_mode=', Model_mode, ' they must be equal' + ierr = 1 + ENDIF + CALL check_restart_dimen('nhru', nhru_test, Nhru, ierr) + CALL check_restart_dimen('nhrucell', nhrucell_test, Nhrucell, ierr) + CALL check_restart_dimen('nlake', nlake_test, Nlake, ierr) + IF ( Dprst_flag/=dprst_test ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model with dprst_flag=', dprst_test + PRINT *, ' Current model has dprst_flag=', Dprst_flag, ' they must be equal' + ierr = 1 + ENDIF + IF ( Cascade_flag/=cascade_test ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model with cascade_flag=', cascade_test + PRINT *, ' Current model has cascade_flag=', Cascade_flag, ' they must be equal' + ierr = 1 + ENDIF + IF ( Cascadegw_flag/=cascdgw_test ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model with cascadegw_flag=', cascdgw_test + PRINT *, ' Current model has cascadegw_flag=', Cascadegw_flag, ' they must be equal' + ierr = 1 + ENDIF + CALL check_restart_dimen('nsegment', nsegment_test, Nsegment, ierr) + ! Temp_flag (1=temp_1sta; 2=temp_laps; 3=temp_dist2; 5=ide_dist; 6=xyz_dist; 7=climate_hru; 8=temp_sta + IF ( Temp_flag/=temp_test ) THEN + IF ( Temp_flag<4 .OR. temp_test<4 ) THEN + PRINT *, 'ERROR, Initial Conditions File saved for model with different temperature module' + PRINT *, ' than current model, cannot switch to/from temp_1sta, temp_laps, or temp_dist2' + ierr = 1 + ENDIF + ENDIF + IF ( Et_flag/=et_test ) THEN + IF ( Et_flag==4 .OR. et_test==4 ) THEN + PRINT *, 'ERROR, Cannot switch to/from potet_pan module for restart simulations' + ierr = 1 + ENDIF + ENDIF + IF ( Transp_flag/=transp_test ) THEN + IF ( Transp_flag==1 .OR. transp_test==1 ) THEN + PRINT *, 'ERROR, Cannot switch to/from transp_tindex module for restart simulations' + ierr = 1 + ENDIF + ENDIF + IF ( ierr==1 ) STOP + ENDIF + END SUBROUTINE call_modules_restart diff --git a/prmsRip/mizurouteRip.f90 b/prmsRip/mizurouteRip.f90 new file mode 100644 index 00000000..8b6b0121 --- /dev/null +++ b/prmsRip/mizurouteRip.f90 @@ -0,0 +1,787 @@ +!*********************************************************************** +! Defines stream and lake routing parameters and variables +!*********************************************************************** + MODULE PRMS_MIZUROUTE + IMPLICIT NONE +! Local Variables +! index for printing (set to negative to supress printing + integer,parameter :: ixPrint = -9999 ! index for printing +! useful constants + logical,parameter :: doKWTroute=.True. !.True. if switch off will do KWT + double precision,parameter :: verySmall=tiny(1.0D0) ! a very small number +! general guff + integer,parameter :: strLen=256 ! length of character string + integer :: ierr ! error code + character(len=strLen) :: cmessage ! error message of downwind routine + integer :: iTime ! loop through time + character(len=strLen) :: str ! miscellaneous string +! define stream segment information + integer,target :: nSeg ! number of all the stream segments + integer,pointer :: nSegRoute ! number of stream segments to be routed + integer :: nUpstream ! number of reaches upstream of each stream segment + integer :: iSeg ! index of stream segment + integer :: jSeg ! index of stream segment + integer :: iSegOut ! index of outlet stream segment + integer :: iSelect(1) ! index of desired stream segment (iSegOut) from the minloc operation + integer :: iSegDesire ! index of desired stream segment -- de-vectorized version of iSelect(1) + integer :: iUps ! index of upstream stream segment added by NM + integer :: iStart ! start index of the ragged array + integer,dimension(1) :: iDesire ! index of stream segment with maximum upstream area (vector) + integer :: ixDesire ! index of stream segment with maximum upstream area (scalar) +! define stream network information + integer,allocatable :: REACHIDGV(:) + integer,allocatable :: RCHIXLIST(:) + integer :: nTotal ! total number of upstream segments for all stream segments + integer :: iRchStart + integer :: iRchStart1 + integer,target :: nRchCount + integer :: nRchCount1 + integer :: iUpRchStart + integer :: nUpRchCount + integer,allocatable :: upStrmRchList(:) +! define metadata from model output file + integer :: iRch ! index in reach structures +! interpolate simulated runoff data to the basins + integer :: ibas ! index of the basins + integer :: iHRU ! index of the HRUs associated to the basin + integer :: nDrain ! number of HRUs that drain into a given stream segment + integer :: ix ! index of the HRU assigned to a given basin +! route delaied runoff through river network with St.Venant UH + integer :: nUH_DATA_MAX ! maximum number of elements in the UH data among all the upstreamfs for a segment +! compute total instantaneous runoff upstream of each reach + integer,allocatable :: iUpstream(:) ! indices for all reaches upstream + double precision,allocatable :: qUpstream(:) ! streamflow for all reaches upstream +! route kinematic waves through the river network + integer, parameter :: nens=1 ! number of ensemble members + integer :: iens ! index of ensemble member + double precision, save :: T0 ! start of the time step (seconds) + double precision :: T1 ! end of the time step (seconds) + integer :: LAKEFLAG ! >0 if processing lakes + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:) + CHARACTER(LEN=9), SAVE :: MODNAME + END MODULE PRMS_MIZUROUTE + +!*********************************************************************** +! Main mizuroute routine +!*********************************************************************** + INTEGER FUNCTION mizuroute() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: mizuroute_decl, mizuroute_init, mizuroute_run + EXTERNAL :: mizuroute_restart +!*********************************************************************** + mizuroute = 0 + + IF ( Process(:3)=='run' ) THEN + mizuroute = mizuroute_run() + ELSEIF ( Process(:4)=='decl' ) THEN + mizuroute = mizuroute_decl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL mizuroute_restart(1) + mizuroute = mizuroute_init() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL mizuroute_restart(0) + ENDIF + + END FUNCTION mizuroute + +!*********************************************************************** +! mizuroute_decl - Declare parameters and variables and allocate arrays +! Declared Parameters +! tosegment, hru_segment, obsin_segment, K_coef, x_coef +!*********************************************************************** + INTEGER FUNCTION mizuroute_decl() + USE PRMS_MIZUROUTE + USE PRMS_MODULE, ONLY: Nsegment + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_mizuroute +!*********************************************************************** + mizuroute_decl = 0 + + Version_mizuroute = 'mizuroute.f90 2017-10-06 11:04:00Z' + CALL print_module(Version_mizuroute, 'Streamflow Routing ', 90) + MODNAME = 'mizuroute' + + ALLOCATE ( Outflow_ts(Nsegment) ) + + END FUNCTION mizuroute_decl + +!*********************************************************************** +! mizuroute_init - Get and check parameter values and initialize variables +!*********************************************************************** + INTEGER FUNCTION mizuroute_init() + USE PRMS_MIZUROUTE + USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file + USE PRMS_BASIN, ONLY: Basin_area_inv, FT2_PER_ACRE, FEET2METERS + USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_ROUTING, ONLY: Basin_segment_storage, Tosegment, Segment_hruarea, & + & Segment_order, Obsin_segment, Obsout_segment, Seg_length, Seg_slope +! mizuroute specific modules + USE nrtype ! variable types, etc. + USE reachparam ! reach parameters + USE reachstate ! reach states + USE reach_flux ! fluxes in each reach + USE nrutil,only:arth ! use to build vectors with regular increments + USE lake_param ! lake parameters + USE lakes_flux ! fluxes in each lake +! **** + USE kwt_route,only:reachorder ! define the processing order for the stream segments + IMPLICIT NONE +! Functions + EXTERNAL :: read_error + INTEGER, EXTERNAL :: getparam +! Local Variables + INTEGER :: i, j, k, jj, toseg, iorder, reachStart(Nsegment), reachCount(Nsegment) + INTEGER :: upReachStart(Nsegment), upReachCount(Nsegment),reachListMat(Nsegment,Nsegment) + INTEGER :: reachList(Nsegment*Nsegment),upReachIndex(Nsegment*Nsegment), seg_id(Nsegment) + INTEGER :: upReachIndMat(Nsegment,Nsegment), ilake + DOUBLE PRECISION :: totalArea(Nsegment) +!*********************************************************************** + mizuroute_init = 0 + + IF ( Init_vars_from_file==0 ) THEN + Outflow_ts = 0.0D0 + ENDIF + + !Seg_outflow will have been initialized to Segment_flow_init in PRMS_ROUTING + Basin_segment_storage = 0.0D0 + DO i = 1, Nsegment + Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) + ENDDO + Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv + + DO i = 1, Nsegment + IF ( Tosegment(i)==0 ) iSegOut = i + seg_id(i) = i + ENDDO + + T0 = 0.D0 + nSeg = Nsegment + +! Calculate network topology information... + reachStart = 0 + reachCount = 1 + upReachStart = -9999 + upReachCount = 0 + reachListMat = 0 + reachList = 0 + upReachIndMat = 0 + upReachIndex = 0 + DO i = 1, Nsegment + iorder = Segment_order(i) + toseg = Tosegment(iorder) + reachListMat(iorder,iorder) = 1 + IF ( toseg>0 ) THEN + reachListMat(toseg,1:Nsegment) = reachListMat(toseg,1:Nsegment)+reachListMat(iorder,1:Nsegment) + upReachIndMat(toseg,iorder) = 1 + ENDIF + ENDDO + !Note, size of upReachIndex sUps = SUM(upReachIndex) + !Note, size of reachList sAll = SUM(reachListMat) + DO i = 1, Nsegment + reachCount(i) = SUM(reachListMat(i,1:Nsegment)) + upReachCount(i) = SUM(upReachIndMat(i,1:Nsegment)) + ENDDO + DO i = 1, Nsegment + reachStart(i) = SUM(reachCount(1:i)) - reachCount(i) + 1 + IF ( upReachCount(i)>0 ) upReachStart(i) = SUM(upReachCount(1:i)) - upReachCount(i) + 1 + j = reachStart(i) + jj = upReachStart(i) + DO k = 1,Nsegment + IF (reachListMat(i,k) == 1) THEN + reachList(j) = k + j = j+1 + ENDIF + IF (jj>0 .AND. upReachIndMat(i,k) == 1) THEN + upReachIndex(jj) = k + jj = jj+1 + ENDIF + ENDDO + iRchStart = reachStart(i) + nRchCount = reachCount(i) + totalArea(i) = DBLE(SUM(Segment_hruarea(reachList(iRchStart:(iRchStart+nRchCount-1))))) + totalArea(i) = totalArea(i)*FT2_PER_ACRE*(FEET2METERS**2.) + ENDDO + +! Read global reach id, allocate + allocate(REACHIDGV(Nsegment), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for REACHIDGV') + REACHIDGV = seg_id + if ( iSegOut /= -9999 ) then + !print*, 'Outlet segment = ', iSegOut +! Identify index of the desired stream segment from reachID vector (dimension size: Nsegment) + iSelect = minloc(abs(REACHIDGV - iSegOut)) + iSegDesire = iSelect(1) ! de-vectorize the desired stream segment + if(REACHIDGV(iSegDesire) /= iSegOut)& + call handle_err(20,'unable to find desired stream segment') + +! Start index and the count for lagged array - all the upstream segments, immediate upstream segment, immediate upstream HRUs + iRchStart = reachStart(iSegDesire) + nRchCount = reachCount(iSegDesire) + !print*,'iRchStart = ',iRchStart + !print*,'Number of upstream segment from outlet segment (nRchCount): ',nRchCount + +! Read reach list of index from global segments (all the upstream reachs for each segment) + allocate(upStrmRchList(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for upStrmRchList') + upStrmRchList = reachList(iRchStart:(iRchStart+nRchCount-1)) + +! Reach upstream segment and associated HRU infor from non-ragged vector + allocate(NETOPO(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO') + allocate(RPARAM(nRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RPARAM') + +! Create REACH index for local segments + NETOPO(:)%REACHIX=arth(1,1,nRchCount) + do iSeg=1,nRchCount + ! Reach reach topology and parameters (integer) + NETOPO(iSeg)%REACHID = seg_id(upStrmRchList(iSeg)) + NETOPO(iSeg)%DREACHK = Tosegment(upStrmRchList(iSeg)) + ! Reach reach topology and parameters (double precision precision) + RPARAM(iSeg)%R_SLOPE = DBLE(Seg_slope(upStrmRchList(iSeg))) + RPARAM(iSeg)%RLENGTH = DBLE(Seg_length(upStrmRchList(iSeg))) + RPARAM(iSeg)%TOTAREA = totalArea(upStrmRchList(iSeg)) + enddo + + ! Recompute downstream segment index as local segment list, NETOPO(:)%REACHID + do iSeg=1,nRchCount + ! Assign downstream segment ID = 0 at desired outlet segment + if (NETOPO(iSeg)%REACHID == iSegOut) then + NETOPO(iSeg)%DREACHK = 0 + else + ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) + iSelect = minloc(abs(NETOPO(:)%REACHID - NETOPO(iSeg)%DREACHK)) + NETOPO(iSeg)%DREACHI = iSelect(1) ! de-vectorize the desired stream segment + if (NETOPO(NETOPO(iSeg)%DREACHI)%REACHID /= NETOPO(iSeg)%DREACHK) then + !print*,'iSeg = ', iSeg + !print*,'NETOPO(iSeg)%DREACHK = ', NETOPO(iSeg)%DREACHK + !print*,'NETOPO(NETOPO(iSeg)%DREACHI)%REACHID = ', NETOPO(NETOPO(iSeg)%DREACHI)%REACHID + call handle_err(20,'unable to find desired downstream segment') + endif + endif + enddo + +! Reach upstream segment and associated HRU infor from ragged vector + nTotal=0 + do iSeg=1,nRchCount + ! sAll dimension + iRchStart1 = reachStart(upStrmRchList(iSeg)) + nRchCount1 = reachCount(upStrmRchList(iSeg)) + allocate(NETOPO(iSeg)%RCHLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%RCHLIST') + allocate(RCHIXLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RCHIXLIST(nRchCount)') + RCHIXLIST = reachList(iRchStart1:(iRchStart1+nRchCount1-1)) + + ! Recompute all the upstream segment indices as local segment list = NETOPO(:)%REACHID + nTotal = nTotal + nRchCount1 + do jSeg=1,nRchCount1 + ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) + iSelect = minloc( abs( NETOPO(:)%REACHID - REACHIDGV(RCHIXLIST(jSeg)) ) ) + NETOPO(iSeg)%RCHLIST(jSeg) = iSelect(1) ! de-vectorize the desired stream segment + enddo + !print*,'NETOPO(iSeg)%RCHLIST(:) = ',NETOPO(iSeg)%RCHLIST(:) + deallocate(RCHIXLIST, stat=ierr) + + ! sUps dimension + iUpRchStart = upReachStart(upStrmRchList(iSeg)) + nUpRchCount = upReachCount(upStrmRchList(iSeg)) + allocate(NETOPO(iSeg)%UREACHI(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHI') + allocate(NETOPO(iSeg)%UREACHK(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHK') + allocate(NETOPO(iSeg)%goodBas(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%goodBas') + if (nUpRchCount > 0) then + + NETOPO(iSeg)%UREACHK(:) = seg_id(upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1))) + do jSeg=1,nUpRchCount + ! Identify the index of the desired stream segment from reachID vector (dimension size: Nsegment) + iSelect = minloc(abs(NETOPO(:)%REACHID - NETOPO(iSeg)%UREACHK(jSeg))) + NETOPO(iSeg)%UREACHI(jSeg) = iSelect(1) ! de-vectorize the desired stream segment + ! check that we identify the correct upstream reach + if (NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID /= NETOPO(iSeg)%UREACHK(jSeg)) then + !print*,'iSeg = ', iSeg + !print*,'NETOPO(iSeg)%UREACHK(jSeg) = ', NETOPO(iSeg)%UREACHK(jSeg) + !print*,'NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID = ', NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID + call handle_err(20,'unable to find desired immediate upstream segment') + endif + + ! check that the upstream reach has a basin area > 0 + if(RPARAM(NETOPO(iSeg)%UREACHI(jSeg))%TOTAREA > verySmall)then + NETOPO(iSeg)%goodBas(jSeg) = .true. + else + NETOPO(iSeg)%goodBas(jSeg) = .false. + endif + + enddo ! looping through the immediate upstream reaches + endif ! if not a headwater + enddo ! looping through the stream segments within the model domain + nSegRoute => nRchCount + + else ! if the entire river network routing is selected + !print*, 'Route all the segments included in network topology' + ! Populate sSeg dimensioned variable + allocate(NETOPO(nSeg), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO') + allocate(RPARAM(nSeg), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for RPARAM') + do iSeg=1,Nsegment + ! Reach reach topology and parameters (integer) + NETOPO(iSeg)%REACHIX = iSeg + NETOPO(iSeg)%REACHID = seg_id(iSeg) != to iSeg + NETOPO(iSeg)%DREACHI = Tosegment(iSeg) + NETOPO(iSeg)%DREACHK = Tosegment(iSeg) + ! Reach reach topology and parameters (double precision precision) + RPARAM(iSeg)%R_SLOPE = DBLE(Seg_slope(iSeg)) + RPARAM(iSeg)%RLENGTH = DBLE(Seg_length(iSeg)) + RPARAM(iSeg)%TOTAREA = totalArea(iSeg) + enddo + ! Populate sAll dimensioned variable + ! NETOPO%RCHLIST - upstream reach list + nTotal=0 + do iSeg=1,Nsegment + iRchStart1 = reachStart(iSeg) + nRchCount1 = reachCount(iSeg) + allocate(NETOPO(iSeg)%UPSLENG(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UPSLENG') + allocate(NETOPO(iSeg)%RCHLIST(nRchCount1), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%RCHLIST') + NETOPO(iSeg)%RCHLIST(:) = reachList(iRchStart1:(iRchStart1+nRchCount1-1)) + nTotal = nTotal + nRchCount1 + enddo + ! Populate sUps dimensioned variable + ! NETOPO%UREACHI - Immediate upstream reach index list + ! NETOPO%UREACHK - Immediate upstream reach ID list + do iSeg=1,Nsegment + iUpRchStart = upReachStart(iSeg) + nUpRchCount = upReachCount(iSeg) + allocate(NETOPO(iSeg)%UREACHI(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHI') + allocate(NETOPO(iSeg)%UREACHK(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%UREACHK') + allocate(NETOPO(iSeg)%goodBas(nUpRchCount), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for NETOPO%goodBas') + if (nUpRchCount > 0) then + NETOPO(iSeg)%UREACHK(:) = seg_id(upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1))) + NETOPO(iSeg)%UREACHI(:) = upReachIndex(iUpRchStart:(iUpRchStart+nUpRchCount-1)) + do jSeg=1,nUpRchCount + ! check that we identify the correct upstream reach + if (NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID /= NETOPO(iSeg)%UREACHK(jSeg)) then + !print*,'iSeg = ', iSeg + !print*,'NETOPO(iSeg)%UREACHK(jSeg) = ', NETOPO(iSeg)%UREACHK(jSeg) + !print*,'NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID = ', NETOPO(NETOPO(iSeg)%UREACHI(jSeg))%REACHID + call handle_err(20,'unable to find desired immediate upstream segment') + endif + ! check that the upstream reach has a basin area > 0 + if(RPARAM(NETOPO(iSeg)%UREACHI(jSeg))%TOTAREA > verySmall)then + NETOPO(iSeg)%goodBas(jSeg) = .true. + else + NETOPO(iSeg)%goodBas(jSeg) = .false. + endif + enddo ! looping through the immediate upstream reaches + endif ! if not a headwater + enddo + nSegRoute => nSeg + endif ! outlet segment choice + + if (doKWTroute) then + ! define processing order of the reaches + call reachorder(nSegRoute, ierr, cmessage); call handle_err(ierr, cmessage) + end if + + ! identify the stream segment with the largest upstream area + iDesire = maxLoc(RPARAM(:)%TOTAREA) + ixDesire= iDesire(1) + !print*, 'maximum upstream area = ', RPARAM(ixDesire)%TOTAREA, size(NETOPO(ixDesire)%RCHLIST) + + ! set the downstream index of the outlet reach to negative (the outlet reach does not flow into anything) + NETOPO(ixDesire)%DREACHI = -9999 + + ! allocate space for the simulated runoff at reaches + allocate(RCHFLX(nens,nSegRoute), KROUTE(nens,nSegRoute), stat=ierr) + if(ierr/=0) call handle_err(ierr,'problem allocating space for simulated runoff at the basins') + + + ! setup streamflow replacement at segments if needed + ! using as fake lakes for now, FIX? + ! ************************************************** + ilake = 0 + DO i = iSeg, nSegRoute + IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) ilake = ilake+1 + IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) ilake = ilake+1 + ENDDO + NETOPO(:)%LAKE_IX = 0 + NETOPO(:)%LAKINLT = .FALSE. + allocate(LKTOPO(ilake), stat=ierr); if(ierr/=0) call handle_err(ierr,'problem allocating space for LKTOPO') + LKTOPO(:)%DREACHI = 0 + ! allocate space for the simulated flux at lakes + allocate(LAKFLX(nens,ilake), stat=ierr) + if(ierr/=0) call handle_err(ierr,'problem allocating space for simulated fluxes at the lakes') + LAKFLX(:,:)%LAKE_Q = 0.D0 + IF (ilake>0) THEN + LAKEFLAG = 1 + ilake = 0 + DO i = 1, nSegRoute + IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is outlet of lake with known 'lake' flow coming into reach + ilake= ilake+1 + NETOPO(iSeg)%LAKE_IX = ilake + LKTOPO(ilake)%DREACHI = NETOPO(iSeg)%REACHIX + ENDIF + IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach a lake with known 'lake' flow coming out reach and not routed in the reach + ilake= ilake+1 + NETOPO(iSeg)%LAKE_IX = ilake + LKTOPO(ilake)%DREACHI = NETOPO(iSeg)%REACHIX + RPARAM(iSeg)%RLENGTH = 0.D0 ! FIX: NOT SURE I CAN HAVE 0 LENGTH + ENDIF + ENDDO + ENDIF + ! initialize the routed elements + RCHFLX(:,:)%BASIN_QR(1) = 0.D0 + + END FUNCTION mizuroute_init + +!*********************************************************************** +! mizuroute_run - Compute routing summary values +!*********************************************************************** + INTEGER FUNCTION mizuroute_run() + USE PRMS_MIZUROUTE + USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, METERS2FEET, Active_hrus, Hru_route_order, & + & Basin_gl_cfs, Basin_gl_ice_cfs + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & + & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & + & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out + USE PRMS_OBS, ONLY: Streamflow_cfs + USE PRMS_SET_TIME, ONLY: Cfs_conv, Timestep_seconds + USE PRMS_ROUTING, ONLY: Mann_n, Seg_Width, Obsin_segment, Tosegment, Obsout_segment, & + & Segment_delta_flow, Segment_type, Basin_segment_storage, Flow_in_great_lakes, & + & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Flow_terminus, & + & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, & + & Stage_ts, Stage_ante, Seg_bankflow, Seg_slope, Basin_bankflow, Bankst_seep_rate, & + & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, Basin_ripflow, & + & Basin_bankst_seep_rate, Basin_bankflow, Basin_bankst_seep, Basin_bankst_vol, & + & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_seep, Basin_ripst_evap, & + & Basin_ripst_vol, Bankst_seep_rate + USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt + USE PRMS_SRUNOFF, ONLY: Basin_sroff + USE PRMS_GWFLOW, ONLY: Basin_gwflow +! mizuroute specific modules + USE nrtype ! variable types, etc. + USE reachparam ! reach parameters + USE reachstate ! reach states + USE reach_flux ! fluxes in each reach + USE lake_param ! lake parameters + USE lakes_flux ! fluxes in each lake + USE kwt_route,only:qroute_rch ! route kinematic waves through the river network + + IMPLICIT NONE +! Functions + INTRINSIC MOD + EXTERNAL comp_bank_storage, drain_the_swamp +! Local Variables + INTEGER :: i, j, segtype, ilake, toseg + DOUBLE PRECISION :: area_fac, segout +!*********************************************************************** + mizuroute_run = 0 + +! compute the time-delay histogram (to route runoff within basins) + allocate(FRAC_FUTURE(1), stat=ierr) + FRAC_FUTURE(1) = 0.d0 + !call qtimedelay(dt, fshape, tscale, ierr, cmessage) + !call handle_err(ierr, cmessage) + +! ***** +! Prepare for the routing simulations... +! ******************************************* +! allocate space for the simulated runoff at the HRUs + + ! initialize the time-delay histogram + do iens=1,nens + do ibas=1,nSegRoute + ! allocate space for the delayed runoff + allocate(RCHFLX(iens,ibas)%QFUTURE(size(FRAC_FUTURE)), stat=ierr) + call handle_err(ierr, 'problem allocating space for QFUTURE element') + ! initialize to zeroes + RCHFLX(iens,ibas)%QFUTURE(:) = 0.D0 + end do + end do + + + ! define flags + !LAKEFLAG=0 ! no lakes in the river network, but putting in fake ones to add in observed streamflow + ! FIX: HOW DO WE DEAL WITH LAKES HERE, USE MUSKINGUM?? + + ! define time + T1 = T0+Timestep_seconds + +! ***** +! Perform the routing... +! ************************** + iTime=1 + + ! loop through ensemble members + do iens=1,nens + ! Interpolate simulated runoff to local basins... + do ibas=1,nSegRoute + RCHFLX(iens,ibas)%BASIN_QI = DBLE(Seg_lateral_inflow(NETOPO(ibas)%REACHID)*CFS2CMS_CONV) + end do ! (looping through basins) + !print*,'RCHFLX(iens,:)%BASIN_QI = ',RCHFLX(iens,:)%BASIN_QI! + + ! ***** + ! FIX ZERO OUT Delay runoff within local basins... IS THIS RIGHT?? + ! **************************************** + ! route streamflow through the basin + do ibas=1,nSegRoute ! place a fraction of runoff in future time steps + RCHFLX(iens,ibas)%QFUTURE(1) = RCHFLX(iens,ibas)%BASIN_QI + ! save the routed runoff + RCHFLX(iens,ibas)%BASIN_QR(0) = RCHFLX(iens,ibas)%BASIN_QR(1) ! (save the runoff from the previous time step) !CUT? + RCHFLX(iens,ibas)%BASIN_QR(1) = RCHFLX(iens,ibas)%QFUTURE(1) + RCHFLX(iens,ibas)%QFUTURE(1) = 0.D0 + end do ! (looping through basins) + + ! ***** + ! Replace streamflow at segments if needed + ! water-use removed/added in routing module + ! FIX DEAL WITH GAINING STREAMS will happen in depression storage type module + ! ************************************************** + ilake = 0 + DO iSeg = 1, nSegRoute + IF ( Obsin_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is outlet of lake with known 'lake' flow coming into reach + ilake= ilake+1 + LAKFLX(iens,ilake)%LAKE_Q = DBLE((Streamflow_cfs(Obsin_segment(NETOPO(iSeg)%REACHID))+Seg_lateral_inflow(NETOPO(iSeg)%REACHID))*CFS2CMS_CONV) + ENDIF + IF ( Obsout_segment(NETOPO(iSeg)%REACHID)>0 ) THEN !like reach is inlet of lake with known 'lake' flow coming into reach + ilake= ilake+1 + LAKFLX(iens,ilake)%LAKE_Q = DBLE(Streamflow_cfs(Obsout_segment(NETOPO(iSeg)%REACHID))*CFS2CMS_CONV) + ENDIF + ENDDO + + ! ***** + ! Compute total instantaneous runoff from all upstream basins... + ! ******************************************************************* + ! compute the sum of all upstream runoff at each point in the river network + do iSeg=1,nSegRoute + ! identify how many reaches are upstream + nUpstream = size(NETOPO(iSeg)%RCHLIST) + ! allocate space for upstream vectors + allocate(iUpstream(nUpstream), qUpstream(nUpstream), stat=ierr) + if(ierr/=0) call handle_err(ierr,'problem allocating vectors for all upstream basins') + ! get indices for all reaches upstream + iUpstream = NETOPO(iSeg)%RCHLIST(1:nUpstream) + ! get streamflow for all reaches upstream + qUpstream = RCHFLX(iens,iUpstream(1:nUpstream))%BASIN_QR(1) + ! get mean streamflow + RCHFLX(IENS,iSeg)%UPSTREAM_QI = sum(qUpstream) + ! test + if(NETOPO(iSeg)%REACHID == ixPrint)then + print*, 'ixUpstream = ', NETOPO(iUpstream(1:nUpstream))%REACHIX + print*, 'idUpstream = ', NETOPO(iUpstream(1:nUpstream))%REACHID + print*, 'qUpstream = ', qUpstream + endif + ! deallocate space for upstream vectors + deallocate(iUpstream,qUpstream, stat=ierr) + if(ierr/=0) call handle_err(ierr,'problem deallocating vectors for all upstream basins') + end do ! looping through stream segments + + ! ***** + ! Route streamflow through the river network... + ! ************************************************** + Seg_inflow = 0.0D0 + Seg_outflow = 0.0D0 + Seg_upstream_inflow = 0.0D0 + IF ( Ripst_flag==1 ) Stage_ante =Stage_ts + if (doKWTroute) then + RPARAM(:)%R_WIDTH = DBLE(Seg_width) ! channel width (m) + RPARAM(:)%R_MAN_N = DBLE(Mann_n) ! Manning's "n" paramater (unitless) + + ! route streamflow through the river network + do iSeg=1,nSegRoute + ! identify reach to process + irch = NETOPO(iSeg)%RHORDER + !print*, 'irch, ixDesire = ', irch, ixDesire + ! route kinematic waves through the river network + CALL QROUTE_RCH(IENS,irch, & ! input: array indices + ixDesire, & ! input: index of the outlet reach + T0,T1, & ! input: start and end of the time step + LAKEFLAG, & ! input: flag if lakes are to be processed + ierr,cmessage) ! output: error control + call handle_err(ierr,cmessage) + !if(iRch==5) pause 'finished stream segment' + end do ! (looping through stream segments) + Seg_outflow(NETOPO(:)%REACHID)= RCHFLX(iens,:)%REACH_Q/CFS2CMS_CONV + + DO iSeg=1,nSegRoute + irch = NETOPO(iSeg)%RHORDER + toseg = Tosegment(irch) + IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Seg_outflow(irch) + ENDDO + Seg_inflow(NETOPO(:)%REACHID) = Seg_lateral_inflow(NETOPO(:)%REACHID) + & + & Seg_upstream_inflow(NETOPO(:)%REACHID) + + + Outflow_ts(NETOPO(:)%REACHID)= RCHFLX(iens,:)%REACH_Q/CFS2CMS_CONV + end if + end do ! (looping through ensemble members) + + ! for stage estimate + IF ( Ripst_flag==1 ) THEN + Basin_bankst_seep = 0.D0 + Basin_bankst_seep_rate = 0.0D0 + Basin_bankst_head = 0.0D0 + Basin_bankst_vol = 0.0D0 + Basin_ripst_area = 0.0D0 + Basin_ripst_seep = 0.0D0 + Basin_ripst_evap = 0.0D0 + Basin_ripst_vol = 0.0D0 + Bankst_seep_rate = 0.0 !collect by segment that HRUs go to + Seg_bankflow = 0.0D0 !collect by segment that HRUs go to + DO i = 1, Nsegment + Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & + & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + IF (Stage_ts(i)>250.) Stage_ts(i) = 250. + ENDDO + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) & + & CALL comp_bank_storage(i) +! ******Compute the bank storage component +! transfers water between separate bank storage and stream depending on seepage + ENDDO + Basin_bankst_seep = Basin_bankst_seep*Basin_area_inv + Basin_bankst_head = Basin_bankst_head*Basin_area_inv + Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv + DO i = 1, Nsegment + Basin_bankst_seep_rate = Basin_bankst_seep_rate + Bankst_seep_rate(i) & + & *Seg_length(i)/SUM(Seg_length) !m2/day per stream ft length + Seg_outflow(i) = Seg_outflow(i)+Seg_bankflow(i) + IF (Seg_bankflow(i) < 0.0) THEN ! only could go negative because of bankflow if is negative + IF (Seg_outflow(i) < 0.0) THEN ! took out more than streamflow, this could also be a water_use problem + Seg_bankflow(i) = Seg_bankflow(i) - Seg_outflow(i) + Seg_outflow(i) = 0.0 + ENDIF + ENDIF + ENDDO + Bankst_seep_rate = 0.0 !collect by segment that HRUs go to + Seg_ripflow = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_segment(i)>0 .AND. Ripst_areafr_max(i)>0.0) & + & CALL drain_the_swamp(i) +! ******Compute the overbank riparian storage component +! transfers water between separate riparian storage and stream depending on seepage + ENDDO + Basin_ripst_seep = Basin_ripst_seep*Basin_area_inv + Basin_ripst_evap = Basin_ripst_evap*Basin_area_inv + Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv + DO i = 1, Nsegment + Seg_outflow(i) = Seg_outflow(i)+Seg_ripflow(i) ! cannot go negative by design + Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & + & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + IF (Stage_ts(i)>250.) Stage_ts(i) = 250. + ENDDO + ENDIF + + T0 = T1 + + Basin_segment_storage = 0.0D0 + Basin_bankflow = 0.0D0 + Basin_ripflow = 0.0D0 + Flow_out = 0.0D0 + Flow_to_lakes = 0.0D0 + Flow_to_ocean = 0.0D0 + Flow_to_great_lakes = 0.0D0 + Flow_out_region = 0.0D0 + Flow_out_NHM = 0.0D0 + Flow_in_region = 0.0D0 + Flow_terminus = 0.0D0 + Flow_in_nation = 0.0D0 + Flow_headwater = 0.0D0 + Flow_in_great_lakes = 0.0D0 + Flow_replacement = 0.0D0 + DO i = 1, Nsegment + segtype = Segment_type(i) + segout = Seg_outflow(i) +! Flow_out is the total flow out of the basin, which allows for multiple outlets +! includes closed basins (tosegment=0) + IF ( segtype==1 ) THEN + Flow_headwater = Flow_headwater + segout + ELSEIF ( segtype==2 ) THEN + Flow_to_lakes = Flow_to_lakes + segout + ELSEIF ( segtype==3 ) THEN + Flow_replacement = Flow_replacement + segout + ELSEIF ( segtype==4 ) THEN + Flow_in_nation = Flow_in_nation + segout + ELSEIF ( segtype==5 ) THEN + Flow_out_NHM = Flow_out_NHM + segout + ELSEIF ( segtype==6 ) THEN + Flow_in_region = Flow_in_region + segout + ELSEIF ( segtype==7 ) THEN + Flow_out_region = Flow_out_region + segout + ELSEIF ( segtype==8 ) THEN + Flow_to_ocean = Flow_to_ocean + segout + ELSEIF ( segtype==9 ) THEN + Flow_terminus = Flow_terminus + segout + ELSEIF ( segtype==10 ) THEN + Flow_in_great_lakes = Flow_in_great_lakes + segout + ELSEIF ( segtype==11 ) THEN + Flow_to_great_lakes = Flow_to_great_lakes + segout + ENDIF + IF ( Tosegment(i)==0 ) Flow_out = Flow_out + segout + + Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout +! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) + Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) + IF ( Ripst_flag==1 ) THEN + Basin_bankflow = Basin_bankflow + Seg_bankflow(i) + Basin_ripflow = Basin_ripflow + Seg_ripflow(i) + ENDIF + ENDDO + + area_fac = Cfs_conv/Basin_area_inv + Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows + Basin_cfs = Flow_out + Basin_stflow_out = Basin_cfs / area_fac + Basin_cms = Basin_cfs*CFS2CMS_CONV + IF ( Glacier_flag==1 ) THEN + Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt + Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac + Basin_gl_cfs = Basin_gl_top_melt*area_fac + ENDIF + Basin_sroff_cfs = Basin_sroff*area_fac + Basin_ssflow_cfs = Basin_ssflow*area_fac + Basin_gwflow_cfs = Basin_gwflow*area_fac + Basin_segment_storage = Basin_segment_storage/area_fac + IF ( Ripst_flag==1 ) THEN + Basin_bankflow = Basin_bankflow/area_fac + Basin_ripflow = Basin_ripflow/area_fac + ENDIF + + END FUNCTION mizuroute_run + +!*********************************************************************** + subroutine handle_err(err,message) + ! handle error codes + implicit none + integer,intent(in)::err ! error code + character(*),intent(in)::message ! error message + if(err/=0)then + print*,'FATAL ERROR: '//trim(message) + stop + endif + end subroutine handle_err + +!*********************************************************************** +! mizuroute_restart - write or read restart file +!*********************************************************************** + SUBROUTINE mizuroute_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_MIZUROUTE + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + ! Function + EXTERNAL :: check_restart + ! Local Variable + CHARACTER(LEN=9) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Outflow_ts + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Outflow_ts + ENDIF + END SUBROUTINE mizuroute_restart diff --git a/prmsRip/muskingumRip.f90 b/prmsRip/muskingumRip.f90 new file mode 100644 index 00000000..61035381 --- /dev/null +++ b/prmsRip/muskingumRip.f90 @@ -0,0 +1,473 @@ +!*********************************************************************** +! Routes water between segments in the system using Muskingum routing +! +! The Muskingum equation is described in 'Hydrology for Engineers', 3rd ed. +! by Linsley, R.K, Kohler, M.A., and Paulhus, J.L.H., 1982 p. 275 and in +! 'Water in Environmental Planning' by Dunne, T., and Leopold, L.B. 1978 +! p. 357. +! +! Note that the Muskingum equation assumes a linear relation of storage +! to the inflow/outflow relation and therefore the relation is the same +! throughout the range of the hydrograph. The route_time parameter in +! the fixroute module is replaced by two new parameters, K_coef and +! x_coef, which are described below: +! +! The Muskingum method is based on the equation: S = K[xI + (1 - x)O] +! where S is storage, K is the storage coefficient, x is a coefficient +! between 0 and .5, I is inflow, and O is outflow. +! +! Solving for the outflow at day 2,O2; and knowing the inflow at day 1, +! I1; the inflow at day 2,I2; and the outflow at day 1, O1; the storage +! equation can be written as follows: +! +! O2 = czero*I2 + cone*I1 + ctwo*O1 +! +! where czero = -((Kx - 12) / (K - Kx + 12)) +! cone = (Kx + 12) / (K - Kx + 12) +! ctwo = (K - Kx - 12) / (K - Kx + 12) +! +! assuming a time step of one day and K is in units of hours +! +! This module is based on the "musroute.f" module. It differs in three +! basic ways: +! +! 1. This module uses an internal routing time step of one hour. +! The old muskingum module ran on the same daily time step as +! the rest of PRMS. The problem with this is that there is no +! ability to distinguish where the flood wave (front of the flow +! change) within the segment. For example, if there is a series +! of 4 1-day long segments, a flood wave will make it to the bottom +! of these in 1 day. If the same system is modeled as 1 4-day long +! segment, it will take 4 days. +! +! 2. The X parameter has been removed as a specified input and is now computed. To +! my knowledge, no modeler had ever set this to anything other than the default +! value (0.2) anyway. Always using the default value can lead to problems +! with the C coffecients which can result in mass balance problems or negative +! flow values. +! +! To solve this problem, I assume that the C coefficients must +! always be between 0 and 1. By setting the C coefficients equal to 0 and 1, +! various limits on the time step (ts), X, and K can be determined. There are +! two of these limits which are of interest: +! +! When C0 = 0: +! ts +! K = ----- +! 2X +! +! When C2 = 0: +! ts +! K = ----- +! 2(1-X) +! +! Determining a value of K half way between these two limits (by averaging) +! and solving for X using the quadratic formula results in: +! +! 1-sqrt(1-(ts/K)) +! X = ------------------ +! 2 +! +! So when ts is fixed at one hour and K is fixed as the average (or expected) +! travel time corresponding to the segment (for each segment in the stream +! network), a value of X can be computed (for each segment in the stream +! network) which will result in both conservation of mass and non-negative +! flows. Another benefit is that only one input parameter (K) needs to be +! input to the module. +! +! 3. If the travel time of a segment is less than or equal to the routing +! time step (one hour), then the outflow of the segment is set to the +! value of the inflow. +! +!*********************************************************************** + MODULE PRMS_MUSKINGUM + IMPLICIT NONE +! Local Variables + DOUBLE PRECISION, PARAMETER :: ONE_24TH = 1.0D0 / 24.0D0 + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Currinsum(:), Pastin(:), Pastout(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:), Inflow_ts(:) + CHARACTER(LEN=14), SAVE :: MODNAME + END MODULE PRMS_MUSKINGUM + +!*********************************************************************** +! Main muskingum routine +!*********************************************************************** + INTEGER FUNCTION muskingum() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: muskingum_decl, muskingum_init, muskingum_run + EXTERNAL :: muskingum_restart +!*********************************************************************** + muskingum = 0 + + IF ( Process(:3)=='run' ) THEN + muskingum = muskingum_run() + ELSEIF ( Process(:4)=='decl' ) THEN + muskingum = muskingum_decl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL muskingum_restart(1) + muskingum = muskingum_init() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL muskingum_restart(0) + ENDIF + + END FUNCTION muskingum + +!*********************************************************************** +! muskingum_decl - Declare parameters and variables and allocate arrays +! Declared Parameters +! tosegment, hru_segment, obsin_segment, K_coef, x_coef +!*********************************************************************** + INTEGER FUNCTION muskingum_decl() + USE PRMS_MUSKINGUM + USE PRMS_MODULE, ONLY: Nsegment, Strmflow_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_muskingum +!*********************************************************************** + muskingum_decl = 0 + + Version_muskingum = 'muskingum.f90 2019-06-05 17:18:00Z' + IF ( Strmflow_flag==4 ) THEN + MODNAME = 'muskingum' + ELSE + MODNAME = 'muskingum_mann' + ENDIF + CALL print_module(Version_muskingum, 'Streamflow Routing ', 90) + + ALLOCATE ( Currinsum(Nsegment) ) + ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) ) + ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) ) + + END FUNCTION muskingum_decl + +!*********************************************************************** +! muskingum_init - Get and check parameter values and initialize variables +!*********************************************************************** + INTEGER FUNCTION muskingum_init() + USE PRMS_MUSKINGUM + USE PRMS_MODULE, ONLY: Nsegment + USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv + USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_ROUTING, ONLY: Basin_segment_storage + IMPLICIT NONE +! Functions + EXTERNAL :: read_error + INTEGER, EXTERNAL :: getparam +! Local Variables + INTEGER :: i +!*********************************************************************** + muskingum_init = 0 + + !Seg_outflow will have been initialized to Segment_flow_init in PRMS_ROUTING + Basin_segment_storage = 0.0D0 + DO i = 1, Nsegment + Basin_segment_storage = Basin_segment_storage + Seg_outflow(i) + ENDDO + Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv + + END FUNCTION muskingum_init + +!*********************************************************************** +! muskingum_run - Compute routing summary values +!*********************************************************************** + INTEGER FUNCTION muskingum_run() + USE PRMS_MUSKINGUM + USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, Active_hrus, Hru_route_order, & + & Basin_gl_cfs, Basin_gl_ice_cfs + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & + & Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, & + & Seg_upstream_inflow, Seg_lateral_inflow, Flow_out + USE PRMS_OBS, ONLY: Streamflow_cfs + USE PRMS_SET_TIME, ONLY: Cfs_conv + USE PRMS_ROUTING, ONLY: Use_transfer_segment, Segment_delta_flow, Basin_segment_storage, & + & Obsin_segment, Segment_order, Tosegment, C0, C1, C2, Ts, Ts_i, Obsout_segment, & + & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Segment_type, Flow_terminus, & + & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes, & + & Flow_in_great_lakes, Stage_ts, Stage_ante, Seg_bankflow, Mann_n, Seg_width, Seg_slope, Basin_bankflow, & + & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, Basin_ripflow, & + & Basin_bankst_seep_rate, Basin_bankflow, Basin_bankst_seep, Basin_bankst_vol, & + & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_seep, Basin_ripst_evap, & + & Basin_ripst_vol, Bankst_seep_rate + USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt + USE PRMS_SRUNOFF, ONLY: Basin_sroff + USE PRMS_GWFLOW, ONLY: Basin_gwflow + IMPLICIT NONE +! Functions + INTRINSIC MOD + EXTERNAL comp_bank_storage, drain_the_swamp +! Local Variables + INTEGER :: i, j, iorder, toseg, imod, tspd, segtype + DOUBLE PRECISION :: area_fac, segout, currin +!*********************************************************************** + muskingum_run = 0 + +! SET yesterdays inflows and outflows into temp (past arrays) +! values may be 0.0 as intial, > 0.0 for runtime and dynamic +! initial condtions. Then set outlfow and inflow for this time +! step to 0.0 +! +! upstream_inflow and outflow will vary by hour +! lateral_inflow and everything else will vary by day +! +! Compute surface runoff, ssflow, and gwflow going to each segment +! This is todays "seg_inflow" before additional water is routed to +! a new (if any is routed) +! +! For each HRU if the lateral flow for this HRU goes to the +! segment being evaluated (segment i) then sum flows +! +! Do these calculations once for the current day, before the hourly +! routing starts. +! +! Out2 = In2*C0 + In1*C1 + Out1*C2 +! Seg_outflow = Seg_inflow*Czero + Pastinflow*Cone + Pastoutflow*Ctwo +! C0, C1, and C2: initialized in the "init" part of this module +! + Pastin = Seg_inflow + Pastout = Seg_outflow + Seg_inflow = 0.0D0 + Seg_outflow = 0.0D0 + Inflow_ts = 0.0D0 + Currinsum = 0.0D0 + IF ( Ripst_flag==1 ) Stage_ante =Stage_ts + +! 24 hourly timesteps per day + DO j = 1, 24 + + Seg_upstream_inflow = 0.0D0 + DO i = 1, Nsegment + iorder = Segment_order(i) + +! current inflow to the segment is the time weighted average of the outflow +! of the upstream segments plus the lateral HRU inflow plus any gains. + currin = Seg_lateral_inflow(iorder) !note, this routes to inlet and mizuroute routes to outlet + IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder)) + currin = currin + Seg_upstream_inflow(iorder) + Seg_inflow(iorder) = Seg_inflow(iorder) + currin + Inflow_ts(iorder) = Inflow_ts(iorder) + currin + Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder) + + ! Check to see if this segment is to be routed on this time step + tspd = Ts_i(iorder) + imod = MOD( j, tspd ) + IF ( imod==0 ) THEN + Inflow_ts(iorder) = (Inflow_ts(iorder) / Ts(iorder)) +! Compute routed streamflow + IF ( Ts_i(iorder)>0 ) THEN +! Muskingum routing equation + Outflow_ts(iorder) = Inflow_ts(iorder)*C0(iorder) + Pastin(iorder)*C1(iorder) + Outflow_ts(iorder)*C2(iorder) + ELSE +! If travel time (K_coef paremter) is less than or equal to +! time step (one hour), then the outflow is equal to the inflow +! Outflow_ts is the value from last hour + Outflow_ts(iorder) = Inflow_ts(iorder) + ENDIF + + ! pastin is equal to the Inflow_ts on the previous routed timestep + Pastin(iorder) = Inflow_ts(iorder) + +! because the upstream inflow from streams is used, reset it to zero so new average +! can be computed next routing timestep. + Inflow_ts(iorder) = 0.0D0 + ENDIF + + IF ( Obsout_segment(iorder)>0 ) Outflow_ts(iorder) = Streamflow_cfs(Obsout_segment(iorder)) + + ! water-use removed/added in routing module + ! check for negative flow + IF ( Outflow_ts(iorder)<0.0 ) THEN + IF ( Use_transfer_segment==1 ) THEN + PRINT *, 'ERROR, transfer(s) from stream segment:', iorder, ' causes outflow to be negative' + PRINT *, ' outflow =', Outflow_ts(iorder), ' must fix water-use stream segment transfer file' + ELSE + PRINT *, 'ERROR, outflow from segment:', iorder, ' is negative:', Outflow_ts(iorder) + PRINT *, ' routing parameters may be invalid' + ENDIF + STOP + ENDIF + + ! Seg_outflow (the mean daily flow rate for each segment) will be the average of the hourly values. + Seg_outflow(iorder) = Seg_outflow(iorder) + Outflow_ts(iorder) + ! pastout is equal to the Inflow_ts on the previous routed timestep + Pastout(iorder) = Outflow_ts(iorder) + +! Add current timestep's flow rate to sum the upstream flow rates. +! This can be thought of as a volume because it is a volumetric rate +! (cubic feet per second) over a time step of an hour. Down below when +! this value is used, it will be divided by the number of hours in the +! segment's simulation time step, giving the mean flow rate over that +! period of time. + toseg = Tosegment(iorder) + IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Outflow_ts(iorder) + + ENDDO ! segment + + ENDDO ! timestep + + DO i = 1, Nsegment + Seg_outflow(i) = Seg_outflow(i) * ONE_24TH + ENDDO + ! for stage estimate + IF ( Ripst_flag==1 ) THEN + Basin_bankst_seep = 0.D0 + Basin_bankst_seep_rate = 0.0D0 + Basin_bankst_head = 0.0D0 + Basin_bankst_vol = 0.0D0 + Basin_ripst_area = 0.0D0 + Basin_ripst_seep = 0.0D0 + Basin_ripst_evap = 0.0D0 + Basin_ripst_vol = 0.0D0 + Bankst_seep_rate = 0.0 !collect by segment that HRUs go to + Seg_bankflow = 0.0D0 !collect by segment that HRUs go to + DO i = 1, Nsegment + Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & + & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + IF (Stage_ts(i)>250.) Stage_ts(i) = 250. + ENDDO + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) & + & CALL comp_bank_storage(i) +! ******Compute the bank storage component +! transfers water between separate bank storage and stream depending on seepage + ENDDO + Basin_bankst_seep = Basin_bankst_seep*Basin_area_inv + Basin_bankst_head = Basin_bankst_head*Basin_area_inv + Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv + DO i = 1, Nsegment + Basin_bankst_seep_rate = Basin_bankst_seep_rate + Bankst_seep_rate(i) & + & *Seg_length(i)/SUM(Seg_length) !m2/day per stream ft length + Seg_outflow(i) = Seg_outflow(i)+Seg_bankflow(i) + IF (Seg_bankflow(i) < 0.0) THEN ! only could go negative because of bankflow if is negative + IF (Seg_outflow(i) < 0.0) THEN ! took out more than streamflow, this could also be a water_use problem + Seg_bankflow(i) = Seg_bankflow(i) - Seg_outflow(i) + Seg_outflow(i) = 0.0 + ENDIF + ENDIF + ENDDO + Bankst_seep_rate = 0.0 !collect by segment that HRUs go to + Seg_ripflow = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Hru_segment(i)>0 .AND. Ripst_areafr_max(i)>0.0) & + & CALL drain_the_swamp(i) +! ******Compute the overbank riparian storage component +! transfers water between separate riparian storage and stream depending on seepage + ENDDO + Basin_ripst_seep = Basin_ripst_seep*Basin_area_inv + Basin_ripst_evap = Basin_ripst_evap*Basin_area_inv + Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv + DO i = 1, Nsegment + Seg_outflow(i) = Seg_outflow(i)+Seg_ripflow(i) ! cannot go negative by design + Stage_ts(i) = ( Seg_outflow(i)*CFS2CMS_CONV & + & *Mann_n(i)/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + IF (Stage_ts(i)>250.) Stage_ts(i) = 250. + ENDDO + ENDIF + + Basin_segment_storage = 0.0D0 + Basin_bankflow = 0.0D0 + Basin_ripflow = 0.0D0 + Flow_out = 0.0D0 + Flow_to_lakes = 0.0D0 + Flow_to_ocean = 0.0D0 + Flow_to_great_lakes = 0.0D0 + Flow_out_region = 0.0D0 + Flow_out_NHM = 0.0D0 + Flow_in_region = 0.0D0 + Flow_terminus = 0.0D0 + Flow_in_nation = 0.0D0 + Flow_headwater = 0.0D0 + Flow_in_great_lakes = 0.0D0 + Flow_replacement = 0.0D0 + DO i = 1, Nsegment + segtype = Segment_type(i) + Seg_inflow(i) = Seg_inflow(i) * ONE_24TH + Seg_upstream_inflow(i) = Currinsum(i) * ONE_24TH + segout = Seg_outflow(i) +! Flow_out is the total flow out of the basin, which allows for multiple outlets +! includes closed basins (tosegment=0) + IF ( segtype==1 ) THEN + Flow_headwater = Flow_headwater + segout + ELSEIF ( segtype==2 ) THEN + Flow_to_lakes = Flow_to_lakes + segout + ELSEIF ( segtype==3 ) THEN + Flow_replacement = Flow_replacement + segout + ELSEIF ( segtype==4 ) THEN + Flow_in_nation = Flow_in_nation + segout + ELSEIF ( segtype==5 ) THEN + Flow_out_NHM = Flow_out_NHM + segout + ELSEIF ( segtype==6 ) THEN + Flow_in_region = Flow_in_region + segout + ELSEIF ( segtype==7 ) THEN + Flow_out_region = Flow_out_region + segout + ELSEIF ( segtype==8 ) THEN + Flow_to_ocean = Flow_to_ocean + segout + ELSEIF ( segtype==9 ) THEN + Flow_terminus = Flow_terminus + segout + ELSEIF ( segtype==10 ) THEN + Flow_in_great_lakes = Flow_in_great_lakes + segout + ELSEIF ( segtype==11 ) THEN + Flow_to_great_lakes = Flow_to_great_lakes + segout + ENDIF + IF ( Tosegment(i)==0 ) Flow_out = Flow_out + segout + Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout +! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) + Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) + IF ( Ripst_flag==1 ) THEN + Basin_bankflow = Basin_bankflow + Seg_bankflow(i) + Basin_ripflow = Basin_ripflow + Seg_ripflow(i) + ENDIF + ENDDO + + area_fac = Cfs_conv/Basin_area_inv + Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to basin_stflow_out if replacement flows + Basin_cfs = Flow_out + Basin_stflow_out = Basin_cfs / area_fac + Basin_cms = Basin_cfs*CFS2CMS_CONV + IF ( Glacier_flag==1 ) THEN + Basin_stflow_in = Basin_stflow_in + Basin_gl_top_melt + Basin_gl_ice_cfs = Basin_gl_ice_melt*area_fac + Basin_gl_cfs = Basin_gl_top_melt*area_fac + ENDIF + Basin_sroff_cfs = Basin_sroff*area_fac + Basin_ssflow_cfs = Basin_ssflow*area_fac + Basin_gwflow_cfs = Basin_gwflow*area_fac + Basin_segment_storage = Basin_segment_storage/area_fac + IF ( Ripst_flag==1 ) THEN + Basin_bankflow = Basin_bankflow/area_fac + Basin_ripflow = Basin_ripflow/area_fac + ENDIF + + END FUNCTION muskingum_run + +!*********************************************************************** +! muskingum_restart - write or read restart file +!*********************************************************************** + SUBROUTINE muskingum_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit + USE PRMS_MUSKINGUM + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + ! Function + EXTERNAL :: check_restart + ! Local Variable + CHARACTER(LEN=9) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Outflow_ts + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Outflow_ts + ENDIF + END SUBROUTINE muskingum_restart diff --git a/prmsRip/routingRip.f90 b/prmsRip/routingRip.f90 new file mode 100644 index 00000000..ff638dd6 --- /dev/null +++ b/prmsRip/routingRip.f90 @@ -0,0 +1,1575 @@ +!*********************************************************************** +! Defines stream and lake routing parameters and variables +!*********************************************************************** + MODULE PRMS_ROUTING + IMPLICIT NONE +! Local Variables + CHARACTER(LEN=7), SAVE :: MODNAME + DOUBLE PRECISION, SAVE :: Cfs2acft + DOUBLE PRECISION, SAVE :: Segment_area + INTEGER, SAVE :: Use_transfer_segment, Noarea_flag, Hru_seg_cascades + INTEGER, SAVE, ALLOCATABLE :: Segment_order(:), Segment_up(:), Seg_hru_num(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Segment_hruarea(:) + CHARACTER(LEN=80), SAVE :: Version_routing + !CHARACTER(LEN=32), SAVE :: Outfmt + INTEGER, SAVE, ALLOCATABLE :: Ts_i(:) + REAL, SAVE, ALLOCATABLE :: Ts(:), C0(:), C1(:), C2(:) + REAL, SAVE, ALLOCATABLE :: Ripst_area_max(:), Ripst_area(:), Ripst_depth(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_vol_max(:) +! Declared Variables + DOUBLE PRECISION, SAVE :: Basin_segment_storage + DOUBLE PRECISION, SAVE :: Flow_to_lakes, Flow_to_ocean, Flow_to_great_lakes, Flow_out_region + DOUBLE PRECISION, SAVE :: Flow_in_region, Flow_in_nation, Flow_headwater, Flow_out_NHM + DOUBLE PRECISION, SAVE :: Flow_in_great_lakes, Flow_replacement, Flow_terminus + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seginc_ssflow(:), Seginc_sroff(:), Segment_delta_flow(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Seginc_gwflow(:), Seginc_swrad(:), Seginc_potet(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_outflow(:), Seg_ssflow(:), Seg_sroff(:), Seg_gwflow(:) +! Declared Parameters + INTEGER, SAVE, ALLOCATABLE :: Segment_type(:), Tosegment(:), Hru_segment(:), Obsin_segment(:), Obsout_segment(:) + REAL, SAVE, ALLOCATABLE :: Seg_depth(:), K_coef(:), X_coef(:), Mann_n(:), Seg_width(:), Segment_flow_init(:) + REAL, SAVE, ALLOCATABLE :: Seg_length(:), Seg_slope(:) +! Declared Parameters for Overbank and bank Storage + REAL, SAVE, ALLOCATABLE :: Transmiss_seg(:), Ripst_areafr_max(:) +! Declared Parameters for Overbank Storage + REAL, SAVE, ALLOCATABLE :: Tr_ratio(:), Porosity_seg(:), Ripst_et_coef(:), Ripst_frac_init(:) +! Declared Variables for Overbank Storage + DOUBLE PRECISION, SAVE :: Basin_ripst_evap, Basin_ripst_seep, Basin_ripflow, Basin_ripst_vol, Basin_ripst_area + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_stor_hru(:), Ripst_seep_hru(:), Ripst_vol(:), Seg_ripflow(:) + REAL, SAVE, ALLOCATABLE :: Ripst_evap_hru(:), Ripst_frac(:) +! Declared Parameters for Bank Storage + REAL, SAVE, ALLOCATABLE :: Specyield_seg(:), Bankst_head_init(:) + INTEGER, SAVE, ALLOCATABLE :: Bankfinite_hru(:) +! Declared Variables for Bank Storage + DOUBLE PRECISION, SAVE :: Basin_bankst_head, Basin_bankst_seep_rate, Basin_bankflow + DOUBLE PRECISION, SAVE :: Basin_bankst_seep, Basin_bankst_vol, Basin_bankst_area + REAL, SAVE, ALLOCATABLE :: Bankst_head(:), Bankst_seep_rate(:), Bankst_seep_hru(:) + REAL, SAVE, ALLOCATABLE :: Bankst_stor_hru(:), Bankst_head_pts(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Stage_ante(:), Stage_ts(:), Seg_bankflow(:) + END MODULE PRMS_ROUTING + +!*********************************************************************** +! Main routing routine +!*********************************************************************** + INTEGER FUNCTION routing() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: routingdecl, routinginit, route_run + EXTERNAL :: routing_restart +!*********************************************************************** + routing = 0 + + IF ( Process(:3)=='run' ) THEN + routing = route_run() + ELSEIF ( Process(:4)=='decl' ) THEN + routing = routingdecl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL routing_restart(1) + routing = routinginit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL routing_restart(0) + ENDIF + + END FUNCTION routing + +!*********************************************************************** +! routingdecl - set up parameters +!*********************************************************************** + INTEGER FUNCTION routingdecl() + USE PRMS_ROUTING + USE PRMS_MODULE, ONLY: Nhru, Nsegment, Model, Strmflow_flag, Cascade_flag, & + & Ripst_flag, Stream_temp_flag, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar + EXTERNAL read_error, print_module +!*********************************************************************** + routingdecl = 0 + + Version_routing = 'routing.f90 2019-06-05 17:22:00Z' + CALL print_module(Version_routing, 'Routing Initialization ', 90) + MODNAME = 'routing' + +! Declared Variables + ALLOCATE ( Hru_outflow(Nhru) ) + IF ( declvar(MODNAME, 'hru_outflow', 'nhru', Nhru, 'double', & + & 'Total flow leaving each HRU', & + & 'cfs', Hru_outflow)/=0 ) CALL read_error(3, 'hru_outflow') + + IF ( declvar(MODNAME, 'flow_to_lakes', 'one', 1, 'double', & + & 'Total flow to lakes (segment_type=2)', & + & 'cfs', Flow_to_lakes)/=0 ) CALL read_error(3, 'flow_to_lakes') + + IF ( declvar(MODNAME, 'flow_terminus', 'one', 1, 'double', & + & 'Total flow to terminus segments (segment_type=9)', & + & 'cfs', Flow_terminus)/=0 ) CALL read_error(3, 'flow_terminus') + + IF ( declvar(MODNAME, 'flow_to_ocean', 'one', 1, 'double', & + & 'Total flow to oceans (segment_type=8)', & + & 'cfs', Flow_to_ocean)/=0 ) CALL read_error(3, 'flow_to_ocean') + + IF ( declvar(MODNAME, 'flow_to_great_lakes', 'one', 1, 'double', & + & 'Total flow to Great Lakes (segment_type=11)', & + & 'cfs', Flow_to_great_lakes)/=0 ) CALL read_error(3, 'Flow_to_great_lakes') + + IF ( declvar(MODNAME, 'flow_out_region', 'one', 1, 'double', & + & 'Total flow out of region (segment_type=7)', & + & 'cfs', Flow_out_region)/=0 ) CALL read_error(3, 'flow_out_region') + + IF ( declvar(MODNAME, 'flow_out_NHM', 'one', 1, 'double', & + & 'Total flow out of model domain to Mexico or Canada (segment_type=5)', & + & 'cfs', Flow_out_NHM)/=0 ) CALL read_error(3, 'flow_out_NHM') + + IF ( declvar(MODNAME, 'flow_in_region', 'one', 1, 'double', & + & 'Total flow into region (segment_type=6)', & + & 'cfs', Flow_in_region)/=0 ) CALL read_error(3, 'flow_in_region') + + IF ( declvar(MODNAME, 'flow_in_nation', 'one', 1, 'double', & + & 'Total flow into model domain from Mexico or Canada (segment_type=4)', & + & 'cfs', Flow_in_nation)/=0 ) CALL read_error(3, 'flow_in_nation') + + IF ( declvar(MODNAME, 'flow_headwater', 'one', 1, 'double', & + & 'Total flow out of headwater segments (segment_type=1)', & + & 'cfs', Flow_headwater)/=0 ) CALL read_error(3, 'flow_headwater') + + IF ( declvar(MODNAME, 'flow_in_great_lakes', 'one', 1, 'double', & + & 'Total flow out into model domain from Great Lakes (segment_type=10)', & + & 'cfs', Flow_in_great_lakes)/=0 ) CALL read_error(3, 'flow_in_great_lakes') + + IF ( declvar(MODNAME, 'flow_replacement', 'one', 1, 'double', & + & 'Total flow out from replacement flow (segment_type=3)', & + & 'cfs', Flow_replacement)/=0 ) CALL read_error(3, 'flow_replacement') + + ! 0 = normal; 1 = headwater; 2 = lake; 3 = replacement flow; 4 = inbound to nation; + ! 5 = outbound from nation; 6 = inbound to region; 7 = outbound from region; + ! 8 = drains to ocean; 9 = sink (terminus to soil); 10 = inbound from Great Lakes; + ! 11 = outbound to Great Lakes; 12 = ephemeral; + 100 user updated; 1000 user virtual segment + ! 100 = user normal; 101 - 108 = not used; 109 sink (tosegment used by Lumen) + + IF ( Ripst_flag==1 .OR. Model==99 ) THEN +! Overbank storage variables + IF ( declvar(MODNAME, 'basin_ripst_evap', 'one', 1, 'double', & + & 'Basin area-weighted average evaporation from riparian overbank flow storage', & + & 'inches', Basin_ripst_evap)/=0 ) CALL read_error(3, 'basin_ripst_evap') + + IF ( declvar(MODNAME, 'basin_ripst_seep', 'one', 1, 'double', & + & 'Basin area-weighted average seepage from riparian overbank flow storage', & + & 'inches', Basin_ripst_seep)/=0 ) CALL read_error(3, 'basin_ripst_seep') + + IF ( declvar(MODNAME, 'basin_ripst_vol', 'one', 1, 'double', & + & 'Basin area-weighted average storage volume in riparian overbank flow storage', & + & 'inches', Basin_ripst_vol)/=0 ) CALL read_error(3, 'basin_ripst_vol') + + IF ( declvar(MODNAME, 'basin_ripst_area', 'one', 1, 'double', & + & 'Basin area of riparian overbank flow storage', & + & 'acres', Basin_ripst_area)/=0 ) CALL read_error(3, 'basin_ripst_area') + + ALLOCATE ( Seg_ripflow(Nsegment) ) + IF ( declvar(MODNAME, 'seg_ripflow', 'nsegment', Nsegment, 'double', & + & 'Riparian area contribution to streamflow, negative if steam goes overbank', & + & 'cfs', Seg_ripflow)/=0 ) CALL read_error(3, 'seg_ripflow') + + ALLOCATE ( Ripst_stor_hru(Nhru) ) + IF ( declvar(MODNAME, 'ripst_stor_hru', 'nhru', Nhru, 'double', & + & 'Riparian overbank flow storage for each HRU', & + & 'inches', Ripst_stor_hru)/=0 ) CALL read_error(3, 'ripst_stor_hru') + + ALLOCATE ( Ripst_seep_hru(Nhru) ) + IF ( declvar(MODNAME, 'ripst_seep_hru', 'nhru', Nhru, 'double', & + & 'Seepage from riparian overbank flow storage to associated riparian-GWR for each HRU', & + & 'inches', Ripst_seep_hru)/=0 ) CALL read_error(3, 'ripst_seep_hru') + + ALLOCATE ( Ripst_evap_hru(Nhru) ) + IF ( declvar(MODNAME, 'ripst_evap_hru', 'nhru', Nhru, 'real', & + & 'Evaporation from riparian overbank flow storage for each HRU', & + & 'inches', Ripst_evap_hru)/=0 ) CALL read_error(3, 'ripst_evap_hru') + + ALLOCATE ( Ripst_vol(Nhru) ) + IF ( declvar(MODNAME, 'ripst_vol', 'nhru', Nhru, 'double', & + & 'Volume in riparian overbank flow storage for each HRU', & + & 'acre-inches', Ripst_vol)/=0 ) CALL read_error(3, 'ripst_vol') + + ALLOCATE ( Ripst_frac(Nhru) ) + IF ( declvar(MODNAME, 'ripst_frac', 'nhru', Nhru, 'real', & + & 'Volume and area fraction of riparian overbank flow storage of the maximum storage for each HRU', & + & 'decimal fraction', Ripst_frac)/=0 ) CALL read_error(3, 'ripst_frac') + + IF ( declvar(MODNAME, 'basin_ripflow', 'one', 1, 'double', & + & 'Basin riparian area contribution to streamflow, negative if steam goes overbank', & + & 'cfs', Basin_bankflow)/=0 ) CALL read_error(3, 'basin_ripflow') + + ALLOCATE ( Ripst_vol_max(Nhru), Ripst_area(Nhru), Ripst_area_max(Nhru), Ripst_depth(Nhru) ) + ALLOCATE ( Seg_hru_num(Nsegment) ) + +! Bank storage variables + IF ( declvar(MODNAME, 'basin_bankst_head', 'one', 1, 'double', & + & 'Basin bank storage area only area-weighted average head of bank storage above groundwater head', & + & 'meters', Basin_bankst_head)/=0 ) CALL read_error(3, 'basin_bankst_head') + + IF ( declvar(MODNAME, 'basin_bankst_seep', 'one', 1, 'double', & + & 'Basin area-weighted average seepage from bank storage to streams', & + & 'inches', Basin_bankst_seep)/=0 ) CALL read_error(3, 'basin_bankst_seep') + + IF ( declvar(MODNAME, 'basin_bankst_vol', 'one', 1, 'double', & + & 'Basin area-weighted average bank storage', & + & 'inches', Basin_bankst_vol)/=0 ) CALL read_error(3, 'basin_bankst_vol') + + IF ( declvar(MODNAME, 'basin_bankst_area', 'one', 1, 'double', & + & 'Basin area bank storage, if all semi-infinite will be area of basin', & + & 'acres', Basin_bankst_area)/=0 ) CALL read_error(3, 'basin_bankst_area') + + IF ( declvar(MODNAME, 'basin_bankst_seep_rate', 'one', 1, 'double', & + & 'Basin rate of seepage from bank storage into stream per unit length stream', & + & 'meter3/day/meter', Basin_bankst_seep_rate)/=0 ) CALL read_error(3, 'basin_bankst_seep_rate') + + IF ( declvar(MODNAME, 'basin_bankflow', 'one', 1, 'double', & + & 'Basin bank storage contribution to streamflow can be negative if steam losing water', & + & 'cfs', Basin_bankflow)/=0 ) CALL read_error(3, 'basin_bankflow') + + ALLOCATE ( Bankst_head(Nhru) ) + IF ( declvar(MODNAME, 'bankst_head', 'nhru', Nhru, 'real', & + & 'Bank storage area only average head of bank storage above groundwater head', & + & 'meters', Bankst_head)/=0 ) CALL read_error(3, 'bankst_head') + + ALLOCATE ( Seg_bankflow(Nsegment) ) + IF ( declvar(MODNAME, 'seg_bankflow', 'nsegment', Nsegment, 'double', & + & 'Bank storage area contribution to streamflow can be negative if steam losing water', & + & 'cfs', Seg_bankflow)/=0 ) CALL read_error(3, 'seg_bankflow') + + ALLOCATE ( Bankst_head_pts(Nhru) ) + IF ( declvar(MODNAME, 'bankst_head_pts', 'nhru', Nhru, 'real', & + & 'Head of bank storage above groundwater head: at half width away', & + & 'meters', Bankst_head_pts)/=0 ) CALL read_error(3, 'bankst_head_pts') + + ALLOCATE ( Stage_ante(Nsegment) ) + IF ( declvar(MODNAME, 'stage_ante', 'nsegment', Nsegment, 'double', & + & 'Antecedent stage height of segment, estimated with Manning Equation', & + & 'meters', stage_ante)/=0 ) CALL read_error(3, 'stage_ante') + + ALLOCATE ( Stage_ts(Nsegment) ) + IF ( declvar(MODNAME, 'stage_ts', 'nsegment', Nsegment, 'double', & + & 'Stage height of segment, estimated with Manning Equation', & + & 'meters', stage_ts)/=0 ) CALL read_error(3, 'stage_ts') + + ALLOCATE ( Bankst_seep_hru(Nhru) ) + IF ( declvar(MODNAME, 'bankst_seep_hru', 'nhru', Nhru, 'real', & + & 'HRU average seepage from bank storage to associated stream_segment for each HRU', & + & 'inches', Bankst_seep_hru)/=0 ) CALL read_error(3, 'bankst_seep_hru') + + ALLOCATE ( Bankst_stor_hru(Nhru) ) + IF ( declvar(MODNAME, 'bankst_stor_hru', 'nhru', Nhru, 'real', & + & 'HRU average bank storage for each HRU', & + & 'inches', Bankst_stor_hru)/=0 ) CALL read_error(3, 'bankst_stor_hru') + + ALLOCATE ( Bankst_seep_rate(Nsegment) ) + IF ( declvar(MODNAME, 'bankst_seep_rate', 'nsegment', Nsegment, 'real', & + & 'Seepage rate from bank storage into stream per unit length segment', & + & 'meter2/day', Bankst_seep_rate )/=0 ) CALL read_error(1, 'bankst_seep_rate') + + ENDIF + + IF (Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN + ALLOCATE ( Mann_n(Nsegment) ) + IF ( declparam( MODNAME, 'mann_n', 'nsegment', 'real', & + & '0.04', '0.001', '0.15', & + & 'Mannings roughness coefficient', & + & 'Mannings roughness coefficient for each segment', & + & 'dimensionless')/=0 ) CALL read_error(1, 'mann_n') + ENDIF + + IF (Stream_temp_flag==1 .OR. Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN + ALLOCATE ( Seg_slope(Nsegment) ) + IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & + & '0.0001', '0.0000001', '2.0', & + & 'Surface slope of each segment', & + & 'Surface slope of each segment as approximation for bed slope of stream', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'seg_slope') + + ALLOCATE ( Seg_length(Nsegment) ) + IF ( declparam( MODNAME, 'seg_length', 'nsegment', 'real', & + & '1000.0', '0.001', '200000.0', & + & 'Length of each segment', & + & 'Length of each segment, bounds based on CONUS', & + & 'meters')/=0 ) CALL read_error(1, 'seg_length') + ENDIF + + IF (Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Model==99 ) THEN + ALLOCATE ( Seg_width(Nsegment) ) + IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & + & '15.0', '0.18', '40000.0', & + & 'Segment river width', & + & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & + & 'meters')/=0 ) CALL read_error(1, 'seg_width') + ENDIF + + IF (Ripst_flag==1 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN + ALLOCATE ( Seg_depth(Nsegment) ) + IF ( declparam(MODNAME, 'seg_depth', 'nsegment', 'real', & + & '1.0', '0.03', '250.0', & + & 'Segment river depth', & + & 'Segment river depth at bankfull, shallowest from Blackburn-Lynch 2017,'//& + & 'Congo is deepest at 250 m but in the US it is probably the Hudson at 66 m', & + & 'meters')/=0 ) CALL read_error(1, 'seg_depth') + ENDIF + + ALLOCATE ( Segment_type(Nsegment) ) + IF ( declparam(MODNAME, 'segment_type', 'nsegment', 'integer', & + & '0', '0', '111', & + & 'Segment type', & + & 'Segment type (0=segment; 1=headwater; 2=lake; 3=replace inflow; 4=inbound to NHM;'// & + & ' 5=outbound from NHM; 6=inbound to region; 7=outbound from region; 8=drains to ocean;'// & + & ' 9=sink; 10=inbound from Great Lakes; 11=outbound to Great Lakes)', & + & 'none')/=0 ) CALL read_error(1, 'segment_type') + + ! user updated values if different than tosegment_orig + ! -5 = outbound from NHM; -6 = inbound from region; -7 = outbound from region; + ! -8 = drains to ocean; -11 = drains to Great Lake + ALLOCATE ( Tosegment(Nsegment) ) + IF ( declparam(MODNAME, 'tosegment', 'nsegment', 'integer', & + & '0', '-11', '1000000', & + & 'The index of the downstream segment', & + & 'Index of downstream segment to which the segment'// & + & ' streamflow flows, for segments that do not flow to another segment enter 0', & + & 'none')/=0 ) CALL read_error(1, 'tosegment') + + IF ( Cascade_flag==0 .OR. Cascade_flag==2 .OR. Model==99 ) THEN + Hru_seg_cascades = 1 + ALLOCATE ( Hru_segment(Nhru) ) + IF ( declparam(MODNAME, 'hru_segment', 'nhru', 'integer', & + & '0', 'bounded', 'nsegment', & + & 'Segment index for HRU lateral inflows', & + & 'Segment index to which an HRU contributes lateral flows'// & + & ' (surface runoff, interflow, and groundwater discharge)', & + & 'none')/=0 ) CALL read_error(1, 'hru_segment') + ELSE + Hru_seg_cascades = 0 + ENDIF + + ALLOCATE ( Obsin_segment(Nsegment) ) + IF ( declparam(MODNAME, 'obsin_segment', 'nsegment', 'integer', & + & '0', 'bounded', 'nobs', & + & 'Index of measured streamflow station that replaces inflow to a segment', & + & 'Index of measured streamflow station that replaces inflow to a segment', & + & 'none')/=0 ) CALL read_error(1, 'obsin_segment') + + ALLOCATE ( Obsout_segment(Nsegment) ) + IF ( declparam(MODNAME, 'obsout_segment', 'nsegment', 'integer', & + & '0', 'bounded', 'nobs', & + & 'Index of measured streamflow station that replaces outflow from a segment', & + & 'Index of measured streamflow station that replaces outflow from a segment', & + & 'none')/=0 ) CALL read_error(1, 'obsout_segment') + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN + ALLOCATE ( Segment_flow_init(Nsegment) ) + IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', & + & '0.0', '0.0', '1.0E7', & + & 'Initial flow in each stream segment', & + & 'Initial flow in each stream segment', & + & 'cfs')/=0 ) CALL read_error(1, 'segment_flow_init') +! Bank Storage parameters: + IF ( Ripst_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Bankst_head_init(Nhru) ) + IF ( declparam(MODNAME, 'bankst_head_init', 'nhru', 'real', & + & '0.0', '0.0', '1000.0', & + & 'Bank storage area only average initial head of bank storage above groundwater head', & + & 'Bank storage area only average initial head of bank storage above groundwater head', & + & 'meters')/=0 ) CALL read_error(1, 'bankst_head_init') + +! Riparian Overbank Storage parameters: + ALLOCATE ( Ripst_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'ripst_frac_init', 'nhru', 'real', & + & '0.5', '0.0', '1.0', & + & 'Fraction of maximum storage that contains water at the start of a simulation', & + & 'Fraction of maximum riparian overbank flow storage that'// & + & ' contains water at the start of a simulation', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_frac_init') + + ENDIF + ENDIF + + IF ( Ripst_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Ripst_areafr_max(Nhru) ) + IF ( declparam(MODNAME, 'ripst_areafr_max', 'nhru', 'real', & + & '0.1', '0.0', '1.0', & + & 'Surface area fraction of HRU that has possible riparian overbank or bank storage', & + & 'Surface area fraction of HRU that has possible riparian overbank or bank storage;'// & + & ' if =0, then overbank storage is turned off, if also bankfinite_hru =1 bank storage is off', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_areafr_max') + + ALLOCATE ( Porosity_seg(Nsegment) ) + IF ( declparam(MODNAME, 'porosity_seg', 'nsegment', 'real', & + & '0.4', '0.15', '0.75', & + & 'Porosity of soil of riparian overbank flow storage', & + & 'Porosity of soil around segment involved in riparian overbank flow storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'porosity_seg') + + ALLOCATE ( Ripst_et_coef(Nhru) ) + IF ( declparam(MODNAME, 'ripst_et_coef', 'nhru', 'real', & + & '1.0', '0.0', '1.0', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to riparian overbank flow storage', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to riparian overbank flow storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_et_coef') + + ALLOCATE ( Tr_ratio(Nhru) ) + IF ( declparam(MODNAME, 'tr_ratio', 'nhru', 'real', & + & '0.5', '0.0', '1.0', & + & 'Triangle to rectangle ratio describing vertical cross-section'// & + & ' shape of riparian overbank flow storage', & + & 'Triangle to rectangle ratio describing vertical cross-section'// & + & ' shape of riparian overbank flow storage;'// & + & ' 1 is a triangle, 0 is a rectangle', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'tr_ratio') + + ALLOCATE ( Bankfinite_hru(Nhru) ) + IF ( declparam(MODNAME, 'bankfinite_hru', 'nhru', 'integer', & + & '0', '0', '1', & + & 'Bank storage is finite flag', & + & '1 means the bank storage is considered finite and not semi-infinite', & + & 'none')/=0 ) CALL read_error(1, 'bankfinite_hru') + + ALLOCATE ( Transmiss_seg(Nsegment) ) + IF ( declparam(MODNAME, 'transmiss_seg', 'nsegment', 'real', & + & '50.0', '0.00001', '100000', & + & 'Effective transmissivity of groundwater aquifer beneath segment', & + & 'Efective transmissivity of groundwater aquifer beneath segment;'// & + & ' 1.e-8 is unfractured basalt; 10000 is gravel', & + & 'm squared/day')/=0 ) CALL read_error(1, 'transmiss_seg') + + ALLOCATE ( Specyield_seg(Nsegment) ) !Storativity approximated as Specific yield since storativity hard to measure + IF ( declparam(MODNAME, 'specyield_seg', 'nsegment', 'real', & + & '0.2', '0.01', '0.5', & + & 'Volume of water released from storage per unit aquifer surface per unit head decline', & + & 'Volume of water released from storage per unit aquifer surface per unit head decline; '// & + & ' 0.01 is clay; 0.5 is peat', & + & 'none')/=0 ) CALL read_error(1, 'specyield_seg') + +! Not using at moment +! ALLOCATE ( Gwdepth_seg(Nsegment) ) +! IF ( declparam(MODNAME, 'gwdepth_seg', 'nsegment', 'real', & +! & '100.0', '-10.0', '10000.0', & +! & 'Depth to groundwater aquifer beneath segment', & +! & 'Depth to groundwater aquifer beneath segment;'// & +! & ' CONUS goes to ~300 m, but worldwide higher', & +! & 'meters')/=0 ) CALL read_error(1, 'gwdepth_seg') + + ENDIF + + + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Strmflow_flag==7 ) ALLOCATE ( K_coef(Nsegment) ) + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Model==99 ) THEN + IF ( declparam(MODNAME, 'K_coef', 'nsegment', 'real', & + & '1.0', '0.01', '24.0', & + & 'Muskingum storage coefficient', & + & 'Travel time of flood wave from one segment to the next downstream segment,'// & + & ' called the Muskingum storage coefficient; enter 1.0 for reservoirs,'// & + & ' diversions, and segment(s) flowing out of the basin', & + & 'hours')/=0 ) CALL read_error(1, 'K_coef') + ENDIF + + IF ( Strmflow_flag==3 .OR. Strmflow_flag==4 .OR. Strmflow_flag==7 .OR. Model==99 ) THEN + ALLOCATE ( X_coef(Nsegment) ) + IF ( declparam(MODNAME, 'x_coef', 'nsegment', 'real', & + & '0.2', '0.0', '0.5', & + & 'Routing weighting factor', & + & 'The amount of attenuation of the flow wave, called the'// & + & ' Muskingum routing weighting factor; enter 0.0 for'// & + & ' reservoirs, diversions, and segment(s) flowing out of the basin', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'x_coef') + ENDIF + + IF ( Hru_seg_cascades==1 .OR. Model==99 ) THEN + ALLOCATE ( Seginc_potet(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_potet', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average potential ET for each segment'// & + & ' from HRUs contributing flow to the segment', & + & 'inches', Seginc_potet)/=0 ) CALL read_error(3, 'seginc_potet') + + ALLOCATE ( Seginc_swrad(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_swrad', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average solar radiation for each segment'// & + & ' from HRUs contributing flow to the segment', & + & 'Langleys', Seginc_swrad)/=0 ) CALL read_error(3, 'seginc_swrad') + + ALLOCATE ( Seginc_ssflow(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_ssflow', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average interflow for each segment from'// & + & ' HRUs contributing flow to the segment', & + & 'cfs', Seginc_ssflow)/=0 ) CALL read_error(3, 'seginc_ssflow') + + ALLOCATE ( Seginc_gwflow(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_gwflow', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average groundwater discharge for each'// & + & ' segment from HRUs contributing flow to the segment', & + & 'cfs', Seginc_gwflow)/=0 ) CALL read_error(3, 'seginc_gwflow') + + ALLOCATE ( Seginc_sroff(Nsegment) ) + IF ( declvar(MODNAME, 'seginc_sroff', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average surface runoff for each'// & + & ' segment from HRUs contributing flow to the segment', & + & 'cfs', Seginc_sroff)/=0 ) CALL read_error(3, 'seginc_sroff') + + ALLOCATE ( Seg_ssflow(Nsegment) ) + IF ( declvar(MODNAME, 'seg_ssflow', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average interflow for each segment from'// & + & ' HRUs contributing flow to the segment and upstream HRUs', & + & 'inches', Seg_ssflow)/=0 ) CALL read_error(3, 'seg_ssflow') + + ALLOCATE ( Seg_gwflow(Nsegment) ) + IF ( declvar(MODNAME, 'seg_gwflow', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average groundwater discharge for each segment from'// & + & ' HRUs contributing flow to the segment and upstream HRUs', & + & 'inches', Seg_gwflow)/=0 ) CALL read_error(3, 'seg_gwflow') + + ALLOCATE ( Seg_sroff(Nsegment) ) + IF ( declvar(MODNAME, 'seg_sroff', 'nsegment', Nsegment, 'double', & + & 'Area-weighted average surface runoff for each segment from'// & + & ' HRUs contributing flow to the segment and upstream HRUs', & + & 'inches', Seg_sroff)/=0 ) CALL read_error(3, 'seg_sroff') + ENDIF + + IF ( declvar(MODNAME, 'basin_segment_storage', 'one', 1, 'double', & + & 'Basin area-weighted average storage in the stream network', & + & 'inches', Basin_segment_storage)/=0 ) CALL read_error(3, 'basin_segment_storage') + + ALLOCATE ( Segment_delta_flow(Nsegment) ) + IF ( declvar(MODNAME, 'segment_delta_flow', 'nsegment', Nsegment, 'double', & + & 'Cummulative flow in minus flow out for each stream segment', & + & 'cfs', Segment_delta_flow)/=0 ) CALL read_error(3, 'segment_delta_flow') + + ! local arrays + ALLOCATE ( Segment_order(Nsegment), Segment_up(Nsegment), Segment_hruarea(Nsegment) ) + + END FUNCTION routingdecl + +!********************************************************************** +! routinginit - check for validity of parameters +!********************************************************************** + INTEGER FUNCTION routinginit() + USE PRMS_ROUTING + USE PRMS_MODULE, ONLY: Nsegment, Nhru, Init_vars_from_file, Strmflow_flag, & + & Water_use_flag, Segment_transferON_OFF, Inputerror_flag, Parameter_check_flag , & + & Ripst_flag, Stream_temp_flag !, Print_debug + USE PRMS_SET_TIME, ONLY: Timestep_seconds + USE PRMS_BASIN, ONLY: FT2_PER_ACRE, DNEARZERO, Active_hrus, Hru_route_order, Hru_area_dble, NEARZERO, & + & Hru_area, FEET2METERS, CFS2CMS_CONV !, Active_area + USE PRMS_FLOWVARS, ONLY: Seg_outflow + IMPLICIT NONE +! Functions + INTRINSIC MOD, DBLE + INTEGER, EXTERNAL :: getparam + EXTERNAL :: read_error +! Local Variable + INTEGER :: i, j, test, lval, toseg, iseg, isegerr, ierr, eseg + REAL :: k, x, d, x_max, velocity + DOUBLE PRECISION :: flow + INTEGER, ALLOCATABLE :: x_off(:) + CHARACTER(LEN=10) :: buffer +!********************************************************************** + routinginit = 0 + + Use_transfer_segment = 0 + IF ( Water_use_flag==1 .AND. Segment_transferON_OFF==1 ) Use_transfer_segment = 1 + + IF ( Init_vars_from_file==0 ) THEN + Basin_segment_storage = 0.0D0 + Segment_delta_flow = 0.0D0 + ENDIF + + IF ( Hru_seg_cascades==1 ) THEN + Seginc_potet = 0.0D0 + Seginc_gwflow = 0.0D0 + Seginc_ssflow = 0.0D0 + Seginc_sroff = 0.0D0 + Seginc_swrad = 0.0D0 + Seg_gwflow = 0.0D0 + Seg_ssflow = 0.0D0 + Seg_sroff = 0.0D0 + ENDIF + Hru_outflow = 0.0D0 + Flow_to_ocean = 0.0D0 + Flow_to_great_lakes = 0.0D0 + Flow_out_region = 0.0D0 + Flow_out_NHM = 0.0D0 + Flow_terminus = 0.0D0 + Flow_to_lakes = 0.0D0 + Flow_in_nation = 0.0D0 + Flow_in_region = 0.0D0 + Flow_headwater = 0.0D0 + Flow_in_great_lakes = 0.0D0 + Flow_replacement = 0.0D0 + + Cfs2acft = Timestep_seconds/FT2_PER_ACRE + + IF ( getparam(MODNAME, 'segment_type', Nsegment, 'integer', Segment_type)/=0 ) CALL read_error(2, 'segment_type') + DO i = 1, Nsegment + Segment_type(i) = MOD( Segment_type(i), 100 ) + ENDDO + + IF ( Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN + IF ( getparam(MODNAME, 'mann_n', Nsegment, 'real', Mann_n)/=0 ) CALL read_error(2, 'mann_n') + ENDIF + IF ( Stream_temp_flag==1 .OR. Ripst_flag==1 .OR. Strmflow_flag==6 .OR. Strmflow_flag==7 ) THEN + IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') + IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') +! find segments that are too short and print them out as they are found + ierr = 0 + DO i = 1, Nsegment + IF ( Seg_length(i)0 ) Segment_hruarea(iseg) = Segment_hruarea(iseg) + Hru_area_dble(i) + ENDDO + Segment_area = 0.0D0 + DO j = 1, Nsegment + Segment_area = Segment_area + Segment_hruarea(j) + IF ( Segment_hruarea(j)0 ) THEN + WRITE ( buffer, '(I10)' ) j + CALL write_outfile('WARNING, No HRUs are associated with segment:'//buffer) + IF ( Tosegment(j)==0 ) PRINT *, 'WARNING, No HRUs and tosegment=0 for segment:', j + ENDIF + ENDIF + ENDDO +! IF ( Active_area/=Segment_area ) PRINT *, 'Not all area in model domain included with segments, basin area =', & +! & Active_area, ' segment area = ', Segment_area + ENDIF + + IF ( Ripst_flag==1 ) THEN + IF ( getparam(MODNAME, 'ripst_areafr_max', Nhru, 'real', Ripst_areafr_max)/=0 ) CALL read_error(2, 'ripst_areafr_max') + IF ( getparam(MODNAME, 'ripst_et_coef', Nhru, 'real', Ripst_et_coef)/=0 ) CALL read_error(2, 'ripst_et_coef') + IF ( getparam(MODNAME, 'tr_ratio', Nhru, 'real', Tr_ratio)/=0 ) CALL read_error(2, 'tr_ratio') + IF ( getparam(MODNAME, 'bankfinite_hru', Nhru, 'integer', Bankfinite_hru)/=0 ) CALL read_error(2, 'bankfinite_hru') + ! might be able to calculate if want bankfinite_hru = 1 or 0 based on ripst_areafr_max and transmiss_seg + IF ( getparam(MODNAME, 'transmiss_seg', Nsegment, 'real', Transmiss_seg)/=0 ) CALL read_error(2, 'transmiss_seg') + IF ( getparam(MODNAME, 'specyield_seg', Nsegment, 'real', Specyield_seg)/=0 ) CALL read_error(2, 'specyield_seg') + IF ( getparam(MODNAME, 'porosity_seg', Nsegment, 'real', Porosity_seg)/=0 ) CALL read_error(2, 'porosity_seg') + Seg_hru_num = 0 + DO i = 1, Active_hrus + IF ( Hru_segment(i)>0) THEN + IF (Bankfinite_hru(i)==1) Basin_bankst_area = Basin_bankst_area+Ripst_areafr_max(i)*Hru_area_dble(i) ! in inches + IF (Bankfinite_hru(i)==0) Basin_bankst_area = Basin_bankst_area+Hru_area_dble(i) ! in inches + Ripst_area_max(i) = Ripst_areafr_max(i)*Hru_area(i) +! depth of hyporheic estimated at stream depth/porosity, Harvey and Wagner (2000) ?? + Ripst_depth(i) = Seg_depth(Hru_segment(i)) / Porosity_seg(Hru_segment(i)) + IF (Ripst_areafr_max(i)==0.0) Ripst_depth(i) = 0.0 + Ripst_vol_max(i) = DBLE( Ripst_area_max(i)*Ripst_depth(i)*(1.0-0.5*Tr_ratio(i)) ) + Seg_hru_num(Hru_segment(i)) =Seg_hru_num(Hru_segment(i)) +1 + ENDIF + ENDDO + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 ) THEN + IF ( getparam(MODNAME, 'ripst_frac_init', Nhru, 'real', Ripst_frac_init)/=0 ) CALL read_error(2, 'ripst_frac_init') + IF ( getparam(MODNAME, 'bankst_head_init', Nhru, 'real', Bankst_head_init)/=0 ) CALL read_error(2, 'bankst_head_init') + CALL init_the_swamp() + CALL init_bank_storage() + DEALLOCATE ( Bankst_head_init, Ripst_frac_init ) + ENDIF + ENDIF + + isegerr = 0 + Segment_up = 0 + ! Begin the loops for ordering segments + DO j = 1, Nsegment + iseg = Obsin_segment(j) + toseg = Tosegment(j) + IF ( toseg==j ) THEN + PRINT *, 'ERROR, tosegment value (', toseg, ') equals itself for segment:', j + isegerr = 1 + ELSEIF ( toseg>0 ) THEN + IF ( Tosegment(toseg)==j ) THEN + PRINT *, 'ERROR, circle found, segment:', j, ' sends flow to segment:', toseg, ' that sends it flow' + isegerr = 1 + ELSE + ! load segment_up with last stream segment that flows into a segment + Segment_up(toseg) = j + ENDIF + ENDIF + ENDDO + + IF ( Parameter_check_flag>0 ) THEN + DO i = 1, Nsegment + IF ( Segment_up(i)==0 .AND. Tosegment(i)==0 ) & + & PRINT *, 'WARNING, no other segment flows into segment:', i, ' and tosegment=0' + ENDDO + ENDIF + + IF ( isegerr==1 ) THEN + Inputerror_flag = 1 + RETURN + ENDIF + + ! Begin the loops for ordering segments + ALLOCATE ( x_off(Nsegment) ) + x_off = 0 + Segment_order = 0 + lval = 0 + iseg = 0 + eseg = 0 + DO WHILE ( lval0 + Ts = 1.0 + ierr = 0 + DO i = 1, Nsegment + IF ( Strmflow_flag==7 ) THEN ! muskingum_mann + velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth + K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped length + !K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours + ENDIF + + IF ( Segment_type(i)==2 .AND. K_coef(i)<24.0 ) K_coef(i) = 24.0 !K_coef must be specified = 24.0 for lake segments' + IF ( K_coef(i)<0.01 ) K_coef(i) = 0.01 !make compliant with old version of K_coef + IF ( K_coef(i)>24.0 ) K_coef(i) = 24.0 + k = K_coef(i) + x = X_coef(i) + +! check the values of k and x to make sure that Muskingum routing is stable + + IF ( k<1.0 ) THEN + IF ( Parameter_check_flag>0 ) THEN + PRINT '(/,A,I6,A,F6.2,/,9X,A,/)', 'WARNING, segment ', i, ' has K_coef < 1.0,', k, & + & 'this may produce unstable results' +! ierr = 1 + ENDIF +! Ts(i) = 0.0 ! not sure why this was set to zero, causes divide by 0 if K_coef < 1, BUG FIX 10/18/2016 RSR + Ts_i(i) = -1 + + ELSEIF ( k<2.0 ) THEN + Ts(i) = 1.0 + Ts_i(i) = 1 + + ELSEIF ( k<3.0 ) THEN + Ts(i) = 2.0 + Ts_i(i) = 2 + + ELSEIF ( k<4.0 ) THEN + Ts(i) = 3.0 + Ts_i(i) = 3 + + ELSEIF ( k<6.0 ) THEN + Ts(i) = 4.0 + Ts_i(i) = 4 + + ELSEIF ( k<8.0 ) THEN + Ts(i) = 6.0 + Ts_i(i) = 6 + + ELSEIF ( k<12.0 ) THEN + Ts(i) = 8.0 + Ts_i(i) = 8 + + ELSEIF ( k<24.0 ) THEN + Ts(i) = 12.0 + Ts_i(i) = 12 + + ELSE + Ts(i) = 24.0 + Ts_i(i) = 24 + + ENDIF + +! x must be <= t/(2K) the C coefficents will be negative. Check for this for all segments +! with Ts >= minimum Ts (1 hour). + IF ( Ts(i)>0.1 ) THEN + x_max = Ts(i) / (2.0 * k) + IF ( x>x_max ) THEN + PRINT *, 'ERROR, x_coef value is too large for stable routing for segment:', i, ' x_coef:', x + PRINT *, ' a maximum value of:', x_max, ' is suggested' + Inputerror_flag = 1 + CYCLE + ENDIF + ENDIF + + d = k - (k * x) + (0.5 * Ts(i)) + IF ( ABS(d)0 ) PRINT *, 'WARNING, segment ', i, ' computed value d <', NEARZERO, ', set to 0.0001' + d = 0.0001 + ENDIF + C0(i) = (-(k * x) + (0.5 * Ts(i))) / d + C1(i) = ((k * x) + (0.5 * Ts(i))) / d + C2(i) = (k - (k * x) - (0.5 * Ts(i))) / d + + ! the following code was in the original musroute, but, not in Linsley and others + ! rsr, 3/1/2016 - having < 0 coefficient can cause negative flows as found by Jacob in GCPO headwater +! if c2 is <= 0.0 then short travel time though reach (less daily +! flows), thus outflow is mainly = inflow w/ small influence of previous +! inflow. Therefore, keep c0 as is, and lower c1 by c2, set c2=0 + +! if c0 is <= 0.0 then long travel time through reach (greater than daily +! flows), thus mainly dependent on yesterdays flows. Therefore, keep +! c2 as is, reduce c1 by c0 and set c0=0 +! SHORT travel time + IF ( C2(i)<0.0 ) THEN + IF ( Parameter_check_flag>0 ) THEN + PRINT '(/,A)', 'WARNING, c2 < 0, set to 0, c1 set to c1 + c2' + PRINT *, ' old c2:', C2(i), '; old c1:', C1(i), '; new c1:', C1(i) + C2(i) + PRINT *, ' K_coef:', K_coef(i), '; x_coef:', x_coef(i) + ENDIF + C1(i) = C1(i) + C2(i) + C2(i) = 0.0 + ENDIF + +! LONG travel time + IF ( C0(i)<0.0 ) THEN + IF ( Parameter_check_flag>0 ) THEN + PRINT '(/,A)', 'WARNING, c0 < 0, set to 0, c0 set to c1 + c0' + PRINT *, ' old c0:', C0(i), 'old c1:', C1(i), 'new c1:', C1(i) + C0(i) + PRINT *, ' K_coef:', K_coef(i), '; x_coef:', x_coef(i) + ENDIF + C1(i) = C1(i) + C0(i) + C0(i) = 0.0 + ENDIF + + ENDDO + IF ( ierr==1 ) PRINT '(/,A,/)', '***Recommend that the Muskingum parameters be adjusted in the Parameter File' + DEALLOCATE ( K_coef, X_coef) + + END FUNCTION routinginit + +!*********************************************************************** +! route_run - Computes segment flow states and fluxes +!*********************************************************************** + INTEGER FUNCTION route_run() + USE PRMS_ROUTING + USE PRMS_MODULE, ONLY: Nsegment, Cascade_flag, Glacier_flag + USE PRMS_BASIN, ONLY: Hru_area, Hru_route_order, Active_hrus, NEARZERO, FT2_PER_ACRE + USE PRMS_CLIMATEVARS, ONLY: Swrad, Potet + USE PRMS_SET_TIME, ONLY: Timestep_seconds, Cfs_conv + USE PRMS_FLOWVARS, ONLY: Ssres_flow, Sroff, Seg_lateral_inflow !, Seg_outflow + USE PRMS_WATER_USE, ONLY: Segment_transfer, Segment_gain + USE PRMS_GWFLOW, ONLY: Gwres_flow + USE PRMS_SRUNOFF, ONLY: Strm_seg_in + USE PRMS_GLACR, ONLY: Glacr_flow + IMPLICIT NONE +! Functions + INTRINSIC DBLE +! Local Variables + INTEGER :: i, j, jj, this_seg + DOUBLE PRECISION :: tocfs + LOGICAL :: found +!*********************************************************************** + route_run = 0 + + Cfs2acft = Timestep_seconds/FT2_PER_ACRE + +! seg variables are not computed if cascades are active as hru_segment is ignored + IF ( Hru_seg_cascades==1 ) THEN + ! add hru_ppt, hru_actet + Seginc_gwflow = 0.0D0 + Seginc_ssflow = 0.0D0 + Seginc_sroff = 0.0D0 + Seginc_swrad = 0.0D0 + Seginc_potet = 0.0D0 + Seg_gwflow = 0.0D0 + Seg_sroff = 0.0D0 + Seg_ssflow = 0.0D0 + ENDIF + IF ( Cascade_flag==0 ) THEN + Seg_lateral_inflow = 0.0D0 + ELSE ! use strm_seg_in for cascade_flag = 1 or 2 + Seg_lateral_inflow = Strm_seg_in + ENDIF + + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + tocfs = DBLE( Hru_area(j) )*Cfs_conv + Hru_outflow(j) = DBLE( (Sroff(j) + Ssres_flow(j) + Gwres_flow(j)) )*tocfs + ! Note: glacr_flow (from glacier or snowfield) is added as a gain, outside stream network addition + ! glacr_flow in inch^3, 1728=12^3 + IF ( Glacier_flag==1 ) Hru_outflow(j) = Hru_outflow(j) + Glacr_flow(j)/1728.0/Timestep_seconds + IF ( Hru_seg_cascades==1 ) THEN + i = Hru_segment(j) + IF ( i>0 ) THEN + Seg_gwflow(i) = Seg_gwflow(i) + Gwres_flow(j) + Seg_sroff(i) = Seg_sroff(i) + Sroff(j) + Seg_ssflow(i) = Seg_ssflow(i) + Ssres_flow(j) + ! if cascade_flag = 2, seg_lateral_inflow set with strm_seg_in + IF ( Cascade_flag==0 ) Seg_lateral_inflow(i) = Seg_lateral_inflow(i) + Hru_outflow(j) + Seginc_sroff(i) = Seginc_sroff(i) + DBLE( Sroff(j) )*tocfs + Seginc_ssflow(i) = Seginc_ssflow(i) + DBLE( Ssres_flow(j) )*tocfs + Seginc_gwflow(i) = Seginc_gwflow(i) + DBLE( Gwres_flow(j) )*tocfs + Seginc_swrad(i) = Seginc_swrad(i) + DBLE( Swrad(j)*Hru_area(j) ) + Seginc_potet(i) = Seginc_potet(i) + DBLE( Potet(j)*Hru_area(j) ) + ENDIF + ENDIF + ENDDO + + IF ( Use_transfer_segment==1 ) THEN + DO i = 1, Nsegment + Seg_lateral_inflow(i) = Seg_lateral_inflow(i) + DBLE( Segment_gain(i) - Segment_transfer(i) ) + ENDDO + ENDIF + + IF ( Cascade_flag==1 ) RETURN + +! Divide solar radiation and PET by sum of HRU area to get avarage + IF ( Noarea_flag==0 ) THEN + DO i = 1, Nsegment + Seginc_swrad(i) = Seginc_swrad(i)/Segment_hruarea(i) + Seginc_potet(i) = Seginc_potet(i)/Segment_hruarea(i) + ENDDO + +! If there are no HRUs associated with a segment, then figure out some +! other way to get the solar radiation, the following is not great + ELSE ! IF ( Noarea_flag==1 ) THEN + DO i = 1, Nsegment +! This reworked by markstrom + IF ( Segment_hruarea(i)>NEARZERO ) THEN + Seginc_swrad(i) = Seginc_swrad(i)/Segment_hruarea(i) + Seginc_potet(i) = Seginc_potet(i)/Segment_hruarea(i) + ELSE + +! Segment does not have any HRUs, check upstream segments. + this_seg = i + found = .false. + do + if (Segment_hruarea(this_seg) <= NEARZERO) then + + ! Hit the headwater segment without finding any HRUs (i.e. sources of streamflow) + if (segment_up(this_seg) .eq. 0) then + found = .false. + exit + endif + + ! There is an upstream segment, check that segment for HRUs + this_seg = segment_up(this_seg) + else + ! This segment has HRUs so there will be swrad and potet + Seginc_swrad(i) = Seginc_swrad(this_seg)/Segment_hruarea(this_seg) + Seginc_potet(i) = Seginc_potet(this_seg)/Segment_hruarea(this_seg) + found = .true. + exit + endif + enddo + + if (.not. found) then +! Segment does not have any upstream segments with HRUs, check downstream segments. + + this_seg = i + found = .false. + do + if (Segment_hruarea(this_seg) <= NEARZERO) then + + ! Hit the terminal segment without finding any HRUs (i.e. sources of streamflow) + if (tosegment(this_seg) .eq. 0) then + found = .false. + exit + endif + + ! There is a downstream segment, check that segment for HRUs + this_seg = tosegment(this_seg) + else + ! This segment has HRUs so there will be swrad and potet + Seginc_swrad(i) = Seginc_swrad(this_seg)/Segment_hruarea(this_seg) + Seginc_potet(i) = Seginc_potet(this_seg)/Segment_hruarea(this_seg) + found = .true. + exit + endif + enddo + + if (.not. found) then +! write(*,*) "route_run: no upstream or downstream HRU found for segment ", i +! write(*,*) " no values for seginc_swrad and seginc_potet" + Seginc_swrad(i) = -99.9 + Seginc_potet(i) = -99.9 + endif + endif + ENDIF + ENDDO + ENDIF + + END FUNCTION route_run + +!*********************************************************************** +! Initialize overbank riparian (swamp) hydrology +!*********************************************************************** + SUBROUTINE init_the_swamp() + USE PRMS_BASIN, ONLY: Basin_area_inv, Hru_area_dble, Active_hrus + USE PRMS_ROUTING, ONLY: Basin_ripst_vol, Basin_ripst_area, Ripst_vol, Ripst_frac, & + & Hru_segment, Ripst_frac_init, Basin_ripst_vol, Ripst_area, Ripst_area_max, & + & Ripst_vol_max, Ripst_stor_hru + IMPLICIT NONE +! Functions + INTRINSIC SNGL, DBLE +! Local Variables + INTEGER :: i +!*********************************************************************** + DO i = 1, Active_hrus + IF ( Hru_segment(i)>0) THEN + Ripst_frac(i) = Ripst_frac_init(i) + Ripst_vol(i) = DBLE(Ripst_frac(i))*Ripst_vol_max(i) + Ripst_stor_hru(i) = Ripst_vol(i)/Hru_area_dble(i) +! Filled riparian storage surface area for each HRU: +! Fills outward from the river with one edge on river and with same depth and same side shape +! this works out to keeping fraction same for area and volume filled + Ripst_area(i) = Ripst_area_max(i)*Ripst_frac(i) !area +! calculate the basin riparian storage volumes + Basin_ripst_vol = Basin_ripst_vol + Ripst_vol(i) + Basin_ripst_area = Basin_ripst_area + Ripst_area(i) + ENDIF + ENDDO + Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv + + END SUBROUTINE init_the_swamp + +!*********************************************************************** +! Compute overbank area (swamp) fill and drain +! Treat like a closed surface depression in that it can't spill. +! Right now, not getting water from anywhere but stream, and losing only +! to ET and seep. Possibly should take water in from precipitation, +! runoff, and interflow. +! This is called after bank storage has been removed, so not inside +! hourly routing. +!*********************************************************************** + SUBROUTINE drain_the_swamp(Ihru) + USE PRMS_ROUTING, ONLY: Seg_width, Seg_depth, Seg_width, Hru_segment, Mann_n, & + & Transmiss_seg, Tr_ratio, Ripst_vol_max, Ripst_et_coef, Ripst_evap_hru, & + & Basin_ripst_vol, Basin_ripst_evap, Basin_ripst_seep, Ripst_stor_hru, & + & Ripst_frac, Ripst_vol, Ripst_area_max, Ripst_area, Ripst_seep_hru, Seg_slope, & + & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area, Seg_length + USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Hru_area, Hru_area_dble, FEET2METERS, & + & FT2_PER_ACRE, CFS2CMS_CONV + USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_CLIMATEVARS, ONLY: Potet + USE PRMS_SET_TIME, ONLY: Timestep_seconds + USE PRMS_SRUNOFF, ONLY: Hru_impervevap, Dprst_evap_hru + USE PRMS_INTCP, ONLY: Hru_intcpevap + USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap + IMPLICIT NONE +! Functions + INTRINSIC EXP, LOG, MIN, DBLE, SNGL +! Arguments + INTEGER, INTENT(IN) :: Ihru +! Local Variables + REAL :: ripst_avail_et, unsatisfied_et, ripst_evap, ripst_wid + REAL :: inflow, inflow_in, max_depth + DOUBLE PRECISION :: seep, ripst_grnd, poss, seep_in +!*********************************************************************** +!It won't get deeper than this depth, should be Seg_depth but not accurate or Seg_width and other terms not accurate + !max_depth = Seg_depth(Hru_segment(Ihru))*10.0 + max_depth = Seg_depth(Hru_segment(Ihru))*1e30 +! amount possible in cfs given a river depth + poss = Seg_width(Hru_segment(Ihru))*SQRT(Seg_slope(Hru_segment(Ihru)))* & + & max_depth**(3./5.)/ ( CFS2CMS_CONV*Mann_n(Hru_segment(Ihru)) ) +!inflow is water over bank, remove from Seg_outflow(Hru_segment(Ihru)) and give half to +! each side of bank, in acre inches + inflow = 0.0 +! in cfs, amount over amount possible + IF ( poss < Seg_outflow(Hru_segment(Ihru)) ) inflow = SNGL(Seg_outflow(Hru_segment(Ihru)) - poss) +! give it equally to each HRU surrounding it + inflow = inflow/REAL(Seg_hru_num(Hru_segment(Ihru))) +!negative flow is out of stream into riparian + Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru)) - inflow + inflow_in = SNGL(inflow*Timestep_seconds/(FT2_PER_ACRE*12.0)) + Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow_in + Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) +! Filled riparian storage surface area for each HRU: +! Fills outward from the river with one edge on river and with same depth and same side shape +! this works out to keeping fraction same for area and volume filled + Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) + + ! evaporate water from riparian area based on snowcov_area + ! ripst_evap_open & ripst_evap_clos = inches-acres on the HRU + unsatisfied_et = Potet(Ihru) - Snow_evap(Ihru) - Hru_intcpevap(Ihru) & + & - Hru_impervevap(Ihru) - Dprst_evap_hru(Ihru) + ripst_avail_et = Potet(Ihru)*(1.0-Snowcov_area(Ihru))*Ripst_et_coef(Ihru) + Ripst_evap_hru(Ihru) = 0.0 + IF ( ripst_avail_et>0.0 ) THEN + ripst_evap = 0.0 + IF ( Ripst_area(Ihru)>0.0 ) THEN + ripst_evap = MIN(Ripst_area(Ihru)*ripst_avail_et, SNGL(Ripst_vol(Ihru))) + IF ( ripst_evap/Hru_area(Ihru)>unsatisfied_et ) THEN + !IF ( Print_debug>-1 ) THEN + ! PRINT *, 'Warning, ripst evaporation > available ET, HRU:, ', Ihru, & +! & unsatisfied_et, ripst_evap*Ripst_frac(Ihru) + ! PRINT *, 'Set to available ET, perhaps ripst_et_coef specified too large' + ! PRINT *, 'Set print_debug to -1 to turn off message' + !ENDIF + ripst_evap = unsatisfied_et*Hru_area(Ihru) + ENDIF + IF ( ripst_evap>SNGL(Ripst_vol(Ihru)) ) ripst_evap = SNGL( Ripst_vol(Ihru) ) + Ripst_vol(Ihru) = Ripst_vol(Ihru) - DBLE( ripst_evap ) + ENDIF + Ripst_evap_hru(Ihru) = ripst_evap/Hru_area(Ihru) + ENDIF + + ! compute seepage + Ripst_seep_hru(Ihru) = 0.0D0 + seep = 0.0 + IF ( Ripst_vol(Ihru)>NEARZERO ) THEN + ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters +!assumed it was a one sided stream, here a headwater with both sides in one HRU + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 +! Stream ground area is stream side area (flat wall) and other side area (fraction of triangle (1) to rectangle (0)) + ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle + & (SQRT( ripst_wid**2.0 + Ripst_depth(Ihru)**2.0 )- Ripst_depth(Ihru))*Tr_ratio(Ihru) + & !triangle + & 2.0*Ripst_depth(Ihru) ) ) !stream and other side +!assumed it was a one sided stream, here a headwater with both sides in one HRU + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 +!seep in a day through ground surface area of riparian, m^3 into ft^3 to acre_in +!Transmissivity would be way too big, maybe ssr2gw_rate + seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) + !seep = 0.0 !if want to turn off seep + seep_in = seep*FT2_PER_ACRE*12.0 + Ripst_vol(Ihru) = Ripst_vol(Ihru) - seep_in + IF ( Ripst_vol(Ihru)<0.0D0 ) THEN + !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) + seep_in = seep_in + Ripst_vol(Ihru) + seep = seep_in/(FT2_PER_ACRE*12.0) + Ripst_vol(Ihru) = 0.0D0 + ENDIF + Ripst_seep_hru(Ihru) = seep_in/Hru_area_dble(Ihru) !inch per HRU + ENDIF + IF ( Ripst_vol(Ihru)<0.0D0 ) THEN + !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) + Ripst_vol(Ihru) = 0.0D0 + ENDIF + + ! seep goes back in stream as positive flow, cfs + Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru))+ seep/Timestep_seconds + !Seg_ripflow(Hru_segment(Ihru)) = 0.0 !if want to turn off overbank flow + +! print*, Ihru, Hru_segment(Ihru), poss, Seg_outflow(Hru_segment(Ihru)), Seg_ripflow(Hru_segment(Ihru)), Seg_depth(Hru_segment(Ihru)),& +! & Stage_ts(Hru_segment(Ihru)) + + Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) + Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) + Ripst_stor_hru(Ihru) = Ripst_vol(Ihru)/Hru_area_dble(Ihru) + Basin_ripst_vol = Basin_ripst_vol + Ripst_vol(Ihru) + Basin_ripst_evap = Basin_ripst_evap + DBLE(Ripst_evap_hru(Ihru))*Hru_area_dble(Ihru) + Basin_ripst_seep = Basin_ripst_seep + Ripst_seep_hru(Ihru)*Hru_area_dble(Ihru) + Basin_ripst_area = Basin_ripst_area + Ripst_area(Ihru) + + END SUBROUTINE drain_the_swamp + +!*********************************************************************** +! Initialize bank storage hydrology +!*********************************************************************** + SUBROUTINE init_bank_storage() + USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_area_dble, Active_hrus, & + & FT2_PER_ACRE, FEET2METERS, CFS2CMS_CONV + USE PRMS_ROUTING, ONLY: Basin_bankst_head, Bankst_head_init, Basin_bankst_area, & + & Basin_bankst_vol, Bankst_head, Hru_segment, Seg_width, Seg_length, & + & Bankst_stor_hru, Bankst_head_pts, Ripst_areafr_max, Bankfinite_hru + USE PRMS_FLOWVARS, ONLY: Seg_outflow + IMPLICIT NONE +! Functions + INTRINSIC SNGL +! Local Variables + INTEGER :: i +!*********************************************************************** + DO i = 1, Active_hrus + IF ( Hru_segment(i)>0) THEN + Bankst_head(i) = Bankst_head_init(i) + Bankst_head_pts(i) =SNGL(Seg_outflow(Hru_segment(i))*CFS2CMS_CONV)*60.*60.*24. & + & /Seg_width(Hru_segment(i))/Seg_length(Hru_segment(i)) + IF (Bankfinite_hru(i)==1) THEN + Bankst_stor_hru(i) = Ripst_areafr_max(i)*12.0*Bankst_head(i)/FEET2METERS !in inches + Basin_bankst_head = Basin_bankst_head + Ripst_areafr_max(i)*Bankst_head(i)*Hru_area_dble(i) ! in meters + ELSE + Bankst_stor_hru(i) = 12.0*Bankst_head(i)/FEET2METERS !in inches + Basin_bankst_head = Basin_bankst_head + Bankst_head(i)*Hru_area_dble(i) ! in meters + ENDIF + Basin_bankst_vol = Basin_bankst_vol+Bankst_stor_hru(i)*Hru_area_dble(i) ! in inches + ENDIF + ENDDO + Basin_bankst_vol = Basin_bankst_vol*Basin_area_inv + Basin_bankst_head = Basin_bankst_head/Basin_bankst_area + + END SUBROUTINE init_bank_storage + +!*********************************************************************** +! Compute bank storage hydrology +! For the linear boundary-value problems discussed by Moench and Barlow (2000), the total +! response of a stream–aquifer system to a time series of individual stresses (stream-stage +! fluctuations or recharge) can be determined by superposition (or convolution) of the +! system’s response to the individual stresses. +! Assume no layer of semi-pervious bank sediments, so storage right at the bank. Use a +! finite confined aquifer with no overlying aquitard, or a finite water table aquifer +! (swamp) with a specific yield of aquifer = 0, or ~ 0. +! This is saying very little water is released by the aquifer from the water table lowering +! and the unsaturated zone is thin. This is true for shallow water table aquifers; see +! Barlow et al (2000). +!*********************************************************************** + SUBROUTINE comp_bank_storage(Ihru) + USE PRMS_ROUTING, ONLY: Bankst_seep_rate, Bankst_head, Bankst_head_pts, Hru_segment, & + & Bankst_seep_hru, Bankst_stor_hru, Stage_ts, Stage_ante, Seg_bankflow, Ripst_areafr_max, & + & Transmiss_seg, Seg_width, Seg_length, Specyield_seg, Bankfinite_hru, Seg_hru_num, & + & Basin_bankst_seep, Basin_bankst_head, Basin_bankst_vol + USE PRMS_BASIN, ONLY: CFS2CMS_CONV, FT2_PER_ACRE, FEET2METERS, Hru_area, Hru_area_dble + USE PRMS_FLOWVARS, ONLY: Gwres_stor + IMPLICIT NONE +! Functions + INTRINSIC SUM, SNGL, SQRT + EXTERNAL LTST1 +! Arguments + INTEGER, INTENT(IN) :: Ihru + ! Local Variables + INTEGER :: h, t0 + INTEGER, PARAMETER :: nbankd = 2 + REAL, PARAMETER :: PI = 3.14159 + REAL :: area, str_wid, tot_wid, bank_wid, trans, a, xd, t, td + REAL :: delt, delta_input(nbankd), delta_diff(nbankd), head(nbankd), seep(nbankd) + REAL :: bank(nbankd), bankv(nbankd), ripfrac + DOUBLE PRECISION :: input_net(nbankd), diff_net(nbankd), recharge(nbankd), stage(nbankd) + DOUBLE PRECISION :: head_step, head_step_grad, seep_sum, head_sum +!*********************************************************************** + area = Ripst_areafr_max(Ihru)*Hru_area(Ihru) !acres + trans = Transmiss_seg(Hru_segment(Ihru)) +!aquifer diffusivity, ratio of the transmissivity/storativity of the aquifer + a = trans/Specyield_seg(Hru_segment(Ihru)) + str_wid = Seg_width(Hru_segment(Ihru))/2.0 + bank_wid = SNGL(area*FT2_PER_ACRE*(FEET2METERS**2.)/Seg_length(Hru_segment(Ihru))/str_wid) !dimensionless + tot_wid = bank_wid+1.0 !dimensionless + delt = 1.0 !fraction of day +! might want to interpolate a curve, so leaving nbankd as a dimension -- sh + stage(1) = Stage_ante(Hru_segment(Ihru)) + stage(2) = Stage_ts(Hru_segment(Ihru)) + ! changes in a day + DO h = 1, nbankd + seep(h) = 0.0 + bank(h) = 0.0 + bankv(h) = 0.0 + recharge(h) = (h-1)*delt*Gwres_stor(Ihru)*FEET2METERS/12.D0 ! in meters, currently ignoring ET +! Can only use recharge change if say it's a leaky aquifer overlain by a water table aquitard. +! might want to do that. Also might want to go other way and make simpler, make it semi-infinite so then +! no numerical Laplace inverse, just can solve + input_net(h) = stage(h) !+ recharge(h) + diff_net(h) = stage(h) !- recharge(h) !FIX What is this vs input_net + ENDDO +!Make head ideal flood wave for volume change and recharge ideal observed response at a well for vol change?? + DO h = 2,nbankd + delta_input(h-1) = SNGL( (input_net(h)-input_net(h-1))/delt ) + delta_diff(h-1) = SNGL((diff_net(h)-diff_net(h-1))/delt ) + ENDDO + Bankst_seep_hru(Ihru) = 0.0 + xd = 1.0+ bank_wid/2.0 ! at x = 1.0 is stage which already know, calc at middle of bank storage area + head=Bankst_head_pts(Ihru) !set at last height for initial +! Calculate heads, seepage, and bank storage using convolution + ripfrac = Ripst_areafr_max(Ihru) + IF (Bankfinite_hru(Ihru)==0) ripfrac = 1.0 + DO h = 1, (nbankd-1) + head_sum = 0.0 + seep_sum = 0.0 + DO t0 = 1,h + t = t0*delt + td = t*a/(str_wid**2.0) !dimensionless + IF (Bankfinite_hru(Ihru)==1) then !finite solution if transmissivity high, COMPUTATIONALLY EXPENSIVE, might eliminate + CALL LTST1(td, xd, tot_wid, bank_wid, head_step, head_step_grad) + ELSE IF (Bankfinite_hru(Ihru)==0) then !semi-infinite solution + head_step = ERFC( (xd - 1.0)/SQRT((4.0*td)) ) + head_step_grad = -( 1.0/SQRT((PI*td)) ) + ENDIF + !head is a function of xd + head_sum = delta_input(h-t0+1)*head_step + head_sum + !seep is per unit segment length rate goes out, not a function of xd + seep_sum = delta_diff(h-t0+1)*head_step_grad + seep_sum + ENDDO + head(h+1)=head(h+1) + SNGL(head_sum*delt) + seep(h+1)=SNGL((trans/str_wid)*seep_sum*delt) + bank(h+1)=bank(h) - seep(h+1)*delt + bankv(h+1)=bank(h+1)*Seg_length(Hru_segment(Ihru)) + !IF (Ihru==1) print*,h+1,stage(h+1),bank(h+1),seep(h+1),bankv(h+1) !for plotting daily pattern + ENDDO + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) THEN +!assumed it was a one sided stream, here a headwater with both sides in one HRU + seep = seep*2.0 + bank = bank*2.0 + bankv = bankv*2.0 + ENDIF + Bankst_head_pts(Ihru) = head(nbankd) ! meters + !linear interpolation for total average head over bank storage area, meters + Bankst_head(Ihru) = 0.5*(SNGL(stage(nbankd))+Bankst_head_pts(Ihru)) + ! Bankst_head_pts at finite edge of bank storage area is 0 (xd = 1, so head_step = 0) + ! is only saved at the end of the timestep + Bankst_head(Ihru) = Bankst_head(Ihru) + 0.5*Bankst_head_pts(Ihru) + ! m2 per 24 hr per stream segment for both sides of stream + ! seep hru is inch over hru seeping out per day + Bankst_seep_hru(Ihru) = -12.0*bankv(nbankd)/SNGL(CFS2CMS_CONV*Hru_area(Ihru)*FT2_PER_ACRE) + Bankst_seep_rate(Hru_segment(Ihru)) = Bankst_seep_rate(Hru_segment(Ihru)) - bank(nbankd) + Bankst_stor_hru(Ihru) = Bankst_stor_hru(Ihru)- Bankst_seep_hru(Ihru) !inch over hru + Seg_bankflow(Hru_segment(Ihru)) = Seg_bankflow(Hru_segment(Ihru))-bankv(nbankd)/(24.*60.*60.)/CFS2CMS_CONV + !FIX area change?? no I don't think so + Basin_bankst_seep = Basin_bankst_seep + Bankst_seep_hru(Ihru)*Hru_area_dble(Ihru) + Basin_bankst_head = Basin_bankst_head + ripfrac*Bankst_head(Ihru)* Hru_area_dble(Ihru) + Basin_bankst_vol = Basin_bankst_vol+Bankst_stor_hru(Ihru)*Hru_area_dble(Ihru) + + END SUBROUTINE comp_bank_storage + +!*********************************************************************** +! Laplace transform leakage equation +!*********************************************************************** + SUBROUTINE LTST1(td, xd, tot_wid, bank_wid, head_step, head_step_grad) + IMPLICIT NONE +! Functions + INTRINSIC EXP, LOG, DBLE + EXTERNAL LINVST +! Arguments + REAL, INTENT(IN) :: td, xd, tot_wid, bank_wid + DOUBLE PRECISION, INTENT(OUT) :: head_step, head_step_grad +! Local Variables + INTEGER, PARAMETER :: NS=12 ! Number of Stehfest terms, 8 usually sufficient but Barlow uses 12 + INTEGER :: expmax, i, NH + DOUBLE PRECISION :: c1, c2, c3, c4, ff, fnum, fden, xLN2, p + DOUBLE PRECISION :: caq, ca, re0, re0q, pdl, pdlq, xp, xpq, V(NS) +!*********************************************************************** + NH=NS/2 + CALL LINVST(NS,NH,V) + xLN2=LOG(2.0) +!expmax is the maximum allowable absolute value of the exponential arguments + expmax=708 + xp=0.0 + xpq=0.0 + DO i=1,NS + p=xLN2*i/td +!calculate coeficients + c1 = SQRT(p) + c2 = p + fnum = EXP(DBLE( -2.0*SQRT(p)*(tot_wid-xd) )) +1.0 + fden = EXP(DBLE( -2.0*SQRT(p)*bank_wid )) +1.0 + ff = fnum/fden + c3 = fden + c4 = c2*c3 + caq = -(c1/c4)*(EXP(DBLE( -2.0*SQRT(p)*bank_wid )) -1.0) + ca = c1*(xd-1.0) + IF (ca > expmax) ca = expmax +!calculate head and seepage terms + re0 = ff*EXP(-ca) + re0q = caq + pdl = re0/c2 + pdlq = re0q + xp = xp + V(i)*pdl + xpq = xpq + V(i)*pdlq + ENDDO + head_step = xp*xLN2/td + head_step_grad = xpq*xLN2/td + + END SUBROUTINE LTST1 + +!*********************************************************************** +! Stehfest coefficients for Laplace transform +!*********************************************************************** + SUBROUTINE LINVST(NS, NH, V) + IMPLICIT NONE +! Functions + INTRINSIC FLOOR +! Arguments + INTEGER, INTENT(IN) :: NS,NH + DOUBLE PRECISION, INTENT(OUT) :: V(NS) +! Local Variables + INTEGER :: i, j, FI, SN, K1,K2 + DOUBLE PRECISION :: G(NS), HS(NH) +!*********************************************************************** + G(1)=1.0 + DO i=2,NS + G(i)=G(i-1)*i + ENDDO + HS(1)=2.0/G(NH-1) + DO i = 2,NH + FI=i + IF (i== NH) THEN + HS(i)=(FI**NH)*G(2*i)/(G(i)*G(i-1)) + ELSE + HS(i)=(FI**NH)*G(2*i)/(G(NH-i)*G(i)*G(i-1)) + ENDIF + ENDDO + SN=2*(NH-NH/2*2)-1 + DO i=1,NS + V(i)=0.0 + K1=FLOOR((i+1)/2.0) + K2=i + IF (K2 > NH) K2 = NH + DO j=K1,K2 + IF (2*j-i == 0) THEN + V(i)=V(i)+HS(j)/(G(i-j)) + ELSEIF (i == j) THEN + V(i)=V(i)+HS(j)/G(2*j-i) + ELSE + V(i)=V(i)+HS(j)/(G(i-j)*G(2*j-i)) + ENDIF + ENDDO + V(i)=SN*V(i) + SN=-SN + ENDDO + + END SUBROUTINE LINVST + +!*********************************************************************** +! routing_restart - write or read restart file +!*********************************************************************** + SUBROUTINE routing_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Ripst_flag + USE PRMS_ROUTING + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variables + CHARACTER(LEN=7) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Basin_segment_storage + WRITE ( Restart_outunit ) Segment_delta_flow + IF ( Ripst_flag==1 ) THEN + WRITE ( Restart_outunit ) Basin_bankst_head + WRITE ( Restart_outunit ) Basin_bankst_vol + WRITE ( Restart_outunit ) Basin_bankst_seep_rate + WRITE ( Restart_outunit ) Basin_bankst_seep, Basin_bankflow + WRITE ( Restart_outunit ) Bankst_head, Seg_bankflow + WRITE ( Restart_outunit ) Bankst_head_pts + WRITE ( Restart_outunit ) Bankst_stor_hru + WRITE ( Restart_outunit ) Stage_ante, Stage_ts + WRITE ( Restart_outunit ) Basin_ripflow + WRITE ( Restart_outunit ) Basin_ripst_evap, Basin_ripst_seep + WRITE ( Restart_outunit ) Basin_ripst_vol, Basin_ripst_area + WRITE ( Restart_outunit ) Ripst_stor_hru, Ripst_seep_hru, Ripst_vol + WRITE ( Restart_outunit ) Seg_ripflow, Ripst_evap_hru, Ripst_frac + ENDIF + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Basin_segment_storage + READ ( Restart_inunit ) Segment_delta_flow + IF ( Ripst_flag==1 ) THEN + READ ( Restart_inunit ) Basin_segment_storage + READ ( Restart_inunit ) Segment_delta_flow + READ ( Restart_inunit ) Basin_bankst_head + READ ( Restart_inunit ) Basin_bankst_vol + READ ( Restart_inunit ) Basin_bankst_seep_rate + READ ( Restart_inunit ) Basin_bankst_seep, Basin_bankflow + READ ( Restart_inunit ) Bankst_head, Seg_bankflow + READ ( Restart_inunit ) Bankst_head_pts + READ ( Restart_inunit ) Bankst_stor_hru + READ ( Restart_inunit ) Stage_ante, Stage_ts + READ ( Restart_inunit ) Basin_ripflow + READ ( Restart_inunit ) Basin_ripst_evap, Basin_ripst_seep + READ ( Restart_inunit ) Basin_ripst_vol, Basin_ripst_area + READ ( Restart_inunit ) Ripst_stor_hru, Ripst_seep_hru, Ripst_vol + READ ( Restart_inunit ) Seg_ripflow, Ripst_evap_hru, Ripst_frac + ENDIF + ENDIF + END SUBROUTINE routing_restart diff --git a/prmsRip/snowcompCfgim.f90 b/prmsRip/snowcompCfgim.f90 new file mode 100644 index 00000000..b519fc56 --- /dev/null +++ b/prmsRip/snowcompCfgim.f90 @@ -0,0 +1,3074 @@ +!*********************************************************************** +! Initiates development of a snowpack and simulates snow accumulation +! and depletion processes using an energy-budget approach +! +! Modified glacier melt and glacier basal melt +! These modifications includes albedo info for saving between runs 2/00 +!*********************************************************************** + +! PRMS_SNOW module for defining stateful variables + + MODULE PRMS_SNOW + + IMPLICIT NONE + !**************************************************************** + ! Local Constants + + INTEGER, PARAMETER :: MAXALB = 15 + + !**************************************************************** + ! Local Variables + + REAL, PARAMETER :: PI = 3.1415927 + INTEGER, SAVE :: Active_glacier + INTEGER, SAVE, ALLOCATABLE :: Int_alb(:) + DOUBLE PRECISION, SAVE :: Deninv, Denmaxinv, Settle_const_dble + ! REAL, SAVE :: Setden, Set1 + REAL, SAVE :: Acum(MAXALB), Amlt(MAXALB) + REAL, SAVE, ALLOCATABLE :: Snowcov_areasv(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Scrv(:), Pss(:), Pksv(:), Pst(:) + REAL, SAVE, ALLOCATABLE :: Salb(:), Slst(:) + CHARACTER(LEN=8), SAVE :: MODNAME + + !**************************************************************** + ! Declared Variables + + INTEGER :: Yrdays5 + INTEGER, SAVE, ALLOCATABLE :: Pptmix_nopack(:), Lst(:) + INTEGER, SAVE, ALLOCATABLE :: Iasw(:), Iso(:), Mso(:), Lso(:) + DOUBLE PRECISION, SAVE :: Basin_snowmelt, Basin_pweqv, Basin_tcal + DOUBLE PRECISION, SAVE :: Basin_snowcov, Basin_snowevap + DOUBLE PRECISION, SAVE :: Basin_snowdepth, Basin_pk_precip + REAL, SAVE, ALLOCATABLE :: Snowmelt(:), Snow_evap(:) + REAL, SAVE, ALLOCATABLE :: Albedo(:), Pk_temp(:), Pk_den(:) + REAL, SAVE, ALLOCATABLE :: Pk_def(:), Pk_ice(:), Freeh2o(:) + REAL, SAVE, ALLOCATABLE :: Snowcov_area(:), Tcal(:) + REAL, SAVE, ALLOCATABLE :: Snsv(:), Pk_precip(:), Frac_swe(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Pk_depth(:), Pkwater_ante(:), Ai(:) +! Frozen ground variables + REAL, SAVE, ALLOCATABLE :: Tcalin_nosnow(:), Tcalin_snow(:), Land_albedo(:) +! Glacier variables + DOUBLE PRECISION, SAVE :: Basin_glacrevap, Basin_snowicecov + DOUBLE PRECISION, SAVE :: Basin_glacrb_melt + REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_capm(:), Prev_ann_tempc(:) + REAL, SAVE, ALLOCATABLE :: Glacrmelt(:), Glacr_evap(:), Glacr_albedo(:), Glacr_pk_den(:) + REAL, SAVE, ALLOCATABLE :: Glacr_pk_ice(:), Glacr_freeh2o(:), Glacrcov_area(:) + REAL, SAVE, ALLOCATABLE :: Glacrb_melt(:), Glacr_pk_def(:), Glacr_pk_temp(:), Ann_tempc(:) + REAL, SAVE, ALLOCATABLE :: Glacr_air_5avtemp1(:), Glacr_air_deltemp(:), Glacr_air_5avtemp(:) + REAL, SAVE, ALLOCATABLE :: Glacr_5avsnow1(:), Glacr_5avsnow(:),Glacr_delsnow(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pkwater_ante(:), Glacr_pkwater_equiv(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Glacr_pk_depth(:), Glacr_pss(:), Glacr_pst(:) + !**************************************************************** + ! Declared Parameters + + INTEGER, SAVE, ALLOCATABLE :: Melt_look(:), Melt_force(:), Tstorm_mo(:, :) + INTEGER, SAVE, ALLOCATABLE :: Hru_deplcrv(:) + REAL, SAVE :: Albset_rnm, Albset_rna, Albset_snm, Albset_sna + REAL, SAVE, ALLOCATABLE :: Emis_noppt(:), Freeh2o_cap(:), Cecn_coef(:, :) + REAL, SAVE :: Den_init, Settle_const, Den_max + REAL, SAVE, ALLOCATABLE :: Rad_trncf(:), Snarea_thresh(:), Snowpack_init(:) + REAL, SAVE, ALLOCATABLE :: Snarea_curve(:, :) +! Glacier parameters + REAL, SAVE, ALLOCATABLE :: Glacr_layer(:), Albedo_coef(:), Albedo_ice(:) + REAL, SAVE, ALLOCATABLE :: Glacr_freeh2o_cap(:), Glacier_frac_init(:), Glrette_frac_init(:) + + END MODULE PRMS_SNOW + +!*********************************************************************** +! Main snowcomp routine +!*********************************************************************** + INTEGER FUNCTION snowcomp() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: snodecl, snoinit, snorun + EXTERNAL :: snowcomp_restart +!*********************************************************************** + snowcomp = 0 + + IF ( Process(:3)=='run' ) THEN + snowcomp = snorun() + ELSEIF ( Process(:4)=='decl' ) THEN + snowcomp = snodecl() + ELSEIF ( Process(:4)=='init' ) THEN + snowcomp = snoinit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL snowcomp_restart(0) + ENDIF + + END FUNCTION snowcomp + +!*********************************************************************** +! snodecl - set up parameters for snowmelt computations +! Declared Parameters +! den_init, settle_const, den_max, melt_look +! melt_force, rad_trncf, hru_deplcrv, snarea_curve, snarea_thresh +! albset_rnm, albset_rna, albset_snm, albset_sna, potet_sublim +! emis_noppt, cecn_coef, freeh2o_cap, tstorm_mo, tmax_allsnow +! hru_area, cov_type, covden_win +! glacr_freeh2o_cap, glacr_layer +!*********************************************************************** + INTEGER FUNCTION snodecl() + USE PRMS_SNOW + USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag, Model, & + & Frozen_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80) :: Version_snowcomp +!*********************************************************************** + snodecl = 0 + + Version_snowcomp = 'snowcomp.f90 2018-05-04 09:41:00Z' + CALL print_module(Version_snowcomp, 'Snow Dynamics ', 90) + MODNAME = 'snowcomp' + +! declare variables + ALLOCATE ( Scrv(Nhru) ) + IF ( declvar(MODNAME, 'scrv', 'nhru', Nhru, 'double', & + & 'Snowpack water equivalent plus a portion of new snow on each HRU', & + & 'inches', Scrv)/=0 ) CALL read_error(3, 'scrv') + + ALLOCATE ( Pksv(Nhru) ) + IF ( declvar(MODNAME, 'pksv', 'nhru', Nhru, 'double', & + & 'Snowpack water equivalent when there is new snow and in melt phase;'// & + & ' used to interpolate between depletion curve and 100 percent on each HRU', & + & 'inches', Pksv)/=0 ) CALL read_error(3, 'pksv') + + ALLOCATE ( Snowcov_areasv(Nhru) ) + IF ( declvar(MODNAME, 'snowcov_areasv', 'nhru', Nhru, 'real', & + & 'Snow cover fraction when there is new snow and in melt phase;'// & + & ' used to interpolate between depletion curve and 100 percent on each HRU', & + & 'decimal fraction', Snowcov_areasv)/=0 ) CALL read_error(3, 'snowcov_areasv') + + ALLOCATE ( Salb(Nhru) ) + IF ( declvar(MODNAME, 'salb', 'nhru', Nhru, 'real', & + & 'Days since last new snow to reset albedo for each HRU', & + & 'days', Salb)/=0 ) CALL read_error(3, 'salb') + + ALLOCATE ( Slst(Nhru) ) + IF ( declvar(MODNAME, 'slst', 'nhru', Nhru, 'real', & + & 'Days since last new snow for each HRU', & + & 'days', Slst)/=0 ) CALL read_error(3, 'slst') + + ALLOCATE ( Int_alb(Nhru) ) + IF ( declvar(MODNAME, 'int_alb', 'nhru', Nhru, 'integer', & + & 'Flag to indicate (1: accumulation season curve; 2: use of the melt season curve)', & + & 'none', Int_alb)/=0 ) CALL read_error(3, 'int_alb') + +! Glacier declares + IF ( Glacier_flag==1 .OR. Frozen_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Ann_tempc(Nhru) ) + IF ( declvar(MODNAME, 'ann_tempc', 'nhru', Nhru, 'real', & + & 'Current average year air temperature over HRU', & + & 'degrees Celsius', Ann_tempc)/=0 ) CALL read_error(3, 'ann_tempc') + ALLOCATE ( Prev_ann_tempc(Nhru) ) + ENDIF + + IF ( Glacier_flag==1 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'yrdays5', 'one', 1, 'integer', & + & 'Number of days since last 5 year mark', & + & 'none', Yrdays5)/=0 ) CALL read_error(3, 'yrdays5') + + ALLOCATE ( Glacr_freeh2o_capm(Nhru) ) + IF ( declvar(MODNAME, 'glacr_freeh2o_capm', 'nhru', Nhru, 'real', & + & 'Free-water holding capacity of glacier ice, changes to 0 if active layer melts', & + & 'decimal fraction', Glacr_freeh2o_capm)/=0 ) CALL read_error(3, 'glacr_freeh2o_capm') + + ALLOCATE ( Glacrb_melt(Nhru) ) + IF ( declvar(MODNAME, 'glacrb_melt', 'nhru', Nhru, 'real', & + 'Glacier basal melt, goes to soil', & + 'inches/day', Glacrb_melt)/=0 ) CALL read_error(3, 'glacrb_melt') + + ALLOCATE ( Glacr_air_5avtemp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_5avtemp', 'nhru', Nhru, 'real', & + & 'Current 5-yr average summer (June July Aug) air temperature over glacier or glrette HRU', & + & 'degrees Celsius', Glacr_air_5avtemp)/=0 ) CALL read_error(3, 'glacr_air_5avtemp') + + ALLOCATE ( Glacr_air_5avtemp1(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_5avtemp1', 'nhru', Nhru, 'real', & + & 'First 5-yr average summer temperature over glacier or glrette HRU', & + & 'degrees Celsius', Glacr_air_5avtemp1)/=0 ) CALL read_error(3, 'glacr_air_5avtemp1') + + ALLOCATE ( Glacr_air_deltemp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_air_deltemp', 'nhru', Nhru, 'real', & + & 'Change in 5-yr average air temperature over glacier or glrette HRU from first', & + & 'degrees Celsius', Glacr_air_deltemp)/=0 ) CALL read_error(3, 'glacr_air_deltemp') + + ALLOCATE ( Glacr_5avsnow(Nhru) ) + IF ( declvar(MODNAME, 'glacr_5avsnow', 'nhru', Nhru, 'real', & + & 'Current 5-yr average snow over glacier or glrette HRU', & + & 'inches/yr', Glacr_5avsnow)/=0 ) CALL read_error(3, 'glacr_5avsnow') + + ALLOCATE ( Glacr_5avsnow1(Nhru) ) + IF ( declvar(MODNAME, 'glacr_5avsnow1', 'nhru', Nhru, 'real', & + & 'First 5-yr average snow over glacier or glrette HRU', & + & 'inches/yr', Glacr_5avsnow1)/=0 ) CALL read_error(3, 'glacr_5avsnow1') + + ALLOCATE ( Glacr_delsnow(Nhru) ) + IF ( declvar(MODNAME, 'glacr_delsnow', 'nhru', Nhru, 'real', & + & 'Change in 5-yr average snow over glacier or glrette HRU from first', & + & 'inches/yr', Glacr_delsnow)/=0 ) CALL read_error(3, 'glacr_delsnow') + + ALLOCATE ( Glacr_pk_temp(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_temp', 'nhru', Nhru, 'real', & + & 'Temperature of the glacier on each HRU', & + & 'degrees Celsius', Glacr_pk_temp)/=0 ) CALL read_error(3, 'glacr_pk_temp') + + ALLOCATE ( Glacr_pk_def(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_def', 'nhru', Nhru, 'real', & + & 'Heat deficit, amount of heat necessary to make the glacier snowpack isothermal at 0 degrees Celsius', & + & 'Langleys', Glacr_pk_def)/=0 ) CALL read_error(3, 'glacr_pk_def') + + ALLOCATE ( Glacr_pk_den(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_den', 'nhru', Nhru, 'real', & + & 'Density of the icepack on each glacier HRU, hard-coded to equal 0.917', & + & 'gm/cm3', Glacr_pk_den)/=0 ) CALL read_error(3, 'glacr_pk_den') + + ALLOCATE ( Glacr_albedo(Nhru) ) + IF ( declvar(MODNAME, 'glacr_albedo', 'nhru', Nhru, 'real', & + & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier HRU', & + & 'decimal fraction', Glacr_albedo)/=0 ) CALL read_error(3, 'glacr_albedo') + + ALLOCATE ( Glacr_evap(Nhru) ) + IF ( declvar(MODNAME, 'glacr_evap', 'nhru', Nhru, 'real', & + & 'Evaporation and sublimation from icepack on each glacier HRU', & + & 'inches', Glacr_evap)/=0 ) CALL read_error(3, 'glacr_evap') + + ALLOCATE ( Glacrmelt(Nhru) ) + IF ( declvar(MODNAME, 'glacrmelt', 'nhru', Nhru, 'real', & + & 'Melt from icepack on each glacier HRU, includes rain water that does not absorb', & + & 'inches', Glacrmelt)/=0 ) CALL read_error(3, 'glacrmelt') + + ALLOCATE ( Glacr_pkwater_equiv(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pkwater_equiv', 'nhru', Nhru, 'double', & + & 'Icepack water equivalent on each glacier HRU', & + & 'inches', Glacr_pkwater_equiv)/=0 ) CALL read_error(3, 'glacr_pkwater_equiv') + + ALLOCATE ( Glacr_pkwater_ante(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pkwater_ante', 'nhru', Nhru, 'double', & + & 'Antecedent icepack water equivalent on each glacier HRU', & + & 'inches', Glacr_pkwater_ante)/=0 ) CALL read_error(3, 'glacr_pkwater_ante') + + ALLOCATE ( Glacrcov_area(Nhru) ) + IF ( declvar(MODNAME, 'glacrcov_area', 'nhru', Nhru, 'real', & + & 'Ice-covered area on each glacier HRU or HRU with glacierette at start of step', & + & 'decimal fraction', Glacrcov_area)/=0 ) CALL read_error(3, 'glacrcov_area') + + ALLOCATE ( Glacr_pk_ice(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_ice', 'nhru', Nhru, 'real', & + & 'Storage of frozen water in the icepack on each glacier HRU', & + & 'inches', Glacr_pk_ice)/=0 ) CALL read_error(3, 'glacr_pk_ice') + + ALLOCATE ( Glacr_freeh2o(Nhru) ) + IF ( declvar(MODNAME, 'glacr_freeh2o', 'nhru', Nhru, 'real', & + & 'Storage of free liquid water in the icepack on each glacier HRU', & + & 'inches', Glacr_freeh2o)/=0 ) CALL read_error(3, 'glacr_freeh2o') + + ALLOCATE ( Glacr_pk_depth(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pk_depth', 'nhru', Nhru, 'double', & + & 'Depth of icepack on each glacier HRU, make essentially infinite', & + & 'inches', Glacr_pk_depth)/=0 ) CALL read_error(3, 'glacr_pk_depth') + + ALLOCATE ( Glacr_pss(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pss', 'nhru', Nhru, 'double', & + & 'Previous glacier pack water equivalent plus new ice', & + & 'inches', Glacr_pss)/=0 ) CALL read_error(3, 'glacr_pss') + + ALLOCATE ( Glacr_pst(Nhru) ) + IF ( declvar(MODNAME, 'glacr_pst', 'nhru', Nhru, 'double', & + & 'While a icepack exists, glacr_pst tracks the maximum ice water equivalent of that icepack', & + & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') + + IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & + & 'Basin area-weighted average snow and glacier and glrette covered area', & + & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') + + ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) + IF ( declparam(MODNAME, 'glacr_freeh2o_cap', 'nhru', 'real', & + & '0.002', '0.0', '0.01', & + & 'Free-water holding capacity of glacier ice', & + & 'Free-water holding capacity of glacier ice expressed as a' // & + & ' decimal fraction of the frozen water content of the glacier ice (glacr_pk_ice)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacr_freeh2o_cap') + + ALLOCATE ( Glacr_layer(Nhru) ) + IF ( declparam(MODNAME, 'glacr_layer', 'nhru', 'real', & + & '3.94', '0.0', '590.6', & + & 'Active layer on glacier', & + & 'Active layer is 0 to 15 m (590.6 inches) thick at start of year, when' // & + & ' melts will set daily glacr_pk_temp to 0', & + & 'inches')/=0 ) CALL read_error(1, 'glacr_layer') + + IF ( Init_vars_from_file==0 ) THEN + ALLOCATE ( Glacier_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') + + ALLOCATE ( Glrette_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glrette_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glrette_frac_init') + + ENDIF + ENDIF + + IF ( Frozen_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Tcalin_nosnow(Nhru) ) + IF ( declvar(MODNAME, 'tcalin_nosnow', 'nhru', Nhru, 'real', & + & 'Net energy coming in on each HRU without snow or glacier', & + & 'Langleys', Tcalin_nosnow)/=0 ) CALL read_error(3, 'tcalin_nosnow') + + ALLOCATE ( Tcalin_snow(Nhru) ) + IF ( declvar(MODNAME, 'tcalin_snow', 'nhru', Nhru, 'real', & + & 'Net energy coming in on each HRU with snow', & + & 'Langleys', Tcalin_snow)/=0 ) CALL read_error(3, 'tcalin_snow') + + ALLOCATE ( Land_albedo(Nhru) ) + IF ( declvar(MODNAME, 'land_albedo', 'nhru', Nhru, 'real', & + & 'Land surface albedo or the fraction of radiation reflected from the'// & + & ' land surface for each HRU', & + & 'decimal fraction', land_albedo)/=0 ) CALL read_error(3, 'land_albedo') + + ENDIF + + + IF ( declvar(MODNAME, 'basin_snowdepth', 'one', 1, 'double', & + & 'Basin area-weighted average snow depth', & + & 'inches', Basin_snowdepth)/=0 ) CALL read_error(3, 'basin_snowdepth') + + ALLOCATE ( Pk_precip(Nhru) ) + IF ( declvar(MODNAME, 'pk_precip', 'nhru', Nhru, 'real', & + & 'Precipitation added to snowpack for each HRU', & + & 'inches', Pk_precip)/=0 ) CALL read_error(3, 'pk_precip') + + IF ( declvar(MODNAME, 'basin_pk_precip', 'one', 1, 'double', & + & 'Basin area-weighted average precipitation added to snowpack', & + & 'inches', Basin_pk_precip)/=0 ) CALL read_error(3, 'basin_pk_precip') + + ALLOCATE ( Albedo(Nhru) ) + IF ( declvar(MODNAME, 'albedo', 'nhru', Nhru, 'real', & + & 'Snow surface albedo or the fraction of radiation reflected from the'// & + & ' snowpack surface for each HRU', & + & 'decimal fraction', Albedo)/=0 ) CALL read_error(3, 'albedo') + + ALLOCATE ( Pk_temp(Nhru) ) + IF ( declvar(MODNAME, 'pk_temp', 'nhru', Nhru, 'real', & + & 'Temperature of the snowpack on each HRU', & + & 'degrees Celsius', Pk_temp)/=0 ) CALL read_error(3, 'pk_temp') + + ALLOCATE ( Pk_den(Nhru) ) + IF ( declvar(MODNAME, 'pk_den', 'nhru', Nhru, 'real', & + & 'Density of the snowpack on each HRU', & + & 'gm/cm3', Pk_den)/=0 ) CALL read_error(3, 'pk_den') + + IF ( declvar(MODNAME, 'basin_tcal', 'one', 1, 'double', & + & 'Basin area-weighted average net snowpack energy balance', & + & 'Langleys', Basin_tcal)/=0 ) CALL read_error(3, 'basin_tcal') + + ALLOCATE ( Tcal(Nhru) ) + IF ( declvar(MODNAME, 'tcal', 'nhru', Nhru, 'real', & + & 'Net snowpack energy balance on each HRU', & + & 'Langleys', Tcal)/=0 ) CALL read_error(3, 'tcal') + + ALLOCATE ( Snow_evap(Nhru) ) + IF ( declvar(MODNAME, 'snow_evap', 'nhru', Nhru, 'real', & + & 'Evaporation and sublimation from snowpack on each HRU', & + & 'inches', Snow_evap)/=0 ) CALL read_error(3, 'snow_evap') + + ALLOCATE ( Snowmelt(Nhru) ) + IF ( declvar(MODNAME, 'snowmelt', 'nhru', Nhru, 'real', & + & 'Snowmelt from snowpack on each HRU (not including snow on glacier)', & + & 'inches', Snowmelt)/=0 ) CALL read_error(3, 'snowmelt') + + IF ( declvar(MODNAME, 'basin_snowmelt', 'one', 1, 'double', & + & 'Basin area-weighted average snowmelt (not on including snow on glacier)', & + & 'inches', Basin_snowmelt)/=0 ) CALL read_error(3, 'basin_snowmelt') + + IF ( declvar(MODNAME, 'basin_pweqv', 'one', 1, 'double', & + & 'Basin area-weighted average snowpack water equivalent not including glacier', & + & 'inches', Basin_pweqv)/=0 ) CALL read_error(3, 'basin_pweqv') + + ALLOCATE ( Pkwater_ante(Nhru) ) + IF ( declvar(MODNAME, 'pkwater_ante', 'nhru', Nhru, 'double', & + & 'Antecedent snowpack water equivalent on each HRU', & + & 'inches', Pkwater_ante)/=0 ) CALL read_error(3, 'pkwater_ante') + + ALLOCATE ( Snowcov_area(Nhru) ) + IF ( declvar(MODNAME, 'snowcov_area', 'nhru', Nhru, 'real', & + & 'Snow-covered area on each HRU prior to melt and sublimation unless snowpack depleted', & + & 'decimal fraction', Snowcov_area)/=0 ) CALL read_error(3, 'snowcov_area') + + IF ( declvar(MODNAME, 'basin_snowevap', 'one', 1, 'double', & + & 'Basin area-weighted average evaporation and sublimation not including glacier', & + & 'inches', Basin_snowevap)/=0 ) CALL read_error(3, 'basin_snowevap') + + IF ( declvar(MODNAME, 'basin_snowcov', 'one', 1, 'double', & + & 'Basin area-weighted average snow-covered area', & + & 'decimal fraction', Basin_snowcov)/=0 ) CALL read_error(3, 'basin_snowcov') + + IF ( declvar(MODNAME, 'basin_glacrb_melt', 'one', 1, 'double', & + & 'Basin area-weighted average basal melt of glacier, goes to soil', & + & 'inches', Basin_glacrb_melt)/=0 ) CALL read_error(3, 'basin_glacrb_melt') + + IF ( declvar(MODNAME, 'basin_glacrevap', 'one', 1, 'double', & + & 'Basin area-weighted average glacier ice evaporation and sublimation', & + & 'inches', Basin_glacrevap)/=0 ) CALL read_error(3, 'basin_glacrevap') + + !rpayn commented + ALLOCATE ( Pptmix_nopack(Nhru) ) + IF ( declvar(MODNAME, 'pptmix_nopack', 'nhru', Nhru, 'integer', & + & 'Flag indicating that a mixed precipitation event has'// & + & ' occurred with no snowpack present on an HRU (1), otherwise (0)', & + & 'none', Pptmix_nopack)/=0 ) CALL read_error(3, 'pptmix_nopack') + + !rpayn commented + ALLOCATE ( Iasw(Nhru) ) + IF ( declvar(MODNAME, 'iasw', 'nhru', Nhru, 'integer', & + & 'Flag indicating that snow covered area is'// & + & ' interpolated between previous location on curve and'// & + & ' maximum (1), or is on the defined curve (0)', & + & 'none', Iasw)/=0 ) CALL read_error(3, 'iasw') + + !rpayn commented + ALLOCATE ( Iso(Nhru) ) + IF ( declvar(MODNAME, 'iso', 'nhru', Nhru, 'integer', & + & 'Flag to indicate if time is before (1) or after (2)'// & + & ' the day to force melt season (melt_force)', & + & 'none', Iso)/=0 ) CALL read_error(3, 'iso') + + !rpayn commented + ALLOCATE ( Mso(Nhru) ) + IF ( declvar(MODNAME, 'mso', 'nhru', Nhru, 'integer', & + & 'Flag to indicate if time is before (1) or after (2)'// & + & ' the first potential day for melt season (melt_look)', & + & 'none', Mso)/=0 ) CALL read_error(3, 'mso') + + !rpayn commented + ALLOCATE ( Lso(Nhru) ) + IF ( declvar(MODNAME, 'lso', 'nhru', Nhru, 'integer', & + & 'Counter for tracking the number of days the snowpack'// & + & ' is at or above 0 degrees Celsius', & + & 'number of iterations', Lso)/=0 ) CALL read_error(3, 'lso') + + !rpayn commented + ALLOCATE ( Lst(Nhru) ) + IF ( declvar(MODNAME, 'lst', 'nhru', Nhru, 'integer', & + & 'Flag indicating whether there was new snow that'// & + & ' was insufficient to reset the albedo curve (1)'// & + & ' (albset_snm or albset_sna), otherwise (0)', & + & 'none', Lst)/=0 ) CALL read_error(3, 'lst') + + !rpayn commented + ALLOCATE ( Pk_def(Nhru) ) + IF ( declvar(MODNAME, 'pk_def', 'nhru', Nhru, 'real', & + & 'Heat deficit, amount of heat necessary to make'// & + & ' the snowpack isothermal at 0 degrees Celsius', & + & 'Langleys', Pk_def)/=0 ) CALL read_error(3, 'pk_def') + + !rpayn commented + ALLOCATE ( Pk_ice(Nhru) ) + IF ( declvar(MODNAME, 'pk_ice', 'nhru', Nhru, 'real', & + & 'Storage of frozen water in the snowpack on each HRU', & + & 'inches', Pk_ice)/=0 ) CALL read_error(3, 'pk_ice') + + !rpayn commented + ALLOCATE ( Freeh2o(Nhru) ) + IF ( declvar(MODNAME, 'freeh2o', 'nhru', Nhru, 'real', & + & 'Storage of free liquid water in the snowpack on each HRU', & + & 'inches', Freeh2o)/=0 ) CALL read_error(3, 'freeh2o') + + !rpayn commented + ALLOCATE ( Pk_depth(Nhru) ) + IF ( declvar(MODNAME, 'pk_depth', 'nhru', Nhru, 'double', & + & 'Depth of snowpack on each HRU', & + & 'inches', Pk_depth)/=0 ) CALL read_error(3, 'pk_depth') + + !rpayn commented + ALLOCATE ( Pss(Nhru) ) + IF ( declvar(MODNAME, 'pss', 'nhru', Nhru, 'double', & + & 'Previous snowpack water equivalent plus new snow', & + & 'inches', Pss)/=0 ) CALL read_error(3, 'pss') + + !rpayn commented + ALLOCATE ( Pst(Nhru) ) + IF ( declvar(MODNAME, 'pst', 'nhru', Nhru, 'double', & + & 'While a snowpack exists, pst tracks the maximum'// & + & ' snow water equivalent of that snowpack', & + & 'inches', Pst)/=0 ) CALL read_error(3, 'pst') + + !rpayn commented + ALLOCATE ( Snsv(Nhru) ) + IF ( declvar(MODNAME, 'snsv', 'nhru', Nhru, 'real', & + & 'Tracks the cumulative amount of new snow until'// & + & ' there is enough to reset the albedo curve (albset_snm or albset_sna)', & + & 'inches', Snsv)/=0 ) CALL read_error(3, 'snsv') + + ALLOCATE ( Ai(Nhru) ) + IF ( declvar(MODNAME, 'ai', 'nhru', Nhru, 'double', & + & 'Maximum snowpack for each HRU', & + & 'inches', Ai)/=0 ) CALL read_error(3, 'ai') + + ALLOCATE ( Frac_swe(Nhru) ) + IF ( declvar(MODNAME, 'frac_swe', 'nhru', Nhru, 'real', & + & 'Fraction of maximum snow-water equivalent (snarea_thresh) on each HRU', & + & 'decimal fraction', Frac_swe)/=0 ) CALL read_error(3, 'frac_swe') + +! declare parameters + IF ( Glacier_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Albedo_coef(Nhru) ) + IF ( declparam(MODNAME, 'albedo_coef', 'nhru', 'real', & + & '0.137', '0.1', '0.3', & + & 'Coefficient in calculation of ice albedo', & + & 'Coefficient in calculation of ice albedo', & + & 'none')/=0 ) CALL read_error(1, 'albedo_coef') + + ALLOCATE ( Albedo_ice(Nhru) ) + IF ( declparam(MODNAME, 'albedo_ice', 'nhru', 'real', & + & '0.344', '0.2', '0.6', & + & 'Ice albedo 300 meters below ELA', & + & 'Ice albedo 300 meters below ELA', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo_ice') + ENDIF + + IF ( declparam(MODNAME, 'den_init', 'one', 'real', & + & '0.10', '0.01', '0.5', & + & 'Initial density of new-fallen snow', & + & 'Initial density of new-fallen snow', & + & 'gm/cm3')/=0 ) CALL read_error(1, 'den_init') + + IF ( declparam(MODNAME, 'settle_const', 'one', 'real', & + & '0.10', '0.01', '0.5', & + & 'Snowpack settlement time constant', & + & 'Snowpack settlement time constant', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'settle_const') + + IF ( declparam(MODNAME, 'den_max', 'one', 'real', & + & '0.6', '0.1', '0.8', & + & 'Average maximum snowpack density', & + & 'Average maximum snowpack density', & + & 'gm/cm3')/=0 ) CALL read_error(1, 'den_max') + + ALLOCATE ( Melt_look(Nhru) ) + IF ( declparam(MODNAME, 'melt_look', 'nhru', 'integer', & + & '90', '1', '366', & + & 'Julian date to start looking for spring snowmelt for each HRU', & + & 'Julian date to start looking for spring snowmelt stage for each HRU;'// & + & ' varies with region depending on length of time that'// & + & ' permanent snowpack exists', & + & 'Julian day')/=0 ) CALL read_error(1, 'melt_look') + + ALLOCATE ( Melt_force(Nhru) ) + IF ( declparam(MODNAME, 'melt_force', 'nhru', 'integer', & + & '140', '1', '366', & + & 'Julian date to force snowpack to spring snowmelt stage for each HRU', & + & 'Julian date to force snowpack to spring snowmelt stage for each HRU;'// & + & ' varies with region depending on length of time that'// & + & ' permanent snowpack exists', & + & 'Julian day')/=0 ) CALL read_error(1, 'melt_force') + + ALLOCATE ( Rad_trncf(Nhru) ) + IF ( declparam(MODNAME, 'rad_trncf', 'nhru', 'real', & + & '0.5', '0.0', '1.0', & + & 'Solar radiation transmission coefficient', & + & 'Transmission coefficient for short-wave radiation through'// & + & ' the winter vegetation canopy', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'rad_trncf') + + ALLOCATE ( Hru_deplcrv(Nhru) ) + IF ( declparam(MODNAME, 'hru_deplcrv', 'nhru', 'integer', & + & '1', 'bounded', 'ndepl', & + & 'Index number for snowpack areal depletion curve', & + & 'Index number for the snowpack areal depletion curve associated with each HRU', & + & 'none')/=0 ) CALL read_error(1, 'hru_deplcrv') + + ALLOCATE ( Snarea_curve(11, Ndepl) ) + IF ( declparam(MODNAME, 'snarea_curve', 'ndeplval', 'real', & + & '1.0', '0.0', '1.0', & + & 'Snow area depletion curve values', & + & 'Snow area depletion curve values, 11 values for each'// & + & ' curve (0.0 to 1.0 in 0.1 increments)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'snarea_curve') + + ALLOCATE ( Snarea_thresh(Nhru) ) + IF ( declparam(MODNAME, 'snarea_thresh', 'nhru', 'real', & + & '50.0', '0.0', '200.0', & + & 'Maximum threshold water equivalent for snow depletion', & + & 'Maximum threshold snowpack water equivalent below'// & + & ' which the snow-covered-area curve is applied', & + & 'inches')/=0 ) CALL read_error(1, 'snarea_thresh') + + IF ( declparam(MODNAME, 'albset_rnm', 'one', 'real', & + & '0.6', '0.4', '1.0', & + & 'Albedo reset - rain, melt stage', & + & 'Fraction of rain in a mixed precipitation event'// & + & ' above which the snow albedo is not reset; applied during'// & + & ' the snowpack melt stage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'albset_rnm') + + IF ( declparam(MODNAME, 'albset_rna', 'one', 'real', & + & '0.8', '0.5', '1.0', & + & 'Albedo reset - rain, accumulation stage', & + & 'Fraction of rain in a mixed precipitation event'// & + & ' above which the snow albedo is not reset; applied during'// & + & ' the snowpack accumulation stage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'albset_rna') + + IF ( declparam(MODNAME, 'albset_snm', 'one', 'real', & + & '0.2', '0.1', '1.0', & + & 'Albedo reset - snow, melt stage', & + & 'Minimum snowfall, in water equivalent, needed to reset'// & + & ' snow albedo during the snowpack melt stage', & + & 'inches')/=0 ) CALL read_error(1, 'albset_snm') + + IF ( declparam(MODNAME, 'albset_sna', 'one', 'real', & + & '0.05', '0.01', '1.0', & + & 'Albedo reset - snow, accumulation stage', & + & 'Minimum snowfall, in water equivalent, needed to reset'// & + & ' snow albedo during the snowpack accumulation stage', & + & 'inches')/=0 ) CALL read_error(1, 'albset_sna') + + ALLOCATE ( Emis_noppt(Nhru) ) + IF ( declparam(MODNAME, 'emis_noppt', 'nhru', 'real', & + & '0.757', '0.757', '1.0', & + & 'Emissivity of air on days without precipitation for each HRU', & + & 'Average emissivity of air on days without precipitation for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'emis_noppt') + + ALLOCATE ( Cecn_coef(Nhru,12) ) + IF ( declparam(MODNAME, 'cecn_coef', 'nhru,nmonths', 'real', & + & '5.0', '0.02', '20.0', & + & 'Monthly convection condensation energy coefficient for each HRU', & + & 'Monthly (January to December) convection condensation energy coefficient for each HRU', & + & 'calories per degree Celsius above 0')/=0 ) CALL read_error(1, 'cecn_coef') + + ALLOCATE ( Freeh2o_cap(Nhru) ) + IF ( declparam(MODNAME, 'freeh2o_cap', 'nhru', 'real', & + & '0.05', '0.01', '0.2', & + & 'Free-water holding capacity of snowpack for each HRU', & + & 'Free-water holding capacity of snowpack for each HRU, expressed as a'// & + & ' decimal fraction of the frozen water content of the snowpack (pk_ice)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'freeh2o_cap') + + ALLOCATE ( Tstorm_mo(Nhru,12) ) + IF ( declparam(MODNAME, 'tstorm_mo', 'nhru,nmonths', 'integer', & + & '0', '0', '1', & + & 'Set to 1 if thunderstorms prevalent during month for each HRU', & + & 'Monthly flag (January to December) for prevalent storm'// & + & ' type for each HRU (0=frontal storms; 1=convective storms)', & + & 'none')/=0 ) CALL read_error(1, 'tstorm_mo') + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==3 ) THEN + ALLOCATE ( Snowpack_init(Nhru) ) + IF ( declparam(MODNAME, 'snowpack_init', 'nhru', 'real', & + & '0.0', '0.0', '5000.0', & + & 'Initial snowpack water equivalent in each HRU', & + & 'Storage of snowpack in each HRU at the beginning of a simulation', & + & 'inches')/=0 ) CALL read_error(1, 'snowpack_init') + ENDIF + + END FUNCTION snodecl + +!*********************************************************************** +! snoinit - Initialize snowcomp module - get parameter values, +! compute initial values +!*********************************************************************** + INTEGER FUNCTION snoinit() + USE PRMS_SNOW + USE PRMS_MODULE, ONLY: Nhru, Ndepl, Init_vars_from_file, Glacier_flag, Frozen_flag + USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_route_order, Active_hrus, Hru_area_dble, & + & FEET2METERS, Elev_units, Hru_type +! USE PRMS_BASIN, ONLY: Hru_elev_feet + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Glrette_frac, Alt_above_ela + IMPLICIT NONE +! Functions + INTRINSIC :: DBLE, ATAN, SNGL + INTEGER, EXTERNAL :: getparam + EXTERNAL :: read_error, snowcomp_restart, sca_deplcrv, glacr_states_to_zero +! Local Variables + INTEGER :: i, j +! Save Variables + REAL, SAVE :: acum_init(MAXALB), amlt_init(MAXALB) + DATA acum_init/.80, .77, .75, .72, .70, .69, .68, .67, .66, .65, .64, .63, .62, .61, .60/ + DATA amlt_init/.72, .65, .60, .58, .56, .54, .52, .50, .48, .46, .44, .43, .42, .41, .40/ +!*********************************************************************** + snoinit = 0 + + IF ( Init_vars_from_file>0 ) CALL snowcomp_restart(1) + + IF ( Glacier_flag==1 ) THEN + IF ( getparam(MODNAME, 'glacr_freeh2o_cap', Nhru, 'real', Glacr_freeh2o_cap)/=0 ) CALL read_error(2, 'glacr_freeh2o_cap') + IF ( getparam(MODNAME, 'albedo_ice', Nhru, 'real', Albedo_ice)/=0 ) CALL read_error(2, 'albedo_ice') + IF ( getparam(MODNAME, 'albedo_coef', Nhru, 'real', Albedo_coef)/=0 ) CALL read_error(2, 'albedo_coef') + IF ( getparam(MODNAME, 'glacr_layer', Nhru, 'real', Glacr_layer)/=0 ) CALL read_error(2, 'glacr_layer') + + ENDIF + + IF ( getparam(MODNAME, 'den_init', 1, 'real', Den_init)/=0 ) CALL read_error(2, 'den_init') + Deninv = 1.0D0/DBLE(Den_init) + IF ( getparam(MODNAME, 'den_max', 1, 'real', Den_max)/=0 ) CALL read_error(2, 'den_max') + Denmaxinv = 1.0D0/DBLE(Den_max) + + IF ( getparam(MODNAME, 'settle_const', 1, 'real', Settle_const)/=0 ) CALL read_error(2, 'settle_const') + Settle_const_dble = DBLE( Settle_const ) +! Set1 = 1.0/(1.0+Settle_const) +! Setden = Settle_const/Den_max + + IF ( getparam(MODNAME, 'melt_look', Nhru, 'integer', Melt_look)/=0 ) CALL read_error(2, 'melt_look') + IF ( getparam(MODNAME, 'melt_force', Nhru, 'integer', Melt_force)/=0 ) CALL read_error(2, 'melt_force') + IF ( getparam(MODNAME, 'rad_trncf', Nhru, 'real', Rad_trncf)/=0 ) CALL read_error(2, 'rad_trncf') + IF ( getparam(MODNAME, 'hru_deplcrv', Nhru, 'integer', Hru_deplcrv)/=0 ) CALL read_error(2, 'hru_deplcrv') + IF ( getparam(MODNAME, 'snarea_curve', Ndepl*11, 'real', Snarea_curve)/=0 ) CALL read_error(2, 'snarea_curve') + IF ( getparam(MODNAME, 'snarea_thresh', Nhru, 'real', Snarea_thresh)/=0 ) CALL read_error(2, 'snarea_thresh') + IF ( getparam(MODNAME, 'albset_rnm', 1, 'real', Albset_rnm)/=0 ) CALL read_error(2, 'albset_rnm') + IF ( getparam(MODNAME, 'albset_rna', 1, 'real', Albset_rna)/=0 ) CALL read_error(2, 'albset_rna') + IF ( getparam(MODNAME, 'albset_sna', 1, 'real', Albset_sna)/=0 ) CALL read_error(2, 'albset_sna') + IF ( getparam(MODNAME, 'albset_snm', 1, 'real', Albset_snm)/=0 ) CALL read_error(2, 'albset_snm') + IF ( getparam(MODNAME, 'emis_noppt', Nhru, 'real', Emis_noppt)/=0 ) CALL read_error(2, 'emis_noppt') + IF ( getparam(MODNAME, 'cecn_coef', Nhru*12, 'real', Cecn_coef)/=0 ) CALL read_error(2, 'cecn_coef') + IF ( getparam(MODNAME, 'freeh2o_cap', Nhru, 'real', Freeh2o_cap)/=0 ) CALL read_error(2, 'freeh2o_cap') + IF ( getparam(MODNAME, 'tstorm_mo', Nhru*12, 'integer', Tstorm_mo)/=0 ) CALL read_error(2, 'tstorm_mo') + + Pk_precip = 0.0 + Snowmelt = 0.0 + Snow_evap = 0.0 + Pptmix_nopack = 0 + Tcal = 0.0 + Frac_swe = 0.0 + Acum = acum_init + Amlt = amlt_init + IF (Frozen_flag==1) THEN + Tcalin_nosnow = 0.0 + Tcalin_snow = 0.0 + Land_albedo = 0.0 + ENDIF + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==3 ) THEN + IF ( getparam(MODNAME, 'snowpack_init', Nhru, 'real', Snowpack_init)/=0 ) CALL read_error(2, 'snowpack_init') + Pkwater_equiv = 0.0D0 + Pk_depth = 0.0D0 + Pk_den = 0.0 + Pk_ice = 0.0 + Freeh2o = 0.0 + Ai = 0.0D0 + Snowcov_area = 0.0 + Basin_pweqv = 0.0D0 + Basin_snowdepth = 0.0D0 + Basin_snowcov = 0.0D0 + Basin_snowicecov = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + Pkwater_equiv(i) = DBLE( Snowpack_init(i) ) + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*Hru_area_dble(i) + Pk_depth(i) = Pkwater_equiv(i)*Deninv + Pk_den(i) = SNGL( Pkwater_equiv(i)/Pk_depth(i) ) + Pk_ice(i) = SNGL( Pkwater_equiv(i) ) + Freeh2o(i) = Pk_ice(i)*Freeh2o_cap(i) + Ai(i) = Pkwater_equiv(i) ! [inches] + IF ( Ai(i)>Snarea_thresh(i) ) Ai(i) = DBLE( Snarea_thresh(i) ) ! [inches] + Frac_swe(i) = SNGL( Pkwater_equiv(i)/Ai(i) ) ! [fraction] + CALL sca_deplcrv(Snowcov_area(i), Snarea_curve(1,Hru_deplcrv(i)), Frac_swe(i)) + Basin_snowcov = Basin_snowcov + DBLE(Snowcov_area(i))*Hru_area_dble(i) + Basin_snowdepth = Basin_snowdepth + Pk_depth(i)*Hru_area_dble(i) + ENDIF + ENDDO + Basin_pweqv = Basin_pweqv*Basin_area_inv + Basin_snowcov = Basin_snowcov*Basin_area_inv + Basin_snowdepth = Basin_snowdepth*Basin_area_inv + DEALLOCATE ( Snowpack_init ) + Pkwater_ante = Pkwater_equiv + Pss = Pkwater_equiv + Pst = Pkwater_equiv + + IF ( Glacier_flag==1 ) THEN ! do here when not a restart simulation + IF ( getparam(MODNAME, 'glacier_frac_init', Nhru, 'real', Glacier_frac_init)/=0 ) CALL read_error(2, 'glacier_frac_init') + Glacr_albedo = 0.0 + Glacier_frac = Glacier_frac_init + IF ( getparam(MODNAME, 'glrette_frac_init', Nhru, 'real', Glrette_frac_init)/=0 ) CALL read_error(2, 'glrette_frac_init') + Glrette_frac = Glrette_frac_init + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Glacier_frac(i)>0.0 ) THEN + IF ( Hru_type(i)==4 ) THEN + IF ( Elev_units==0 ) THEN !from Oerlemans 1992 + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)*FEET2METERS+300.0)/200.0 ) + ELSE + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) + ENDIF + ELSE + PRINT *, 'Warning, glacier_frac > 0, but hru_type not equal to 4, glacier_frac set to 0' + PRINT *, 'in HRU ', i, 'glacier_frac_init = ',Glacier_frac_init(i) + Glacier_frac(i) = 0.0 + ENDIF + ENDIF + IF ( Glrette_frac(i)>0.0 ) THEN + IF ( Hru_type(i)==1 ) THEN + Glacr_albedo(i) = Albedo_ice(i) + ELSE + PRINT *, 'Warning, glrette_frac > 0, but hru_type not equal to 1, glrette_frac set to 0' + PRINT *, 'in HRU ', i, 'glrette_frac_init = ',Glrette_frac_init(i) + Glrette_frac(i) = 0.0 + ENDIF + ENDIF + ENDDO + DEALLOCATE ( Glacier_frac_init ) + ENDIF + ENDIF + + IF ( Init_vars_from_file>0 ) RETURN + Basin_tcal = 0.0D0 + Iasw = 0 + Iso = 1 + Mso = 1 + Lso = 0 + Pk_def = 0.0 + Pk_temp = 0.0 + Albedo = 0.0 + Snsv = 0.0 + Lst = 0 + Int_alb = 1 + Salb = 0.0 + Slst = 0.0 + Snowcov_areasv = 0.0 + Scrv = 0.0D0 + Pksv = 0.0D0 + Basin_snowmelt = 0.0D0 + Basin_snowevap = 0.0D0 + Basin_pk_precip = 0.0D0 + + Yrdays5 = 0 + Basin_glacrb_melt = 0.0D0 + Basin_glacrevap = 0.0D0 + IF ( Glacier_flag==1 .OR. Frozen_flag==1) THEN + Ann_tempc = 0.0 + Prev_ann_tempc = 0.0 + ENDIF + IF ( Glacier_flag==1 ) THEN + Alt_above_ela = 0.0 + Glacr_air_5avtemp = 0.0 + Glacr_air_5avtemp1 = 0.0 + Glacr_air_deltemp = 0.0 + Glacr_5avsnow = 0.0 + Glacr_5avsnow1 = 0.0 + Glacr_delsnow = 0.0 + Glacrb_melt = 0.0 + Glacrmelt = 0.0 + Glacr_pk_den = 0.0 + Glacr_pk_temp = 0.0 + Glacr_pk_ice = 0.0 + Glacr_pk_def = 0.0 + Glacr_pkwater_equiv = 0.0D0 + Glacr_pkwater_ante = 0.0D0 + Glacr_evap = 0.0 + Glacr_freeh2o = 0.0 + Glacr_pk_depth = 0.0D0 + Glacr_pst = 0.0D0 + Glacr_pss = 0.0D0 + Glacrcov_area = 0.0 + Glacr_freeh2o_capm = Glacr_freeh2o_cap + DO j = 1, Active_hrus + i = Hru_route_order(j) + IF ( Glacier_frac(i)>0.0 .AND. Hru_type(i)==4 ) CALL glacr_states_to_zero(i,1) + ENDDO + ENDIF + + END FUNCTION snoinit + +!*********************************************************************** +! snorun - daily mode snow estimates +!*********************************************************************** + INTEGER FUNCTION snorun() + USE PRMS_SNOW + USE PRMS_MODULE, ONLY: Nhru, Print_debug, Glacier_flag, Starttime, Frozen_flag + USE PRMS_BASIN, ONLY: DNEARZERO, Hru_area, Active_hrus, Hru_type, & + & Basin_area_inv, Hru_route_order, Cov_type, INCH2M, FEET2METERS, Elev_units + USE PRMS_CLIMATEVARS, ONLY: Newsnow, Pptmix, Orad, Basin_horad, Potet_sublim, & + & Hru_ppt, Prmx, Tmaxc, Tminc, Tavgc, Swrad, Potet, Transp_on, Tmax_allsnow_c + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv, Glacier_frac, Glrette_frac, Alt_above_ela + USE PRMS_SET_TIME, ONLY: Jday, Nowmonth, Julwater, Nowyear + USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Canopy_covden, Hru_intcpevap + IMPLICIT NONE +! Functions + EXTERNAL ppt_to_pack, snowcov, snalbedo, snowbal, snowevap, glacr_states_to_zero + INTRINSIC ABS, SQRT, DBLE, SNGL, EXP, DABS, MOD, ATAN +! Local Variables + INTEGER :: i, j, k, niteda, isglacier, ijunk, Active_frozen + REAL :: trd, sw, effk, cst, temp, cals, emis, esv, swn, cec + REAL :: ieffk, icst, icals, isw, iswn, frac, lswn, lsw, rjunk + DOUBLE PRECISION :: dpt1, dpt_before_settle, djunk, djunk2 +!*********************************************************************** + snorun = 0 + + ! Set the basin totals to 0 + ! (recalculated at the end of the time step) + Basin_snowmelt = 0.0D0 + Basin_pweqv = 0.0D0 + Basin_snowevap = 0.0D0 + Basin_snowcov = 0.0D0 + Basin_snowicecov = 0.0D0 + Basin_pk_precip = 0.0D0 + Basin_snowdepth = 0.0D0 + Basin_tcal = 0.0D0 + IF ( Glacier_flag==1 ) THEN + Basin_glacrb_melt = 0.0D0 + Basin_glacrevap = 0.0D0 + ENDIF + + ! Calculate the ratio of measured radiation to potential radiation + ! (used as a cumulative indicator of cloud cover) + trd = Orad/SNGL(Basin_horad) ! [dimensionless ratio] + IF ( Julwater==1 .AND. MOD(Nowyear-Starttime(1),5)==0 ) Yrdays5 = 0 + + ! Loop through all the active HRUs, in routing order + DO j = 1, Active_hrus + i = Hru_route_order(j) ! [counter] + + ! Skip the HRU if it is a lake + IF ( Hru_type(i)==2 ) CYCLE !AVB 7/18/19 we want to do frozen ground under lakes? + + Active_glacier = 0 + Active_frozen = 0 + isglacier = 0 + IF (Frozen_flag==1) Active_frozen = 1 + IF ( Hru_type(i)==4 .OR. Hru_type(i)==1 ) THEN + IF ( Glacier_flag==1 ) THEN + Glacrmelt(i) = 0.0 ! [inches] + Glacrb_melt(i) = 0.0 ! [inches] + Glacr_evap(i) = 0.0 ! [inches] + Glacr_pkwater_ante(i) = Glacr_pkwater_equiv(i) + IF ( Glacier_frac(i)==1.0 .OR. Glrette_frac(i)==1.0 ) Active_frozen = 0 !no need to separately calculate energy if glacier + IF ( Glacier_frac(i)>0.0 .OR. Glrette_frac(i)>0.0 ) THEN + IF (Glacier_frac(i)>0.0) Active_glacier = 1 + IF (Glrette_frac(i)>0.0) Active_glacier = 2 + Glacr_pk_den(i) = 0.917 + ! if no active layer make 0 deg and no holding capacity at start of each day + IF ( Glacr_layer(i)==0.0 .OR. Glacr_pk_depth(i)>1.0D3 ) THEN + Glacr_pk_def(i) = 0.0 + Glacr_pk_temp(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + ENDIF + ELSE !zero out states for glacier if gone (glacier state changes in glacier module, not here) + Glacr_pkwater_equiv(i) = 0.D0 + Glacrcov_area(i) = 0.0 + Glacr_pk_def(i) = 0.0 + Glacr_pk_temp(i) = 0.0 + Glacr_pk_ice(i) = 0.0 + Glacr_freeh2o(i) = 0.0 + Glacr_pk_depth(i) = 0.D0 + Glacr_pss = 0.0D0 + Glacr_pst(i) = 0.0D0 + Glacr_pk_den(i) = 0.0 + Glacr_freeh2o_capm(i) = 0.0 + Glacr_albedo(i) = 0.0 + ENDIF + isglacier = 1 + ENDIF + ENDIF + + ! If it's the first julian day of the water year, several + ! variables need to be reset + ! - reset the previous snow water eqivalent plus new snow to 0 + ! - reset flags to indicate it is not melt season or potetential melt season + ! - reset the counter for the number of days a snowpack is at 0 deg Celsius + !rsr, do we want to reset all HRUs, what about Southern Hemisphere + IF ( Julwater==1 ) THEN + Pss(i) = 0.0D0 ! [inches] + Iso(i) = 1 ! [flag] + Mso(i) = 1 ! [flag] + Lso(i) = 0 ! [counter] + + + IF ( Active_glacier>=1 ) CALL glacr_states_to_zero(i,1) !all snow on glacier becomes firn, reset active layer thickness + IF ( Active_glacier==1 ) THEN +! If Active_glacier>=1 we are zeroing out snowpack if have glacierettes even though possibly a lot of HRU is not glacierized. +! If Active_glacier==1 do not zero out glacierettes, but then will maybe never melt ice on glacierettes. If the climate is +! correct the snowpack will deplete quick because there is a lot of lower elevation than the glacierette included in the HRU. +! Choice does not effect runoff much, but will effect Basin_pweqv and things like that + ! if terminus glacier, and has snow will disappear off glacier but that is likely anyhow + Pkwater_equiv(i) = 0.0 + Pk_depth(i) = 0.0D0 + Pss(i) = 0.0D0 + Snsv(i) = 0.0 + Lst(i) = 0 + Pst(i) = 0.0D0 + Iasw(i) = 0 + Pk_den(i) = 0.0 + Snowcov_area(i) = 0.0 + Pk_def(i) = 0.0 + Pk_temp(i) = 0.0 + Pk_ice(i) = 0.0 + Freeh2o(i) = 0.0 + Snowcov_areasv(i) = 0.0 ! rsr, not in original code + Ai(i) = 0.0D0 + Frac_swe(i) = 0.0 + IF ( Elev_units==0 ) THEN !from Oerlemans 1992 + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)*FEET2METERS+300.0)/200.0 ) + ELSE + Glacr_albedo(i) = Albedo_ice(i) +(Albedo_coef(i)/PI)*ATAN( (Alt_above_ela(i)+300.0)/200.0 ) + ENDIF + ENDIF + IF ( Active_glacier==2 ) Glacr_albedo(i) = Albedo_ice(i) !glacr_albedo doesn't change if glacierette but could get zeroed out + IF ( isglacier==1 ) THEN + IF (Nowyear >= Starttime(1)+10 .AND. MOD(Nowyear-Starttime(1),5)==0 ) THEN + Glacr_air_deltemp(i) = Glacr_air_5avtemp1(i) - Glacr_air_5avtemp(i) !need 5 years of data + Glacr_delsnow(i) = 10.0*(Glacr_5avsnow1(i) - Glacr_5avsnow(i))/Glacr_5avsnow1(i) !number of 10 percent (*100.0/10.0) changes + ENDIF + !keep before restart + IF ( MOD(Nowyear-Starttime(1),5)==0 ) THEN + IF ( Nowyear-Starttime(1)==5 ) THEN + Glacr_air_5avtemp1(i) = Glacr_air_5avtemp(i) + Glacr_5avsnow1(i) = Glacr_5avsnow(i) + ENDIF + Glacr_air_5avtemp(i) = 0.0 !zero out for new year restart + Glacr_5avsnow(i) = 0.0 !zero out for new year restart + ENDIF + ENDIF + Prev_ann_tempc(i) = Ann_tempc(i) + Ann_tempc(i) = 0.0 !zero out for new year restart + ENDIF !end start of year calculations + +! Do for summer + IF ( isglacier==1 ) THEN + IF (Julwater>151 .AND. Julwater<244) THEN ! Now following McGrath et al 2017, temp June-August, 92 days + Yrdays5 = Yrdays5 + 1 + Glacr_air_5avtemp(i) = ( Glacr_air_5avtemp(i)*(Yrdays5-1)+ Tavgc(i) )/Yrdays5 + ENDIF +! Do for every time step + Glacr_5avsnow(i) = Glacr_5avsnow(i) + Net_snow(i)/5.0 + ENDIF + Ann_tempc(i) = ( Ann_tempc(i)*(Julwater-1)+ Tavgc(i) )/Julwater + + ! HRU SET-UP - SET DEFAULT VALUES AND/OR BASE + ! CONDITIONS FOR THIS TIME PERIOD + !************************************************************** + + ! Keep track of the pack water equivalent before it is changed + ! by precipitation during this time step + Pkwater_ante(i) = Pkwater_equiv(i) + + ! By default, the precipitation added to snowpack, snowmelt, + ! and snow evaporation are 0 + Pk_precip(i) = 0.0 ! [inches] + Snowmelt(i) = 0.0 ! [inches] + Snow_evap(i) = 0.0 ! [inches] + Frac_swe(i) = 0.0 + Ai(i) = 0.0D0 + Tcal(i) = 0.0 + IF (Frozen_flag==1) THEN + Tcalin_nosnow(i) = 0.0 + Tcalin_snow(i) = 0.0 + ENDIF + + ! By default, there has not been a mixed event without a + ! snowpack + Pptmix_nopack(i) = 0 ! [flag] + + ! If the day of the water year is beyond the forced melt day + ! indicated by the parameter, then set the flag indicating + ! melt season + !rsr, need to rethink this at some point +!rsr10 IF ( Iso(i)/=2 ) THEN + IF ( Jday==Melt_force(i) ) Iso(i) = 2 ! [flag] +!rsr10 ENDIF + + ! If the day of the water year is beyond the first day to + ! look for melt season indicated by the parameter, + ! then set the flag indicating to watch for melt season + !rsr, need to rethink this at some point +!rsr10 IF ( Mso(i)/=2 ) THEN + IF ( Jday==Melt_look(i) ) Mso(i) = 2 ! [flag] +!rsr10 ENDIF + + ! Skip the HRU if there is no snowpack and no new snow and not a glacier and no frozen ground + IF ( Pkwater_equiv(i)0.0D0.AND.Net_ppt(i)>0.0) .OR. Net_snow(i)>0.0 ) & + & CALL ppt_to_pack(Pptmix(i), Iasw(i), Tmaxc(i), Tminc(i), & + & Tavgc(i), Pkwater_equiv(i), Net_rain(i), Pk_def(i), & + & Pk_temp(i), Pk_ice(i), Freeh2o(i), Snowcov_area(i), & + & Snowmelt(i), Pk_depth(i), Pss(i), Pst(i), Net_snow(i), & + & Pk_den(i), Pptmix_nopack(i), Pk_precip(i), Tmax_allsnow_c(i,Nowmonth), Freeh2o_cap(i), -1) + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0.AND.Glacr_pkwater_ante(i)>0.0D0.AND.Net_ppt(i)>0.0 & + & .AND.Pptmix(i)==0.AND.Net_snow(i)==0.0 ) THEN + CALL ppt_to_pack(0, Iasw(i), Tmaxc(i), Tminc(i), & + & Tavgc(i), Glacr_Pkwater_equiv(i), Net_rain(i), Glacr_pk_def(i), & + & Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), Glacrcov_area(i), & + & Glacrmelt(i), Glacr_pk_depth(i), Glacr_pss(i), Glacr_pst(i), 0.0, & + & Glacr_pk_den(i), Pptmix_nopack(i), Pk_precip(i), Tmax_allsnow_c(i,Nowmonth), Glacr_freeh2o_capm(i), i) + ENDIF + ENDIF +! FOLLOWING does basal melt on glacier +!Paterson 2010 says 12 mm/yr for friction and geothermal heating + IF ( Active_glacier==1 ) Glacrb_melt(i) = 12.0*0.03937/365.242*Glacier_frac(i) + IF ( Active_glacier==2 ) Glacrb_melt(i) = 12.0*0.03937/365.242*Glrette_frac(i) !since not moving much, maybe =0 + + ! If there is still a snowpack + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + + ! HRU STEP 2 - CALCULATE THE NEW SNOW COVERED AREA + !********************************************************** + ! Compute snow-covered area from depletion curve + k = Hru_deplcrv(i) + ! calculate the new snow covered area + CALL snowcov(Iasw(i), Newsnow(i), Snowcov_area(i), & + & Snarea_curve(1, k), Pkwater_equiv(i), Pst(i), & + & Snarea_thresh(i), Net_snow(i), Scrv(i), & + & Pksv(i), Snowcov_areasv(i), Ai(i), Frac_swe(i)) + + ! HRU STEP 3 - COMPUTE THE NEW ALBEDO + !********************************************************** + + ! Compute albedo if there is any snowpack + CALL snalbedo(Newsnow(i), Iso(i), Lst(i), Snsv(i), & + & Prmx(i), Pptmix(i), Albset_rnm, Net_snow(i), & + & Albset_snm, Albset_rna, Albset_sna, Albedo(i), & + & Int_alb(i), Salb(i), Slst(i)) + ENDIF + IF ( Active_glacier==1 ) Glacrcov_area(i) =(1.0-Snowcov_area(i))*Glacier_frac(i) + IF ( Active_glacier==2 ) Glacrcov_area(i) =(1.0-Snowcov_area(i))*Glrette_frac(i) + + IF ( Active_glacier>=1 ) THEN +! Albedo so transition snow to ice smooothly, see Oerlemans 1992, this is albedo if snowcovered ice too + Albedo(i) = Albedo(i) - (Albedo(i)-Glacr_albedo(i))*EXP(-5.0*SNGL(Pkwater_equiv(i))*INCH2M) + IF ( Albedo(i)<0.08 ) Albedo(i)=0.08 !See Brock 2000 + IF ( Albedo(i)>0.92 ) Albedo(i)=0.92 !See Brock 2000 + ENDIF + + IF ( Active_frozen==1 ) THEN +! Use land albedo based on geographic areas there is frozen ground, from Euskirchen et al 2016 +! Assumes canopy is assumed to be a perfect blackbody so only want albedo of land under canopy + If (Cov_type(i)==0) Land_albedo(i) = 0.12 !bare soil (rock, may be mostly impervious already) + If (Cov_type(i)>=1) Land_albedo(i) = 0.25 !grasses (boreal grass, tundra) possibly under trees + ENDIF + + ! If there is still a snowpack or glacier + IF ( Pkwater_equiv(i)>0.0D0 .OR. Active_glacier>=1 .OR. Active_frozen==1) THEN + + ! HRU STEP 4 - DETERMINE RADIATION FLUXES AND SNOWPACK + ! STATES NECESSARY FOR ENERGY BALANCE + !********************************************************** + + ! Set the emissivity of the air to the emissivity when there + ! is no precipitation + emis = Emis_noppt(i) ! [fraction of radiation] + ! Could use equation from Swinbank 63 using Temp, a is -13.638, b is 6.148 + !emis = ((temp+273.15)**(Emis_coefb-4.0))*(10.0**(Emis_coefa+1.0))/5.670373E−8 ! /by Stefan Boltzmann in SI units + ! If there is any precipitation in the HRU, reset the + ! emissivity to 1 + IF ( Hru_ppt(i)>0.0 ) emis = 1.0 ! [fraction of radiation] + ! Save the current value of emissivity + esv = emis ! [fraction of radiation] + ! Set the convection-condensation for a half-day interval + cec = Cecn_coef(i, Nowmonth)*0.5 ! [cal/(cm^2 degC)] + ! or [Langleys / degC] + ! If the land cover is trees, reduce the convection- + ! condensation parameter by half + IF ( Cov_type(i)>2 ) cec = cec*0.5 ! [cal/(cm^2 degC)] RSR: cov_type=4 is valid for trees (coniferous) + ! or [Langleys / degC] + ! Check whether to force spring melt + ! Spring melt is forced if time is before the melt-force + ! day and after the melt-look day (parameters) + ! If between these dates, the spring melt applies if the + ! snowpack temperature is above or equal to 0 + ! for more than 4 cycles of the snorun function + + ! If before the first melt-force day + IF ( Iso(i)==1 ) THEN + ! If after the first melt-look day + IF ( Mso(i)==2 ) THEN + + ! Melt season is determined by the number of days the + ! snowpack is above 0 degrees C. The first time that + ! the snowpack is isothermal at 0 degrees C for more + ! than 4 days is the beginning of snowmelt season. + ! 2 options below (if-then, else) + + ! (1) The snowpack temperature is 0 degrees + IF ( Pk_temp(i)>=0.0 ) THEN + ! Increment the number of days that the snowpack + ! has been isothermal at 0 degrees C + Lso(i) = Lso(i) + 1 ! [days] + ! If the snowpack temperature has been 0 or greater + ! for more than 4 cycles + IF ( Lso(i)>4 ) THEN + ! Set the melt-force flag and reset counter + Iso(i) = 2 ! [flag] + Lso(i) = 0 ! [days] + ENDIF + + ! (2) The snowpack temperature is less than 0 degrees + ELSE + ! Reset the counter for days snowpack temperature is above 0 + Lso(i) = 0 ! [days] + ENDIF + ENDIF + ENDIF + + ! Compute energy balance for night period + ! niteda is a flag indicating nighttime (1) or daytime (2) + ! set the flag indicating night time + niteda = 1 ! [flag] + ! temparature is halfway between the minimum and average temperature + ! for the day + temp = (Tminc(i)+Tavgc(i))*0.5 + + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + ! The incoming shortwave radiation is the HRU radiation + ! adjusted by the albedo (some is reflected back into the + ! atmoshphere) and the transmission coefficient (some is + ! intercepted by the winter vegetative canopy) + swn = Swrad(i)*(1.0-Albedo(i))*Rad_trncf(i) ! [cal/cm^2] + ! or [Langleys] + ! Calculate the new snow depth (Riley et al. 1973) + ! RSR: the following 3 lines of code were developed by Rob Payn, 7/10/2013 + ! The snow depth depends on the previous snow pack water + ! equivalent plus the new net snow + Pss(i) = Pss(i) + DBLE( Net_snow(i) ) ! [inches] + dpt_before_settle = Pk_depth(i) + DBLE(Net_snow(i))*Deninv + dpt1 = dpt_before_settle + Settle_const_dble * ((Pss(i)*Denmaxinv) - dpt_before_settle) + ! dpt1 = Pk_depth(i) + (Net_snow(i)*Deninv) + & + ! Settle_const * ((Pss(i)*Denmaxinv) - Pk_depth(i)) + ! dpt1 = ((Net_snow(i)*Deninv)+ (Setden*Pss(i))+Pk_depth(i))*Set1 ! [inches] + ! RAPCOMMENT - CHANGED TO THE APPROPRIATE FINITE DIFFERENCE + ! APPROXIMATION OF SNOW DEPTH + Pk_depth(i) = dpt1 ! [inches] + + ! Calculate the snowpack density + IF ( dpt1>0.0D0 ) THEN + Pk_den(i) = SNGL( Pkwater_equiv(i)/dpt1 ) + ELSE + Pk_den(i) = 0.0 + ENDIF + ! [inch water equiv / inch depth] + + ! The effective thermal conductivity is approximated + ! (empirically) as 0.0077 times (snowpack density)^2 + ! [cal / (sec g degC)] Therefore, the effective + ! conductivity term (inside the square root) in the + ! equation for conductive heat exchange can be + ! calculated as follows (0.0077*pk_den^2)/(pk_den*0.5) + ! where 0.5 is the specific heat of ice [cal / (g degC)] + ! this simplifies to the following + effk = 0.0154*Pk_den(i) ! [unitless] + ! 13751 is the number of seconds in 12 hours over pi + ! So for a half day, to calculate the conductive heat + ! exchange per cm snow per cm^2 area per degree + ! temperature difference is the following + ! In effect, multiplying cst times the temperature + ! gradient gives the heatexchange by heat conducted + ! (calories) per square cm of snowpack + cst = Pk_den(i)*(SQRT(effk*13751.0)) ! [cal/(cm^2 degC)] + ! or [Langleys / degC] + + ! no shortwave (solar) radiation at night + sw = 0.0 ! [cal / cm^2] or [Langleys] + ! calculate the night time energy balance + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Pkwater_equiv(i), & + & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & + & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & + & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) + ! track total heat flux from both night and day periods + Tcal(i) = cals ! [cal/cm^2] or [Langleys] + IF ( Active_frozen==1 ) THEN + !frozen ground calculation just incoming energy + ijunk = 0 + rjunk = 0.0 + djunk = 0.D0 + djunk2 = 0.D0 + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), ijunk, & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, djunk, & + & rjunk, rjunk, rjunk, rjunk, & + & rjunk, rjunk, djunk, & + & djunk, djunk2, rjunk, cst, cals, sw, rjunk,-100) + ! track total heat flux from both night and day periods + Tcalin_snow(i) = cals ! [cal/cm^2] or [Langleys] + ENDIF + ENDIF + + iswn = 0.0 + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0 ) THEN + iswn = Swrad(i)*(1.0-Glacr_albedo(i))*Rad_trncf(i) ! [cal/cm^2] !want bare ice albedo + ! or [Langleys] + ! Calculate the Glacier icepack density + ! + ! The effective thermal conductivity is approximated + ! (empirically) as 0.0077 times (snowpack density)^2 cal/(cm sec degC) + ! from Oke 1987 + ! ice is 2.1 W/(m degC) = 0.021 W/(cm deg C) = 0.00502 cal/(cm sec degC) + ! = 0.00597 times (0.917**2), + ! firn (old snow density .5) is closer to 0.0042 W/(cm deg C) = 0.00401 times (0.5**2) + ! Therefore, the effective + ! conductivity term (inside the square root) in the + ! equation for conductive heat exchange can be + ! calculated as follows (0.0597*pk_den^2)/(pk_den*0.5) + ! where 0.5 is the specific heat of ice [cal / (g degC)] + ! this simplifies to the following + ! might want to use 0.005*2 = 0.01 half way between if doing mix of firn and ice + ieffk = 0.01194*Glacr_pk_den(i) ! [unitless] + icst = Glacr_pk_den(i)*(SQRT(ieffk*13751.0)) ! [cal/(cm^2 degC)] + ! or [Langleys / degC] + isw = 0.0 ! [cal / cm^2] or [Langleys] + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Glacr_pkwater_equiv(i), & + & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & + & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & + & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) + ENDIF + ENDIF + + IF ( Active_frozen==1 ) THEN + lswn = Swrad(i)*(1.0-Land_albedo(i))*Rad_trncf(i) ! [cal/cm^2] + ! or [Langleys] + lsw = 0.0 ! [cal / cm^2] or [Langleys] + ijunk = 0 + rjunk = 0.0 + djunk = 0.D0 + djunk2 = 0.D0 + !frozen ground calculation just incoming energy + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), ijunk, & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, djunk, & + & rjunk, rjunk, rjunk, rjunk, & + & rjunk, rjunk, djunk, & + & djunk, djunk2, rjunk, cst, cals, lsw, rjunk,-100) + ! track total heat flux from both night and day periods + Tcalin_nosnow(i) = cals ! [cal/cm^2] or [Langleys] + ENDIF + + ! Compute energy balance for day period + ! set the flag indicating daytime + niteda = 2 ! [flag] + ! temparature is halfway between the maximum and average + ! temperature for the day + temp = (Tmaxc(i)+Tavgc(i))*0.5 ! [degrees C] + + IF ( Pkwater_equiv(i)>0.0D0 ) THEN !(if the snowpack still exists) + ! set shortwave radiation as calculated earlier + sw = swn ! [cal/cm^2] or [Langleys] + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Pkwater_equiv(i), & + & Pk_def(i), Pk_temp(i), Pk_ice(i), Freeh2o(i), & + & Snowcov_area(i), Snowmelt(i), Pk_depth(i), & + & Pss(i), Pst(i), Pk_den(i), cst, cals, sw, Freeh2o_cap(i),-1) + ! track total heat flux from both night and day periods + Tcal(i) = Tcal(i) + cals ! [cal/cm^2] or [Langleys] + IF ( Active_frozen==1 ) THEN + !frozen ground calculation just incoming energy + ijunk = 0 + rjunk = 0.0 + djunk = 0.D0 + djunk2 = 0.D0 + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), ijunk, & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, djunk, & + & rjunk, rjunk, rjunk, rjunk, & + & rjunk, rjunk, djunk, & + & djunk, djunk2, rjunk, cst, cals, sw, rjunk,-100) + ! track total heat flux from both night and day periods + Tcalin_snow(i) = Tcalin_snow(i) + cals ! [cal/cm^2] or [Langleys] + ENDIF + ENDIF + + ! Compute energy balance for day period (if glacier exists) + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0 ) THEN + ! set shortwave radiation as calculated earlier + isw = iswn ! [cal/cm^2] or [Langleys] + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), Iasw(i), & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, Glacr_pkwater_equiv(i), & + & Glacr_pk_def(i), Glacr_pk_temp(i), Glacr_pk_ice(i), Glacr_freeh2o(i), & + & Glacrcov_area(i), Glacrmelt(i), Glacr_pk_depth(i), & + & Glacr_pss(i), Glacr_pst(i), Glacr_pk_den(i), icst, icals, isw, Glacr_freeh2o_capm(i),i) + ENDIF + ENDIF + IF ( Active_frozen==1 ) THEN + lsw = lswn ! [cal / cm^2] or [Langleys] + ijunk = 0 + rjunk = 0.0 + djunk = 0.D0 + djunk2 = 0.D0 + ! only call for calories to frozen ground + CALL snowbal(niteda, Tstorm_mo(i,Nowmonth), ijunk, & + & temp, esv, Hru_ppt(i), trd, Emis_noppt(i), & + & Canopy_covden(i), cec, djunk, & + & rjunk, rjunk, rjunk, rjunk, & + & rjunk, rjunk, djunk, & + & djunk, djunk2, rjunk, cst, cals, lsw, rjunk,-100) + ! track total heat flux from both night and day periodss + Tcalin_nosnow(i) = Tcalin_nosnow(i) + cals ! [cal/cm^2] or [Langleys] + ENDIF + + ! HRU STEP 5 - CALCULATE SNOWPACK LOSS TO EVAPORATION + !******************************************************** + + ! Compute snow evaporation (if there is still a snowpack) + ! Some of the calculated evaporation can come from interception + ! rather than the snowpack. Therefore, the effects of + ! interception must be evaluated. + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + ! Snow can evaporate when transpiration is not occuring + ! or when transpiration is occuring with cover types of + ! bare soil or grass + IF ( Transp_on(i)==0 .OR. (Transp_on(i)==1 .AND. Cov_type(i)<2) ) & + & CALL snowevap(Potet_sublim(i), Potet(i), Snowcov_area(i), & + & Snow_evap(i), Pkwater_equiv(i), Pk_ice(i), & + & Pk_def(i), Freeh2o(i), Pk_temp(i), Hru_intcpevap(i)) + ELSEIF ( Pkwater_equiv(i)<0.0D0 ) THEN + IF ( Print_debug>-1 ) THEN + IF ( Pkwater_equiv(i)<-DNEARZERO ) PRINT *, 'snowpack issue 3, negative pkwater_equiv, & + & HRU:', i, ' value:', Pkwater_equiv(i) + ENDIF + Pkwater_equiv(i) = 0.0D0 ! just to be sure negative values are ignored + ENDIF + IF ( Active_glacier>=1 ) THEN + IF ( Glacrcov_area(i)>0.0 ) & + & CALL snowevap(Potet_sublim(i), Potet(i), Glacrcov_area(i), & + & Glacr_evap(i), Glacr_pkwater_equiv(i), Glacr_pk_ice(i), & + & Glacr_pk_def(i), Glacr_freeh2o(i), Glacr_pk_temp(i), Hru_intcpevap(i)) + ENDIF + + ! HRU CLEAN-UP - ADJUST FINAL HRU SNOWPACK STATES AND + ! INCREMENT THE BASIN TOTALS + !********************************************************* + + ! Final state of the snowpack depends on whether it still + ! exists after all the processing above + ! 2 options below (if-then, else) + + ! (1) Snow pack still exists + IF ( Pkwater_equiv(i)>0.0D0 ) THEN + ! Snowpack still exists + IF ( Pk_den(i)>0.0 ) THEN + Pk_depth(i) = Pkwater_equiv(i)/DBLE(Pk_den(i)) + ELSE + Pk_den(i) = Den_max + Pk_depth(i) = Pkwater_equiv(i)*Denmaxinv + ENDIF + Pss(i) = Pkwater_equiv(i) + ! If it is during the melt period and snowfall was + ! insufficient to reset albedo, then reduce the cumulative + ! new snow by the amount melted during the period + ! (but don't let it be negative) + IF ( Lst(i)>0 ) THEN + Snsv(i) = Snsv(i) - Snowmelt(i) + IF ( Snsv(i)<0.0 ) Snsv(i) = 0.0 + ENDIF + ENDIF + + ENDIF + +! LAST check to clear out all arrays if packwater is gone + IF ( Pkwater_equiv(i)<=0.0D0 ) THEN + IF ( Print_debug>-1 ) THEN + IF ( Pkwater_equiv(i)<-DNEARZERO ) & + & PRINT *, 'Snowpack problem, pkwater_equiv negative, HRU:', i, ' value:', Pkwater_equiv(i) + ENDIF + Pkwater_equiv(i) = 0.0D0 ! just to be sure negative values are ignored + ! Snowpack has been completely depleted, reset all states + ! to no-snowpack values + Pk_depth(i) = 0.0D0 + Pss(i) = 0.0D0 + Snsv(i) = 0.0 + Lst(i) = 0 + Pst(i) = 0.0D0 + Iasw(i) = 0 + Albedo(i) = 0.0 + Pk_den(i) = 0.0 + Snowcov_area(i) = 0.0 + Pk_def(i) = 0.0 + Pk_temp(i) = 0.0 + Pk_ice(i) = 0.0 + Freeh2o(i) = 0.0 + Snowcov_areasv(i) = 0.0 ! rsr, not in original code + Ai(i) = 0.0D0 + Frac_swe(i) = 0.0 + ENDIF + IF ( Active_glacier>=1 ) THEN + IF ( Glacr_pkwater_equiv(i)>0.0D0 ) THEN + Glacr_pk_depth(i) = Glacr_pkwater_equiv(i)/DBLE(Glacr_pk_den(i)) + ELSE + CALL glacr_states_to_zero(i,0) + ENDIF + ENDIF + + frac = 1.0 + IF ( Active_glacier==1 ) frac = (1.0 - Glacier_frac(i)) + IF ( Active_glacier==2 ) frac = (1.0 - Glrette_frac(i)) + ! Sum volumes for basin totals + Basin_snowmelt = Basin_snowmelt + DBLE( Snowmelt(i)*Hru_area(i)*frac ) !don't include stuff melting into glacier + Basin_pweqv = Basin_pweqv + Pkwater_equiv(i)*DBLE( Hru_area(i) ) + Basin_snowevap = Basin_snowevap + DBLE( Snow_evap(i)*Hru_area(i) ) + Basin_snowcov = Basin_snowcov + DBLE( Snowcov_area(i)*Hru_area(i) ) + Basin_pk_precip = Basin_pk_precip + DBLE( Pk_precip(i)*Hru_area(i) ) + Basin_snowdepth = Basin_snowdepth + Pk_depth(i)*DBLE(Hru_area(i)) + Basin_tcal = Basin_tcal + DBLE( Tcal(i)*Hru_area(i) ) + IF ( Active_glacier>=1 ) THEN + Basin_glacrb_melt = Basin_glacrb_melt + Glacrb_melt(i)*Hru_area(i) + Basin_glacrevap = Basin_glacrevap + Glacr_evap(i)*Hru_area(i) + ENDIF + + ENDDO + + ! Area normalize basin totals + Basin_snowmelt = Basin_snowmelt*Basin_area_inv + Basin_pweqv = Basin_pweqv*Basin_area_inv + Basin_snowevap = Basin_snowevap*Basin_area_inv + Basin_snowcov = Basin_snowcov*Basin_area_inv + Basin_snowicecov = Basin_snowcov + Basin_pk_precip = Basin_pk_precip*Basin_area_inv + Basin_snowdepth = Basin_snowdepth*Basin_area_inv + Basin_tcal = Basin_tcal*Basin_area_inv + IF ( Glacier_flag==1 ) THEN + Basin_glacrb_melt = Basin_glacrb_melt*Basin_area_inv + Basin_glacrevap = Basin_glacrevap*Basin_area_inv + ENDIF + + + IF ( Print_debug==9 ) THEN + PRINT 9001, Jday, (Net_rain(i), i=1, Nhru) + PRINT 9001, Jday, (Net_snow(i), i=1, Nhru) + PRINT 9001, Jday, (Snowmelt(i), i=1, Nhru) + ENDIF + + 9001 FORMAT (I5, 177F6.3) + + END FUNCTION snorun + +!*********************************************************************** +! Subroutine to add rain and/or snow to snowpack +!*********************************************************************** + SUBROUTINE ppt_to_pack(Pptmix, Iasw, Tmaxc, Tminc, Tavgc, & + & Pkwater_equiv, Net_rain, Pk_def, Pk_temp, Pk_ice, & + & Freeh2o, Snowcov_area, Snowmelt, Pk_depth, Pss, Pst, & + & Net_snow, Pk_den, Pptmix_nopack, Pk_precip, Tmax_allsnow_c, Freeh2o_cap, Ihru_gl) + USE PRMS_BASIN, ONLY: CLOSEZERO, INCH2CM !, DNEARZERO + IMPLICIT NONE + REAL, EXTERNAL :: f_to_c + EXTERNAL calin + INTRINSIC ABS, DBLE, SNGL +! Arguments + INTEGER, INTENT(IN) :: Pptmix, Ihru_gl + INTEGER, INTENT(INOUT) :: Iasw, Pptmix_nopack + REAL, INTENT(IN) :: Tmaxc, Tminc, Tavgc, Net_rain, Net_snow + REAL, INTENT(IN) :: Freeh2o_cap, Tmax_allsnow_c + REAL, INTENT(INOUT) :: Snowmelt, Freeh2o, Pk_precip + REAL, INTENT(INOUT) :: Pk_def, Pk_ice, Pk_den, Snowcov_area, Pk_temp + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv, Pk_depth, Pst, Pss +! Local Variables + REAL :: train, tsnow, caln, pndz, calpr, calps +!*********************************************************************** + + ! The temperature of precipitation will be different if it is mixed or + ! all rain or snow 2 options below (if-then, else) + + ! If there is any snow, the snow temperature is the average + ! temperature + tsnow = Tavgc ! [degrees C] + ! (1) If precipitation is mixed... + IF ( Pptmix==1 ) THEN + ! If there is any rain, the rain temperature is halfway between the maximum + ! temperature and the allsnow temperature + train = (Tmaxc+Tmax_allsnow_c)*0.5 ! [degrees C] + + ! Temperatures will be different, depending on if there is an + ! existing snowpack or not + + ! If there is a snowpack, snow temperature is halfway between + ! the minimum daily temperature and maximum temperature for + ! which all precipitation is snow + IF ( Pkwater_equiv>0.0D0 ) THEN + tsnow = (Tminc+Tmax_allsnow_c)*0.5 ! [degrees C] + + ! If there is no existing snowpack, snow temperature is the + ! average temperature for the day + ELSEIF ( Pkwater_equiv<0.0D0 ) THEN +! IF ( Pkwater_equiv<-DNEARZERO ) & +! & PRINT *, 'snowpack issue in ppt_to_pack, negative pkwater_equiv', Pkwater_equiv + Pkwater_equiv = 0.0D0 ! to be sure negative snowpack is ignored + ENDIF + + ! (2) If precipitation is all snow or all rain... + ELSE ! on glacier ice goes in here only + ! If there is any rain, the rain temperature is the average + ! temperature + train = Tavgc ! [degrees C] + ! If average temperature is close to freezing, the rain + ! temperature is halfway between the maximum daily temperature + ! and maximum temperature for which all precipitation is snow + IF ( train0.0 ) tsnow = 0.0 ! [degrees C] ! tsnow can't be > 0 + + ! Leavesley comments... + ! If snowpack already exists, add rain first, then add + ! snow. If no antecedent snowpack, rain is already taken care + ! of, so start snowpack with snow. This SUBROUTINE assumes + ! that in a mixed event, the rain will be first and turn to + ! snow as the temperature drops. + + ! Rain can only add to the snowpack if a previous snowpack + ! exists, so rain or a mixed event is processed differently + ! when a snowpack exists + ! 2 options below (if-then, elseif) + + ! (1) If there is net rain on an existing snowpack... + IF ( Pkwater_equiv>0.0D0 ) THEN + IF ( Net_rain>0.0 ) THEN ! on glacier ice goes in here only + ! Add rain water to pack (rain on snow) and increment the + ! precipitation on the snowpack by the rain water + Pkwater_equiv = Pkwater_equiv + DBLE(Net_rain) ! [inches] + Pk_precip = Pk_precip + Net_rain ! [inches] + + ! Incoming rain water carries heat that must be added to + ! the snowpack. + ! This heat could both warm the snowpack and melt snow. + ! Handling of this heat depends on the current thermal + ! condition of the snowpack. + ! 2 options below (if-then, else) + + ! (1.1) If the snowpack is colder than freezing it has a + ! heat deficit (requires heat to be brought to isothermal + ! at 0 degC)... + IF ( Pk_def>0.0 ) THEN + ! Calculate the number of calories given up per inch of + ! rain when cooling it from the current rain temperature + ! to 0 deg C and then freezing it (liquid to solid state + ! latent heat) + ! This calculation assumes a volume of an inch of rain + ! over a square cm of area + ! 80 cal come from freezing 1 cm3 at 0 C + ! (latent heat of fusion is 80 cal/cm^3), + ! 1 cal from cooling 1cm3 for every degree C + ! (specific heat of water is 1 cal/(cm^3 degC)), + ! convert from 1 cm depth over 1 square cm to + ! 1 inch depth over 1 square cm (INCH2CM = 2.54 cm/in) + caln = (80.0+train)*INCH2CM ! [cal / (in cm^2)] + ! calculate the amount of rain in inches + ! (at the current rain temperature) + ! needed to bring the snowpack to isothermal at 0 + pndz = Pk_def/caln ! [inches] + + ! The effect of rain on the snowpack depends on if there + ! is not enough, enough, or more than enough heat in the + ! rain to bring the snowpack to isothermal at 0 degC or not + ! 3 options below (if-then, elseif, else) + + ! (1.1.1) Exactly enough rain to bring pack to isothermal... + IF ( ABS(Net_rain-pndz)0.0 ) THEN + ! Be careful with the code here. + ! If this subroutine is called when there is an all-rain day + ! on no existing snowpack (currently, it will not), + ! then the flag here will be set inappropriately. + Pptmix_nopack = 1 ! [flag] + ENDIF + + ! At this point, the subroutine has handled all conditions + ! where there is net rain, so if there is net snow + ! (doesn't matter if there is a pack or not)... + IF ( Net_snow>0.0 ) THEN + ! add the new snow to the pack water equivalent, precip, and ice + Pkwater_equiv = Pkwater_equiv + DBLE(Net_snow) + Pk_precip = Pk_precip + Net_snow + Pk_ice = Pk_ice + Net_snow + + ! The temperature of the new snow will determine its effect on + ! snowpack heat deficit + ! 2 options below (if-then, else) + + ! (1) if the new snow is at 0 degC... + IF ( tsnow>=0.0 ) THEN + ! incoming snow does not change the overall heat content of + ! the snowpack. + ! However, the temperature will change, because the total heat + ! content of the snowpack will be "spread out" among + ! more snow. Calculate the snow pack temperature from the + ! heat deficit, specific heat of snow, + ! and the new total snowpack water content + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + + ! (2) if the new snow is colder than 0 degC... + ELSE + ! calculate the amount of heat the new snow will absorb if + ! warming it to 0C (negative number). + ! This is the negative of the heat deficit of the new snow. + calps = tsnow*Net_snow*1.27 ! [cal/cm^2] + + ! The heat to warm the new snow can come from different + ! sources depending on the state of the snowpack + ! 2 options below (if-then, else) + + ! (2.1) if there is free water in the pack + ! (at least some of it is going to freeze)... + IF ( Freeh2o>0.0 ) THEN + CALL caloss(calps, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) + + ! (2.2) if there is no free water (snow pack has a + ! heat deficit greater than or equal to 0)... + ELSE + ! heat deficit increases because snow is colder than + ! pack (minus a negative number = plus) + ! and calculate the new pack temperature + Pk_def = Pk_def - calps ! [cal/cm^2] + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ENDIF + ENDIF + ENDIF + + END SUBROUTINE ppt_to_pack + +!*********************************************************************** +! Subroutine to compute change in snowpack when a net loss in +! heat energy has occurred. +!*********************************************************************** + SUBROUTINE caloss(Cal, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) + USE PRMS_BASIN, ONLY: CLOSEZERO !, DNEARZERO + IMPLICIT NONE + INTRINSIC SNGL +! Arguments + INTEGER, INTENT(IN) :: Ihru_gl + REAL, INTENT(IN) :: Cal + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv + REAL, INTENT(INOUT) :: Pk_def, Pk_ice, Freeh2o, Pk_temp +! Functions + EXTERNAL glacr_states_to_zero +! Local Variables + REAL :: calnd, dif +!*********************************************************************** + + ! Loss of heat is handled differently if there is liquid water in + ! the snowpack or not + ! 2 options below (if-then, else) + + ! (1) No free water exists in pack + IF ( Freeh2o0.0 ) THEN + ! the calories absorbed by the new snow freezes some + ! of the free water + ! (increase in ice, decrease in free water) + Pk_ice = Pk_ice + (-Cal/203.2) ! [inches] + Freeh2o = Freeh2o - (-Cal/203.2) ! [inches] + RETURN + ! (1) All free water freezes + ELSE ! IF ( dif<=0.0 ) THEN + ! if all the water freezes, then the remaining heat + ! that can be absorbed by new snow (that which is not + ! provided by freezing free water) becomes the new pack + ! heat deficit + IF ( dif<0.0 ) Pk_def = -dif ! [cal/cm^2] + ! free pack water becomes ice + Pk_ice = Pk_ice + Freeh2o ! [inches] + Freeh2o = 0.0 ! [inches] + + ENDIF + ENDIF + + ! if there is still a snowpack, calculate the new temperature + IF ( Pkwater_equiv>0.0D0 ) THEN + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ELSEIF ( Pkwater_equiv<0.0D0 ) THEN +! IF ( Pkwater_equiv<-DNEARZERO ) & +! & PRINT *, 'snowpack issue 4, negative pkwater_equiv', Pkwater_equiv + Pkwater_equiv = 0.0D0 + ! If on melting glacier ice/firn, Ihru_gl >0, so melted active layer (won't melt infinite ice layer) + If (Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl,0) + ENDIF + + END SUBROUTINE caloss + +!*********************************************************************** +! Subroutine to compute changes in snowpack when a net gain in +! heat energy has occurred. +!*********************************************************************** + SUBROUTINE calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & + & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & + & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) + USE PRMS_SNOW, ONLY: Denmaxinv, Den_max, Active_glacier + USE PRMS_MODULE, ONLY: Print_debug + USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO + IMPLICIT NONE +! Arguments + INTEGER, INTENT(INOUT) :: Iasw + INTEGER, INTENT(IN) :: Ihru_gl + REAL, INTENT(IN) :: Cal, Freeh2o_cap, Snowcov_area + REAL, INTENT(INOUT) :: Freeh2o + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv + REAL, INTENT(INOUT) :: Pk_def, Pk_temp, Pk_ice, Pk_den, Snowmelt + DOUBLE PRECISION, INTENT(INOUT) :: Pss, Pst, Pk_depth +! Functions + INTRINSIC SNGL, DBLE + EXTERNAL :: print_date, glacr_states_to_zero +! Local Variables + REAL :: dif, pmlt, apmlt, apk_ice, pwcap + DOUBLE PRECISION :: dif_dble +!*********************************************************************** + + ! Calculate the difference between the incoming calories and the + ! calories needed to bring the pack to isothermal + ! at 0 (heat deficit) + dif = Cal - Pk_def ! [cal/cm^2] + + ! The way incoming heat is handled depends on whether there is + ! not enough, just enough, or more than enough heat to overcome + ! the heat deficit of the snowpack. + ! 3 choices below (if-then, elseif, else) + + ! (1) Not enough heat to overcome heat deficit... + IF ( dif<0.0 ) THEN + ! Reduce the heat deficit by the amount of incoming calories + ! and adjust to the new temperature based on new heat deficit + Pk_def = Pk_def - Cal ! [cal/cm^2] + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + + ! (3) More than enough heat to overcome heat deficit + ! (melt ice)... + ELSEIF ( dif>0.0 ) THEN + ! calculate the potential amount of snowmelt from excess + ! heat in rain it takes 203.2 calories / (in cm^2) to melt snow + ! (latent heat of fusion) + ! convert from 1 cm depth over 1 square cm to + ! 1 inch depth over 1 square cm 80.0*(INCH2CM = 2.54 cm/in) = 203.2 + pmlt = dif/203.2 ! [inches] + ! Actual snowmelt can only come from snow covered area, so to + ! calculate the actual potential snowmelt, the potential + ! snowmelt from snowcovered area must be re-normalized to + ! HRU area (rather than snowcover area) + ! In effect, the potential snowmelt per area is reduced by the + ! fraction of the watershed that is actually covered by snow + apmlt = pmlt*Snowcov_area ! [inches] + ! Set the heat deficit and temperature of the remaining + ! snowpack to 0 + Pk_def = 0.0 ! [cal/cm^2] + Pk_temp = 0.0 ! [degrees C] + ! The only pack ice that is melted is in the snow covered area, + ! so the pack ice needs to be re-normalized to the snowcovered + ! area (rather than HRU area) + ! In effect, the pack ice per area is increased by the fraction + ! of the watershed that is actually covered by snow + IF ( Snowcov_area>0.0 ) THEN + apk_ice = Pk_ice/Snowcov_area ! [inches] + ELSE +! PRINT *, 'snowcov_area really small, melt all ice', snowcov_area, ' pmlt:', pmlt, ' dif:', dif, ' pk_ice:', Pk_ice + apk_ice = 0.0 + ENDIF + + ! If snow is melting, the heat is handled based on whether all + ! or only part of the pack ice melts + ! 2 options below (if-then, else) + + ! (3.1) Heat applied to snow covered area is sufficient + ! to melt all the ice in that snow pack... + ! if on snow over glacier or active_layer and have excess energy from day over + ! depth can melt from layer thickness, add depth to that layer + IF ( pmlt>apk_ice .AND. Active_glacier>=1 ) THEN + !fractionate density with snow/active layer melting vs extra ice underneath melting + Pk_den = Pk_den*SNGL(apk_ice/pmlt) + 0.917*SNGL((pmlt-apk_ice)/pmlt) + apk_ice = pmlt + Pk_ice = apmlt + Pkwater_equiv = apmlt + Freeh2o = 0.0 ! [inches] + Iasw = 0 + Pk_def = 0.0 ! [cal / cm^2] + Pk_temp = 0.0 ! [degreees C] + Pst = 0.0D0 ! [inches] + ENDIF + + IF ( pmlt>apk_ice ) THEN ! will not happen if Active_glacier>=1 because of above + ! All pack water equivalent becomes meltwater + Snowmelt = Snowmelt + SNGL( Pkwater_equiv ) ! [inches] + Pkwater_equiv = 0.0D0 ! [inches] + Iasw = 0 ! snow area does not change + ! Set all snowpack states to 0 + ! Snowcov_area = 0.0 ! [fraction of area] ! shouldn't be changed with melt + Pk_def = 0.0 ! [cal / cm^2] + Pk_temp = 0.0 ! [degreees C] + Pk_ice = 0.0 ! [inches] + Freeh2o = 0.0 ! [inches] + Pk_depth = 0.0D0 ! [inches] + Pss = 0.0D0 ! [inches] + Pst = 0.0D0 ! [inches] + Pk_den = 0.0 ! [fraction of depth] + + ! (3.2) Heat only melts part of the ice in the snow pack... + ELSE + ! Remove actual melt from frozen water and add melt to + ! free water + Pk_ice = Pk_ice - apmlt ! [inches] + Freeh2o = Freeh2o + apmlt ! [inches] + ! Calculate the capacity of the snowpack to hold free water + ! according to its current level of frozen water + pwcap = Freeh2o_cap*Pk_ice ! [inches] + ! Calculate the amount of free water in excess of the + ! capacity to hold free water + dif_dble = DBLE( Freeh2o - pwcap ) ! [inches] + ! If there is more free water than the snowpack can hold, + ! then there is going to be melt... + IF ( dif_dble>0.0D0 ) THEN + IF ( dif_dble>Pkwater_equiv ) dif_dble = Pkwater_equiv + ! total packwater decreases by the excess and a new depth + ! is calculated based on density + Pkwater_equiv = Pkwater_equiv - dif_dble ! [inches] + ! free water is at the current capacity + Freeh2o = pwcap ! [inches] + IF ( Pk_den>0.0 ) THEN + Pk_depth = Pkwater_equiv/DBLE(Pk_den) ! [inches] + ! RAPCOMMENT - added the conditional statement to make + ! sure there is no division by zero (this can happen + ! if there is a mixed event on no existing snowpack + ! because a pack density has not been calculated, yet + ELSE + !rsr, this should not happen, remove later + IF ( Print_debug>-1 ) THEN + PRINT *, 'snow density problem', Pk_depth, Pk_den, Pss, Pkwater_equiv + CALL print_date(1) + ENDIF + IF ( Active_glacier==0 ) Pk_den = Den_max + Pk_depth = Pkwater_equiv*Denmaxinv ! [inches] + ENDIF + + ! snowmelt increases by the excess free water + Snowmelt = Snowmelt + SNGL( dif_dble ) ! [inches] + ! reset the previous-snowpack-plus-new-snow to the + ! current pack water equivalent + Pss = Pkwater_equiv ! [inches] + ENDIF + ENDIF + ! (2) Just enough heat to overcome heat deficit + ELSE ! IF ( dif==0.0 ) THEN ! rsr 1/27/2016 why not set all snow states to 0 ??? + ! Set temperature and heat deficit to zero + Pk_temp = 0.0 ! [degrees C] + Pk_def = 0.0 ! [cal/cm^2] + ENDIF + IF ( Pkwater_equiv<=0.0D0 ) Pk_den = 0.0 + ! If on melting glacier ice/firn, Ihru_gl >0, so melted active layer (won't melt infinite ice layer) + IF ( Pkwater_equiv<=0.0D0 .AND. Ihru_gl>0) CALL glacr_states_to_zero(Ihru_gl,0) + + END SUBROUTINE calin + +!*********************************************************************** +! Subroutine to compute snowpack albedo +!*********************************************************************** + SUBROUTINE snalbedo(Newsnow, Iso, Lst, Snsv, Prmx, Pptmix, Albset_rnm, & + & Net_snow, Albset_snm, Albset_rna, Albset_sna, Albedo, & + & Int_alb, Salb, Slst) + USE PRMS_SNOW, ONLY: MAXALB, Acum, Amlt + IMPLICIT NONE + INTRINSIC INT +! Arguments + INTEGER, INTENT(IN) :: Newsnow, Iso, Pptmix + INTEGER, INTENT(INOUT) :: Int_alb, Lst + REAL, INTENT(IN) :: Albset_rnm, Albset_snm, Albset_rna, Albset_sna, Prmx, Net_snow + REAL, INTENT(INOUT) :: Salb, Slst, Snsv + REAL, INTENT(OUT) :: Albedo +! Local Variables + INTEGER :: l +!*********************************************************************** + + ! The albedo is always reset to a new initial (high) value when + ! there is new snow above a threshold (parameter). Albedo + ! is then a function of the number of days since the last new snow + ! Intermediate conditions apply when there is new snow + ! below the threshold to reset the albedo to its highest value. + ! The curve for albedo change (decreasing) is different for the + ! snow accumulation season and the snow melt season. + ! The albedo first depends on if there is no new snow during the + ! current time step, if there is new snow during accumulation + ! season, or if there is new snow during melt season. + ! 3 options below (if-then, elseif, else) + + ! (1) There is no new snow + IF ( Newsnow==0 ) THEN + ! If no new snow, check if there was previous new snow that + ! was not sufficient to reset the albedo (Lst=1) + ! Lst can only be greater than 0 during melt season (see below) + IF ( Lst>0 ) THEN + ! Slst is the number of days (float) since the last + ! new snowfall + ! Set the albedo curve back three days from the number + ! of days since the previous snowfall + ! (see Salb assignment below) + ! (note that "shallow new snow" indicates new snow that + ! is insufficient to completely reset the albedo curve) + ! In effect, a shallow new snow sets the albedo curve back + ! a few days, rather than resetting it entirely. + Slst = Salb - 3.0 ! [days] + ! Make sure the number of days since last new snow + ! isn't less than 1 + IF ( Slst<1.0 ) Slst = 1.0 ! [days] + ! If not in melt season + IF ( Iso/=2 ) THEN + ! Note that this code is unreachable in its current state. + ! This code is only run during melt season due to the + ! fact that Lst can only be set to 1 in the melt season. + ! Therefore, Iso is always going to be equal to 2. + ! Make sure the maximum point on the albedo curve is 5 + ! In effect, if there is any new snow, the albedo can + ! only get so low in accumulation season, even if the + ! new snow is insufficient to reset albedo entirely + IF ( Slst>5.0 ) Slst = 5.0 ! [days] + ENDIF + ! Reset the shallow new snow flag and cumulative shallow + ! snow variable (see below) + Lst = 0 ! [flag] + Snsv = 0.0 ! [inches] + ENDIF + + ! (2) New snow during the melt season + ELSEIF ( Iso==2 ) THEN +! RAPCOMMENT - CHANGED TO ISO FROM MSO + + ! If there is too much rain in a precipitation mix, + ! albedo will not be reset + ! New snow changes albedo only if the fraction rain + ! is less than the threshold above which albedo is not reset + IF ( PrmxAlbset_snm ) THEN + ! Reset number of days since last new snow to 0 + Slst = 0.0 ! [days] + Lst = 0 ! [flag] + ! Reset the saved new snow to 0 + Snsv = 0.0 ! [inches] + + ! (2.2) If there is not enough new snow this time period + ! to reset the albedo on its own + ELSE + ! Snsv tracks the amount of snow that has fallen as long + ! as the total new snow is not + ! enough to reset the albedo. + Snsv = Snsv + Net_snow ! [inches] + + ! Even if the new snow during this time period is + ! insufficient to reset the albedo, it may still reset the + ! albedo if it adds enough to previous shallow snow + ! accumulation. The change in Albedo depends on if the + ! total amount of accumulated shallow snow has become enough + ! to reset the albedo or not. + ! 2 options below (if-then, else) + + ! (2.2.1) If accumulated shallow snow is enough to reset + ! the albedo + IF ( Snsv>Albset_snm ) THEN + ! Reset the albedo states. + Slst = 0.0 ! [days] + Lst = 0 ! [flag] + Snsv = 0.0 ! [inches] + + ! (2.2.2) If the accumulated shallow snow is not enough to + ! reset the albedo curve + ELSE + ! Salb records the number of days since the last new snow + ! that reset albedo + IF ( Lst==0 ) Salb = Slst ! [days] + ! Reset the number of days since new snow + Slst = 0.0 ! [days] + ! set the flag indicating that there is shallow new snow + ! (i.e. not enough new snow to reset albedo) + Lst = 1 ! [flag] + ENDIF + ENDIF + ENDIF + + ! (3) New snow during the accumulation season + ELSE + + ! The change in albedo depends on if the precipitation is a mix, + ! if the rain is above a threshold, or if the snow is above + ! a threshold. + ! 4 options below (if-then, elseif, elseif, else) + + ! (3.1) If it is not a mixed event... + IF ( Pptmix<1 ) THEN + ! During the accumulation season, the threshold for resetting + ! the albedo does not apply if there is a snow-only event. + ! Therefore, no matter how little snow there is, it will + ! always reset the albedo curve the the maximum, if it + ! occurs during the accumulation season. + ! reset the time since last snow to 0 + Slst = 0.0 ! [days] + ! there is no new shallow snow + Lst = 0 ! [flag] + + ! (3.2) If it is a mixed event and the fraction rain is above + ! the threshold above which albedo is not reset... + ELSEIF ( Prmx>=Albset_rna ) THEN + ! there is no new shallow snow + Lst = 0 ! [flag] + ! albedo continues to decrease on the curve + + ! (3.3) If it is a mixed event and there is enough new snow + ! to reset albedo... + ELSEIF ( Net_snow>=Albset_sna ) THEN + ! reset the albedo + Slst = 0.0 ! [days] + ! there is no new shallow snow + Lst = 0 ! [flag] + + ! (3.4) If it is a mixed event and the new snow was not + ! enough to reset the albedo... + ELSE + ! set the albedo curve back 3 days (increasing the albedo) + Slst = Slst - 3.0 ! [days] + ! Make sure the number of days since last new snow is not + ! less than 0 + IF ( Slst<0.0 ) Slst = 0.0 ! [days] + ! Make sure the number of days since last new snow is not + ! greater than 5 + ! In effect, if there is any new snow, the albedo can + ! only get so low in accumulation season, even if the + ! new snow is insufficient to reset albedo entirely + IF ( Slst>5.0 ) Slst = 5.0 ! [days] + Lst = 0 ! [flag] + ENDIF + Snsv = 0.0 ! [inches] + ENDIF + ! At this point, the subroutine knows where on the curve the + ! albedo should be based on current conditions and the + ! new snow (determined by value of Slst variable) + + ! Get the integer value for days (or effective days) + ! since last snowfall + l = INT(Slst+0.5) ! [days] + + ! Increment the state variable for days since the + ! last snowfall + Slst = Slst + 1.0 ! [days] + + !******Compute albedo + ! Albedo will only be different from the max (default value) + ! if it has been more than 0 days since the last new snow + ! capable of resetting the albedo. If albedo is at the + ! maximum, the maximum is different for accumulation and + ! melt season. + ! 3 options below (if-then, elseif, else) + + ! (1) It has been more than 0 days since the last new snow + IF ( l>0 ) THEN + + ! Albedo depends on whether it is currently on the + ! accumulation season curve or on the melt season curve. + ! 3 options below (if-then, elseif, else) + + ! (1.1) Currently using the melt season curve + ! (Old snow - Spring melt period)... + IF ( Int_alb==2 ) THEN + ! Don't go past the last possible albedo value + IF ( l>MAXALB ) l = MAXALB ! [days] + ! Get the albedo number from the melt season curve + Albedo = Amlt(l) ! [fraction of radiation] + + ! (1.2) Currently using the accumulation season curve + ! (Old snow - Winter accumulation period)... + ! and not past the maximum curve index + ELSEIF ( l<=MAXALB ) THEN + ! Get the albedo number from the accumulation season curve + Albedo = Acum(l) ! [fraction of radiation] + + ! (1.3) Currently using the accumulation season curve and + ! past the maximum curve index... + ELSE + ! start using the the MELT season curve at 12 days + ! previous to the current number of days since the last + ! new snow + l = l - 12 ! [days] + ! keep using the melt season curve until its minimum + ! value (maximum index) is reached or until there is new snow + IF ( l>MAXALB ) l = MAXALB ! [days] + ! get the albedo value from the melt season curve + Albedo = Amlt(l) ! [fraction of radiation] + ENDIF + + ! (2) New snow has reset the albedo and it is melt season + ELSEIF ( Iso==2 ) THEN +! RAPCOMMENT - CHANGED TO ISO FROM MSO + ! Set albedo to initial value during melt season + Albedo = 0.72 ! [fraction of radiation] value Rob suggested +! Albedo = 0.81 ! [fraction of radiation] original value + ! Int_alb is a flag to indicate use of the melt season curve (2) + ! or accumulation season curve (1) + ! Set flag to indicate melt season curve + Int_alb = 2 ! [flag] + + ! (3) New snow has reset the albedo and it is accumulation season + ELSE + ! Set albedo to initial value during accumulation season + Albedo = 0.91 ! [fraction of radiation] + ! Set flag to indicate accumulation season curve + Int_alb = 1 ! [flag] + ENDIF + + END SUBROUTINE snalbedo + +!*********************************************************************** +! Subroutine to compute energy balance of snowpack +! 1st call is for night period, 2nd call for day period +!*********************************************************************** + SUBROUTINE snowbal(Niteda, Tstorm_mo, Iasw, Temp, Esv, Hru_ppt, & + & Trd, Emis_noppt, Canopy_covden, Cec, Pkwater_equiv, & + & Pk_def, Pk_temp, Pk_ice, Freeh2o, Snowcov_area, & + & Snowmelt, Pk_depth, Pss, Pst, Pk_den, Cst, Cal, Sw, Freeh2o_cap, Ihru_gl) + USE PRMS_BASIN, ONLY: CLOSEZERO + IMPLICIT NONE + INTRINSIC SNGL + EXTERNAL calin, caloss +! Arguments + INTEGER, INTENT(IN) :: Niteda, Tstorm_mo, Ihru_gl + INTEGER, INTENT(INOUT) :: Iasw + REAL, INTENT(IN) :: Temp, Esv, Trd, Cec, Cst, Canopy_covden + REAL, INTENT(IN) :: Emis_noppt, Sw, Freeh2o_cap + REAL, INTENT(IN) :: Hru_ppt, Snowcov_area + DOUBLE PRECISION, INTENT(OUT) :: Pst, Pss + REAL, INTENT(OUT) :: Cal + REAL, INTENT(INOUT) :: Pk_den, Pk_def, Pk_temp, Pk_ice + REAL, INTENT(INOUT) :: Freeh2o, Snowmelt + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv, Pk_depth +! Local Variables + REAL :: air, ts, emis, sno, sky, can, cecsub, qcond, pk_defsub, pkt, pks + REAL, PARAMETER :: ONETHIRD = 1.0/3.0 +!*********************************************************************** + ! Calculate the potential long wave energy from air based on + ! temperature (assuming perfect black-body emission) + ! Stefan Boltzmann/2 = (11.71E-8)/2 = 0.585E-7 because add for day and night + air = 0.585E-7*((Temp+273.15)**4.0) ! [cal/cm^2] or [Langleys] + ! set emissivity, which is the fraction of perfect black-body + ! emission that is actually applied + emis = Esv ! [fraction of radiation] + + ! The snowpack surface temperature and long-wave radiation + ! FROM the snowpack depend on the air temperature (effectively, + ! snowpack temperature cannot be larger than 0 degC) + ! 2 options below (if-then, else) + + ! (1) If the temperature is below freezing, surface snow + ! temperature and long wave energy are determined + ! by temperature... + IF ( Temp<0.0 ) THEN + ts = Temp ! [degrees C] + sno = air ! [cal/cm^2] or [Langleys] + + ! (2) If the temperature is at or above freezing, snow + ! temperature and long wave energy are set to values + ! corresponding to a temperature of 0 degC... + ELSE + ts = 0.0 ! [degrees C] + sno = 325.7 ! [cal/cm^2] or [Langleys] + ENDIF + IF ( Ihru_gl==-100 ) sno=0.0 !frozen ground energy computation + + ! If precipitation over the time period was due to + ! convective thunderstorms, then the emissivity should be reset + IF ( Hru_ppt>0.0 ) THEN + IF ( Tstorm_mo==1 ) THEN + + ! The emissivity of air depends on if it is day or night + ! and the fraction of measured short wave radiation to + ! potential short wave radiation is used as a surrogate + ! to the duration of the convective storms + ! 2 options below (if-then, else) + + ! (1) Night + IF ( Niteda==1 ) THEN + ! set the default emissivity + emis = 0.85 ! [fraction of radiation] + ! if measured radiation is greater than 1/3 potential + ! radiation through the time period, then the emissivity + ! is set to the "no precipitation" value + IF ( Trd>ONETHIRD ) emis = Emis_noppt ![fraction of radiation] + + ! (2) Day + ELSE + ! if measured radiation is greater than 1/3 potential + ! radiation but less than 1/2, then the emissivity is + ! interpolated between 1.0 and 0.85 + ! if measured radiation is greater than 1/2 potential + ! radiation, then the emissivity is interpolated between + ! 0.85 and 0.75 + IF ( Trd>ONETHIRD ) emis = 1.29 - (0.882*Trd) + ! [fraction of radiation] + IF ( Trd>=0.5 ) emis = 0.95 - (0.2*Trd) + ! [fraction of radiation] + ENDIF + ENDIF + ENDIF + + ! Calculate the net incoming long wave radiation coming from the + ! sky or canopy in the uncovered or covered portions of the + ! snowpack, respectively. + ! Note that the canopy is assumed to be a perfect blackbody + ! (emissivity = 1) and the air has emissivity as determined + ! from previous calculations + sky = (1.0-Canopy_covden)*((emis*air)-sno) ! [cal/cm^2] or [Langleys] + can = Canopy_covden*(air-sno) ! [cal/cm^2] or [Langleys] +!RAPCOMMENT - CHECK THE INTERECEPT MODULE FOR CHANGE. What if the land +! cover is grass? Is this automatically covered by canopy_covden being zero +! if the cover type is grass? + + ! If air temperature is above 0 degC then set the energy from + ! condensation and convection, otherwise there is + ! no energy from convection or condensation + cecsub = 0.0 ! [cal/cm^2] or [Langleys] + IF ( Temp>0.0 ) THEN + IF ( Hru_ppt>0.0 ) cecsub = Cec*Temp ! [cal/cm^2] + ! or [Langleys] + ENDIF + + ! Total energy potentially available from atmosphere: longwave, + ! shortwave, and condensation/convection + Cal = sky + can + cecsub + Sw ! [cal/cm^2] or [Langleys] + + IF ( Ihru_gl==-100 ) RETURN !frozen ground energy computation, do not need more + ! If the surface temperature of the snow is 0 degC, and there + ! is net incoming energy, then energy conduction has to be from + ! the surface into the snowpack. + ! Therefore, the energy from the atmosphere is applied to the + ! snowpack and subroutine terminates + IF ( ts>=0.0 ) THEN + IF ( Cal>0.0 ) THEN + CALL calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & + & Pk_ice, Freeh2o, Snowcov_area, Snowmelt, & + & Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) + RETURN + ENDIF + ENDIF + + ! If the program gets to this point, then either the surface + ! temperature is less than 0 degC, or the total energy from the + ! atmosphere is not providing energy to the snowpack + + ! Because the temperature of the surface of the snowpack is + ! assumed to be controlled by air temperature, there is a + ! potential heat flux due to conduction between the deeper + ! snowpack and its surface. + ! Calculate conductive heat flux as a function of the + ! temperature gradient then set new snowpack conditions + ! depending on the direction of heat flow + qcond = Cst*(ts-Pk_temp) ! [cal/cm^2] or [Langleys] +!RAPCOMMENT - The original equation in the paper implies that the +! this equation should be relative to the temperature gradient +! in degF, not degC (Anderson 1968). Which is correct? + + ! The energy flow depends on the direction of conduction and the + ! temperature of the surface of the snowpack. The total energy + ! from the atmosphere can only penetrate into the snow pack if + ! the temperature gradient allows conduction from the surface + ! into the snowpack. + ! 4 options below (if-then, elseif, elseif, else) + + ! (1) Heat is conducted from the snowpack to the surface + ! (atmospheric energy is NOT applied to snowpack)... + IF ( qcond<0.0 ) THEN + ! If the temperature of the snowpack is below 0 degC, + ! add to the heat deficit. Otherwise, remove heat + ! from the 0 degC isothermal snow pack. + IF ( Pk_temp<0.0 ) THEN + ! increase the heat deficit (minus a negative) + ! and adjust temperature + Pk_def = Pk_def - qcond ! [cal/cm^2] or [Langleys] + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ELSE + ! remove heat from the snowpack + CALL caloss(qcond, Pkwater_equiv, Pk_def, Pk_temp, Pk_ice, Freeh2o, Ihru_gl) + ENDIF + ! Even though Cal is not applied to the snowpack under this + ! condition, it maintains its value and the referencing code + ! uses it to calculate the total energy balance of the snowpack. + ! Right, now, Cal isn't used for anything outside this subroutine, + ! but care should be taken if it is. + + ! (2) There is no heat conduction, qcond = 0.0 + ELSEIF ( qcond=0.0 ) THEN + ! It does not appear that the interior of the following if + ! statement is reachable in its current form, because if these + ! conditions are true, then the code for surface temperature=0 + ! and cal=positive number would have run and the subroutine + ! will have terminated + IF ( Cal>0.0 ) CALL calin(Cal, Pkwater_equiv, Pk_def, Pk_temp, & + & Pk_ice, Freeh2o, Snowcov_area, & + & Snowmelt, Pk_depth, Pss, Pst, Iasw, Pk_den, Freeh2o_cap, Ihru_gl) + ENDIF + + ! (3) conduction is from the surface to the snowpack and the + ! surface temperature is 0 degrees C... + ELSEIF ( ts>=0.0 ) THEN + ! note that Cal must be <= 0 for this condition to apply. + ! Otherwise, the program wouldn't have gotten to this point. + + ! determine if the conductive heat is enough to overcome the + ! current heat deficit + pk_defsub = Pk_def - qcond + IF ( pk_defsub<0.0 ) THEN + ! deficit is overcome and snowpack becomes + ! isothermal at 0 degC + Pk_def = 0.0 ! [cal/cm^2] or [Langleys] + Pk_temp = 0.0 ! [degrees C] + ELSE + ! deficit is decreased by conducted heat and temperature + ! is recalculated + Pk_def = pk_defsub ! [cal/cm^2] or [Langleys] + Pk_temp = -pk_defsub/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ENDIF + + ! (4) conduction is from the surface to the snowpack and the + ! surface temperature is less than 0 degrees C... + ELSE + ! calculate the pack deficit if the snowpack was all at the + ! surface temperature, then calculate how many calories to + ! shift the pack to that deficit (pks will be a positive + ! number because the conduction direction is from the surface + ! into the snowpack) + pkt = -ts*SNGL(Pkwater_equiv*1.27D0) ! [cal/cm^2] or [Langleys] + pks = Pk_def - pkt ! [cal/cm^2] or [Langleys] + ! determine if the conducted heat is enough to shift the + ! pack to the deficit relative to the surface temperature + pk_defsub = pks - qcond ! [cal/cm^2] or [Langleys] + + ! The effect of incoming conducted heat depends on whether + ! it is enough to bring the snowpack to the same temperature + ! as the surface or not + ! 2 options below (if-then, else) + + ! (4.1) There is enough conducted heat to bring the deep + ! snowpack to the surface temperature... + IF ( pk_defsub<0.0 ) THEN + ! there is enough conduction to change to the new pack deficit + Pk_def = pkt ! [cal/cm^2] or [Langleys] + Pk_temp = ts ! [degrees C] + + ! (4.2) There is not enough conducted heat to bring the deep + ! snowpack to the surface temperature... + ELSE + ! the pack deficit doesn't make it all the way to the surface + ! deficit, but is decreased relative to the conducted heat + ! note that the next statement is equivalent to + ! Pk_def = Pk_def - qcond + Pk_def = pk_defsub + pkt ! [cal/cm^2] or [Langleys] + Pk_temp = -Pk_def/SNGL(Pkwater_equiv*1.27D0) ! [degrees C] + ENDIF + ENDIF + + END SUBROUTINE snowbal + +!*********************************************************************** +! Subroutine to compute evaporation from snowpack +!*********************************************************************** + SUBROUTINE snowevap(Potet_sublim, Potet, Snowcov_area, Snow_evap, & + & Pkwater_equiv, Pk_ice, Freeh2o, Pk_def, Pk_temp, Hru_intcpevap) + USE PRMS_SNOW, ONLY: Active_glacier + USE PRMS_BASIN, ONLY: CLOSEZERO, DNEARZERO + USE PRMS_MODULE, ONLY: Print_debug + IMPLICIT NONE + INTRINSIC DBLE, SNGL +! Arguments + REAL, INTENT(IN) :: Potet_sublim, Potet, Snowcov_area, Hru_intcpevap + REAL, INTENT(INOUT) :: Pk_ice, Pk_def, Pk_temp + DOUBLE PRECISION, INTENT(INOUT) :: Pkwater_equiv + REAL, INTENT(OUT) :: Snow_evap, Freeh2o +! Local Variables + REAL :: avail_et, cal, ez +!*********************************************************************** + ! the amount of evaporation affecting the snowpack is the + ! total evaporation potential minus the evaporation from + ! the interception storage + ez = Potet_sublim*Potet*Snowcov_area - Hru_intcpevap ! [inches] + + ! The effects of evaporation depend on whether there is any + ! potential for evaporation, and if the potential evapotation + ! is enough to completely deplete the snow pack or not + ! 3 options below (if-then, elseif, else) + + ! (1) There is no potential for evaporation... + ! if on snow over glacier or active_layer and have excess energy from day over + ! depth can evap from layer thickness, add depth to that layer + IF ( ez>Pkwater_equiv .AND. Active_glacier>=1 ) Pkwater_equiv = DBLE(ez) + IF ( ez=Pkwater_equiv ) THEN + ! Set the evaporation to the pack water equivalent and set + ! all snowpack variables to no-snowpack values + Snow_evap = SNGL(Pkwater_equiv) ! [inches] + Pkwater_equiv = 0.0D0 ! [inches] + Pk_ice = 0.0 ! [inches] + Pk_def = 0.0 ! [cal/cm^2] + Freeh2o = 0.0 ! [inches] + Pk_temp = 0.0 ! [degrees C] + + ! (3) Potential evaporation only partially depletes snowpack + ELSE + ! Evaporation depletes the amount of ice in the snowpack + ! (sublimation) + Pk_ice = Pk_ice - ez + + ! Change the pack conditions according to whether there is + ! any ice left in the snowpack + IF ( Pk_ice<0.0 ) THEN +!RAPCOMMENT - CHANGED TO CHECK FOR NEGATIVE PACK ICE + ! If all pack ice is removed, then there cannot be a + ! heat deficit + Pk_ice = 0.0 + Pk_def = 0.0 + Pk_temp = 0.0 + ELSE + ! Calculate the amount of heat deficit that is removed + ! by the sublimating ice + ! Note that this only changes the heat deficit if the + ! pack temperature is less than 0degC + cal = Pk_temp*ez*1.27 + Pk_def = Pk_def + cal + ENDIF + ! Remove the evaporated water from the pack water equivalent + Pkwater_equiv = Pkwater_equiv - ez + Snow_evap = ez + ENDIF + IF ( Snow_evap<0.0 ) THEN + Pkwater_equiv = Pkwater_equiv - DBLE(Snow_evap) + IF ( Pkwater_equiv<0.0D0 ) THEN + IF ( Print_debug>-1 ) THEN + IF ( Pkwater_equiv<-DNEARZERO ) & + & PRINT *, 'snowpack issue, negative pkwater_equiv in snowevap', Pkwater_equiv + Pkwater_equiv = 0.0D0 + ENDIF + ENDIF + Snow_evap = 0.0 + ENDIF + avail_et = Potet - Hru_intcpevap - Snow_evap + IF ( avail_et<0.0 ) THEN +! PRINT *, 'snow evap', snow_evap, avail_et, pkwater_equiv + Snow_evap = Snow_evap + avail_et + Pkwater_equiv = Pkwater_equiv - DBLE(avail_et) + IF ( Snow_evap<0.0 ) THEN + Pkwater_equiv = Pkwater_equiv - Snow_evap + IF ( Pkwater_equiv<0.0D0 ) THEN + IF ( Print_debug>-1 ) THEN + IF ( Pkwater_equiv<-DNEARZERO ) & + & PRINT *, 'snowpack issue 2, negative pkwater_equiv in snowevap', Pkwater_equiv + ENDIF + Pkwater_equiv = 0.0D0 ! to be sure negative snowpack is ignored + ENDIF + Snow_evap = 0.0 + ENDIF + ENDIF + + END SUBROUTINE snowevap + +!*********************************************************************** +! Subroutine to compute snow-covered area +!*********************************************************************** + SUBROUTINE snowcov(Iasw, Newsnow, Snowcov_area, Snarea_curve, & + & Pkwater_equiv, Pst, Snarea_thresh, Net_snow, & + & Scrv, Pksv, Snowcov_areasv, Ai, Frac_swe) + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Newsnow + INTEGER, INTENT(INOUT) :: Iasw + REAL, INTENT(IN) :: Snarea_thresh, Net_snow, Snarea_curve(11) + DOUBLE PRECISION, INTENT(IN) :: Pkwater_equiv + REAL, INTENT(INOUT) :: Snowcov_area + DOUBLE PRECISION, INTENT(OUT) :: Ai + REAL, INTENT(INOUT) :: Snowcov_areasv + DOUBLE PRECISION, INTENT(INOUT) :: Pst, Scrv, Pksv + REAL, INTENT(OUT) :: Frac_swe +! Functions + INTRINSIC DBLE, SNGL + EXTERNAL :: sca_deplcrv +! Local Variables + REAL :: snowcov_area_ante + DOUBLE PRECISION :: fracy, difx, dify +!*********************************************************************** + snowcov_area_ante = Snowcov_area + ! Reset snowcover area to the maximum + Snowcov_area = Snarea_curve(11) ! [fraction of area] + + ! Track the maximum pack water equivalent for the current + ! snow pack + IF ( Pkwater_equiv>Pst ) Pst = Pkwater_equiv ! [inches] + + ! Set ai to the maximum packwater equivalent, but no higher than + ! the threshold for complete snow cover + Ai = Pst ! [inches] + IF ( Ai>Snarea_thresh ) Ai = DBLE( Snarea_thresh ) ! [inches] + + ! calculate the ratio of the current packwater equivalent to + ! the maximum packwater equivalent for the given snowpack + Frac_swe = SNGL( Pkwater_equiv/Ai ) ! [fraction] + + ! There are 3 potential conditions for the snow area curve: + ! A. snow is accumulating and the pack is currently at its + ! maximum level + ! B. snow is depleting and the area is determined by the + ! snow area curve + ! C. new snow has occured on a depleting pack, temporarily + ! resetting to 100% cover. + ! For case (C), the snow covered area is linearly interpolated + ! between 100% and the snow covered area before the new snow. + ! In general, 1/4 of the new snow has to melt before the snow + ! covered area goes below 100%, and then the remaining 3/4 has + ! to melt to return to the previous snow covered area. + + ! First, the code decides whether snow is accumulating (A) + ! or not (B/C). + ! 2 options below (if-then, else) + + ! (1) The pack water equivalent is at the maximum + IF ( Pkwater_equiv>=Ai ) THEN + ! Stay on the snow area curve (it will be at the maximum + ! because the pack water equivalent is equal to ai + ! and it can't be higher) + Iasw = 0 + + ! (2) The pack water equivalent is less than the maximum + ELSE + + ! If the snowpack isn't accumulating to a new maximum, + ! it is either on the curve (condition B above) or being + ! interpolated between the previous place on the curve and + ! 100% (condition C above) + ! 2 options below (if-then, elseif) + + ! (2.1) There was new snow... + IF ( Newsnow/=0 ) THEN + + ! New snow will always reset the snow cover to 100%. + ! However, different states changes depending on whether + ! the previous snow area condition was on the curve or + ! being interpolated between the curve and 100% + ! 2 options below (if-then, else) + + ! (2.1.1) The snow area is being interpolated between 100% + ! and a previous location on the curve... + IF ( Iasw>0 ) THEN + ! The location on the interpolated line is based on how + ! much of the new snow has melted. Because the first 1/4 + ! of the new snow doesn't matter, it has to keep track of + ! the current snow pack plus 3/4 of the new snow. + Scrv = Scrv + (0.75D0*DBLE(Net_snow)) ! [inches] + ! Scrv = Pkwater_equiv - (0.25D0*DBLE(Net_snow))) ! [inches] +!RAPCOMMENT - CHANGED TO INCREMENT THE SCRV VALUE IF ALREADY +! INTERPOLATING BETWEEN CURVE AND 100% + + ! (2.1.2) The current snow area is on the curve... + ELSE + ! If switching from the snow area curve to interpolation + ! between the curve and 100%, the current state of the snow + ! pack has to be saved so that the interpolation can + ! continue until back to the original conditions. + ! First, set the flag to indicate interpolation between 100% + ! and the previous area should be done + Iasw = 1 ! [flag] + ! Save the current snow covered area + ! (before the new net snow) + Snowcov_areasv = snowcov_area_ante ! [inches] + ! Save the current pack water equivalent + ! (before the new net snow) + Pksv = Pkwater_equiv - DBLE( Net_snow ) ! [inches] + ! The location on the interpolated line is based on how much + ! of the new snow has melted. Because the first 1/4 + ! of the new snow doesn't matter, it has to keep track of + ! the current snow pack plus 3/4 of the new snow. + Scrv = Pkwater_equiv - (0.25D0*DBLE(Net_snow)) ! [inches] + ENDIF + ! The subroutine terminates here because the snow covered area + ! always starts at 100% if there is any new snow (no need to + ! reset it from the maximum value set at the beginning of the + ! subroutine). + RETURN + + ! (2.2) There was no new snow, but the snow covered area is + ! currently being interpolated between 100% + ! from a previous new snow and the snow covered area + ! before that previous new snow... + ELSEIF ( Iasw/=0 ) THEN + ! If the first 1/4 of the previous new snow has not melted, + ! yet, then the snow covered area is still + ! 100% and the subroutine can terminate. + IF ( Pkwater_equiv>Scrv ) RETURN + + ! At this point, the program is almost sure it is + ! interpolating between the previous snow covered area and + ! 100%, but it is possible that enough snow has melted to + ! return to the snow covered area curve instead. + ! 2 options below (if-then, else) + + ! (2.2.1) The snow pack still has a larger water equivalent + ! than before the previous new snow. I.e., new snow + ! has not melted back to original area... + IF ( Pkwater_equiv>=Pksv ) THEN + ! Do the interpolation between 100% and the snow covered + ! area before the previous new snow. + + ! Calculate the difference between the maximum snow + ! covered area (remember that Snowcov_area is always + ! set to the maximum value at this point) and the snow + ! covered area before the last new snow. + difx = DBLE( Snowcov_area - Snowcov_areasv ) + ! Calculate the difference between the water equivalent + ! before the last new snow and the previous water + ! equivalent plus 3/4 of the last new snow. + ! In effect, get the value of 3/4 of the previous + ! new snow. + dify = Scrv - Pksv ! [inches] !gl1098 + + ! If 3/4 of the previous new snow is significantly + ! different from zero, then calculate the ratio of the + ! unmelted amount of previous new snow in the snow pack + ! to the value of 3/4 of previous new snow. + ! In effect, this is the fraction of the previous new snow + ! that determines the current interpolation + ! of snow covered area. + fracy = 0.0D0 ! [fraction] !gl1098 + IF ( dify>0.0D0 ) fracy = (Pkwater_equiv-Pksv)/dify + ! [fraction] + ! Linearly interpolate the new snow covered area. + Snowcov_area = Snowcov_areasv + SNGL(fracy*difx) + ! [fraction of area] + ! Terminate the subroutine + RETURN + + ! (2.2.2) The snow pack has returned to the snow water + ! equivalent before the previous new snow. I.e. back to + ! original area before new snow. + ELSE + ! Reset the flag to use the snow area curve + Iasw = 0 ! [flag] + ENDIF + + ENDIF + + ! If this subroutine is still running at this point, then the + ! program knows that the snow covered area needs to be + ! adjusted according to the snow covered area curve. So at + ! this point it must interpolate between points on the snow + ! covered area curve (not the same as interpolating between + ! 100% and the previous spot on the snow area depletion curve). + + CALL sca_deplcrv(Snowcov_area, Snarea_curve, Frac_swe) + + ENDIF + + END SUBROUTINE snowcov + +!*********************************************************************** +! Interpolate along snow covered area depletion curve +!*********************************************************************** + SUBROUTINE sca_deplcrv(Snowcov_area, Snarea_curve, Frac_swe) + IMPLICIT NONE +! Functions + INTRINSIC :: INT, FLOAT +! Arguments + REAL, INTENT(OUT) :: Snowcov_area + REAL, INTENT(IN) :: Snarea_curve(11), Frac_swe +! Local Variables + INTEGER :: idx, jdx + REAL :: af, dify, difx +!*********************************************************************** + IF ( Frac_swe>1.0 ) THEN + Snowcov_area = Snarea_curve(11) + ELSE + + ! get the indices (as integers) of the depletion curve that + ! bracket the given Frac_swe (next highest and next lowest) + idx = INT( 10.0*(Frac_swe+0.2) ) ! [index] + jdx = idx - 1 ! [index] + IF ( idx>11 ) idx = 11 + ! calculate the fraction of the distance (from the next lowest) + ! the given Frac_swe is between the next highest and lowest + ! curve values + af = FLOAT( jdx-1 ) + dify = (Frac_swe*10.0) - af ! [fraction] + ! calculate the difference in snow covered area represented + ! by next highest and lowest curve values + difx = Snarea_curve(idx) - Snarea_curve(jdx) + ! linearly interpolate a snow covered area between those + ! represented by the next highest and lowest curve values + Snowcov_area = Snarea_curve(jdx) + dify*difx + ENDIF + END SUBROUTINE sca_deplcrv + +!*********************************************************************** +! Set all glacier states to 0 +!*********************************************************************** + SUBROUTINE glacr_states_to_zero(Ihru, active_layer_present) + USE PRMS_SNOW, ONLY: Glacr_freeh2o_cap, Glacr_freeh2o_capm, Glacr_pk_def, Glacr_pk_depth, & + & Glacr_layer, Glacr_pk_temp, Ann_tempc, Glacr_pkwater_equiv, Glacr_pk_den, & + & Glacr_pk_ice, Glacr_pkwater_ante, Glacr_freeh2o, Glacr_pss, Glacr_pk_den + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Ihru, active_layer_present +! Functions + INTRINSIC ATAN, SNGL +! Local Variables + REAL :: reduce +!*********************************************************************** + IF ( Glacr_layer(Ihru)==0.0 .OR. active_layer_present==0) THEN + Glacr_pk_depth(Ihru) = 1.0D5 + Glacr_pk_temp(Ihru) = 0.0 + Glacr_pk_def(Ihru) = 0.0 + Glacr_freeh2o_capm(Ihru) = 0.0 + reduce = 1.0 + ElSE + Glacr_pk_depth(Ihru) = DBLE(Glacr_layer(Ihru)) + Glacr_pk_temp(Ihru) = Ann_tempc(Ihru) !start at average last year temp like Oerlemans 1992 + IF ( Glacr_pk_temp(Ihru) > 0.0) Glacr_pk_temp(Ihru) = 0.0 + Glacr_freeh2o_capm(Ihru) = Glacr_freeh2o_cap(Ihru) + reduce = 0.8 !if start Glacr_pk_ice too close to Glacr_pk_depth can't grow with energy loss to free water gain + ENDIF + Glacr_pk_den(Ihru) = 0.917 + Glacr_pkwater_equiv(Ihru) = Glacr_pk_den(Ihru)*Glacr_pk_depth(Ihru) + Glacr_pkwater_ante(Ihru) = Glacr_pkwater_equiv(Ihru) + Glacr_pk_ice(Ihru) = reduce*SNGL(Glacr_pkwater_equiv(Ihru)-Glacr_freeh2o(Ihru))/0.9340 !density of pure ice + Glacr_pss(Ihru) = Glacr_pkwater_equiv(Ihru) + + END SUBROUTINE glacr_states_to_zero + +!*********************************************************************** +! snowcomp_restart - write or read snowcomp restart file +!*********************************************************************** + SUBROUTINE snowcomp_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Glacier_flag, Frozen_flag + USE PRMS_SNOW + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variable + CHARACTER(LEN=8) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Deninv, Denmaxinv, Basin_snowmelt, Basin_pweqv, Basin_snowcov, & + & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal, Basin_glacrb_melt, & + & Basin_snowicecov, Basin_glacrevap + WRITE ( Restart_outunit ) Int_alb + WRITE ( Restart_outunit ) Scrv + WRITE ( Restart_outunit ) Pksv + WRITE ( Restart_outunit ) Snowcov_areasv + WRITE ( Restart_outunit ) Salb + WRITE ( Restart_outunit ) Slst + WRITE ( Restart_outunit ) Lst + WRITE ( Restart_outunit ) Iasw + WRITE ( Restart_outunit ) Iso + WRITE ( Restart_outunit ) Mso + WRITE ( Restart_outunit ) Lso + WRITE ( Restart_outunit ) Albedo + WRITE ( Restart_outunit ) Pk_temp + WRITE ( Restart_outunit ) Pk_den + WRITE ( Restart_outunit ) Pk_def + WRITE ( Restart_outunit ) Pk_ice + WRITE ( Restart_outunit ) Freeh2o + WRITE ( Restart_outunit ) Snowcov_area + WRITE ( Restart_outunit ) Pss + WRITE ( Restart_outunit ) Pst + WRITE ( Restart_outunit ) Snsv + WRITE ( Restart_outunit ) Pk_depth + WRITE ( Restart_outunit ) Pkwater_ante + IF ( Glacier_flag==1 ) THEN + WRITE ( Restart_outunit ) Glacrmelt + WRITE ( Restart_outunit ) Glacr_evap + WRITE ( Restart_outunit ) Glacr_albedo + WRITE ( Restart_outunit ) Glacr_pk_den + WRITE ( Restart_outunit ) Glacr_pk_ice + WRITE ( Restart_outunit ) Glacr_freeh2o + WRITE ( Restart_outunit ) Glacrcov_area + WRITE ( Restart_outunit ) Glacr_pss + WRITE ( Restart_outunit ) Glacr_pst + WRITE ( Restart_outunit ) Glacr_pk_depth + WRITE ( Restart_outunit ) Glacr_pkwater_equiv + WRITE ( Restart_outunit ) Glacr_pkwater_ante + WRITE ( Restart_outunit ) Glacr_pk_temp + WRITE ( Restart_outunit ) Ann_tempc, Yrdays5, Prev_ann_tempc + WRITE ( Restart_outunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp + WRITE ( Restart_outunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow + WRITE ( Restart_outunit ) Glacr_pk_def + WRITE ( Restart_outunit ) Glacrb_melt + WRITE ( Restart_outunit ) Glacr_freeh2o_capm + ENDIF + IF ( Frozen_flag==1 ) THEN + WRITE ( Restart_outunit ) Tcalin_nosnow, Tcalin_snow, Land_albedo + ENDIF + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Deninv, Denmaxinv, Basin_snowmelt, Basin_pweqv, Basin_snowcov, & + & Basin_snowevap, Basin_snowdepth, Basin_pk_precip, Basin_tcal, Basin_glacrb_melt, & + & Basin_snowicecov, Basin_glacrevap + READ ( Restart_inunit ) Int_alb + READ ( Restart_inunit ) Scrv + READ ( Restart_inunit ) Pksv + READ ( Restart_inunit ) Snowcov_areasv + READ ( Restart_inunit ) Salb + READ ( Restart_inunit ) Slst + READ ( Restart_inunit ) Lst + READ ( Restart_inunit ) Iasw + READ ( Restart_inunit ) Iso + READ ( Restart_inunit ) Mso + READ ( Restart_inunit ) Lso + READ ( Restart_inunit ) Albedo + READ ( Restart_inunit ) Pk_temp + READ ( Restart_inunit ) Pk_den + READ ( Restart_inunit ) Pk_def + READ ( Restart_inunit ) Pk_ice + READ ( Restart_inunit ) Freeh2o + READ ( Restart_inunit ) Snowcov_area + READ ( Restart_inunit ) Pss + READ ( Restart_inunit ) Pst + READ ( Restart_inunit ) Snsv + READ ( Restart_inunit ) Pk_depth + READ ( Restart_inunit ) Pkwater_ante + IF ( Glacier_flag==1 ) THEN + READ ( Restart_inunit ) Glacrmelt + READ ( Restart_inunit ) Glacr_evap + READ ( Restart_inunit ) Glacr_albedo + READ ( Restart_inunit ) Glacr_pk_den + READ ( Restart_inunit ) Glacr_pk_ice + READ ( Restart_inunit ) Glacr_freeh2o + READ ( Restart_inunit ) Glacrcov_area + READ ( Restart_inunit ) Glacr_pss + READ ( Restart_inunit ) Glacr_pst + READ ( Restart_inunit ) Glacr_pk_depth + READ ( Restart_inunit ) Glacr_pkwater_equiv + READ ( Restart_inunit ) Glacr_pkwater_ante + READ ( Restart_inunit ) Glacr_pk_temp + READ ( Restart_inunit ) Ann_tempc, Yrdays5, Prev_ann_tempc + READ ( Restart_inunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp + READ ( Restart_inunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow + READ ( Restart_inunit ) Glacr_pk_def + READ ( Restart_inunit ) Glacrb_melt + READ ( Restart_inunit ) Glacr_freeh2o_capm + ENDIF + IF ( Frozen_flag==1 ) THEN + WRITE ( Restart_inunit ) Tcalin_nosnow, Tcalin_snow, Land_albedo + ENDIF + ENDIF + END SUBROUTINE snowcomp_restart diff --git a/prmsRip/soilzoneCfgim.f90 b/prmsRip/soilzoneCfgim.f90 new file mode 100644 index 00000000..28a29166 --- /dev/null +++ b/prmsRip/soilzoneCfgim.f90 @@ -0,0 +1,1875 @@ +!*********************************************************************** +! Computes inflows to and outflows from soil zone of each HRU and +! includes inflows from infiltration, groundwater, and upslope HRUs, +! and outflows to gravity drainage, interflow, and surface runoff to +! downslope HRUs; merge of smbal_prms and ssflow_prms with enhancements +! +! Daily accounting for soil zone; +! adds infiltration +! computes et +! computes recharge of soil zone +! computes interflow to stream or cascade +! adjusts storage in soil zone +! sends dunnian runoff to stream or cascade by adding to sroff +! computes drainage to groundwater +!*********************************************************************** + MODULE PRMS_SOILZONE + IMPLICIT NONE +! Local Variables + INTEGER, SAVE :: DBGUNT + CHARACTER(LEN=8), SAVE :: MODNAME + INTEGER, SAVE :: Max_gvrs, Et_type, Pref_flag, Is_land + INTEGER, SAVE, ALLOCATABLE :: Soil2gw(:), Pref_flow_flag(:) + REAL, SAVE, ALLOCATABLE :: Gvr2pfr(:), Swale_limit(:) + REAL, SAVE, ALLOCATABLE :: Soil_lower_stor_max(:) + REAL, SAVE, ALLOCATABLE :: Soil_moist_ante(:), Ssres_stor_ante(:) + REAL, SAVE, ALLOCATABLE :: Grav_dunnian_flow(:), Pfr_dunnian_flow(:) + DOUBLE PRECISION, SAVE :: Last_soil_moist, Last_ssstor +! GSFLOW variables + INTEGER, SAVE, ALLOCATABLE :: Hru_gvr_count(:), Hru_gvr_index(:, :), Hrucheck(:) + REAL, SAVE, ALLOCATABLE :: Replenish_frac(:) + REAL, SAVE, ALLOCATABLE :: It0_soil_rechr(:), It0_soil_moist(:) + REAL, SAVE, ALLOCATABLE :: It0_pref_flow_stor(:), It0_ssres_stor(:) + REAL, SAVE, ALLOCATABLE :: It0_gravity_stor_res(:), It0_sroff(:) + REAL, SAVE, ALLOCATABLE :: It0_slow_stor(:), It0_potet(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: It0_strm_seg_in(:) + DOUBLE PRECISION, SAVE :: It0_basin_soil_moist, It0_basin_ssstor, Basin_sz_gwin + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Gvr_hru_pct_adjusted(:) +! Declared Variables + DOUBLE PRECISION, SAVE :: Basin_sz2gw, Basin_cap_infil_tot + DOUBLE PRECISION, SAVE :: Basin_interflow_max, Basin_sm2gvr_max ! this is the same as basin_sm2gvr + DOUBLE PRECISION, SAVE :: Basin_soil_rechr, Basin_dunnian_gvr + DOUBLE PRECISION, SAVE :: Basin_recharge, Basin_pref_flow_infil + DOUBLE PRECISION, SAVE :: Basin_ssin, Basin_dunnian_pfr + DOUBLE PRECISION, SAVE :: Basin_sm2gvr, Basin_dninterflow + DOUBLE PRECISION, SAVE :: Basin_dncascadeflow, Basin_dndunnianflow + DOUBLE PRECISION, SAVE :: Basin_capwaterin, Basin_dunnian + DOUBLE PRECISION, SAVE :: Basin_gvr2pfr, Basin_slowflow + DOUBLE PRECISION, SAVE :: Basin_pref_stor, Basin_slstor, Basin_prefflow + DOUBLE PRECISION, SAVE :: Basin_lakeinsz, Basin_lakeprecip + DOUBLE PRECISION, SAVE :: Basin_cap_up_max + DOUBLE PRECISION, SAVE :: Basin_soil_moist_tot + DOUBLE PRECISION, SAVE :: Basin_soil_lower_stor_frac, Basin_soil_rechr_stor_frac, Basin_sz_stor_frac + DOUBLE PRECISION, SAVE :: Basin_cpr_stor_frac, Basin_gvr_stor_frac, Basin_pfr_stor_frac + REAL, SAVE, ALLOCATABLE :: Perv_actet(:), Pref_flow_thrsh(:) + REAL, SAVE, ALLOCATABLE :: Soil_moist_tot(:), Recharge(:) + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Upslope_interflow(:), Upslope_dunnianflow(:), Lakein_sz(:) + REAL, SAVE, ALLOCATABLE :: Dunnian_flow(:), Cap_infil_tot(:) + REAL, SAVE, ALLOCATABLE :: Pref_flow_stor(:), Pref_flow(:) + REAL, SAVE, ALLOCATABLE :: Pref_flow_infil(:), Pref_flow_in(:) + REAL, SAVE, ALLOCATABLE :: Hru_sz_cascadeflow(:), Swale_actet(:) + REAL, SAVE, ALLOCATABLE :: Pref_flow_max(:), Snow_free(:) + REAL, SAVE, ALLOCATABLE :: Cap_waterin(:), Soil_lower(:), Soil_zone_max(:) + REAL, SAVE, ALLOCATABLE :: Potet_lower(:), Potet_rechr(:), Soil_lower_ratio(:) + REAL, SAVE, ALLOCATABLE :: Unused_potet(:) +! REAL, SAVE, ALLOCATABLE :: Cascade_interflow(:), Cascade_dunnianflow(:), Interflow_max(:) +! REAL, SAVE, ALLOCATABLE :: Cpr_stor_frac(:), Pfr_stor_frac(:), Gvr_stor_frac(:), Soil_moist_frac(:) +! REAL, SAVE, ALLOCATABLE :: Soil_rechr_ratio(:), Snowevap_aet_frac(:), Perv_avail_et(:), Cap_upflow_max(:) +! GSFLOW Declared Variables + DOUBLE PRECISION, SAVE :: Basin_gvr2sm + REAL, SAVE, ALLOCATABLE :: Sm2gw_grav(:), Gw2sm_grav(:) + REAL, SAVE, ALLOCATABLE :: Gravity_stor_res(:), Gvr2sm(:), Grav_gwin(:) +! Declared Parameters + INTEGER, SAVE, ALLOCATABLE :: Soil_type(:), Gvr_hru_id(:) + REAL, SAVE, ALLOCATABLE :: Pref_flow_den(:) + REAL, SAVE, ALLOCATABLE :: Fastcoef_lin(:), Fastcoef_sq(:) + REAL, SAVE, ALLOCATABLE :: Slowcoef_lin(:), Slowcoef_sq(:) + REAL, SAVE, ALLOCATABLE :: Ssr2gw_rate(:), Ssr2gw_exp(:) + REAL, SAVE, ALLOCATABLE :: Soil2gw_max(:) + REAL, SAVE, ALLOCATABLE :: Lake_evap_adj(:, :) + END MODULE PRMS_SOILZONE + +!*********************************************************************** +! Main soilzone routine +!*********************************************************************** + INTEGER FUNCTION soilzone() + USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: szdecl, szinit, szrun + EXTERNAL :: soilzone_restart +!*********************************************************************** + soilzone = 0 + + IF ( Process(:3)=='run' ) THEN + soilzone = szrun() + ELSEIF ( Process(:4)=='decl' ) THEN + soilzone = szdecl() + ELSEIF ( Process(:4)=='init' ) THEN + IF ( Init_vars_from_file>0 ) CALL soilzone_restart(1) + soilzone = szinit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL soilzone_restart(0) + ENDIF + + END FUNCTION soilzone + +!*********************************************************************** +! szdecl - set up parameters for soil zone computations +! Declared Parameters +! sat_threshold, ssstor_init_frac fastcoef_lin, fastcoef_sq +! ssr2gw_rate, ssr2gw_exp, soil2gw_max, soil_type +! soil_rechr_max_frac, soil_rechr_init_frac, soil_moist_max, soil_moist_init_frac +! pref_flow_den, slowcoef_lin, cov_type +! hru_area, slowcoef_sq, gvr_hru_id +!*********************************************************************** + INTEGER FUNCTION szdecl() + USE PRMS_SOILZONE + USE PRMS_MODULE, ONLY: Model, Nhru, Nsegment, Nlake, Nhrucell, Print_debug, Cascade_flag, GSFLOW_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declparam, declvar, getdim + EXTERNAL :: read_error, print_module, PRMS_open_module_file +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_soilzone +!*********************************************************************** + szdecl = 0 + + Version_soilzone = 'soilzone.f90 2019-03-05 11:11:00Z' + CALL print_module(Version_soilzone, 'Soil Zone Computations ', 90 ) + MODNAME = 'soilzone' + +! Declare Variables + IF ( declvar(MODNAME, 'basin_capwaterin', 'one', 1, 'double', & + & 'Basin area-weighted average infiltration,'// & + & ' cascading interflow and Dunnian flow added to capillary reservoir storage', & + & 'inches', Basin_capwaterin)/=0 ) CALL read_error(3, 'basin_capwaterin') + + IF ( declvar(MODNAME, 'basin_cap_infil_tot', 'one', 1, 'double', & + & 'Basin area-weighted average infiltration with cascading flow into capillary reservoirs', & + & 'inches', Basin_cap_infil_tot)/=0 ) CALL read_error(3, 'basin_cap_infil_tot') + + IF ( declvar(MODNAME, 'basin_cap_up_max', 'one', 1, 'double', & + & 'Basin area-weighted average maximum cascade flow that flows to capillary reservoirs', & + & 'inches', Basin_cap_up_max)/=0 ) CALL read_error(3, 'basin_cap_up_max') + + IF ( declvar(MODNAME, 'basin_pref_flow_infil', 'one', 1, 'double', & + & 'Basin area-weighted average infiltration to preferential-flow reservoir storage', & + & 'inches', Basin_pref_flow_infil)/=0 ) CALL read_error(3, 'basin_pref_flow_infil') + + IF ( declvar(MODNAME, 'basin_dunnian_pfr', 'one', 1, 'double', & + & 'Basin area-weighted average excess infiltration to'// & + & ' preferential-flow reservoirs from variable infil', & + & 'inches', Basin_dunnian_pfr)/=0 ) CALL read_error(3, 'basin_dunnian_pfr') + + IF ( declvar(MODNAME, 'basin_dunnian_gvr', 'one', 1, 'double', & + & 'Basin area-weighted average excess flow to preferential'// & + & '-flow reservoirs from gravity reservoirs', & + & 'inches', Basin_dunnian_gvr)/=0 ) CALL read_error(3, 'basin_dunnian_gvr') + + ALLOCATE ( Cap_infil_tot(Nhru) ) + IF ( declvar(MODNAME, 'cap_infil_tot', 'nhru', Nhru, 'real', & + & 'Infiltration and cascading interflow and Dunnian'// & + & ' flow added to capillary reservoir storage for each HRU', & + & 'inches', Cap_infil_tot)/=0 ) CALL read_error(3, 'cap_infil_tot') + + IF ( declvar(MODNAME, 'basin_soil_moist_tot', 'one', 1, 'double', & + & 'Basin area-weighted average total soil-zone water storage', & + & 'inches', Basin_soil_moist_tot)/=0 ) CALL read_error(3, 'basin_soil_moist_tot') + + ALLOCATE ( Soil_moist_tot(Nhru) ) + IF ( declvar(MODNAME, 'soil_moist_tot', 'nhru', Nhru, 'real', & + & 'Total soil-zone water storage (soil_moist + ssres_stor)', & + & 'inches', Soil_moist_tot)/=0 ) CALL read_error(3, 'soil_moist_tot') + + IF ( declvar(MODNAME, 'basin_cpr_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of capillary reservoir storage of the maximum storage', & + & 'decimal fraction', Basin_cpr_stor_frac)/=0 ) CALL read_error(3, 'basin_cpr_stor_frac') + + IF ( declvar(MODNAME, 'basin_gvr_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of gravity reservoir storage of the maximum storage', & + & 'decimal fraction', Basin_gvr_stor_frac)/=0 ) CALL read_error(3, 'basin_gvr_stor_frac') + + IF ( declvar(MODNAME, 'basin_pfr_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of preferential-flow reservoir storage of the maximum storage', & + & 'decimal fraction', Basin_pfr_stor_frac)/=0 ) CALL read_error(3, 'basin_pfr_stor_frac') + + IF ( declvar(MODNAME, 'basin_soil_lower_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of soil lower zone storage of the maximum storage', & + & 'decimal fraction', Basin_soil_lower_stor_frac)/=0 ) CALL read_error(3, 'basin_soil_lower_stor_frac') + + IF ( declvar(MODNAME, 'basin_soil_rechr_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of soil recharge zone storage of the maximum storage', & + & 'decimal fraction', Basin_soil_rechr_stor_frac)/=0 ) CALL read_error(3, 'basin_soil_rechr_stor_frac') + + IF ( declvar(MODNAME, 'basin_sz_stor_frac', 'one', 1, 'double', & + & 'Basin area-weighted average fraction of soil zone storage of the maximum storage', & + & 'decimal fraction', Basin_sz_stor_frac)/=0 ) CALL read_error(3, 'basin_sz_stor_frac') + +! ALLOCATE ( Cpr_stor_frac(Nhru) ) +! IF ( declvar(MODNAME, 'cpr_stor_frac', 'nhru', Nhru, 'real', & +! & 'Fraction of capillary reservoir storage of the maximum storage for each HRU', & +! & 'decimal fraction', Cpr_stor_frac)/=0 ) CALL read_error(3, 'cpr_stor_frac') + +! ALLOCATE ( Pfr_stor_frac(Nhru) ) +! IF ( declvar(MODNAME, 'pfr_stor_frac', 'nhru', Nhru, 'real', & +! & 'Fraction of preferential flow reservoir storage of the maximum storage for each HRU', & +! & 'decimal fraction', Pfr_stor_frac)/=0 ) CALL read_error(3, 'pfr_stor_frac') + +! ALLOCATE ( Gvr_stor_frac(Nhru) ) +! IF ( declvar(MODNAME, 'gvr_stor_frac', 'nhru', Nhru, 'real', & +! & 'Fraction of gravity reservoir storage of the maximum storage for each HRU', & +! & 'decimal fraction', Gvr_stor_frac)/=0 ) CALL read_error(3, 'gvr_stor_frac') + +! ALLOCATE ( Soil_moist_frac(Nhru) ) +! IF ( declvar(MODNAME, 'soil_moist_frac', 'nhru', Nhru, 'real', & +! & 'Fraction of soil zone storage of the maximum storage for each HRU', & +! & 'decimal fraction', Soil_moist_frac)/=0 ) CALL read_error(3, 'soil_moist_frac') + + IF ( declvar(MODNAME, 'basin_sm2gvr', 'one', 1, 'double', & + & 'Basin area-weighted average excess flow from'// & + & ' capillary reservoirs to gravity reservoir storage', & + & 'inches', Basin_sm2gvr)/=0 ) CALL read_error(3, 'basin_sm2gvr') + + IF ( declvar(MODNAME, 'basin_gvr2pfr', 'one', 1, 'double', & + & 'Basin area-weighted average excess flow to'// & + & ' preferential-flow reservoir storage from gravity reservoirs', & + & 'inches', Basin_gvr2pfr)/=0 ) CALL read_error(3, 'basin_gvr2pfr') + + IF ( declvar(MODNAME, 'basin_slowflow', 'one', 1, 'double', & + & 'Basin area-weighted average interflow from gravity reservoirs to the stream network', & + & 'inches', Basin_slowflow)/=0 ) CALL read_error(3, 'basin_slowflow') + + IF ( declvar(MODNAME, 'basin_prefflow', 'one', 1, 'double', & + & 'Basin area-weighted average interflow from'// & + & ' preferential-flow reservoirs to the stream network', & + & 'inches', Basin_prefflow)/=0 ) CALL read_error(3, 'basin_prefflow') + + IF ( declvar(MODNAME, 'basin_slstor', 'one', 1, 'double', & + & 'Basin area-weighted average storage of gravity reservoirs', & + & 'inches', Basin_slstor)/=0 ) CALL read_error(3, 'basin_slstor') + + ALLOCATE ( Dunnian_flow(Nhru) ) + IF ( declvar(MODNAME, 'dunnian_flow', 'nhru', Nhru, 'real', & + & 'Dunnian surface runoff that flows to the stream network for each HRU', & + & 'inches', Dunnian_flow)/=0 ) CALL read_error(3, 'dunnian_flow') + + IF ( declvar(MODNAME, 'basin_dunnian', 'one', 1, 'double', & + & 'Basin area-weighted average Dunnian surface runoff that flows to the stream network', & + & 'inches', Basin_dunnian)/=0 ) CALL read_error(3, 'basin_dunnian') + + IF ( declvar(MODNAME, 'basin_soil_rechr', 'one', 1, 'double', & + & 'Basin area-weighted average storage for recharge zone;'// & + & ' upper portion of capillary reservoir where both'// & + & ' evaporation and transpiration occurs', & + & 'inches', Basin_soil_rechr)/=0 ) CALL read_error(3, 'basin_soil_rechr') + + IF ( declvar(MODNAME, 'basin_sz2gw', 'one', 1, 'double', & + & 'Basin area-weighted average drainage from gravity reservoirs to GWRs', & + & 'inches', Basin_sz2gw)/=0 ) CALL read_error(3, 'basin_sz2gw') + + ALLOCATE ( Pref_flow_in(Nhru) ) + IF ( declvar('soilzone', 'pref_flow_in', 'nhru', Nhru, 'real', & + & 'Infiltration and flow from gravity reservoir to the preferential-flow reservoir', & + & 'inches', Pref_flow_in)/=0 ) CALL read_error(3, 'pref_flow_in') + + IF ( declvar(MODNAME, 'basin_sm2gvr_maxin', 'one', 1, 'double', & + & 'Basin area-weighted average maximum excess flow from'// & + & ' capillary reservoirs that flows to gravity reservoirs', & + & 'inches', Basin_sm2gvr_max)/=0 ) CALL read_error(3, 'basin_sm2gvr_max') + + IF ( declvar(MODNAME, 'basin_interflow_max', 'one', 1, 'double', & + & 'Basin area-weighted average maximum interflow that flows from gravity reservoirs', & + & 'inches', Basin_interflow_max)/=0 ) CALL read_error(3, 'basin_interflow_max') + + ALLOCATE ( Perv_actet(Nhru) ) + IF ( declvar(MODNAME, 'perv_actet', 'nhru', Nhru, 'real', & + & 'Actual ET from the capillary reservoir of each HRU', & + & 'inches', Perv_actet)/=0 ) CALL read_error(3, 'perv_actet') + +! ALLOCATE ( Perv_avail_et(Nhru) ) +! IF ( declvar(MODNAME, 'perv_avail_et', 'nhru', Nhru, 'real', & +! & 'Unsatisfied ET available to the capillary reservoir of each HRU', & +! & 'inches', Perv_avail_et)/=0 ) CALL read_error(3, 'perv_avail_et') + + ! added to be compatible with ssflow_prms + IF ( declvar(MODNAME, 'basin_ssin', 'one', 1, 'double', & + & 'Basin area-weighted average inflow to gravity and preferential-flow reservoir storage', & + & 'inches', Basin_ssin)/=0 ) CALL read_error(3, 'basin_ssin') + +! ALLOCATE ( Interflow_max(Nhru) ) +! IF ( declvar(MODNAME, 'interflow_max', 'nhru', Nhru, 'real', & +! & 'Maximum interflow for each HRU', & +! & 'inches', Interflow_max)/=0 ) CALL read_error(3, 'interflow_max') + + IF ( Cascade_flag>0 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'basin_dndunnianflow', 'one', 1, 'double', & + & 'Basin area-weighted average cascading Dunnian flow', & + & 'inches', Basin_dndunnianflow)/=0 ) CALL read_error(3, 'basin_dndunnianflow') + + IF ( declvar(MODNAME, 'basin_dninterflow', 'one', 1, 'double', & + & 'Basin area-weighted average cascading interflow', & + & 'inches', Basin_dninterflow)/=0 ) CALL read_error(3, 'basin_dninterflow') + + IF ( declvar(MODNAME, 'basin_dncascadeflow', 'one', 1, 'double', & + & 'Basin area-weighted average cascading interflow and Dunnian surface runoff', & + & 'inches', Basin_dncascadeflow)/=0 ) CALL read_error(3, 'basin_dncascadeflow') + + ALLOCATE ( Upslope_interflow(Nhru) ) + IF ( declvar(MODNAME, 'upslope_interflow', 'nhru', Nhru, 'double', & + & 'Cascading interflow runoff that flows to'// & + & ' the capillary reservoir of each downslope HRU for each upslope HRU', & + & 'inches', Upslope_interflow)/=0 ) CALL read_error(3, 'upslope_interflow') + + ALLOCATE ( Upslope_dunnianflow(Nhru) ) + IF ( declvar(MODNAME, 'upslope_dunnianflow', 'nhru', Nhru, 'double', & + & 'Cascading Dunnian surface runoff that'// & + & ' flows to the capillary reservoir of each downslope HRU for each upslope HRU', & + & 'inches', Upslope_dunnianflow)/=0 ) CALL read_error(3, 'upslope_dunnianflow') + + ALLOCATE ( Hru_sz_cascadeflow(Nhru) ) + IF ( declvar(MODNAME, 'hru_sz_cascadeflow', 'nhru', Nhru, 'real', & + & 'Cascading interflow and Dunnian surface runoff from each HRU', & + & 'inches', Hru_sz_cascadeflow)/=0 ) CALL read_error(3, 'hru_sz_cascadeflow') + +! ALLOCATE ( Cap_upflow_max(Nhru) ) +! IF ( declvar(MODNAME, 'cap_upflow_max', 'nhru', Nhru, 'real', & +! & 'Maximum infiltration and any cascading interflow and'// & +! & ' Dunnian surface runoff that can be added to capillary reservoir storage for each HRU', & +! & 'inches', Cap_upflow_max)/=0 ) CALL read_error(3, 'cap_upflow_max') + +! ALLOCATE ( Cascade_interflow(Nhru) ) +! IF ( declvar(MODNAME, 'cascade_interflow', 'nhru', Nhru, 'real', & +! & 'Cascading interflow for each HRU', & +! & 'inches', Cascade_interflow)/=0 ) CALL read_error(3, 'cascade_interflow') + +! ALLOCATE ( Cascade_dunnianflow(Nhru) ) +! IF ( declvar(MODNAME, 'cascade_dunnianflow', 'nhru', Nhru, 'real', & +! & 'Cascading Dunnian flow for each HRU', & +! & 'inches', Cascade_dunnianflow)/=0 ) CALL read_error(3, 'cascade_dunnianflow') + + IF ( Nlake>0 ) THEN + ALLOCATE ( Lakein_sz(Nhru) ) + IF ( declvar(MODNAME, 'lakein_sz', 'nhru', Nhru, 'double', & + & 'Cascading interflow and Dunnian surface runoff to lake HRUs for each upslope HRU', & + & 'inches', Lakein_sz)/=0 ) CALL read_error(3, 'lakein_sz') + + IF ( declvar(MODNAME, 'basin_lakeinsz', 'one', 1, 'double', & + & 'Basin area-weighted average lake inflow from land HRUs', & + & 'inches', Basin_lakeinsz)/=0 ) CALL read_error(3, 'basin_lakeinsz') + ENDIF + ENDIF + + IF ( declvar(MODNAME, 'basin_pref_stor', 'one', 1, 'double', & + & 'Basin area-weighted average storage in preferential-flow reservoirs', & + & 'inches', Basin_pref_stor)/=0 ) CALL read_error(3, 'basin_pref_stor') + + ALLOCATE ( Pref_flow_infil(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow_infil', 'nhru', Nhru, 'real', & + & 'Infiltration to the preferential-flow reservoir storage for each HRU', & + & 'inches', Pref_flow_infil)/=0 ) CALL read_error(3, 'pref_flow_infil') + + ALLOCATE ( Pref_flow_stor(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow_stor', 'nhru', Nhru, 'real', & + & 'Storage in preferential-flow reservoir for each HRU', & + & 'inches', Pref_flow_stor)/=0 ) CALL read_error(3, 'pref_flow_stor') + + ALLOCATE ( Pref_flow(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow', 'nhru', Nhru, 'real', & + & 'Interflow from the preferential-flow reservoir that'// & + & ' flows to the stream network for each HRU', & + & 'inches', Pref_flow)/=0 ) CALL read_error(3, 'pref_flow') + + ALLOCATE ( Pref_flow_thrsh(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow_thrsh', 'nhru', Nhru, 'real', & + & 'Soil storage threshold defining storage between field'// & + & ' capacity and maximum soil saturation minus preferential-flow storage', & + & 'inches', Pref_flow_thrsh)/=0 ) CALL read_error(3, 'pref_flow_thrsh') + + ALLOCATE ( Pref_flow_max(Nhru) ) + IF ( declvar(MODNAME, 'pref_flow_max', 'nhru', Nhru, 'real', & + & 'Maximum storage of the preferential-flow reservoir for each HRU', & + & 'inches', Pref_flow_max)/=0 ) CALL read_error(3, 'pref_flow_max') + + ALLOCATE ( Soil_zone_max(Nhru) ) +! IF ( declvar(MODNAME, 'soil_zone_max', 'nhru', Nhru, 'real', & +! & 'Maximum storage of all soil zone reservoirs', & +! & 'inches', Soil_zone_max)/=0 ) CALL read_error(3, 'soil_zone_max') + + IF ( declvar(MODNAME, 'basin_lakeprecip', 'one', 1, 'double', & + & 'Basin area-weighted average precipitation on lake HRUs', & + & 'inches', Basin_lakeprecip)/=0 ) CALL read_error(3, 'basin_lakeprecip') + + ALLOCATE ( Swale_actet(Nhru) ) + IF ( declvar(MODNAME, 'swale_actet', 'nhru', Nhru, 'real', & + & 'Evaporation from the gravity and preferential-flow reservoirs that exceeds sat_threshold', & + & 'inches', Swale_actet)/=0 ) CALL read_error(3, 'swale_actet') + + IF ( declvar(MODNAME, 'basin_recharge', 'one', 1, 'double', & + & 'Basin area-weighted average recharge to GWRs', & + & 'inches', Basin_recharge)/=0 ) CALL read_error(3, 'basin_recharge') + + ALLOCATE ( Recharge(Nhru) ) + IF ( declvar(MODNAME, 'recharge', 'nhru', Nhru, 'real', & + & 'Recharge to the associated GWR as sum of soil_to_gw and ssr_to_gw for each HRU', & + & 'inches', Recharge)/=0 ) CALL read_error(3, 'recharge') + + ALLOCATE ( Cap_waterin(Nhru) ) + IF ( declvar(MODNAME, 'cap_waterin', 'nhru', Nhru, 'real', & + & 'Infiltration and any cascading interflow and'// & + & ' Dunnian surface runoff added to capillary reservoir storage for each HRU', & + & 'inches', Cap_waterin)/=0 ) CALL read_error(3, 'cap_waterin') + + ALLOCATE ( Soil_lower(Nhru) ) + IF ( declvar(MODNAME, 'soil_lower', 'nhru', Nhru, 'real', & + & 'Storage in the lower zone of the capillary'// & + & ' reservoir that is only available for transpiration for each HRU', & + & 'inches', Soil_lower)/=0 ) CALL read_error(3, 'soil_lower') + + ALLOCATE ( Potet_lower(Nhru) ) + IF ( declvar(MODNAME, 'potet_lower', 'nhru', Nhru, 'real', & + & 'Potential ET in the lower zone of the capillary reservoir for each HRU', & + & 'inches', Potet_lower)/=0 ) CALL read_error(3, 'potet_lower') + + ALLOCATE ( Potet_rechr(Nhru) ) + IF ( declvar(MODNAME, 'potet_rechr', 'nhru', Nhru, 'real', & + & 'Potential ET in the recharge zone of the capillary reservoir for each HRU', & + & 'inches', Potet_rechr)/=0 ) CALL read_error(3, 'potet_rechr') + + ALLOCATE ( Soil_lower_ratio(Nhru), Soil_lower_stor_max(Nhru) ) + IF ( declvar(MODNAME, 'soil_lower_ratio', 'nhru', Nhru, 'real', & + & 'Water content ratio in the lower zone of the capillary reservoir for each HRU', & + & 'decimal fraction', Soil_lower_ratio)/=0 ) CALL read_error(3, 'soil_lower_ratio') + +! ALLOCATE ( Soil_rechr_ratio(Nhru) ) +! IF ( declvar(MODNAME, 'soil_rechr_ratio', 'nhru', Nhru, 'real', & +! & 'Water content ratio in the recharge zone of the capillary reservoir for each HRU', & +! & 'decimal fraction', Soil_rechr_ratio)/=0 ) CALL read_error(3, 'soil_rechr_ratio') + + ALLOCATE ( Snow_free(Nhru) ) + IF ( declvar(MODNAME, 'snow_free', 'nhru', Nhru, 'real', & + & 'Fraction of snow-free surface for each HRU', & + & 'decimal fraction', Snow_free)/=0 ) CALL read_error(3, 'snow_free') + + ALLOCATE ( Unused_potet(Nhru) ) + IF ( declvar(MODNAME, 'unused_potet', 'nhru', Nhru, 'real', & + & 'Unsatisfied potential evapotranspiration', & + & 'inches', Unused_potet)/=0 ) CALL read_error(3, 'unused_potet') + +! ALLOCATE ( Snowevap_aet_frac(Nhru) ) +! IF ( declvar(MODNAME, 'snowevap_aet_frac', 'nhru', Nhru, 'double', & +! & 'Fraction of sublimation of AET for each HRU', & +! & 'decimal fraction', Snowevap_aet_frac)/=0 ) CALL read_error(3, 'snowevap_aet_frac') + + IF ( GSFLOW_flag==1 .OR. Model==99 ) THEN + IF ( Nhrucell<-1 ) STOP 'ERROR, dimension nhrucell not specified > 0' + ALLOCATE ( Gravity_stor_res(Nhrucell) ) + IF ( declvar(MODNAME, 'gravity_stor_res', 'nhrucell', Nhrucell, 'real', & + & 'Storage in each gravity-flow reservoir', & + & 'inches', Gravity_stor_res)/=0 ) CALL read_error(3, 'gravity_stor_res') + + ALLOCATE ( Sm2gw_grav(Nhrucell) ) + IF ( declvar(MODNAME, 'sm2gw_grav', 'nhrucell', Nhrucell, 'real', & + & 'Drainage from each gravity reservoir to each MODFLOW cell', & + & 'inches', Sm2gw_grav)/=0 ) CALL read_error(3, 'sm2gw_grav') + + IF ( declvar(MODNAME, 'basin_gvr2sm', 'one', 1, 'double', & + & 'Basin area-weighted average gravity flow to capillary reservoirs', & + & 'inches', Basin_gvr2sm)/=0 ) CALL read_error(3, 'basin_gvr2sm') + + ALLOCATE ( Gvr2sm(Nhru) ) + IF ( declvar(MODNAME, 'gvr2sm', 'nhru', Nhru, 'real', & + & 'Gravity flow to soil moist replenishment for each HRU', & + & 'inches', Gvr2sm)/=0 ) CALL read_error(3, 'gvr2sm') + + ALLOCATE ( Gw2sm_grav(Nhrucell) ) + IF ( declvar(MODNAME, 'gw2sm_grav', 'nhrucell', Nhrucell, 'real', & + & 'Groundwater discharge to gravity-flow reservoirs', & + & 'inches', Gw2sm_grav)/=0 ) CALL read_error(3, 'gw2sm_grav') + + ALLOCATE ( Grav_gwin(Nhru) ) ! ??? + IF ( declvar(MODNAME, 'grav_gwin', 'nhru', Nhru, 'real', & + & 'Groundwater discharge to gravity-flow reservoirs for each HRU', & + & 'inches', Grav_gwin)/=0 ) CALL read_error(3, 'grav_gwin') + + ALLOCATE ( Gvr_hru_pct_adjusted(Nhrucell) ) + ALLOCATE ( Hru_gvr_count(Nhru), Hrucheck(Nhru) ) + ALLOCATE ( It0_pref_flow_stor(Nhru), It0_ssres_stor(Nhru), It0_soil_rechr(Nhru), It0_soil_moist(Nhru) ) + ALLOCATE ( It0_gravity_stor_res(Nhrucell), It0_sroff(Nhru), It0_slow_stor(Nhru) ) + ALLOCATE ( It0_strm_seg_in(Nsegment), It0_potet(Nhru), Replenish_frac(Nhru) ) + ENDIF + +! Allocate arrays for local and variables from other modules + ALLOCATE ( Soil2gw(Nhru), Gvr2pfr(Nhru), Swale_limit(Nhru), Pref_flow_flag(Nhru) ) + ALLOCATE ( Pfr_dunnian_flow(Nhru), Grav_dunnian_flow(Nhru) ) + IF ( Print_debug==1 ) ALLOCATE( Soil_moist_ante(Nhru), Ssres_stor_ante(Nhru) ) + + IF ( Print_debug==7 ) CALL PRMS_open_module_file(DBGUNT, 'soilzone.dbg') + +! Declare Parameters + IF ( GSFLOW_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Gvr_hru_id(Nhrucell) ) + IF ( Nhru/=Nhrucell ) THEN + IF ( declparam(MODNAME, 'gvr_hru_id', 'nhrucell', 'integer', & + & '0', 'bounded', 'nhru', & + & 'Corresponding HRU id of each GVR', & + & 'Index of the HRU associated with each gravity reservoir', & + & 'none')/=0 ) CALL read_error(1, 'gvr_hru_id') + ENDIF + ENDIF + + IF ( Nlake>0 ) THEN + ALLOCATE ( Lake_evap_adj(12,Nlake) ) + IF ( declparam(MODNAME, 'lake_evap_adj', 'nmonths,nlake', & + & 'real', '1.0', '0.5', '1.0', & + & 'Monthly potet factor to adjust potet on lakes', & + & 'Monthly (January to December) adjustment factor for potential ET for each lake', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'lake_evap_adj') + ENDIF + + ALLOCATE ( Slowcoef_lin(Nhru) ) + IF ( declparam(MODNAME, 'slowcoef_lin', 'nhru', 'real', & + & '0.015', '0.0', '1.0', & + & 'Linear gravity-flow reservoir routing coefficient', & + & 'Linear coefficient in equation to route gravity-reservoir storage downslope for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'slowcoef_lin') + + ALLOCATE ( Slowcoef_sq(Nhru) ) + IF ( declparam(MODNAME, 'slowcoef_sq', 'nhru', 'real', & + & '0.1', '0.0', '1.0', & + & 'Non-linear gravity-flow reservoir routing coefficient', & + & 'Non-linear coefficient in equation to route'// & + & ' gravity-reservoir storage downslope for each HRU', & + & 'none')/=0 ) CALL read_error(1, 'slowcoef_sq') + + ALLOCATE ( Pref_flow_den(Nhru) ) + IF ( declparam(MODNAME, 'pref_flow_den', 'nhru', 'real', & + & '0.0', '0.0', '0.5', & + & 'Fraction of the soil zone in which preferential flow occurs for each HRU', & + & 'Fraction of the soil zone in which preferential flow occurs for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1,'pref_flow_den') + + ALLOCATE ( Soil2gw_max(Nhru) ) + IF ( declparam(MODNAME, 'soil2gw_max', 'nhru', 'real', & + & '0.0', '0.0', '5.0', & + & 'Maximum value for capillary reservoir excess to GWR', & + & 'Maximum amount of the capillary reservoir excess that'// & + & ' is routed directly to the GWR for each HRU', & + & 'inches')/=0 ) CALL read_error(1, 'soil2gw_max') + + ALLOCATE ( Soil_type(Nhru) ) + IF ( declparam(MODNAME, 'soil_type', 'nhru', 'integer', & + & '2', '1', '3', & + & 'HRU soil type', 'Soil type of each HRU (1=sand; 2=loam; 3=clay)', & + & 'none')/=0 ) CALL read_error(1, 'soil_type') + + ALLOCATE ( Fastcoef_lin(Nhru) ) + IF ( declparam(MODNAME, 'fastcoef_lin', 'nhru', 'real', & + & '0.1', '0.0', '1.0', & + & 'Linear preferential-flow routing coefficient', & + & 'Linear coefficient in equation to route preferential-flow storage downslope for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'fastcoef_lin') + + ALLOCATE ( Fastcoef_sq(Nhru) ) + IF ( declparam(MODNAME, 'fastcoef_sq', 'nhru', 'real', & + & '0.8', '0.0', '1.0', & + & 'Non-linear preferential-flow routing coefficient', & + & 'Non-linear coefficient in equation used to route'// & + & ' preferential-flow storage downslope for each HRU', & + & 'none')/=0 ) CALL read_error(1, 'fastcoef_sq') + + ALLOCATE ( Ssr2gw_rate(Nhru) ) + IF ( declparam(MODNAME, 'ssr2gw_rate', 'nssr', 'real', & + & '0.1', '0.0001', '1.0', & + & 'Coefficient to route water from gravity reservoir to GWR', & + & 'Linear coefficient in equation used to route water from'// & + & ' the gravity reservoir to the GWR for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'ssr2gw_rate') + + ALLOCATE ( Ssr2gw_exp(Nhru) ) + IF ( declparam(MODNAME, 'ssr2gw_exp', 'nssr', 'real', & + & '1.0', '0.0', '3.0', & + & 'Coefficient to route water from subsurface to groundwater', & + & 'Non-linear coefficient in equation used to route water'// & + & ' from the gravity reservoir to the GWR for each HRU', & + & 'none')/=0 ) CALL read_error(1, 'ssr2gw_exp') + + END FUNCTION szdecl + +!*********************************************************************** +! szinit - Initialize soilzone module - get parameter values, +! set initial values and check parameter values +!*********************************************************************** + INTEGER FUNCTION szinit() + USE PRMS_SOILZONE + USE PRMS_MODULE, ONLY: Nhru, Nssr, Nlake, GSFLOW_flag, Nhrucell, & + & Parameter_check_flag, Cascade_flag, Init_vars_from_file, Inputerror_flag + USE PRMS_BASIN, ONLY: Hru_type, Hru_perv, & + & Basin_area_inv, Hru_area, Hru_frac_perv, Numlake_hrus + USE PRMS_FLOWVARS, ONLY: Soil_moist_max, Soil_rechr_max, & + & Ssres_stor, Basin_ssstor, Basin_soil_moist, Slow_stor, & + & Soil_moist, Sat_threshold, Soil_rechr + USE PRMS_SNOW, ONLY: Snowcov_area + IMPLICIT NONE +! Functions + EXTERNAL :: init_basin_vars, checkdim_bounded_limits + INTEGER, EXTERNAL :: getparam + INTRINSIC MIN, DBLE +! Local Variables + INTEGER :: i, ii, ihru, icnt + REAL :: hruarea, hruperv +!*********************************************************************** + szinit = 0 + + IF ( getparam(MODNAME, 'slowcoef_lin', Nhru, 'real', Slowcoef_lin)/=0 ) CALL read_error(2, 'slowcoef_lin') + IF ( getparam(MODNAME, 'slowcoef_sq', Nhru, 'real', Slowcoef_sq)/=0 ) CALL read_error(2, 'slowcoef_sq') + IF ( getparam(MODNAME, 'pref_flow_den', Nhru, 'real', Pref_flow_den)/=0 ) CALL read_error(2, 'pref_flow_den') + IF ( getparam(MODNAME, 'fastcoef_lin', Nhru, 'real', Fastcoef_lin)/=0 ) CALL read_error(2, 'fastcoef_lin') + IF ( getparam(MODNAME, 'fastcoef_sq', Nhru, 'real', Fastcoef_sq)/=0 ) CALL read_error(2, 'fastcoef_sq') + IF ( getparam(MODNAME, 'ssr2gw_rate', Nssr, 'real', Ssr2gw_rate)/=0 ) CALL read_error(2, 'ssr2gw_rate') + IF ( getparam(MODNAME, 'ssr2gw_exp', Nssr, 'real', Ssr2gw_exp)/=0 ) CALL read_error(2, 'ssr2gw_exp') + IF ( getparam(MODNAME, 'soil_type', Nhru, 'integer', Soil_type)/=0 ) CALL read_error(2, 'soil_type') + IF ( getparam(MODNAME, 'soil2gw_max', Nhru, 'real', Soil2gw_max)/=0 ) CALL read_error(2, 'soil2gw_max') + IF ( Nlake>0 ) THEN + IF ( getparam(MODNAME, 'lake_evap_adj', 12*Nlake, 'real', Lake_evap_adj)/=0 ) CALL read_error(2, 'lake_evap_adj') + ENDIF + + IF ( GSFLOW_flag==1 ) THEN + IF ( Nhru/=Nhrucell ) THEN + IF ( getparam(MODNAME, 'gvr_hru_id', Nhrucell, 'integer', Gvr_hru_id)/=0 ) CALL read_error(2, 'gvr_hru_id') + IF ( Parameter_check_flag==1 ) & + & CALL checkdim_bounded_limits('gvr_hru_id', 'nhru', Gvr_hru_id, Nhrucell, 1, Nhru, Inputerror_flag) + ELSE + DO i = 1, Nhru + Gvr_hru_id(i) = i + ENDDO + ENDIF + Grav_gwin = 0.0 ! dimension nhru + Gw2sm_grav = 0.0 + ENDIF + + Swale_limit = 0.0 + Soil2gw = 0 + Pref_flow_flag = 0 + Pref_flag = 0 + Pfr_dunnian_flow = 0.0 + Grav_dunnian_flow = 0.0 + Soil_lower_ratio = 0.0 + Pref_flow_thrsh = 0.0 + + Basin_soil_moist = 0.0D0 + Basin_slstor = 0.0D0 + Basin_ssstor = 0.0D0 + Basin_pref_stor = 0.0D0 + Basin_soil_rechr = 0.0D0 + Basin_soil_moist_tot = 0.0D0 + Basin_soil_lower_stor_frac = 0.0D0 + Basin_soil_rechr_stor_frac = 0.0D0 + Basin_sz_stor_frac = 0.0D0 + Basin_cpr_stor_frac = 0.0D0 + Basin_gvr_stor_frac = 0.0D0 + Basin_pfr_stor_frac = 0.0D0 +! Pfr_stor_frac = 0.0 +! Gvr_stor_frac = 0.0 +! Cpr_stor_frac = 0.0 +! Soil_moist_frac = 0.0 + + DO i = 1, Nhru + Snow_free(i) = 1.0 - Snowcov_area(i) + + IF ( Hru_type(i)==0 .OR. Hru_type(i)==2 ) THEN !if inactive or lake + Soil_rechr(i) = 0.0 + Soil_moist(i) = 0.0 + Ssres_stor(i) = 0.0 + Slow_stor(i) = 0.0 + Pref_flow_stor(i) = 0.0 + Soil_moist_tot(i) = 0.0 + Soil_lower(i) = 0.0 +! Soil_rechr_ratio(i) = 0.0 + Soil_zone_max(i) = 0.0 + Soil_lower_stor_max(i) = 0.0 + Sat_threshold(i) = 0.0 + Pref_flow_den(i) = 0.0 + Pref_flow_max(i) = 0.0 + CYCLE + ENDIF + + IF ( Hru_type(i)==3 ) THEN ! swale + Swale_limit(i) = 3.0*Sat_threshold(i) + Pref_flow_den(i) = 0.0 + Pref_flow_thrsh(i) = Sat_threshold(i) + Pref_flow_max(i) = 0.0 + ELSE ! land + Pref_flow_thrsh(i) = Sat_threshold(i)*(1.0-Pref_flow_den(i)) + Pref_flow_max(i) = Sat_threshold(i) - Pref_flow_thrsh(i) + ENDIF + + ! hru_type = 1 or 3 + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==5 ) THEN + Slow_stor(i) = MIN( Ssres_stor(i), Pref_flow_thrsh(i) ) + Pref_flow_stor(i) = Ssres_stor(i) - Slow_stor(i) + ENDIF + IF ( Soil2gw_max(i)>0.0 ) Soil2gw(i) = 1 + IF ( Hru_type(i)==1 .OR. Hru_type(i)==4 ) THEN ! interflow coefficient values don't matter unless land HRU + IF ( Pref_flow_den(i)>0.0 ) THEN + Pref_flow_flag(i) = 1 + Pref_flag = 1 + ENDIF + ENDIF + + hruarea = Hru_area(i) + hruperv = Hru_perv(i) + Soil_zone_max(i) = Sat_threshold(i) + Soil_moist_max(i)*Hru_frac_perv(i) + Soil_moist_tot(i) = Ssres_stor(i) + Soil_moist(i)*Hru_frac_perv(i) +! Soil_moist_frac(i) = Soil_moist_tot(i)/Soil_zone_max(i) +! Cpr_stor_frac(i) = Soil_moist(i)/Soil_moist_max(i) +! IF ( Pref_flow_thrsh(i)>0.0 ) Gvr_stor_frac(i) = Slow_stor(i)/Pref_flow_thrsh(i) +! Basin_cpr_stor_frac = Basin_cpr_stor_frac + DBLE( Cpr_stor_frac(i)*hruperv ) +! Basin_gvr_stor_frac = Basin_gvr_stor_frac + DBLE( Gvr_stor_frac(i)*hruarea ) + Basin_cpr_stor_frac = Basin_cpr_stor_frac + DBLE( Soil_moist(i)/Soil_moist_max(i)*hruperv ) + IF ( Pref_flow_thrsh(i)>0.0 ) Basin_gvr_stor_frac = Basin_gvr_stor_frac + DBLE( Slow_stor(i)/Pref_flow_thrsh(i)*hruarea ) + Soil_lower(i) = Soil_moist(i) - Soil_rechr(i) + Soil_lower_stor_max(i) = Soil_moist_max(i) - Soil_rechr_max(i) + IF ( Soil_lower_stor_max(i)>0.0 ) Soil_lower_ratio(i) = Soil_lower(i)/Soil_lower_stor_max(i) +! Soil_rechr_ratio(i) = Soil_rechr(i)/Soil_rechr_max(i) +! Basin_sz_stor_frac = Basin_sz_stor_frac + DBLE( Soil_moist_frac(i)*hruarea ) + Basin_sz_stor_frac = Basin_sz_stor_frac + DBLE( Soil_moist_tot(i)/Soil_zone_max(i)*hruarea ) + Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac + DBLE( Soil_lower_ratio(i)*hruperv ) +! Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + DBLE( Soil_rechr_ratio(i)*hruperv ) + Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + DBLE( Soil_rechr(i)/Soil_rechr_max(i)*hruperv ) + Basin_soil_moist = Basin_soil_moist + DBLE( Soil_moist(i)*Hru_perv(i) ) + Basin_soil_moist_tot = Basin_soil_moist_tot + DBLE( Soil_moist_tot(i)*hruarea ) + ! rsr, 6/12/2014 potential problem for GSFLOW if sum of slow_stor /= gravity_stor_res + Basin_slstor = Basin_slstor + DBLE( Slow_stor(i)*hruarea ) + Basin_ssstor = Basin_ssstor + DBLE( Ssres_stor(i)*hruarea ) + Basin_soil_rechr = Basin_soil_rechr + DBLE( Soil_rechr(i)*hruperv ) + IF ( Pref_flow_flag(i)==1 ) THEN + Basin_pref_stor = Basin_pref_stor + DBLE( Pref_flow_stor(i)*hruarea ) +! Pfr_stor_frac(i) = Pref_flow_stor(i)/Pref_flow_max(i) +! Basin_pfr_stor_frac = Basin_pfr_stor_frac + DBLE( Pfr_stor_frac(i)*hruarea ) + Basin_pfr_stor_frac = Basin_pfr_stor_frac + DBLE( Pref_flow_stor(i)/Pref_flow_max(i)*hruarea ) + ENDIF + ENDDO + Basin_soil_rechr = Basin_soil_rechr*Basin_area_inv + Basin_ssstor = Basin_ssstor*Basin_area_inv + Basin_slstor = Basin_slstor*Basin_area_inv + Basin_soil_moist = Basin_soil_moist*Basin_area_inv + Basin_soil_moist_tot = Basin_soil_moist_tot*Basin_area_inv + Basin_pref_stor = Basin_pref_stor*Basin_area_inv + Last_soil_moist = Basin_soil_moist + Last_ssstor = Basin_ssstor + Basin_cpr_stor_frac = Basin_cpr_stor_frac*Basin_area_inv + Basin_gvr_stor_frac = Basin_gvr_stor_frac*Basin_area_inv + Basin_pfr_stor_frac = Basin_pfr_stor_frac*Basin_area_inv + Basin_sz_stor_frac = Basin_sz_stor_frac*Basin_area_inv + Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac*Basin_area_inv + Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac*Basin_area_inv + +! initialize arrays (dimensioned Nhru) + Dunnian_flow = 0.0 + IF ( Cascade_flag>0 ) THEN + Upslope_interflow = 0.0D0 + Upslope_dunnianflow = 0.0D0 + Hru_sz_cascadeflow = 0.0 +! Cap_upflow_max = 0.0 +! Cascade_interflow = 0.0 +! Cascade_dunnianflow = 0.0 + IF ( Numlake_hrus>0 ) Lakein_sz = 0.0D0 + ENDIF + Cap_infil_tot = 0.0 + Pref_flow_infil = 0.0 + Pref_flow_in = 0.0 + Pref_flow = 0.0 + Gvr2pfr = 0.0 + Swale_actet = 0.0 + Perv_actet = 0.0 +! Perv_avail_et = 0.0 + Recharge = 0.0 + Cap_waterin = 0.0 + Potet_lower = 0.0 + Potet_rechr = 0.0 + Unused_potet = 0.0 ! dimension nhru +! Interflow_max = 0.0 +! Snowevap_aet_frac = 0.0 + + ! initialize scalers + IF ( Init_vars_from_file==0 ) CALL init_basin_vars() + +! initialize GSFLOW arrays + IF ( GSFLOW_flag==1 ) THEN + Gvr2sm = 0.0 ! dimension nhru + Sm2gw_grav = 0.0 ! dimension nhrucell + + Max_gvrs = 1 + Hrucheck = 1 + Hru_gvr_count = 0 + DO i = 1, Nhrucell + ihru = Gvr_hru_id(i) + IF ( Hru_type(ihru)==0 .OR. Hru_type(ihru)==2 ) THEN + Gravity_stor_res(i) = 0.0 + Hrucheck(ihru) = 0 + Replenish_frac(ihru) = 0.0 + ELSE + ! set only for cold start simulations + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==5 ) & + & Gravity_stor_res(i) = Ssres_stor(ihru) + Hru_gvr_count(ihru) = Hru_gvr_count(ihru) + 1 + IF ( Hru_gvr_count(ihru)>Max_gvrs ) Max_gvrs = Hru_gvr_count(ihru) + Replenish_frac(ihru) = Soil_rechr_max(ihru)/Soil_moist_max(ihru) + ENDIF + ENDDO + ALLOCATE ( Hru_gvr_index(Max_gvrs, Nhru) ) + IF ( Nhru==Nhrucell ) THEN + IF ( Max_gvrs/=1 ) THEN + PRINT *, 'ERROR, nhru=nhrucell, but, gvr_hru_id array specifies more than one GVR for an HRU' + STOP + ENDIF + DO i = 1, Nhru + Hru_gvr_index(1, i) = i + ENDDO + ELSE + Hru_gvr_index = 0 + DO i = 1, Nhru + IF ( Hru_type(i)==0 .OR. Hru_type(i)==2 ) CYCLE !if inactive or lake + icnt = 0 + DO ii = 1, Nhrucell + IF ( Gvr_hru_id(ii)==i ) THEN + icnt = icnt + 1 + Hru_gvr_index(icnt, i) = ii + IF ( icnt==Hru_gvr_count(i) ) EXIT + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + END FUNCTION szinit + +!*********************************************************************** +! szrun - Does soil water balance for each HRU, adds in infiltration +! then computes actual et and apportions remainder between +! recharge of soil moisture, soil storage available for +! interflow, excess routed to stream, +! and groundwater reservoirs +!*********************************************************************** + INTEGER FUNCTION szrun() + USE PRMS_SOILZONE + USE PRMS_MODULE, ONLY: Dprst_flag, Print_debug, Kkiter, & + & GSFLOW_flag, Nlake, Cascade_flag, Dprst_flag, Frozen_flag + USE PRMS_BASIN, ONLY: Hru_type, Hru_perv, Hru_frac_perv, & + & Hru_route_order, Active_hrus, Basin_area_inv, Hru_area, & + & NEARZERO, Lake_hru_id, Cov_type, Numlake_hrus, Hru_area_dble + USE PRMS_CLIMATEVARS, ONLY: Hru_ppt, Transp_on, Potet, Basin_potet +! WARNING!!! Sroff, Basin_sroff, and Strm_seg_in can be updated + USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_actet, Hru_actet, & + & Ssres_flow, Soil_to_gw, Basin_soil_to_gw, Ssr_to_gw, & + & Soil_to_ssr, Basin_lakeevap, Basin_perv_et, Basin_swale_et, & + & Sroff, Soil_moist_max, Infil, Soil_rechr_max, Ssres_in, & + & Basin_soil_moist, Basin_ssstor, Slow_stor, Slow_flow, & + & Ssres_stor, Soil_moist, Sat_threshold, Soil_rechr, Basin_lake_stor + USE PRMS_CASCADE, ONLY: Ncascade_hru + USE PRMS_SET_TIME, ONLY: Nowmonth !, Nowday + USE PRMS_INTCP, ONLY: Hru_intcpevap + USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap + USE PRMS_SRUNOFF, ONLY: Basin_sroff, Hru_impervevap, Strm_seg_in, Dprst_evap_hru, & + & Dprst_seep_hru, Frozen, Thaw_depth, Soil_depth + IMPLICIT NONE +! Functions + INTRINSIC MIN, ABS, MAX, SNGL, DBLE + EXTERNAL compute_soilmoist, compute_szactet, compute_cascades, compute_gravflow + EXTERNAL compute_interflow, compute_gwflow, init_basin_vars, print_date +! Local Variables + INTEGER :: i, k, update_potet + REAL :: dunnianflw, interflow, perv_area, harea + REAL :: dnslowflow, dnpreflow, dndunn, availh2o, avail_potet + REAL :: gvr_maxin, topfr !, tmp + REAL :: dunnianflw_pfr, dunnianflw_gvr, pref_flow_maxin + REAL :: perv_frac, capacity, capwater_maxin, ssresin + REAL :: cap_upflow_max, unsatisfied_et, pervactet, prefflow + REAL :: prefflowmax, soilmoistmax, soilrechrmax, thaw_frac ! frozen ground + REAL :: soil2gwmax, ssr2gwrate ! frozen ground + DOUBLE PRECISION :: gwin + INTEGER :: cfgi_frozen_hru +!*********************************************************************** + szrun = 0 + + IF ( GSFLOW_flag==1 ) THEN + IF ( Kkiter==0 ) STOP 'ERROR, problem with KKITER, equals 0' + + IF ( Kkiter==1 ) THEN +! It0 variables used with MODFLOW integration to save iteration states. + DO k = 1, Active_hrus + i = Hru_route_order(k) + It0_soil_rechr(i) = Soil_rechr(i) + It0_soil_moist(i) = Soil_moist(i) + It0_ssres_stor(i) = Ssres_stor(i) + It0_pref_flow_stor(i) = Pref_flow_stor(i) + It0_slow_stor(i) = Slow_stor(i) + It0_sroff(i) = Sroff(i) + It0_potet(i) = Potet(i) + ENDDO + It0_basin_soil_moist = Basin_soil_moist + It0_basin_ssstor = Basin_ssstor + It0_gravity_stor_res = Gravity_stor_res + It0_strm_seg_in = Strm_seg_in + Gw2sm_grav = 0.0 + ELSE + DO k = 1, Active_hrus + i = Hru_route_order(k) + Soil_rechr(i) = It0_soil_rechr(i) + Soil_moist(i) = It0_soil_moist(i) + Ssres_stor(i) = It0_ssres_stor(i) + Pref_flow_stor(i) = It0_pref_flow_stor(i) + Slow_stor(i) = It0_slow_stor(i) + Sroff(i) = It0_sroff(i) + Potet(i) = It0_potet(i) + ENDDO + Basin_soil_moist = It0_basin_soil_moist + Basin_ssstor = It0_basin_ssstor + Gravity_stor_res = It0_gravity_stor_res + Strm_seg_in = It0_strm_seg_in + ENDIF + Sm2gw_grav = 0.0 + ENDIF + + IF ( Cascade_flag>0 ) THEN + DO k = 1, Active_hrus + i = Hru_route_order(k) + Upslope_interflow(i) = 0.0D0 + Upslope_dunnianflow(i) = 0.0D0 + ENDDO + IF ( Numlake_hrus>0 ) THEN + Lakein_sz = 0.0D0 + Basin_lakeinsz = 0.0D0 + ENDIF + ENDIF + + IF ( Print_debug==1 ) THEN + Soil_moist_ante = Soil_moist + Ssres_stor_ante = Ssres_stor + Last_soil_moist = Basin_soil_moist + Last_ssstor = Basin_ssstor + ENDIF + CALL init_basin_vars() + gwin = 0.0D0 + Basin_soil_moist = 0.0D0 + Basin_slstor = 0.0D0 + Basin_ssstor = 0.0D0 + Basin_pref_stor = 0.0D0 + Basin_soil_rechr = 0.0D0 + Basin_soil_moist_tot = 0.0D0 + Basin_cpr_stor_frac = 0.0D0 + Basin_gvr_stor_frac = 0.0D0 + Basin_pfr_stor_frac = 0.0D0 + update_potet = 0 + DO k = 1, Active_hrus + i = Hru_route_order(k) + + Hru_actet(i) = Hru_impervevap(i) + Hru_intcpevap(i) + Snow_evap(i) + IF ( Dprst_flag==1 ) Hru_actet(i) = Hru_actet(i) + Dprst_evap_hru(i) + harea = Hru_area(i) + + IF ( Hru_type(i)==2 ) THEN ! lake or reservoir + !WARNING, RSR, if hru_actet>water in lake, then budget error + Hru_actet(i) = (Potet(i) - Hru_actet(i))*Lake_evap_adj(Nowmonth,Lake_hru_id(i)) + IF ( Hru_actet(i)>Potet(i) ) THEN + PRINT *, 'WARNING, lake evap > potet, for HRU:', i, ' potential ET increased to adjusted lake ET' + PRINT *, Hru_actet(i), Potet(i), Hru_actet(i) - Potet(i) + Basin_potet = Basin_potet - DBLE( Potet(i)*harea ) + Potet(i) = Hru_actet(i) ! this could be a problem when it happens + Basin_potet = Basin_potet + DBLE( Potet(i)*harea ) + update_potet = 1 + ENDIF + Unused_potet(i) = Potet(i) - Hru_actet(i) + Basin_actet = Basin_actet + DBLE( Hru_actet(i)*harea ) + Basin_lakeevap = Basin_lakeevap + DBLE( Hru_actet(i)*harea ) + Basin_lakeprecip = Basin_lakeprecip + DBLE( Hru_ppt(i)*harea ) + IF ( Cascade_flag>0 ) THEN + ! if lake HRU doesn't cascade, should we limit ET to + ! water entering the HRU to this point (no gwflow yet) + Lakein_sz(i) = Upslope_interflow(i) + Upslope_dunnianflow(i) + Basin_lakeinsz = Basin_lakeinsz + Lakein_sz(i)*Hru_area_dble(i) + ENDIF + CYCLE + ENDIF + + perv_area = Hru_perv(i) + perv_frac = Hru_frac_perv(i) + + ! Soil_to_gw for whole HRU + Soil_to_gw(i) = 0.0 + Ssr_to_gw(i) = 0.0 + Slow_flow(i) = 0.0 + Ssres_flow(i) = 0.0 + avail_potet = Potet(i) - Hru_actet(i) + IF ( avail_potet<0.0 ) avail_potet = 0.0 +! Snowevap_aet_frac(i) = 0.0 + + !Hru_type can be 1 (land) or 3 (swale) or 4 (glacier) + Is_land = 0 + IF ( Hru_type(i)==1 .OR. Hru_type(i)==4 ) Is_land = 1 + +!******Add infiltration to soil and compute excess + ! note, perv_area has to be > 0.0 + dunnianflw = 0.0 + dunnianflw_pfr = 0.0 + dunnianflw_gvr = 0.0 + interflow = 0.0 + pref_flow_maxin = 0.0 + +!******Add infiltration to soil and compute excess + !infil_tot is the depth in whole HRU + !capillary reservoir for pervious area + !preferential flow reservoir for whole HRU + !gravity reservoir for whole HRU + !upslope flow for whole HRU + +!******if cascading flow available from upslope cascades +!****** add soil excess (Dunnian flow) to infiltration + ! perv_frac has to be > 0.001 + ! infil for pervious portion of HRU + capwater_maxin = Infil(i) + + cfgi_frozen_hru = 0 + thaw_frac = 1.0 + !Frozen is HRU variable that says if frozen gravity reservoir + ! For CFGI all inflow is assumed to be Dunnian Flow when frozen + IF ( Frozen_flag==1 ) THEN + IF ( Frozen(i)>=1 ) THEN + IF ( Hru_type(i)==3 ) THEN + PRINT *, 'ERROR, a swale HRU cannot be frozen for CFGI, HRU:', i + STOP + ENDIF + cfgi_frozen_hru = Frozen(i) + IF ( cfgi_frozen_hru==1 ) THEN + thaw_frac = 0.0 + ELSEIF ( cfgi_frozen_hru==2 ) THEN + thaw_frac = Thaw_depth(i)/Soil_depth(i) + ENDIF + ENDIF + ENDIF + + ! compute preferential flow and storage, and any dunnian flow + prefflow = 0.0 + prefflowmax = Pref_flow_max(i)*thaw_frac + IF ( Pref_flow_flag(i)==1 ) THEN + Pref_flow_infil(i) = 0.0 + IF ( capwater_maxin>0.0 ) THEN + ! pref_flow for whole HRU + pref_flow_maxin = capwater_maxin*Pref_flow_den(i) + capwater_maxin = capwater_maxin - pref_flow_maxin + pref_flow_maxin = pref_flow_maxin*perv_frac + IF ( cfgi_frozen_hru==1 ) THEN !frozen to top + dunnianflw_pfr = pref_flow_maxin + Basin_dunnian_pfr = Basin_dunnian_pfr + dunnianflw_pfr*harea + ELSE + ! compute contribution to preferential-flow reservoir storage + Pref_flow_stor(i) = Pref_flow_stor(i) + pref_flow_maxin + dunnianflw_pfr = MAX( 0.0, Pref_flow_stor(i)-prefflowmax) + IF ( dunnianflw_pfr>0.0 ) THEN + Basin_dunnian_pfr = Basin_dunnian_pfr + dunnianflw_pfr*harea + Pref_flow_stor(i) = prefflowmax + ENDIF + Pref_flow_infil(i) = pref_flow_maxin - dunnianflw_pfr + Basin_pref_flow_infil = Basin_pref_flow_infil + Pref_flow_infil(i)*harea + ENDIF + Pfr_dunnian_flow(i) = dunnianflw_pfr + ENDIF + ENDIF + + IF ( Cascade_flag>0 ) THEN +! Cap_upflow_max(i) = SNGL(Upslope_dunnianflow(i)+Upslope_interflow(i))/perv_frac +! capwater_maxin = capwater_maxin + Cap_upflow_max(i) +! Basin_cap_up_max = Basin_cap_up_max + Cap_upflow_max(i)*perv_area + cap_upflow_max = SNGL(Upslope_dunnianflow(i)+Upslope_interflow(i))/perv_frac + capwater_maxin = capwater_maxin + cap_upflow_max + Basin_cap_up_max = Basin_cap_up_max + cap_upflow_max*perv_area + ENDIF + Cap_infil_tot(i) = capwater_maxin*perv_frac + Basin_cap_infil_tot = Basin_cap_infil_tot + DBLE( Cap_infil_tot(i)*harea ) + +!******Add infiltration to soil and compute excess + gvr_maxin = 0.0 + Cap_waterin(i) = capwater_maxin + soilmoistmax = Soil_moist_max(i)*thaw_frac + soilrechrmax = Soil_rechr_max(i)*thaw_frac + soil2gwmax = Soil2gw_max(i) + ssr2gwrate = Ssr2gw_rate(i) + IF ( cfgi_frozen_hru==3 ) THEN !frozen layer below soil + soil2gwmax = 0.0 + Soil2gw(i) = 0 + ssr2gwrate = 0.0 + ENDIF + IF ( cfgi_frozen_hru/=1 ) THEN !some infiltration because not all the way frozen + ! call even if capwate_maxin = 0, just in case soil_moist now > Soil_moist_max + IF ( capwater_maxin+Soil_moist(i)>0.0 ) THEN + CALL compute_soilmoist(Cap_waterin(i), soilmoistmax, & + & soilrechrmax, soil2gwmax, gvr_maxin, & + & Soil_moist(i), Soil_rechr(i), Soil_to_gw(i), Soil2gw(i), perv_frac) + Cap_waterin(i) = Cap_waterin(i)*perv_frac + Basin_capwaterin = Basin_capwaterin + DBLE( Cap_waterin(i)*harea ) + Basin_soil_to_gw = Basin_soil_to_gw + DBLE( Soil_to_gw(i)*harea ) + Basin_sm2gvr_max = Basin_sm2gvr_max + DBLE( gvr_maxin*harea ) + ENDIF + ENDIF + ! Soil_to_ssr for whole HRU + Soil_to_ssr(i) = gvr_maxin + +! compute slow interflow and ssr_to_gw, changed to say effected by frozen state, already effected by reduced gvr_maxin if soil frozen + topfr = 0.0 + IF ( GSFLOW_flag==1 ) THEN + ! capacity for whole HRU + capacity = (soilmoistmax - Soil_moist(i))*perv_frac + CALL compute_gravflow(i, capacity, Slowcoef_lin(i), & + & Slowcoef_sq(i), ssr2gwrate, Ssr2gw_exp(i), & + & gvr_maxin, Pref_flow_thrsh(i), topfr, & + & Ssr_to_gw(i), Slow_flow(i), Slow_stor(i), & + & Gvr2sm(i), Soil_to_gw(i), gwin, Hru_type(i)) + ! adjust soil moisture with replenish amount + IF ( Gvr2sm(i)>0.0 ) THEN + Soil_moist(i) = Soil_moist(i) + Gvr2sm(i)/perv_frac +! IF ( Soil_moist(i)>soilmoistmax ) & +! & PRINT *, 'sm>max', Soil_moist(i), soilmoistmax, i + Soil_rechr(i) = Soil_rechr(i) + Gvr2sm(i)/perv_frac*Replenish_frac(i) + Soil_rechr(i) = MIN( soilrechrmax, Soil_rechr(i) ) + Basin_gvr2sm = Basin_gvr2sm + DBLE( Gvr2sm(i)*harea ) +! ELSEIF ( Gvr2sm(i)<-NEARZERO ) THEN +! PRINT *, 'negative gvr2sm, HRU:', i, Gvr2sm(i) +! Gvr2sm(i) = 0.0 + ENDIF + Grav_gwin(i) = SNGL( gwin ) + Basin_sz_gwin = Basin_sz_gwin + gwin*DBLE( harea ) + ELSE + availh2o = Slow_stor(i) + gvr_maxin + IF ( Hru_type(i)==1 ) THEN + topfr = MAX( 0.0, availh2o-Pref_flow_thrsh(i) ) + ssresin = gvr_maxin - topfr + Slow_stor(i) = availh2o - topfr + ! compute slow contribution to interflow, if any + IF ( Slow_stor(i)>0.0 ) & + & CALL compute_interflow(Slowcoef_lin(i), Slowcoef_sq(i), & + & ssresin, Slow_stor(i), Slow_flow(i)) + ELSEIF ( Hru_type(i)==3 ) THEN + Slow_stor(i) = availh2o + ENDIF + IF ( Slow_stor(i)>0.0 .AND. ssr2gwrate>0.0 ) & + & CALL compute_gwflow(ssr2gwrate, Ssr2gw_exp(i), Ssr_to_gw(i), Slow_stor(i)) + ENDIF + + ! compute contribution to Dunnian flow from PFR, if any + IF ( Pref_flow_flag(i)==1 ) THEN + availh2o = Pref_flow_stor(i) + topfr + dunnianflw_gvr = MAX( 0.0, availh2o-prefflowmax ) + IF ( dunnianflw_gvr>0.0 ) THEN + topfr = topfr - dunnianflw_gvr + IF ( topfr<0.0 ) THEN +! IF ( topfr<-NEARZERO .AND. Print_debug>-1 ) PRINT *, 'gvr2pfr<0', topfr, dunnianflw_gvr, & +! & prefflowmax, Pref_flow_stor(i), gvr_maxin + topfr = 0.0 + ENDIF + ENDIF + Pref_flow_in(i) = Pref_flow_infil(i) + topfr + Pref_flow_stor(i) = Pref_flow_stor(i) + topfr + IF ( Pref_flow_stor(i)>0.0 ) & + & CALL compute_interflow(Fastcoef_lin(i), Fastcoef_sq(i), & + & Pref_flow_in(i), Pref_flow_stor(i), prefflow) + Basin_pref_stor = Basin_pref_stor + DBLE( Pref_flow_stor(i)*harea ) +! Pfr_stor_frac(i) = 0.0 +! IF ( thaw_frac>0.0 ) Pfr_stor_frac(i) = Pref_flow_stor(i)/prefflowmax +! Basin_pfr_stor_frac = Basin_pfr_stor_frac + Pfr_stor_frac(i)*harea + IF ( prefflowmax>0) Basin_pfr_stor_frac = Basin_pfr_stor_frac + Pref_flow_stor(i)/prefflowmax*harea + ELSEIF ( Hru_type(i)==1 ) THEN + dunnianflw_gvr = topfr !?? is this right + ENDIF + Gvr2pfr(i) = topfr + + Basin_sm2gvr = Basin_sm2gvr + DBLE( Soil_to_ssr(i)*harea ) + Basin_dunnian_gvr = Basin_dunnian_gvr + DBLE( dunnianflw_gvr*harea ) + Basin_sz2gw = Basin_sz2gw + DBLE( Ssr_to_gw(i)*harea ) + +!******Compute actual evapotranspiration + Snow_free(i) = 1.0 - Snowcov_area(i) + Potet_rechr(i) = 0.0 + Potet_lower(i) = 0.0 + pervactet = 0.0 + IF ( Soil_moist(i)>0.0 .AND. cfgi_frozen_hru==0 ) THEN + CALL compute_szactet(soilmoistmax, soilrechrmax, Transp_on(i), Cov_type(i), & + & Soil_type(i), Soil_moist(i), Soil_rechr(i), pervactet, & + & avail_potet, Snow_free(i), Potet_rechr(i), Potet_lower(i)) + ! sanity check +! IF ( pervactet>avail_potet ) THEN +! Soil_moist(i) = Soil_moist(i) + pervactet - avail_potet +! pervactet = avail_potet +! PRINT *, 'perv_et problem', pervactet, Avail_potet +! ENDIF + ENDIF +! Perv_avail_et(i) = avail_potet + + ! sanity check +! IF ( Soil_moist(i)<0.0 ) THEN +! IF ( Print_debug>-1 ) PRINT *, i, Soil_moist(i), ' negative' +! IF ( pervactet>=ABS(Soil_moist(i)) ) THEN +! pervactet = pervactet + Soil_moist(i) +! Soil_moist(i) = 0.0 +! ENDIF +! IF ( Soil_moist(i)<-NEARZERO ) THEN +! IF ( Print_debug>-1 ) PRINT *, 'HRU:', i, ' soil_moist<0.0', Soil_moist(i) +! ENDIF +! Soil_moist(i) = 0.0 +! ENDIF + + Hru_actet(i) = Hru_actet(i) + pervactet*perv_frac + avail_potet = Potet(i) - Hru_actet(i) + ! sanity check +! IF ( avail_potet<0.0 ) THEN +! IF ( Print_debug>-1 ) THEN +! IF ( avail_potet<-NEARZERO ) PRINT *, 'hru_actet>potet', i, & +! & Nowmonth, Nowday, Hru_actet(i), Potet(i), avail_potet +! ENDIF +! Hru_actet(i) = Potet(i) +! tmp = avail_potet/perv_frac +! pervactet = pervactet + tmp +! Soil_moist(i) = Soil_moist(i) - tmp +! Soil_rechr(i) = Soil_rechr(i) - tmp +! IF ( Soil_rechr(i)<0.0 ) Soil_rechr(i) = 0.0 +! IF ( Soil_moist(i)<0.0 ) Soil_moist(i) = 0.0 +! ENDIF + Perv_actet(i) = pervactet + +! soil_moist & soil_rechr multiplied by perv_area instead of harea + Soil_lower(i) = Soil_moist(i) - Soil_rechr(i) + Basin_soil_moist = Basin_soil_moist + DBLE( Soil_moist(i)*perv_area ) + Basin_soil_rechr = Basin_soil_rechr + DBLE( Soil_rechr(i)*perv_area ) + Basin_perv_et = Basin_perv_et + DBLE( Perv_actet(i)*perv_area ) + +! if HRU cascades, +! compute interflow and excess flow to each HRU or stream + IF ( Is_land==1 ) THEN + interflow = Slow_flow(i) + prefflow +! Interflow_max(i) = interflow + Basin_interflow_max = Basin_interflow_max + interflow*harea + dunnianflw = dunnianflw_gvr + dunnianflw_pfr + Dunnian_flow(i) = dunnianflw + IF ( Cascade_flag>0 ) THEN + IF ( Ncascade_hru(i)>0 ) THEN + dnslowflow = 0.0 + dnpreflow = 0.0 + dndunn = 0.0 + IF ( interflow+dunnianflw>0.0 ) THEN + CALL compute_cascades(i, Ncascade_hru(i), Slow_flow(i), & + & prefflow, Dunnian_flow(i), dnslowflow, & + & dnpreflow, dndunn) + Basin_dninterflow = Basin_dninterflow + DBLE( (dnslowflow+dnpreflow)*harea ) + Basin_dndunnianflow = Basin_dndunnianflow + DBLE( dndunn*harea ) + ENDIF + Hru_sz_cascadeflow(i) = dnslowflow + dnpreflow + dndunn +! Cascade_interflow(i) = dnslowflow + dnpreflow +! Cascade_dunnianflow(i) = dndunn + Basin_dncascadeflow = Basin_dncascadeflow + DBLE( Hru_sz_cascadeflow(i)*harea ) + ENDIF + ENDIF + +! treat pref_flow as interflow + Ssres_flow(i) = Slow_flow(i) + IF ( Pref_flow_flag(i)==1 ) THEN + Pref_flow(i) = prefflow + Ssres_flow(i) = Ssres_flow(i) + prefflow + Basin_prefflow = Basin_prefflow + DBLE( prefflow*harea ) + Basin_gvr2pfr = Basin_gvr2pfr + DBLE( Gvr2pfr(i)*harea ) + ENDIF + Basin_ssflow = Basin_ssflow + DBLE( Ssres_flow(i)*harea ) + Basin_slowflow = Basin_slowflow + DBLE( Slow_flow(i)*harea ) + +! treat dunnianflw as surface runoff to streams + Sroff(i) = Sroff(i) + Dunnian_flow(i) + Basin_sroff = Basin_sroff + DBLE( Sroff(i)*harea ) + Basin_dunnian = Basin_dunnian + DBLE( Dunnian_flow(i)*harea ) + Ssres_stor(i) = Slow_stor(i) + Pref_flow_stor(i) + + ELSE ! for swales + availh2o = Slow_stor(i) - Sat_threshold(i) + Swale_actet(i) = 0.0 + IF ( availh2o>0.0 ) THEN ! if ponding, as storage > sat_threshold + unsatisfied_et = Potet(i) - Hru_actet(i) + IF ( unsatisfied_et>0.0 ) THEN + availh2o = MIN ( availh2o, unsatisfied_et ) + Swale_actet(i) = availh2o + Hru_actet(i) = Hru_actet(i) + Swale_actet(i) + Slow_stor(i) = Slow_stor(i) - Swale_actet(i) + Basin_swale_et = Basin_swale_et + DBLE( Swale_actet(i)*harea ) + ENDIF + IF ( Print_debug==7 ) THEN + IF ( Slow_stor(i)>Swale_limit(i) ) THEN + WRITE ( DBGUNT, * ) 'Swale ponding, HRU:', i, & + & ' gravity reservoir is 3*sat_threshold', Slow_stor(i), Sat_threshold(i) + CALL print_date(DBGUNT) + ENDIF + ENDIF + ENDIF + Ssres_stor(i) = Slow_stor(i) + ENDIF + + IF ( Soil_lower_stor_max(i)>0.0 ) Soil_lower_ratio(i) = Soil_lower(i)/Soil_lower_stor_max(i) +! Soil_rechr_ratio(i) = 0.0 +! IF ( thaw_frac>0.0 ) Soil_rechr_ratio(i) = Soil_rechr(i)/soilrechrmax + Ssres_in(i) = Soil_to_ssr(i) + Pref_flow_infil(i) + SNGL( gwin ) + Basin_ssin = Basin_ssin + DBLE( Ssres_in(i)*harea ) + Basin_ssstor = Basin_ssstor + DBLE( Ssres_stor(i)*harea ) + Basin_slstor = Basin_slstor + DBLE( Slow_stor(i)*harea ) + Soil_moist_tot(i) = Ssres_stor(i) + Soil_moist(i)*perv_frac + Basin_soil_moist_tot = Basin_soil_moist_tot + DBLE( Soil_moist_tot(i)*harea ) +! Soil_moist_frac(i) = Soil_moist_tot(i)/Soil_zone_max(i) +! Cpr_stor_frac(i) = 0.0 +! IF ( thaw_frac>0.0 ) Cpr_stor_frac(i) = Soil_moist(i)/soilmoistmax +! IF ( Pref_flow_thrsh(i)>0.0 ) Gvr_stor_frac(i) = Slow_stor(i)/Pref_flow_thrsh(i) +! Basin_cpr_stor_frac = Basin_cpr_stor_frac + Cpr_stor_frac(i)*perv_area +! Basin_gvr_stor_frac = Basin_gvr_stor_frac + Gvr_stor_frac(i)*harea +! Basin_sz_stor_frac = Basin_sz_stor_frac + Soil_moist_frac(i)*harea + IF ( thaw_frac>0.0 ) Basin_cpr_stor_frac = Basin_cpr_stor_frac + Soil_moist(i)/soilmoistmax*perv_area + IF ( Pref_flow_thrsh(i)>0.0 ) Basin_gvr_stor_frac = Basin_gvr_stor_frac + Slow_stor(i)/Pref_flow_thrsh(i)*harea + Basin_sz_stor_frac = Basin_sz_stor_frac + Soil_moist_tot(i)/Soil_zone_max(i)*harea + Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac + Soil_lower_ratio(i)*perv_area +! Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + Soil_rechr_ratio(i)*perv_area + IF ( soilrechrmax>0 ) Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac + Soil_rechr(i)/soilrechrmax*perv_area + Recharge(i) = Soil_to_gw(i) + Ssr_to_gw(i) + IF ( Dprst_flag==1 ) Recharge(i) = Recharge(i) + SNGL( Dprst_seep_hru(i) ) + Basin_recharge = Basin_recharge + DBLE( Recharge(i)*harea ) + Grav_dunnian_flow(i) = dunnianflw_gvr + Unused_potet(i) = Potet(i) - Hru_actet(i) + Basin_actet = Basin_actet + DBLE( Hru_actet(i)*harea ) +! IF ( Hru_actet(i)>0.0 ) Snowevap_aet_frac(i) = Snow_evap(i)/Hru_actet(i) + + ENDDO + Basin_actet = Basin_actet*Basin_area_inv + Basin_perv_et = Basin_perv_et*Basin_area_inv + Basin_swale_et = Basin_swale_et*Basin_area_inv + Basin_soil_rechr = Basin_soil_rechr*Basin_area_inv + Basin_soil_to_gw = Basin_soil_to_gw*Basin_area_inv + Basin_soil_moist = Basin_soil_moist*Basin_area_inv + IF ( update_potet==1 ) Basin_potet = Basin_potet*Basin_area_inv + Basin_soil_moist_tot = Basin_soil_moist_tot*Basin_area_inv + IF ( Nlake>0 ) THEN + Basin_lakeevap = Basin_lakeevap*Basin_area_inv + Basin_lakeprecip = Basin_lakeprecip*Basin_area_inv + Basin_lakeinsz = Basin_lakeinsz*Basin_area_inv + Basin_lake_stor = Basin_lake_stor + Basin_lakeprecip - Basin_lakeevap + ENDIF + IF ( Pref_flag==1 ) THEN + Basin_pref_stor = Basin_pref_stor*Basin_area_inv + Basin_pref_flow_infil = Basin_pref_flow_infil*Basin_area_inv + Basin_prefflow = Basin_prefflow*Basin_area_inv + Basin_dunnian_pfr = Basin_dunnian_pfr*Basin_area_inv + Basin_pfr_stor_frac = Basin_pfr_stor_frac*Basin_area_inv + ENDIF + Basin_dunnian_gvr = Basin_dunnian_gvr*Basin_area_inv + Basin_ssstor = Basin_ssstor*Basin_area_inv + Basin_ssflow = Basin_ssflow*Basin_area_inv + Basin_interflow_max = Basin_interflow_max*Basin_area_inv + Basin_sz2gw = Basin_sz2gw*Basin_area_inv + Basin_ssin = Basin_ssin*Basin_area_inv + Basin_slstor = Basin_slstor*Basin_area_inv + Basin_sroff = Basin_sroff*Basin_area_inv + Basin_dunnian = Basin_dunnian*Basin_area_inv + Basin_sm2gvr = Basin_sm2gvr*Basin_area_inv + Basin_sm2gvr_max = Basin_sm2gvr_max*Basin_area_inv + Basin_capwaterin = Basin_capwaterin*Basin_area_inv + Basin_cap_infil_tot = Basin_cap_infil_tot*Basin_area_inv + Basin_cap_up_max = Basin_cap_up_max*Basin_area_inv + Basin_dninterflow = Basin_dninterflow*Basin_area_inv + Basin_dndunnianflow = Basin_dndunnianflow*Basin_area_inv + Basin_dncascadeflow = Basin_dncascadeflow*Basin_area_inv + Basin_gvr2pfr = Basin_gvr2pfr*Basin_area_inv + Basin_slowflow = Basin_slowflow*Basin_area_inv + Basin_recharge = Basin_recharge*Basin_area_inv + Basin_gvr2sm = Basin_gvr2sm*Basin_area_inv + Basin_sz_gwin = Basin_sz_gwin*Basin_area_inv + Basin_cpr_stor_frac = Basin_cpr_stor_frac*Basin_area_inv + Basin_gvr_stor_frac = Basin_gvr_stor_frac*Basin_area_inv + Basin_sz_stor_frac = Basin_sz_stor_frac*Basin_area_inv + Basin_soil_lower_stor_frac = Basin_soil_lower_stor_frac*Basin_area_inv + Basin_soil_rechr_stor_frac = Basin_soil_rechr_stor_frac*Basin_area_inv + + END FUNCTION szrun + +!*********************************************************************** +! Add infiltration to soil and compute excess +! Soil_to_gw and Soil_to_ssr for whole HRU +!*********************************************************************** + SUBROUTINE compute_soilmoist(Infil, Soil_moist_max, & + & Soil_rechr_max, Soil2gw_max, Soil_to_ssr, Soil_moist, & + & Soil_rechr, Soil_to_gw, Soil2gw, Perv_frac) + IMPLICIT NONE + INTRINSIC MIN +! Arguments + INTEGER, INTENT(IN) :: Soil2gw + REAL, INTENT(IN) :: Perv_frac, Soil_moist_max, Soil_rechr_max, Soil2gw_max + REAL, INTENT(INOUT) :: Infil, Soil_moist, Soil_rechr, Soil_to_gw, Soil_to_ssr +! Local Variables + REAL :: excs +!*********************************************************************** + Soil_rechr = MIN( (Soil_rechr+Infil), Soil_rechr_max ) + ! soil_moist_max from previous time step or soil_moist_max has + ! changed for a restart simulation + excs = Soil_moist + Infil + Soil_moist = MIN( excs, Soil_moist_max ) + excs = (excs - Soil_moist_max)*Perv_frac + IF ( excs>0.0 ) THEN + IF ( Soil2gw==1 ) THEN + Soil_to_gw = MIN( Soil2gw_max, excs ) + excs = excs - Soil_to_gw + ENDIF + IF ( excs>Infil*Perv_frac ) THEN !probably dynamic + Infil = 0.0 + ELSE + Infil = Infil - excs/Perv_frac !???? what if Infil<0 ??? might happen with dynamic and small values, maybe ABS < NEARZERO = 0.0 +! IF ( Infil<0.0 ) THEN +! IF ( Infil<-0.0001 ) THEN +! PRINT *, 'negative infil', infil, soil_moist, excs +! Soil_moist = Soil_moist + Infil +! ENDIF +! Infil = 0.0 +! ENDIF + ENDIF + + Soil_to_ssr = excs + IF ( Soil_to_ssr<0.0 ) Soil_to_ssr = 0.0 + ENDIF + + END SUBROUTINE compute_soilmoist + +!*********************************************************************** +! Compute actual evapotranspiration +!*********************************************************************** + SUBROUTINE compute_szactet(Soil_moist_max, Soil_rechr_max, & + & Transp_on, Cov_type, Soil_type, & + & Soil_moist, Soil_rechr, Perv_actet, Avail_potet, & + & Snow_free, Potet_rechr, Potet_lower) + USE PRMS_SOILZONE, ONLY: Et_type + USE PRMS_BASIN, ONLY: NEARZERO + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Transp_on, Cov_type, Soil_type + REAL, INTENT(IN) :: Soil_moist_max, Soil_rechr_max, Snow_free + REAL, INTENT(INOUT) :: Soil_moist, Soil_rechr, Avail_potet, Potet_rechr, Potet_lower + REAL, INTENT(OUT) :: Perv_actet +! Local Variables + REAL, PARAMETER :: ONETHIRD = 1.0/3.0, TWOTHIRDS = 2.0/3.0 + REAL :: et, pcts, pctr +!*********************************************************************** +!******Determine if evaporation(Et_type = 2) or transpiration plus +!******evaporation(Et_type = 3) are active. if not, Et_type = 1 + + IF ( Avail_potet0 ) THEN + Et_type = 3 + ELSEIF ( Snow_free<0.01 ) THEN + Et_type = 1 + ELSE + Et_type = 2 + ENDIF + + IF ( Et_type>1 ) THEN + pcts = Soil_moist/Soil_moist_max + pctr = Soil_rechr/Soil_rechr_max + Potet_lower = Avail_potet + Potet_rechr = Avail_potet + +!******sandy soil + IF ( Soil_type==1 ) THEN + IF ( pcts<0.25 ) Potet_lower = 0.5*pcts*Avail_potet + IF ( pctr<0.25 ) Potet_rechr = 0.5*pctr*Avail_potet +!******loam soil + ELSEIF ( Soil_type==2 ) THEN + IF ( pcts<0.5 ) Potet_lower = pcts*Avail_potet + IF ( pctr<0.5 ) Potet_rechr = pctr*Avail_potet +!******clay soil + ELSEIF ( Soil_type==3 ) THEN + IF ( pctsONETHIRD ) THEN + Potet_lower = pcts*Avail_potet + ELSEIF ( pcts<=ONETHIRD ) THEN + Potet_lower = 0.5*pcts*Avail_potet + ENDIF + IF ( pctrONETHIRD ) THEN + Potet_rechr = pctr*Avail_potet + ELSEIF ( pctr<=ONETHIRD ) THEN + Potet_rechr = 0.5*pctr*Avail_potet + ENDIF + ENDIF + +!******Soil moisture accounting + IF ( Et_type==2 ) Potet_rechr = Potet_rechr*Snow_free + IF ( Potet_rechr>Soil_rechr ) THEN + Potet_rechr = Soil_rechr + Soil_rechr = 0.0 + ELSE + Soil_rechr = Soil_rechr - Potet_rechr + ENDIF + IF ( Et_type==2 .OR. Potet_rechr>=Potet_lower ) THEN + IF ( Potet_rechr>Soil_moist ) THEN + Potet_rechr = Soil_moist + Soil_moist = 0.0 + ELSE + Soil_moist = Soil_moist - Potet_rechr + ENDIF + et = Potet_rechr + ELSEIF ( Potet_lower>Soil_moist ) THEN + et = Soil_moist + Soil_moist = 0.0 + ELSE + Soil_moist = Soil_moist - Potet_lower + et = Potet_lower + ENDIF + IF ( Soil_rechr>Soil_moist ) Soil_rechr = Soil_moist + ELSE + et = 0.0 + ENDIF + Perv_actet = et + ! sanity check +! IF ( Perv_actet>Avail_potet ) THEN +! PRINT *, 'perv_et problem', Perv_actet, Avail_potet +! Soil_moist = Soil_moist + Perv_actet - Avail_potet +! Perv_actet = Avail_potet +! ENDIF + + END SUBROUTINE compute_szactet + +!*********************************************************************** +! compute interflow and flow to groundwater reservoir +!*********************************************************************** + SUBROUTINE compute_gwflow(Ssr2gw_rate, Ssr2gw_exp, Ssr_to_gw, Slow_stor) + IMPLICIT NONE +! Arguments + REAL, INTENT(IN) :: Ssr2gw_rate, Ssr2gw_exp + REAL, INTENT(INOUT) :: Slow_stor, Ssr_to_gw +!*********************************************************************** +!******compute flow to groundwater + Ssr_to_gw = Ssr2gw_rate*(Slow_stor**Ssr2gw_exp) + IF ( Ssr_to_gw<0.0 ) THEN + Ssr_to_gw = 0.0 + ELSEIF ( Ssr_to_gw>Slow_stor ) THEN + Ssr_to_gw = Slow_stor + ENDIF + Slow_stor = Slow_stor - Ssr_to_gw + + END SUBROUTINE compute_gwflow + +!*********************************************************************** +! Compute subsurface lateral flow +!*********************************************************************** + SUBROUTINE compute_interflow(Coef_lin, Coef_sq, Ssres_in, Storage, Inter_flow) +! USE PRMS_BASIN, ONLY: NEARZERO, CLOSEZERO + IMPLICIT NONE + INTRINSIC EXP, SQRT +! Arguments + REAL, INTENT(IN) :: Coef_lin, Coef_sq, Ssres_in + REAL, INTENT(INOUT) :: Storage, Inter_flow +! Local Variables + REAL :: c1, c2, c3, sos +!*********************************************************************** +! Inter_flow is in inches for the timestep +!******compute interflow + IF ( Coef_lin<=0.0 .AND. Ssres_in<=0.0 ) THEN + c1 = Coef_sq*Storage + Inter_flow = Storage*(c1/(1.0+c1)) + ELSEIF ( Coef_lin>0.0 .AND. Coef_sq<=0.0 ) THEN + c2 = 1.0 - EXP(-Coef_lin) + Inter_flow = Ssres_in*(1.0-c2/Coef_lin) + Storage*c2 + ELSEIF ( Coef_sq>0.0 ) THEN + c3 = SQRT(Coef_lin**2.0+4.0*Coef_sq*Ssres_in) + sos = Storage - ((c3-Coef_lin)/(2.0*Coef_sq)) + IF ( c3==0.0 ) STOP 'ERROR, in compute_interflow sos=0, please contact code developers' + c1 = Coef_sq*sos/c3 + c2 = 1.0 - EXP(-c3) + IF ( 1.0+c1*c2>0.0 ) THEN + Inter_flow = Ssres_in + (sos*(1.0+c1)*c2)/(1.0+c1*c2) + ELSE + Inter_flow = Ssres_in + ENDIF + ELSE + Inter_flow = 0.0 + ENDIF + +! sanity check + IF ( Inter_flow<0.0 ) THEN +! IF ( Inter_flow<-NEARZERO ) PRINT *, 'interflow<0', Inter_flow, Ssres_in, Storage + Inter_flow = 0.0 + ELSEIF ( Inter_flow>Storage ) THEN + Inter_flow = Storage + ENDIF + Storage = Storage - Inter_flow +! IF ( Storage<0.0 ) THEN +! IF ( Storage<-CLOSEZERO ) PRINT *, 'Sanity check, ssres_stor<0.0', Storage +! Storage = 0.0 +! rsr, if very small storage, add it to interflow +! ELSEIF ( Storage>0.0 .AND. Storage 0, cascade contributes to a downslope HRU + IF ( j>0 ) THEN + fracwt = Hru_down_fracwt(k, Ihru) + Upslope_interflow(j) = Upslope_interflow(j) + DBLE( (Slowflow+Preflow)*fracwt ) + Upslope_dunnianflow(j) = Upslope_dunnianflow(j) + DBLE( Dunnian*fracwt ) + Dnslowflow = Dnslowflow + Slowflow*frac + Dnpreflow = Dnpreflow + Preflow*frac + Dndunnflow = Dndunnflow + Dunnian*frac +! if hru_down(k, Ihru) < 0, cascade contributes to a stream + ELSEIF ( j<0 ) THEN + j = IABS(j) + Strm_seg_in(j) = Strm_seg_in(j) + DBLE( (Slowflow+Preflow+Dunnian)*Cascade_area(k, Ihru) )*Cfs_conv + ENDIF + ENDDO + +! reset Slowflow, Preflow, and Dunnian_flow as they accumulate flow to streams + Slowflow = Slowflow - Dnslowflow + Preflow = Preflow - Dnpreflow + Dunnian = Dunnian - Dndunnflow + + END SUBROUTINE compute_cascades + +!*********************************************************************** +! compute interflow and flow to groundwater reservoir +!*********************************************************************** + SUBROUTINE compute_gravflow(Ihru, Capacity, Slowcoef_lin, & + & Slowcoef_sq, Ssr2gw_rate, Ssr2gw_exp, Gvr_maxin, & + & Pref_flow_thrsh, Gvr2pfr, Ssr_to_gw, & + & Slow_flow, Slow_stor, Gvr2sm, Soil_to_gw, Gwin, Hru_type) + USE PRMS_SOILZONE, ONLY: Gravity_stor_res, Sm2gw_grav, Hru_gvr_count, Hru_gvr_index, & + & Gw2sm_grav, Gvr_hru_pct_adjusted + USE PRMS_MODULE, ONLY: Dprst_flag, Print_debug + USE PRMS_SRUNOFF, ONLY: Dprst_seep_hru + IMPLICIT NONE +! Functions + INTRINSIC MAX, DBLE, SNGL + EXTERNAL check_gvr_sm, compute_interflow +! Arguments + INTEGER, INTENT(IN) :: Ihru, Hru_type + REAL, INTENT(IN) :: Slowcoef_lin, Slowcoef_sq, Ssr2gw_rate, Ssr2gw_exp + REAL, INTENT(IN) :: Pref_flow_thrsh, Soil_to_gw, Gvr_maxin + REAL, INTENT(INOUT) :: Capacity + REAL, INTENT(OUT) :: Ssr_to_gw, Slow_stor, Slow_flow, Gvr2pfr, Gvr2sm + DOUBLE PRECISION, INTENT(OUT) :: Gwin +! Local Variables + INTEGER :: j, igvr + REAL :: perc, slowflow, extra_water, gvrin_actual, depth, input + DOUBLE PRECISION :: topfr, slflow, togw, slowstor, frac +!*********************************************************************** + !Capacity is for whole HRU + !Soil_to_gw is for whole HRU + !TO DO +! use VKS as a function of slope (vector analysis) instead of coef_lin +! coef_lin for pref_flow needs to be VKS lateral times a factor +! change slow to interflow +! in init, set an array dimensioned by nhrucell to vks*mfl_to_inch + + Gwin = 0.0D0 + Gvr2sm = 0.0 + topfr = 0.0D0 + slflow = 0.0D0 + togw = 0.0D0 + slowstor = 0.0D0 + DO j = 1, Hru_gvr_count(Ihru) + igvr = Hru_gvr_index(j, Ihru) + frac = Gvr_hru_pct_adjusted(igvr) + Gwin = Gwin + DBLE( Gw2sm_grav(igvr) )*frac + input = Gvr_maxin + Gw2sm_grav(igvr) + depth = Gravity_stor_res(igvr) + input + IF ( depth>0.0 .AND. Capacity>0.0 ) CALL check_gvr_sm(Capacity, depth, frac, Gvr2sm, input) + + IF ( Hru_type==1 ) THEN + extra_water = MAX( 0.0, depth-Pref_flow_thrsh ) + IF ( extra_water>0.0 ) THEN + !compute contribution to preferential-flow reservoir storage + topfr = topfr + DBLE( extra_water )*frac + depth = Pref_flow_thrsh + ENDIF + gvrin_actual = MAX(0.0, input-extra_water) + +! compute contribution to slow interflow, if any + IF ( depth>0.0 ) THEN + CALL compute_interflow(Slowcoef_lin, Slowcoef_sq, gvrin_actual, depth, slowflow) + slflow = slflow + DBLE( slowflow )*frac + ENDIF + ENDIF + +! compute flow to groundwater, if any + IF ( depth>0.0 ) THEN + IF ( Ssr2gw_rate>0.0 ) THEN +! use VKS instead of rate ??????????????? + perc = Ssr2gw_rate*(depth**Ssr2gw_exp) + IF ( perc<0.0 ) THEN + perc = 0.0 + ELSEIF ( perc>depth ) THEN + perc = depth + ENDIF + depth = depth - perc +! IF ( sm2gw_grav(igvr)>0.0 ) print*,'problem',sm2gw_grav(igvr),igvr + Sm2gw_grav(igvr) = perc + togw = togw + DBLE( perc )*frac + ENDIF +! ELSE ! GVRs can go negative if flux change in MODFLOW final iteration decreases, so don't set to 0 +! if(depth<0.0) print *, 'depth<0', depth, ihru +! depth = 0.0 + ENDIF + + Gravity_stor_res(igvr) = depth + slowstor = slowstor + DBLE(depth)*frac + +! add any direct recharge from soil infiltration + Sm2gw_grav(igvr) = Sm2gw_grav(igvr) + Soil_to_gw + IF ( Dprst_flag==1 ) Sm2gw_grav(igvr) = Sm2gw_grav(igvr) + SNGL( Dprst_seep_hru(Ihru) ) + + ENDDO ! end loop of GVRs in the HRU + + Gvr2pfr = SNGL( topfr ) + Slow_flow = SNGL( slflow ) + Ssr_to_gw = SNGL( togw ) + Slow_stor = SNGL( slowstor ) + IF ( Slow_stor>Pref_flow_thrsh ) THEN + IF ( Print_debug>-1 .AND. Hru_type==1 ) & + & PRINT *, 'slow_stor > thrsh', Slow_stor, Pref_flow_thrsh, ' HRU:', Ihru, ' type:', Hru_type + ENDIF + + END SUBROUTINE compute_gravflow + +!*********************************************************************** +! adjust soil moist based on being below field capacity (capacity) +! and preferential-flow threshold (Pref_flow_thrsh) +!*********************************************************************** + SUBROUTINE check_gvr_sm(Capacity, Depth, Frac, Gvr2sm, Input) +! USE PRMS_BASIN, ONLY: CLOSEZERO + IMPLICIT NONE +! Functions + INTRINSIC MAX, ABS, SNGL +! Arguments + DOUBLE PRECISION, INTENT(IN) :: Frac + REAL, INTENT(INOUT) :: Capacity, Gvr2sm, Depth, Input +! Local Variables + REAL :: to_sm, frac_sngl +!*********************************************************************** +! check to see if soil is below capacity, if so add up to field capacity +! Capacity is for whole HRU +! to_sm and Gvr2sm are for whole HRU + + frac_sngl = SNGL( Frac ) + ! fill up capillary with part of gravity water + to_sm = Capacity + ! take all gravity water and put in capillary + IF ( to_sm>Depth ) to_sm = Depth + +! compute adjusmtent to soil moist to get to field capacity + Capacity = Capacity - to_sm*frac_sngl + IF ( Capacity<0.0 ) THEN + to_sm = to_sm - Capacity*frac_sngl + Capacity = 0.0 + ENDIF + Gvr2sm = Gvr2sm + to_sm*frac_sngl + Depth = Depth - to_sm + !IF ( Depth<0.0 ) PRINT *, 'depth<0', depth +! IF ( Depth0 ) CALL srunoff_restart(1) + srunoff = srunoffinit() + ELSEIF ( Process(:5)=='clean' ) THEN + IF ( Save_vars_to_file==1 ) CALL srunoff_restart(0) + ENDIF + + END FUNCTION srunoff + +!*********************************************************************** +! srunoffdecl - set up parameters for surface runoff computations +! Declared Parameters +! smidx_coef, smidx_exp, carea_max, imperv_stor_max, snowinfil_max +! hru_area, soil_moist_max, soil_rechr_max, carea_min +! cfgi_thrshld, cfgi_decay, soil_depth, soil_den, porosity_hru +!*********************************************************************** + INTEGER FUNCTION srunoffdecl() + USE PRMS_SRUNOFF + USE PRMS_MODULE, ONLY: Model, Dprst_flag, Nhru, Nsegment, Print_debug, & + & Cascade_flag, Sroff_flag, Nlake, Init_vars_from_file, Call_cascade, PRMS4_flag, & + & Frozen_flag + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: declvar, declparam + EXTERNAL read_error, print_module +! Local Variables + CHARACTER(LEN=80), SAVE :: Version_srunoff +!*********************************************************************** + srunoffdecl = 0 + + Version_srunoff = 'srunoff.f90 2019-05-24 14:50:00Z' + IF ( Sroff_flag==1 ) THEN + MODNAME = 'srunoff_smidx' + ELSE + MODNAME = 'srunoff_carea' + ENDIF + Version_srunoff = MODNAME//'.f90 '//Version_srunoff(13:80) + CALL print_module(Version_srunoff, 'Surface Runoff ', 90) + + IF ( declvar(MODNAME, 'basin_imperv_evap', 'one', 1, 'double', & + & 'Basin area-weighted average evaporation from impervious area', & + & 'inches', Basin_imperv_evap)/=0 ) CALL read_error(3, 'basin_imperv_evap') + + IF ( declvar(MODNAME, 'basin_imperv_stor', 'one', 1, 'double', & + & 'Basin area-weighted average storage on impervious area', & + & 'inches', Basin_imperv_stor)/=0 ) CALL read_error(3, 'basin_imperv_stor') + + IF ( declvar(MODNAME, 'basin_infil', 'one', 1, 'double', & + & 'Basin area-weighted average infiltration to the capillary reservoirs', & + & 'inches', Basin_infil)/=0 ) CALL read_error(3, 'basin_infil') + + IF ( declvar(MODNAME, 'basin_sroff', 'one', 1, 'double', & + & 'Basin area-weighted average surface runoff to the stream network', & + & 'inches', Basin_sroff)/=0 ) CALL read_error(3, 'basin_sroff') + + IF ( declvar(MODNAME, 'basin_hortonian', 'one', 1, 'double', & + & 'Basin area-weighted average Hortonian runoff', & + & 'inches', Basin_hortonian)/=0 ) CALL read_error(3, 'basin_hortonian') + + IF ( declvar(MODNAME, 'basin_contrib_fraction', 'one', 1, 'double', & + & 'Basin area-weighted average contributing area of the pervious area of each HRU', & + & 'decimal fraction', Basin_contrib_fraction)/=0 ) CALL read_error(3, 'basin_contrib_fraction') + + ALLOCATE ( Contrib_fraction(Nhru) ) + IF ( declvar(MODNAME, 'contrib_fraction', 'nhru', Nhru, 'real', & + & 'Contributing area of each HRU pervious area', & + & 'decimal fraction', Contrib_fraction)/=0 ) CALL read_error(3, 'contrib_fraction') + + ALLOCATE ( Hru_impervevap(Nhru) ) + IF ( declvar(MODNAME, 'hru_impervevap', 'nhru', Nhru, 'real', & + & 'HRU area-weighted average evaporation from impervious area for each HRU', & + & 'inches', Hru_impervevap)/=0 ) CALL read_error(3, 'hru_impervevap') + + ALLOCATE ( Hru_impervstor(Nhru) ) + IF ( declvar(MODNAME, 'hru_impervstor', 'nhru', Nhru, 'real', & + & 'HRU area-weighted average storage on impervious area for each HRU', & + & 'inches', Hru_impervstor)/=0 ) CALL read_error(3, 'hru_impervstor') + + ALLOCATE ( Imperv_evap(Nhru) ) + IF ( declvar(MODNAME, 'imperv_evap', 'nhru', Nhru, 'real', & + & 'Evaporation from impervious area for each HRU', & + & 'inches', Imperv_evap)/=0 ) CALL read_error(3, 'imperv_evap') + + IF ( declvar(MODNAME, 'basin_sroffi', 'one', 1, 'double', & + & 'Basin area-weighted average surface runoff from impervious areas', & + & 'inches', Basin_sroffi)/=0 ) CALL read_error(3, 'basin_sroffi') + + IF ( declvar(MODNAME, 'basin_sroffp', 'one', 1, 'double', & + & 'Basin area-weighted average surface runoff from pervious areas', & + & 'inches', Basin_sroffp)/=0 ) CALL read_error(3, 'basin_sroffp') + + ALLOCATE ( Hru_sroffp(Nhru) ) + IF ( declvar(MODNAME, 'hru_sroffp', 'nhru', Nhru, 'real', & + & 'HRU area-weighted average surface runoff from pervious areas for each HRU', & + & 'inches', Hru_sroffp)/=0 ) CALL read_error(3, 'hru_sroffp') + + ALLOCATE ( Hru_sroffi(Nhru) ) + IF ( declvar(MODNAME, 'hru_sroffi', 'nhru', Nhru, 'real', & + & 'HRU area-weighted average surface runoff from impervious areas for each HRU', & + & 'inches', Hru_sroffi)/=0 ) CALL read_error(3, 'hru_sroffi') + +! Depression storage variables + IF ( Dprst_flag==1 .OR. Model==99 ) THEN + IF ( declvar(MODNAME, 'basin_dprst_sroff', 'one', 1, 'double', & + & 'Basin area-weighted average surface runoff from open surface-depression storage', & + & 'inches', Basin_dprst_sroff)/=0 ) CALL read_error(3, 'basin_dprst_sroff') + + IF ( declvar(MODNAME, 'basin_dprst_evap', 'one', 1, 'double', & + & 'Basin area-weighted average evaporation from surface-depression storage', & + & 'inches', Basin_dprst_evap)/=0 ) CALL read_error(3, 'basin_dprst_evap') + + IF ( declvar(MODNAME, 'basin_dprst_seep', 'one', 1, 'double', & + & 'Basin area-weighted average seepage from surface-depression storage', & + & 'inches', Basin_dprst_seep)/=0 ) CALL read_error(3, 'basin_dprst_seep') + + IF ( declvar(MODNAME, 'basin_dprst_volop', 'one', 1, 'double', & + & 'Basin area-weighted average storage volume in open surface depressions', & + & 'inches', Basin_dprst_volop)/=0 ) CALL read_error(3, 'basin_dprst_volop') + + IF ( declvar(MODNAME, 'basin_dprst_volcl', 'one', 1, 'double', & + & 'Basin area-weighted average storage volume in closed surface depressions', & + & 'inches', Basin_dprst_volcl)/=0 ) CALL read_error(3, 'basin_dprst_volcl') + + ALLOCATE ( Dprst_sroff_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_sroff_hru', 'nhru', Nhru, 'double', & + & 'Surface runoff from open surface-depression storage for each HRU', & + & 'inches', Dprst_sroff_hru)/=0 ) CALL read_error(3, 'dprst_sroff_hru') + + ALLOCATE ( Dprst_insroff_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_insroff_hru', 'nhru', Nhru, 'real', & + & 'Surface runoff from pervious and impervious portions into open and closed surface-depression storage for each HRU', & + & 'inches', Dprst_insroff_hru)/=0 ) CALL read_error(3, 'dprst_insroff_hru') + + ALLOCATE ( Dprst_area_open(Nhru) ) + IF ( declvar(MODNAME, 'dprst_area_open', 'nhru', Nhru, 'real', & + & 'Surface area of open surface depressions based on storage volume for each HRU', & + & 'acres', Dprst_area_open)/=0 ) CALL read_error(3, 'dprst_area_open') + + ALLOCATE ( Dprst_area_clos(Nhru) ) + IF ( declvar(MODNAME, 'dprst_area_clos', 'nhru', Nhru, 'real', & + & 'Surface area of closed surface depressions based on storage volume for each HRU', & + & 'acres', Dprst_area_clos)/=0 ) CALL read_error(3, 'dprst_area_clos') + + ALLOCATE ( Dprst_stor_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_stor_hru', 'nhru', Nhru, 'double', & + & 'Surface-depression storage for each HRU', & + & 'inches', Dprst_stor_hru)/=0 ) CALL read_error(3, 'dprst_stor_hru') + + ALLOCATE ( Dprst_seep_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_seep_hru', 'nhru', Nhru, 'double', & + & 'Seepage from surface-depression storage to associated GWR for each HRU', & + & 'inches', Dprst_seep_hru)/=0 ) CALL read_error(3, 'dprst_seep_hru') + + ALLOCATE ( Dprst_evap_hru(Nhru) ) + IF ( declvar(MODNAME, 'dprst_evap_hru', 'nhru', Nhru, 'real', & + & 'Evaporation from surface-depression storage for each HRU', & + & 'inches', Dprst_evap_hru)/=0 ) CALL read_error(3, 'dprst_evap_hru') + + ALLOCATE ( Dprst_vol_open_frac(Nhru) ) + IF ( declvar(MODNAME, 'dprst_vol_open_frac', 'nhru', Nhru, 'real', & + & 'Fraction of open surface-depression storage of the maximum storage for each HRU', & + & 'decimal fraction', Dprst_vol_open_frac)/=0 ) CALL read_error(3, 'dprst_vol_open_frac') + + ALLOCATE ( Dprst_vol_clos_frac(Nhru) ) + IF ( declvar(MODNAME, 'dprst_vol_clos_frac', 'nhru', Nhru, 'real', & + & 'Fraction of closed surface-depression storage of the maximum storage for each HRU', & + & 'decimal fraction', Dprst_vol_clos_frac)/=0 ) CALL read_error(3, 'dprst_vol_clos_frac') + + ALLOCATE ( Dprst_vol_frac(Nhru) ) + IF ( declvar(MODNAME, 'dprst_vol_frac', 'nhru', Nhru, 'real', & + & 'Fraction of surface-depression storage of the maximum storage for each HRU', & + & 'decimal fraction', Dprst_vol_frac)/=0 ) CALL read_error(3, 'dprst_vol_frac') + + ALLOCATE ( Dprst_vol_open_max(Nhru), Dprst_vol_clos_max(Nhru), Dprst_vol_thres_open(Nhru), Dprst_in(Nhru) ) + ENDIF + + ALLOCATE ( Hortonian_flow(Nhru) ) + IF ( declvar(MODNAME, 'hortonian_flow', 'nhru', Nhru, 'real', & + & 'Hortonian surface runoff reaching stream network for each HRU', & + & 'inches', Hortonian_flow)/=0 ) CALL read_error(3, 'hortonian_flow') + +! cascading variables and parameters + IF ( Cascade_flag>0 .OR. Model==99 ) THEN + ALLOCATE ( Upslope_hortonian(Nhru) ) + IF ( declvar(MODNAME, 'upslope_hortonian', 'nhru', Nhru, 'double', & + & 'Hortonian surface runoff received from upslope HRUs', & + & 'inches', Upslope_hortonian)/=0 ) CALL read_error(3, 'upslope_hortonian') + + IF ( declvar(MODNAME, 'basin_sroff_down', 'one', 1, 'double', & + & 'Basin area-weighted average of cascading surface runoff', & + & 'inches', Basin_sroff_down)/=0 ) CALL read_error(3, 'basin_sroff_down') + + IF ( declvar(MODNAME, 'basin_sroff_upslope', 'one', 1, 'double', & + & 'Basin area-weighted average of cascading surface runoff received from upslope HRUs', & + & 'inches', Basin_sroff_upslope)/=0 ) CALL read_error(3, 'basin_sroff_upslope') + + ALLOCATE ( Hru_hortn_cascflow(Nhru) ) + IF ( declvar(MODNAME, 'hru_hortn_cascflow', 'nhru', Nhru, 'double', & + & 'Cascading Hortonian surface runoff leaving each HRU', & + & 'inches', Hru_hortn_cascflow)/=0 ) CALL read_error(3, 'hru_hortn_cascflow') + + IF ( Nlake>0 ) THEN + IF ( declvar(MODNAME, 'basin_hortonian_lakes', 'one', 1, 'double', & + & 'Basin area-weighted average Hortonian surface runoff to lakes', & + & 'inches', Basin_hortonian_lakes)/=0 ) CALL read_error(3, 'basin_hortonian_lakes') + + ALLOCATE ( Hortonian_lakes(Nhru) ) + IF ( declvar(MODNAME, 'hortonian_lakes', 'nhru', Nhru, 'double', & + & 'Surface runoff to lakes for each HRU', & + & 'inches', Hortonian_lakes)/=0 ) CALL read_error(3, 'hortonian_lakes') + ENDIF + ENDIF + + IF ( Call_cascade==1 .OR. Model==99 ) THEN + ALLOCATE ( Strm_seg_in(Nsegment) ) + IF ( declvar(MODNAME, 'strm_seg_in', 'nsegment', Nsegment, 'double', & + & 'Flow in stream segments as a result of cascading flow in each stream segment', & + & 'cfs', Strm_seg_in)/=0 ) CALL read_error(3,'strm_seg_in') + ENDIF + +! frozen ground variables and parameters + IF ( Frozen_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Frozen(Nhru) ) + IF ( declvar(MODNAME, 'frozen', 'nhru', Nhru, 'integer', & + & 'Flag for frozen ground (0=no; 1=soil at surface; 2=soil below surf; 3=below soil)', & + & 'dimensionless', Frozen)/=0 ) CALL read_error(3, 'frozen') + + ALLOCATE ( Cfgi(Nhru) ) + IF ( declvar(MODNAME, 'cfgi', 'nhru', Nhru, 'real', & + & 'Continuous Frozen Ground Index', & + & 'index', Cfgi)/=0 ) CALL read_error(3, 'cfgi') + + ALLOCATE ( Soil_water(Nhru) ) + IF ( declvar(MODNAME, 'soil_water', 'nhru', Nhru, 'real', & + & 'Based off soil_moist, measuring water in soil even if frozen', & + & 'inches', Soil_water)/=0 ) CALL read_error(3, 'soil_water') + + ALLOCATE ( Cfgi_prev(Nhru) ) + IF ( declvar(MODNAME, 'cfgi_prev', 'nhru', Nhru, 'real', & + & 'Continuous Frozen Ground Index from previous day', & + & 'index', Cfgi_prev)/=0 ) CALL read_error(3, 'cfgi_prev') + + IF ( declparam(MODNAME, 'cfgi_decay', 'one', 'real', & + & '0.97', '0.01', '1.0', & + & 'CFGI daily decay of index, value of 1.0 is no decay', & + & 'CFGI daily decay of index, value of 1.0 is no decay', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'cfgi_decay') + + IF ( declparam(MODNAME, 'cfgi_thrshld', 'one', 'real', & + & '5.0', '5.0', '83.0', & + & 'CFGImod threshold value indicating frozen soil', & + & 'CFGImod threshold value indicating frozen soil', & + & 'index')/=0 ) CALL read_error(1, 'cfgi_thrshld') + + ALLOCATE ( Frz_depth(Nhru) ) + IF ( declvar(MODNAME, 'frz_depth', 'nhru', Nhru, 'real', & + & 'Maximum depth soil is frozen, may be thawed above', & + & 'inches', Frz_depth)/=0 ) CALL read_error(1, 'frz_depth') + + ALLOCATE ( Thaw_depth(Nhru) ) + IF ( declvar(MODNAME, 'thaw_depth', 'nhru', Nhru, 'real', & + & 'Depth soil is thawed from surface', & + & 'inches', Thaw_depth)/=0 ) CALL read_error(1, 'thaw_depth') + + ALLOCATE ( Soil_depth(Nhru) ) + IF ( declparam(MODNAME, 'soil_depth', 'nhru', 'real', & + & '19.685', '0.0', '60.0', & + & 'Depth of soil that could freeze', & + & 'Depth of soil that could freeze', & + & 'inches')/=0 ) CALL read_error(1, 'soil_depth') + + ALLOCATE ( Soil_den(Nhru) ) + IF ( declparam(MODNAME, 'soil_den', 'nhru', 'real', & + & '1.3', '0.1', '2.0', & + & 'Density of soil that could freeze', & + & 'Density of soil that could freeze, limits based on Alaska UNASM map', & + & 'gm/cm3')/=0 ) CALL read_error(1, 'soil_den') + + ALLOCATE ( Porosity_hru(Nhru) ) + IF ( declparam(MODNAME, 'porosity_hru', 'nhru', 'real', & + & '0.4', '0.15', '0.75', & + & 'Porosity of soil for frozen ground calculations', & + & 'Porosity of soil for frozen ground calculations', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'porosity_hru') + + ALLOCATE( Soil_moist_prev(Nhru) ) + ENDIF + +! Declare parameters + IF ( Sroff_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Smidx_coef(Nhru) ) + IF ( declparam(MODNAME, 'smidx_coef', 'nhru', 'real', & + & '0.005', '0.0', '1.0', & + & 'Coefficient in contributing area computations', & + & 'Coefficient in non-linear contributing area algorithm for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'smidx_coef') + ALLOCATE ( Smidx_exp(Nhru) ) + IF ( declparam(MODNAME, 'smidx_exp', 'nhru', 'real', & + & '0.3', '0.0', '5.0', & + & 'Exponent in contributing area computations', & + & 'Exponent in non-linear contributing area algorithm for each HRU', & + & '1.0/inch')/=0 ) CALL read_error(1, 'smidx_exp') + ENDIF + + IF ( Sroff_flag==2 .OR. Model==99 ) THEN + ALLOCATE ( Carea_min(Nhru), Carea_dif(Nhru) ) + IF ( declparam(MODNAME, 'carea_min', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Minimum contributing area', & + & 'Minimum possible area contributing to surface runoff expressed as a portion of the area for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'carea_min') + ENDIF + + ALLOCATE ( Carea_max(Nhru) ) + IF ( declparam(MODNAME, 'carea_max', 'nhru', 'real', & + & '0.6', '0.0', '1.0', & + & 'Maximum contributing area', & + & 'Maximum possible area contributing to surface runoff expressed as a portion of the HRU area', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'carea_max') + +! Depression Storage parameters: + IF ( Dprst_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Dprst_depth_avg(Nhru) ) + IF ( declparam(MODNAME, 'dprst_depth_avg', 'nhru', 'real', & + & '132.0', '0.0', '500.0', & + & 'Average depth of surface depressions at maximum storage capacity', & + & 'Average depth of surface depressions at maximum storage capacity', & + & 'inches')/=0 ) CALL read_error(1, 'dprst_depth_avg') + + ALLOCATE ( Dprst_flow_coef(Nhru) ) + IF ( declparam(MODNAME, 'dprst_flow_coef', 'nhru', 'real', & + & '0.05', '0.00001', '0.5', & + & 'Coefficient in linear flow routing equation for open surface depressions', & + & 'Coefficient in linear flow routing equation for open surface depressions for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_flow_coef') + + ALLOCATE ( Dprst_seep_rate_open(Nhru) ) + IF ( declparam(MODNAME, 'dprst_seep_rate_open', 'nhru', 'real', & + & '0.02', '0.0', '0.2', & + & 'Coefficient used in linear seepage flow equation for open surface depressions', & + & 'Coefficient used in linear seepage flow equation for'// & + & ' open surface depressions for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_seep_rate_open') + + ALLOCATE ( Dprst_seep_rate_clos(Nhru) ) + IF ( declparam(MODNAME, 'dprst_seep_rate_clos', 'nhru', 'real', & + & '0.02', '0.0', '0.2', & + & 'Coefficient used in linear seepage flow equation for closed surface depressions', & + & 'Coefficient used in linear seepage flow equation for'// & + & ' closed surface depressions for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_seep_rate_clos') + + ALLOCATE ( Op_flow_thres(Nhru) ) + IF ( declparam(MODNAME, 'op_flow_thres', 'nhru', 'real', & + & '1.0', '0.01', '1.0', & + & 'Fraction of open depression storage above which surface runoff occurs for each timestep', & + & 'Fraction of open depression storage above'// & + & ' which surface runoff occurs; any water above'// & + & ' maximum open storage capacity spills as surface runoff', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'op_flow_thres') + + ALLOCATE ( Sro_to_dprst_perv(Nhru) ) + IF ( PRMS4_flag==1 ) THEN + IF ( declparam(MODNAME, 'sro_to_dprst', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of pervious surface runoff that flows into surface-depression storage', & + & 'Fraction of pervious surface runoff that'// & + & ' flows into surface-depression storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst') + ELSE + IF ( declparam(MODNAME, 'sro_to_dprst_perv', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of pervious surface runoff that flows into surface-depression storage', & + & 'Fraction of pervious surface runoff that'// & + & ' flows into surface-depression storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_perv') + ENDIF + + ALLOCATE ( Sro_to_dprst_imperv(Nhru) ) + IF ( declparam(MODNAME, 'sro_to_dprst_imperv', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of impervious surface runoff that flows into surface-depression storage', & + & 'Fraction of impervious surface runoff that'// & + & ' flows into surface-depression storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_imperv') + + ALLOCATE ( Dprst_et_coef(Nhru) ) + IF ( declparam(MODNAME, 'dprst_et_coef', 'nhru', 'real', & + & '1.0', '0.5', '1.5', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression storage', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'dprst_et_coef') + + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN + ALLOCATE ( Dprst_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'dprst_frac_init', 'nhru', 'real', & + & '0.5', '0.0', '1.0', & + & 'Fraction of maximum storage that contains water at the start of a simulation', & + & 'Fraction of maximum surface-depression storage that'// & + & ' contains water at the start of a simulation', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'dprst_frac_init') + ENDIF + + ALLOCATE ( Va_open_exp(Nhru) ) + IF ( declparam(MODNAME, 'va_open_exp', 'nhru', 'real', & + & '0.001', '0.0001', '10.0', & + & 'Coefficient in the exponential equation to compute'// & + & ' current surface area of open surface-depression storage', & + & 'Coefficient in the exponential equation relating'// & + & ' maximum surface area to the fraction that open'// & + & ' depressions are full to compute current surface area for each HRU;'// & + & ' 0.001 is an approximate cylinder; 1.0 is a cone', & + & 'none')/=0 ) CALL read_error(1, 'va_open_exp') + + ALLOCATE ( Va_clos_exp(Nhru) ) + IF ( declparam(MODNAME, 'va_clos_exp', 'nhru', 'real', & + & '0.001', '0.0001', '10.0', & + & 'Coefficient in the exponential equation to compute'// & + & ' current surface area of closed surface-depression storage', & + & 'Coefficient in the exponential equation relating'// & + & ' maximum surface area to the fraction that closed'// & + & ' depressions are full to compute current surface area for each HRU;'// & + & ' 0.001 is an approximate cylinder; 1.0 is a cone', & + & 'none')/=0 ) CALL read_error(1, 'va_clos_exp') + ENDIF + + IF ( Print_debug==1 ) THEN + ALLOCATE ( Imperv_stor_ante(Nhru) ) + IF ( Dprst_flag==1 ) ALLOCATE ( Dprst_stor_ante(Nhru) ) + ENDIF + + END FUNCTION srunoffdecl + +!*********************************************************************** +! srunoffinit - Initialize srunoff module - get parameter values +!*********************************************************************** + INTEGER FUNCTION srunoffinit() + USE PRMS_SRUNOFF + USE PRMS_MODULE, ONLY: Dprst_flag, Nhru, Nlake, Cascade_flag, Sroff_flag, & + & Init_vars_from_file, Call_cascade, Water_use_flag, & + & Frozen_flag!, Parameter_check_flag + USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order + USE PRMS_FLOWVARS, ONLY: Soil_moist !, Soil_moist_max + IMPLICIT NONE +! Functions + INTEGER, EXTERNAL :: getparam + EXTERNAL read_error +! Local Variables + INTEGER :: i, j !, k, num_hrus +! REAL :: frac +!*********************************************************************** + srunoffinit = 0 + + Use_sroff_transfer = 0 + IF ( Water_use_flag==1 ) Use_sroff_transfer = 1 + + Imperv_evap = 0.0 + Hortonian_flow = 0.0 + Hru_sroffi = 0.0 + Hru_sroffp = 0.0 + Contrib_fraction = 0.0 + Hru_impervevap = 0.0 + Hru_impervstor = 0.0 + IF ( Call_cascade==1 ) Strm_seg_in = 0.0D0 + IF ( Cascade_flag>0 ) THEN + Upslope_hortonian = 0.0D0 + Hru_hortn_cascflow = 0.0D0 + IF ( Nlake>0 ) Hortonian_lakes = 0.0D0 + ENDIF + + IF ( Init_vars_from_file==0 ) THEN + Basin_sroffi = 0.0D0 + Basin_sroffp = 0.0D0 + Basin_infil = 0.0D0 + Basin_sroff = 0.0D0 + Basin_imperv_evap = 0.0D0 + Basin_imperv_stor = 0.0D0 + Basin_hortonian = 0.0D0 + Basin_dprst_sroff = 0.0D0 + Basin_dprst_evap = 0.0D0 + Basin_dprst_seep = 0.0D0 + Basin_dprst_volop = 0.0D0 + Basin_dprst_volcl = 0.0D0 + Basin_sroff_upslope = 0.0D0 + Basin_sroff_down = 0.0D0 + Basin_hortonian_lakes = 0.0D0 + Basin_contrib_fraction = 0.0D0 + Srp = 0.0 + Sri = 0.0 + IF ( Frozen_flag==1 ) THEN + Frozen = 0 + Cfgi = 0.0 + Cfgi_prev = 0.0 + Frz_depth = 0.0 + Thaw_depth = 0.0 + Soil_moist_prev = Soil_moist + ENDIF + ENDIF + + IF ( getparam(MODNAME, 'carea_max', Nhru, 'real', Carea_max)/=0 ) CALL read_error(2, 'carea_max') + + IF ( Sroff_flag==1 ) THEN +! Smidx parameters + IF ( getparam(MODNAME, 'smidx_coef', Nhru, 'real', Smidx_coef)/=0 ) CALL read_error(2, 'smidx_coef') + IF ( getparam(MODNAME, 'smidx_exp', Nhru, 'real', Smidx_exp)/=0 ) CALL read_error(2, 'smidx_exp') + ELSE !IF ( Sroff_flag==2 ) THEN +! Carea parameters + IF ( getparam(MODNAME, 'carea_min', Nhru, 'real', Carea_min)/=0 ) CALL read_error(2, 'carea_min') + Carea_dif = 0.0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + Carea_dif(i) = Carea_max(i) - Carea_min(i) + ENDDO + ENDIF + +! num_hrus = 0 +! DO j = 1, Active_hrus +! i = Hru_route_order(j) +! IF ( Sroff_flag==2 ) THEN +! Carea_dif(i) = Carea_max(i) - Carea_min(i) +! ELSEIF ( Parameter_check_flag>0 ) THEN +! frac = Smidx_coef(i)*10**(Soil_moist_max(i)*Smidx_exp(i)) +! k = 0 +! IF ( frac>2.0 ) k = 1 +! IF ( frac>Carea_max(i)*2.0 ) k = k + 2 +! IF ( k>0 ) THEN +! num_hrus = num_hrus + 1 + !IF ( Print_debug>-1 ) THEN + ! PRINT *, ' ' + ! PRINT *, 'WARNING' + ! PRINT *, 'Contributing area based on smidx parameters and soil_moist_max:', frac + ! IF ( k==1 .OR. k==3 ) PRINT *, 'Maximum contributing area > 200%' + ! IF ( k>1 ) PRINT *, 'Maximum contributing area > carea_max:', Carea_max(i) + ! PRINT *, 'HRU:', i, '; soil_moist_max:', Soil_moist_max(i) + ! PRINT *, 'smidx_coef:', Smidx_coef(i), '; smidx_exp:', Smidx_exp(i) + ! PRINT *, 'This can make smidx parameters insensitive and carea_max very sensitive' + !ENDIF +! ENDIF +! ENDIF +! ENDDO +! IF ( num_hrus>0 .AND. Print_debug>-1 ) THEN +! WRITE (*, '(/,A,/,9X,A,/,9X,A,I7,/,9X,A,/,9X,A,/)') & +! & 'WARNING, maximum contributing area based on smidx coefficents and', & +! & 'soil_moist_max are > 200% of the HRU area and/or > 2*carea_max', & +! & 'number of HRUs for which this condition exists:', num_hrus, & +! & 'This means the smidx parameters are insensitive and', & +! & 'carea_max very sensitive for those HRUs' +! ENDIF + +! Frozen soil parameters + IF ( Frozen_flag==1 ) THEN + IF ( getparam(MODNAME, 'cfgi_thrshld', 1, 'real', Cfgi_thrshld)/=0 ) CALL read_error(2, 'cfgi_thrshld') + IF ( getparam(MODNAME, 'cfgi_decay', 1, 'real', Cfgi_decay)/=0 ) CALL read_error(2, 'cfgi_decay') + IF ( getparam(MODNAME, 'soil_depth', Nhru, 'real', Soil_depth)/=0 ) CALL read_error(2, 'soil_depth') + IF ( getparam(MODNAME, 'soil_den', Nhru, 'real', Soil_den)/=0 ) CALL read_error(2, 'soil_den') + IF ( getparam(MODNAME, 'porosity_hru', Nhru, 'real', Porosity_hru)/=0 ) CALL read_error(2, 'porosity_hru') + IF ( Init_vars_from_file==0 ) THEN + Soil_water = 0.3*Soil_depth !if starts at 0, divide by 0 later so start at general value + ENDIF + ENDIF + + +! Depression Storage parameters and variables: + IF ( Dprst_flag==1 ) CALL dprst_init() + + END FUNCTION srunoffinit + +!*********************************************************************** +! srunoffrun - Computes surface runoff using contributing area +! computations using antecedent soil moisture. +!*********************************************************************** + INTEGER FUNCTION srunoffrun() + USE PRMS_SRUNOFF + USE PRMS_MODULE, ONLY: Dprst_flag, Cascade_flag, Call_cascade, Print_debug, Frozen_flag, Glacier_flag + USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, & + & Hru_perv, Hru_imperv, Hru_percent_imperv, Hru_frac_perv, & + & Dprst_area_max, Hru_area, Hru_type, Basin_area_inv, & + & Dprst_area_clos_max, Dprst_area_open_max, Hru_area_dble, Cov_type, INCH2M + USE PRMS_CLIMATEVARS, ONLY: Potet, Tavgc + USE PRMS_FLOWVARS, ONLY: Sroff, Infil, Imperv_stor, Pkwater_equiv, Dprst_vol_open, Dprst_vol_clos, & + & Imperv_stor_max, Snowinfil_max, Glacier_frac, Soil_moist + USE PRMS_CASCADE, ONLY: Ncascade_hru + USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Hru_intcpevap, Net_apply, Intcp_changeover + USE PRMS_SNOW, ONLY: Snow_evap, Snowcov_area, Snowmelt, Pk_depth, Glacrb_melt, & + & Tcalin_snow, Tcalin_nosnow, Glacrcov_area, Prev_ann_tempc + USE PRMS_SET_TIME, ONLY: Jday + IMPLICIT NONE + INTRINSIC SNGL, DBLE + EXTERNAL imperv_et, compute_infil, run_cascade_sroff, dprst_comp, perv_comp +! Local Variables + INTEGER :: i, k, dprst_chk, frzen, active_glacier + REAL :: srunoff, avail_et, hperv, sra, availh2o + DOUBLE PRECISION :: hru_sroff_down, runoff, apply_sroff, cfgi_sroff + REAL :: cfgi_k, depth_cm, nosnow_area, depthg_cm, trad, emiss, emisl ! frozen ground + REAL :: cfgi_kg, soil_cond, latent_soil, nice, ice_cond, beta, thaw_frac ! frozen ground + REAL :: water_cond, sat_cond, mean_cond, lambda, omega, l5, l6, l8 ! frozen ground + REAL :: volumetric_soil, thermal_ratio_alp, fusion_param_mu, frz_height ! frozen ground + REAL :: glcrmltb, temp, temp2 ! glaciers + REAL, PARAMETER :: Freezepoint = 0.0 !deg C freezing point of soil moisture, could be below 0 in fine grained soil +!*********************************************************************** + srunoffrun = 0 + + IF ( Print_debug==1 ) THEN + Imperv_stor_ante = Hru_impervstor + IF ( Dprst_flag==1 ) Dprst_stor_ante = Dprst_stor_hru + ENDIF + Basin_sroffi = 0.0D0 + Basin_sroffp = 0.0D0 + Basin_sroff = 0.0D0 + Basin_infil = 0.0D0 + Basin_imperv_evap = 0.0D0 + Basin_imperv_stor = 0.0D0 + Basin_hortonian = 0.0D0 + Basin_contrib_fraction = 0.0D0 + Basin_cfgi_sroff = 0.0D0 + Basin_apply_sroff = 0.0D0 + + IF ( Call_cascade==1 ) Strm_seg_in = 0.0D0 + IF ( Cascade_flag>0 ) THEN + Basin_sroff_down = 0.0D0 + Basin_sroff_upslope = 0.0D0 + Basin_hortonian_lakes = 0.0D0 + Upslope_hortonian = 0.0D0 + ENDIF + + IF ( Dprst_flag==1 ) THEN + Basin_dprst_sroff = 0.0D0 + Basin_dprst_evap = 0.0D0 + Basin_dprst_seep = 0.0D0 + Basin_dprst_volop = 0.0D0 + Basin_dprst_volcl = 0.0D0 + ENDIF + + dprst_chk = 0 + DO k = 1, Active_hrus + i = Hru_route_order(k) + Hruarea = Hru_area(i) + Hruarea_dble = Hru_area_dble(i) + Ihru = i + runoff = 0.0D0 + glcrmltb = 0.0 ! glacier + Isglacier = 0 + active_glacier = -1 ! not an glacier + IF ( Glacier_flag>0 ) THEN + IF ( Hru_type(i)==4 ) THEN + IF ( Glacier_flag==1 ) THEN ! glacier + Isglacier = 1 + glcrmltb = Glacrb_melt(i) + IF ( Glacier_frac(i)>0.0 ) THEN + active_glacier = 1 + ELSE + active_glacier = 0 ! glacier capable HRU, but not glaciated + ENDIF + ENDIF + ENDIF + ENDIF + + IF ( Hru_type(i)==2 ) THEN +! HRU is a lake +! eventually add code for lake area less than hru_area +! that includes soil_moist for fraction of hru_area that is dry bank + ! Sanity check + IF ( Infil(i)+Sroff(i)+Imperv_stor(i)+Imperv_evap(i)>0.0 ) & + & PRINT *, 'srunoff lake ERROR', Infil(i), Sroff(i), Imperv_stor(i), Imperv_evap(i), i + IF ( Cascade_flag>0 ) THEN + Hortonian_lakes(i) = Upslope_hortonian(i) + Basin_hortonian_lakes = Basin_hortonian_lakes + Hortonian_lakes(i)*Hruarea_dble + ENDIF + CYCLE + ENDIF + + Infil(i) = 0.0 + hperv = Hru_perv(i) + Perv_frac = Hru_frac_perv(i) + Srp = 0.0 + Sri = 0.0 + Hru_sroffp(i) = 0.0 + Contrib_fraction(i) = 0.0 + Hruarea_imperv = Hru_imperv(i) + Imperv_frac = Hru_percent_imperv(i) + Hru_sroffi(i) = 0.0 + Imperv_evap(i) = 0.0 + Hru_impervevap(i) = 0.0 + + avail_et = Potet(i) - Snow_evap(i) - Hru_intcpevap(i) + + frzen = 0 + thaw_frac = 1.0 + + IF ( Frozen_flag==1 ) THEN + + IF ( Frozen(i)/=1 && Frozen_prev(i)/=1 ) Soil_water(i) = Soil_water(i)+ Soil_moist(i) - Soil_moist_prev(i) !is Soil_moist correct? Soil_moist_tot? + IF ( Frozen(i)/=1 && Frozen_prev(i)/=1 ) Soil_moist_prev(i) = Soil_moist(i) + ! modCFGI, following Follum et al 2018 + ! set emissivity, which is the fraction of perfect black-body + ! emission that is actually applied + ! Stefan Boltzmann/2 = (11.71E-8) = 2.0*0.585E-7 because add for day and night + ! energy available to snowpack proxy temperature is based on Tcalin + emiss = 0.97 ! [fraction of radiation] snow + emisl = 0.95 ! [fraction of radiation] land based on Jin and Liang 2006 + nosnow_area = 1.0-Snowcov_area(i) + IF (Glacier_flag==1) nosnow_area = nosnow_area-Glacrcov_area(i) !there will only be permafrost if glacierettes + !energy that is available to heat land under snow and without snow + trad = Snowcov_area(i)*( (Tcalin_snow(i) /(emiss*2.0*0.585E-7))**0.25 - 273.15 ) & + & + nosnow_area*( (Tcalin_nosnow(i)/(emisl*2.0*0.585E-7))**0.25 - 273.15 ) + cfgi_kg = 1.0 !From Follum et al 2018, could be a bit high + IF ( Tavgc(i)>0.0 ) THEN ![cal/cm^2] or [Langleys] + cfgi_k = 0.5 + ELSE + cfgi_k = 0.08 + ENDIF + ! depth over only snow covered area, so real depth of pack because considering land heat too now + depth_cm = 0.0 + IF ( Snowcov_area(i)>0.0 ) depth_cm = SNGL(Pk_depth(i)/Snowcov_area(i))*2.54 + ! depth ground cover only, from Follum et al, 2018, but was in Vermont + depthg_cm = 0.0 !Cov_type =0 bare soil (rock, may be mostly impervious already) + IF (Cov_type(i)==1) depthg_cm = 4.0 !grasses (boreal grass, tundra) + IF (Cov_type(i)==2) depthg_cm = 3.0 !shrub (tundra) + IF (Cov_type(i)>=3) depthg_cm = 6.0 !trees + IF (Cov_type(i)==4) depthg_cm = 2.0 !coniferous + +! Continuous frozen ground index + Cfgi(i) = Cfgi_decay*Cfgi_prev(i) - trad*( 2.71828**(-0.4*(cfgi_k*depth_cm+cfgi_kg*depthg_cm)) ) + IF ( active_glacier==1 ) THEN + Cfgi(i) = 0.0 !if glacier over, want ground completely unfrozen, or below threshold, infiltration + IF ( Glacier_frac(i)<1.0 ) Cfgi(i) = Cfgi_thrshld ! glacier with some open fraction + ENDIF + IF ( Cfgi(i)<0.0 ) Cfgi(i) = 0.0 +! If above the threshold to be frozen + IF ( Cfgi(i)>=Cfgi_thrshld ) THEN + ! Use modified Berggren formula to get a depth of frozen + ! soil water content % of dry weight is water vol*density / (soil vol*density) + omega = Soil_water(i) / (Soil_depth(i)*Soil_den(i)) + IF ( omega>1.0 ) omega = 1.0 + IF ( omega<0.1 ) omega = 0.1 + ! volumetric heat of fusion of the soil + volumetric_soil = Soil_den(i)*(4.187*0.17 + 0.75*omega)*1.e6 ! J/m^3/K, specific heat of rock, water, ice =0.17, 1, 0.5 *4.187 J/g/K , density in g/cm3 + ! latent heat of fusion of the soil + latent_soil = 334.0*Soil_den(i)*omega*1.e6 ! J/m^3, latent heat of fusion of water = 334 J/g , density in g/cm3 + thermal_ratio_alp = (Prev_ann_tempc(i) - Freezepoint)/(Cfgi(i) - Cfgi_thrshld) !degree K/ index Ti/Ts + IF ( thermal_ratio_alp<0.0 ) thermal_ratio_alp = 0.0 + fusion_param_mu =(Cfgi(i) - Cfgi_thrshld)*volumetric_soil/latent_soil !index/degree K St12 + ! lambda corrects the Stefan formula for the effects of volumetric heat which it neglected + beta = 1.0 !ranges between 0.95 and 1.3 depending on soil type and soil moisture + lambda = 1.0 !Graph in Aldrich 1956, says in Alaska this is usually 1 but if less northern, can be as low as 0.3 + l5 = 1.0 -0.16*fusion_param_mu +0.038*(fusion_param_mu**2.0) !Kurylyk and Hayashi 2016, Ti = 0 + l6 = ( 1.0 + 0.147*fusion_param_mu*((beta*thermal_ratio_alp)**2.0)+ 0.535*(fusion_param_mu**0.5)*beta*thermal_ratio_alp )*l5 ! Kurylyk and Hayashi 2016, Ti < 0 + l8 = ( 1.0 + 0.061*(fusion_param_mu**0.88)*((thermal_ratio_alp/beta)**1.65)- 0.43*(fusion_param_mu**0.44)*((thermal_ratio_alp/beta)**0.825) )*l5 ! Kurylyk and Hayashi 2016, Ti > 0 + IF ( Cfgi(i)>Cfgi_prev(i) ) lambda = l8 !freezing + IF ( Cfgi(i)Frz_depth(i) ) Frz_depth(i) = frz_height + IF ( frz_height==0.0 ) Frz_depth(i) = 0.0 ! everything thawed + Thaw_depth(i) = Frz_depth(i) - frz_height ! active layer is between Frz_depth and Thaw_depth + + ! Can frz_depth be greater than soil_depth? + IF (frz_height>0.0) THEN + IF ( Thaw_depth(i)==0.0) THEN + frzen = 1 !soil frozen at top + thaw_frac = 0.0 + ELSEIF ( Thaw_depth(i)=Soil_depth(i) ) THEN ! Thaw_depth(i)>=Soil_depth(i)) + frzen = 3 !soil not frozen but below is, thaw_frac = 1.0 + ENDIF + ENDIF + ENDIF + + IF (frzen>0) THEN + ! depression storage states are not changed for frozen parts of soil + IF ( Cascade_flag>0 ) THEN + cfgi_sroff = (1.0-thaw_frac)*(Snowmelt(i) + Net_rain(i) + Upslope_hortonian(i) + glcrmltb)*Hruarea + ELSE + cfgi_sroff = (1.0-thaw_frac)*(Snowmelt(i) + Net_rain(i) + glcrmltb)*Hruarea + ENDIF + IF ( Use_sroff_transfer==1 ) cfgi_sroff = cfgi_sroff + Net_apply(i)*Hruarea + runoff = runoff + cfgi_sroff + Basin_cfgi_sroff = Basin_cfgi_sroff + cfgi_sroff + ELSE !not frozen + Frz_depth(i) = 0.0 + Thaw_depth(i) = 0.0 + ENDIF + Frozen(i) = frzen + Cfgi_prev(i) = Cfgi(i) + ENDIF + +!******Compute runoff for pervious, impervious, and depression storage area, only if not totally frozen ground + IF ( frzen/=1 ) THEN +! DO IRRIGATION APPLICATION, ONLY DONE HERE, ASSUMES NO SNOW and +! only for pervious areas (just like infiltration) + IF ( Use_sroff_transfer==1 ) THEN + IF ( Net_apply(i)>0.0 ) THEN + sra = 0.0 + Infil(i) = Infil(i) + Net_apply(i) + IF ( Hru_type(i)==1 ) THEN + CALL perv_comp(Net_apply(i), Net_apply(i), Infil(i), sra, thaw_frac) +! ** ADD in water from irrigation application and water-use transfer for pervious portion - sra (if any) + apply_sroff = DBLE( sra*hperv ) + Basin_apply_sroff = Basin_apply_sroff + apply_sroff + runoff = runoff + apply_sroff + ENDIF + ENDIF + ENDIF + + availh2o = Intcp_changeover(i) + Net_rain(i) + IF ( Isglacier==1 ) THEN ! glacier + temp = Snowmelt(i) + glcrmltb !Snowmelt or 0.0 + temp2 = availh2o*(1.0-Glacier_frac(i)) + CALL compute_infil(temp2, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), temp, & + & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i), thaw_frac) + ELSE + CALL compute_infil(availh2o, Net_ppt(i), Imperv_stor(i), Imperv_stor_max(i), Snowmelt(i), & + & Snowinfil_max(i), Net_snow(i), Pkwater_equiv(i), Infil(i), Hru_type(i), thaw_frac) + ENDIF + + ENDIF + + IF ( Dprst_flag==1 ) THEN + Dprst_in(i) = 0.0D0 + dprst_chk = 0 + IF ( Dprst_area_max(i)>0.0 ) THEN + dprst_chk = 1 +! ******Compute the depression storage component +! only call if total depression surface area for each HRU is > 0.0 + IF ( frzen/=1 ) THEN + CALL dprst_comp(Dprst_vol_clos(i), Dprst_area_clos_max(i), Dprst_area_clos(i), & + & Dprst_vol_open_max(i), Dprst_vol_open(i), Dprst_area_open_max(i), Dprst_area_open(i), & + & Dprst_sroff_hru(i), Dprst_seep_hru(i), Sro_to_dprst_perv(i), Sro_to_dprst_imperv(i), & + & Dprst_evap_hru(i), avail_et, availh2o, Dprst_in(i), thaw_frac) + runoff = runoff + Dprst_sroff_hru(i)*Hruarea_dble + ENDIF + ENDIF + ENDIF +! ********************************************************** + + srunoff = 0.0 + IF ( Hru_type(i)==1 .OR. active_glacier==0 ) THEN ! could be an glacier-capable HRU with no ice +!******Compute runoff for pervious and impervious area, and depression storage area + runoff = runoff + DBLE( Srp*hperv + Sri*Hruarea_imperv ) + srunoff = SNGL( runoff/Hruarea_dble ) + +!******Compute HRU weighted average (to units of inches/dt) + IF ( Cascade_flag>0 ) THEN + hru_sroff_down = 0.0D0 + IF ( srunoff>0.0 ) THEN + IF ( Ncascade_hru(i)>0 ) CALL run_cascade_sroff(Ncascade_hru(i), srunoff, hru_sroff_down) + Hru_hortn_cascflow(i) = hru_sroff_down + !IF ( Hru_hortn_cascflow(i)<0.0D0 ) Hru_hortn_cascflow(i) = 0.0D0 + !IF ( Upslope_hortonian(i)<0.0D0 ) Upslope_hortonian(i) = 0.0D0 + Basin_sroff_upslope = Basin_sroff_upslope + Upslope_hortonian(i)*Hruarea_dble + Basin_sroff_down = Basin_sroff_down + hru_sroff_down*Hruarea_dble + ELSE + Hru_hortn_cascflow(i) = 0.0D0 + ENDIF + ENDIF + Hru_sroffp(i) = Srp*Perv_frac + Basin_sroffp = Basin_sroffp + Srp*hperv + ENDIF + + Basin_infil = Basin_infil + DBLE( Infil(i)*hperv ) + Basin_contrib_fraction = Basin_contrib_fraction + DBLE( Contrib_fraction(i)*hperv ) + +!******Compute evaporation from impervious area + IF ( frzen==0 ) THEN + IF ( Hruarea_imperv>0.0 ) THEN + IF ( Imperv_stor(i)>0.0 ) THEN + CALL imperv_et(Imperv_stor(i), Potet(i), Imperv_evap(i), Snowcov_area(i), avail_et) + Hru_impervevap(i) = Imperv_evap(i)*Imperv_frac + !IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 + avail_et = avail_et - Hru_impervevap(i) + IF ( avail_et<0.0 ) THEN + ! sanity check +! IF ( avail_et<-NEARZERO ) PRINT*, 'avail_et<0 in srunoff imperv', i, Nowmonth, Nowday, avail_et + Hru_impervevap(i) = Hru_impervevap(i) + avail_et + IF ( Hru_impervevap(i)<0.0 ) Hru_impervevap(i) = 0.0 + Imperv_evap(i) = Hru_impervevap(i)/Imperv_frac + Imperv_stor(i) = Imperv_stor(i) - avail_et/Imperv_frac + avail_et = 0.0 + ENDIF + Basin_imperv_evap = Basin_imperv_evap + DBLE( Hru_impervevap(i)*Hruarea ) + Hru_impervstor(i) = Imperv_stor(i)*Imperv_frac + Basin_imperv_stor = Basin_imperv_stor + DBLE(Imperv_stor(i)*Hruarea_imperv ) + ENDIF + Hru_sroffi(i) = Sri*Imperv_frac + Basin_sroffi = Basin_sroffi + DBLE( Sri*Hruarea_imperv ) + ENDIF + ENDIF + + IF ( dprst_chk==1 ) Dprst_stor_hru(i) = (Dprst_vol_open(i)+Dprst_vol_clos(i))/Hruarea_dble + + Sroff(i) = srunoff + Hortonian_flow(i) = srunoff + Basin_hortonian = Basin_hortonian + DBLE( srunoff*Hruarea ) + Basin_sroff = Basin_sroff + DBLE( srunoff*Hruarea ) + ENDDO + +!******Compute basin weighted averages (to units of inches/dt) + !rsr, should be land_area??? + Basin_sroff = Basin_sroff*Basin_area_inv + Basin_imperv_evap = Basin_imperv_evap*Basin_area_inv + Basin_imperv_stor = Basin_imperv_stor*Basin_area_inv + Basin_infil = Basin_infil*Basin_area_inv + ! doesn't include CFGI runoff + Basin_sroffp = Basin_sroffp*Basin_area_inv + Basin_sroffi = Basin_sroffi*Basin_area_inv + Basin_hortonian = Basin_hortonian*Basin_area_inv + Basin_contrib_fraction = Basin_contrib_fraction*Basin_area_inv + IF ( Cascade_flag>0 ) THEN + Basin_hortonian_lakes = Basin_hortonian_lakes*Basin_area_inv + Basin_sroff_down = Basin_sroff_down*Basin_area_inv + Basin_sroff_upslope = Basin_sroff_upslope*Basin_area_inv + ENDIF + + IF ( Dprst_flag==1 ) THEN + Basin_dprst_volop = Basin_dprst_volop*Basin_area_inv + Basin_dprst_volcl = Basin_dprst_volcl*Basin_area_inv + Basin_dprst_evap = Basin_dprst_evap*Basin_area_inv + Basin_dprst_seep = Basin_dprst_seep*Basin_area_inv + Basin_dprst_sroff = Basin_dprst_sroff*Basin_area_inv + ENDIF + + END FUNCTION srunoffrun + +!*********************************************************************** +! Subroutine to compute evaporation from impervious area at +! potential ET rate up to available ET +!*********************************************************************** + SUBROUTINE imperv_et(Imperv_stor, Potet, Imperv_evap, Sca, Avail_et) + USE PRMS_SRUNOFF, ONLY: Imperv_frac + IMPLICIT NONE +! Arguments + REAL, INTENT(IN) :: Potet, Sca, Avail_et + REAL, INTENT(INOUT) :: Imperv_stor, Imperv_evap +!*********************************************************************** + IF ( Sca<1.0 ) THEN + IF ( PotetAvail_et ) Imperv_evap = Avail_et/Imperv_frac + Imperv_stor = Imperv_stor - Imperv_evap + ENDIF + !rsr, sanity check +! IF ( Imperv_stor<0.0 ) THEN +! PRINT *, 'imperv_stor<0', Imperv_stor +! Imperv_stor = 0.0 +! ENDIF + + END SUBROUTINE imperv_et + +!*********************************************************************** +! Compute infiltration +!*********************************************************************** + SUBROUTINE compute_infil(Net_rain, Net_ppt, Imperv_stor, Imperv_stor_max, Snowmelt, & + & Snowinfil_max, Net_snow, Pkwater_equiv, Infil, Hru_type, Thaw_frac) + USE PRMS_SRUNOFF, ONLY: Sri, Hruarea_imperv, Upslope_hortonian, Ihru, Srp, Isglacier + USE PRMS_SNOW, ONLY: Pptmix_nopack + USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO + USE PRMS_MODULE, ONLY: Cascade_flag + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: Hru_type + REAL, INTENT(IN) :: Net_rain, Net_ppt, Imperv_stor_max, Thaw_frac + REAL, INTENT(IN) :: Snowmelt, Snowinfil_max, Net_snow + DOUBLE PRECISION, INTENT(IN) :: Pkwater_equiv + REAL, INTENT(INOUT) :: Imperv_stor, Infil +! Functions + INTRINSIC SNGL + EXTERNAL perv_comp, check_capacity +! Local Variables + REAL :: avail_water + INTEGER :: hru_flag +!*********************************************************************** + hru_flag = 0 + IF ( Hru_type==1 .OR. Isglacier==1 ) hru_flag = 1 ! land or glacier +! compute runoff from cascading Hortonian flow + IF ( Cascade_flag>0 ) THEN + avail_water = SNGL( Upslope_hortonian(Ihru) ) + IF ( avail_water>0.0 ) THEN + Infil = avail_water + IF ( hru_flag==1 ) CALL perv_comp(avail_water, avail_water, Infil, Srp, Thaw_frac) + ENDIF + ELSE + avail_water = 0.0 + ENDIF + +!******if rain/snow event with no antecedent snowpack, +!******compute the runoff from the rain first and then proceed with the +!******snowmelt computations + + IF ( Pptmix_nopack(Ihru)==1 ) THEN + avail_water = avail_water + Net_rain + Infil = Infil + Net_rain + IF ( hru_flag==1 ) CALL perv_comp(Net_rain, Net_rain, Infil, Srp, Thaw_frac) + ENDIF + +!******If precipitation on snowpack, all water available to the surface is +!******considered to be snowmelt, and the snowmelt infiltration +!******procedure is used. If there is no snowpack and no precip, +!******then check for melt from last of snowpack. If rain/snow mix +!******with no antecedent snowpack, compute snowmelt portion of runoff. + + IF ( Snowmelt>0.0 ) THEN + avail_water = avail_water + Snowmelt + Infil = Infil + Snowmelt + IF ( hru_flag==1 ) THEN + IF ( Pkwater_equiv>0.0D0 .OR. Net_ppt-Net_snow0.0 ) THEN +! no snow, some rain + avail_water = avail_water + Net_rain + Infil = Infil + Net_rain + IF ( hru_flag==1 ) CALL perv_comp(Net_rain, Net_rain, Infil, Srp, Thaw_frac) + ENDIF + +!***** Snowpack exists, check to see if infil exceeds maximum daily +!***** snowmelt infiltration rate. Infil results from rain snow mix +!***** on a snowfree surface. + + ELSEIF ( Infil>0.0 ) THEN + IF ( hru_flag==1 ) CALL check_capacity(Snowinfil_max, Infil) + ENDIF + +!******Impervious area computations + IF ( Hruarea_imperv>0.0 ) THEN + Imperv_stor = Imperv_stor + avail_water + IF ( hru_flag==1 ) THEN + IF ( Imperv_stor>Imperv_stor_max ) THEN + Sri = Imperv_stor - Imperv_stor_max + Imperv_stor = Imperv_stor_max + ENDIF + ENDIF + ENDIF + + END SUBROUTINE compute_infil + +!*********************************************************************** + SUBROUTINE perv_comp(Pptp, Ptc, Infil, Srp, Thaw_frac) + USE PRMS_SRUNOFF, ONLY: Ihru, Smidx_coef, Smidx_exp, & + & Carea_max, Carea_min, Carea_dif, Contrib_fraction + USE PRMS_MODULE, ONLY: Sroff_flag +! USE PRMS_BASIN, ONLY: CLOSEZERO + USE PRMS_FLOWVARS, ONLY: Soil_moist, Soil_rechr, Soil_rechr_max + IMPLICIT NONE +! Arguments + REAL, INTENT(IN) :: Pptp, Ptc, Thaw_frac + REAL, INTENT(INOUT) :: Infil, Srp +! Local Variables + REAL :: smidx, srpp, ca_fraction +!*********************************************************************** +!******Pervious area computations + IF ( Sroff_flag==1 ) THEN + ! antecedent soil_moist + smidx = Soil_moist(Ihru) + (0.5*Ptc) + ca_fraction = Smidx_coef(Ihru)*10.0**(Smidx_exp(Ihru)*smidx) + ELSE + ! antecedent soil_rechr + ca_fraction = Carea_min(Ihru) + Carea_dif(Ihru)*(Soil_rechr(Ihru)/(Thaw_frac*Soil_rechr_max(Ihru))) + ENDIF + IF ( ca_fraction>Carea_max(Ihru) ) ca_fraction = Carea_max(Ihru) + srpp = ca_fraction*Pptp + Contrib_fraction(Ihru) = ca_fraction +! IF ( srpp<0.0 ) THEN +! PRINT *, 'negative srp', srpp +! srpp = 0.0 +! ENDIF + Infil = Infil - srpp + Srp = Srp + srpp + !IF ( Srp 0, cascade contributes to a downslope HRU + IF ( j>0 ) THEN + Upslope_hortonian(j) = Upslope_hortonian(j) + DBLE( Runoff*Hru_down_fracwt(k, Ihru) ) + Hru_sroff_down = Hru_sroff_down + DBLE( Runoff*Hru_down_frac(k,Ihru) ) + +! if hru_down(k, Ihru) < 0, cascade contributes to a stream + ELSEIF ( j<0 ) THEN + j = IABS( j ) + Strm_seg_in(j) = Strm_seg_in(j) + DBLE( Runoff*Cascade_area(k, Ihru) )*Cfs_conv + ENDIF + ENDDO + +! reset Sroff as it accumulates flow to streams + Runoff = Runoff - SNGL( Hru_sroff_down ) +! IF ( Runoff<0.0 ) THEN +! IF ( Runoff<-NEARZERO ) THEN +! IF ( Print_debug>-1 ) PRINT *, 'runoff < NEARZERO', Runoff +! IF ( Hru_sroff_down>ABS(Runoff) ) THEN +! Hru_sroff_down = Hru_sroff_down - Runoff +! ELSE +! DO k = 1, Ncascade_hru +! j = Hru_down(k, Ihru) +! IF ( Strm_seg_in(j)>ABS(Runoff) ) THEN +! Strm_seg_in(j) = Strm_seg_in(j) - Runoff +! EXIT +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! Runoff = 0.0 +! ENDIF + + END SUBROUTINE run_cascade_sroff + +!*********************************************************************** +! fill soil to soil_moist_max, if more than capacity restrict +! infiltration by snowinfil_max, with excess added to runoff +!*********************************************************************** + SUBROUTINE check_capacity(Snowinfil_max, Infil) + USE PRMS_FLOWVARS, ONLY: Soil_moist_max, Soil_moist + USE PRMS_SRUNOFF, ONLY: Ihru, Srp + IMPLICIT NONE +! Arguments + REAL, INTENT(IN) :: Snowinfil_max + REAL, INTENT(INOUT) :: Infil +! Local Variables + REAL :: capacity, excess +!*********************************************************************** + capacity = Soil_moist_max(Ihru) - Soil_moist(Ihru) + excess = Infil - capacity + IF ( excess>Snowinfil_max ) THEN + Srp = Srp + excess - Snowinfil_max + Infil = Snowinfil_max + capacity + ENDIF + + END SUBROUTINE check_capacity + +!*********************************************************************** +! Initialize depression storage area hydrology +!*********************************************************************** + SUBROUTINE dprst_init() + USE PRMS_SRUNOFF + USE PRMS_MODULE, ONLY: Init_vars_from_file, Nhru, PRMS4_flag, Inputerror_flag + USE PRMS_BASIN, ONLY: Dprst_clos_flag, NEARZERO, Dprst_frac, & + & Dprst_area_clos_max, Dprst_area_open_max, Basin_area_inv, & + & Hru_area_dble, Active_hrus, Hru_route_order, Dprst_open_flag + USE PRMS_FLOWVARS, ONLY: Dprst_vol_open, Dprst_vol_clos + IMPLICIT NONE +! Functions + INTRINSIC EXP, LOG, DBLE, SNGL + INTEGER, EXTERNAL :: getparam +! Local Variables + INTEGER :: i, j + REAL :: frac_op_ar, frac_cl_ar, open_vol_r, clos_vol_r +!*********************************************************************** + Dprst_evap_hru = 0.0 + Dprst_seep_hru = 0.0D0 + Dprst_sroff_hru = 0.0D0 + Dprst_insroff_hru = 0.0 + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN + IF ( getparam(MODNAME, 'dprst_frac_init', Nhru, 'real', Dprst_frac_init)/=0 ) CALL read_error(2, 'dprst_frac_init') + ENDIF + IF ( getparam(MODNAME, 'dprst_flow_coef', Nhru, 'real', Dprst_flow_coef)/=0 ) CALL read_error(2, 'dprst_flow_coef') + IF ( Dprst_open_flag==1 ) THEN + IF ( getparam(MODNAME, 'dprst_seep_rate_open', Nhru, 'real', Dprst_seep_rate_open)/=0 ) & + & CALL read_error(2, 'dprst_seep_rate_open') + IF ( getparam(MODNAME, 'va_open_exp', Nhru, 'real', Va_open_exp)/=0 ) CALL read_error(2, 'va_open_exp') + IF ( getparam(MODNAME, 'op_flow_thres', Nhru, 'real', Op_flow_thres)/=0 ) CALL read_error(2, 'op_flow_thres') + ELSE + Dprst_seep_rate_open = 0.0 + Va_open_exp = 0.0 + Op_flow_thres = 0.0 + ENDIF + IF ( PRMS4_flag==1 ) THEN + IF ( getparam(MODNAME, 'sro_to_dprst', Nhru, 'real', Sro_to_dprst_perv)/=0 ) CALL read_error(2, 'sro_to_dprst') + ELSE + IF ( getparam(MODNAME, 'sro_to_dprst_perv', Nhru, 'real', Sro_to_dprst_perv)/=0 ) CALL read_error(2, 'sro_to_dprst_perv') + ENDIF + IF ( getparam(MODNAME, 'sro_to_dprst_imperv', Nhru, 'real', Sro_to_dprst_imperv)/=0 ) & + & CALL read_error(2, 'sro_to_dprst_imperv') + IF ( getparam(MODNAME, 'dprst_depth_avg', Nhru, 'real', Dprst_depth_avg)/=0 ) CALL read_error(2, 'dprst_depth_avg') + IF ( getparam(MODNAME, 'dprst_et_coef', Nhru, 'real', Dprst_et_coef)/=0 ) CALL read_error(2, 'dprst_et_coef') + IF ( Dprst_clos_flag==1 ) THEN + IF ( getparam(MODNAME, 'dprst_seep_rate_clos', Nhru, 'real', Dprst_seep_rate_clos)/=0 ) & + & CALL read_error(2, 'dprst_seep_rate_clos') + IF ( getparam(MODNAME, 'va_clos_exp', Nhru, 'real', Va_clos_exp)/=0 ) CALL read_error(2, 'va_clos_exp') + ELSE + Dprst_seep_rate_clos = 0.0 + Va_clos_exp = 0.0 + ENDIF + Dprst_in = 0.0D0 + Dprst_area_open = 0.0 + Dprst_area_clos = 0.0 + Dprst_stor_hru = 0.0D0 + Dprst_vol_thres_open = 0.0D0 + Dprst_vol_open_max = 0.0D0 + Dprst_vol_clos_max = 0.0D0 + Dprst_vol_frac = 0.0 + Dprst_vol_open_frac = 0.0 + Dprst_vol_clos_frac = 0.0 + Basin_dprst_volop = 0.0D0 + Basin_dprst_volcl = 0.0D0 + DO j = 1, Active_hrus + i = Hru_route_order(j) + + IF ( Dprst_frac(i)>0.0 ) THEN + IF ( Dprst_depth_avg(i)==0.0 ) THEN + PRINT *, 'ERROR, dprst_frac>0 and dprst_depth_avg==0 for HRU:', i, '; dprst_frac:', Dprst_frac(i) + Inputerror_flag = 1 + CYCLE + ENDIF +! calculate open and closed volumes (acre-inches) of depression storage by HRU +! Dprst_area_open_max is the maximum open depression area (acres) that can generate surface runoff: + IF ( Dprst_clos_flag==1 ) Dprst_vol_clos_max(i) = DBLE( Dprst_area_clos_max(i)*Dprst_depth_avg(i) ) + IF ( Dprst_open_flag==1 ) Dprst_vol_open_max(i) = DBLE( Dprst_area_open_max(i)*Dprst_depth_avg(i) ) + +! calculate the initial open and closed depression storage volume: + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN + IF ( Dprst_open_flag==1 ) Dprst_vol_open(i) = DBLE(Dprst_frac_init(i))*Dprst_vol_open_max(i) + IF ( Dprst_clos_flag==1 ) Dprst_vol_clos(i) = DBLE(Dprst_frac_init(i))*Dprst_vol_clos_max(i) + ENDIF + +! threshold volume is calculated as the % of maximum open +! depression storage above which flow occurs * total open depression storage volume + Dprst_vol_thres_open(i) = DBLE(Op_flow_thres(i))*Dprst_vol_open_max(i) + +! initial open and closed storage volume as fraction of total open and closed storage volume + +! Open depression surface area for each HRU: + IF ( Dprst_vol_open(i)>0.0D0 ) THEN + open_vol_r = SNGL( Dprst_vol_open(i)/Dprst_vol_open_max(i) ) + IF ( open_vol_r1.0 ) THEN + frac_op_ar = 1.0 + ELSE + frac_op_ar = EXP(Va_open_exp(i)*LOG(open_vol_r)) + ENDIF + Dprst_area_open(i) = Dprst_area_open_max(i)*frac_op_ar + IF ( Dprst_area_open(i)>Dprst_area_open_max(i) ) Dprst_area_open(i) = Dprst_area_open_max(i) +! IF ( Dprst_area_open(i)0.0D0 ) THEN + clos_vol_r = SNGL( Dprst_vol_clos(i)/Dprst_vol_clos_max(i) ) + IF ( clos_vol_r1.0 ) THEN + frac_cl_ar = 1.0 + ELSE + frac_cl_ar = EXP(Va_clos_exp(i)*LOG(clos_vol_r)) + ENDIF + Dprst_area_clos(i) = Dprst_area_clos_max(i)*frac_cl_ar + IF ( Dprst_area_clos(i)>Dprst_area_clos_max(i) ) Dprst_area_clos(i) = Dprst_area_clos_max(i) +! IF ( Dprst_area_clos(i)0.0 ) Dprst_vol_open_frac(i) = SNGL( Dprst_vol_open(i)/Dprst_vol_open_max(i) ) + IF ( Dprst_vol_clos_max(i)>0.0 ) Dprst_vol_clos_frac(i) = SNGL( Dprst_vol_clos(i)/Dprst_vol_clos_max(i) ) + Dprst_vol_frac(i) = SNGL( (Dprst_vol_open(i)+Dprst_vol_clos(i))/(Dprst_vol_open_max(i)+Dprst_vol_clos_max(i)) ) + ENDIF + ENDDO + Basin_dprst_volop = Basin_dprst_volop*Basin_area_inv + Basin_dprst_volcl = Basin_dprst_volcl*Basin_area_inv + IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) DEALLOCATE ( Dprst_frac_init ) + + END SUBROUTINE dprst_init + +!*********************************************************************** +! Compute depression storage area hydrology +!*********************************************************************** + SUBROUTINE dprst_comp(Dprst_vol_clos, Dprst_area_clos_max, Dprst_area_clos, & + & Dprst_vol_open_max, Dprst_vol_open, Dprst_area_open_max, Dprst_area_open, & + & Dprst_sroff_hru, Dprst_seep_hru, Sro_to_dprst_perv, Sro_to_dprst_imperv, Dprst_evap_hru, & + & Avail_et, Net_rain, Dprst_in, Thaw_frac) + USE PRMS_SRUNOFF, ONLY: Srp, Sri, Ihru, Perv_frac, Imperv_frac, Hruarea, Dprst_et_coef, & + & Dprst_seep_rate_open, Dprst_seep_rate_clos, Va_clos_exp, Va_open_exp, Dprst_flow_coef, & + & Dprst_vol_thres_open, Dprst_vol_clos_max, Dprst_insroff_hru, Upslope_hortonian, & + & Basin_dprst_volop, Basin_dprst_volcl, Basin_dprst_evap, Basin_dprst_seep, Basin_dprst_sroff, & + & Dprst_vol_open_frac, Dprst_vol_clos_frac, Dprst_vol_frac, Dprst_stor_hru, Hruarea_dble + USE PRMS_MODULE, ONLY: Cascade_flag !, Print_debug + USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Dprst_frac_open, Dprst_frac_clos + USE PRMS_INTCP, ONLY: Net_snow + USE PRMS_CLIMATEVARS, ONLY: Potet + USE PRMS_FLOWVARS, ONLY: Pkwater_equiv + USE PRMS_SNOW, ONLY: Snowmelt, Pptmix_nopack, Snowcov_area + IMPLICIT NONE + INTRINSIC EXP, LOG, MAX, DBLE, SNGL +! Arguments + REAL, INTENT(IN) :: Dprst_area_open_max, Dprst_area_clos_max, Net_rain, Thaw_frac + REAL, INTENT(IN) :: Sro_to_dprst_perv, Sro_to_dprst_imperv + DOUBLE PRECISION, INTENT(IN) :: Dprst_vol_open_max + DOUBLE PRECISION, INTENT(INOUT) :: Dprst_vol_open, Dprst_vol_clos, Dprst_in + REAL, INTENT(INOUT) :: Avail_et + REAL, INTENT(OUT) :: Dprst_area_open, Dprst_area_clos, Dprst_evap_hru + DOUBLE PRECISION, INTENT(OUT) :: Dprst_sroff_hru, Dprst_seep_hru +! Local Variables + REAL :: inflow, dprst_avail_et + REAL :: dprst_srp, dprst_sri + REAL :: dprst_srp_open, dprst_srp_clos, dprst_sri_open, dprst_sri_clos + REAL :: frac_op_ar, frac_cl_ar, open_vol_r, clos_vol_r, unsatisfied_et + REAL :: tmp, dprst_evap_open, dprst_evap_clos + DOUBLE PRECISION :: seep_open, seep_clos, tmp1 +!*********************************************************************** +! add the hortonian flow to the depression storage volumes: + IF ( Cascade_flag>0 ) THEN + inflow = SNGL( Upslope_hortonian(Ihru) ) + ELSE + inflow = 0.0 + ENDIF + + IF ( Pptmix_nopack(Ihru)==1 ) inflow = inflow + Net_rain + +!******If precipitation on snowpack all water available to the surface is considered to be snowmelt +!******If there is no snowpack and no precip,then check for melt from last of snowpack. +!******If rain/snow mix with no antecedent snowpack, compute snowmelt portion of runoff. + + IF ( Snowmelt(Ihru)>0.0 ) THEN + inflow = inflow + Snowmelt(Ihru) + +!******There was no snowmelt but a snowpack may exist. If there is +!******no snowpack then check for rain on a snowfree HRU. + ELSEIF ( Pkwater_equiv(Ihru)0.0 ) THEN + inflow = inflow + Net_rain + ENDIF + ENDIF + + Dprst_in = 0.0D0 + IF ( Dprst_area_open_max>0.0 ) THEN + Dprst_in = DBLE( inflow*Dprst_area_open_max*Thaw_frac ) ! inch-acres + Dprst_vol_open = Dprst_vol_open + Dprst_in + ENDIF + IF ( Dprst_area_clos_max>0.0 ) THEN + tmp1 = DBLE( inflow*Dprst_area_clos_max*Thaw_frac ) ! inch-acres + Dprst_vol_clos = Dprst_vol_clos + tmp1 + Dprst_in = Dprst_in + tmp1 + ENDIF + Dprst_in = Dprst_in/Hruarea_dble ! inches over HRU + + ! add any pervious surface runoff fraction to depressions + dprst_srp = 0.0 + dprst_sri = 0.0 + IF ( Srp>0.0 ) THEN + tmp = Srp*Perv_frac*Sro_to_dprst_perv*Hruarea + IF ( Dprst_area_open_max>0.0 ) THEN + dprst_srp_open = tmp*Dprst_frac_open(Ihru) ! acre-inches + dprst_srp = dprst_srp_open/Hruarea + Dprst_vol_open = Dprst_vol_open + DBLE( dprst_srp_open ) + ENDIF + IF ( Dprst_area_clos_max>0.0 ) THEN + dprst_srp_clos = tmp*Dprst_frac_clos(Ihru) + dprst_srp = dprst_srp + dprst_srp_clos/Hruarea + Dprst_vol_clos = Dprst_vol_clos + DBLE( dprst_srp_clos ) + ENDIF + Srp = Srp - dprst_srp/Perv_frac + IF ( Srp<0.0 ) THEN + IF ( Srp<-NEARZERO ) PRINT *, 'dprst srp<0.0', Srp, dprst_srp + ! may need to adjust dprst_srp and volumes + Srp = 0.0 + ENDIF + ENDIF + + IF ( Sri>0.0 ) THEN + tmp = Sri*Imperv_frac*Sro_to_dprst_imperv*Hruarea + IF ( Dprst_area_open_max>0.0 ) THEN + dprst_sri_open = tmp*Dprst_frac_open(Ihru) + dprst_sri = dprst_sri_open/Hruarea + Dprst_vol_open = Dprst_vol_open + DBLE( dprst_sri_open ) + ENDIF + IF ( Dprst_area_clos_max>0.0 ) THEN + dprst_sri_clos = tmp*Dprst_frac_clos(Ihru) + dprst_sri = dprst_sri + dprst_sri_clos/Hruarea + Dprst_vol_clos = Dprst_vol_clos + DBLE( dprst_sri_clos ) + ENDIF + Sri = Sri - dprst_sri/Imperv_frac + IF ( Sri<0.0 ) THEN + IF ( Sri<-NEARZERO ) PRINT *, 'dprst sri<0.0', Sri, dprst_sri + ! may need to adjust dprst_sri and volumes + Sri = 0.0 + ENDIF + ENDIF + + Dprst_insroff_hru(Ihru) = dprst_srp + dprst_sri + +! Open depression surface area for each HRU: + Dprst_area_open = 0.0 + IF ( Dprst_vol_open>0.0D0 ) THEN + open_vol_r = SNGL( Dprst_vol_open/(Dprst_vol_open_max*Thaw_frac) ) + IF ( open_vol_r1.0 ) THEN + frac_op_ar = 1.0 + ELSE + frac_op_ar = EXP(Va_open_exp(Ihru)*LOG(open_vol_r)) + ENDIF + Dprst_area_open = Dprst_area_open_max*Thaw_frac*frac_op_ar + IF ( Dprst_area_open>Dprst_area_open_max*Thaw_frac ) Dprst_area_open = Dprst_area_open_max*Thaw_frac +! IF ( Dprst_area_open0.0 ) THEN + Dprst_area_clos = 0.0 + IF ( Dprst_vol_clos>0.0D0 ) THEN + clos_vol_r = SNGL( Dprst_vol_clos/(Dprst_vol_clos_max(Ihru)*Thaw_frac) ) + IF ( clos_vol_r1.0 ) THEN + frac_cl_ar = 1.0 + ELSE + frac_cl_ar = EXP(Va_clos_exp(Ihru)*LOG(clos_vol_r)) + ENDIF + Dprst_area_clos = Dprst_area_clos_max*Thaw_frac*frac_cl_ar + IF ( Dprst_area_clos>Dprst_area_clos_max*Thaw_frac ) Dprst_area_clos = Dprst_area_clos_max*Thaw_frac +! IF ( Dprst_area_clos0.0 ) THEN + dprst_evap_open = 0.0 + dprst_evap_clos = 0.0 + IF ( Dprst_area_open>0.0 ) THEN + dprst_evap_open = MIN(Dprst_area_open*dprst_avail_et, SNGL(Dprst_vol_open)) + IF ( dprst_evap_open/Hruarea>unsatisfied_et ) THEN + !IF ( Print_debug>-1 ) THEN + ! PRINT *, 'Warning, open dprst evaporation > available ET, HRU:, ', Ihru, & +! & unsatisfied_et, dprst_evap_open*DBLE(Dprst_frac_open(Ihru)) + ! PRINT *, 'Set to available ET, perhaps dprst_et_coef specified too large' + ! PRINT *, 'Set print_debug to -1 to turn off message' + !ENDIF + dprst_evap_open = unsatisfied_et*Hruarea + ENDIF + !IF ( dprst_evap_open>SNGL(Dprst_vol_open) ) print *, '>', dprst_evap_open, dprst_vol_open + IF ( dprst_evap_open>SNGL(Dprst_vol_open) ) dprst_evap_open = SNGL( Dprst_vol_open ) + unsatisfied_et = unsatisfied_et - dprst_evap_open/Hruarea + Dprst_vol_open = Dprst_vol_open - DBLE( dprst_evap_open ) + ENDIF + IF ( Dprst_area_clos>0.0 ) THEN + dprst_evap_clos = MIN(Dprst_area_clos*dprst_avail_et, SNGL(Dprst_vol_clos)) + IF ( dprst_evap_clos/Hruarea>unsatisfied_et ) THEN + !IF ( Print_debug>-1 ) THEN + ! PRINT *, 'Warning, closed dprst evaporation > available ET, HRU:, ', Ihru, & +! & unsatisfied_et, dprst_evap_clos*Dprst_frac_clos(Ihru) + ! PRINT *, 'Set to available ET, perhaps dprst_et_coef specified too large' + ! PRINT *, 'Set print_debug to -1 to turn off message' + !ENDIF + dprst_evap_clos = unsatisfied_et*Hruarea + ENDIF + IF ( dprst_evap_clos>SNGL(Dprst_vol_clos) ) dprst_evap_clos = SNGL( Dprst_vol_clos ) + Dprst_vol_clos = Dprst_vol_clos - DBLE( dprst_evap_clos ) + ENDIF + Dprst_evap_hru = (dprst_evap_open + dprst_evap_clos)/Hruarea + ENDIF + + ! compute seepage + Dprst_seep_hru = 0.0D0 + IF ( Dprst_vol_open>0.0D0 ) THEN + seep_open = Dprst_vol_open*DBLE( Dprst_seep_rate_open(Ihru) ) + Dprst_vol_open = Dprst_vol_open - seep_open + IF ( Dprst_vol_open<0.0D0 ) THEN +! IF ( Dprst_vol_open<-DNEARZERO ) PRINT *, 'negative dprst_vol_open:', Dprst_vol_open, ' HRU:', Ihru + seep_open = seep_open + Dprst_vol_open + Dprst_vol_open = 0.0D0 + ENDIF + Dprst_seep_hru = seep_open/Hruarea_dble + ENDIF + + ! compute open surface runoff + Dprst_sroff_hru = 0.0D0 + IF ( Dprst_vol_open>0.0D0 ) THEN + Dprst_sroff_hru = MAX( 0.0D0, Dprst_vol_open-Dprst_vol_open_max*Thaw_frac ) + Dprst_sroff_hru = Dprst_sroff_hru + & + & MAX( 0.0D0, (Dprst_vol_open-Dprst_sroff_hru-Dprst_vol_thres_open(Ihru))*DBLE(Dprst_flow_coef(Ihru)) ) + Dprst_vol_open = Dprst_vol_open - Dprst_sroff_hru + Dprst_sroff_hru = Dprst_sroff_hru/Hruarea_dble + ! sanity checks + IF ( Dprst_vol_open<0.0D0 ) THEN +! IF ( Dprst_vol_open<-DNEARZERO ) PRINT *, 'issue, dprst_vol_open<0.0', Dprst_vol_open + Dprst_vol_open = 0.0D0 + ENDIF + ENDIF + + IF ( Dprst_area_clos_max>0.0 ) THEN + IF ( Dprst_area_clos>NEARZERO ) THEN + seep_clos = Dprst_vol_clos*DBLE( Dprst_seep_rate_clos(Ihru) ) + Dprst_vol_clos = Dprst_vol_clos - seep_clos + IF ( Dprst_vol_clos<0.0D0 ) THEN +! IF ( Dprst_vol_clos<-DNEARZERO ) PRINT *, 'issue, dprst_vol_clos<0.0', Dprst_vol_clos + seep_clos = seep_clos + Dprst_vol_clos + Dprst_vol_clos = 0.0D0 + ENDIF + Dprst_seep_hru = Dprst_seep_hru + seep_clos/Hruarea_dble + ENDIF + IF ( Dprst_vol_clos<0.0D0 ) THEN +! IF ( Dprst_vol_clos<-DNEARZERO ) PRINT *, 'issue, dprst_vol_clos<0.0', Dprst_vol_clos + Dprst_vol_clos = 0.0D0 + ENDIF + ENDIF + + Basin_dprst_volop = Basin_dprst_volop + Dprst_vol_open + Basin_dprst_volcl = Basin_dprst_volcl + Dprst_vol_clos + Basin_dprst_evap = Basin_dprst_evap + DBLE( Dprst_evap_hru*Hruarea ) + Basin_dprst_seep = Basin_dprst_seep + Dprst_seep_hru*Hruarea_dble + Basin_dprst_sroff = Basin_dprst_sroff + Dprst_sroff_hru*Hruarea_dble + Avail_et = Avail_et - Dprst_evap_hru + IF ( Dprst_vol_open_max>0.0 ) Dprst_vol_open_frac(Ihru) = SNGL( Dprst_vol_open/(Dprst_vol_open_max*Thaw_frac) ) + IF ( Dprst_vol_clos_max(Ihru)>0.0 ) Dprst_vol_clos_frac(Ihru) = SNGL( Dprst_vol_clos/(Dprst_vol_clos_max(Ihru)*Thaw_frac) ) + Dprst_vol_frac(Ihru) = SNGL( (Dprst_vol_open+Dprst_vol_clos)/((Dprst_vol_open_max+Dprst_vol_clos_max(Ihru))*Thaw_frac) ) + Dprst_stor_hru(Ihru) = (Dprst_vol_open+Dprst_vol_clos)/Hruarea_dble + + END SUBROUTINE dprst_comp + +!*********************************************************************** +! srunoff_restart - write or read srunoff restart file +!*********************************************************************** + SUBROUTINE srunoff_restart(In_out) + USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit, Dprst_flag, & + & Frozen_flag + USE PRMS_SRUNOFF + IMPLICIT NONE + ! Argument + INTEGER, INTENT(IN) :: In_out + EXTERNAL check_restart + ! Local Variable + CHARACTER(LEN=13) :: module_name +!*********************************************************************** + IF ( In_out==0 ) THEN + WRITE ( Restart_outunit ) MODNAME + WRITE ( Restart_outunit ) Basin_sroff_down, Basin_sroff_upslope, Basin_sroffi, Basin_sroffp, & + & Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, Basin_infil, Basin_hortonian, & + & Sri, Srp, Basin_hortonian_lakes + WRITE ( Restart_outunit ) Basin_dprst_sroff, Basin_dprst_evap, Basin_dprst_seep, & + & Basin_dprst_volop, Basin_dprst_volcl, Basin_contrib_fraction + IF ( Dprst_flag==1 ) THEN + WRITE ( Restart_outunit ) Dprst_area_open + WRITE ( Restart_outunit ) Dprst_area_clos + WRITE ( Restart_outunit ) Dprst_stor_hru + WRITE ( Restart_outunit ) Dprst_vol_thres_open + ENDIF + IF ( Frozen_flag==1 ) THEN + WRITE ( Restart_outunit ) Frozen + WRITE ( Restart_outunit ) Cfgi + WRITE ( Restart_outunit ) Cfgi_prev + WRITE ( Restart_outunit ) Frz_depth, Thaw_depth, Soil_water + ENDIF + ELSE + READ ( Restart_inunit ) module_name + CALL check_restart(MODNAME, module_name) + READ ( Restart_inunit ) Basin_sroff_down, Basin_sroff_upslope, Basin_sroffi, Basin_sroffp, & + & Basin_imperv_stor, Basin_imperv_evap, Basin_sroff, Basin_infil, Basin_hortonian, & + & Sri, Srp, Basin_hortonian_lakes + READ ( Restart_inunit ) Basin_dprst_sroff, Basin_dprst_evap, Basin_dprst_seep, & + & Basin_dprst_volop, Basin_dprst_volcl, Basin_contrib_fraction + IF ( Dprst_flag==1 ) THEN + READ ( Restart_inunit ) Dprst_area_open + READ ( Restart_inunit ) Dprst_area_clos + READ ( Restart_inunit ) Dprst_stor_hru + READ ( Restart_inunit ) Dprst_vol_thres_open + ENDIF + IF ( Frozen_flag==1 ) THEN ! could be problem for restart + READ ( Restart_inunit ) Frozen + READ ( Restart_inunit ) Cfgi + READ ( Restart_inunit ) Cfgi_prev + READ ( Restart_inunit ) Frz_depth, Thaw_depth, Soil_water + ENDIF + ENDIF + END SUBROUTINE srunoff_restart From 61d58fc7fc1b3aa6eab25602a12fd5f0a2f26367 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sun, 18 Aug 2019 21:26:38 -0600 Subject: [PATCH 26/47] Merge commit 'bf4da2c757e0abe034f36eced427899a3965561c' into develop * commit 'bf4da2c757e0abe034f36eced427899a3965561c': (509 commits) Update readme for PRMS6 build steps Remove prms5-related files and directories move test cases out of source development tree added exclusions Start of parameter override work Change output to uncompressed 64BIT_OFFSET added extensions to control variables add dimension information to parameters update basin_sroff computation fix bugs plus minor changes change procedure APIs Added dynamic parameter support moved hru_storage_ante and gwres_stor_ante from water balance module change statvar_file to stat_var_file change statvar_file to stat_var_file misc updates minor update Minor changes Remove hru_storage_ante updated definition of basin_changeover in declvar ... # Conflicts: # .gitignore # Makefile # makelist # mmf/Makefile # mmf/defs.h # mmf/read_control.c # mmf/umalloc_etc.c # prms/Makefile # prms/basin.f90 # prms/basin_sum.f90 # prms/call_modules.f90 # prms/climate_hru.f90 # prms/climateflow.f90 # prms/dynamic_param_read.f90 # prms/ide_dist.f # prms/intcp.f90 # prms/muskingum.f90 # prms/muskingum_lake.f90 # prms/precip_1sta_laps.f90 # prms/prms_summary.f90 # prms/routing.f90 # prms/snowcomp.f90 # prms/soilzone.f90 # prms/soltab.f90 # prms/srunoff.f90 # prms/stream_temp.f90 # prms/temp_1sta_laps.f90 # prms/temp_dist2.f90 # prms/water_balance.f90 # prms/xyz_dist.f --- prms/routing.f90 | 1 - prmsRip/mizurouteRip.f90 | 22 ++-- prmsRip/muskingumRip.f90 | 22 ++-- prmsRip/routingRip.f90 | 208 +++++++++++++++++++------------------- prmsRip/snowcompCfgim.f90 | 20 ++-- prmsRip/srunoffCfgim.f90 | 41 ++++++-- 6 files changed, 161 insertions(+), 153 deletions(-) diff --git a/prms/routing.f90 b/prms/routing.f90 index 08dd0f82..9e700512 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -545,7 +545,6 @@ INTEGER FUNCTION routinginit() velocity = (1./Mann_n(i))*SQRT(Seg_slope(i))*Seg_depth(i)**(2./3.) ! simplify if say width>>depth K_coef(i) = Seg_length(i)/(velocity*60.*60.) !want in hours, length should include sloped length !K_coef(i) = Seg_length(i)*sqrt(1+ Seg_slope(i)**2)/(velocity*60.*60.) !want in hours - print*, i, K_coef(i) ENDIF IF ( Segment_type(i)==2 .AND. K_coef(i)<24.0 ) K_coef(i) = 24.0 !K_coef must be specified = 24.0 for lake segments' diff --git a/prmsRip/mizurouteRip.f90 b/prmsRip/mizurouteRip.f90 index 8b6b0121..f49c55d1 100644 --- a/prmsRip/mizurouteRip.f90 +++ b/prmsRip/mizurouteRip.f90 @@ -449,10 +449,10 @@ INTEGER FUNCTION mizuroute_run() & Segment_delta_flow, Segment_type, Basin_segment_storage, Flow_in_great_lakes, & & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Flow_terminus, & & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, & - & Stage_ts, Stage_ante, Seg_bankflow, Seg_slope, Basin_bankflow, Bankst_seep_rate, & - & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, Basin_ripflow, & - & Basin_bankst_seep_rate, Basin_bankflow, Basin_bankst_seep, Basin_bankst_vol, & - & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_seep, Basin_ripst_evap, & + & Stage_ts, Stage_ante, Seg_bankflow, Seg_slope, Bankst_seep_rate, & + & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, & + & Basin_bankst_seep_rate, Basin_bankst_seep, Basin_bankst_vol, & + & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_contrib, Basin_ripst_evap, & & Basin_ripst_vol, Bankst_seep_rate USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt USE PRMS_SRUNOFF, ONLY: Basin_sroff @@ -622,7 +622,7 @@ INTEGER FUNCTION mizuroute_run() Basin_bankst_head = 0.0D0 Basin_bankst_vol = 0.0D0 Basin_ripst_area = 0.0D0 - Basin_ripst_seep = 0.0D0 + Basin_ripst_contrib = 0.0D0 Basin_ripst_evap = 0.0D0 Basin_ripst_vol = 0.0D0 Bankst_seep_rate = 0.0 !collect by segment that HRUs go to @@ -662,7 +662,7 @@ INTEGER FUNCTION mizuroute_run() ! ******Compute the overbank riparian storage component ! transfers water between separate riparian storage and stream depending on seepage ENDDO - Basin_ripst_seep = Basin_ripst_seep*Basin_area_inv + Basin_ripst_contrib = Basin_ripst_contrib*Basin_area_inv Basin_ripst_evap = Basin_ripst_evap*Basin_area_inv Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv DO i = 1, Nsegment @@ -676,8 +676,6 @@ INTEGER FUNCTION mizuroute_run() T0 = T1 Basin_segment_storage = 0.0D0 - Basin_bankflow = 0.0D0 - Basin_ripflow = 0.0D0 Flow_out = 0.0D0 Flow_to_lakes = 0.0D0 Flow_to_ocean = 0.0D0 @@ -723,10 +721,6 @@ INTEGER FUNCTION mizuroute_run() Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout ! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) - IF ( Ripst_flag==1 ) THEN - Basin_bankflow = Basin_bankflow + Seg_bankflow(i) - Basin_ripflow = Basin_ripflow + Seg_ripflow(i) - ENDIF ENDDO area_fac = Cfs_conv/Basin_area_inv @@ -743,10 +737,6 @@ INTEGER FUNCTION mizuroute_run() Basin_ssflow_cfs = Basin_ssflow*area_fac Basin_gwflow_cfs = Basin_gwflow*area_fac Basin_segment_storage = Basin_segment_storage/area_fac - IF ( Ripst_flag==1 ) THEN - Basin_bankflow = Basin_bankflow/area_fac - Basin_ripflow = Basin_ripflow/area_fac - ENDIF END FUNCTION mizuroute_run diff --git a/prmsRip/muskingumRip.f90 b/prmsRip/muskingumRip.f90 index 61035381..dab60368 100644 --- a/prmsRip/muskingumRip.f90 +++ b/prmsRip/muskingumRip.f90 @@ -190,10 +190,10 @@ INTEGER FUNCTION muskingum_run() & Obsin_segment, Segment_order, Tosegment, C0, C1, C2, Ts, Ts_i, Obsout_segment, & & Flow_to_ocean, Flow_to_great_lakes, Flow_out_region, Flow_out_NHM, Segment_type, Flow_terminus, & & Flow_to_lakes, Flow_replacement, Flow_in_region, Flow_in_nation, Flow_headwater, Flow_in_great_lakes, & - & Flow_in_great_lakes, Stage_ts, Stage_ante, Seg_bankflow, Mann_n, Seg_width, Seg_slope, Basin_bankflow, & - & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, Basin_ripflow, & - & Basin_bankst_seep_rate, Basin_bankflow, Basin_bankst_seep, Basin_bankst_vol, & - & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_seep, Basin_ripst_evap, & + & Flow_in_great_lakes, Stage_ts, Stage_ante, Seg_bankflow, Mann_n, Seg_width, Seg_slope, & + & Ripst_areafr_max, Bankfinite_hru, Basin_bankst_head, Seg_ripflow, & + & Basin_bankst_seep_rate, Basin_bankst_seep, Basin_bankst_vol, & + & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_contrib, Basin_ripst_evap, & & Basin_ripst_vol, Bankst_seep_rate USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt USE PRMS_SRUNOFF, ONLY: Basin_sroff @@ -321,7 +321,7 @@ INTEGER FUNCTION muskingum_run() Basin_bankst_head = 0.0D0 Basin_bankst_vol = 0.0D0 Basin_ripst_area = 0.0D0 - Basin_ripst_seep = 0.0D0 + Basin_ripst_contrib = 0.0D0 Basin_ripst_evap = 0.0D0 Basin_ripst_vol = 0.0D0 Bankst_seep_rate = 0.0 !collect by segment that HRUs go to @@ -361,7 +361,7 @@ INTEGER FUNCTION muskingum_run() ! ******Compute the overbank riparian storage component ! transfers water between separate riparian storage and stream depending on seepage ENDDO - Basin_ripst_seep = Basin_ripst_seep*Basin_area_inv + Basin_ripst_contrib = Basin_ripst_contrib*Basin_area_inv Basin_ripst_evap = Basin_ripst_evap*Basin_area_inv Basin_ripst_vol = Basin_ripst_vol*Basin_area_inv DO i = 1, Nsegment @@ -373,8 +373,6 @@ INTEGER FUNCTION muskingum_run() ENDIF Basin_segment_storage = 0.0D0 - Basin_bankflow = 0.0D0 - Basin_ripflow = 0.0D0 Flow_out = 0.0D0 Flow_to_lakes = 0.0D0 Flow_to_ocean = 0.0D0 @@ -421,10 +419,6 @@ INTEGER FUNCTION muskingum_run() Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - segout ! IF ( Segment_delta_flow(i) < 0.0D0 ) PRINT *, 'negative delta flow', Segment_delta_flow(i) Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i) - IF ( Ripst_flag==1 ) THEN - Basin_bankflow = Basin_bankflow + Seg_bankflow(i) - Basin_ripflow = Basin_ripflow + Seg_ripflow(i) - ENDIF ENDDO area_fac = Cfs_conv/Basin_area_inv @@ -441,10 +435,6 @@ INTEGER FUNCTION muskingum_run() Basin_ssflow_cfs = Basin_ssflow*area_fac Basin_gwflow_cfs = Basin_gwflow*area_fac Basin_segment_storage = Basin_segment_storage/area_fac - IF ( Ripst_flag==1 ) THEN - Basin_bankflow = Basin_bankflow/area_fac - Basin_ripflow = Basin_ripflow/area_fac - ENDIF END FUNCTION muskingum_run diff --git a/prmsRip/routingRip.f90 b/prmsRip/routingRip.f90 index ff638dd6..2936dc8b 100644 --- a/prmsRip/routingRip.f90 +++ b/prmsRip/routingRip.f90 @@ -33,14 +33,14 @@ MODULE PRMS_ROUTING ! Declared Parameters for Overbank Storage REAL, SAVE, ALLOCATABLE :: Tr_ratio(:), Porosity_seg(:), Ripst_et_coef(:), Ripst_frac_init(:) ! Declared Variables for Overbank Storage - DOUBLE PRECISION, SAVE :: Basin_ripst_evap, Basin_ripst_seep, Basin_ripflow, Basin_ripst_vol, Basin_ripst_area - DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_stor_hru(:), Ripst_seep_hru(:), Ripst_vol(:), Seg_ripflow(:) + DOUBLE PRECISION, SAVE :: Basin_ripst_evap, Basin_ripst_contrib, Basin_ripst_vol, Basin_ripst_area + DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_stor_hru(:), Ripst_vol(:), Seg_ripflow(:) REAL, SAVE, ALLOCATABLE :: Ripst_evap_hru(:), Ripst_frac(:) ! Declared Parameters for Bank Storage REAL, SAVE, ALLOCATABLE :: Specyield_seg(:), Bankst_head_init(:) INTEGER, SAVE, ALLOCATABLE :: Bankfinite_hru(:) ! Declared Variables for Bank Storage - DOUBLE PRECISION, SAVE :: Basin_bankst_head, Basin_bankst_seep_rate, Basin_bankflow + DOUBLE PRECISION, SAVE :: Basin_bankst_head, Basin_bankst_seep_rate DOUBLE PRECISION, SAVE :: Basin_bankst_seep, Basin_bankst_vol, Basin_bankst_area REAL, SAVE, ALLOCATABLE :: Bankst_head(:), Bankst_seep_rate(:), Bankst_seep_hru(:) REAL, SAVE, ALLOCATABLE :: Bankst_stor_hru(:), Bankst_head_pts(:) @@ -152,9 +152,9 @@ INTEGER FUNCTION routingdecl() & 'Basin area-weighted average evaporation from riparian overbank flow storage', & & 'inches', Basin_ripst_evap)/=0 ) CALL read_error(3, 'basin_ripst_evap') - IF ( declvar(MODNAME, 'basin_ripst_seep', 'one', 1, 'double', & - & 'Basin area-weighted average seepage from riparian overbank flow storage', & - & 'inches', Basin_ripst_seep)/=0 ) CALL read_error(3, 'basin_ripst_seep') + IF ( declvar(MODNAME, 'basin_ripst_contrib', 'one', 1, 'double', & + & 'Basin area-weighted average contribution from riparian overbank flow storage into stream', & + & 'inches', Basin_ripst_contrib)/=0 ) CALL read_error(3, 'basin_ripst_contrib') IF ( declvar(MODNAME, 'basin_ripst_vol', 'one', 1, 'double', & & 'Basin area-weighted average storage volume in riparian overbank flow storage', & @@ -174,11 +174,6 @@ INTEGER FUNCTION routingdecl() & 'Riparian overbank flow storage for each HRU', & & 'inches', Ripst_stor_hru)/=0 ) CALL read_error(3, 'ripst_stor_hru') - ALLOCATE ( Ripst_seep_hru(Nhru) ) - IF ( declvar(MODNAME, 'ripst_seep_hru', 'nhru', Nhru, 'double', & - & 'Seepage from riparian overbank flow storage to associated riparian-GWR for each HRU', & - & 'inches', Ripst_seep_hru)/=0 ) CALL read_error(3, 'ripst_seep_hru') - ALLOCATE ( Ripst_evap_hru(Nhru) ) IF ( declvar(MODNAME, 'ripst_evap_hru', 'nhru', Nhru, 'real', & & 'Evaporation from riparian overbank flow storage for each HRU', & @@ -194,10 +189,6 @@ INTEGER FUNCTION routingdecl() & 'Volume and area fraction of riparian overbank flow storage of the maximum storage for each HRU', & & 'decimal fraction', Ripst_frac)/=0 ) CALL read_error(3, 'ripst_frac') - IF ( declvar(MODNAME, 'basin_ripflow', 'one', 1, 'double', & - & 'Basin riparian area contribution to streamflow, negative if steam goes overbank', & - & 'cfs', Basin_bankflow)/=0 ) CALL read_error(3, 'basin_ripflow') - ALLOCATE ( Ripst_vol_max(Nhru), Ripst_area(Nhru), Ripst_area_max(Nhru), Ripst_depth(Nhru) ) ALLOCATE ( Seg_hru_num(Nsegment) ) @@ -207,7 +198,7 @@ INTEGER FUNCTION routingdecl() & 'meters', Basin_bankst_head)/=0 ) CALL read_error(3, 'basin_bankst_head') IF ( declvar(MODNAME, 'basin_bankst_seep', 'one', 1, 'double', & - & 'Basin area-weighted average seepage from bank storage to streams', & + & 'Basin area-weighted average seepage from bank storage to streams, negative is out of stream', & & 'inches', Basin_bankst_seep)/=0 ) CALL read_error(3, 'basin_bankst_seep') IF ( declvar(MODNAME, 'basin_bankst_vol', 'one', 1, 'double', & @@ -222,10 +213,6 @@ INTEGER FUNCTION routingdecl() & 'Basin rate of seepage from bank storage into stream per unit length stream', & & 'meter3/day/meter', Basin_bankst_seep_rate)/=0 ) CALL read_error(3, 'basin_bankst_seep_rate') - IF ( declvar(MODNAME, 'basin_bankflow', 'one', 1, 'double', & - & 'Basin bank storage contribution to streamflow can be negative if steam losing water', & - & 'cfs', Basin_bankflow)/=0 ) CALL read_error(3, 'basin_bankflow') - ALLOCATE ( Bankst_head(Nhru) ) IF ( declvar(MODNAME, 'bankst_head', 'nhru', Nhru, 'real', & & 'Bank storage area only average head of bank storage above groundwater head', & @@ -651,15 +638,12 @@ INTEGER FUNCTION routinginit() Basin_bankst_seep_rate = 0.0D0 Basin_bankst_head = 0.0D0 Basin_bankst_vol = 0.0D0 - Basin_bankflow = 0.0D0 Basin_bankst_area = 0.0D0 - Basin_ripflow = 0.0D0 Basin_ripst_evap = 0.0D0 - Basin_ripst_seep = 0.0D0 + Basin_ripst_contrib = 0.0D0 Basin_ripst_vol = 0.0D0 Basin_ripst_area = 0.D0 Ripst_evap_hru = 0.0 - Ripst_seep_hru = 0.0D0 Ripst_frac = 0.0 Bankst_seep_hru = 0.0 Bankst_seep_rate = 0.0 @@ -1146,16 +1130,18 @@ END SUBROUTINE init_the_swamp !*********************************************************************** SUBROUTINE drain_the_swamp(Ihru) USE PRMS_ROUTING, ONLY: Seg_width, Seg_depth, Seg_width, Hru_segment, Mann_n, & - & Transmiss_seg, Tr_ratio, Ripst_vol_max, Ripst_et_coef, Ripst_evap_hru, & - & Basin_ripst_vol, Basin_ripst_evap, Basin_ripst_seep, Ripst_stor_hru, & - & Ripst_frac, Ripst_vol, Ripst_area_max, Ripst_area, Ripst_seep_hru, Seg_slope, & - & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area, Seg_length + & Tr_ratio, Ripst_vol_max, Ripst_et_coef, Ripst_evap_hru, Seg_length, & + & Basin_ripst_vol, Basin_ripst_evap, Basin_ripst_contrib, Ripst_stor_hru, & + & Ripst_frac, Ripst_vol, Ripst_area_max, Ripst_area, Seg_slope, & + & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area !, Transmiss_seg + USE PRMS_MODULE, ONLY: Frozen_flag USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Hru_area, Hru_area_dble, FEET2METERS, & & FT2_PER_ACRE, CFS2CMS_CONV USE PRMS_FLOWVARS, ONLY: Seg_outflow USE PRMS_CLIMATEVARS, ONLY: Potet USE PRMS_SET_TIME, ONLY: Timestep_seconds - USE PRMS_SRUNOFF, ONLY: Hru_impervevap, Dprst_evap_hru + USE PRMS_SRUNOFF, ONLY: Hru_impervevap, Dprst_evap_hru, Frozen, Thaw_depth, Soil_depth, & + & Dprst_seep_rate_open USE PRMS_INTCP, ONLY: Hru_intcpevap USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap IMPLICIT NONE @@ -1164,105 +1150,117 @@ SUBROUTINE drain_the_swamp(Ihru) ! Arguments INTEGER, INTENT(IN) :: Ihru ! Local Variables - REAL :: ripst_avail_et, unsatisfied_et, ripst_evap, ripst_wid + REAL :: ripst_avail_et, unsatisfied_et, ripst_evap, ripst_wid, thaw_frac REAL :: inflow, inflow_in, max_depth - DOUBLE PRECISION :: seep, ripst_grnd, poss, seep_in + DOUBLE PRECISION :: seep, ripst_grnd, poss, seep_in, ripst_contrib_hru !*********************************************************************** + thaw_frac = 1.0 + IF (Frozen_flag==1) THEN + IF ( Frozen(Ihru)==1 ) THEN + thaw_frac = 0.0 + ELSEIF ( Frozen(Ihru)==2) THEN + thaw_frac = Thaw_depth(Ihru)/Soil_depth(Ihru) + ENDIF + ENDIF !It won't get deeper than this depth, should be Seg_depth but not accurate or Seg_width and other terms not accurate - !max_depth = Seg_depth(Hru_segment(Ihru))*10.0 - max_depth = Seg_depth(Hru_segment(Ihru))*1e30 + !max_depth = Seg_depth(Hru_segment(Ihru)) + max_depth = Seg_depth(Hru_segment(Ihru))*20.0 ! amount possible in cfs given a river depth poss = Seg_width(Hru_segment(Ihru))*SQRT(Seg_slope(Hru_segment(Ihru)))* & & max_depth**(3./5.)/ ( CFS2CMS_CONV*Mann_n(Hru_segment(Ihru)) ) !inflow is water over bank, remove from Seg_outflow(Hru_segment(Ihru)) and give half to ! each side of bank, in acre inches inflow = 0.0 -! in cfs, amount over amount possible - IF ( poss < Seg_outflow(Hru_segment(Ihru)) ) inflow = SNGL(Seg_outflow(Hru_segment(Ihru)) - poss) + inflow_in = 0.0 +! in cfs, amount over amount possible, no inflow if everything frozen, and then no outflow either + IF (thaw_frac>0.0) THEN + IF ( poss < Seg_outflow(Hru_segment(Ihru))) inflow = SNGL(Seg_outflow(Hru_segment(Ihru)) - poss) ! give it equally to each HRU surrounding it - inflow = inflow/REAL(Seg_hru_num(Hru_segment(Ihru))) + inflow = inflow/REAL(Seg_hru_num(Hru_segment(Ihru))) !negative flow is out of stream into riparian - Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru)) - inflow - inflow_in = SNGL(inflow*Timestep_seconds/(FT2_PER_ACRE*12.0)) - Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow_in - Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) + Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru)) - inflow + inflow_in = SNGL(inflow*Timestep_seconds/(FT2_PER_ACRE*12.0)) !inch acre + Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow_in + Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/(Ripst_vol_max(Ihru)*thaw_frac)) + IF (Ripst_frac(Ihru)>1.0) Ripst_frac(Ihru) = 1.0 ! Filled riparian storage surface area for each HRU: ! Fills outward from the river with one edge on river and with same depth and same side shape ! this works out to keeping fraction same for area and volume filled - Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) + Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) - ! evaporate water from riparian area based on snowcov_area - ! ripst_evap_open & ripst_evap_clos = inches-acres on the HRU - unsatisfied_et = Potet(Ihru) - Snow_evap(Ihru) - Hru_intcpevap(Ihru) & + ! evaporate water from riparian area based on snowcov_area + ! ripst_evap_open & ripst_evap_clos = inches-acres on the HRU + unsatisfied_et = Potet(Ihru) - Snow_evap(Ihru) - Hru_intcpevap(Ihru) & & - Hru_impervevap(Ihru) - Dprst_evap_hru(Ihru) - ripst_avail_et = Potet(Ihru)*(1.0-Snowcov_area(Ihru))*Ripst_et_coef(Ihru) - Ripst_evap_hru(Ihru) = 0.0 - IF ( ripst_avail_et>0.0 ) THEN - ripst_evap = 0.0 - IF ( Ripst_area(Ihru)>0.0 ) THEN - ripst_evap = MIN(Ripst_area(Ihru)*ripst_avail_et, SNGL(Ripst_vol(Ihru))) - IF ( ripst_evap/Hru_area(Ihru)>unsatisfied_et ) THEN - !IF ( Print_debug>-1 ) THEN - ! PRINT *, 'Warning, ripst evaporation > available ET, HRU:, ', Ihru, & + ripst_avail_et = 0.0 + ripst_avail_et = Potet(Ihru)*(1.0-Snowcov_area(Ihru))*Ripst_et_coef(Ihru) + Ripst_evap_hru(Ihru) = 0.0 + IF ( ripst_avail_et>0.0 ) THEN + ripst_evap = 0.0 + IF ( Ripst_area(Ihru)>0.0 ) THEN + ripst_evap = MIN(Ripst_area(Ihru)*ripst_avail_et, SNGL(Ripst_vol(Ihru))) + IF ( ripst_evap/Hru_area(Ihru)>unsatisfied_et ) THEN + !IF ( Print_debug>-1 ) THEN + ! PRINT *, 'Warning, ripst evaporation > available ET, HRU:, ', Ihru, & ! & unsatisfied_et, ripst_evap*Ripst_frac(Ihru) - ! PRINT *, 'Set to available ET, perhaps ripst_et_coef specified too large' - ! PRINT *, 'Set print_debug to -1 to turn off message' - !ENDIF - ripst_evap = unsatisfied_et*Hru_area(Ihru) + ! PRINT *, 'Set to available ET, perhaps ripst_et_coef specified too large' + ! PRINT *, 'Set print_debug to -1 to turn off message' + !ENDIF + ripst_evap = unsatisfied_et*Hru_area(Ihru) + ENDIF + IF ( ripst_evap>SNGL(Ripst_vol(Ihru)) ) ripst_evap = SNGL( Ripst_vol(Ihru) ) + Ripst_vol(Ihru) = Ripst_vol(Ihru) - DBLE( ripst_evap ) ENDIF - IF ( ripst_evap>SNGL(Ripst_vol(Ihru)) ) ripst_evap = SNGL( Ripst_vol(Ihru) ) - Ripst_vol(Ihru) = Ripst_vol(Ihru) - DBLE( ripst_evap ) + Ripst_evap_hru(Ihru) = ripst_evap/Hru_area(Ihru) ENDIF - Ripst_evap_hru(Ihru) = ripst_evap/Hru_area(Ihru) - ENDIF - ! compute seepage - Ripst_seep_hru(Ihru) = 0.0D0 - seep = 0.0 - IF ( Ripst_vol(Ihru)>NEARZERO ) THEN - ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters + ! compute seepage + seep = 0.0 + seep_in = 0.0 + IF ( Ripst_vol(Ihru)>NEARZERO) THEN + ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters !assumed it was a one sided stream, here a headwater with both sides in one HRU - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 ! Stream ground area is stream side area (flat wall) and other side area (fraction of triangle (1) to rectangle (0)) - ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle - & (SQRT( ripst_wid**2.0 + Ripst_depth(Ihru)**2.0 )- Ripst_depth(Ihru))*Tr_ratio(Ihru) + & !triangle - & 2.0*Ripst_depth(Ihru) ) ) !stream and other side + ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle + & (SQRT( ripst_wid**2.0 + (Ripst_depth(Ihru)*thaw_frac)**2.0 )- Ripst_depth(Ihru)*thaw_frac)*Tr_ratio(Ihru) + & !triangle + & 2.0*Ripst_depth(Ihru)*thaw_frac ) ) !stream and other side !assumed it was a one sided stream, here a headwater with both sides in one HRU - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 !seep in a day through ground surface area of riparian, m^3 into ft^3 to acre_in -!Transmissivity would be way too big, maybe ssr2gw_rate - seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) - !seep = 0.0 !if want to turn off seep - seep_in = seep*FT2_PER_ACRE*12.0 - Ripst_vol(Ihru) = Ripst_vol(Ihru) - seep_in +!Transmissivity way too big + !seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) !acre_in +!ground area to total surface area is 5/6, then use depression seep coeff but reduce because surface area smaller + seep = ripst_grnd/(ripst_grnd+Ripst_area(Ihru)*FT2_PER_ACRE/ FEET2METERS**2.0 )/(5.0/6.0) & + & *Ripst_vol(Ihru)*Dprst_seep_rate_open(Ihru)/FT2_PER_ACRE/12.0 + !seep = 0.0 !if want to turn off seep + seep_in = seep*FT2_PER_ACRE*12.0 ! inch acres + Ripst_vol(Ihru) = Ripst_vol(Ihru) - seep_in + IF ( Ripst_vol(Ihru)<0.0D0 ) THEN + !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) + seep_in = seep_in + Ripst_vol(Ihru) + seep = seep_in/FT2_PER_ACRE/12.0 !ft^3 + Ripst_vol(Ihru) = 0.0D0 + ENDIF + ENDIF IF ( Ripst_vol(Ihru)<0.0D0 ) THEN !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) - seep_in = seep_in + Ripst_vol(Ihru) - seep = seep_in/(FT2_PER_ACRE*12.0) Ripst_vol(Ihru) = 0.0D0 ENDIF - Ripst_seep_hru(Ihru) = seep_in/Hru_area_dble(Ihru) !inch per HRU - ENDIF - IF ( Ripst_vol(Ihru)<0.0D0 ) THEN - !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) - Ripst_vol(Ihru) = 0.0D0 + ripst_contrib_hru = seep_in - inflow_in !inch per acre + ! seep goes back in stream as positive flow, cfs + Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru))+ seep/Timestep_seconds + !Seg_ripflow(Hru_segment(Ihru)) = 0.0 !if want to turn off overbank flow + + Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/(Ripst_vol_max(Ihru)*thaw_frac)) + Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) + Ripst_stor_hru(Ihru) = Ripst_vol(Ihru)/Hru_area_dble(Ihru) + Basin_ripst_vol = Basin_ripst_vol + Ripst_vol(Ihru) + Basin_ripst_evap = Basin_ripst_evap + DBLE(Ripst_evap_hru(Ihru))*Hru_area_dble(Ihru) + Basin_ripst_contrib = Basin_ripst_contrib + ripst_contrib_hru + Basin_ripst_area = Basin_ripst_area + Ripst_area(Ihru) ENDIF - ! seep goes back in stream as positive flow, cfs - Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru))+ seep/Timestep_seconds - !Seg_ripflow(Hru_segment(Ihru)) = 0.0 !if want to turn off overbank flow - -! print*, Ihru, Hru_segment(Ihru), poss, Seg_outflow(Hru_segment(Ihru)), Seg_ripflow(Hru_segment(Ihru)), Seg_depth(Hru_segment(Ihru)),& -! & Stage_ts(Hru_segment(Ihru)) - - Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/Ripst_vol_max(Ihru)) - Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) - Ripst_stor_hru(Ihru) = Ripst_vol(Ihru)/Hru_area_dble(Ihru) - Basin_ripst_vol = Basin_ripst_vol + Ripst_vol(Ihru) - Basin_ripst_evap = Basin_ripst_evap + DBLE(Ripst_evap_hru(Ihru))*Hru_area_dble(Ihru) - Basin_ripst_seep = Basin_ripst_seep + Ripst_seep_hru(Ihru)*Hru_area_dble(Ihru) - Basin_ripst_area = Basin_ripst_area + Ripst_area(Ihru) - END SUBROUTINE drain_the_swamp !*********************************************************************** @@ -1538,15 +1536,14 @@ SUBROUTINE routing_restart(In_out) WRITE ( Restart_outunit ) Basin_bankst_head WRITE ( Restart_outunit ) Basin_bankst_vol WRITE ( Restart_outunit ) Basin_bankst_seep_rate - WRITE ( Restart_outunit ) Basin_bankst_seep, Basin_bankflow + WRITE ( Restart_outunit ) Basin_bankst_seep WRITE ( Restart_outunit ) Bankst_head, Seg_bankflow WRITE ( Restart_outunit ) Bankst_head_pts WRITE ( Restart_outunit ) Bankst_stor_hru WRITE ( Restart_outunit ) Stage_ante, Stage_ts - WRITE ( Restart_outunit ) Basin_ripflow - WRITE ( Restart_outunit ) Basin_ripst_evap, Basin_ripst_seep + WRITE ( Restart_outunit ) Basin_ripst_evap, Basin_ripst_contrib WRITE ( Restart_outunit ) Basin_ripst_vol, Basin_ripst_area - WRITE ( Restart_outunit ) Ripst_stor_hru, Ripst_seep_hru, Ripst_vol + WRITE ( Restart_outunit ) Ripst_stor_hru, Ripst_vol WRITE ( Restart_outunit ) Seg_ripflow, Ripst_evap_hru, Ripst_frac ENDIF ELSE @@ -1560,15 +1557,14 @@ SUBROUTINE routing_restart(In_out) READ ( Restart_inunit ) Basin_bankst_head READ ( Restart_inunit ) Basin_bankst_vol READ ( Restart_inunit ) Basin_bankst_seep_rate - READ ( Restart_inunit ) Basin_bankst_seep, Basin_bankflow + READ ( Restart_inunit ) Basin_bankst_seep READ ( Restart_inunit ) Bankst_head, Seg_bankflow READ ( Restart_inunit ) Bankst_head_pts READ ( Restart_inunit ) Bankst_stor_hru READ ( Restart_inunit ) Stage_ante, Stage_ts - READ ( Restart_inunit ) Basin_ripflow - READ ( Restart_inunit ) Basin_ripst_evap, Basin_ripst_seep + READ ( Restart_inunit ) Basin_ripst_evap, Basin_ripst_contrib READ ( Restart_inunit ) Basin_ripst_vol, Basin_ripst_area - READ ( Restart_inunit ) Ripst_stor_hru, Ripst_seep_hru, Ripst_vol + READ ( Restart_inunit ) Ripst_stor_hru, Ripst_vol READ ( Restart_inunit ) Seg_ripflow, Ripst_evap_hru, Ripst_frac ENDIF ENDIF diff --git a/prmsRip/snowcompCfgim.f90 b/prmsRip/snowcompCfgim.f90 index b519fc56..09a30494 100644 --- a/prmsRip/snowcompCfgim.f90 +++ b/prmsRip/snowcompCfgim.f90 @@ -1031,8 +1031,10 @@ INTEGER FUNCTION snorun() Glacr_5avsnow(i) = 0.0 !zero out for new year restart ENDIF ENDIF - Prev_ann_tempc(i) = Ann_tempc(i) - Ann_tempc(i) = 0.0 !zero out for new year restart + IF ( Glacier_flag==1 .OR. Frozen_flag==1) THEN + Prev_ann_tempc(i) = Ann_tempc(i) + Ann_tempc(i) = 0.0 !zero out for new year restart + ENDIF ENDIF !end start of year calculations ! Do for summer @@ -1044,7 +1046,7 @@ INTEGER FUNCTION snorun() ! Do for every time step Glacr_5avsnow(i) = Glacr_5avsnow(i) + Net_snow(i)/5.0 ENDIF - Ann_tempc(i) = ( Ann_tempc(i)*(Julwater-1)+ Tavgc(i) )/Julwater + IF ( Glacier_flag==1 .OR. Frozen_flag==1) Ann_tempc(i) = ( Ann_tempc(i)*(Julwater-1)+ Tavgc(i) )/Julwater ! HRU SET-UP - SET DEFAULT VALUES AND/OR BASE ! CONDITIONS FOR THIS TIME PERIOD @@ -3007,7 +3009,7 @@ SUBROUTINE snowcomp_restart(In_out) WRITE ( Restart_outunit ) Glacr_pkwater_equiv WRITE ( Restart_outunit ) Glacr_pkwater_ante WRITE ( Restart_outunit ) Glacr_pk_temp - WRITE ( Restart_outunit ) Ann_tempc, Yrdays5, Prev_ann_tempc + WRITE ( Restart_outunit ) Yrdays5 WRITE ( Restart_outunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp WRITE ( Restart_outunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow WRITE ( Restart_outunit ) Glacr_pk_def @@ -3017,6 +3019,9 @@ SUBROUTINE snowcomp_restart(In_out) IF ( Frozen_flag==1 ) THEN WRITE ( Restart_outunit ) Tcalin_nosnow, Tcalin_snow, Land_albedo ENDIF + IF ( Glacier_flag==1 .OR. Frozen_flag==1) THEN + WRITE ( Restart_outunit ) Ann_tempc, Prev_ann_tempc + ENDIF ELSE READ ( Restart_inunit ) module_name CALL check_restart(MODNAME, module_name) @@ -3060,7 +3065,7 @@ SUBROUTINE snowcomp_restart(In_out) READ ( Restart_inunit ) Glacr_pkwater_equiv READ ( Restart_inunit ) Glacr_pkwater_ante READ ( Restart_inunit ) Glacr_pk_temp - READ ( Restart_inunit ) Ann_tempc, Yrdays5, Prev_ann_tempc + READ ( Restart_inunit ) Yrdays5 READ ( Restart_inunit ) Glacr_air_5avtemp, Glacr_air_5avtemp1, Glacr_air_deltemp READ ( Restart_inunit ) Glacr_5avsnow, Glacr_5avsnow1, Glacr_delsnow READ ( Restart_inunit ) Glacr_pk_def @@ -3068,7 +3073,10 @@ SUBROUTINE snowcomp_restart(In_out) READ ( Restart_inunit ) Glacr_freeh2o_capm ENDIF IF ( Frozen_flag==1 ) THEN - WRITE ( Restart_inunit ) Tcalin_nosnow, Tcalin_snow, Land_albedo + READ ( Restart_inunit ) Tcalin_nosnow, Tcalin_snow, Land_albedo + ENDIF + IF ( Glacier_flag==1 .OR. Frozen_flag==1) THEN + READ ( Restart_inunit ) Ann_tempc, Prev_ann_tempc ENDIF ENDIF END SUBROUTINE snowcomp_restart diff --git a/prmsRip/srunoffCfgim.f90 b/prmsRip/srunoffCfgim.f90 index ee360dbb..4b78fb56 100644 --- a/prmsRip/srunoffCfgim.f90 +++ b/prmsRip/srunoffCfgim.f90 @@ -22,7 +22,7 @@ MODULE PRMS_SRUNOFF REAL, SAVE, ALLOCATABLE :: Carea_dif(:), Imperv_stor_ante(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Dprst_stor_ante(:) REAL, SAVE :: Srp, Sri, Perv_frac, Imperv_frac, Hruarea_imperv, Hruarea - DOUBLE PRECISION, SAVE :: Hruarea_dble, Basin_apply_sroff, Basin_cfgi_sroff + DOUBLE PRECISION, SAVE :: Hruarea_dble, Basin_apply_sroff INTEGER, SAVE :: Use_sroff_transfer, Isglacier ! Declared Variables DOUBLE PRECISION, SAVE :: Basin_sroff_down, Basin_sroff_upslope @@ -45,7 +45,8 @@ MODULE PRMS_SRUNOFF ! Declared Variables for Frozen Ground REAL, SAVE, ALLOCATABLE :: Cfgi(:), Cfgi_prev(:), Frz_depth(:), Thaw_depth(:), Soil_water(:) REAL, SAVE, ALLOCATABLE :: Soil_moist_prev(:) - INTEGER, SAVE, ALLOCATABLE :: Frozen(:) + INTEGER, SAVE, ALLOCATABLE :: Frozen(:), Frozen_prev(:) + DOUBLE PRECISION, SAVE :: Basin_cfgi_sroff, Basin_frz_depth, Basin_thaw_depth ! Declared Parameters for Depression Storage REAL, SAVE, ALLOCATABLE :: Op_flow_thres(:), Sro_to_dprst_perv(:) REAL, SAVE, ALLOCATABLE :: Va_clos_exp(:), Va_open_exp(:) @@ -341,6 +342,14 @@ INTEGER FUNCTION srunoffdecl() & 'Depth soil is thawed from surface', & & 'inches', Thaw_depth)/=0 ) CALL read_error(1, 'thaw_depth') + IF ( declvar(MODNAME, 'basin_frz_depth', 'one', 1, 'double', & + & 'Basin average maximum depth soil is frozen', & + & 'inches', Basin_frz_depth)/=0 ) CALL read_error(1, 'basin_frz_depth') + + IF ( declvar(MODNAME, 'basin_thaw_depth', 'one', 1, 'double', & + & 'Basin average depth soil is thawed from surface', & + & 'inches', Basin_thaw_depth)/=0 ) CALL read_error(1, 'basin_thaw_depth') + ALLOCATE ( Soil_depth(Nhru) ) IF ( declparam(MODNAME, 'soil_depth', 'nhru', 'real', & & '19.685', '0.0', '60.0', & @@ -362,7 +371,7 @@ INTEGER FUNCTION srunoffdecl() & 'Porosity of soil for frozen ground calculations', & & 'decimal fraction')/=0 ) CALL read_error(1, 'porosity_hru') - ALLOCATE( Soil_moist_prev(Nhru) ) + ALLOCATE( Soil_moist_prev(Nhru), Frozen_prev(Nhru) ) ENDIF ! Declare parameters @@ -571,11 +580,14 @@ INTEGER FUNCTION srunoffinit() Sri = 0.0 IF ( Frozen_flag==1 ) THEN Frozen = 0 + Frozen_prev = Frozen Cfgi = 0.0 Cfgi_prev = 0.0 Frz_depth = 0.0 Thaw_depth = 0.0 Soil_moist_prev = Soil_moist + Basin_frz_depth = 0.0D0 + Basin_thaw_depth = 0.0D0 ENDIF ENDIF @@ -665,7 +677,6 @@ INTEGER FUNCTION srunoffrun() USE PRMS_INTCP, ONLY: Net_rain, Net_snow, Net_ppt, Hru_intcpevap, Net_apply, Intcp_changeover USE PRMS_SNOW, ONLY: Snow_evap, Snowcov_area, Snowmelt, Pk_depth, Glacrb_melt, & & Tcalin_snow, Tcalin_nosnow, Glacrcov_area, Prev_ann_tempc - USE PRMS_SET_TIME, ONLY: Jday IMPLICIT NONE INTRINSIC SNGL, DBLE EXTERNAL imperv_et, compute_infil, run_cascade_sroff, dprst_comp, perv_comp @@ -713,6 +724,11 @@ INTEGER FUNCTION srunoffrun() Basin_dprst_volcl = 0.0D0 ENDIF + IF ( Frozen_flag==1 ) THEN + Basin_frz_depth = 0.0D0 + Basin_thaw_depth = 0.0D0 + ENDIF + dprst_chk = 0 DO k = 1, Active_hrus i = Hru_route_order(k) @@ -771,8 +787,8 @@ INTEGER FUNCTION srunoffrun() IF ( Frozen_flag==1 ) THEN - IF ( Frozen(i)/=1 && Frozen_prev(i)/=1 ) Soil_water(i) = Soil_water(i)+ Soil_moist(i) - Soil_moist_prev(i) !is Soil_moist correct? Soil_moist_tot? - IF ( Frozen(i)/=1 && Frozen_prev(i)/=1 ) Soil_moist_prev(i) = Soil_moist(i) + IF ( Frozen(i)/=1 .AND. Frozen_prev(i)/=1 ) Soil_water(i) = Soil_water(i)+ Soil_moist(i) - Soil_moist_prev(i) !is Soil_moist correct? Soil_moist_tot? + IF ( Frozen(i)/=1 .AND. Frozen_prev(i)/=1 ) Soil_moist_prev(i) = Soil_moist(i) ! modCFGI, following Follum et al 2018 ! set emissivity, which is the fraction of perfect black-body ! emission that is actually applied @@ -872,15 +888,17 @@ INTEGER FUNCTION srunoffrun() ENDIF IF ( Use_sroff_transfer==1 ) cfgi_sroff = cfgi_sroff + Net_apply(i)*Hruarea runoff = runoff + cfgi_sroff - Basin_cfgi_sroff = Basin_cfgi_sroff + cfgi_sroff + Basin_cfgi_sroff = Basin_cfgi_sroff + cfgi_sroff !might want to put this in cfs and make plotable variable ELSE !not frozen Frz_depth(i) = 0.0 Thaw_depth(i) = 0.0 ENDIF + Frozen_prev(i) = Frozen(i) Frozen(i) = frzen Cfgi_prev(i) = Cfgi(i) + Basin_frz_depth = Basin_frz_depth + Frz_depth(i)*Hruarea_dble + Basin_thaw_depth = Basin_thaw_depth + Thaw_depth(i)*Hruarea_dble ENDIF - !******Compute runoff for pervious, impervious, and depression storage area, only if not totally frozen ground IF ( frzen/=1 ) THEN ! DO IRRIGATION APPLICATION, ONLY DONE HERE, ASSUMES NO SNOW and @@ -1008,6 +1026,11 @@ INTEGER FUNCTION srunoffrun() Basin_sroff_upslope = Basin_sroff_upslope*Basin_area_inv ENDIF + IF ( Frozen_flag==1 ) THEN + Basin_frz_depth = Basin_frz_depth*Basin_area_inv + Basin_thaw_depth = Basin_thaw_depth*Basin_area_inv + ENDIF + IF ( Dprst_flag==1 ) THEN Basin_dprst_volop = Basin_dprst_volop*Basin_area_inv Basin_dprst_volcl = Basin_dprst_volcl*Basin_area_inv @@ -1682,6 +1705,7 @@ SUBROUTINE srunoff_restart(In_out) WRITE ( Restart_outunit ) Cfgi WRITE ( Restart_outunit ) Cfgi_prev WRITE ( Restart_outunit ) Frz_depth, Thaw_depth, Soil_water + WRITE ( Restart_outunit ) Basin_frz_depth, Basin_thaw_depth ENDIF ELSE READ ( Restart_inunit ) module_name @@ -1702,6 +1726,7 @@ SUBROUTINE srunoff_restart(In_out) READ ( Restart_inunit ) Cfgi READ ( Restart_inunit ) Cfgi_prev READ ( Restart_inunit ) Frz_depth, Thaw_depth, Soil_water + READ ( Restart_inunit ) Basin_frz_depth, Basin_thaw_depth ENDIF ENDIF END SUBROUTINE srunoff_restart From 6d01ac830f50c3d01bc4bbc37a69709b2d91c812 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 20 Aug 2019 19:25:24 -0600 Subject: [PATCH 27/47] bug fixing in bank storage and riparian --- prmsRip/muskingumRip.f90 | 1 + prmsRip/routingRip.f90 | 20 ++++++++++++++------ prmsRip/srunoffCfgim.f90 | 4 ++-- 3 files changed, 17 insertions(+), 8 deletions(-) diff --git a/prmsRip/muskingumRip.f90 b/prmsRip/muskingumRip.f90 index dab60368..37c6bfb9 100644 --- a/prmsRip/muskingumRip.f90 +++ b/prmsRip/muskingumRip.f90 @@ -344,6 +344,7 @@ INTEGER FUNCTION muskingum_run() DO i = 1, Nsegment Basin_bankst_seep_rate = Basin_bankst_seep_rate + Bankst_seep_rate(i) & & *Seg_length(i)/SUM(Seg_length) !m2/day per stream ft length + !print*, Seg_outflow(i)+Seg_bankflow(i),Seg_outflow(i),Seg_bankflow(i), i Seg_outflow(i) = Seg_outflow(i)+Seg_bankflow(i) IF (Seg_bankflow(i) < 0.0) THEN ! only could go negative because of bankflow if is negative IF (Seg_outflow(i) < 0.0) THEN ! took out more than streamflow, this could also be a water_use problem diff --git a/prmsRip/routingRip.f90 b/prmsRip/routingRip.f90 index 2936dc8b..53f10b5f 100644 --- a/prmsRip/routingRip.f90 +++ b/prmsRip/routingRip.f90 @@ -30,6 +30,7 @@ MODULE PRMS_ROUTING REAL, SAVE, ALLOCATABLE :: Seg_length(:), Seg_slope(:) ! Declared Parameters for Overbank and bank Storage REAL, SAVE, ALLOCATABLE :: Transmiss_seg(:), Ripst_areafr_max(:) + REAL, SAVE :: Bank_height_fac ! Declared Parameters for Overbank Storage REAL, SAVE, ALLOCATABLE :: Tr_ratio(:), Porosity_seg(:), Ripst_et_coef(:), Ripst_frac_init(:) ! Declared Variables for Overbank Storage @@ -383,6 +384,12 @@ INTEGER FUNCTION routingdecl() & ' if =0, then overbank storage is turned off, if also bankfinite_hru =1 bank storage is off', & & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_areafr_max') + IF ( declparam(MODNAME, 'bank_height_fac', 'one', 'real', & + & '20.0', '1.0', '100.0', & + & 'Factor multiplied to Seg_depth to give maximum height of banks', & + & 'Factor multiplied to Seg_depth to give maximum height of banks for riparian overbank storage', & + & 'none')/=0 ) CALL read_error(1, 'bank_height_fac') + ALLOCATE ( Porosity_seg(Nsegment) ) IF ( declparam(MODNAME, 'porosity_seg', 'nsegment', 'real', & & '0.4', '0.15', '0.75', & @@ -697,6 +704,7 @@ INTEGER FUNCTION routinginit() IF ( Ripst_flag==1 ) THEN IF ( getparam(MODNAME, 'ripst_areafr_max', Nhru, 'real', Ripst_areafr_max)/=0 ) CALL read_error(2, 'ripst_areafr_max') + IF ( getparam(MODNAME, 'bank_height_fac', 1, 'real', Bank_height_fac)/=0 ) CALL read_error(2, 'bank_height_fac') IF ( getparam(MODNAME, 'ripst_et_coef', Nhru, 'real', Ripst_et_coef)/=0 ) CALL read_error(2, 'ripst_et_coef') IF ( getparam(MODNAME, 'tr_ratio', Nhru, 'real', Tr_ratio)/=0 ) CALL read_error(2, 'tr_ratio') IF ( getparam(MODNAME, 'bankfinite_hru', Nhru, 'integer', Bankfinite_hru)/=0 ) CALL read_error(2, 'bankfinite_hru') @@ -710,8 +718,8 @@ INTEGER FUNCTION routinginit() IF (Bankfinite_hru(i)==1) Basin_bankst_area = Basin_bankst_area+Ripst_areafr_max(i)*Hru_area_dble(i) ! in inches IF (Bankfinite_hru(i)==0) Basin_bankst_area = Basin_bankst_area+Hru_area_dble(i) ! in inches Ripst_area_max(i) = Ripst_areafr_max(i)*Hru_area(i) -! depth of hyporheic estimated at stream depth/porosity, Harvey and Wagner (2000) ?? - Ripst_depth(i) = Seg_depth(Hru_segment(i)) / Porosity_seg(Hru_segment(i)) +! depth to depth of hyporheic, estimated at stream depth/porosity, Harvey and Wagner (2000) + Ripst_depth(i) = Seg_depth(Hru_segment(i)) / Porosity_seg(Hru_segment(i)) + Seg_depth(Hru_segment(i)) IF (Ripst_areafr_max(i)==0.0) Ripst_depth(i) = 0.0 Ripst_vol_max(i) = DBLE( Ripst_area_max(i)*Ripst_depth(i)*(1.0-0.5*Tr_ratio(i)) ) Seg_hru_num(Hru_segment(i)) =Seg_hru_num(Hru_segment(i)) +1 @@ -1133,7 +1141,7 @@ SUBROUTINE drain_the_swamp(Ihru) & Tr_ratio, Ripst_vol_max, Ripst_et_coef, Ripst_evap_hru, Seg_length, & & Basin_ripst_vol, Basin_ripst_evap, Basin_ripst_contrib, Ripst_stor_hru, & & Ripst_frac, Ripst_vol, Ripst_area_max, Ripst_area, Seg_slope, & - & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area !, Transmiss_seg + & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area, Bank_height_fac !, Transmiss_seg USE PRMS_MODULE, ONLY: Frozen_flag USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Hru_area, Hru_area_dble, FEET2METERS, & & FT2_PER_ACRE, CFS2CMS_CONV @@ -1162,9 +1170,8 @@ SUBROUTINE drain_the_swamp(Ihru) thaw_frac = Thaw_depth(Ihru)/Soil_depth(Ihru) ENDIF ENDIF -!It won't get deeper than this depth, should be Seg_depth but not accurate or Seg_width and other terms not accurate - !max_depth = Seg_depth(Hru_segment(Ihru)) - max_depth = Seg_depth(Hru_segment(Ihru))*20.0 +!It won't get deeper than this depth, should be close to Seg_depth but not accurate or Seg_width and other terms not accurate + max_depth = Seg_depth(Hru_segment(Ihru))*Bank_height_fac ! amount possible in cfs given a river depth poss = Seg_width(Hru_segment(Ihru))*SQRT(Seg_slope(Hru_segment(Ihru)))* & & max_depth**(3./5.)/ ( CFS2CMS_CONV*Mann_n(Hru_segment(Ihru)) ) @@ -1406,6 +1413,7 @@ SUBROUTINE comp_bank_storage(Ihru) Bankst_head(Ihru) = Bankst_head(Ihru) + 0.5*Bankst_head_pts(Ihru) ! m2 per 24 hr per stream segment for both sides of stream ! seep hru is inch over hru seeping out per day + Bankst_seep_hru(Ihru) = -12.0*bankv(nbankd)/SNGL(CFS2CMS_CONV*Hru_area(Ihru)*FT2_PER_ACRE) Bankst_seep_rate(Hru_segment(Ihru)) = Bankst_seep_rate(Hru_segment(Ihru)) - bank(nbankd) Bankst_stor_hru(Ihru) = Bankst_stor_hru(Ihru)- Bankst_seep_hru(Ihru) !inch over hru diff --git a/prmsRip/srunoffCfgim.f90 b/prmsRip/srunoffCfgim.f90 index 4b78fb56..24815e85 100644 --- a/prmsRip/srunoffCfgim.f90 +++ b/prmsRip/srunoffCfgim.f90 @@ -976,7 +976,7 @@ INTEGER FUNCTION srunoffrun() Basin_contrib_fraction = Basin_contrib_fraction + DBLE( Contrib_fraction(i)*hperv ) !******Compute evaporation from impervious area - IF ( frzen==0 ) THEN + !IF ( frzen/=1 ) THEN !Should we care that it's frozen if it's impervious? AVB IF ( Hruarea_imperv>0.0 ) THEN IF ( Imperv_stor(i)>0.0 ) THEN CALL imperv_et(Imperv_stor(i), Potet(i), Imperv_evap(i), Snowcov_area(i), avail_et) @@ -999,7 +999,7 @@ INTEGER FUNCTION srunoffrun() Hru_sroffi(i) = Sri*Imperv_frac Basin_sroffi = Basin_sroffi + DBLE( Sri*Hruarea_imperv ) ENDIF - ENDIF + !ENDIF IF ( dprst_chk==1 ) Dprst_stor_hru(i) = (Dprst_vol_open(i)+Dprst_vol_clos(i))/Hruarea_dble From 2036070f99e27a99c811dbd5d19e1d1c6763603e Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 20 Aug 2019 19:36:14 -0600 Subject: [PATCH 28/47] updating makefile and readme --- Makefile | 6 +++--- README.md | 1 + 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index dbc49f34..5c59934c 100755 --- a/Makefile +++ b/Makefile @@ -13,9 +13,9 @@ include ./makelist # Standard Targets for Users # -all: prmsglrip prmsgl +all: prmsrip prms -prmsglrip: +prmsrip: # Create lib directory, if necessary @if [ ! -d $(MMFDIR) ] ; then \ mkdir $(MMFDIR) ; \ @@ -30,7 +30,7 @@ prmsglrip: cd $(MIZUDIR); $(MAKE); cd $(PRMSRDIR); $(MAKE); -prmsgl: +prms: # Create lib directory, if necessary @if [ ! -d $(MMFDIR) ] ; then \ mkdir $(MMFDIR) ; \ diff --git a/README.md b/README.md index aa67641c..6a765f70 100644 --- a/README.md +++ b/README.md @@ -1,2 +1,3 @@ # prms Precipitation Runoff Modeling System +This fork makes two executables when doing 'make'. The executable /bin/prms will have capabilities of turning on the glacier_flag, the stream_temp_flag, the frozen_flag (that uses the old CFGI with no frozen depth just binary frozen state), and using the strmflow_module muskingum, muskingum_mann, or mizuroute. The executable /bin/prmsrip will have capabilities of turning on the glacier_flag, the stream_temp_flag, the frozen_flag (that uses the new CFGImod with frozen depth), the ripst_flag, and using the strmflow_module muskingum, muskingum_mann, or mizuroute. From 5e91f7e2a6c5fff42f3095745e590b4c30b79e90 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 20 Aug 2019 19:38:21 -0600 Subject: [PATCH 29/47] fixed bug in makefile --- Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 5c59934c..dbc49f34 100755 --- a/Makefile +++ b/Makefile @@ -13,9 +13,9 @@ include ./makelist # Standard Targets for Users # -all: prmsrip prms +all: prmsglrip prmsgl -prmsrip: +prmsglrip: # Create lib directory, if necessary @if [ ! -d $(MMFDIR) ] ; then \ mkdir $(MMFDIR) ; \ @@ -30,7 +30,7 @@ prmsrip: cd $(MIZUDIR); $(MAKE); cd $(PRMSRDIR); $(MAKE); -prms: +prmsgl: # Create lib directory, if necessary @if [ ! -d $(MMFDIR) ] ; then \ mkdir $(MMFDIR) ; \ From c4459108928370d53a43cf0d7b11fdc442803397 Mon Sep 17 00:00:00 2001 From: "Markstrom, Steven L" Date: Fri, 23 Aug 2019 08:18:50 -0600 Subject: [PATCH 30/47] Working on stream temp slow down bug --- prms/call_modules.f90 | 2 +- prms/stream_temp.f90 | 16 ++++++++-------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/prms/call_modules.f90 b/prms/call_modules.f90 index 3e559cfb..64b64bd7 100644 --- a/prms/call_modules.f90 +++ b/prms/call_modules.f90 @@ -8,7 +8,7 @@ MODULE PRMS_MODULE CHARACTER(LEN=68), PARAMETER :: & & EQULS = '====================================================================' CHARACTER(LEN=12), PARAMETER :: MODNAME = 'call_modules' - CHARACTER(LEN=24), PARAMETER :: PRMS_VERSION = 'Version 5.0.1 06/12/2019' + CHARACTER(LEN=24), PARAMETER :: PRMS_VERSION = 'Version 5.1.0 RC' CHARACTER(LEN=8), SAVE :: Process CHARACTER(LEN=80), SAVE :: PRMS_versn INTEGER, SAVE :: Model, Process_flag, Call_cascade, Ncascade, Ncascdgw diff --git a/prms/stream_temp.f90 b/prms/stream_temp.f90 index 0978f824..f980df64 100644 --- a/prms/stream_temp.f90 +++ b/prms/stream_temp.f90 @@ -842,14 +842,14 @@ INTEGER FUNCTION stream_temp_run() ! k is the upstream segment fs = 0.0 up_temp = 0.0 - DO k = 1, Nsegment - IF ( Tosegment(k)==i ) THEN - if (Seg_tave_water(k) > -1.0) then - up_temp = up_temp + (Seg_tave_water(k) * SNGL(Seg_outflow(k))) - fs = fs + SNGL(Seg_outflow(k)) - endif - ENDIF - ENDDO +! DO k = 1, Nsegment +! IF ( Tosegment(k)==i ) THEN +! if (Seg_tave_water(k) > -1.0) then +! up_temp = up_temp + (Seg_tave_water(k) * SNGL(Seg_outflow(k))) +! fs = fs + SNGL(Seg_outflow(k)) +! endif +! ENDIF +! ENDDO ! Finish computing seg_tave_upstream IF ( fs > NEARZERO) THEN From 213ed399c15a70ed958b5e0100d9220cefc54575 Mon Sep 17 00:00:00 2001 From: "Markstrom, Steven L" Date: Fri, 23 Aug 2019 08:25:12 -0600 Subject: [PATCH 31/47] not finished. --- prms/stream_temp.f90 | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/prms/stream_temp.f90 b/prms/stream_temp.f90 index f980df64..82819a02 100644 --- a/prms/stream_temp.f90 +++ b/prms/stream_temp.f90 @@ -839,9 +839,18 @@ INTEGER FUNCTION stream_temp_run() ! Find upstream intitial inflow temperature for segment i ! i is the current segment -! k is the upstream segment +! kk is the upstream segment fs = 0.0 up_temp = 0.0 + do k = 1, upstream_count(i) + kk = upstream_idx(i,k) + if (Seg_tave_water(kk) > -1.0) then + up_temp = up_temp + (Seg_tave_water(kk) * SNGL(Seg_outflow(kk))) + fs = fs + SNGL(Seg_outflow(kk)) + endif + ENDIF + ENDDO + ! DO k = 1, Nsegment ! IF ( Tosegment(k)==i ) THEN ! if (Seg_tave_water(k) > -1.0) then From 73efd3c68c926cf91f6142f56305e092662f7a5e Mon Sep 17 00:00:00 2001 From: "Markstrom, Steven L" Date: Mon, 26 Aug 2019 11:56:55 -0600 Subject: [PATCH 32/47] Compiles and runs --- prms/stream_temp.f90 | 36 ++++++++++++++++++++++++++++++++---- 1 file changed, 32 insertions(+), 4 deletions(-) diff --git a/prms/stream_temp.f90 b/prms/stream_temp.f90 index 82819a02..8dcd9508 100644 --- a/prms/stream_temp.f90 +++ b/prms/stream_temp.f90 @@ -20,6 +20,8 @@ MODULE PRMS_STRMTEMP REAL, SAVE, ALLOCATABLE :: gw_sum(:), ss_sum(:) REAL, SAVE, ALLOCATABLE :: gw_silo(:,:), ss_silo(:,:) REAL, SAVE, ALLOCATABLE :: hru_area_sum(:) + INTEGER, SAVE, ALLOCATABLE :: upstream_count(:) + INTEGER, SAVE, ALLOCATABLE :: upstream_idx(:,:) INTEGER, SAVE :: gw_index, ss_index ! Declared Variables @@ -406,7 +408,7 @@ INTEGER FUNCTION stream_temp_init() USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Segment_up IMPLICIT NONE ! Functions - INTRINSIC :: COS, SIN, ABS, SIGN, ASIN + INTRINSIC :: COS, SIN, ABS, SIGN, ASIN, maxval INTEGER, EXTERNAL :: getparam REAL, EXTERNAL :: solalt EXTERNAL :: read_error, checkdim_param_limits @@ -661,6 +663,33 @@ INTEGER FUNCTION stream_temp_init() endif enddo enddo + +! For each segment, figure out how many upstream segments. + ALLOCATE(upstream_count(Nsegment)) + upstream_count = 0 + do i = 1, nsegment + do j = 1, nsegment + if (tosegment(i) .eq. j) then + upstream_count(i) = upstream_count(i) + 1 + endif + end do + end do + +! For each segment, figure out the upstream segments. These will be looped over to determine inflows and temps to each segment + ALLOCATE(upstream_idx(Nsegment, maxval(upstream_count))) + upstream_idx = 0 + upstream_count = 0 + do i = 1, nsegment + do j = 1, nsegment + if (tosegment(i) .eq. j) then + upstream_count(i) = upstream_count(i) + 1 + upstream_idx(i,upstream_count(i)) = j + endif + end do + end do + + + END FUNCTION stream_temp_init @@ -676,7 +705,7 @@ INTEGER FUNCTION stream_temp_run() USE PRMS_CLIMATE_HRU, ONLY: Humidity_hru USE PRMS_FLOWVARS, ONLY: Seg_outflow USE PRMS_SNOW, ONLY: Snowmelt - USE PRMS_ROUTING, ONLY: Hru_segment, Tosegment, Segment_order, Seginc_swrad + USE PRMS_ROUTING, ONLY: Hru_segment, Segment_order, Seginc_swrad USE PRMS_OBS, ONLY: Humidity USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday, Jday USE PRMS_SOLTAB, ONLY: Soltab_potsw, Hru_cossl @@ -688,7 +717,7 @@ INTEGER FUNCTION stream_temp_run() EXTERNAL :: equilb, lat_inflow, shday ! Local Variables REAL :: harea, svi, fs - INTEGER :: i, j, k, iseg + INTEGER :: i, j, k, kk, iseg REAL :: te, ak1, ak2, ccov DOUBLE PRECISION :: qlat REAL :: t_o, up_temp @@ -847,7 +876,6 @@ INTEGER FUNCTION stream_temp_run() if (Seg_tave_water(kk) > -1.0) then up_temp = up_temp + (Seg_tave_water(kk) * SNGL(Seg_outflow(kk))) fs = fs + SNGL(Seg_outflow(kk)) - endif ENDIF ENDDO From f0e0d239b17f62e160dd921a7e3687ce6a31e75d Mon Sep 17 00:00:00 2001 From: "Markstrom, Steven L" Date: Mon, 26 Aug 2019 17:08:12 -0600 Subject: [PATCH 33/47] Upstream connections now being determined correctly. --- prms/stream_temp.f90 | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/prms/stream_temp.f90 b/prms/stream_temp.f90 index 8dcd9508..7022c668 100644 --- a/prms/stream_temp.f90 +++ b/prms/stream_temp.f90 @@ -669,7 +669,7 @@ INTEGER FUNCTION stream_temp_init() upstream_count = 0 do i = 1, nsegment do j = 1, nsegment - if (tosegment(i) .eq. j) then + if (tosegment(j) .eq. i) then upstream_count(i) = upstream_count(i) + 1 endif end do @@ -681,13 +681,22 @@ INTEGER FUNCTION stream_temp_init() upstream_count = 0 do i = 1, nsegment do j = 1, nsegment - if (tosegment(i) .eq. j) then + if (tosegment(j) .eq. i) then upstream_count(i) = upstream_count(i) + 1 upstream_idx(i,upstream_count(i)) = j endif end do end do +! do i = 1, nsegment +! write(*, fmt="(1x,a,i0)", advance="no") "segment #", i +! write(*, fmt="(1x,a,i0)", advance="no") " ", upstream_count(i) +! do j = 1, upstream_count(i) +! write(*, fmt="(1x,a,i0)", advance="no") " ", upstream_idx(i,j) +! end do +! write(*, fmt="(1x,a)",advance="yes") " done" +! end do + END FUNCTION stream_temp_init @@ -879,15 +888,6 @@ INTEGER FUNCTION stream_temp_run() ENDIF ENDDO -! DO k = 1, Nsegment -! IF ( Tosegment(k)==i ) THEN -! if (Seg_tave_water(k) > -1.0) then -! up_temp = up_temp + (Seg_tave_water(k) * SNGL(Seg_outflow(k))) -! fs = fs + SNGL(Seg_outflow(k)) -! endif -! ENDIF -! ENDDO - ! Finish computing seg_tave_upstream IF ( fs > NEARZERO) THEN seg_tave_upstream(i) = up_temp / fs From 240bf41088702814375b23c53ff57c34acb635b1 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Wed, 28 Aug 2019 10:46:44 -0600 Subject: [PATCH 34/47] makefile stuff --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index dbc49f34..687d4ece 100755 --- a/Makefile +++ b/Makefile @@ -51,4 +51,4 @@ clean: cd $(MIZUDIR); $(MAKE) clean; cd $(PRMSDIR); $(MAKE) clean; cd $(PRMSRDIR); $(MAKE) clean; - $(RM) $(BINDIR)/prms*~ + $(RM) $(BINDIR)/prms* From 48821deeae83af15d90e896996108432fea8c90c Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 3 Sep 2019 11:56:16 -0600 Subject: [PATCH 35/47] updating readme and some parameter descriptions --- README.md | 111 +++++++++++++++++++++++++++++++++++++++ prms/routing.f90 | 6 +-- prmsRip/muskingumRip.f90 | 1 - prmsRip/routingRip.f90 | 6 +-- 4 files changed, 117 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index 6a765f70..61f15279 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,114 @@ # prms Precipitation Runoff Modeling System This fork makes two executables when doing 'make'. The executable /bin/prms will have capabilities of turning on the glacier_flag, the stream_temp_flag, the frozen_flag (that uses the old CFGI with no frozen depth just binary frozen state), and using the strmflow_module muskingum, muskingum_mann, or mizuroute. The executable /bin/prmsrip will have capabilities of turning on the glacier_flag, the stream_temp_flag, the frozen_flag (that uses the new CFGImod with frozen depth), the ripst_flag, and using the strmflow_module muskingum, muskingum_mann, or mizuroute. + + + +Glacier params, calculate: + +abl_elev_range-- from RGI == Randolph Glacier Inventory and modify, /Roland has code +glacier_frac_init-- from RGI /Roland has code +glrette_frac_init-- from RGI, fraction of HRU that is small glacier and not delineated into special glacier HRU /Roland has code +hru_length--geometric map tools/Roland has code +hru_width--geometric map tools/Roland has code +tohru--from glacier HRU delineation/Roland has code +(Note, some standard PRMS params change on glaciers, like hru_type =4 on all possible to be glacierized HRUs). Roland's code figured out all this + + + +Glacier params, defaults, could calibrate some of these (I did in the Copper paper): + +albedo_coef +albedo_ice +glacr_freeh2o_cap +glacr_layer +glacrva_coef-- will go away if update code with Delta h area change and then might add some +glacrva_exp-- will go away if update code with Delta h area change and then might add some +max_gldepth +stor_firn +stor_ice +stor_snow + + + +Routing params calculate: + +mann_n-- can be from slope if nothing better, that is the method in CONUS and then we calibrate +seg_slope-- DEM +Muskingum: seg_depth-- from regression models or? I got it from a paper in CONUS +Dynamic: seg_width-- from regression models or NARwidth of ? I got it from a paper in CONUS for the streams smaller than 30 m wide, big is NARwidths +seg_length-- DEM? needs to be length including the vertical drop +(does not use K_coef) + + + +Frozen ground params, defaults, can calibrate to permafrost probability maps: + +cfgi_decay -- calibrate this maybe +cfgi_thrshld-- calibrate this definitely +porosity_hru-- soils data porosity +soil_depth-- Unified North American Soil Map? STATSGO? +soil_den --Unified North American Soil Map? STATSGO? + + + +Riparian needs all the new routing params (besides seg_length) and: +calculate: + +porosity_seg-- soils data porosity +ripst_areafr_max-- riparian area data gives fraction of HRU riparian +specyield_seg-- might be data on this somewhere, haven't got it for CONUS yet but default is perhaps close enough +transmiss_seg-- soils data transmissivity + + + +Riparian defaults, most of these have no good reason to calibrate: + +bankfinite_hru +bankst_head_init +ripst_et_coef +ripst_frac_init +tr_ratio +bank_height_fac -- calibrate this or at least think about what want, it's 20 right now + + + +Stream Temp calculate: + +seg_elev-- DEM +seg_lat-- DEM +width_m-- relate to seg_width somehow? + + + +Stream Temp, I'd leave these at defaults ... ask Markstrom: + +albedo +alte +altw +azrh +gw_tau +lat_temp_adj +maxiter_sntemp +melt_temp +ss_tau +vce +vcw +vdemn +vdemx +vdwmn +vdwmx +vdwmx +vhe +vhw +voe +vow +width_alpha + + + +Calving glacier params calculate: +NOTE: currently this isn't going to get put in so you can ignore (there are calving parameters needed for MWBMglacier now) + +ocean_depth -- offshore DEM at end of calving front, current idea is to set up offshore HRUs that contain the glacier tongue area and have properties +(these glaciers will have tohrus that then will be possible to tell that the upstream glacier part feeds a calving front, as long as tongue calculated to float) diff --git a/prms/routing.f90 b/prms/routing.f90 index 9e700512..baf65715 100644 --- a/prms/routing.f90 +++ b/prms/routing.f90 @@ -148,7 +148,7 @@ INTEGER FUNCTION routingdecl() IF ( declparam( MODNAME, 'seg_length', 'nsegment', 'real', & & '1000.0', '0.001', '200000.0', & & 'Length of each segment', & - & 'Length of each segment, bounds based on CONUS', & + & 'Length of each segment including vertical drop', & & 'meters')/=0 ) CALL read_error(1, 'seg_length') ENDIF @@ -156,8 +156,8 @@ INTEGER FUNCTION routingdecl() ALLOCATE ( Seg_width(Nsegment) ) IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & & '15.0', '0.18', '40000.0', & - & 'Segment river width', & - & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & + & 'Segment bankfull river width', & + & 'Segment bankfull river width, narrowest observed from Zimmerman 1967, Amazon biggest', & & 'meters')/=0 ) CALL read_error(1, 'seg_width') ENDIF diff --git a/prmsRip/muskingumRip.f90 b/prmsRip/muskingumRip.f90 index 37c6bfb9..dab60368 100644 --- a/prmsRip/muskingumRip.f90 +++ b/prmsRip/muskingumRip.f90 @@ -344,7 +344,6 @@ INTEGER FUNCTION muskingum_run() DO i = 1, Nsegment Basin_bankst_seep_rate = Basin_bankst_seep_rate + Bankst_seep_rate(i) & & *Seg_length(i)/SUM(Seg_length) !m2/day per stream ft length - !print*, Seg_outflow(i)+Seg_bankflow(i),Seg_outflow(i),Seg_bankflow(i), i Seg_outflow(i) = Seg_outflow(i)+Seg_bankflow(i) IF (Seg_bankflow(i) < 0.0) THEN ! only could go negative because of bankflow if is negative IF (Seg_outflow(i) < 0.0) THEN ! took out more than streamflow, this could also be a water_use problem diff --git a/prmsRip/routingRip.f90 b/prmsRip/routingRip.f90 index 53f10b5f..72e647f3 100644 --- a/prmsRip/routingRip.f90 +++ b/prmsRip/routingRip.f90 @@ -277,7 +277,7 @@ INTEGER FUNCTION routingdecl() IF ( declparam( MODNAME, 'seg_length', 'nsegment', 'real', & & '1000.0', '0.001', '200000.0', & & 'Length of each segment', & - & 'Length of each segment, bounds based on CONUS', & + & 'Length of each segment including vertical drop', & & 'meters')/=0 ) CALL read_error(1, 'seg_length') ENDIF @@ -285,8 +285,8 @@ INTEGER FUNCTION routingdecl() ALLOCATE ( Seg_width(Nsegment) ) IF ( declparam(MODNAME, 'seg_width', 'nsegment', 'real', & & '15.0', '0.18', '40000.0', & - & 'Segment river width', & - & 'Segment river width, narrowest observed from Zimmerman 1967, Amazon biggest', & + & 'Segment bankfull river width', & + & 'Segment bankfull river width, narrowest observed from Zimmerman 1967, Amazon biggest', & & 'meters')/=0 ) CALL read_error(1, 'seg_width') ENDIF From 3529586400018df4529297f1325a92e3d973a0d1 Mon Sep 17 00:00:00 2001 From: "Markstrom, Steven L" Date: Tue, 10 Sep 2019 15:16:12 -0600 Subject: [PATCH 36/47] Regan's changes --- prms/dynamic_param_read.f90 | 65 ++++++++++++++++++++----------------- 1 file changed, 35 insertions(+), 30 deletions(-) diff --git a/prms/dynamic_param_read.f90 b/prms/dynamic_param_read.f90 index 3d32466d..ba254e50 100644 --- a/prms/dynamic_param_read.f90 +++ b/prms/dynamic_param_read.f90 @@ -54,7 +54,7 @@ INTEGER FUNCTION dynamic_param_read() IF ( Process(:3)=='run' ) THEN dynamic_param_read = dynparamrun() ELSEIF ( Process(:4)=='decl' ) THEN - Version_dynamic_param_read = 'dynamic_param_read.f90 2019-05-30 13:50:00Z' + Version_dynamic_param_read = 'dynamic_param_read.f90 2019-09-06 16:05:00Z' CALL print_module(Version_dynamic_param_read, 'Time Series Data ', 90) !MODNAME = 'dynamic_param_read' ELSEIF ( Process(:4)=='init' ) THEN @@ -426,12 +426,14 @@ INTEGER FUNCTION dynparamrun() EXTERNAL write_dynoutput, is_eof, write_dynparam, write_dynparam_int EXTERNAL write_dynparam_potet ! Local Variables - INTEGER :: i, istop, check_dprst_depth_flag + INTEGER :: i, istop, check_dprst_depth_flag, check_sm_max_flag, check_srechr_max_flag REAL :: harea, frac_imperv, tmp, hruperv, dprstfrac, soil_adj CHARACTER(LEN=30), PARAMETER :: fmt1 = '(A, I0, ":", I5, 2("/",I2.2))' !*********************************************************************** dynparamrun = 0 istop = 0 + check_srechr_max_flag = 0 + check_sm_max_flag = 0 IF ( Imperv_frac_flag==1 .OR. Dprst_frac_flag==1 .OR. Dprst_depth_flag==1 ) THEN Check_imperv = 0 @@ -582,6 +584,7 @@ INTEGER FUNCTION dynparamrun() ENDIF Basin_soil_moist = Basin_soil_moist + DBLE( Soil_moist(i)*Hru_perv(i) ) Basin_soil_rechr = Basin_soil_rechr + DBLE( Soil_rechr(i)*Hru_perv(i) ) + Soil_moist_tot(i) = Ssres_stor(i) + Soil_moist(i)*Hru_frac_perv(i) ENDDO Basin_soil_moist = Basin_soil_moist*Basin_area_inv Basin_soil_rechr = Basin_soil_rechr*Basin_area_inv @@ -668,33 +671,34 @@ INTEGER FUNCTION dynparamrun() CALL write_dynparam(Output_unit, Nhru, Updated_hrus, Temp, Potet_coef(1,Nowmonth), 'potet_coef') ENDIF CALL is_eof(Potetcoef_unit, Potetcoef_next_yr, Potetcoef_next_mo, Potetcoef_next_day) - ENDIF - IF ( Et_flag==1 ) THEN ! potet_jh - IF ( Dyn_potet_flag==1 ) THEN - Jh_coef = Potet_coef - ELSE - DO i = 1, Nhru - Jh_coef_hru(i) = Potet_coef(i,Nowmonth) - ENDDO - ENDIF - ELSEIF ( Et_flag==7 ) THEN ! climate_hru - Potet_cbh_adj = Potet_coef - ELSEIF ( Et_flag==11 ) THEN ! potet_pm - IF ( Dyn_potet_flag==1 ) THEN - Pm_n_coef = Potet_coef - ELSE - Pm_d_coef = Potet_coef + + IF ( Et_flag==1 ) THEN ! potet_jh + IF ( Dyn_potet_flag==1 ) THEN + Jh_coef = Potet_coef + ELSE + DO i = 1, Nhru + Jh_coef_hru(i) = Potet_coef(i,Nowmonth) + ENDDO + ENDIF + ELSEIF ( Et_flag==7 ) THEN ! climate_hru + Potet_cbh_adj = Potet_coef + ELSEIF ( Et_flag==11 ) THEN ! potet_pm + IF ( Dyn_potet_flag==1 ) THEN + Pm_n_coef = Potet_coef + ELSE + Pm_d_coef = Potet_coef + ENDIF + ELSEIF ( Et_flag==5 ) THEN ! potet_pt + Pt_alpha = Potet_coef + ELSEIF ( Et_flag==10 ) THEN ! potet_hs + Hs_krs = Potet_coef + ELSEIF ( Et_flag==2 ) THEN ! potet_hamon + Hamon_coef = Potet_coef + !ELSEIF ( Et_flag==6 ) THEN ! potet_jh_hru + !Jh_coef_hru2 = Potet_coef + ELSEIF ( Et_flag==4 ) THEN ! potet_pan + Epan_coef = Potet_coef ENDIF - ELSEIF ( Et_flag==5 ) THEN ! potet_pt - Pt_alpha = Potet_coef - ELSEIF ( Et_flag==10 ) THEN ! potet_hs - Hs_krs = Potet_coef - ELSEIF ( Et_flag==2 ) THEN ! potet_hamon - Hamon_coef = Potet_coef - !ELSEIF ( Et_flag==6 ) THEN ! potet_jh_hru - !Jh_coef_hru2 = Potet_coef - ELSEIF ( Et_flag==4 ) THEN ! potet_pan - Epan_coef = Potet_coef ENDIF ENDIF ENDIF @@ -750,6 +754,7 @@ INTEGER FUNCTION dynparamrun() CALL write_dynparam(Output_unit, Nhru, Updated_hrus, Temp, Soil_rechr_max_frac, 'soil_rechr_max_frac') ENDIF CALL is_eof(Soil_rechr_unit, Soil_rechr_next_yr, Soil_rechr_next_mo, Soil_rechr_next_day) + check_srechr_max_flag = 1 ENDIF ENDIF ENDIF @@ -761,11 +766,12 @@ INTEGER FUNCTION dynparamrun() READ ( Soil_moist_unit, * ) Soil_moist_next_yr, Soil_moist_next_mo, Soil_moist_next_day, Temp CALL write_dynparam(Output_unit, Nhru, Updated_hrus, Temp, Soil_moist_max, 'soil_moist_max') CALL is_eof(Soil_moist_unit, Soil_moist_next_yr, Soil_moist_next_mo, Soil_moist_next_day) + check_sm_max_flag = 1 ENDIF ENDIF ENDIF - IF ( Soilmoist_flag==1 .OR. Soilrechr_flag==1 ) THEN + IF ( check_sm_max_flag==1 .OR. check_srechr_max_flag==1 ) THEN DO i = 1, Nhru IF ( Hru_type(i)==2 .OR. Hru_type(i)==0 ) CYCLE ! skip lake and inactive HRUs @@ -786,7 +792,6 @@ INTEGER FUNCTION dynparamrun() CYCLE ENDIF Soil_zone_max(i) = Sat_threshold(i) + Soil_moist_max(i)*Hru_frac_perv(i) - Soil_moist_tot(i) = Ssres_stor(i) + Soil_moist(i)*Hru_frac_perv(i) Soil_lower_stor_max(i) = Soil_moist_max(i) - Soil_rechr_max(i) Replenish_frac(i) = Soil_rechr_max(i)/Soil_moist_max(i) ENDDO From 36d2a4704a0cf9f3ae09488e6785d6678bcc096e Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Fri, 13 Sep 2019 11:04:58 -0600 Subject: [PATCH 37/47] fixing some options/flags --- prms/glacr_melt.f90 | 53 +++++++++++++++++++++++++++++++----------- prmsRip/routingRip.f90 | 5 ++-- 2 files changed, 43 insertions(+), 15 deletions(-) diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 index ebc429db..15891f27 100644 --- a/prms/glacr_melt.f90 +++ b/prms/glacr_melt.f90 @@ -54,7 +54,7 @@ MODULE PRMS_GLACR ! Ntp - Number of tops of glaciers, so max glaciers that could ever split in two ! Nhrugl - Number of at least partially glacierized hrus at initiation !#of cells=Nhrugl,#of streams=Ntp,#of cells/stream<=Ntp, #of glaciers<=Nhru - INTEGER, SAVE :: Nglres, Ngl, Ntp, Nhrugl, MbInit_flag, Output_unit, Fraw_unit, All_unit + INTEGER, SAVE :: Nglres, Ngl, Ntp, Nhrugl, Mbinit_flag, Output_unit, Fraw_unit, All_unit INTEGER, SAVE :: Seven, Four, Glac_HRUnum_down DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_area_inch2(:) REAL, PARAMETER :: Gravity = 9.8 ! m/s2 @@ -85,7 +85,7 @@ MODULE PRMS_GLACR REAL, SAVE :: Max_gldepth REAL, SAVE, ALLOCATABLE :: Glacrva_coef(:), Glacrva_exp(:), Hru_length(:), Hru_width(:) REAL, SAVE, ALLOCATABLE :: Stor_ice(:,:), Stor_snow(:,:), Stor_firn(:,:) - REAL, SAVE, ALLOCATABLE :: Hru_slope(:), Abl_elev_range(:) + REAL, SAVE, ALLOCATABLE :: Hru_slope(:), Abl_elev_range(:), Basal_elev_set(:), Basal_slope_set(:) END MODULE PRMS_GLACR @@ -119,7 +119,7 @@ END FUNCTION GLACR ! glacrsetdims - declares glacier module specific dimensions !*********************************************************************** INTEGER FUNCTION glacrsetdims() - USE PRMS_GLACR, ONLY: Nglres, Seven, Four, MbInit_flag + USE PRMS_GLACR, ONLY: Nglres, Seven, Four, Mbinit_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declfix, control_integer @@ -134,7 +134,8 @@ INTEGER FUNCTION glacrsetdims() IF ( declfix('four',4, 4, 'Need for keeping glacier variable integer array')/=0 ) CALL read_error(7, 'four') Four = 4 - IF ( control_integer(MbInit_flag, 'mbInit_flag')/=0 ) MbInit_flag = 0 + IF ( control_integer(Mbinit_flag, 'mbinit_flag')/=0 ) Mbinit_flag = 0 + print*,Mbinit_flag END FUNCTION glacrsetdims @@ -434,7 +435,23 @@ INTEGER FUNCTION glacrdecl() 'Average HRU snowfield ablation zones elevation range or ~ median-min elev', & 'elev_units')/=0 ) CALL read_error(1, 'abl_elev_range') - END FUNCTION glacrdecl + IF (Mbinit_flag==1) THEN + ALLOCATE ( Basal_elev_set(Nhru) ) + IF ( declparam(MODNAME, 'basal_elev_set', 'nhru', 'real', & + '0.0', '-1000.0', '30000.0', & + 'Glacier basal elevation mean over HRU inputted from outside information', & + 'Glacier basal elevation mean over HRU inputted from outside information', & + 'elev_units')/=0 ) CALL read_error(1, 'basal_elev_set') + + ALLOCATE ( Basal_slope_set(Nhru) ) + IF ( declparam(MODNAME, 'basal_slope_set', 'nhru', 'real', & + '0.0', '0.0', '10.0', & + 'Glacier basal slope down flowline mean over HRU inputted from outside information', & + 'Glacier basal slope down flowline mean over HRU inputted from outside information', & + 'decimal fraction')/=0) CALL read_error(1, 'basal_slope_set') + ENDIF + + END FUNCTION glacrdecl !*********************************************************************** ! glacrinit - Initialize glacr module - get parameter values @@ -498,8 +515,15 @@ INTEGER FUNCTION glacrinit() Gl_mb_cumul = 0.0D0 Gl_mbc_yrend = 0.0D0 Hru_slope_ts = Hru_slope - Basal_elev = Hru_elev_ts ! Hru_elev_ts always set in basin, need in case of restart - Basal_slope = Hru_slope_ts + IF (Mbinit_flag/=1) THEN + Basal_elev = Hru_elev_ts ! Hru_elev_ts always set in basin, need in case of restart + Basal_slope = Hru_slope_ts + ELSE !get from parameters + IF ( getparam(MODNAME, 'basal_elev_set', Nhru, 'real', Basal_elev_set)/=0 ) CALL read_error(2, 'basal_elev_set') + Basal_elev = Basal_elev_set + IF ( getparam(MODNAME, 'basal_slope_set', Nhru, 'real', Basal_slope_set)/=0 ) CALL read_error(2, 'basal_slope_set') + Basal_slope = Basal_slope_set + ENDIF Av_basal_slope = 0.0 Glacr_elev_init = Hru_elev_ts Glacr_slope_init = Hru_slope_ts @@ -903,9 +927,12 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) INTEGER, INTENT(IN) :: glacr_exist, glrette_exist !*********************************************************************** comp_glsurf = 1 - dobot = 1 ! 1 calls bottom calcs, 0 doesn't: Set to 0 for calibrating, then run one extra step with it on - ! Should change so that saves the basal elevations (or reads in as parameter) and then recalibrating does not change + dobot = 1 ! Should change so that saves the basal elevations (or reads in as parameter) and then recalibrating does not change botwrite = 0 ! 1 writes bottom calcs, 0 doesn't: Set to 0 for calibrating + IF (Mbinit_flag<2) THEN ! know the bottom, read as parameter + dobot = 0 + botwrite = 0 + ENDIF ! initialize ela_elevt = 0.0 gt = 0 @@ -950,7 +977,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) ENDIF ENDDO ! ELA calculations - IF ( MBinit_flag==2 ) THEN + IF ( MBinit_flag==3 ) THEN doela = compute_ela_aar() !want steady state ELA estimation for fraw calc DO j = 1, Ntp ela_elevt(j)=Hru_elev(Ela(j)) !will scale inside subroutine, want initial one without _ts @@ -1919,9 +1946,9 @@ END SUBROUTINE tag_count ! subroutine bottom - calculates bottom topo using Salamatin and Mazo ! equations (1985) without optimization for steady state, instead ! needs a proxy for steady state mass balance. Can do this from mass -! balance calculation with climate data first year (MbInit_flag=1) +! balance calculation with climate data first year (Mbinit_flag=2) ! or use max and min balance above and below Ela, respectively and assume -! constant mass balance gradient above and below Ela; e.g. Farinotti (MbInit_flag=2) +! constant mass balance gradient above and below Ela; e.g. Farinotti (Mbinit_flag=3) ! All mass balances are adjust to put glacier in steady state. ! ! The method of Salamatin and Mazo is from conservation of mass, @@ -2061,7 +2088,7 @@ SUBROUTINE bottom(Frawt, Gln, Gt, Topn, Gl_top, Av_elev, Ela_elevt, Flow_slope, ! then add(x)=-int(f(z(x))*area(z(x)))dz/int(area(z(x)))dz ! if add is constant in z, then constant in x because no matter what z is, same add !If only one Hru on glacier, fraw will all be 0 to be in steady state - ! add would be zero if did the full integral with Mbinit_flag==2, but wrong at the moment + ! add would be zero if did the full integral with Mbinit_flag==3, but wrong at the moment hf(1) = hrawe(1)*frawe(1) DO i = 2, len_str_true+1 hf(i) = hraw(i-1)*fraw(i-1) diff --git a/prmsRip/routingRip.f90 b/prmsRip/routingRip.f90 index 72e647f3..16d7c566 100644 --- a/prmsRip/routingRip.f90 +++ b/prmsRip/routingRip.f90 @@ -367,7 +367,7 @@ INTEGER FUNCTION routingdecl() ALLOCATE ( Ripst_frac_init(Nhru) ) IF ( declparam(MODNAME, 'ripst_frac_init', 'nhru', 'real', & & '0.5', '0.0', '1.0', & - & 'Fraction of maximum storage that contains water at the start of a simulation', & + & 'Fraction of maximum storage volume that contains water at the start of a simulation', & & 'Fraction of maximum riparian overbank flow storage that'// & & ' contains water at the start of a simulation', & & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_frac_init') @@ -385,7 +385,7 @@ INTEGER FUNCTION routingdecl() & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_areafr_max') IF ( declparam(MODNAME, 'bank_height_fac', 'one', 'real', & - & '20.0', '1.0', '100.0', & + & '20.0', '1.0', '1000.0', & & 'Factor multiplied to Seg_depth to give maximum height of banks', & & 'Factor multiplied to Seg_depth to give maximum height of banks for riparian overbank storage', & & 'none')/=0 ) CALL read_error(1, 'bank_height_fac') @@ -1343,6 +1343,7 @@ SUBROUTINE comp_bank_storage(Ihru) DOUBLE PRECISION :: head_step, head_step_grad, seep_sum, head_sum !*********************************************************************** area = Ripst_areafr_max(Ihru)*Hru_area(Ihru) !acres + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) area = area/2.0 !only take half of area if hru contains all of stream not just one side trans = Transmiss_seg(Hru_segment(Ihru)) !aquifer diffusivity, ratio of the transmissivity/storativity of the aquifer a = trans/Specyield_seg(Hru_segment(Ihru)) From 5763d41bfe6be219a45e2fabaa5e4c33d75c80e0 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Fri, 13 Sep 2019 11:13:07 -0600 Subject: [PATCH 38/47] Regan's version cut out glaciers so I put them back in --- prms/call_modules.f90 | 38 ++++++++++++++++++++++++++++++-------- 1 file changed, 30 insertions(+), 8 deletions(-) diff --git a/prms/call_modules.f90 b/prms/call_modules.f90 index 64b64bd7..2f4bb880 100644 --- a/prms/call_modules.f90 +++ b/prms/call_modules.f90 @@ -20,7 +20,7 @@ MODULE PRMS_MODULE INTEGER, SAVE :: Climate_temp_flag, Climate_precip_flag, Climate_potet_flag, Climate_transp_flag INTEGER, SAVE :: Lake_route_flag, Nratetbl, Strmflow_flag, Stream_order_flag INTEGER, SAVE :: Temp_flag, Precip_flag, Climate_hru_flag, Climate_swrad_flag - INTEGER, SAVE :: Precip_combined_flag, Temp_combined_flag + INTEGER, SAVE :: Precip_combined_flag, Temp_combined_flag, Muskingum_flag INTEGER, SAVE :: Inputerror_flag, Timestep INTEGER, SAVE :: Humidity_cbh_flag, Windspeed_cbh_flag INTEGER, SAVE :: Stream_temp_flag, Strmtemp_humidity_flag, PRMS4_flag @@ -48,6 +48,7 @@ MODULE PRMS_MODULE INTEGER, SAVE :: Dyn_snareathresh_flag, Dyn_transp_on_flag INTEGER, SAVE :: Dyn_sro2dprst_perv_flag, Dyn_sro2dprst_imperv_flag, Dyn_fallfrost_flag, Dyn_springfrost_flag INTEGER, SAVE :: Gwr_transferON_OFF, External_transferON_OFF, Segment_transferON_OFF, Lake_transferON_OFF + INTEGER, SAVE :: Frozen_flag, Glacier_flag END MODULE PRMS_MODULE !*********************************************************************** @@ -67,7 +68,7 @@ INTEGER FUNCTION call_modules(Arg) INTEGER, EXTERNAL :: ddsolrad, ccsolrad INTEGER, EXTERNAL :: potet_pan, potet_jh, potet_hamon, potet_hs, potet_pt, potet_pm INTEGER, EXTERNAL :: intcp, snowcomp, gwflow - INTEGER, EXTERNAL :: srunoff, soilzone + INTEGER, EXTERNAL :: srunoff, soilzone, mizuroute INTEGER, EXTERNAL :: strmflow, subbasin, basin_sum, map_results, write_climate_hru INTEGER, EXTERNAL :: strmflow_in_out, muskingum, muskingum_lake, numchars INTEGER, EXTERNAL :: water_use_read, dynamic_param_read, potet_pm_sta @@ -75,6 +76,7 @@ INTEGER FUNCTION call_modules(Arg) EXTERNAL :: module_error, print_module, PRMS_open_output_file EXTERNAL :: call_modules_restart, water_balance, basin_summary, nsegment_summary EXTERNAL :: prms_summary, nhru_summary, module_doc, convert_params, read_error, nsub_summary + INTEGER, EXTERNAL :: glacr ! Local Variables INTEGER :: i, iret, nc !*********************************************************************** @@ -92,7 +94,7 @@ INTEGER FUNCTION call_modules(Arg) Process_flag = 1 - PRMS_versn = 'call_modules.f90 2019-06-12:14:50Z' + PRMS_versn = 'call_modules.f90 2019-06-20 15:33:00Z' IF ( check_dims()/=0 ) STOP @@ -116,12 +118,12 @@ INTEGER FUNCTION call_modules(Arg) & ' Potential ET: potet_hamon, potet_jh, potet_pan, climate_hru,', /, & & ' potet_hs, potet_pt, potet_pm, potet_pm_sta', /, & & ' Interception: intcp', /, & - & ' Snow Dynamics: snowcomp', /, & + & 'Snow & Glacr Dynam: snowcomp, glacr', /, & & ' Surface Runoff: srunoff_smidx, srunoff_carea', /, & & ' Soil Zone: soilzone', /, & & ' Groundwater: gwflow', /, & & 'Streamflow Routing: strmflow, strmflow_in_out, muskingum,', /, & - & ' muskingum_lake', /, & + & ' muskingum_lake, muskingum_mann, mizuroute,', /, & & 'Stream Temperature: stream_temp', /, & & ' Output Summary: basin_sum, subbasin, map_results, prms_summary,', /, & & ' nhru_summary, nsub_summary, water_balance', /, & @@ -326,6 +328,11 @@ INTEGER FUNCTION call_modules(Arg) call_modules = snowcomp() IF ( call_modules/=0 ) CALL module_error('snowcomp', Arg, call_modules) + IF ( Glacier_flag==1 ) THEN + call_modules = glacr() + IF ( call_modules/=0 ) CALL module_error('glacr', Arg, call_modules) + ENDIF + call_modules = srunoff() IF ( call_modules/=0 ) CALL module_error(Srunoff_module, Arg, call_modules) @@ -342,10 +349,12 @@ INTEGER FUNCTION call_modules(Arg) IF ( Strmflow_flag==1 ) THEN call_modules = strmflow() - ELSEIF ( Strmflow_flag==4 ) THEN + ELSEIF ( Muskingum_flag==1 ) THEN ! muskingum = 4; muskingum_mann = 7 call_modules = muskingum() ELSEIF ( Strmflow_flag==5 ) THEN call_modules = strmflow_in_out() + ELSEIF ( Strmflow_flag==6 ) THEN + call_modules = mizuroute() ELSEIF ( Strmflow_flag==3 ) THEN call_modules = muskingum_lake() ENDIF @@ -674,6 +683,7 @@ INTEGER FUNCTION setdims() & Climate_swrad_flag==1 .OR. Climate_transp_flag==1 .OR. & & Humidity_cbh_flag==1 .OR. Windspeed_cbh_flag==1 ) Climate_hru_flag = 1 + Muskingum_flag = 0 IF ( Strmflow_module(:15)=='strmflow_in_out' ) THEN Strmflow_flag = 5 ELSEIF ( Strmflow_module(:14)=='muskingum_lake' ) THEN @@ -683,8 +693,14 @@ INTEGER FUNCTION setdims() Inputerror_flag = 1 ELSEIF ( Strmflow_module(:8)=='strmflow' ) THEN Strmflow_flag = 1 + ELSEIF ( Strmflow_module(:14)=='muskingum_mann' ) THEN + Strmflow_flag = 7 + Muskingum_flag = 1 ELSEIF ( Strmflow_module(:9)=='muskingum' ) THEN Strmflow_flag = 4 + Muskingum_flag = 1 + ELSEIF ( Strmflow_module(:9)=='mizuroute' ) THEN + Strmflow_flag = 6 ELSE PRINT '(/,2A)', 'ERROR, invalid strmflow_module value: ', Strmflow_module Inputerror_flag = 1 @@ -704,6 +720,7 @@ INTEGER FUNCTION setdims() IF ( decldim('nsub', 0, MAXDIM, 'Number of internal subbasins')/=0 ) CALL read_error(7, 'nsub') IF ( control_integer(Dprst_flag, 'dprst_flag')/=0 ) Dprst_flag = 0 + ! 0 = off, 1 = on, 2 = lauren version IF ( control_integer(CsvON_OFF, 'csvON_OFF')/=0 ) CsvON_OFF = 0 ! map results dimensions @@ -716,6 +733,8 @@ INTEGER FUNCTION setdims() IF ( decldim('ngwcell', 0, MAXDIM, & & 'Number of spatial units in the target map for mapped results')/=0 ) CALL read_error(7, 'ngwcell') + IF ( control_integer(Glacier_flag, 'glacier_flag')/=0 ) Glacier_flag = 0 + IF ( control_integer(Frozen_flag, 'frozen_flag')/=0 ) Frozen_flag = 0 IF ( control_integer(Dyn_imperv_flag, 'dyn_imperv_flag')/=0 ) Dyn_imperv_flag = 0 IF ( control_integer(Dyn_intcp_flag, 'dyn_intcp_flag')/=0 ) Dyn_intcp_flag = 0 IF ( control_integer(Dyn_covden_flag, 'dyn_covden_flag')/=0 ) Dyn_covden_flag = 0 @@ -935,7 +954,7 @@ INTEGER FUNCTION check_dims() Stream_order_flag = 0 IF ( Nsegment>0 .AND. Strmflow_flag>1 .AND. Model/=0 ) THEN - Stream_order_flag = 1 ! strmflow_in_out, muskingum, muskingum_lake + Stream_order_flag = 1 ! strmflow_in_out, muskingum, muskingum_lake, muskingum_mann, mizuroute ENDIF IF ( Nsegment<1 .AND. Model/=99 ) THEN @@ -1036,12 +1055,13 @@ SUBROUTINE module_doc() INTEGER, EXTERNAL :: precip_dist2, xyz_dist, ide_dist INTEGER, EXTERNAL :: ddsolrad, ccsolrad INTEGER, EXTERNAL :: potet_pan, potet_jh, potet_hamon, potet_hs, potet_pt, potet_pm - INTEGER, EXTERNAL :: intcp, snowcomp, gwflow, srunoff, soilzone + INTEGER, EXTERNAL :: intcp, snowcomp, gwflow, srunoff, soilzone, mizuroute INTEGER, EXTERNAL :: strmflow, subbasin, basin_sum, map_results, strmflow_in_out INTEGER, EXTERNAL :: write_climate_hru, muskingum, muskingum_lake INTEGER, EXTERNAL :: stream_temp EXTERNAL :: nhru_summary, prms_summary, water_balance, nsub_summary, basin_summary, nsegment_summary INTEGER, EXTERNAL :: dynamic_param_read, water_use_read, setup, potet_pm_sta + INTEGER, EXTERNAL :: glacr ! Local variable INTEGER :: test !********************************************************************** @@ -1077,12 +1097,14 @@ SUBROUTINE module_doc() test = intcp() test = snowcomp() test = srunoff() + test = glacr() test = soilzone() test = gwflow() test = routing() test = strmflow() test = strmflow_in_out() test = muskingum() + test = mizuroute() test = muskingum_lake() test = stream_temp() test = basin_sum() From d5131f8e9e33ef757967f21998280b4122d321f9 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Fri, 13 Sep 2019 19:38:45 -0600 Subject: [PATCH 39/47] Putting dunnian and hortonian flow in riparian areas and fixing some CFGI stuff. --- prmsRip/routingRip.f90 | 125 +++++++++++++++++++++++++++++++++------ prmsRip/srunoffCfgim.f90 | 14 +++-- 2 files changed, 116 insertions(+), 23 deletions(-) diff --git a/prmsRip/routingRip.f90 b/prmsRip/routingRip.f90 index 16d7c566..bf834e33 100644 --- a/prmsRip/routingRip.f90 +++ b/prmsRip/routingRip.f90 @@ -33,6 +33,7 @@ MODULE PRMS_ROUTING REAL, SAVE :: Bank_height_fac ! Declared Parameters for Overbank Storage REAL, SAVE, ALLOCATABLE :: Tr_ratio(:), Porosity_seg(:), Ripst_et_coef(:), Ripst_frac_init(:) + REAL, SAVE, ALLOCATABLE :: Sro_to_ripst_perv(:), Sro_to_ripst_imperv(:) ! Declared Variables for Overbank Storage DOUBLE PRECISION, SAVE :: Basin_ripst_evap, Basin_ripst_contrib, Basin_ripst_vol, Basin_ripst_area DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_stor_hru(:), Ripst_vol(:), Seg_ripflow(:) @@ -390,6 +391,21 @@ INTEGER FUNCTION routingdecl() & 'Factor multiplied to Seg_depth to give maximum height of banks for riparian overbank storage', & & 'none')/=0 ) CALL read_error(1, 'bank_height_fac') + ALLOCATE ( Sro_to_ripst_imperv(Nhru) ) + IF ( declparam(MODNAME, 'sro_to_ripst_imperv', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of impervious surface runoff that flows into riparian storage', & + & 'Fraction of impervious surface runoff that flows into riparian storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_ripst_imperv') + + ALLOCATE ( Sro_to_ripst_perv(Nhru) ) + IF ( declparam(MODNAME, 'sro_to_ripst_perv', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of pervious surface runoff that flows into riparian storage', & + & 'Fraction of pervious surface runoff that flows into riparian storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_ripst_perv') + + ALLOCATE ( Porosity_seg(Nsegment) ) IF ( declparam(MODNAME, 'porosity_seg', 'nsegment', 'real', & & '0.4', '0.15', '0.75', & @@ -712,6 +728,8 @@ INTEGER FUNCTION routinginit() IF ( getparam(MODNAME, 'transmiss_seg', Nsegment, 'real', Transmiss_seg)/=0 ) CALL read_error(2, 'transmiss_seg') IF ( getparam(MODNAME, 'specyield_seg', Nsegment, 'real', Specyield_seg)/=0 ) CALL read_error(2, 'specyield_seg') IF ( getparam(MODNAME, 'porosity_seg', Nsegment, 'real', Porosity_seg)/=0 ) CALL read_error(2, 'porosity_seg') + IF ( getparam(MODNAME, 'sro_to_ripst_imperv', Nhru, 'real', Sro_to_ripst_imperv)/=0 ) CALL read_error(2, 'sro_to_ripst_imperv') + IF ( getparam(MODNAME, 'sro_to_ripst_perv', Nhru, 'real', Sro_to_ripst_perv)/=0 ) CALL read_error(2, 'sro_to_ripst_perv') Seg_hru_num = 0 DO i = 1, Active_hrus IF ( Hru_segment(i)>0) THEN @@ -1141,17 +1159,18 @@ SUBROUTINE drain_the_swamp(Ihru) & Tr_ratio, Ripst_vol_max, Ripst_et_coef, Ripst_evap_hru, Seg_length, & & Basin_ripst_vol, Basin_ripst_evap, Basin_ripst_contrib, Ripst_stor_hru, & & Ripst_frac, Ripst_vol, Ripst_area_max, Ripst_area, Seg_slope, & - & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area, Bank_height_fac !, Transmiss_seg - USE PRMS_MODULE, ONLY: Frozen_flag + & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area, Bank_height_fac, & + & Ripst_areafr_max, Sro_to_ripst_imperv, Sro_to_ripst_perv !, Transmiss_seg + USE PRMS_MODULE, ONLY: Cascade_flag, Frozen_flag USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Hru_area, Hru_area_dble, FEET2METERS, & & FT2_PER_ACRE, CFS2CMS_CONV - USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_FLOWVARS, ONLY: Seg_outflow, Pkwater_equiv USE PRMS_CLIMATEVARS, ONLY: Potet USE PRMS_SET_TIME, ONLY: Timestep_seconds USE PRMS_SRUNOFF, ONLY: Hru_impervevap, Dprst_evap_hru, Frozen, Thaw_depth, Soil_depth, & - & Dprst_seep_rate_open - USE PRMS_INTCP, ONLY: Hru_intcpevap - USE PRMS_SNOW, ONLY: Snowcov_area, Snow_evap + & Dprst_seep_rate_open, Upslope_hortonian, Srp, Sri, Imperv_frac, Perv_frac + USE PRMS_INTCP, ONLY: Hru_intcpevap, Net_rain, Net_snow + USE PRMS_SNOW, ONLY: Snowmelt, Pptmix_nopack, Snowcov_area, Snow_evap IMPLICIT NONE ! Functions INTRINSIC EXP, LOG, MIN, DBLE, SNGL @@ -1159,7 +1178,7 @@ SUBROUTINE drain_the_swamp(Ihru) INTEGER, INTENT(IN) :: Ihru ! Local Variables REAL :: ripst_avail_et, unsatisfied_et, ripst_evap, ripst_wid, thaw_frac - REAL :: inflow, inflow_in, max_depth + REAL :: inflow, inflow_in, tmp, ripst_sri, ripst_srp, max_depth DOUBLE PRECISION :: seep, ripst_grnd, poss, seep_in, ripst_contrib_hru !*********************************************************************** thaw_frac = 1.0 @@ -1170,26 +1189,98 @@ SUBROUTINE drain_the_swamp(Ihru) thaw_frac = Thaw_depth(Ihru)/Soil_depth(Ihru) ENDIF ENDIF + +! add the hortonian flow to the riparian storage volumes: + IF ( Cascade_flag>0 ) THEN + inflow = SNGL( Upslope_hortonian(Ihru) ) + ELSE + inflow = 0.0 + ENDIF + inflow_in = 0.0 + + IF ( Pptmix_nopack(Ihru)==1 ) inflow = inflow + Net_rain(Ihru) + +!******If precipitation on snowpack all water available to the surface is considered to be snowmelt +!******If there is no snowpack and no precip,then check for melt from last of snowpack. +!******If rain/snow mix with no antecedent snowpack, compute snowmelt portion of runoff. + + IF ( Snowmelt(Ihru)>0.0 ) THEN + inflow = inflow + Snowmelt(Ihru) + +!******There was no snowmelt but a snowpack may exist. If there is +!******no snowpack then check for rain on a snowfree HRU. + ELSEIF ( Pkwater_equiv(Ihru)0.0 ) THEN + inflow = inflow + Net_rain(Ihru) + ENDIF + ENDIF + + ! add any pervious surface runoff fraction to riparian areas + ripst_srp = 0.0 + ripst_sri = 0.0 + IF ( Srp>0.0 ) THEN + tmp = Srp*Perv_frac*Sro_to_ripst_perv(Ihru)*Hru_area(Ihru) + ripst_srp = tmp*Ripst_areafr_max(Ihru) ! acre-inches + ENDIF + IF ( Sri>0.0 ) THEN + tmp = Sri*Imperv_frac*Sro_to_ripst_imperv(Ihru)*Hru_area(Ihru) + ripst_sri = tmp*Ripst_areafr_max(Ihru) ! acre-inches + ENDIF + !It won't get deeper than this depth, should be close to Seg_depth but not accurate or Seg_width and other terms not accurate max_depth = Seg_depth(Hru_segment(Ihru))*Bank_height_fac ! amount possible in cfs given a river depth poss = Seg_width(Hru_segment(Ihru))*SQRT(Seg_slope(Hru_segment(Ihru)))* & - & max_depth**(3./5.)/ ( CFS2CMS_CONV*Mann_n(Hru_segment(Ihru)) ) + & max_depth**(5./3.)/ ( CFS2CMS_CONV*Mann_n(Hru_segment(Ihru)) ) !inflow is water over bank, remove from Seg_outflow(Hru_segment(Ihru)) and give half to ! each side of bank, in acre inches - inflow = 0.0 - inflow_in = 0.0 + ! in cfs, amount over amount possible, no inflow if everything frozen, and then no outflow either + Ripst_vol(Ihru) = 0.0 + Ripst_frac(Ihru) =0.0 IF (thaw_frac>0.0) THEN - IF ( poss < Seg_outflow(Hru_segment(Ihru))) inflow = SNGL(Seg_outflow(Hru_segment(Ihru)) - poss) + IF ( poss < Seg_outflow(Hru_segment(Ihru))) inflow_in = SNGL(Seg_outflow(Hru_segment(Ihru)) - poss) ! give it equally to each HRU surrounding it - inflow = inflow/REAL(Seg_hru_num(Hru_segment(Ihru))) + inflow_in = inflow_in/REAL(Seg_hru_num(Hru_segment(Ihru))) !negative flow is out of stream into riparian - Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru)) - inflow - inflow_in = SNGL(inflow*Timestep_seconds/(FT2_PER_ACRE*12.0)) !inch acre - Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow_in - Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/(Ripst_vol_max(Ihru)*thaw_frac)) - IF (Ripst_frac(Ihru)>1.0) Ripst_frac(Ihru) = 1.0 +! add this in and add Hortonian and Dunnian flow +! + IF (Ripst_frac(Ihru)<1.0) THEN + Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru)) - inflow_in + inflow_in = SNGL(inflow*Timestep_seconds/(FT2_PER_ACRE*12.0)) !inch acre + Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow*Ripst_areafr_max(Ihru) + inflow_in + IF ( Ripst_vol(Ihru) > (Ripst_vol_max(Ihru)*thaw_frac) ) THEN + Ripst_vol(Ihru) = Ripst_vol_max(Ihru)*thaw_frac + ELSE + Ripst_vol(Ihru) = Ripst_vol(Ihru) + ripst_srp + ripst_sri + IF ( Ripst_vol(Ihru) > (Ripst_vol_max(Ihru)*thaw_frac) ) THEN + ripst_srp = SNGL((Ripst_vol(Ihru) - (Ripst_vol_max(Ihru)*thaw_frac))*ripst_srp/(ripst_srp + ripst_sri)) + ripst_sri = SNGL((Ripst_vol(Ihru) - (Ripst_vol_max(Ihru)*thaw_frac))*ripst_sri/(ripst_srp + ripst_sri)) + Ripst_vol(Ihru) = Ripst_vol_max(Ihru)*thaw_frac + ENDIF + IF ( Srp>0.0 ) THEN + Srp = Srp - ripst_srp/Perv_frac/Hru_area(Ihru) + IF ( Srp<0.0 ) THEN + IF ( Srp<-NEARZERO ) PRINT *, 'ripst srp<0.0', Srp, ripst_srp + ! may need to adjust ripst_srp and volumes + Srp = 0.0 + ENDIF + ENDIF + IF ( Sri>0.0 ) THEN + Sri = Sri - ripst_sri/Imperv_frac/Hru_area(Ihru) + IF ( Sri<0.0 ) THEN + IF ( Srp<-NEARZERO ) PRINT *, 'ripst sri<0.0', Sri, ripst_sri + ! may need to adjust ripst_sri and volumes + Sri = 0.0 + ENDIF + ENDIF + ENDIF + Ripst_frac(Ihru)= SNGL(Ripst_vol(Ihru)/(Ripst_vol_max(Ihru)*thaw_frac)) + ENDIF + ! Filled riparian storage surface area for each HRU: ! Fills outward from the river with one edge on river and with same depth and same side shape ! this works out to keeping fraction same for area and volume filled diff --git a/prmsRip/srunoffCfgim.f90 b/prmsRip/srunoffCfgim.f90 index 24815e85..88860725 100644 --- a/prmsRip/srunoffCfgim.f90 +++ b/prmsRip/srunoffCfgim.f90 @@ -1484,12 +1484,13 @@ SUBROUTINE dprst_comp(Dprst_vol_clos, Dprst_area_clos_max, Dprst_area_clos, & ENDIF Dprst_in = 0.0D0 + IF ( Dprst_area_open_max>0.0 ) THEN - Dprst_in = DBLE( inflow*Dprst_area_open_max*Thaw_frac ) ! inch-acres + Dprst_in = DBLE( inflow*Dprst_area_open_max ) ! inch-acres Dprst_vol_open = Dprst_vol_open + Dprst_in ENDIF IF ( Dprst_area_clos_max>0.0 ) THEN - tmp1 = DBLE( inflow*Dprst_area_clos_max*Thaw_frac ) ! inch-acres + tmp1 = DBLE( inflow*Dprst_area_clos_max ) ! inch-acres Dprst_vol_clos = Dprst_vol_clos + tmp1 Dprst_in = Dprst_in + tmp1 ENDIF @@ -1543,6 +1544,7 @@ SUBROUTINE dprst_comp(Dprst_vol_clos, Dprst_area_clos_max, Dprst_area_clos, & ! Open depression surface area for each HRU: Dprst_area_open = 0.0 IF ( Dprst_vol_open>0.0D0 ) THEN +! Thaw_frac reduces the volume the new water can add to, so the new water will spill open_vol_r = SNGL( Dprst_vol_open/(Dprst_vol_open_max*Thaw_frac) ) IF ( open_vol_rDprst_area_open_max*Thaw_frac ) Dprst_area_open = Dprst_area_open_max*Thaw_frac + Dprst_area_open = Dprst_area_open_max*frac_op_ar + IF ( Dprst_area_open>Dprst_area_open_max ) Dprst_area_open = Dprst_area_open_max ! IF ( Dprst_area_openDprst_area_clos_max*Thaw_frac ) Dprst_area_clos = Dprst_area_clos_max*Thaw_frac + Dprst_area_clos = Dprst_area_clos_max*frac_cl_ar + IF ( Dprst_area_clos>Dprst_area_clos_max) Dprst_area_clos = Dprst_area_clos_max ! IF ( Dprst_area_clos Date: Fri, 13 Sep 2019 19:58:40 -0600 Subject: [PATCH 40/47] Seg_slope and seg_length were in stream temp and in routing. moved to routing --- prms/stream_temp.f90 | 140 +++++++++++++++++-------------------------- 1 file changed, 56 insertions(+), 84 deletions(-) diff --git a/prms/stream_temp.f90 b/prms/stream_temp.f90 index 7022c668..a62e6a68 100644 --- a/prms/stream_temp.f90 +++ b/prms/stream_temp.f90 @@ -30,8 +30,7 @@ MODULE PRMS_STRMTEMP REAL, SAVE, ALLOCATABLE :: Seg_tave_air(:), Seg_melt(:), Seg_rain(:) DOUBLE PRECISION, ALLOCATABLE :: Seg_potet(:) ! Segment Parameters - REAL, SAVE, ALLOCATABLE :: Seg_length(:) !, Mann_n(:) - REAL, SAVE, ALLOCATABLE :: Seg_slope(:), Width_values(:, :) + REAL, SAVE, ALLOCATABLE :: Width_values(:, :) REAL, SAVE, ALLOCATABLE :: width_alpha(:), width_m(:) INTEGER, SAVE:: Width_dim, Maxiter_sntemp REAL, SAVE, ALLOCATABLE :: Seg_humidity(:, :) @@ -151,7 +150,7 @@ INTEGER FUNCTION stream_temp_decl() IF ( declvar( MODNAME, 'seg_ccov', 'nsegment', Nsegment, 'real', & & 'Area-weighted average cloud cover fraction for each segment from HRUs contributing flow to the segment', & & 'decimal fraction', Seg_ccov )/=0 ) CALL read_error(3, 'seg_ccov') - + ALLOCATE(Seg_shade(Nsegment)) IF (declvar(MODNAME, 'seg_shade', 'nsegment', Nsegment, 'real', & & 'Area-weighted average shade fraction for each segment', & @@ -161,27 +160,27 @@ INTEGER FUNCTION stream_temp_decl() IF ( declvar( MODNAME, 'seg_daylight', 'nsegment', Nsegment, 'real', & & 'Hours of daylight', & & 'hours', Seg_daylight)/=0 ) CALL read_error(3,'seg_daylight') - + ALLOCATE(seg_tave_gw(Nsegment)) IF ( declvar( MODNAME, 'seg_tave_gw', 'nsegment', Nsegment, 'real', & & 'groundwater temperature', & & 'degrees Celsius', seg_tave_gw)/=0 ) CALL read_error(3,'seg_tave_gw') - + ALLOCATE(seg_tave_ss(Nsegment)) IF ( declvar( MODNAME, 'seg_tave_ss', 'nsegment', Nsegment, 'real', & & 'subsurface temperature', & & 'degrees Celsius', seg_tave_ss)/=0 ) CALL read_error(3,'seg_tave_ss') - + ALLOCATE(seg_tave_sroff(Nsegment)) IF ( declvar( MODNAME, 'seg_tave_sroff', 'nsegment', Nsegment, 'real', & & 'surface runoff temperature', & & 'degrees Celsius', seg_tave_sroff)/=0 ) CALL read_error(3,'seg_tave_sroff') - + ALLOCATE(seg_tave_lat(Nsegment)) IF ( declvar( MODNAME, 'seg_tave_lat', 'nsegment', Nsegment, 'real', & & 'lateral flow temperature', & & 'degrees Celsius', seg_tave_lat)/=0 ) CALL read_error(3,'seg_tave_lat') - + ALLOCATE (Press(Nsegment) ) ALLOCATE ( Seg_hru_count(Nsegment) ) ALLOCATE (Seg_carea_inv(Nsegment) ) @@ -195,7 +194,7 @@ INTEGER FUNCTION stream_temp_decl() & 'Short-wave solar radiation reflected by streams', & & 'Short-wave solar radiation reflected by streams', & & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo') - + ALLOCATE(lat_temp_adj(Nsegment,12)) IF ( declparam( MODNAME, 'lat_temp_adj', 'nsegment,nmonths', 'real', & & '0.0', '-5.0', '5.0', & @@ -203,27 +202,13 @@ INTEGER FUNCTION stream_temp_decl() & 'Correction factor to adjust the bias of the temperature of the lateral inflow', & & 'decimal fraction')/=0 ) CALL read_error(1, 'lat_temp_adj') - ALLOCATE ( Seg_length(Nsegment) ) - IF ( declparam( MODNAME, 'seg_length', 'nsegment', 'real', & - & '1000.0', '1.0', '100000.0', & - & 'Length of each segment', & - & 'Length of each segment', & - & 'meters')/=0 ) CALL read_error(1, 'seg_length') - - ALLOCATE ( Seg_slope(Nsegment) ) - IF ( declparam( MODNAME, 'seg_slope', 'nsegment', 'real', & - & '0.015', '0.0001', '2.0', & - & 'Bed slope of each segment', & - & 'Bed slope of each segment', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'seg_slope') - ALLOCATE (width_alpha(Nsegment) ) IF ( declparam( MODNAME, 'width_alpha', 'nsegment', 'real', & & '0.015', '0.0001', '2.0', & & 'Alpha coefficient in power function for width calculation', & & 'Alpha coefficient in power function for width calculation', & & 'unknown')/=0 ) CALL read_error(1, 'width_alpha') - + ALLOCATE (width_m(Nsegment) ) IF ( declparam( MODNAME, 'width_m', 'nsegment', 'real', & & '0.015', '0.0001', '2.0', & @@ -264,14 +249,14 @@ INTEGER FUNCTION stream_temp_decl() IF ( declparam( MODNAME, 'vdemx', 'nsegment', 'real', & & '0.0', '0.0', '1.0', & & 'Maximum east bank vegetation density', & - & 'Maximum east bank vegetation density for each segment', & + & 'Maximum east bank vegetation density for each segment', & & 'decimal fraction')/=0 ) CALL read_error(1, 'vdemx') ALLOCATE ( Vdemn(Nsegment) ) IF ( declparam( MODNAME, 'vdemn', 'nsegment', 'real', & & '0.0', '0.0', '1.0', & & 'Minimum east bank vegetation density', & - & 'Minimum east bank vegetation density for each segment', & + & 'Minimum east bank vegetation density for each segment', & & 'decimal fraction')/=0 ) CALL read_error(1, 'vdemn') ALLOCATE ( Vhe(Nsegment) ) @@ -353,7 +338,7 @@ INTEGER FUNCTION stream_temp_decl() & 'Average residence time in groundwater flow', & & 'Average residence time in groundwater flow', & & 'days')/=0 ) CALL read_error(1, 'gw_tau') - + IF ( declparam( MODNAME, 'melt_temp', 'one', 'real', & & '1.5', '0.0', '10.0', & & 'Temperature at which snowmelt enters a stream', & @@ -420,7 +405,6 @@ INTEGER FUNCTION stream_temp_init() IF ( getparam( MODNAME, 'albedo', 1, 'real', Albedo)/=0 ) CALL read_error(2, 'albedo') IF ( getparam( MODNAME, 'lat_temp_adj', Nsegment*12, 'real', lat_temp_adj)/=0 ) CALL read_error(2, 'lat_temp_adj') - IF ( getparam( MODNAME, 'seg_length', Nsegment, 'real', Seg_length)/=0 ) CALL read_error(2, 'seg_length') IF (getparam(MODNAME, 'seg_lat', Nsegment, 'real', Seg_lat)/=0 ) CALL read_error(2, 'seg_lat') ! Convert latitude from degrees to radians @@ -428,10 +412,6 @@ INTEGER FUNCTION stream_temp_init() IF (getparam(MODNAME, 'seg_elev', Nsegment, 'real', Seg_elev)/=0 ) CALL read_error(2, 'seg_elev') -! convert stream length in meters to km - Seg_length = Seg_length / 1000.0 - - IF ( getparam( MODNAME, 'seg_slope', Nsegment, 'real', Seg_slope)/=0 ) CALL read_error(2, 'seg_slope') IF ( getparam( MODNAME, 'width_alpha', Nsegment, 'real', width_alpha)/=0 ) CALL read_error(2, 'width_alpha') IF ( getparam( MODNAME, 'width_m', Nsegment, 'real', width_m)/=0 ) CALL read_error(2, 'width_m') @@ -453,7 +433,7 @@ INTEGER FUNCTION stream_temp_init() IF ( getparam( MODNAME, 'segshade_sum', Nsegment, 'real', Segshade_sum)/=0 ) CALL read_error(2, 'segshade_sum') IF ( getparam( MODNAME, 'segshade_win', Nsegment, 'real', Segshade_win)/=0 ) CALL read_error(2, 'segshade_win') ENDIF - + IF ( getparam( MODNAME, 'ss_tau', Nsegment, 'integer', Ss_tau)/=0 ) CALL read_error(2, 'ss_tau') IF ( getparam( MODNAME, 'gw_tau', Nsegment, 'integer', Gw_tau)/=0 ) CALL read_error(2, 'Gw_tau') IF ( getparam( MODNAME, 'melt_temp', 1, 'real', Melt_temp)/=0 ) CALL read_error(2, 'melt_temp') @@ -515,14 +495,6 @@ INTEGER FUNCTION stream_temp_init() Seg_hru_count(i) = Seg_hru_count(i) + 1 ENDDO -! find segments that are too short and print them out as they are found - DO i = 1, Nsegment - IF ( Seg_length(i)0 ) THEN ! assign downstream values Seg_close(i) = Tosegment(i) ! don't have a value yet, need to fix ELSE ! no upstream or downstream segment @@ -576,7 +548,7 @@ INTEGER FUNCTION stream_temp_init() Press(i) = 1013.0 - (0.1055 * Seg_elev(i)) IF ( Stream_temp_shade_flag==0 ) THEN -! LATITUDE TRIGONOMETRIC PARAMETERS +! LATITUDE TRIGONOMETRIC PARAMETERS Cos_seg_lat(i) = COS(Seg_lat(i)) ! coso IF ( Cos_seg_lat(i) < NEARZERO ) Cos_Seg_lat(i) = NEARZERO Sin_seg_lat(i) = SIN(Seg_lat(i)) ! sino @@ -633,7 +605,7 @@ INTEGER FUNCTION stream_temp_init() ENDDO ! There may be headwater segments that do not have any HRUs and do not have any upstream segments to produce -! streamflow. These segments will never have any streamflow, and consequently never be able to simulate +! streamflow. These segments will never have any streamflow, and consequently never be able to simulate ! stream temperature. This block finds these and sets the stream temperature value to -99.9. Subsequent code ! should be able to check if the temperature value is less than -99.0 and know that it doesn't need to do ! any stream temperature calculation because there will never be any water in the segment. @@ -696,7 +668,7 @@ INTEGER FUNCTION stream_temp_init() ! end do ! write(*, fmt="(1x,a)",advance="yes") " done" ! end do - + END FUNCTION stream_temp_init @@ -714,7 +686,7 @@ INTEGER FUNCTION stream_temp_run() USE PRMS_CLIMATE_HRU, ONLY: Humidity_hru USE PRMS_FLOWVARS, ONLY: Seg_outflow USE PRMS_SNOW, ONLY: Snowmelt - USE PRMS_ROUTING, ONLY: Hru_segment, Segment_order, Seginc_swrad + USE PRMS_ROUTING, ONLY: Hru_segment, Segment_order, Seginc_swrad, Seg_length USE PRMS_OBS, ONLY: Humidity USE PRMS_SET_TIME, ONLY: Nowyear, Nowmonth, Nowday, Jday USE PRMS_SOLTAB, ONLY: Soltab_potsw, Hru_cossl @@ -733,7 +705,7 @@ INTEGER FUNCTION stream_temp_run() !*********************************************************************** stream_temp_run = 0 Seg_tave_air = 0.0 - + ! Humidity info come from parameter file when Strmtemp_humidity_flag==1 ! Otherwise it comes as daily values per HRU from CBH. Code for this is ! down in the HRU loop. @@ -748,7 +720,7 @@ INTEGER FUNCTION stream_temp_run() ELSE Seg_humid = 0.0 ENDIF - + Seg_potet = 0.0D0 Seg_ccov = 0.0 Seg_melt = 0.0 @@ -782,7 +754,7 @@ INTEGER FUNCTION stream_temp_run() Seg_ccov(i) = Seg_ccov(i) + ccov*harea Seg_potet(i) = Seg_potet(i) + DBLE( Potet(j)*harea ) Seg_melt(i) = Seg_melt(i) + Snowmelt(j)*harea - Seg_rain(i) = Seg_rain(i) + Hru_rain(j)*harea + Seg_rain(i) = Seg_rain(i) + Hru_rain(j)*harea ENDDO @@ -863,7 +835,7 @@ INTEGER FUNCTION stream_temp_run() cycle endif -! GW moving average +! GW moving average gw_sum(i) = gw_sum(i) - gw_silo(i, gw_index) gw_silo(i, gw_index) = Seg_tave_air(i) gw_sum(i) = gw_sum(i) + gw_silo(i, gw_index) @@ -906,13 +878,13 @@ INTEGER FUNCTION stream_temp_run() if (seg_outflow(i) > NEARZERO) then Seg_width(i) = width_alpha(i) * sngl(Seg_outflow(i)) ** width_m(i) else - Seg_width(i) = 0.0 + Seg_width(i) = 0.0 if (Seg_tave_water(i) > -99.0) then ! This segment has upstream HRUs somewhere, but the current day's flow is zero Seg_tave_water(i) = -98.9 endif endif - + ! Compute the shade on the segment. Either set by value in the parameter file or computed IF ( Stream_temp_shade_flag==1 ) THEN IF ( Summer_flag==0 ) THEN @@ -920,19 +892,19 @@ INTEGER FUNCTION stream_temp_run() ELSE seg_shade(i) = Segshade_sum(i) ENDIF - + ! Svi = RIPARIAN VEGETATION SHADE svi = 0.0 ELSE CALL shday(i, seg_shade(i), svi) ENDIF - + ! Start working towards the computation of the equilibrium temperature qlat = 0.0D0 seg_tave_lat(i) = 0.0 - ak1 = 0.0 + ak1 = 0.0 ak2 = 0.0 - + ! Inputs: seg_tave_gw, Seg_tave_air, seg_tave_ss, seg_tave_upstream, Seg_melt, Seg_rain ! Outputs: qlat (in CMS), seg_tave_lat CALL lat_inflow(qlat, seg_tave_lat(i), i, seg_tave_gw(i), Seg_tave_air(i), seg_tave_ss(i), & @@ -949,7 +921,7 @@ INTEGER FUNCTION stream_temp_run() ! Compute t_o ! t_o is the temperature of the water at the beginning of the time step (this is To in equation 32) - if (Seg_tave_water(i) < -99.0) then + if (Seg_tave_water(i) < -99.0) then ! No flow in this segment and there never will be becuase there are no upstream HRUs. t_o = Seg_tave_water(i) @@ -972,18 +944,18 @@ INTEGER FUNCTION stream_temp_run() ! if this is true, then there is no lateral flow, but there is flow from upstream t_o = seg_tave_upstream(i) - else + else ! if this is true, then there is both lateral flow and flow from upstream ! qlat is in CMS so fs needs to be converted t_o = sngl((seg_tave_upstream(i) * fs * CFS2CMS_CONV) + & & (sngl(qlat) * (seg_tave_lat(i) + lat_temp_adj(i,Nowmonth)))) / & & sngl((fs * CFS2CMS_CONV) + sngl(qlat)) - endif + endif ! debug if (t_o .ne. t_o) then write(*,*) "t_o is Nan, seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & - & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) + & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) continue endif @@ -991,12 +963,12 @@ INTEGER FUNCTION stream_temp_run() if (t_o .gt. 100.0) then write(*,*) "this is the place: t_o = ", t_o, " ted = ", te, " seg_id = ", i write(*,*) " seg_tave_upstream = ", seg_tave_upstream(i), " fs = ", fs, & - & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) + & " qlat = ", qlat, " seg_tave_lat = ", seg_tave_lat(i), " lat_temp_adj = ", lat_temp_adj(i,Nowmonth) write(*,*) " width = ", Seg_width(i), Nowyear, Nowmonth, Nowday continue exit endif - + ! Need a good value of t_o if (t_o .gt. -98.0) then ! This block computes the value for seg_tave_water @@ -1008,8 +980,8 @@ INTEGER FUNCTION stream_temp_run() ! Compute the daily mean water temperature ! In: t_o, qlat, seg_tave_lat(i), te, ak1, ak2, i, seg_width, seg_length - Seg_tave_water(i) = twavg(fs, t_o, qlat, seg_tave_lat(i), te, ak1, ak2, seg_width(i), seg_length(i)) - + Seg_tave_water(i) = twavg(fs, t_o, qlat, seg_tave_lat(i), te, ak1, ak2, seg_width(i), seg_length(i)/1000.0) + else ! bad t_o value Seg_tave_water(i) = -98.9 @@ -1050,7 +1022,7 @@ SUBROUTINE lat_inflow(Qlat, Tl_avg, id, tave_gw, tave_air, tave_ss, melt, rain) weight_ss = 0.0 weight_gw = 0.0 ENDIF - + IF (melt > 0.0) THEN melt_wt = melt/(melt + rain) IF (melt_wt < 0.0) melt_wt = 0.0 @@ -1067,7 +1039,7 @@ SUBROUTINE lat_inflow(Qlat, Tl_avg, id, tave_gw, tave_air, tave_ss, melt, rain) troff = tave_air tss = tave_ss ENDIF - + Tl_avg = weight_roff * troff + weight_ss * tss + weight_gw * tave_gw END SUBROUTINE lat_inflow @@ -1093,7 +1065,7 @@ REAL FUNCTION twavg(qup, T0, Qlat, Tl_avg, Te, Ak1, Ak2, width, length) Ql = SNGL( Qlat ) ! This is confused logic coment out here and compute the terms as needed below -! b = (Ql / Seg_length) + ((Ak1 * Seg_width) / 4182.0E03) +! b = (Ql / Seg_length/1000.0) + ((Ak1 * Seg_width) / 4182.0E03) ! IF ( b < NEARZERO ) b = NEARZERO ! rsr, don't know what value this should be to avoid divide by 0 ! r = 1.0 + (Ql / q_init) ! IF ( r < NEARZERO ) r = NEARZERO @@ -1136,7 +1108,7 @@ REAL FUNCTION twavg(qup, T0, Qlat, Tl_avg, Te, Ak1, Ak2, width, length) ELSE rexp = 0.0 ENDIF - + ! DANGER -- replaced this potential divide by zero with the logic below ! r = 1.0 + (Ql / q_init) if (q_init < NEARZERO) then @@ -1169,10 +1141,10 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) ! 2. DETERMINE THE MAXIMUM DAILY EQUILIBRIUM WATER TEMPERATURE PARAMETERS USE PRMS_STRMTEMP, ONLY: ZERO_C, Seg_width, Seg_humid, Press, MPS_CONVERT, & - & Seg_ccov, Seg_slope, Seg_potet, Albedo, seg_tave_gw + & Seg_ccov, Seg_potet, Albedo, seg_tave_gw USE PRMS_BASIN, ONLY: NEARZERO, CFS2CMS_CONV USE PRMS_FLOWVARS, ONLY: Seg_inflow - USE PRMS_ROUTING, ONLY: Seginc_swrad + USE PRMS_ROUTING, ONLY: Seg_slope, Seginc_swrad IMPLICIT NONE ! Functions INTRINSIC EXP, SQRT, ABS, SNGL, DBLE @@ -1195,11 +1167,11 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) taabs = DBLE( t_o + ZERO_C ) vp_sat = 6.108 * EXP(17.26939 * t_o/(t_o + 237.3)) -! +! ! Convert units and set up parameters q_init = SNGL( Seg_inflow(Seg_id) * CFS2CMS_CONV ) IF ( q_init < NEARZERO ) q_init = NEARZERO - + ! sw_power should be in watts / m2 ! seginc_swrad is in langly / day ! Used to use RAD_CONVERT, the conversion I'm using now is a slightly different number. @@ -1207,14 +1179,14 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) del_ht = 2.36E06 ! could multiple by 10E6 for this and other terms later to reduce round-off ltnt_ht = 2495.0E06 - + ! If humidity is 1.0, there is a divide by zero below. if (Seg_humid(Seg_id) > 0.99) then foo = 0.99 else foo = Seg_humid(Seg_id) endif - + bow_coeff = (0.00061 * Press(Seg_id))/(vp_sat * (1.0 - foo)) evap = SNGL( Seg_potet(Seg_id) * MPS_CONVERT ) ! @@ -1243,7 +1215,7 @@ SUBROUTINE equilb (Ted, Ak1d, Ak2d, Sh, Svi, Seg_id, t_o) Ted = t_o CALL teak1(A, b, c, d, Ted, Ak1d) - + ! ! DETERMINE 2ND ORDER THERMAL EXCHANGE COEFFICIENT hnet = (A * ((t_o + ZERO_C)**4)) + (b * t_o) - (c * (t_o**2.0)) - d @@ -1262,7 +1234,7 @@ END SUBROUTINE equilb ! "teak1" !********************************************************************************** SUBROUTINE teak1(A, B, C, D, Teq, Ak1c) -! PURPOSE: +! PURPOSE: ! 1. TO DETERMINE THE EQUILIBRIUM WATER TEMPERATURE FROM THE ENERGY BALANCE ! EQUATION BY ITERATING NEWTON'S METHOD ! 2. TO DETERMINE THE 1ST THERMAL EXCHANGE COEFFICIENT. @@ -1296,7 +1268,7 @@ SUBROUTINE teak1(A, B, C, D, Teq, Ak1c) delte = fte / fpte Teq = Teq - delte ENDDO - + ! DETERMINE 1ST THERMAL EXCHANGE COEFFICIENT Ak1c = (4.0 * A * ((Teq + ZERO_C)**3.0)) + B - (2.0 * C * Teq) ! @@ -1404,7 +1376,7 @@ SUBROUTINE shday(Seg_id, Shade, Svi) REAL, PARAMETER :: RADTOHOUR = 24.0/(2.0 * PI) !********************************************************************************* -! LATITUDE TRIGONOMETRIC PARAMETERS +! LATITUDE TRIGONOMETRIC PARAMETERS coso = Cos_seg_lat(Seg_id) sino = Sin_seg_lat(Seg_id) sin_d = Sin_declination(Jday, Seg_id) @@ -1457,7 +1429,7 @@ SUBROUTINE shday(Seg_id, Shade, Svi) ELSE ! INITIALIZE SHADE VALUES -! +! ! INSERT STARTING TOPOGRAPHIC AZIMUTH VALUES BETWEEN LEVEL PLAIN SUNRISE AND SUNSET aztop = 0.0 ! @@ -1531,10 +1503,10 @@ SUBROUTINE shday(Seg_id, Shade, Svi) sti = 1.0 - ((((hrss - hrsr) * sinod) + ((SIN(hrss) - SIN(hrsr)) * cosod)) / (totsh)) Svi = ((rprnvg(hrsr, hrrh, hrss, sino, coso, sin_d, cosod, sinod, Seg_id)) / (Seg_width(Seg_id)*totsh)) ! -! END SUNRISE/SUNSET CALCULATION +! END SUNRISE/SUNSET CALCULATION ENDIF ! -! CHECK FOR ROUNDOFF ERRORS +! CHECK FOR ROUNDOFF ERRORS IF ( sti < 0.0 ) sti = 0.0 IF ( sti > 1.0 ) sti = 1.0 IF ( Svi < 0.0 ) Svi = 0.0 @@ -1619,7 +1591,7 @@ SUBROUTINE snr_sst (Coso, Sino, Sin_d, Alt, Almn, Almx, Azmn, Azmx, Azs, Als, Hr IF ( Als < (Almn + NEARZERO) ) Als = (Almn + NEARZERO) IF ( Als > (Almx - NEARZERO) ) Als = (Almx - NEARZERO) ENDDO -! +! ! ENSURE AZIMUTH REMAINS BETWEEN -PI & PI IF ( Azs < (-PI) ) THEN Azs = Azs + PI @@ -1701,7 +1673,7 @@ REAL FUNCTION solalt (Coso, Sino, Sin_d, Az, Almn, Almx) fppal = b - fal delal = (2.0 * fal * fpal) / ((2.0 * fpal * fpal) - (fal * fppal)) ENDIF - al = al - delal + al = al - delal IF (al < Almn) al = (alold + Almn) / 2.0 IF (al > Almx) al = (alold + Almx) / 2.0 ENDDO @@ -1778,7 +1750,7 @@ REAL FUNCTION rprnvg (Hrsr, Hrrs, Hrss, Sino, Coso, Sin_d, Cosod, Sinod, Seg_id) azs = ACOS(temp) IF ( azs < 0.0 ) azs = HALF_PI - azs IF ( hrs < 0.0 ) azs = -azs -! DETERMINE AMOUNT OF STREAM WIDTH SHADED +! DETERMINE AMOUNT OF STREAM WIDTH SHADED bs = ((Vhe(Seg_id) * (cosals/sinals)) * ABS(SIN(azs-Azrh(Seg_id)))) + vco IF ( bs < 0.0 ) bs = 0.0 IF ( bs > Seg_width(Seg_id) ) bs = Seg_width(Seg_id) From bbd92da3acdc78cce0059381950164e122f5f853 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Fri, 13 Sep 2019 21:45:04 -0600 Subject: [PATCH 41/47] using depression parameters for some of the riparian --- prmsRip/routingRip.f90 | 62 +++++++++++++----------------- prmsRip/srunoffCfgim.f90 | 83 ++++++++++++++++++++++------------------ 2 files changed, 72 insertions(+), 73 deletions(-) diff --git a/prmsRip/routingRip.f90 b/prmsRip/routingRip.f90 index bf834e33..68c3060b 100644 --- a/prmsRip/routingRip.f90 +++ b/prmsRip/routingRip.f90 @@ -32,8 +32,7 @@ MODULE PRMS_ROUTING REAL, SAVE, ALLOCATABLE :: Transmiss_seg(:), Ripst_areafr_max(:) REAL, SAVE :: Bank_height_fac ! Declared Parameters for Overbank Storage - REAL, SAVE, ALLOCATABLE :: Tr_ratio(:), Porosity_seg(:), Ripst_et_coef(:), Ripst_frac_init(:) - REAL, SAVE, ALLOCATABLE :: Sro_to_ripst_perv(:), Sro_to_ripst_imperv(:) + REAL, SAVE, ALLOCATABLE :: Tr_ratio(:), Porosity_seg(:), Ripst_frac_init(:) ! Declared Variables for Overbank Storage DOUBLE PRECISION, SAVE :: Basin_ripst_evap, Basin_ripst_contrib, Basin_ripst_vol, Basin_ripst_area DOUBLE PRECISION, SAVE, ALLOCATABLE :: Ripst_stor_hru(:), Ripst_vol(:), Seg_ripflow(:) @@ -391,21 +390,6 @@ INTEGER FUNCTION routingdecl() & 'Factor multiplied to Seg_depth to give maximum height of banks for riparian overbank storage', & & 'none')/=0 ) CALL read_error(1, 'bank_height_fac') - ALLOCATE ( Sro_to_ripst_imperv(Nhru) ) - IF ( declparam(MODNAME, 'sro_to_ripst_imperv', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Fraction of impervious surface runoff that flows into riparian storage', & - & 'Fraction of impervious surface runoff that flows into riparian storage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_ripst_imperv') - - ALLOCATE ( Sro_to_ripst_perv(Nhru) ) - IF ( declparam(MODNAME, 'sro_to_ripst_perv', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Fraction of pervious surface runoff that flows into riparian storage', & - & 'Fraction of pervious surface runoff that flows into riparian storage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_ripst_perv') - - ALLOCATE ( Porosity_seg(Nsegment) ) IF ( declparam(MODNAME, 'porosity_seg', 'nsegment', 'real', & & '0.4', '0.15', '0.75', & @@ -413,13 +397,6 @@ INTEGER FUNCTION routingdecl() & 'Porosity of soil around segment involved in riparian overbank flow storage', & & 'decimal fraction')/=0 ) CALL read_error(1, 'porosity_seg') - ALLOCATE ( Ripst_et_coef(Nhru) ) - IF ( declparam(MODNAME, 'ripst_et_coef', 'nhru', 'real', & - & '1.0', '0.0', '1.0', & - & 'Fraction of unsatisfied potential evapotranspiration to apply to riparian overbank flow storage', & - & 'Fraction of unsatisfied potential evapotranspiration to apply to riparian overbank flow storage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'ripst_et_coef') - ALLOCATE ( Tr_ratio(Nhru) ) IF ( declparam(MODNAME, 'tr_ratio', 'nhru', 'real', & & '0.5', '0.0', '1.0', & @@ -558,11 +535,12 @@ INTEGER FUNCTION routinginit() USE PRMS_ROUTING USE PRMS_MODULE, ONLY: Nsegment, Nhru, Init_vars_from_file, Strmflow_flag, & & Water_use_flag, Segment_transferON_OFF, Inputerror_flag, Parameter_check_flag , & - & Ripst_flag, Stream_temp_flag !, Print_debug + & Ripst_flag, Stream_temp_flag, PRMS4_flag, Dprst_flag !, Print_debug USE PRMS_SET_TIME, ONLY: Timestep_seconds USE PRMS_BASIN, ONLY: FT2_PER_ACRE, DNEARZERO, Active_hrus, Hru_route_order, Hru_area_dble, NEARZERO, & - & Hru_area, FEET2METERS, CFS2CMS_CONV !, Active_area + & Hru_area, FEET2METERS, CFS2CMS_CONV, Dprst_open_flag !, Active_area USE PRMS_FLOWVARS, ONLY: Seg_outflow + USE PRMS_SRUNOFF, ONLY: Dprst_seep_rate_open, Sro_to_dprst_imperv, Sro_to_dprst_perv, Dprst_et_coef IMPLICIT NONE ! Functions INTRINSIC MOD, DBLE @@ -721,15 +699,26 @@ INTEGER FUNCTION routinginit() IF ( Ripst_flag==1 ) THEN IF ( getparam(MODNAME, 'ripst_areafr_max', Nhru, 'real', Ripst_areafr_max)/=0 ) CALL read_error(2, 'ripst_areafr_max') IF ( getparam(MODNAME, 'bank_height_fac', 1, 'real', Bank_height_fac)/=0 ) CALL read_error(2, 'bank_height_fac') - IF ( getparam(MODNAME, 'ripst_et_coef', Nhru, 'real', Ripst_et_coef)/=0 ) CALL read_error(2, 'ripst_et_coef') IF ( getparam(MODNAME, 'tr_ratio', Nhru, 'real', Tr_ratio)/=0 ) CALL read_error(2, 'tr_ratio') IF ( getparam(MODNAME, 'bankfinite_hru', Nhru, 'integer', Bankfinite_hru)/=0 ) CALL read_error(2, 'bankfinite_hru') ! might be able to calculate if want bankfinite_hru = 1 or 0 based on ripst_areafr_max and transmiss_seg IF ( getparam(MODNAME, 'transmiss_seg', Nsegment, 'real', Transmiss_seg)/=0 ) CALL read_error(2, 'transmiss_seg') IF ( getparam(MODNAME, 'specyield_seg', Nsegment, 'real', Specyield_seg)/=0 ) CALL read_error(2, 'specyield_seg') IF ( getparam(MODNAME, 'porosity_seg', Nsegment, 'real', Porosity_seg)/=0 ) CALL read_error(2, 'porosity_seg') - IF ( getparam(MODNAME, 'sro_to_ripst_imperv', Nhru, 'real', Sro_to_ripst_imperv)/=0 ) CALL read_error(2, 'sro_to_ripst_imperv') - IF ( getparam(MODNAME, 'sro_to_ripst_perv', Nhru, 'real', Sro_to_ripst_perv)/=0 ) CALL read_error(2, 'sro_to_ripst_perv') + + IF (Dprst_flag/=1) THEN !didn't call these already then + IF ( PRMS4_flag==1 ) THEN + IF ( getparam(MODNAME, 'sro_to_dprst', Nhru, 'real', Sro_to_dprst_perv)/=0 ) CALL read_error(2, 'sro_to_dprst') + ELSE + IF ( getparam(MODNAME, 'sro_to_dprst_perv', Nhru, 'real', Sro_to_dprst_perv)/=0 ) CALL read_error(2, 'sro_to_dprst_perv') + ENDIF + IF ( getparam(MODNAME, 'sro_to_dprst_imperv', Nhru, 'real', Sro_to_dprst_imperv)/=0 ) CALL read_error(2, 'sro_to_dprst_imperv') + IF ( getparam(MODNAME, 'dprst_et_coef', Nhru, 'real', Dprst_et_coef)/=0 ) CALL read_error(2, 'dprst_et_coef') + ENDIF + IF (Dprst_open_flag/=1 .OR. Dprst_flag/=1) THEN + IF ( getparam(MODNAME, 'dprst_seep_rate_open', Nhru, 'real', Dprst_seep_rate_open)/=0 ) & + & CALL read_error(2, 'dprst_seep_rate_open') + ENDIF Seg_hru_num = 0 DO i = 1, Active_hrus IF ( Hru_segment(i)>0) THEN @@ -1156,11 +1145,11 @@ END SUBROUTINE init_the_swamp !*********************************************************************** SUBROUTINE drain_the_swamp(Ihru) USE PRMS_ROUTING, ONLY: Seg_width, Seg_depth, Seg_width, Hru_segment, Mann_n, & - & Tr_ratio, Ripst_vol_max, Ripst_et_coef, Ripst_evap_hru, Seg_length, & + & Tr_ratio, Ripst_vol_max, Ripst_evap_hru, Seg_length, & & Basin_ripst_vol, Basin_ripst_evap, Basin_ripst_contrib, Ripst_stor_hru, & & Ripst_frac, Ripst_vol, Ripst_area_max, Ripst_area, Seg_slope, & & Seg_hru_num, Seg_ripflow, Ripst_depth, Basin_ripst_area, Bank_height_fac, & - & Ripst_areafr_max, Sro_to_ripst_imperv, Sro_to_ripst_perv !, Transmiss_seg + & Ripst_areafr_max !, Transmiss_seg USE PRMS_MODULE, ONLY: Cascade_flag, Frozen_flag USE PRMS_BASIN, ONLY: NEARZERO, DNEARZERO, Hru_area, Hru_area_dble, FEET2METERS, & & FT2_PER_ACRE, CFS2CMS_CONV @@ -1168,7 +1157,8 @@ SUBROUTINE drain_the_swamp(Ihru) USE PRMS_CLIMATEVARS, ONLY: Potet USE PRMS_SET_TIME, ONLY: Timestep_seconds USE PRMS_SRUNOFF, ONLY: Hru_impervevap, Dprst_evap_hru, Frozen, Thaw_depth, Soil_depth, & - & Dprst_seep_rate_open, Upslope_hortonian, Srp, Sri, Imperv_frac, Perv_frac + & Dprst_seep_rate_open, Upslope_hortonian, Srp, Sri, Imperv_frac, Perv_frac, & + & Sro_to_dprst_imperv, Sro_to_dprst_perv, Dprst_et_coef USE PRMS_INTCP, ONLY: Hru_intcpevap, Net_rain, Net_snow USE PRMS_SNOW, ONLY: Snowmelt, Pptmix_nopack, Snowcov_area, Snow_evap IMPLICIT NONE @@ -1218,15 +1208,15 @@ SUBROUTINE drain_the_swamp(Ihru) ENDIF ENDIF - ! add any pervious surface runoff fraction to riparian areas + ! add any pervious surface runoff fraction to riparian areas, use depression storage factor ripst_srp = 0.0 ripst_sri = 0.0 IF ( Srp>0.0 ) THEN - tmp = Srp*Perv_frac*Sro_to_ripst_perv(Ihru)*Hru_area(Ihru) + tmp = Srp*Perv_frac*Sro_to_dprst_perv(Ihru)*Hru_area(Ihru) ripst_srp = tmp*Ripst_areafr_max(Ihru) ! acre-inches ENDIF IF ( Sri>0.0 ) THEN - tmp = Sri*Imperv_frac*Sro_to_ripst_imperv(Ihru)*Hru_area(Ihru) + tmp = Sri*Imperv_frac*Sro_to_dprst_imperv(Ihru)*Hru_area(Ihru) ripst_sri = tmp*Ripst_areafr_max(Ihru) ! acre-inches ENDIF @@ -1291,7 +1281,7 @@ SUBROUTINE drain_the_swamp(Ihru) unsatisfied_et = Potet(Ihru) - Snow_evap(Ihru) - Hru_intcpevap(Ihru) & & - Hru_impervevap(Ihru) - Dprst_evap_hru(Ihru) ripst_avail_et = 0.0 - ripst_avail_et = Potet(Ihru)*(1.0-Snowcov_area(Ihru))*Ripst_et_coef(Ihru) + ripst_avail_et = Potet(Ihru)*(1.0-Snowcov_area(Ihru))*Dprst_et_coef(Ihru) Ripst_evap_hru(Ihru) = 0.0 IF ( ripst_avail_et>0.0 ) THEN ripst_evap = 0.0 diff --git a/prmsRip/srunoffCfgim.f90 b/prmsRip/srunoffCfgim.f90 index 88860725..d1b133f6 100644 --- a/prmsRip/srunoffCfgim.f90 +++ b/prmsRip/srunoffCfgim.f90 @@ -98,7 +98,7 @@ INTEGER FUNCTION srunoffdecl() USE PRMS_SRUNOFF USE PRMS_MODULE, ONLY: Model, Dprst_flag, Nhru, Nsegment, Print_debug, & & Cascade_flag, Sroff_flag, Nlake, Init_vars_from_file, Call_cascade, PRMS4_flag, & - & Frozen_flag + & Frozen_flag, Ripst_flag IMPLICIT NONE ! Functions INTEGER, EXTERNAL :: declvar, declparam @@ -422,14 +422,6 @@ INTEGER FUNCTION srunoffdecl() & 'Coefficient in linear flow routing equation for open surface depressions for each HRU', & & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_flow_coef') - ALLOCATE ( Dprst_seep_rate_open(Nhru) ) - IF ( declparam(MODNAME, 'dprst_seep_rate_open', 'nhru', 'real', & - & '0.02', '0.0', '0.2', & - & 'Coefficient used in linear seepage flow equation for open surface depressions', & - & 'Coefficient used in linear seepage flow equation for'// & - & ' open surface depressions for each HRU', & - & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_seep_rate_open') - ALLOCATE ( Dprst_seep_rate_clos(Nhru) ) IF ( declparam(MODNAME, 'dprst_seep_rate_clos', 'nhru', 'real', & & '0.02', '0.0', '0.2', & @@ -447,34 +439,6 @@ INTEGER FUNCTION srunoffdecl() & ' maximum open storage capacity spills as surface runoff', & & 'decimal fraction')/=0 ) CALL read_error(1, 'op_flow_thres') - ALLOCATE ( Sro_to_dprst_perv(Nhru) ) - IF ( PRMS4_flag==1 ) THEN - IF ( declparam(MODNAME, 'sro_to_dprst', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Fraction of pervious surface runoff that flows into surface-depression storage', & - & 'Fraction of pervious surface runoff that'// & - & ' flows into surface-depression storage; the remainder'// & - & ' flows to a stream network for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst') - ELSE - IF ( declparam(MODNAME, 'sro_to_dprst_perv', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Fraction of pervious surface runoff that flows into surface-depression storage', & - & 'Fraction of pervious surface runoff that'// & - & ' flows into surface-depression storage; the remainder'// & - & ' flows to a stream network for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_perv') - ENDIF - - ALLOCATE ( Sro_to_dprst_imperv(Nhru) ) - IF ( declparam(MODNAME, 'sro_to_dprst_imperv', 'nhru', 'real', & - & '0.2', '0.0', '1.0', & - & 'Fraction of impervious surface runoff that flows into surface-depression storage', & - & 'Fraction of impervious surface runoff that'// & - & ' flows into surface-depression storage; the remainder'// & - & ' flows to a stream network for each HRU', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_imperv') - ALLOCATE ( Dprst_et_coef(Nhru) ) IF ( declparam(MODNAME, 'dprst_et_coef', 'nhru', 'real', & & '1.0', '0.5', '1.5', & @@ -515,6 +479,51 @@ INTEGER FUNCTION srunoffdecl() & 'none')/=0 ) CALL read_error(1, 'va_clos_exp') ENDIF + IF ( Dprst_flag==1 .OR. Model==99 .OR. Ripst_flag==1) THEN + ALLOCATE ( Sro_to_dprst_perv(Nhru) ) + IF ( PRMS4_flag==1 ) THEN + IF ( declparam(MODNAME, 'sro_to_dprst', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of pervious surface runoff that flows into surface-depression or riparian storage', & + & 'Fraction of pervious surface runoff that'// & + & ' flows into surface-depression or riparian storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst') + ELSE + IF ( declparam(MODNAME, 'sro_to_dprst_perv', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of pervious surface runoff that flows into surface-depression or riparian storage', & + & 'Fraction of pervious surface runoff that'// & + & ' flows into surface-depression or riparian storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_perv') + ENDIF + + ALLOCATE ( Sro_to_dprst_imperv(Nhru) ) + IF ( declparam(MODNAME, 'sro_to_dprst_imperv', 'nhru', 'real', & + & '0.2', '0.0', '1.0', & + & 'Fraction of impervious surface runoff that flows into surface-depression or riparian storage', & + & 'Fraction of impervious surface runoff that'// & + & ' flows into surface-depression or riparian storage; the remainder'// & + & ' flows to a stream network for each HRU', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'sro_to_dprst_imperv') + + ALLOCATE ( Dprst_seep_rate_open(Nhru) ) + IF ( declparam(MODNAME, 'dprst_seep_rate_open', 'nhru', 'real', & + & '0.02', '0.0', '0.2', & + & 'Coefficient used in linear seepage flow equation for open surface depressions or riparian storage', & + & 'Coefficient used in linear seepage flow equation for'// & + & ' open surface depressions or riparian storage for each HRU', & + & 'fraction/day')/=0 ) CALL read_error(1, 'dprst_seep_rate_open') + + ALLOCATE ( Dprst_et_coef(Nhru) ) + IF ( declparam(MODNAME, 'dprst_et_coef', 'nhru', 'real', & + & '1.0', '0.5', '1.5', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression or riparian storage', & + & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression or riparian storage', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'dprst_et_coef') + ENDIF + IF ( Print_debug==1 ) THEN ALLOCATE ( Imperv_stor_ante(Nhru) ) IF ( Dprst_flag==1 ) ALLOCATE ( Dprst_stor_ante(Nhru) ) From ff162b3e3a238509f3d7805908b7ae4b54642547 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Fri, 13 Sep 2019 21:48:29 -0600 Subject: [PATCH 42/47] part of last commit --- prmsRip/srunoffCfgim.f90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/prmsRip/srunoffCfgim.f90 b/prmsRip/srunoffCfgim.f90 index d1b133f6..c7cbb644 100644 --- a/prmsRip/srunoffCfgim.f90 +++ b/prmsRip/srunoffCfgim.f90 @@ -439,13 +439,6 @@ INTEGER FUNCTION srunoffdecl() & ' maximum open storage capacity spills as surface runoff', & & 'decimal fraction')/=0 ) CALL read_error(1, 'op_flow_thres') - ALLOCATE ( Dprst_et_coef(Nhru) ) - IF ( declparam(MODNAME, 'dprst_et_coef', 'nhru', 'real', & - & '1.0', '0.5', '1.5', & - & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression storage', & - & 'Fraction of unsatisfied potential evapotranspiration to apply to surface-depression storage', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'dprst_et_coef') - IF ( Init_vars_from_file==0 .OR. Init_vars_from_file==2 .OR. Init_vars_from_file==7 ) THEN ALLOCATE ( Dprst_frac_init(Nhru) ) IF ( declparam(MODNAME, 'dprst_frac_init', 'nhru', 'real', & From 7dec9fcac8030345aee5fbc73cfd9d05268fc151 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Thu, 19 Sep 2019 18:51:08 -0600 Subject: [PATCH 43/47] changing some inconsistencies in riparian and cfgi found when doing write up --- prmsRip/routingRip.f90 | 111 +++++++++++++++++++++++---------------- prmsRip/srunoffCfgim.f90 | 14 +++-- 2 files changed, 75 insertions(+), 50 deletions(-) diff --git a/prmsRip/routingRip.f90 b/prmsRip/routingRip.f90 index 68c3060b..84d84d42 100644 --- a/prmsRip/routingRip.f90 +++ b/prmsRip/routingRip.f90 @@ -29,6 +29,7 @@ MODULE PRMS_ROUTING REAL, SAVE, ALLOCATABLE :: Seg_depth(:), K_coef(:), X_coef(:), Mann_n(:), Seg_width(:), Segment_flow_init(:) REAL, SAVE, ALLOCATABLE :: Seg_length(:), Seg_slope(:) ! Declared Parameters for Overbank and bank Storage + INTEGER, SAVE :: Two REAL, SAVE, ALLOCATABLE :: Transmiss_seg(:), Ripst_areafr_max(:) REAL, SAVE :: Bank_height_fac ! Declared Parameters for Overbank Storage @@ -44,7 +45,7 @@ MODULE PRMS_ROUTING DOUBLE PRECISION, SAVE :: Basin_bankst_head, Basin_bankst_seep_rate DOUBLE PRECISION, SAVE :: Basin_bankst_seep, Basin_bankst_vol, Basin_bankst_area REAL, SAVE, ALLOCATABLE :: Bankst_head(:), Bankst_seep_rate(:), Bankst_seep_hru(:) - REAL, SAVE, ALLOCATABLE :: Bankst_stor_hru(:), Bankst_head_pts(:) + REAL, SAVE, ALLOCATABLE :: Bankst_stor_hru(:), Bankst_head_pts(:,:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Stage_ante(:), Stage_ts(:), Seg_bankflow(:) END MODULE PRMS_ROUTING @@ -82,7 +83,7 @@ INTEGER FUNCTION routingdecl() & Ripst_flag, Stream_temp_flag, Init_vars_from_file IMPLICIT NONE ! Functions - INTEGER, EXTERNAL :: declparam, declvar + INTEGER, EXTERNAL :: declparam, declvar, declfix EXTERNAL read_error, print_module !*********************************************************************** routingdecl = 0 @@ -148,6 +149,10 @@ INTEGER FUNCTION routingdecl() ! 100 = user normal; 101 - 108 = not used; 109 sink (tosegment used by Lumen) IF ( Ripst_flag==1 .OR. Model==99 ) THEN + + IF ( declfix('two', 2, 2, 'Need for keeping bank storage head points')/=0 ) CALL read_error(7, 'two') + Two = 2 + ! Overbank storage variables IF ( declvar(MODNAME, 'basin_ripst_evap', 'one', 1, 'double', & & 'Basin area-weighted average evaporation from riparian overbank flow storage', & @@ -221,12 +226,12 @@ INTEGER FUNCTION routingdecl() ALLOCATE ( Seg_bankflow(Nsegment) ) IF ( declvar(MODNAME, 'seg_bankflow', 'nsegment', Nsegment, 'double', & - & 'Bank storage area contribution to streamflow can be negative if steam losing water', & + & 'Bank storage area contribution to streamflow, negative if steam losing water', & & 'cfs', Seg_bankflow)/=0 ) CALL read_error(3, 'seg_bankflow') - ALLOCATE ( Bankst_head_pts(Nhru) ) - IF ( declvar(MODNAME, 'bankst_head_pts', 'nhru', Nhru, 'real', & - & 'Head of bank storage above groundwater head: at half width away', & + ALLOCATE ( Bankst_head_pts(Nhru,Two) ) + IF ( declvar(MODNAME, 'bankst_head_pts', 'nhru,two', Nhru*Two, 'real', & + & 'Head of bank storage above groundwater head: at quarter width away and edge of riparian area', & & 'meters', Bankst_head_pts)/=0 ) CALL read_error(3, 'bankst_head_pts') ALLOCATE ( Stage_ante(Nsegment) ) @@ -241,12 +246,12 @@ INTEGER FUNCTION routingdecl() ALLOCATE ( Bankst_seep_hru(Nhru) ) IF ( declvar(MODNAME, 'bankst_seep_hru', 'nhru', Nhru, 'real', & - & 'HRU average seepage from bank storage to associated stream_segment for each HRU', & + & 'HRU average seepage from bank storage to associated stream segment for each HRU', & & 'inches', Bankst_seep_hru)/=0 ) CALL read_error(3, 'bankst_seep_hru') ALLOCATE ( Bankst_stor_hru(Nhru) ) IF ( declvar(MODNAME, 'bankst_stor_hru', 'nhru', Nhru, 'real', & - & 'HRU average bank storage for each HRU', & + & 'Average bank storage for each HRU', & & 'inches', Bankst_stor_hru)/=0 ) CALL read_error(3, 'bankst_stor_hru') ALLOCATE ( Bankst_seep_rate(Nsegment) ) @@ -664,7 +669,7 @@ INTEGER FUNCTION routinginit() Seg_outflow(i) = Segment_flow_init(i) IF ( Ripst_flag==1 ) THEN flow = Seg_outflow(i)*CFS2CMS_CONV - Stage_ts(i) = (Mann_n(i)*flow/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(5./3.) + Stage_ante(i) = (Mann_n(i)*flow/( Seg_width(i)*SQRT(Seg_slope(i)) ))**(3./5.) ENDIF ENDDO DEALLOCATE ( Segment_flow_init ) @@ -1167,6 +1172,7 @@ SUBROUTINE drain_the_swamp(Ihru) ! Arguments INTEGER, INTENT(IN) :: Ihru ! Local Variables + INTEGER :: seep_surface REAL :: ripst_avail_et, unsatisfied_et, ripst_evap, ripst_wid, thaw_frac REAL :: inflow, inflow_in, tmp, ripst_sri, ripst_srp, max_depth DOUBLE PRECISION :: seep, ripst_grnd, poss, seep_in, ripst_contrib_hru @@ -1240,8 +1246,8 @@ SUBROUTINE drain_the_swamp(Ihru) ! IF (Ripst_frac(Ihru)<1.0) THEN Seg_ripflow(Hru_segment(Ihru)) = Seg_ripflow(Hru_segment(Ihru)) - inflow_in - inflow_in = SNGL(inflow*Timestep_seconds/(FT2_PER_ACRE*12.0)) !inch acre - Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow*Ripst_areafr_max(Ihru) + inflow_in + inflow_in = SNGL(inflow_in*Timestep_seconds/(FT2_PER_ACRE*12.0)) !inch acre + Ripst_vol(Ihru) = Ripst_vol(Ihru) + inflow*Ripst_areafr_max(Ihru) + inflow_in !inch acre IF ( Ripst_vol(Ihru) > (Ripst_vol_max(Ihru)*thaw_frac) ) THEN Ripst_vol(Ihru) = Ripst_vol_max(Ihru)*thaw_frac ELSE @@ -1274,10 +1280,10 @@ SUBROUTINE drain_the_swamp(Ihru) ! Filled riparian storage surface area for each HRU: ! Fills outward from the river with one edge on river and with same depth and same side shape ! this works out to keeping fraction same for area and volume filled - Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) + Ripst_area(Ihru) = Ripst_area_max(Ihru)*Ripst_frac(Ihru) !acres ! evaporate water from riparian area based on snowcov_area - ! ripst_evap_open & ripst_evap_clos = inches-acres on the HRU + ! ripst_evap = inches-acres on the HRU unsatisfied_et = Potet(Ihru) - Snow_evap(Ihru) - Hru_intcpevap(Ihru) & & - Hru_impervevap(Ihru) - Dprst_evap_hru(Ihru) ripst_avail_et = 0.0 @@ -1305,29 +1311,33 @@ SUBROUTINE drain_the_swamp(Ihru) ! compute seepage seep = 0.0 seep_in = 0.0 + seep_surface = 0 !0 if just using same as depression storage IF ( Ripst_vol(Ihru)>NEARZERO) THEN - ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters -!assumed it was a one sided stream, here a headwater with both sides in one HRU - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 -! Stream ground area is stream side area (flat wall) and other side area (fraction of triangle (1) to rectangle (0)) - ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle + IF (seep_surface==1) THEN !say the seep coefficient has something to do with surface area + ripst_wid = SNGL(Ripst_area(Ihru)*FT2_PER_ACRE*(FEET2METERS**2.0)/Seg_length(Hru_segment(Ihru))) !meters + !assumed it was a one sided stream, here a headwater with both sides in one HRU + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_wid = ripst_wid/2.0 + ! Stream ground area is stream side area (flat wall) and other side area (fraction of triangle (1) to rectangle (0)) + ripst_grnd = DBLE( Seg_length(Hru_segment(Ihru))*( ripst_wid*(1.0-Tr_ratio(Ihru)) + & !rectangle & (SQRT( ripst_wid**2.0 + (Ripst_depth(Ihru)*thaw_frac)**2.0 )- Ripst_depth(Ihru)*thaw_frac)*Tr_ratio(Ihru) + & !triangle - & 2.0*Ripst_depth(Ihru)*thaw_frac ) ) !stream and other side -!assumed it was a one sided stream, here a headwater with both sides in one HRU - IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 -!seep in a day through ground surface area of riparian, m^3 into ft^3 to acre_in -!Transmissivity way too big - !seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) !acre_in -!ground area to total surface area is 5/6, then use depression seep coeff but reduce because surface area smaller - seep = ripst_grnd/(ripst_grnd+Ripst_area(Ihru)*FT2_PER_ACRE/ FEET2METERS**2.0 )/(5.0/6.0) & - & *Ripst_vol(Ihru)*Dprst_seep_rate_open(Ihru)/FT2_PER_ACRE/12.0 + & 2.0*Ripst_depth(Ihru)*thaw_frac ) ) !stream and other side m^2 + !assumed it was a one sided stream, here a headwater with both sides in one HRU + IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) ripst_grnd = ripst_grnd*2.0 + !seep in a day through ground surface area of riparian, m^3 into ft^3 to acre_in + !Transmissivity way too big + !seep = ripst_grnd*DBLE( Transmiss_seg(Hru_segment(Ihru)) )/(FEET2METERS**3.0) !ft^3 + !ground area to total surface area is 5/6, then use depression seep coeff but reduce because surface area smaller + seep = ripst_grnd/(ripst_grnd+Ripst_area(Ihru)*FT2_PER_ACRE/ FEET2METERS**2.0 )/(5.0/6.0) & + & *Ripst_vol(Ihru)*Dprst_seep_rate_open(Ihru)*FT2_PER_ACRE/12.0 !ft^3 + ELSE !assume it is just a volume thing + seep = Ripst_vol(Ihru)*Dprst_seep_rate_open(Ihru)*FT2_PER_ACRE/12.0 !ft^3 + ENDIF !seep = 0.0 !if want to turn off seep - seep_in = seep*FT2_PER_ACRE*12.0 ! inch acres + seep_in = seep*12.0/FT2_PER_ACRE ! inch acres Ripst_vol(Ihru) = Ripst_vol(Ihru) - seep_in IF ( Ripst_vol(Ihru)<0.0D0 ) THEN !IF ( Ripst_vol(Ihru)<-DNEARZERO ) PRINT *, 'issue, ripst_vol<0.0', Ihru, Ripst_vol(Ihru) - seep_in = seep_in + Ripst_vol(Ihru) - seep = seep_in/FT2_PER_ACRE/12.0 !ft^3 + seep_in = seep_in + Ripst_vol(Ihru) !inch acre Ripst_vol(Ihru) = 0.0D0 ENDIF ENDIF @@ -1358,9 +1368,8 @@ SUBROUTINE init_bank_storage() USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv, Hru_area_dble, Active_hrus, & & FT2_PER_ACRE, FEET2METERS, CFS2CMS_CONV USE PRMS_ROUTING, ONLY: Basin_bankst_head, Bankst_head_init, Basin_bankst_area, & - & Basin_bankst_vol, Bankst_head, Hru_segment, Seg_width, Seg_length, & - & Bankst_stor_hru, Bankst_head_pts, Ripst_areafr_max, Bankfinite_hru - USE PRMS_FLOWVARS, ONLY: Seg_outflow + & Basin_bankst_vol, Bankst_head, Stage_ante, Bankst_stor_hru, Bankst_head_pts, & + & Ripst_areafr_max, Bankfinite_hru, Hru_segment IMPLICIT NONE ! Functions INTRINSIC SNGL @@ -1370,8 +1379,9 @@ SUBROUTINE init_bank_storage() DO i = 1, Active_hrus IF ( Hru_segment(i)>0) THEN Bankst_head(i) = Bankst_head_init(i) - Bankst_head_pts(i) =SNGL(Seg_outflow(Hru_segment(i))*CFS2CMS_CONV)*60.*60.*24. & - & /Seg_width(Hru_segment(i))/Seg_length(Hru_segment(i)) + Bankst_head_pts(i,1) =( 8.0*Bankst_head(i)-SNGL(Stage_ante(Hru_segment(i))) )/4.0 + IF (Bankst_head_pts(i,1)<0.0) Bankst_head_pts(i,1) = 0.0 + Bankst_head_pts(i,1) = 0.0 IF (Bankfinite_hru(i)==1) THEN Bankst_stor_hru(i) = Ripst_areafr_max(i)*12.0*Bankst_head(i)/FEET2METERS !in inches Basin_bankst_head = Basin_bankst_head + Ripst_areafr_max(i)*Bankst_head(i)*Hru_area_dble(i) ! in meters @@ -1417,11 +1427,12 @@ SUBROUTINE comp_bank_storage(Ihru) INTEGER :: h, t0 INTEGER, PARAMETER :: nbankd = 2 REAL, PARAMETER :: PI = 3.14159 - REAL :: area, str_wid, tot_wid, bank_wid, trans, a, xd, t, td - REAL :: delt, delta_input(nbankd), delta_diff(nbankd), head(nbankd), seep(nbankd) + REAL :: area, str_wid, tot_wid, bank_wid, trans, a, xd, t, td, xd2 + REAL :: delt, delta_input(nbankd), delta_diff(nbankd), head(nbankd,2), seep(nbankd) REAL :: bank(nbankd), bankv(nbankd), ripfrac DOUBLE PRECISION :: input_net(nbankd), diff_net(nbankd), recharge(nbankd), stage(nbankd) DOUBLE PRECISION :: head_step, head_step_grad, seep_sum, head_sum + DOUBLE PRECISION :: head_step2, head_step_grad2, head_sum2 !*********************************************************************** area = Ripst_areafr_max(Ihru)*Hru_area(Ihru) !acres IF ( Seg_hru_num(Hru_segment(Ihru))==1 ) area = area/2.0 !only take half of area if hru contains all of stream not just one side @@ -1453,29 +1464,38 @@ SUBROUTINE comp_bank_storage(Ihru) delta_diff(h-1) = SNGL((diff_net(h)-diff_net(h-1))/delt ) ENDDO Bankst_seep_hru(Ihru) = 0.0 - xd = 1.0+ bank_wid/2.0 ! at x = 1.0 is stage which already know, calc at middle of bank storage area - head=Bankst_head_pts(Ihru) !set at last height for initial + xd = 1.0+ bank_wid/4.0 ! at x = 1.0 is stage which already know, calc at 1/4 of bank storage area + DO h = 1, nbankd + head(h,1)=Bankst_head_pts(Ihru,1) !set at last height for initial + head(h,2)=Bankst_head_pts(Ihru,2) !set at last height for initial + ENDDO ! Calculate heads, seepage, and bank storage using convolution ripfrac = Ripst_areafr_max(Ihru) IF (Bankfinite_hru(Ihru)==0) ripfrac = 1.0 DO h = 1, (nbankd-1) head_sum = 0.0 + head_sum2 = 0.0 seep_sum = 0.0 DO t0 = 1,h t = t0*delt td = t*a/(str_wid**2.0) !dimensionless - IF (Bankfinite_hru(Ihru)==1) then !finite solution if transmissivity high, COMPUTATIONALLY EXPENSIVE, might eliminate + IF (Bankfinite_hru(Ihru)==1) then !finite solution if transmissivity high, COMPUTATIONALLY EXPENSIVE + xd2 = bank_wid+1.0 CALL LTST1(td, xd, tot_wid, bank_wid, head_step, head_step_grad) + CALL LTST1(td, xd2, tot_wid, bank_wid, head_step2, head_step_grad2) ELSE IF (Bankfinite_hru(Ihru)==0) then !semi-infinite solution head_step = ERFC( (xd - 1.0)/SQRT((4.0*td)) ) head_step_grad = -( 1.0/SQRT((PI*td)) ) ENDIF !head is a function of xd head_sum = delta_input(h-t0+1)*head_step + head_sum + IF (Bankfinite_hru(Ihru)==1) head_sum2 = delta_input(h-t0+1)*head_step2 + head_sum2 !seep is per unit segment length rate goes out, not a function of xd seep_sum = delta_diff(h-t0+1)*head_step_grad + seep_sum ENDDO - head(h+1)=head(h+1) + SNGL(head_sum*delt) + head(h+1,1)=head(h+1,1) + SNGL(head_sum*delt) + head(h+1,2)=0.0 ! Bankst_head_pts at infinite edge of bank storage area is 0 (xd = 1, so head_step = 0) + IF (Bankfinite_hru(Ihru)==1) head(h+1,2)=head(h+1,2) + SNGL(head_sum2*delt) seep(h+1)=SNGL((trans/str_wid)*seep_sum*delt) bank(h+1)=bank(h) - seep(h+1)*delt bankv(h+1)=bank(h+1)*Seg_length(Hru_segment(Ihru)) @@ -1487,12 +1507,11 @@ SUBROUTINE comp_bank_storage(Ihru) bank = bank*2.0 bankv = bankv*2.0 ENDIF - Bankst_head_pts(Ihru) = head(nbankd) ! meters + Bankst_head_pts(Ihru,1) = head(nbankd,1) ! meters + Bankst_head_pts(Ihru,2) = head(nbankd,2) ! meters !linear interpolation for total average head over bank storage area, meters - Bankst_head(Ihru) = 0.5*(SNGL(stage(nbankd))+Bankst_head_pts(Ihru)) - ! Bankst_head_pts at finite edge of bank storage area is 0 (xd = 1, so head_step = 0) - ! is only saved at the end of the timestep - Bankst_head(Ihru) = Bankst_head(Ihru) + 0.5*Bankst_head_pts(Ihru) + Bankst_head(Ihru) = ( SNGL(stage(nbankd))+4.0*Bankst_head_pts(Ihru,1) & + & + 3.0*Bankst_head_pts(Ihru,2) )/8.0 ! m2 per 24 hr per stream segment for both sides of stream ! seep hru is inch over hru seeping out per day diff --git a/prmsRip/srunoffCfgim.f90 b/prmsRip/srunoffCfgim.f90 index c7cbb644..c5f684d9 100644 --- a/prmsRip/srunoffCfgim.f90 +++ b/prmsRip/srunoffCfgim.f90 @@ -302,8 +302,8 @@ INTEGER FUNCTION srunoffdecl() IF ( Frozen_flag==1 .OR. Model==99 ) THEN ALLOCATE ( Frozen(Nhru) ) IF ( declvar(MODNAME, 'frozen', 'nhru', Nhru, 'integer', & - & 'Flag for frozen ground (0=no; 1=soil at surface; 2=soil below surf; 3=below soil)', & - & 'dimensionless', Frozen)/=0 ) CALL read_error(3, 'frozen') + & 'Marker for frozen ground (0=no; 1=soil at surface; 2=soil below surf; 3=below soil)', & + & 'none', Frozen)/=0 ) CALL read_error(3, 'frozen') ALLOCATE ( Cfgi(Nhru) ) IF ( declvar(MODNAME, 'cfgi', 'nhru', Nhru, 'real', & @@ -816,7 +816,7 @@ INTEGER FUNCTION srunoffrun() depthg_cm = 0.0 !Cov_type =0 bare soil (rock, may be mostly impervious already) IF (Cov_type(i)==1) depthg_cm = 4.0 !grasses (boreal grass, tundra) IF (Cov_type(i)==2) depthg_cm = 3.0 !shrub (tundra) - IF (Cov_type(i)>=3) depthg_cm = 6.0 !trees + IF (Cov_type(i)==3) depthg_cm = 6.0 !trees IF (Cov_type(i)==4) depthg_cm = 2.0 !coniferous ! Continuous frozen ground index @@ -828,13 +828,19 @@ INTEGER FUNCTION srunoffrun() IF ( Cfgi(i)<0.0 ) Cfgi(i) = 0.0 ! If above the threshold to be frozen IF ( Cfgi(i)>=Cfgi_thrshld ) THEN + thaw_frac = 1.0 !use previous frozen state + IF ( Frozen(i)==1 ) THEN + thaw_frac = 0.0 + ELSEIF ( Frozen(i)==2) THEN + thaw_frac = Thaw_depth(i)/Soil_depth(i) + ENDIF ! Use modified Berggren formula to get a depth of frozen ! soil water content % of dry weight is water vol*density / (soil vol*density) omega = Soil_water(i) / (Soil_depth(i)*Soil_den(i)) IF ( omega>1.0 ) omega = 1.0 IF ( omega<0.1 ) omega = 0.1 ! volumetric heat of fusion of the soil - volumetric_soil = Soil_den(i)*(4.187*0.17 + 0.75*omega)*1.e6 ! J/m^3/K, specific heat of rock, water, ice =0.17, 1, 0.5 *4.187 J/g/K , density in g/cm3 + volumetric_soil = Soil_den(i)*(0.71179 + 4.186*(0.5*thaw_frac + 0.5)*omega)*1.e6 ! J/m^3/K, specific heat of rock, water, ice =4.186*0.17,4.186, 0.5 *4.187 J/g/K , density in g/cm3 ! latent heat of fusion of the soil latent_soil = 334.0*Soil_den(i)*omega*1.e6 ! J/m^3, latent heat of fusion of water = 334 J/g , density in g/cm3 thermal_ratio_alp = (Prev_ann_tempc(i) - Freezepoint)/(Cfgi(i) - Cfgi_thrshld) !degree K/ index Ti/Ts From 6a77e8fd87260e081a39c7b19afe9128ed7ae340 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Tue, 1 Oct 2019 20:44:21 -0500 Subject: [PATCH 44/47] fixing some files to agree with documentation --- makelist | 4 ++-- prmsRip/mizurouteRip.f90 | 15 +++++++++++---- prmsRip/muskingumRip.f90 | 15 +++++++++++---- prmsRip/srunoffCfgim.f90 | 17 +++++++++-------- 4 files changed, 33 insertions(+), 18 deletions(-) diff --git a/makelist b/makelist index da812aee..c1d8f803 100644 --- a/makelist +++ b/makelist @@ -44,7 +44,7 @@ FC = gfortran # Define the C compile flags # -D_UF defines UNIX naming conventions for mixed language compilation. ########################################################## -CFLAGS = $(OPTLEVEL) -D$(ARC) -D_UF +CFLAGS = $(OPTLEVEL) -D$(ARC) -D_UF -I /usr/include #for gfortran CC = gcc #for ifort @@ -55,7 +55,7 @@ CC = gcc ########################################################## #for gfortran MATHLIB = -lm -GCLIB = -L/opt/local/lib -lgfortran -lgcc_s.1 +GCLIB = -L/opt/local/lib -lgfortran -lgcc_s.1 -L/usr/lib #for ifort #GCLIB = -lgfortran -lgcc $(MATHLIB) FLIBS = $(GCLIB) diff --git a/prmsRip/mizurouteRip.f90 b/prmsRip/mizurouteRip.f90 index f49c55d1..539f95a6 100644 --- a/prmsRip/mizurouteRip.f90 +++ b/prmsRip/mizurouteRip.f90 @@ -437,7 +437,7 @@ END FUNCTION mizuroute_init !*********************************************************************** INTEGER FUNCTION mizuroute_run() USE PRMS_MIZUROUTE - USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag + USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag, Frozen_flag USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, METERS2FEET, Active_hrus, Hru_route_order, & & Basin_gl_cfs, Basin_gl_ice_cfs USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & @@ -455,7 +455,7 @@ INTEGER FUNCTION mizuroute_run() & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_contrib, Basin_ripst_evap, & & Basin_ripst_vol, Bankst_seep_rate USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt - USE PRMS_SRUNOFF, ONLY: Basin_sroff + USE PRMS_SRUNOFF, ONLY: Basin_sroff, Frozen USE PRMS_GWFLOW, ONLY: Basin_gwflow ! mizuroute specific modules USE nrtype ! variable types, etc. @@ -634,10 +634,17 @@ INTEGER FUNCTION mizuroute_run() ENDDO DO j = 1, Active_hrus i = Hru_route_order(j) - IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) & - & CALL comp_bank_storage(i) + IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) THEN + IF (Frozen_flag==1) THEN + IF ( Frozen(i).ne.1 ) THEN + CALL comp_bank_storage(i) + ENDIF + ELSE + CALL comp_bank_storage(i) + ENDIF ! ******Compute the bank storage component ! transfers water between separate bank storage and stream depending on seepage + ENDIF ENDDO Basin_bankst_seep = Basin_bankst_seep*Basin_area_inv Basin_bankst_head = Basin_bankst_head*Basin_area_inv diff --git a/prmsRip/muskingumRip.f90 b/prmsRip/muskingumRip.f90 index dab60368..0ac99677 100644 --- a/prmsRip/muskingumRip.f90 +++ b/prmsRip/muskingumRip.f90 @@ -178,7 +178,7 @@ END FUNCTION muskingum_init !*********************************************************************** INTEGER FUNCTION muskingum_run() USE PRMS_MUSKINGUM - USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag + USE PRMS_MODULE, ONLY: Nsegment, Ripst_flag, Glacier_flag, Frozen_flag USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, Active_hrus, Hru_route_order, & & Basin_gl_cfs, Basin_gl_ice_cfs USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, & @@ -196,7 +196,7 @@ INTEGER FUNCTION muskingum_run() & Hru_segment, Seg_length, Basin_ripst_area, Basin_ripst_contrib, Basin_ripst_evap, & & Basin_ripst_vol, Bankst_seep_rate USE PRMS_GLACR, ONLY: Basin_gl_top_melt, Basin_gl_ice_melt - USE PRMS_SRUNOFF, ONLY: Basin_sroff + USE PRMS_SRUNOFF, ONLY: Basin_sroff, Frozen USE PRMS_GWFLOW, ONLY: Basin_gwflow IMPLICIT NONE ! Functions @@ -333,10 +333,17 @@ INTEGER FUNCTION muskingum_run() ENDDO DO j = 1, Active_hrus i = Hru_route_order(j) - IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) & - & CALL comp_bank_storage(i) + IF ( Hru_segment(i)>0 .AND. (Bankfinite_hru(i)==0 .OR. Ripst_areafr_max(i)>0.0)) THEN + IF (Frozen_flag==1) THEN + IF ( Frozen(i).ne.1 ) THEN + CALL comp_bank_storage(i) + ENDIF + ELSE + CALL comp_bank_storage(i) + ENDIF ! ******Compute the bank storage component ! transfers water between separate bank storage and stream depending on seepage + ENDIF ENDDO Basin_bankst_seep = Basin_bankst_seep*Basin_area_inv Basin_bankst_head = Basin_bankst_head*Basin_area_inv diff --git a/prmsRip/srunoffCfgim.f90 b/prmsRip/srunoffCfgim.f90 index c5f684d9..8c6e2893 100644 --- a/prmsRip/srunoffCfgim.f90 +++ b/prmsRip/srunoffCfgim.f90 @@ -302,7 +302,7 @@ INTEGER FUNCTION srunoffdecl() IF ( Frozen_flag==1 .OR. Model==99 ) THEN ALLOCATE ( Frozen(Nhru) ) IF ( declvar(MODNAME, 'frozen', 'nhru', Nhru, 'integer', & - & 'Marker for frozen ground (0=no; 1=soil at surface; 2=soil below surf; 3=below soil)', & + & 'Marker for frozen ground layer top (0=none; 1=at surface; 2=in soil below surface; 3=below soil)', & & 'none', Frozen)/=0 ) CALL read_error(3, 'frozen') ALLOCATE ( Cfgi(Nhru) ) @@ -687,7 +687,7 @@ INTEGER FUNCTION srunoffrun() REAL :: srunoff, avail_et, hperv, sra, availh2o DOUBLE PRECISION :: hru_sroff_down, runoff, apply_sroff, cfgi_sroff REAL :: cfgi_k, depth_cm, nosnow_area, depthg_cm, trad, emiss, emisl ! frozen ground - REAL :: cfgi_kg, soil_cond, latent_soil, nice, ice_cond, beta, thaw_frac ! frozen ground + REAL :: cfgi_kg, soil_cond, latent_soil, nwat, ice_cond, beta, thaw_frac ! frozen ground REAL :: water_cond, sat_cond, mean_cond, lambda, omega, l5, l6, l8 ! frozen ground REAL :: volumetric_soil, thermal_ratio_alp, fusion_param_mu, frz_height ! frozen ground REAL :: glcrmltb, temp, temp2 ! glaciers @@ -845,7 +845,7 @@ INTEGER FUNCTION srunoffrun() latent_soil = 334.0*Soil_den(i)*omega*1.e6 ! J/m^3, latent heat of fusion of water = 334 J/g , density in g/cm3 thermal_ratio_alp = (Prev_ann_tempc(i) - Freezepoint)/(Cfgi(i) - Cfgi_thrshld) !degree K/ index Ti/Ts IF ( thermal_ratio_alp<0.0 ) thermal_ratio_alp = 0.0 - fusion_param_mu =(Cfgi(i) - Cfgi_thrshld)*volumetric_soil/latent_soil !index/degree K St12 + fusion_param_mu =(Cfgi(i) - Cfgi_thrshld)*volumetric_soil/latent_soil !index/degree K ! lambda corrects the Stefan formula for the effects of volumetric heat which it neglected beta = 1.0 !ranges between 0.95 and 1.3 depending on soil type and soil moisture lambda = 1.0 !Graph in Aldrich 1956, says in Alaska this is usually 1 but if less northern, can be as low as 0.3 @@ -857,13 +857,13 @@ INTEGER FUNCTION srunoffrun() IF ( Cfgi(i)==Cfgi_prev(i) ) lambda = l5 ! dry soil thermal conductivity - soil_cond = ( 486.0*Soil_den(i) + 233.0 )/( 2.7 - 0.947*Soil_den(i) ) !equation Johansen 1975,J/m/hr/K - !from last time step frozen depth - nice = Porosity_hru(i)* Frz_depth(i)/Soil_depth(i) + soil_cond = ( 486.0*Soil_den(i) + 233.0 )/( 2.7 - 0.947*Soil_den(i) ) !Via Fox 1992, equation Johansen 1975,J/m/hr/K, 1000 kg/m3 = 1 g/cm3 + !from last time step thaw_frac + nwat = Porosity_hru(i)* thaw_frac ! soil saturated conductivity is geometric mean of the conductivities of the materials within the soil profile ice_cond = (-0.0176*Tavgc(i) + 2.0526)*3600.0 !Bonales 2017, J/s/m/K to hr water_cond = 0.5918 *3600.0 !J/s/m/K to hr - sat_cond =( soil_cond**(1.0-Porosity_hru(i)) )*( ice_cond**(nice) )*( water_cond**(Porosity_hru(i)-nice) ) + sat_cond =( soil_cond**(1.0-Porosity_hru(i)) )*( water_cond**(nwat) )*( ice_cond**(Porosity_hru(i)-nwat) ) ! mean thermal conductivity of the frozen and unfrozen soil equation of dry and saturated conductivities mean_cond = (sat_cond - soil_cond)*omega + soil_cond !J/m/hr/K ! this is height of frozen soil. Freezes downward from surface. When thaw, also thaw downward from surface so will be thawed area above here @@ -882,7 +882,8 @@ INTEGER FUNCTION srunoffrun() frzen = 2 !soil frozen below top thaw_frac = Thaw_depth(i)/Soil_depth(i) ELSEIF ( Frz_depth(i)>=Soil_depth(i) ) THEN ! Thaw_depth(i)>=Soil_depth(i)) - frzen = 3 !soil not frozen but below is, thaw_frac = 1.0 + frzen = 3 !soil not frozen but below is + thaw_frac = 1.0 ENDIF ENDIF ENDIF From fda486b729a613b763d1157ec347d3b1092af77f Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Wed, 2 Oct 2019 18:03:42 -0500 Subject: [PATCH 45/47] fixing definitions of variables and parameters --- prms/climateflow.f90 | 4 +-- prms/glacr_melt.f90 | 40 +++++++++--------------- prms/snowcomp.f90 | 65 ++++++++++++++++++++------------------- prmsRip/snowcompCfgim.f90 | 2 +- 4 files changed, 51 insertions(+), 60 deletions(-) diff --git a/prms/climateflow.f90 b/prms/climateflow.f90 index 229b26df..62e58485 100644 --- a/prms/climateflow.f90 +++ b/prms/climateflow.f90 @@ -547,12 +547,12 @@ INTEGER FUNCTION climateflow_decl() ALLOCATE ( Glrette_frac(Nhru) ) IF ( declvar(MODNAME, 'glrette_frac', 'nhru', Nhru, 'real', & - 'Fraction of snow field (too small for glacier dynamics)', & + 'Fraction of glacierette (too small for glacier dynamics)', & 'decimal fraction', Glrette_frac)/=0 ) CALL read_error(3, 'glrette_frac') ALLOCATE ( Alt_above_ela(Nhru) ) IF ( declvar(MODNAME, 'alt_above_ela', 'nhru', Nhru, 'real', & - 'Altitude above equilibrium line altitude (ELA)', & + 'Altitude HRU is above equilibrium line altitude (ELA), negative value indicates HRU below ELA', & 'elev_units', Alt_above_ela)/=0 ) CALL read_error(3, 'alt_above_ela') ENDIF diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 index 15891f27..0ad4b6a3 100644 --- a/prms/glacr_melt.f90 +++ b/prms/glacr_melt.f90 @@ -51,9 +51,8 @@ MODULE PRMS_GLACR ! Local Variables ! Ngl - Number of glaciers counted by termini - ! Ntp - Number of tops of glaciers, so max glaciers that could ever split in two - ! Nhrugl - Number of at least partially glacierized hrus at initiation -!#of cells=Nhrugl,#of streams=Ntp,#of cells/stream<=Ntp, #of glaciers<=Nhru + ! Ntp - Number of tops of glaciers, so max glaciers that could ever split in too + ! Nhrugl - Number of at glacier-capable hrus INTEGER, SAVE :: Nglres, Ngl, Ntp, Nhrugl, Mbinit_flag, Output_unit, Fraw_unit, All_unit INTEGER, SAVE :: Seven, Four, Glac_HRUnum_down DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_area_inch2(:) @@ -206,7 +205,7 @@ INTEGER FUNCTION glacrdecl() ALLOCATE ( Glacr_flow(Nhru) ) IF ( declvar(MODNAME, 'glacr_flow', 'nhru', Nhru, 'real', & - & 'Glacier melt and rain from HRU to stream network, only nonzero at termini HRUs and snowfield HRUs', & + & 'Glacier melt and rain from HRU to stream network, only nonzero at termini HRUs and glacierette HRUs', & & 'inches cubed', Glacr_flow)/=0 ) CALL read_error(3, 'glacr_flow') ALLOCATE ( Delta_volyr(Nhru) ) @@ -309,15 +308,7 @@ INTEGER FUNCTION glacrdecl() & 'Glacier basal elevation mean over HRU', & & 'elev_units', Basal_elev)/=0 ) CALL read_error(3, 'basal_elev') - ALLOCATE ( Keep_gl(Nhru,Seven) ) - IF ( declvar(MODNAME, 'keep_gl', 'nhru,seven', Nhru*Seven, 'real', & - & 'Glacier real variables keeping from first year', & - & 'none', Keep_gl)/=0 ) CALL read_error(3, 'keep_gl') - - ALLOCATE ( Ikeep_gl(Nhru,Four) ) - IF ( declvar(MODNAME, 'ikeep_gl', 'nhru,four', Nhru*Four, 'real', & - & 'Glacier integer variables keeping from first year', & - & 'none', Ikeep_gl)/=0 ) CALL read_error(3, 'ikeep_gl') + ALLOCATE ( Keep_gl(Nhru,Seven), Ikeep_gl(Nhru,Four) ) ALLOCATE ( Basal_slope(Nhru) ) IF ( declvar(MODNAME, 'basal_slope', 'nhru', Nhru, 'real', & @@ -337,7 +328,6 @@ INTEGER FUNCTION glacrdecl() & 'Basin area-weighted average storage estimated start in glacier reservoirs', & & 'inches', Basin_gl_storstart)/=0 ) CALL read_error(3, 'basin_gl_storstart') - IF ( declvar(MODNAME, 'basin_gl_storvol', 'one', 1, 'double', & & 'Basin storage volume in glacier storage reservoirs', & & 'acre-inches', Basin_gl_storvol)/=0 ) CALL read_error(3, 'basin_gl_storvol') @@ -417,22 +407,22 @@ INTEGER FUNCTION glacrdecl() ALLOCATE ( Hru_length(Nhru) ) IF ( declparam(MODNAME, 'hru_length', 'nhru', 'real', & '0.0', '0.0', '10000.0', & - 'Length of segment covering all of glacier-possible HRU', & - 'Length of segment covering all of glacier-possible HRU', & + 'Length of segment covering all of glacier-capable HRU', & + 'Length of segment covering all of glacier-capable HRU', & 'km')/=0 ) CALL read_error(1, 'hru_length') ALLOCATE ( Hru_width(Nhru) ) IF ( declparam(MODNAME, 'hru_width', 'nhru', 'real', & '0.0', '0.0', '10000.0', & - 'Width of glacier-possible HRU', & - 'Width of glacier-possible HRU', & + 'Width of glacier-capable HRU', & + 'Width of glacier-capable HRU', & 'km')/=0 ) CALL read_error(1, 'hru_width') ALLOCATE ( Abl_elev_range(Nhru) ) IF ( declparam(MODNAME, 'abl_elev_range', 'nhru', 'real', & '1000.0', '0.0', '17000.0', & - 'Average HRU snowfield ablation zones elevation range', & - 'Average HRU snowfield ablation zones elevation range or ~ median-min elev', & + 'Average HRU glacierette ablation zones elevation range', & + 'Average HRU glacierette ablation zones elevation range or ~ median-min elev', & 'elev_units')/=0 ) CALL read_error(1, 'abl_elev_range') IF (Mbinit_flag==1) THEN @@ -837,7 +827,7 @@ INTEGER FUNCTION glacrrun() i = Hru_route_order(j) IF ( Hru_type(i)==1 ) THEN IF (Glrette_frac(j)>NEARZERO) THEN - count=1 !has at least one snowfield + count=1 !has at least one glacierette EXIT ENDIF ENDIF @@ -862,7 +852,7 @@ INTEGER FUNCTION glacrrun() dosol = recompute_soltab() ! change soltab tables for Hru_slope_ts IF (count==0) THEN Glacr_flow = 0.0 - Basin_gl_area = 0.D0 !no snowfields either + Basin_gl_area = 0.D0 !no glacierettes either Basin_gl_top_melt = 0.0D0 Basin_gl_top_gain = 0.0D0 Basin_gl_ice_melt = 0.0D0 @@ -1382,9 +1372,9 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) ENDIF ENDDO ENDIF -!Snowfield area change uses Baumann and Winkler 2010 to change area every 10 years; -! technically each snowfield should have own ablation elevation range. - IF (glrette_exist==1) THEN !have snowfields, +!Glacierette area change uses Baumann and Winkler 2010 to change area every 10 years; +! technically each glacierette should have own ablation elevation range. + IF (glrette_exist==1) THEN !have glacierettes, IF ( MOD(Nowyear-Starttime(1),10)==0 ) THEN !change them DO i = 1, Active_hrus j = Hru_route_order(i) diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index f3184967..4f7dbb74 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -276,38 +276,6 @@ INTEGER FUNCTION snodecl() & 'Basin area-weighted average snow and glacier and glrette covered area', & & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') - ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) - IF ( declparam(MODNAME, 'glacr_freeh2o_cap', 'nhru', 'real', & - & '0.002', '0.0', '0.01', & - & 'Free-water holding capacity of glacier ice', & - & 'Free-water holding capacity of glacier ice expressed as a' // & - & ' decimal fraction of the frozen water content of the glacier ice (glacr_pk_ice)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glacr_freeh2o_cap') - - ALLOCATE ( Glacr_layer(Nhru) ) - IF ( declparam(MODNAME, 'glacr_layer', 'nhru', 'real', & - & '3.94', '0.0', '590.6', & - & 'Active layer on glacier', & - & 'Active layer is 0 to 15 m (590.6 inches) thick at start of year, when' // & - & ' melts will set daily glacr_pk_temp to 0', & - & 'inches')/=0 ) CALL read_error(1, 'glacr_layer') - - IF ( Init_vars_from_file==0 ) THEN - ALLOCATE ( Glacier_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & - & '0.0', '0.0', '1.0', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') - - ALLOCATE ( Glrette_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'glrette_frac_init', 'nhru', 'real', & - & '0.0', '0.0', '1.0', & - & 'Initial fraction of glacierette (too small for glacier dynamics)', & - & 'Initial fraction of glacierette (too small for glacier dynamics)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glrette_frac_init') - - ENDIF ENDIF IF ( declvar(MODNAME, 'basin_snowdepth', 'one', 1, 'double', & @@ -506,6 +474,39 @@ INTEGER FUNCTION snodecl() & 'Ice albedo 300 meters below ELA', & & 'Ice albedo 300 meters below ELA', & & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo_ice') + + ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) + IF ( declparam(MODNAME, 'glacr_freeh2o_cap', 'nhru', 'real', & + & '0.002', '0.0', '0.01', & + & 'Free-water holding capacity of glacier ice', & + & 'Free-water holding capacity of glacier ice expressed as a' // & + & ' decimal fraction of the frozen water content of the glacier ice (glacr_pk_ice)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacr_freeh2o_cap') + + ALLOCATE ( Glacr_layer(Nhru) ) + IF ( declparam(MODNAME, 'glacr_layer', 'nhru', 'real', & + & '3.94', '0.0', '590.6', & + & 'Active layer on glacier', & + & 'Active layer is 0 to 15 m (590.6 inches) thick at start of year, when' // & + & ' melts will set daily glacr_pk_temp to 0', & + & 'inches')/=0 ) CALL read_error(1, 'glacr_layer') + + IF ( Init_vars_from_file==0 ) THEN + ALLOCATE ( Glacier_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') + + ALLOCATE ( Glrette_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glrette_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glrette_frac_init') + + ENDIF ENDIF IF ( declparam(MODNAME, 'den_init', 'one', 'real', & diff --git a/prmsRip/snowcompCfgim.f90 b/prmsRip/snowcompCfgim.f90 index 09a30494..f45db19a 100644 --- a/prmsRip/snowcompCfgim.f90 +++ b/prmsRip/snowcompCfgim.f90 @@ -254,7 +254,7 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Glacrcov_area(Nhru) ) IF ( declvar(MODNAME, 'glacrcov_area', 'nhru', Nhru, 'real', & - & 'Ice-covered area on each glacier HRU or HRU with glacierette at start of step', & + & 'Ice-covered area (no snowpack) on each glacier HRU or HRU with glacierette at start of step', & & 'decimal fraction', Glacrcov_area)/=0 ) CALL read_error(3, 'glacrcov_area') ALLOCATE ( Glacr_pk_ice(Nhru) ) From a284e2cffc699984d976c3b7512b1f51b5e5bb65 Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Wed, 2 Oct 2019 18:04:08 -0500 Subject: [PATCH 46/47] fixing definitions --- prms/glacr_melt.f90 | 2 +- prms/snowcomp.f90 | 54 +++++++++---------- prmsRip/snowcompCfgim.f90 | 111 +++++++++++++++++++------------------- 3 files changed, 84 insertions(+), 83 deletions(-) diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 index 0ad4b6a3..313e845a 100644 --- a/prms/glacr_melt.f90 +++ b/prms/glacr_melt.f90 @@ -176,7 +176,7 @@ INTEGER FUNCTION glacrdecl() & 'inches', Basin_gl_top_gain)/=0 ) CALL read_error(3, 'basin_gl_top_gain') IF ( declvar(MODNAME, 'basin_gl_ice_melt', 'one', 1, 'double', & - & 'Basin area-weighted glacier ice (firn) melt coming out of termini of all glaciers and glrettes', & + & 'Basin area-weighted glacier ice (no snow) melt coming out of termini of all glaciers and glrettes', & & 'inches', Basin_gl_ice_melt)/=0 ) CALL read_error(3, 'basin_gl_ice_melt') ALLOCATE ( Gl_mb_yrcumul(Nhru) ) diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index 4f7dbb74..5083e4bb 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -153,118 +153,118 @@ INTEGER FUNCTION snodecl() ! Glacier declares IF ( Glacier_flag==1 .OR. Model==99 ) THEN + ALLOCATE ( Ann_tempc(Nhru) ) + IF ( declvar(MODNAME, 'ann_tempc', 'nhru', Nhru, 'real', & + & 'Current average year air temperature over HRU', & + & 'degrees Celsius', Ann_tempc)/=0 ) CALL read_error(3, 'ann_tempc') + IF ( declvar(MODNAME, 'yrdays5', 'one', 1, 'integer', & & 'Number of days since last 5 year mark', & & 'none', Yrdays5)/=0 ) CALL read_error(3, 'yrdays5') ALLOCATE ( Glacr_freeh2o_capm(Nhru) ) IF ( declvar(MODNAME, 'glacr_freeh2o_capm', 'nhru', Nhru, 'real', & - & 'Free-water holding capacity of glacier ice, changes to 0 if active layer melts', & + & 'Free-water holding capacity of glacier or glacierette ice, changes to 0 if active layer melts', & & 'decimal fraction', Glacr_freeh2o_capm)/=0 ) CALL read_error(3, 'glacr_freeh2o_capm') ALLOCATE ( Glacrb_melt(Nhru) ) IF ( declvar(MODNAME, 'glacrb_melt', 'nhru', Nhru, 'real', & - 'Glacier basal melt, goes to soil', & + 'Glacier or glacierette basal melt, goes to soil', & 'inches/day', Glacrb_melt)/=0 ) CALL read_error(3, 'glacrb_melt') - ALLOCATE ( Ann_tempc(Nhru) ) - IF ( declvar(MODNAME, 'ann_tempc', 'nhru', Nhru, 'real', & - & 'Current average year air temperature overs HRU', & - & 'degrees Celsius', Ann_tempc)/=0 ) CALL read_error(3, 'ann_tempc') - ALLOCATE ( Glacr_air_5avtemp(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_5avtemp', 'nhru', Nhru, 'real', & - & 'Current 5-yr average summer (June July Aug) air temperature over glacier or glrette HRU', & + & 'Current 5-yr average summer (June July Aug) air temperature over glacier or glacierette HRU', & & 'degrees Celsius', Glacr_air_5avtemp)/=0 ) CALL read_error(3, 'glacr_air_5avtemp') ALLOCATE ( Glacr_air_5avtemp1(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_5avtemp1', 'nhru', Nhru, 'real', & - & 'First 5-yr average summer temperature over glacier or glrette HRU', & + & 'First 5-yr average summer temperature over glacier or glacierette HRU', & & 'degrees Celsius', Glacr_air_5avtemp1)/=0 ) CALL read_error(3, 'glacr_air_5avtemp1') ALLOCATE ( Glacr_air_deltemp(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_deltemp', 'nhru', Nhru, 'real', & - & 'Change in 5-yr average air temperature over glacier or glrette HRU from first', & + & 'Change in 5-yr average air temperature over glacier or glacierette HRU from first', & & 'degrees Celsius', Glacr_air_deltemp)/=0 ) CALL read_error(3, 'glacr_air_deltemp') ALLOCATE ( Glacr_5avsnow(Nhru) ) IF ( declvar(MODNAME, 'glacr_5avsnow', 'nhru', Nhru, 'real', & - & 'Current 5-yr average snow over glacier or glrette HRU', & + & 'Current 5-yr average snow over glacier or glacierette HRU', & & 'inches/yr', Glacr_5avsnow)/=0 ) CALL read_error(3, 'glacr_5avsnow') ALLOCATE ( Glacr_5avsnow1(Nhru) ) IF ( declvar(MODNAME, 'glacr_5avsnow1', 'nhru', Nhru, 'real', & - & 'First 5-yr average snow over glacier or glrette HRU', & + & 'First 5-yr average snow over glacier or glacierette HRU', & & 'inches/yr', Glacr_5avsnow1)/=0 ) CALL read_error(3, 'glacr_5avsnow1') ALLOCATE ( Glacr_delsnow(Nhru) ) IF ( declvar(MODNAME, 'glacr_delsnow', 'nhru', Nhru, 'real', & - & 'Change in 5-yr average snow over glacier or glrette HRU from first', & + & 'Change in 5-yr average snow over glacier or glacierette HRU from first', & & 'inches/yr', Glacr_delsnow)/=0 ) CALL read_error(3, 'glacr_delsnow') ALLOCATE ( Glacr_pk_temp(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_temp', 'nhru', Nhru, 'real', & - & 'Temperature of the glacier on each HRU', & + & 'Temperature of the glacier or glacierette on each HRU', & & 'degrees Celsius', Glacr_pk_temp)/=0 ) CALL read_error(3, 'glacr_pk_temp') ALLOCATE ( Glacr_pk_def(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_def', 'nhru', Nhru, 'real', & - & 'Heat deficit, amount of heat necessary to make the glacier snowpack isothermal at 0 degrees Celsius', & + & 'Heat deficit, amount of heat necessary to make the glacier or or glacierette snowpack isothermal at 0 degrees Celsius', & & 'Langleys', Glacr_pk_def)/=0 ) CALL read_error(3, 'glacr_pk_def') ALLOCATE ( Glacr_pk_den(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_den', 'nhru', Nhru, 'real', & - & 'Density of the icepack on each glacier HRU, hard-coded to equal 0.917', & + & 'Density of the icepack on each glacier or glacierette HRU, hard-coded to equal 0.917', & & 'gm/cm3', Glacr_pk_den)/=0 ) CALL read_error(3, 'glacr_pk_den') ALLOCATE ( Glacr_albedo(Nhru) ) IF ( declvar(MODNAME, 'glacr_albedo', 'nhru', Nhru, 'real', & - & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier HRU', & + & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier or glacierette HRU', & & 'decimal fraction', Glacr_albedo)/=0 ) CALL read_error(3, 'glacr_albedo') ALLOCATE ( Glacr_evap(Nhru) ) IF ( declvar(MODNAME, 'glacr_evap', 'nhru', Nhru, 'real', & - & 'Evaporation and sublimation from icepack on each glacier HRU', & + & 'Evaporation and sublimation from icepack on each glacier or glacierette HRU', & & 'inches', Glacr_evap)/=0 ) CALL read_error(3, 'glacr_evap') ALLOCATE ( Glacrmelt(Nhru) ) IF ( declvar(MODNAME, 'glacrmelt', 'nhru', Nhru, 'real', & - & 'Melt from icepack on each glacier HRU, includes rain water that does not absorb', & + & 'Melt from icepack on each glacier or glacierette HRU, includes rain water that does not absorb', & & 'inches', Glacrmelt)/=0 ) CALL read_error(3, 'glacrmelt') ALLOCATE ( Glacr_pkwater_equiv(Nhru) ) IF ( declvar(MODNAME, 'glacr_pkwater_equiv', 'nhru', Nhru, 'double', & - & 'Icepack water equivalent on each glacier HRU', & + & 'Icepack water equivalent on each glacier or glacierette HRU', & & 'inches', Glacr_pkwater_equiv)/=0 ) CALL read_error(3, 'glacr_pkwater_equiv') ALLOCATE ( Glacr_pkwater_ante(Nhru) ) IF ( declvar(MODNAME, 'glacr_pkwater_ante', 'nhru', Nhru, 'double', & - & 'Antecedent icepack water equivalent on each glacier HRU', & + & 'Antecedent icepack water equivalent on each glacier or glacierette HRU', & & 'inches', Glacr_pkwater_ante)/=0 ) CALL read_error(3, 'glacr_pkwater_ante') ALLOCATE ( Glacrcov_area(Nhru) ) IF ( declvar(MODNAME, 'glacrcov_area', 'nhru', Nhru, 'real', & - & 'Ice-covered area on each glacier HRU or HRU with glacierette at start of step', & + & 'Ice-covered area (no snowpack) on each glacier HRU or HRU with glacierette at start of step', & & 'decimal fraction', Glacrcov_area)/=0 ) CALL read_error(3, 'glacrcov_area') ALLOCATE ( Glacr_pk_ice(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_ice', 'nhru', Nhru, 'real', & - & 'Storage of frozen water in the icepack on each glacier HRU', & + & 'Storage of frozen water in the icepack on each glacier or glacierette HRU', & & 'inches', Glacr_pk_ice)/=0 ) CALL read_error(3, 'glacr_pk_ice') ALLOCATE ( Glacr_freeh2o(Nhru) ) IF ( declvar(MODNAME, 'glacr_freeh2o', 'nhru', Nhru, 'real', & - & 'Storage of free liquid water in the icepack on each glacier HRU', & + & 'Storage of free liquid water in the icepack on each glacier or glacierette HRU', & & 'inches', Glacr_freeh2o)/=0 ) CALL read_error(3, 'glacr_freeh2o') ALLOCATE ( Glacr_pk_depth(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_depth', 'nhru', Nhru, 'double', & - & 'Depth of icepack on each glacier HRU, make essentially infinite', & + & 'Depth of icepack on each glacier or glacierette HRU, make essentially infinite', & & 'inches', Glacr_pk_depth)/=0 ) CALL read_error(3, 'glacr_pk_depth') ALLOCATE ( Glacr_pss(Nhru) ) IF ( declvar(MODNAME, 'glacr_pss', 'nhru', Nhru, 'double', & - & 'Previous glacier pack water equivalent plus new ice', & + & 'Previous glacier or glacierette pack water equivalent plus new ice', & & 'inches', Glacr_pss)/=0 ) CALL read_error(3, 'glacr_pss') ALLOCATE ( Glacr_pst(Nhru) ) @@ -273,7 +273,7 @@ INTEGER FUNCTION snodecl() & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & - & 'Basin area-weighted average snow and glacier and glrette covered area', & + & 'Basin area-weighted average snow and glacier and glacierette covered area', & & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') ENDIF diff --git a/prmsRip/snowcompCfgim.f90 b/prmsRip/snowcompCfgim.f90 index f45db19a..ba9c90f8 100644 --- a/prmsRip/snowcompCfgim.f90 +++ b/prmsRip/snowcompCfgim.f90 @@ -174,82 +174,82 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Glacr_freeh2o_capm(Nhru) ) IF ( declvar(MODNAME, 'glacr_freeh2o_capm', 'nhru', Nhru, 'real', & - & 'Free-water holding capacity of glacier ice, changes to 0 if active layer melts', & + & 'Free-water holding capacity of glacier or glacierette ice, changes to 0 if active layer melts', & & 'decimal fraction', Glacr_freeh2o_capm)/=0 ) CALL read_error(3, 'glacr_freeh2o_capm') ALLOCATE ( Glacrb_melt(Nhru) ) IF ( declvar(MODNAME, 'glacrb_melt', 'nhru', Nhru, 'real', & - 'Glacier basal melt, goes to soil', & + 'Glacier or glacierette basal melt, goes to soil', & 'inches/day', Glacrb_melt)/=0 ) CALL read_error(3, 'glacrb_melt') ALLOCATE ( Glacr_air_5avtemp(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_5avtemp', 'nhru', Nhru, 'real', & - & 'Current 5-yr average summer (June July Aug) air temperature over glacier or glrette HRU', & + & 'Current 5-yr average summer (June July Aug) air temperature over glacier or glacierette HRU', & & 'degrees Celsius', Glacr_air_5avtemp)/=0 ) CALL read_error(3, 'glacr_air_5avtemp') ALLOCATE ( Glacr_air_5avtemp1(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_5avtemp1', 'nhru', Nhru, 'real', & - & 'First 5-yr average summer temperature over glacier or glrette HRU', & + & 'First 5-yr average summer temperature over glacier or glacierette HRU', & & 'degrees Celsius', Glacr_air_5avtemp1)/=0 ) CALL read_error(3, 'glacr_air_5avtemp1') ALLOCATE ( Glacr_air_deltemp(Nhru) ) IF ( declvar(MODNAME, 'glacr_air_deltemp', 'nhru', Nhru, 'real', & - & 'Change in 5-yr average air temperature over glacier or glrette HRU from first', & + & 'Change in 5-yr average air temperature over glacier or glacierette HRU from first', & & 'degrees Celsius', Glacr_air_deltemp)/=0 ) CALL read_error(3, 'glacr_air_deltemp') ALLOCATE ( Glacr_5avsnow(Nhru) ) IF ( declvar(MODNAME, 'glacr_5avsnow', 'nhru', Nhru, 'real', & - & 'Current 5-yr average snow over glacier or glrette HRU', & + & 'Current 5-yr average snow over glacier or glacierette HRU', & & 'inches/yr', Glacr_5avsnow)/=0 ) CALL read_error(3, 'glacr_5avsnow') ALLOCATE ( Glacr_5avsnow1(Nhru) ) IF ( declvar(MODNAME, 'glacr_5avsnow1', 'nhru', Nhru, 'real', & - & 'First 5-yr average snow over glacier or glrette HRU', & + & 'First 5-yr average snow over glacier or glacierette HRU', & & 'inches/yr', Glacr_5avsnow1)/=0 ) CALL read_error(3, 'glacr_5avsnow1') ALLOCATE ( Glacr_delsnow(Nhru) ) IF ( declvar(MODNAME, 'glacr_delsnow', 'nhru', Nhru, 'real', & - & 'Change in 5-yr average snow over glacier or glrette HRU from first', & + & 'Change in 5-yr average snow over glacier or glacierette HRU from first', & & 'inches/yr', Glacr_delsnow)/=0 ) CALL read_error(3, 'glacr_delsnow') ALLOCATE ( Glacr_pk_temp(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_temp', 'nhru', Nhru, 'real', & - & 'Temperature of the glacier on each HRU', & + & 'Temperature of the glacier or glacierette on each HRU', & & 'degrees Celsius', Glacr_pk_temp)/=0 ) CALL read_error(3, 'glacr_pk_temp') ALLOCATE ( Glacr_pk_def(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_def', 'nhru', Nhru, 'real', & - & 'Heat deficit, amount of heat necessary to make the glacier snowpack isothermal at 0 degrees Celsius', & + & 'Heat deficit, amount of heat necessary to make the glacier or or glacierette snowpack isothermal at 0 degrees Celsius', & & 'Langleys', Glacr_pk_def)/=0 ) CALL read_error(3, 'glacr_pk_def') ALLOCATE ( Glacr_pk_den(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_den', 'nhru', Nhru, 'real', & - & 'Density of the icepack on each glacier HRU, hard-coded to equal 0.917', & + & 'Density of the icepack on each glacier or glacierette HRU, hard-coded to equal 0.917', & & 'gm/cm3', Glacr_pk_den)/=0 ) CALL read_error(3, 'glacr_pk_den') ALLOCATE ( Glacr_albedo(Nhru) ) IF ( declvar(MODNAME, 'glacr_albedo', 'nhru', Nhru, 'real', & - & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier HRU', & + & 'Ice surface albedo or the fraction of radiation reflected from the icepack surface for each glacier or glacierette HRU', & & 'decimal fraction', Glacr_albedo)/=0 ) CALL read_error(3, 'glacr_albedo') ALLOCATE ( Glacr_evap(Nhru) ) IF ( declvar(MODNAME, 'glacr_evap', 'nhru', Nhru, 'real', & - & 'Evaporation and sublimation from icepack on each glacier HRU', & + & 'Evaporation and sublimation from icepack on each glacier or glacierette HRU', & & 'inches', Glacr_evap)/=0 ) CALL read_error(3, 'glacr_evap') ALLOCATE ( Glacrmelt(Nhru) ) IF ( declvar(MODNAME, 'glacrmelt', 'nhru', Nhru, 'real', & - & 'Melt from icepack on each glacier HRU, includes rain water that does not absorb', & + & 'Melt from icepack on each glacier or glacierette HRU, includes rain water that does not absorb', & & 'inches', Glacrmelt)/=0 ) CALL read_error(3, 'glacrmelt') ALLOCATE ( Glacr_pkwater_equiv(Nhru) ) IF ( declvar(MODNAME, 'glacr_pkwater_equiv', 'nhru', Nhru, 'double', & - & 'Icepack water equivalent on each glacier HRU', & + & 'Icepack water equivalent on each glacier or glacierette HRU', & & 'inches', Glacr_pkwater_equiv)/=0 ) CALL read_error(3, 'glacr_pkwater_equiv') ALLOCATE ( Glacr_pkwater_ante(Nhru) ) IF ( declvar(MODNAME, 'glacr_pkwater_ante', 'nhru', Nhru, 'double', & - & 'Antecedent icepack water equivalent on each glacier HRU', & + & 'Antecedent icepack water equivalent on each glacier or glacierette HRU', & & 'inches', Glacr_pkwater_ante)/=0 ) CALL read_error(3, 'glacr_pkwater_ante') ALLOCATE ( Glacrcov_area(Nhru) ) @@ -259,22 +259,22 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Glacr_pk_ice(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_ice', 'nhru', Nhru, 'real', & - & 'Storage of frozen water in the icepack on each glacier HRU', & + & 'Storage of frozen water in the icepack on each glacier or glacierette HRU', & & 'inches', Glacr_pk_ice)/=0 ) CALL read_error(3, 'glacr_pk_ice') ALLOCATE ( Glacr_freeh2o(Nhru) ) IF ( declvar(MODNAME, 'glacr_freeh2o', 'nhru', Nhru, 'real', & - & 'Storage of free liquid water in the icepack on each glacier HRU', & + & 'Storage of free liquid water in the icepack on each glacier or glacierette HRU', & & 'inches', Glacr_freeh2o)/=0 ) CALL read_error(3, 'glacr_freeh2o') ALLOCATE ( Glacr_pk_depth(Nhru) ) IF ( declvar(MODNAME, 'glacr_pk_depth', 'nhru', Nhru, 'double', & - & 'Depth of icepack on each glacier HRU, make essentially infinite', & + & 'Depth of icepack on each glacier or glacierette HRU, make essentially infinite', & & 'inches', Glacr_pk_depth)/=0 ) CALL read_error(3, 'glacr_pk_depth') ALLOCATE ( Glacr_pss(Nhru) ) IF ( declvar(MODNAME, 'glacr_pss', 'nhru', Nhru, 'double', & - & 'Previous glacier pack water equivalent plus new ice', & + & 'Previous glacier or glacierette pack water equivalent plus new ice', & & 'inches', Glacr_pss)/=0 ) CALL read_error(3, 'glacr_pss') ALLOCATE ( Glacr_pst(Nhru) ) @@ -283,41 +283,9 @@ INTEGER FUNCTION snodecl() & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & - & 'Basin area-weighted average snow and glacier and glrette covered area', & + & 'Basin area-weighted average snow and glacier and glacierette covered area', & & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') - ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) - IF ( declparam(MODNAME, 'glacr_freeh2o_cap', 'nhru', 'real', & - & '0.002', '0.0', '0.01', & - & 'Free-water holding capacity of glacier ice', & - & 'Free-water holding capacity of glacier ice expressed as a' // & - & ' decimal fraction of the frozen water content of the glacier ice (glacr_pk_ice)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glacr_freeh2o_cap') - - ALLOCATE ( Glacr_layer(Nhru) ) - IF ( declparam(MODNAME, 'glacr_layer', 'nhru', 'real', & - & '3.94', '0.0', '590.6', & - & 'Active layer on glacier', & - & 'Active layer is 0 to 15 m (590.6 inches) thick at start of year, when' // & - & ' melts will set daily glacr_pk_temp to 0', & - & 'inches')/=0 ) CALL read_error(1, 'glacr_layer') - - IF ( Init_vars_from_file==0 ) THEN - ALLOCATE ( Glacier_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & - & '0.0', '0.0', '1.0', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') - - ALLOCATE ( Glrette_frac_init(Nhru) ) - IF ( declparam(MODNAME, 'glrette_frac_init', 'nhru', 'real', & - & '0.0', '0.0', '1.0', & - & 'Initial fraction of glacierette (too small for glacier dynamics)', & - & 'Initial fraction of glacierette (too small for glacier dynamics)', & - & 'decimal fraction')/=0 ) CALL read_error(1, 'glrette_frac_init') - - ENDIF ENDIF IF ( Frozen_flag==1 .OR. Model==99 ) THEN @@ -526,8 +494,8 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Albedo_coef(Nhru) ) IF ( declparam(MODNAME, 'albedo_coef', 'nhru', 'real', & & '0.137', '0.1', '0.3', & - & 'Coefficient in calculation of ice albedo', & - & 'Coefficient in calculation of ice albedo', & + & 'Coefficient in calculation of ice albedo for glaciers', & + & 'Coefficient in calculation of ice albedo for glaciers', & & 'none')/=0 ) CALL read_error(1, 'albedo_coef') ALLOCATE ( Albedo_ice(Nhru) ) @@ -536,6 +504,39 @@ INTEGER FUNCTION snodecl() & 'Ice albedo 300 meters below ELA', & & 'Ice albedo 300 meters below ELA', & & 'decimal fraction')/=0 ) CALL read_error(1, 'albedo_ice') + + ALLOCATE ( Glacr_freeh2o_cap(Nhru) ) + IF ( declparam(MODNAME, 'glacr_freeh2o_cap', 'nhru', 'real', & + & '0.002', '0.0', '0.01', & + & 'Free-water holding capacity of glacier ice', & + & 'Free-water holding capacity of glacier ice expressed as a' // & + & ' decimal fraction of the frozen water content of the glacr_pk_ice', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacr_freeh2o_cap') + + ALLOCATE ( Glacr_layer(Nhru) ) + IF ( declparam(MODNAME, 'glacr_layer', 'nhru', 'real', & + & '3.94', '0.0', '590.6', & + & 'Active layer on glacier', & + & 'Active layer is 0 to 15 m (590.6 inches) thick at start of year, when' // & + & ' melts will set daily glacr_pk_temp to 0', & + & 'inches')/=0 ) CALL read_error(1, 'glacr_layer') + + IF ( Init_vars_from_file==0 ) THEN + ALLOCATE ( Glacier_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') + + ALLOCATE ( Glrette_frac_init(Nhru) ) + IF ( declparam(MODNAME, 'glrette_frac_init', 'nhru', 'real', & + & '0.0', '0.0', '1.0', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'Initial fraction of glacierette (too small for glacier dynamics)', & + & 'decimal fraction')/=0 ) CALL read_error(1, 'glrette_frac_init') + + ENDIF ENDIF IF ( declparam(MODNAME, 'den_init', 'one', 'real', & From d8df5c972db323c6a0229050c32a2143f7500a1b Mon Sep 17 00:00:00 2001 From: ashleymedin Date: Sat, 5 Oct 2019 22:54:51 -0500 Subject: [PATCH 47/47] Changing files to agree with documentation, adding some variables to output --- prms/climateflow.f90 | 2 +- prms/glacr_melt.f90 | 102 ++++++++++++++++++++++++-------------- prms/snowcomp.f90 | 6 +-- prmsRip/snowcompCfgim.f90 | 6 +-- prmsRip/srunoffCfgim.f90 | 2 +- 5 files changed, 73 insertions(+), 45 deletions(-) diff --git a/prms/climateflow.f90 b/prms/climateflow.f90 index 62e58485..f41b1af8 100644 --- a/prms/climateflow.f90 +++ b/prms/climateflow.f90 @@ -542,7 +542,7 @@ INTEGER FUNCTION climateflow_decl() IF ( Glacier_flag==1 .OR. Model==99 ) THEN ALLOCATE ( Glacier_frac(Nhru) ) IF ( declvar(MODNAME, 'glacier_frac', 'nhru', Nhru, 'real', & - 'Fraction of glaciation (0=none; 1=100%)', & + 'Fraction of glaciation (0=none; 1=100%) in glacier-capable HRU', & 'decimal fraction', Glacier_frac)/=0 ) CALL read_error(3, 'glacier_frac') ALLOCATE ( Glrette_frac(Nhru) ) diff --git a/prms/glacr_melt.f90 b/prms/glacr_melt.f90 index 313e845a..eba55ca8 100644 --- a/prms/glacr_melt.f90 +++ b/prms/glacr_melt.f90 @@ -27,7 +27,7 @@ ! HRUs with glaciers must have parameter glacier_frac(i)=1, unless they ! are at the terminus of the glacier (in which case they can have ! glacier_frac(i)<1). Hru numbering goes from largest HRU ID at top of glacier to -! smallest at ID at bottom (the way Weasel delineation was designed). The parameter +! smallest ID at bottom (the way Weasel delineation was designed). The parameter ! Glac_HRUnum_down = 1 then in the init function. If the opposite direction, ! then set Glac_HRUnum_down = 0. IDs need to be stacked. ! @@ -54,7 +54,7 @@ MODULE PRMS_GLACR ! Ntp - Number of tops of glaciers, so max glaciers that could ever split in too ! Nhrugl - Number of at glacier-capable hrus INTEGER, SAVE :: Nglres, Ngl, Ntp, Nhrugl, Mbinit_flag, Output_unit, Fraw_unit, All_unit - INTEGER, SAVE :: Seven, Four, Glac_HRUnum_down + INTEGER, SAVE :: Seven, Four, Glac_hrunum_down DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_area_inch2(:) REAL, PARAMETER :: Gravity = 9.8 ! m/s2 REAL, PARAMETER :: Aflow = 1.e-25 ! Pa^-3/s, Farinotti 2009 could be 2.4e-24, could be 1e-26 see Patterson 2010 @@ -69,11 +69,12 @@ MODULE PRMS_GLACR REAL, SAVE, ALLOCATABLE :: Basal_elev(:), Basal_slope(:), Keep_gl(:,:), Prev_outi(:, :), Prev_out(:, :) REAL, SAVE, ALLOCATABLE :: Ode_glacrva_coef(:), Av_basal_slope(:), Av_fgrad(:), Hru_slope_ts(:) REAL, SAVE, ALLOCATABLE :: Hru_mb_yrend(:), Glacr_flow(:), Glacr_slope_init(:), Gl_top_melt(:) + REAL, SAVE, ALLOCATABLE :: Hru_glthick(:) INTEGER, SAVE, ALLOCATABLE :: Top(:), Term(:), Top_tag(:), Ela(:), Order_flowline(:) INTEGER, SAVE, ALLOCATABLE :: Glacr_tag(:), Ikeep_gl(:,:), Tohru(:) DOUBLE PRECISION, SAVE :: Basin_gl_ice_melt, Basin_gl_area, Basin_gl_top_melt DOUBLE PRECISION, SAVE :: Basin_gl_top_gain, Basin_gl_storvol, Basin_gl_storage - DOUBLE PRECISION, SAVE :: Basin_gl_storstart + DOUBLE PRECISION, SAVE :: Basin_gl_storstart, Basin_glthick DOUBLE PRECISION, SAVE, ALLOCATABLE :: Hru_mb_yrcumul(:), Delta_volyr(:), Prev_vol(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Prev_area(:), Gl_mb_yrcumul(:), Gl_area(:) DOUBLE PRECISION, SAVE, ALLOCATABLE :: Gl_mb_cumul(:), Glnet_ar_delta(:), Gl_mbc_yrend(:) @@ -167,16 +168,25 @@ INTEGER FUNCTION glacrdecl() & 'HRU slope for timestep, which can change for glaciers', & & 'decimal fraction', Hru_slope_ts)/=0 ) CALL read_error(3, 'hru_slope_ts') + ALLOCATE ( Hru_glthick(Nhru) ) + IF ( declvar(MODNAME, 'hru_glthick', 'nhru', Nhru, 'real', & + & 'HRU thickness for glacier, changes through time', & + & 'elev_units', Hru_glthick)/=0 ) CALL read_error(3, 'hru_glthick') + + IF ( declvar(MODNAME, 'basin_glthick', 'one', 1, 'double', & + & 'Basin average thickness of glaciers (glacierettes not included)', & + & 'elev_units', Basin_glthick)/=0 ) CALL read_error(3, 'basin_glthick') + IF ( declvar(MODNAME, 'basin_gl_top_melt', 'one', 1, 'double', & - & 'Basin area-weighted glacier surface melt (snow, ice and rain) coming out of termini of all glaciers and glrettes', & + & 'Basin area-weighted glacier surface melt (snow, ice and rain) coming out of termini of all glaciers and glacierettes', & & 'inches', Basin_gl_top_melt)/=0 ) CALL read_error(3, 'basin_gl_top_melt') IF ( declvar(MODNAME, 'basin_gl_top_gain', 'one', 1, 'double', & - & 'Basin area-weighted glacier surface gain (snow and rain minus evap) for all glaciers and glrettes', & + & 'Basin area-weighted glacier surface gain (snow and rain minus evap) for all glaciers and glacierettes', & & 'inches', Basin_gl_top_gain)/=0 ) CALL read_error(3, 'basin_gl_top_gain') IF ( declvar(MODNAME, 'basin_gl_ice_melt', 'one', 1, 'double', & - & 'Basin area-weighted glacier ice (no snow) melt coming out of termini of all glaciers and glrettes', & + & 'Basin area-weighted glacier ice (no snow) melt coming out of termini of all glaciers and glacierettes', & & 'inches', Basin_gl_ice_melt)/=0 ) CALL read_error(3, 'basin_gl_ice_melt') ALLOCATE ( Gl_mb_yrcumul(Nhru) ) @@ -190,7 +200,7 @@ INTEGER FUNCTION glacrdecl() & 'inches', Gl_mb_cumul)/=0 ) CALL read_error(3, 'gl_mb_cumul') IF ( declvar(MODNAME, 'basin_gl_area', 'one', 1, 'double', & - & 'Basin area-weighted average glacier-covered area', & + & 'Basin area-weighted average glacier and glacierette-covered area', & & 'decimal fraction', Basin_gl_area)/=0 ) CALL read_error(3, 'basin_gl_area') ALLOCATE ( Gl_area(Nhru) ) @@ -300,7 +310,7 @@ INTEGER FUNCTION glacrdecl() ALLOCATE ( Gl_ice_melt(Nhru) ) IF ( declvar(MODNAME, 'gl_ice_melt', 'nhru', Nhru, 'real', & - & 'Amount of glacier ice (firn) melt coming out of terminus of glacier, indexed by Glacr_tag', & + & 'Amount of glacier ice (no snow) melt coming out of terminus of glacier, indexed by Glacr_tag', & & 'inches', Gl_ice_melt)/=0 ) CALL read_error(3, 'gl_ice_melt') ALLOCATE ( Basal_elev(Nhru) ) @@ -321,15 +331,15 @@ INTEGER FUNCTION glacrdecl() & 'decimal fraction', Av_basal_slope)/=0 ) CALL read_error(3, 'av_basal_slope') IF ( declvar(MODNAME, 'basin_gl_storage', 'one', 1, 'double', & - & 'Basin area-weighted average storage change in glacier reservoirs', & + & 'Basin area-weighted average storage change in glacier and glacierette reservoirs', & & 'inches', Basin_gl_storage)/=0 ) CALL read_error(3, 'basin_gl_storage') IF ( declvar(MODNAME, 'basin_gl_storstart', 'one', 1, 'double', & - & 'Basin area-weighted average storage estimated start in glacier reservoirs', & + & 'Basin area-weighted average storage estimated start in glacier and glacierette reservoirs', & & 'inches', Basin_gl_storstart)/=0 ) CALL read_error(3, 'basin_gl_storstart') IF ( declvar(MODNAME, 'basin_gl_storvol', 'one', 1, 'double', & - & 'Basin storage volume in glacier storage reservoirs', & + & 'Basin storage volume in glacier and glacierette storage reservoirs', & & 'acre-inches', Basin_gl_storvol)/=0 ) CALL read_error(3, 'basin_gl_storvol') IF ( Init_vars_from_file==0 ) THEN @@ -425,6 +435,12 @@ INTEGER FUNCTION glacrdecl() 'Average HRU glacierette ablation zones elevation range or ~ median-min elev', & 'elev_units')/=0 ) CALL read_error(1, 'abl_elev_range') + IF ( declparam(MODNAME, 'glac_hrunum_down', 'one', 'integer', & + '1', '0', '1', & + '1 is Glacier HRU numbering from largest HRU ID at glacier top to smallest ID at terminus, O opposite, IDs stacked', & + '1 is Glacier HRU numbering from largest HRU ID at glacier top to smallest ID at terminus, O opposite, IDs stacked', & + 'none')/=0 ) CALL read_error(1, 'glac_hrunum_down') + IF (Mbinit_flag==1) THEN ALLOCATE ( Basal_elev_set(Nhru) ) IF ( declparam(MODNAME, 'basal_elev_set', 'nhru', 'real', & @@ -484,6 +500,7 @@ INTEGER FUNCTION glacrinit() IF ( getparam(MODNAME, 'abl_elev_range', Nhru, 'real', Abl_elev_range)/=0 ) CALL read_error(2, 'abl_elev_range') IF ( getparam(MODNAME, 'tohru', Nhru, 'integer', Tohru)/=0 ) CALL read_error(2, 'tohru') IF ( getparam(MODNAME, 'hru_slope', Nhru, 'real', Hru_slope)/=0 ) CALL read_error(2, 'hru_slope') + IF ( getparam(MODNAME, 'glac_hrunum_down', 1, 'one', Glac_hrunum_down)/=0 ) CALL read_error(2, 'glac_hrunum_down') IF ( Init_vars_from_file==0 ) THEN Alt_above_ela = 0.0 Prev_out = 0.0 @@ -514,8 +531,14 @@ INTEGER FUNCTION glacrinit() IF ( getparam(MODNAME, 'basal_slope_set', Nhru, 'real', Basal_slope_set)/=0 ) CALL read_error(2, 'basal_slope_set') Basal_slope = Basal_slope_set ENDIF + Basin_glthick = 0.0D0 + DO jj = 1, Active_hrus + j = Hru_route_order(jj) + Hru_glthick(j) = Hru_elev_ts(j) - Basal_elev(j) + Basin_glthick = Basin_glthick + Hru_glthick(j)*Hru_area(j)*Acre_inch2 + ENDDO Av_basal_slope = 0.0 - Glacr_elev_init = Hru_elev_ts + Glacr_elev_init = Hru_elev_ts !if Mbinit_flag>=2, this will change Glacr_slope_init = Hru_slope_ts Av_fgrad = 0.0 Basin_gl_top_melt = 0.0D0 @@ -529,10 +552,6 @@ INTEGER FUNCTION glacrinit() Basin_gl_storvol = 0.0D0 ENDIF - Glac_HRUnum_down = 1 ! 1 is the way Weasel delineation was designed - ! 1 is terminus is smallest ID and top is largest. IDs are stacked. - ! 0 is terminus is smallest ID and top is largest. IDs are stacked. - hru_flowline = 0 toflowline = 0 str_idm = 1.0E15 @@ -556,9 +575,9 @@ INTEGER FUNCTION glacrinit() count = 1 !has at least one glacier glacier_frac_use(j) = 1.0 !should be end of extensions or branches-- will fail if don't set up with indices stacked - IF ( Glac_HRUnum_down==1) THEN + IF ( Glac_hrunum_down==1) THEN IF (Tohru(j)/=j-1 ) glacier_frac_use(j) = 0.999 - ELSEIF ( Glac_HRUnum_down==0) THEN + ELSEIF ( Glac_hrunum_down==0) THEN IF (Tohru(j)/=j+1 ) glacier_frac_use(j) = 0.999 ENDIF ENDIF @@ -722,9 +741,9 @@ INTEGER FUNCTION glacrinit() glacier_frac_use(j)= Glacier_frac(j) !should be end of extensions or branches-- will fail if don't set up with indices stacked ! making it so has no connected branches because branching bottom calculations don't work - IF ( Glac_HRUnum_down==1) THEN + IF ( Glac_hrunum_down==1) THEN IF (Tohru(j)/=j-1 .AND. glacier_frac_use(j)==1.0 ) glacier_frac_use(j) = 0.999 - ELSEIF ( Glac_HRUnum_down==0) THEN + ELSEIF ( Glac_hrunum_down==0) THEN IF (Tohru(j)/=j+1 .AND. glacier_frac_use(j)==1.0 ) glacier_frac_use(j) = 0.999 ENDIF ENDIF @@ -782,6 +801,8 @@ INTEGER FUNCTION glacrinit() Gl_area(p) = curr_area(Term(o))/Acre_inch2 !print*, 'Glacr_tag', p, ', area acres branches=', Gl_area(p), ', terminus HRU=', Term(o) ENDDO +!average thickness over glaciers only so take area early + Basin_glthick = Basin_glthick/Basin_gl_area!top and bottom /Acre_inch2*Basin_area_inv to give real thing, cancel DO i = 1, Active_hrus j = Hru_route_order(i) IF ( Hru_type(j)==1 ) Basin_gl_area = Basin_gl_area + DBLE(Glrette_frac(j))*Hru_area_inch2(j) @@ -797,9 +818,8 @@ INTEGER FUNCTION glacrinit() ENDDO ENDDO !******Compute basin weighted averages - ! Basin_area_inv is in 1/acres, Basin_gl_area in inches squared + ! Basin_area_inv is in 1/acres, Basin_gl_area in inches squared, put in fraction Basin_gl_area = (Basin_gl_area/Acre_inch2)*Basin_area_inv - !print*, 'Basin area acres=', 1.0/Basin_area_inv ENDIF ! skip all if no glaciers ! @@ -847,6 +867,7 @@ INTEGER FUNCTION glacrrun() Gl_mbc_yrend = 0.0D0 Av_basal_slope = 0.0 Av_fgrad = 0.0 + Basin_glthick = 0.0D0 Hru_slope_ts = Basal_slope Alt_above_ela = 0.0 ! doesn't matter if no glaciers dosol = recompute_soltab() ! change soltab tables for Hru_slope_ts @@ -967,7 +988,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) ENDIF ENDDO ! ELA calculations - IF ( MBinit_flag==3 ) THEN + IF ( Mbinit_flag==3 ) THEN doela = compute_ela_aar() !want steady state ELA estimation for fraw calc DO j = 1, Ntp ela_elevt(j)=Hru_elev(Ela(j)) !will scale inside subroutine, want initial one without _ts @@ -993,9 +1014,9 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) glacier_frac_use(j)= Glacier_frac(j) !should be end of extensions or branches-- will fail if don't set up with indices stacked ! making it so has no connected branches because branching bottom calculations don't work - IF ( Glac_HRUnum_down==1) THEN + IF ( Glac_hrunum_down==1) THEN IF (Tohru(j)/=j-1 .AND. glacier_frac_use(j)==1.0 ) glacier_frac_use(j) = 0.999 - ELSEIF ( Glac_HRUnum_down==0) THEN + ELSEIF ( Glac_hrunum_down==0) THEN IF (Tohru(j)/=j+1 .AND. glacier_frac_use(j)==1.0 ) glacier_frac_use(j) = 0.999 ENDIF ENDIF @@ -1061,8 +1082,9 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) aream(cell_id(i)) = 0.0 !indexed by terminus HRU ENDDO ENDIF +! Need to do this so that Hru_elev_ts is actually the same as Hru_elev before melt in terminus, won't matter if hru_elev = basal_elev +! Do for all dobot cases, all Mbinit_flag choices DO i = 1, Nhrugl -! Need to do this so that Hru_elev_ts is actually the same as Hru_elev before melt in terminus IF ( Glacier_frac(cell_id(i))>NEARZERO) THEN !only effects terminus Glacr_elev_init(cell_id(i)) = (Hru_elev(cell_id(i)) - (1.0-Glacier_frac(cell_id(i))) & & *Basal_elev((cell_id(i))))/Glacier_frac(cell_id(i)) @@ -1318,11 +1340,17 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) ENDIF ENDDO ENDDO + Basin_glthick = 0.0D0 DO jj = 1, Active_hrus j = Hru_route_order(jj) IF ( Hru_type(j)==4 ) THEN curr_area(j) = curr_area(j) + add_area(j) curr_areap(j) = curr_areap(j) + add_areap(j) +! have bottom, compute Hru_elev_ts related stuff + Hru_elev_ts(j) = Glacier_frac(j)*Glacr_elev_init(j) + (1.0-Glacier_frac(j))*Basal_elev(j) + Hru_slope_ts(j) = Glacier_frac(j)*Glacr_slope_init(j) + (1.0-Glacier_frac(j))*Basal_slope(j) + Hru_glthick(j) = Hru_elev_ts(j) - Basal_elev(j) + Basin_glthick = Basin_glthick + Hru_glthick(j)*Hru_area_inch2(j) ENDIF ENDDO Gl_area = 0.D0 @@ -1334,14 +1362,14 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) Basin_gl_area = Basin_gl_area + curr_area(Term(o)) !print*, 'Glacr_tag', p, ', area acres', Nowyear,' =', Gl_area(p), ', terminus HRU=', Term(o) ENDDO -! have bottom, compute Hru_elev_ts related stuff +!average thickness over glaciers only so take area early + Basin_glthick = Basin_glthick/Basin_gl_area!top and bottom /Acre_inch2*Basin_area_inv to give real thing, cancel + DO ii = 1, Ntp DO i = 1, Active_hrus j = Hru_route_order(i) IF ( Hru_type(j)==4 ) THEN IF ( Top_tag(j)==Top_tag(Top(ii)) ) Alt_above_ela(j) = Hru_elev_ts(j)- Hru_elev_ts(Ela(ii)) - Hru_elev_ts(j) = Glacier_frac(j)*Glacr_elev_init(j) + (1.0-Glacier_frac(j))*Basal_elev(j) - Hru_slope_ts(j) = Glacier_frac(j)*Glacr_slope_init(j) + (1.0-Glacier_frac(j))*Basal_slope(j) ENDIF ENDDO ENDDO @@ -1396,10 +1424,9 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) ! !******Compute basin weighted averages (to units of fraction area) -! Basin_area_inv is in 1/acres, Basin_area_inv is in 1/acres, Basin_gl_area in inches squared +! Basin_area_inv is in 1/acres, Basin_gl_area in inches squared, put in fraction Basin_gl_area = (Basin_gl_area/Acre_inch2)*Basin_area_inv ENDIF !get out of start-of-year computations - ! ! Melt runoff calculations, every day DO i = 1, Active_hrus @@ -1431,6 +1458,7 @@ INTEGER FUNCTION comp_glsurf(glacr_exist, glrette_exist) gl_snow = Glrette_frac(j)*(Net_rain(j)+Net_Snow(j)) !Pk_precip is zero if no snow, so don't use gl_evap = Glrette_frac(j)*(Snow_evap(j) + Glacr_evap(j)/Glrette_frac(j)) gl_gain(j) = DBLE(gl_snow - gl_evap) + Basin_gl_top_gain = Basin_gl_top_gain + gl_gain(j)*Hru_area_inch2(j) ENDIF ENDIF ENDDO @@ -2409,7 +2437,7 @@ SUBROUTINE getf_fgrad(ela_elev,len_str,sh,urawe,uraw,xraw,hvec,frawe,fraw,fd) ela_i = 0 ela_x = 0.0 fd = 0.0 - IF (Mbinit_flag==1) THEN !use climate data for mass balance + IF (Mbinit_flag==2) THEN !use climate data for mass balance IF (len_str>1) THEN frawe(1) = fraw(1)- (fraw(2)-fraw(1))/hvec(2)*hvec(1) frawe(2) = fraw(len_str) + (fraw(len_str)-fraw(len_str-1))/hvec(len_str)*(1-xraw(len_str)) @@ -2417,7 +2445,7 @@ SUBROUTINE getf_fgrad(ela_elev,len_str,sh,urawe,uraw,xraw,hvec,frawe,fraw,fd) frawe(1) = fraw(1) frawe(2) = fraw(1) ENDIF - ELSEIF (Mbinit_flag==2) THEN !Farinotti method, using ela_x + ELSEIF (Mbinit_flag==3) THEN !Farinotti method, using ela_x DO i = 1, len_str IF (ela_elev-uraw(i)<0.0001) THEN !has rounding errors ela_x=xraw(i) @@ -3055,7 +3083,7 @@ SUBROUTINE glacr_restart(In_out) WRITE ( Restart_outunit ) MODNAME WRITE ( Restart_outunit ) Nhrugl, Basin_gl_top_melt, Gl_mb_yrcumul WRITE ( Restart_outunit ) Gl_mb_cumul, Glnet_ar_delta, Gl_mbc_yrend - WRITE ( Restart_outunit ) Basin_gl_top_gain + WRITE ( Restart_outunit ) Basin_gl_top_gain, Basin_glthick WRITE ( Restart_outunit ) Basin_gl_area, Gl_area, Basin_gl_ice_melt WRITE ( Restart_outunit ) Hru_glres_melt, Basin_gl_storstart WRITE ( Restart_outunit ) Gl_top_melt, Basin_gl_storage, Basin_gl_storvol @@ -3078,13 +3106,13 @@ SUBROUTINE glacr_restart(In_out) WRITE ( Restart_outunit ) Glacr_tag WRITE ( Restart_outunit ) Delta_volyr WRITE ( Restart_outunit ) Hru_mb_yrcumul - WRITE ( Restart_outunit ) Hru_slope_ts + WRITE ( Restart_outunit ) Hru_slope_ts, Hru_glthick ELSE READ ( Restart_inunit ) module_name CALL check_restart(MODNAME, module_name) READ ( Restart_inunit ) Nhrugl, Basin_gl_top_melt, Gl_mb_yrcumul READ ( Restart_inunit ) Gl_mb_cumul, Glnet_ar_delta, Gl_mbc_yrend - READ ( Restart_inunit ) Basin_gl_top_gain + READ ( Restart_inunit ) Basin_gl_top_gain, Basin_glthick READ ( Restart_inunit ) Basin_gl_area, Gl_area, Basin_gl_ice_melt READ ( Restart_inunit ) Hru_glres_melt, Basin_gl_storstart READ ( Restart_inunit ) Gl_top_melt, Basin_gl_storage, Basin_gl_storvol @@ -3107,6 +3135,6 @@ SUBROUTINE glacr_restart(In_out) READ ( Restart_inunit ) Glacr_tag READ ( Restart_inunit ) Delta_volyr READ ( Restart_inunit ) Hru_mb_yrcumul - READ ( Restart_inunit ) Hru_slope_ts + READ ( Restart_inunit ) Hru_slope_ts, Hru_glthick ENDIF END SUBROUTINE glacr_restart diff --git a/prms/snowcomp.f90 b/prms/snowcomp.f90 index 5083e4bb..19b230dd 100644 --- a/prms/snowcomp.f90 +++ b/prms/snowcomp.f90 @@ -273,7 +273,7 @@ INTEGER FUNCTION snodecl() & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & - & 'Basin area-weighted average snow and glacier and glacierette covered area', & + & 'Basin area-weighted average snow and glacier and glacierette covered area for calibration to satellites', & & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') ENDIF @@ -495,8 +495,8 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Glacier_frac_init(Nhru) ) IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & & '0.0', '0.0', '1.0', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'Inital fraction of glaciation (0=none; 1=100%) in glacier-capable HRU', & + & 'Inital fraction of glaciation (0=none; 1=100%) in glacier-capable HRU', & & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') ALLOCATE ( Glrette_frac_init(Nhru) ) diff --git a/prmsRip/snowcompCfgim.f90 b/prmsRip/snowcompCfgim.f90 index ba9c90f8..b32519ff 100644 --- a/prmsRip/snowcompCfgim.f90 +++ b/prmsRip/snowcompCfgim.f90 @@ -283,7 +283,7 @@ INTEGER FUNCTION snodecl() & 'inches', Glacr_pst)/=0 ) CALL read_error(3, 'glacr_pst') IF ( declvar(MODNAME, 'basin_snowicecov', 'one', 1, 'double', & - & 'Basin area-weighted average snow and glacier and glacierette covered area', & + & 'Basin area-weighted average snow and glacier and glacierette covered area for calibration to satellites', & & 'decimal fraction', Basin_snowicecov)/=0 ) CALL read_error(3, 'basin_snowicecov') ENDIF @@ -525,8 +525,8 @@ INTEGER FUNCTION snodecl() ALLOCATE ( Glacier_frac_init(Nhru) ) IF ( declparam(MODNAME, 'glacier_frac_init', 'nhru', 'real', & & '0.0', '0.0', '1.0', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & - & 'Inital fraction of glaciation (0=none; 1=100%)', & + & 'Inital fraction of glaciation (0=none; 1=100%) in glacier-capable HRU', & + & 'Inital fraction of glaciation (0=none; 1=100%) in glacier-capable HRU', & & 'decimal fraction')/=0 ) CALL read_error(1, 'glacier_frac_init') ALLOCATE ( Glrette_frac_init(Nhru) ) diff --git a/prmsRip/srunoffCfgim.f90 b/prmsRip/srunoffCfgim.f90 index 8c6e2893..6a1e2c67 100644 --- a/prmsRip/srunoffCfgim.f90 +++ b/prmsRip/srunoffCfgim.f90 @@ -823,7 +823,7 @@ INTEGER FUNCTION srunoffrun() Cfgi(i) = Cfgi_decay*Cfgi_prev(i) - trad*( 2.71828**(-0.4*(cfgi_k*depth_cm+cfgi_kg*depthg_cm)) ) IF ( active_glacier==1 ) THEN Cfgi(i) = 0.0 !if glacier over, want ground completely unfrozen, or below threshold, infiltration - IF ( Glacier_frac(i)<1.0 ) Cfgi(i) = Cfgi_thrshld ! glacier with some open fraction + IF ( Glacier_frac(i)<1.0 ) Cfgi(i) = Cfgi_thrshld ! glacier with some open fraction is frozen tongue ENDIF IF ( Cfgi(i)<0.0 ) Cfgi(i) = 0.0 ! If above the threshold to be frozen