From 902ccafd9c9b5be3ef2c2eba00699b61fb5715d6 Mon Sep 17 00:00:00 2001 From: reyns Date: Wed, 19 Nov 2025 09:40:22 +0100 Subject: [PATCH 01/18] UNST-9434 Merge part 1 --- .../src/dflowfm_data/m_flow.f90 | 3 + .../src/dflowfm_data/m_physcoef.f90 | 8 + .../src/dflowfm_data/m_sediment.f90 | 6 + .../src/dflowfm_data/m_waves.f90 | 4 + .../src/dflowfm_data/m_xbeach_data.f90 | 1 + .../src/dflowfm_data/unstruc_model.f90 | 28 + .../dflowfm_kernel/src/dflowfm_gui/zlin.f90 | 1 + .../dflowfm_kernel/compute/compute_dynveg.f90 | 62 ++ .../compute/flow_initimestep.f90 | 7 + .../dflowfm_kernel/compute/getustbcfuhi.f90 | 141 ++-- .../src/dflowfm_kernel/compute/getustwav.f90 | 40 +- .../dflowfm_kernel/compute/getvanrijnwci.f90 | 2 +- .../compute/update_verticalprofiles.f90 | 6 +- .../compute_sediment/bermslopenudging.f90 | 14 +- .../compute_sediment/fm_erosed.f90 | 19 +- .../compute_sediment/fm_fallve.f90 | 3 +- .../compute_sediment/m_fm_bott3d.f90 | 38 +- .../dflowfm_kernel/compute_waves/setwavfu.f90 | 41 +- .../compute_waves/surfbeat/xbeachwaves.f90 | 664 +++++++++--------- .../wave_comp_stokes_velocities.f90 | 2 +- .../dflowfm_kernel/prepost/flow_allocflow.f90 | 11 +- .../dflowfm_kernel/prepost/flow_flowinit.f90 | 51 +- .../prepost/flow_sedmorinit.f90 | 7 +- .../packages/morphology_io/src/rdtrafrm.f90 | 20 +- .../morphology_kernel/src/bedbc2004.f90 | 2 +- .../morphology_kernel/src/calseddf1993.f90 | 2 +- .../packages/morphology_kernel/src/trab19.f90 | 18 +- .../packages/morphology_kernel/src/trab20.f90 | 18 +- 28 files changed, 711 insertions(+), 508 deletions(-) create mode 100644 src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 index 81101b0d9fa..f3613312e3f 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 @@ -329,6 +329,9 @@ module m_flow ! flow arrays-999 real(kind=dp), allocatable, target :: cftrtfac(:) !< array for optional multiplication factor for trachytopes's returned roughness values integer :: jacftrtfac !< Whether or not (1/0) a multiplication factor field was specified for trachytopes's Chezy roughness values. real(kind=dp), allocatable :: czu(:) !< array for chezy friction at flow links {"location": "edge", "shape": ["lnx"]} + real(kind=dp), allocatable :: frcu0(:) !< array for chezy friction at flow links at start of the run {"location": "edge", "shape": ["lnx"]} + logical, allocatable :: dynveg(:) !< vegetation present or not {"location": "edge", "shape": ["lnx"]} + integer, allocatable :: kcsveg(:) !< in vegpol or not {"location": "edge", "shape": ["lnx"]} real(kind=dp), allocatable, target :: frculin(:) !< friction coefficient set by initial fields ( todo mag later ook single real worden) integer, allocatable :: ifrcutp(:) !< friction coefficient type initial fields ( todo mag later ook single real worden) real(kind=dp), allocatable, target :: Cdwusp(:) !< Wind friction coefficient at u point set by initial fields ( todo mag later ook single real worden) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 index 880bd7805fe..921556eabe7 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 @@ -51,6 +51,10 @@ module m_physcoef real(kind=dp) :: frcuniroof = 0.030 real(kind=dp) :: frcuni1Dgrounlay !< uniform friction coeff groundlayer real(kind=dp) :: frcmax !< max friction coeff in frcu + integer :: dynroughveg + real(kind=dp) :: frcumin + real(kind=dp) :: droot + real(kind=dp) :: dstem integer :: ifrctypuni !< 0=chezy, 1=manning, 2=white colebrook D3D, 3=white colebrook Waqua (now only 2D) real(kind=dp) :: frcunilin !< uniform friction coeff @@ -174,6 +178,10 @@ subroutine default_physcoef() locsaltmin = 5.0_dp locsaltmax = 10.0_dp NFEntrainmentMomentum = 0 + dynroughveg = 0 + droot = 0.5_dp + dstem = 0.5_dp + frcumin = 2.3e-2_dp end subroutine default_physcoef !> Calculates derived coefficients. diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 index 423a5a8dccf..ba653d3e4e1 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 @@ -91,6 +91,8 @@ module m_sediment logical, allocatable :: bermslopeindexsus(:) !< index where nudging needs to be applied for suspended load real(kind=dp), allocatable :: bermslopecontrib(:, :) !< bermslope nudging sediment transport real(kind=dp), allocatable :: ssccum(:, :) !< water column integrated sediment transport in dry points (kg/s) + real(kind=dp), allocatable :: cumes(:) !< cumulative erosion/sedimentation in link positions + integer :: jased !< Include sediment, 1=Krone, 2=Soulsby van Rijn 2007, 4=Delft3D morphology module integer :: jaseddenscoupling = 0 !< Include sediment in rho 1 = yes , 0 = no integer :: jasubstancedensitycoupling = 0 !< Include Delwaq substances in rho 1 = yes , 0 = no @@ -106,6 +108,8 @@ module m_sediment integer :: jamormergedtuser real(kind=dp) :: upperlimitssc integer :: inmorphopol !< value of the update inside morphopol (only 0 or 1 make sense) + real(kind=dp) :: difparam !< scale diffusion below reference level with settling velocity, Default 10.0 + real(kind=dp) :: difcal !< scale seddif ! !-------------------------------------------------- old sediment transport and morphology integer :: mxgrKrone !< mx grainsize index nr that followsKrone. Rest follows v.Rijn @@ -168,6 +172,8 @@ subroutine default_sediment() jamormergedtuser = 0 upperlimitssc = 1.0e6_dp inmorphopol = 1 + difparam = 10_fp + difcal = 1_fp end subroutine default_sediment diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 index 33927b0fe99..05e4c353057 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 @@ -64,6 +64,7 @@ module m_waves real(kind=dp) :: ftauw !< Swartfactor, tune bed shear stress real(kind=dp) :: fwfac !< Soulsby factor, tune streaming real(kind=dp) :: fbreak !< tune breaking in tke model + real(kind=dp) :: fforc !< tune wave forces real(kind=dp) :: fwavpendep !< Layer thickness as proportion of Hrms over which wave breaking adds to TKE source. Default 0.5 character(len=4) :: rouwav !< Friction model for wave induced shear stress @@ -102,6 +103,7 @@ module m_waves integer :: jahissigwav !< 1: sign wave height on his output; 0: hrms wave height on his output. integer :: jamapsigwav !< 1: sign wave height on map output; 0: hrms wave height on map output. integer :: jauorbfromswan !< 1: get uorb from SWAN, compare with Delft3D + integer :: jawavevellogprof logical :: extfor_wave_initialized !< is set to .true. when the "external forcing"-part that must be initialized for WAVE during running (instead of during initialization) has actually been initialized contains @@ -122,6 +124,8 @@ subroutine default_waves() fwfac = 1.0_dp fbreak = 1.0_dp fwavpendep = 1.5_dp ! best setting based on sensitivity + jawavevellogprof = 1 + fforc = 1.0_dp call reset_waves() end subroutine default_waves diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_xbeach_data.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_xbeach_data.f90 index e5e1e7da56a..d6a235f7cc3 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_xbeach_data.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_xbeach_data.f90 @@ -262,6 +262,7 @@ module m_xbeach_data integer :: tsmult = -123 ! [-] multiplier, maximizes implicit timestep based on CFL based timestep for implicit solver real(kind=dp) :: waveps = -123 ! [-] eps for wave related quantities, for comparison with XBeach real(kind=dp) :: d_relaxfac = -123 ! [-] Relaxation factor for wave dissipation in stationary solver + real(kind=dp) :: DR_minthresh = -123 ! [-] ! ! [Section] Roller and wave turbulence parameters real(kind=dp) :: BRfac = -123 ! [-] (advanced) Calibration factor surface slope diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 index e882095dd55..78e5b035bdd 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 @@ -151,6 +151,7 @@ module unstruc_model character(len=255) :: md_bedformfile = ' ' !< File containing bedform settings (e.g., *.bfm) character(len=255) :: md_morphopol = ' ' !< File containing boundaries of morphologic change extent (e.g., *.pol) character(len=255) :: md_sedtrailsfile = ' ' !< File containing extent of sedtrails output grid + character(len=255) :: md_dynvegpol = ' ' !< File containing extent of dynymic vegetation application character(len=1024) :: md_obsfile = ' ' !< File containing observation points (e.g., *_obs.xyn, *_obs.ini) integer :: md_delete_observation_points_outside_grid !< 0 - do not delete, 1 - delete @@ -325,6 +326,7 @@ subroutine resetModel() md_bedformfile = ' ' md_morphopol = ' ' md_sedtrailsfile = ' ' + md_dynvegpol = ' ' md_obsfile = ' ' md_delete_observation_points_outside_grid = 0 @@ -1325,6 +1327,18 @@ subroutine readMDUFile(filename, istat) jafrculin = 1 end if + ! Additions for dynamic roughness for storm impacts with morphology + call prop_get(md_ptr, 'physics', 'DynRoughVeg', dynroughveg) + if (dynroughveg > 0 .and. ifrctypuni /= 1) then + call mess(LEVEL_WARN, 'Dynamic vegetation roughness only implemented for Manning roughness. Switched off.') + dynroughveg = 0 + else + call prop_get(md_ptr, 'physics', 'droot', droot) ! default 0.5 [0-100] + call prop_get(md_ptr, 'physics', 'dstem', dstem) ! default 0.5 [0-100] + call prop_get(md_ptr, 'physics', 'nmanmin', frcumin) ! default 0.023 + call prop_get(md_ptr, 'physics', 'dynvegpol', md_dynvegpol, success) + end if + call prop_get(md_ptr, 'physics', 'Umodlin', umodlin) call prop_get(md_ptr, 'physics', 'Vicouv', vicouv) call prop_get(md_ptr, 'physics', 'Dicouv', dicouv) @@ -1484,6 +1498,8 @@ subroutine readMDUFile(filename, istat) call prop_get(md_ptr, 'sediment', 'MasBalMinDep', botcrit, success) ! Minimum depth *after* bottom update for SSC adaptation mass balance call prop_get(md_ptr, 'sediment', 'MormergeDtUser', jamormergedtuser, success) ! Mormerge operation at dtuser timesteps (1) or dts (0, default) call prop_get(md_ptr, 'sediment', 'UpperLimitSSC', upperlimitssc, success) ! Upper limit of cell centre SSC concentration after transport timestep. Default 1d6 (effectively switched off) + call prop_get(md_ptr, 'sediment', 'DiffusionScaling', difparam, success) ! Scaling factor to increase diffusion below reference level + call prop_get(md_ptr, 'sediment', 'DiffusionCal', difcal, success) ! Scaling factor to change diffusion for ssc if (jased > 0 .and. .not. stm_included) then call prop_get(md_ptr, 'sediment', 'Nr_of_sedfractions', Mxgr) @@ -1638,6 +1654,8 @@ subroutine readMDUFile(filename, istat) call prop_get(md_ptr, 'waves', 'fwfac', fwfac) ! factor for adjusting wave boundary layer streaming, default 1.0 call prop_get(md_ptr, 'waves', 'ftauw', ftauw) ! factor for adjusting wave related bottom shear stress call prop_get(md_ptr, 'waves', 'fbreak', fbreak) ! factor for adjusting wave breaking contribution to tke + call prop_get(md_ptr, 'waves', 'fforc', fforc) ! factor for adjusting wave forces in momentum equation + if (ftauw < 0.0_dp) then call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: ftauw<0.0, reset to 0.0. Bed shear stress due to waves switched off.') ftauw = 0.0_dp @@ -1650,6 +1668,10 @@ subroutine readMDUFile(filename, istat) call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: fbreak<0.0, reset to 0.0. Wave breaking contribution to tke switched off.') fbreak = 0.0_dp end if + if (fforc < 0.0_dp) then + call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: fforc<0.0, reset to 0.0. Wave forces switched off.') + fforc = 0.0_dp + end if if (jawave <= WAVE_FETCH_YOUNG) then jawaveStokes = NO_STOKES_DRIFT @@ -3321,6 +3343,12 @@ subroutine writeMDUFilepointer(mout, writeall, istat) if (writeall) then call prop_set(prop_ptr, 'physics', 'Umodlin', umodlin, 'Linear friction umod, for friction_type=4,5,6') end if + call prop_set(prop_ptr, 'physics', 'DynRoughVeg', dynroughveg, 'Switch for dynamic vegetation rougness. Default 0.') + call prop_set(prop_ptr, 'physics', 'droot', droot, 'Root depth. Default 0.5m') ! default 0.5 [0-100] + call prop_set(prop_ptr, 'physics', 'dstem', dstem, 'Stem height. Default 0.5m') ! default 0.5 [0-100] + call prop_set(prop_ptr, 'physics', 'nmanmin', frcumin, 'Base friction Manning value. Default 0.023') ! default 0.023 + call prop_set(prop_ptr, 'physics', 'dynvegpol', md_dynvegpol, 'Area to apply dynamic vegetation roughness. If empty, no roughness update.') + call prop_set(prop_ptr, 'physics', 'Vicouv', vicouv, 'Uniform horizontal eddy viscosity (m2/s)') call prop_set(prop_ptr, 'physics', 'Dicouv', dicouv, 'Uniform horizontal eddy diffusivity (m2/s)') if (writeall .or. (kmx > 0)) then diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 index 3ee3412bd7a..3a986009a23 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 @@ -33,6 +33,7 @@ module m_zlin use m_waveconst + use precision, only: dp implicit none diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 new file mode 100644 index 00000000000..d1edb3d1b46 --- /dev/null +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 @@ -0,0 +1,62 @@ +!----- AGPL -------------------------------------------------------------------- +! +! Copyright (C) Stichting Deltares, 2017-2024. +! +! This file is part of Delft3D (D-Flow Flexible Mesh component). +! +! Delft3D is free software: you can redistribute it and/or modify +! it under the terms of the GNU Affero General Public License as +! published by the Free Software Foundation version 3. +! +! Delft3D is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Affero General Public License for more details. +! +! You should have received a copy of the GNU Affero General Public License +! along with Delft3D. If not, see . +! +! contact: delft3d.support@deltares.nl +! Stichting Deltares +! P.O. Box 177 +! 2600 MH Delft, The Netherlands +! +! All indications and logos of, and references to, "Delft3D", +! "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +! Deltares, and remain the property of Stichting Deltares. All rights reserved. +! +!------------------------------------------------------------------------------- +module m_update_dynveg +! +! + implicit none + + private + + public :: update_dynveg + +contains + + subroutine update_dynveg() + use precision, only: dp + use m_physcoef + use m_sediment + use m_flow + + if (dynroughveg > 0) then + where ((dynveg) .and. (cumes > 0_dp)) ! linear function do to deposition ( sedero > 0 ) + frcu = frcumin + min(max((dstem - cumes) / dstem, 0._dp), 1.0_dp) * (frcu0 - frcumin) + elsewhere((dynveg) .and. (cumes < (-1_dp * droot))) ! step function do to erosion larger than root than always minimum ( sedero < -droot ) + frcu = frcumin + dynveg = .false. + elsewhere(dynveg) ! linear function do to deposition ( -droot < sedero < 0 ) + frcu = frcumin + min(max((droot + cumes) / droot, 0._dp), 1.0_dp) * (frcu0 - frcumin) + elsewhere + ! do nothing + frcu = frcu0 + end where + end if + + end subroutine update_dynveg + +end module m_update_dynveg diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/flow_initimestep.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/flow_initimestep.f90 index 55830a0a082..10f44dabec6 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/flow_initimestep.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/flow_initimestep.f90 @@ -70,6 +70,8 @@ subroutine flow_initimestep(jazws0, set_hu, use_u1, iresult) use fm_external_forcings, only: calculate_wind_stresses, set_external_forcings_boundaries use m_wind, only: update_wind_stress_each_time_step, jaheat_eachstep use m_fm_icecover, only: update_icecover + use m_update_dynveg, only: update_dynveg + implicit none integer, intent(in) :: jazws0 @@ -150,6 +152,11 @@ subroutine flow_initimestep(jazws0, set_hu, use_u1, iresult) end if end if + ! Adapt roughness according to burial/erosion + if (dynroughveg > 0) then + call update_dynveg() + end if + call timstrt('Set conveyance ', handle_extra(44)) ! Start cfuhi call setcfuhi() ! set current related frictioncoefficient call timstop(handle_extra(44)) ! End cfuhi diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 index 6346b3ae810..2ce4800c3f8 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 @@ -46,7 +46,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte use m_get_czz0, only: getczz0 use m_flowgeom, only: ln, dxi, csu, snu use m_flowtimes, only: dti - use m_waves, only: ustokes, vstokes, wblt + use m_waves, only: ustokes, vstokes, wblt, jawavevellogprof use m_waveconst, only: NO_WAVES, NO_STOKES_DRIFT, WAVE_STREAMING_OFF use m_sediment, only: stm_included use m_flowtimes, only: dts @@ -64,25 +64,26 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte real(kind=dp) :: taubxuLL ! taubxu = ymxpar*(taucur+tauwav) real(kind=dp) :: csw, snw ! wave direction cosines - real(kind=dp) :: Dfu, Dfu0, Dfu1, htop, dzu ! wave dissipation by bed friction, / (rhomean*c*deltau) + real(kind=dp) :: Dfu, Dfu0, Dfu1, htop ! wave dissipation by bed friction, / (rhomean*c*deltau) real(kind=dp) :: deltau ! wave dissipation layer thickness real(kind=dp) :: u2dh real(kind=dp) :: z0urouL, rhoL, uorbu real(kind=dp) :: umodeps integer :: nit, nitm = 100 - real(kind=dp) :: r, rv = 123.8d0, e = 8.84d0, eps = 1d-2 + real(kind=dp) :: r, rv = 123.8_dp, e = 8.84_dp, eps = 1e-2_dp real(kind=dp) :: s, sd, er, ers, dzb, uu, vv, alin real(kind=dp) :: cphi, sphi - real(kind=dp) :: fsqrtt = sqrt(2d0) + real(kind=dp) :: fsqrtt = sqrt(2.0_dp) + real(kind=dp) :: threedeltau - cfuhi3D = 0d0 - ustbLL = 0d0; cfuhiLL = 0d0; hdzb = 0d0; z00 = 0d0; cz = 0d0; nit = 0 + cfuhi3D = 0_dp + ustbLL = 0_dp; cfuhiLL = 0_dp; hdzb = 0_dp; z00 = 0_dp; cz = 0_dp; nit = 0 - umodeps = 1d-4 + umodeps = 1e-4_dp frcn = frcu(LL) - if (frcn == 0d0) return + if (frcn == 0_dp) return friction_type = ifrcutp(LL) if (hu(LL) < trsh_u1Lb) then @@ -94,40 +95,40 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte 10 continue if (friction_type < 10) then - if (frcn > 0d0) then + if (frcn > 0_dp) then call getczz0(hu(LL), frcn, friction_type, cz, z00) - hdzb = 0.5d0 * hu(Lb) + c9of1 * z00 ! half bottom layer plus 9z0 + hdzb = 0.5_dp * hu(Lb) + c9of1 * z00 ! half bottom layer plus 9z0 - if (z00 > 0d0) then + if (z00 > 0_dp) then if (jaustarint == 0) then ! sqcf = vonkar/log(c9of1 + hdzb/z00) ! till 012015 sqcf = vonkar / log(hdzb / z00) else if (jaustarint == 1) then ! Yoeri 2014 long time default for jaustarint == 1 dzb = hu(Lb) + c9of1 * z00 - sqcf = vonkar / (log(dzb / z00) - 1d0) + sqcf = vonkar / (log(dzb / z00) - 1_dp) else if (jaustarint == 2) then ! remobilised through jaustarint == 2, good convergence dzb = hu(Lb) / ee + c9of1 * z00 sqcf = vonkar / (log(dzb / z00)) else if (jaustarint == 3) then ! Delft3D - hdzb = 0.5d0 * hu(Lb) + z00 - sqcf = vonkar / (log(1d0 + 0.5d0 * hu(Lb) / z00)) + hdzb = 0.5_dp * hu(Lb) + z00 + sqcf = vonkar / (log(1_dp + 0.5_dp * hu(Lb) / z00)) else if (jaustarint == 4) then - !hdzb = 0.5d0*hu(Lb) + c9of1*z00/0.65d0 - dzb = hu(Lb) / ee + c9of1 * z00 * 0.66d0 + !hdzb = 0.5_dp*hu(Lb) + c9of1*z00/0.65_dp + dzb = hu(Lb) / ee + c9of1 * z00 * 0.66_dp sqcf = vonkar / (log(dzb / z00)) else if (jaustarint == 5) then dzb = hu(Lb) - sqcf = vonkar / ((1d0 + c9of1 * z00 / dzb) * log(dzb / z00 + c9of1) - c9of1 * z00 / dzb * log(c9of1) - 1d0) + sqcf = vonkar / ((1_dp + c9of1 * z00 / dzb) * log(dzb / z00 + c9of1) - c9of1 * z00 / dzb * log(c9of1) - 1_dp) end if z0ucur(LL) = z00 else - sqcf = 0d0 + sqcf = 0_dp end if else - hdzb = 0.5d0 * hu(Lb) - sqcf = 0d0 + hdzb = 0.5_dp * hu(Lb) + sqcf = 0_dp end if umod = sqrt(u1Lb * u1Lb + v(Lb) * v(Lb)) @@ -140,8 +141,8 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte end if end if - if (umod == 0d0) then ! from dry to wet - umod = max(umodeps, dts * ag * dxi(LL) * min(abs(s1(ln(1, LL)) - s1(ln(2, LL))), 0.333333d0 * hu(LL))) + if (umod == 0_dp) then ! from dry to wet + umod = max(umodeps, dts * ag * dxi(LL) * min(abs(s1(ln(1, LL)) - s1(ln(2, LL))), 0.333333_dp * hu(LL))) else umod = max(umod, umodeps) ! 1d-6 for klopman ! until 3D handled like 2D iterative loop , solves Roses problem: ust=1.1e-104 to the power 3 is underflow end if @@ -150,33 +151,28 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte if (jawave > NO_WAVES .and. .not. flowWithoutWaves) then rhoL = rhomean ! for now - if (ustw2 > 1d-8) then + if (ustw2 > 1e-8_dp) then ! ! Virtual 2dh velocity, delft3d style if (LL == Lb) then ! take into account layer integral approach on bnd u2dh = umod else ! here we assume that z0/dzb is small and c9of1==1, ie we use jaustarint==1 approach, cf 3D validation doc Mohamed - !u2dh = umod*(log((1d0+hu(LL))/z0urou(LL))-1d0)/(log(dzb/z0urou(LL))-1d0) - - ! UNST-6297 formulation above gives u2dh of order too big in very shallow water - - ! Delft3D: - !u2dh = (umod/hu(LL) & - ! & *((hu(LL) + z0urou(LL))*log(1d0 + hu(LL)/z0urou(LL)) & - ! & - hu(LL)))/log(1d0 + 0.5d0*(max(dzb,0.01d0))/z0urou(LL)) - - ! use available depth-averaged u1, v - u2dh = sqrt((u1(LL) - ustokes(LL))**2 + & - (v(LL) - vstokes(LL))**2) + if (jawavevellogprof == 0) then + u2dh = umod * (log((1_dp + hu(LL)) / z0urou(LL)) - 1_dp) / (log(dzb / z0urou(LL)) - 1_dp) + else + ! use available depth-averaged u1, v + u2dh = sqrt((u1(LL) - ustokes(LL))**2 + & + (v(LL) - vstokes(LL))**2) + end if end if ! - if (cz > 0d0) then + if (cz > 0_dp) then cdrag = ag / (cz * cz) ! ustc2 = cdrag * u2dh**2 else - ustc2 = 0d0 + ustc2 = 0_dp end if ! uu = u1Lb - ustokes(Lb) @@ -187,21 +183,20 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte sphi = -csw * snu(LL) + snw * csu(LL) abscos = abs(cphi * uu + sphi * vv) / umod call getsoulsbywci(modind, ustc2, ustw2, fw, cdrag, umod, abscos, taubpuLL, taubxuLL) - ! ustbLL = sqrt(umod*taubpuLL) else if (modind == 9) then ! wave-current interaction van Rijn (2004) call getvanrijnwci(LL, umod, u2dh, taubpuLL, z0urouL) taubxuLL = rhoL * (ustc2 + ustw2) ! depth-averaged, see taubot elseif (modind == 10) then ! Ruessink 2001 - if (cz > 0d0) then - taubpuLL = cdrag * sqrt(umod**2 + (1.16d0 * uorbu * fsqrtt)**2) + if (cz > 0_dp) then + taubpuLL = cdrag * sqrt(umod**2 + (1.16_dp * uorbu * fsqrtt)**2) taubxuLL = rhoL * (ustc2 + ustw2) else - taubpuLL = 0d0 - taubxuLL = 0d0 + taubpuLL = 0_dp + taubxuLL = 0_dp end if else if (modind == 0) then ! exception where you don't want wave influence on bed shear stress with jawave>0 if (sqcf > 0.0_dp) then - z0urouL = dzb * exp(-vonkar / sqcf - 1.0_dp) ! inverse of jaustarint == 1 above + z0urouL = z00 ! no wave enhancement taubpuLL = ustbLL * ustbLL / umod ! use flow ustar taubxuLL = rhoL * taubpuLL * umod else @@ -227,48 +222,52 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte z0urou(LL) = z0urouL end if z00 = z0urou(LL) ! wave enhanced z0 for turbulence - ! - if (stm_included) wblt(LL) = deltau - ! - ! Streaming below deltau with linear distribution - if (jawavestreaming > WAVE_STREAMING_OFF .and. deltau > 1.0e-7_dp) then ! Streaming below deltau with linear distribution - Dfu0 = Dfuc ! (m/s2) - do L = Lb, Ltop(LL) - if (hu(L) <= deltau) then - htop = min(hu(L), deltau) ! max height within waveboundarylayer - alin = 1.0_dp - htop / deltau ! linear from 1 at bed to 0 at deltau - Dfu1 = Dfuc * alin - dzu = htop - hu(L - 1) - adve(L) = adve(L) - 0.5_dp * (Dfu0 + Dfu1) * dzu / deltau - Dfu0 = Dfu1 - end if - if (hu(L) > deltau) then - if (L == Lb) then - adve(L) = adve(L) - Dfuc * deltau / (2.0 * hu(L)) ! everything in bottom layer - end if - exit - end if - end do - end if else - if (sqcf > 0.0_dp) then + if (sqcf > 0_dp) then ! taubu for too small wave case needs to be filled z0urou(LL) = z00 ! just use current only z0 taubpuLL = ustbLL * ustbLL / umod ! use flow ustar taubxuLL = rhoL * taubpuLL * umod else - taubu(LL) = 0.0_dp - taubxu(LL) = 0.0_dp + taubu(LL) = 0_dp + taubxu(LL) = 0_dp z0urou(LL) = epsz0 end if end if + ! + if (stm_included) wblt(LL) = deltau + ! + ! Streaming below 3*deltau with linear distribution,, see van Rijn 2011 p9.177 + if (jawavestreaming > WAVE_STREAMING_OFF .and. deltau > 1e-4_dp * hu(LL)) then ! weakly turbulent flume cases ~1mm-1cm, real turbulent cases 5-50cm + threedeltau = 3_dp * deltau + Dfu0 = Dfuc ! (m/s2) + do L = Lb, Ltop(LL) + if (hu(L) <= threedeltau) then + htop = min(hu(L), threedeltau) ! max height within streaming layer + alin = 1_dp - htop / threedeltau ! linear from 1 at bed to 0 at 3*deltau + Dfu1 = Dfuc * alin + adve(L) = adve(L) - 0.5_dp * (Dfu0 + Dfu1) + Dfu0 = Dfu1 + end if + if (hu(L) > threedeltau) then + if (L == Lb) then + adve(L) = adve(L) - Dfuc * threedeltau / (2.0 * hu(L)) ! everything in bottom layer + else + alin = (min(hu(L), threedeltau) - hu(L - 1)) / (2_dp * (hu(L) - hu(L - 1))) + Dfu1 = Dfuc * alin + adve(L) = adve(L) - Dfu1 + end if + exit + end if + end do + end if end if ! end jawave cfuhiLL = sqcf * sqcf / hu(Lb) ! cfuhiLL = g / (H.C.C) = (g.K.K) / (A.A) cfuhi3D = cfuhiLL * umod ! cfuhi3D = frc. contr. to diagonal if (jawave == NO_WAVES .or. flowWithoutWaves) then - z0urou(LL) = z0ucur(LL) ! morfo, bedforms, trachytopes + z0urou(LL) = z00 ! morfo, bedforms, trachytopes end if else if (friction_type == 10) then ! Hydraulically smooth, glass etc @@ -327,7 +326,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte else if (friction_type == 11) then ! Noslip - ! advi(Lb) = advi(Lb) + 2d0*(vicwwu(Lb)+vicouv)/hu(Lb)**2 + ! advi(Lb) = advi(Lb) + 2_dp*(vicwwu(Lb)+vicouv)/hu(Lb)**2 cfuhi3D = 2.0_dp * (vicwwu(Lb) + vicoww) / hu(Lb)**2 end if diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 index 880e64fe5df..ba7f3b77f6e 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 @@ -45,7 +45,6 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor use m_waveconst, only: STOKES_DRIFT_2NDORDER, STOKES_DRIFT_DEPTHUNIFORM, WAVE_SURFBEAT use m_sferic, only: twopi, dg2rd, pi use m_get_Lbot_Ltop, only: getlbotltop - use m_xbeach_data, only: R, cwav, gammaxxb, roller use mathconsts, only: ee integer, intent(in) :: LL @@ -58,10 +57,9 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor real(kind=dp), intent(out) :: uorbu real(kind=dp), external :: sinhsafei - integer :: k1, k2, Lb, Lt, L, Lmin + integer :: k1, k2, Lb, Lt, L real(kind=dp) :: Tsig, Hrms, asg, rk, shs, phi1, phi2, dks, aks, omeg, f1u, f2u, f3u, sintu real(kind=dp) :: p1, p2, h, z, uusto, fac - real(kind=dp) :: rolthk, rmax, erol, crol, mass Dfu = 0.0_dp; Dfuc = 0.0_dp; deltau = 0.0_dp; uorbu = 0.0_dp; csw = 1.0_dp; snw = 0.0_dp; costu = 1.0_dp; fw = 0.0_dp @@ -113,36 +111,6 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor ! depth averaged ustokes(LL) = costu * ag * asg * asg * rk / omeg / 2.0_dp / hu(LL) ! these are needed, also for 3D models (see u bnd furu) vstokes(LL) = sintu * ag * asg * asg * rk / omeg / 2.0_dp / hu(LL) - - ! add 3D roller contribution to stokes drift - if (jawave == WAVE_SURFBEAT .and. roller == 1) then - ! roller mass flux - rmax = 0.125_dp * rhomean * ag * (gammaxxb * h)**2 - erol = min(0.5_dp * (R(k1) + R(k2)), rmax) - crol = max(0.5_dp * (cwav(k1) + cwav(k2)), 1.0e-1_dp) - mass = 2.0_dp * erol / crol / rhomean - ! - if (Lt > Lb) then - ! - ! determine roller thickness - lmin = Lt - rolthk = 0.0_dp - do L = Lt - 1, Lb, -1 - lmin = L - rolthk = hu(Lt) - hu(L) - if (rolthk >= 0.5_dp * hrms) exit - end do - ! - ! depth dependent contribution - ustokes(Lmin:Lt) = ustokes(Lmin:Lt) + mass / rolthk * costu - vstokes(Lmin:Lt) = vstokes(Lmin:Lt) + mass / rolthk * sintu - end if - ! - ! depth averaged contribution - ustokes(LL) = ustokes(LL) + mass / h * costu - vstokes(LL) = ustokes(LL) + mass / h * sintu - end if - end if if (shs > eps10) then @@ -158,13 +126,13 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor dks = 33.0_dp * z00 ! should be 30 for consistency with getust aks = asg * shs / dks * fac ! uorbu/(omega*ks), uorbu/omega = particle excursion length - deltau = 0.09_dp * dks * aks**0.82_dp ! thickness of wave boundary layer from Fredsoe and Deigaard - deltau = alfdeltau * max(deltau, ee * z00) ! alfaw = 20d0 + deltau = 0.09_dp * dks * aks**0.82_dp ! thickness of wave boundary layer from Fredsoe and Deigaard (1992) + deltau = max(deltau, 20_dp * ee * z00) deltau = min(0.5_dp * hu(LL), deltau) ! call soulsby(tsig, uorbu, z00, fw) ! streaming with different calibration fac fwfac + soulsby fws Dfu = 0.28_dp * fw * uorbu**3 ! random waves: 0.28=1/2sqrt(pi) (m3/s3) - Dfu = fwfac * Dfu / deltau ! divided by deltau (m2/s3), missing rho divided out in adve denominator rho*delta + Dfu = fwfac * Dfu / 3_dp / deltau ! divided by 3*deltau (m2/s3) Dfuc = Dfu * rk / omeg * costu ! Dfuc = dfu/c/delta, (m /s2) is contribution to adve else diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 index bbaff5ab112..f5c3bdafc73 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 @@ -113,7 +113,7 @@ subroutine getvanrijnwci(LL, umod, u2dh, taubpuLL, z0urouL) uratio = min(uwbih / (u2dh + waveps), 5.0_dp) ka = ksc * exp(gamma * uratio) ka = min(ka, 10.0_dp * ksc, 0.2_dp * huLL) - ca = 18.0_fp * log10(12.0_fp * huLL / ka) + ca = 18.0_dp * log10(12.0_dp * huLL / ka) taubpuLL = ag * (u2dh * u2dh / umod) / ca**2 z0urouL = max(3.33e-5_dp, ka / 30.0_dp) end subroutine getvanrijnwci diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 index 75798289a17..32595014247 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 @@ -800,7 +800,7 @@ subroutine update_verticalprofiles() epsbot = tureps1(Lb) + dzu(1) * abs(ustb(LL))**3 / (vonkar * hdzb * hdzb) epssur = tureps1(Lt - 1) - 4.0_dp * abs(ustw(LL))**3 / (vonkar * dzu(Lt - Lb + 1)) if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then - epssur = epssur - dzu(Lt - Lb + 1) * fwavpendep * pkwmag / hrmsLL + epssur = epssur - dzu(Lt - Lb + 1) * pkwmag / (hrmsLL * fwavpendep) end if epsbot = max(epsbot, eps_min) epssur = max(epssur, eps_min) @@ -826,7 +826,9 @@ subroutine update_verticalprofiles() vicwwu(Lb0:Lt) = min(vicwmax, cmukep * turkin1(Lb0:Lt) * tureps1(Lb0:Lt)) end if - vicwwu(Lt) = min(vicwwu(Lt), vicwwu(Lt - 1) * Eddyviscositysurfacmax) + if (jawave == NO_WAVES) then + vicwwu(Lt) = min(vicwwu(Lt), vicwwu(Lt - 1) * Eddyviscositysurfacmax) + end if vicwwu(Lb0) = min(vicwwu(Lb0), vicwwu(Lb) * Eddyviscositybedfacmax) call vertical_profile_u0(dzu, womegu, Lb, Lt, kxL, LL) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 index ea7e124bcce..e769f004891 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 @@ -43,14 +43,16 @@ subroutine bermslopenudging(error) use m_fm_erosed, only: bermslopegamma, bermslopedepth, bermslopebed, bermslopesus, e_dzdn, e_dzdt, bermslopefac, bermslope, morfac, lsedtot, bed, has_bedload, e_sbcn, e_sbct, e_sbwn, e_sbwt, sus, lsed, e_ssn, e_sswn, e_sswt use m_waveconst, only: no_waves use m_flow, only: hu, epshu - use m_flowgeom, only: lnx, ln, wu_mor + use m_flowgeom, only: lnx, ln, wu_mor, snu, csu use m_flowparameters, only: jawave + use m_waves, only: phiwav logical, intent(out) :: error integer :: L, k1, k2 integer :: lsd real(kind=dp) :: hwavu, slope, flx, frc, fixf, trmag_u, slpfac + real(kind=dp) :: cosw, sinw, coswu error = .true. ! @@ -96,7 +98,15 @@ subroutine bermslopenudging(error) ! Transports positive outgoing ! slope = max(hypot(e_dzdn(L), e_dzdt(L)), 1.0e-8_dp) - slpfac = bermslopefac * (-e_dzdn(L) + bermslope * e_dzdn(L) / slope) / max(morfac, 1.0_dp) + if (jawave > NO_WAVES) then + cosw = 0.5_dp * (cosd(phiwav(k1)) + cosd(phiwav(k2))) + sinw = 0.5_dp * (sind(phiwav(k1)) + sind(phiwav(k2))) + coswu = cosw * csu(L) + sinw * snu(L) + slpfac = bermslopefac * (-e_dzdn(L) + bermslope * coswu) / max(morfac, 1.0_dp) + else + ! we have no good substitute, so old approach + slpfac = bermslopefac * (-e_dzdn(L) + bermslope * e_dzdn(L) / slope) / max(morfac, 1.0_dp) + end if do lsd = 1, lsedtot ! ! slope magnitude smaller than bermslope leads to transport away from the cell, ie outward diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 index a0d640dc3f5..c3c56c4c62b 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 @@ -76,6 +76,7 @@ subroutine fm_erosed() use sediment_basics_module use m_physcoef, only: ag, vonkar, sag, backgroundsalinity, backgroundwatertemperature, vismol, frcuni, ifrctypuni use m_sediment, only: stmpar, stm_included, jatranspvel, sbcx_raw, sbcy_raw, sswx_raw, sswy_raw, sbwx_raw, sbwy_raw + use m_sediment, only: difparam, difcal use m_flowgeom, only: bl, dxi, csu, snu, wcx1, wcx2, wcy1, wcy2, acl, csu, snu, wcl use m_flow, only: s0, s1, u1, v, kmx, zws, hs, & iturbulencemodel, z0urou, ifrcutp, hu, spirint, spiratx, spiraty, u_to_umain, frcu_mor, javeg, jabaptist, cfuhi, epshs, taubxu, epsz0 @@ -464,7 +465,7 @@ subroutine fm_erosed() do k = kb, kt zcc = 0.5_dp * (zws(k - 1) + zws(k)) ! cell centre position in vertical layer admin, using absolute height kmxvel = k - if (zcc >= (bl(kk) + maxdepfrac * hs(kk)) .or. zcc >= (bl(kk) + deltas(kk))) then + if (zcc >= (bl(kk) + maxdepfrac * hs(kk)) .or. (jawave > NO_WAVES .and. zcc >= (bl(kk) + deltas(kk)))) then exit end if end do @@ -981,7 +982,7 @@ subroutine fm_erosed() if (mfltot <= 0.0_fp) then sourf(l, nm) = 0.0_fp else - sourf(l, nm) = min(sourfluff, mfltot/dts) + sourf(l, nm) = min(sourfluff, mfltot / dts) end if else sinkse(nm, l) = sinktot @@ -1171,10 +1172,16 @@ subroutine fm_erosed() ! bottom of reference cell downwards, to ensure little ! gradient in sed. conc. exists in this area. - difbot = 10.0_fp * ws(kmxsed(nm, l) - 1, l) * thick1 - do kk = kb - 1, kmxsed(nm, l) - 1 - seddif(l, kk) = difbot - end do + if (difparam > 0.0) then + difbot = difparam * ws(kmxsed(nm, l) - 1, l) * thick1 + do kk = kb - 1, kmxsed(nm, l) - 1 + seddif(l, kk) = difbot + end do + end if + ! + if (difcal > 0d0) then + seddif = difcal * seddif + end if end if ! suspfrac else ! diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_fallve.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_fallve.f90 index 071a68f6f71..7897077ad11 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_fallve.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_fallve.f90 @@ -182,6 +182,7 @@ subroutine fm_fallve() end if ! ! loop over the interfaces in the vertical + ! this does not work kmx==1 ! if (kmx > 0) then ! 3D call getkbotktop(k, kb, kt) @@ -334,7 +335,7 @@ subroutine fm_fallve() ws(kk, ll) = wsloc end do ! ll end do ! kk - if (kmx > 1) then + if (kmx > 1) then ! what about kmx==1 do ll = 1, lsed ws(kb - 1, ll) = ws(kb, ll) ! to check end do ! ll diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 index 78c3ba19654..98b829d6a7f 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 @@ -85,6 +85,7 @@ subroutine fm_bott3d() use Timers use m_reconstruct_sed_transports use m_waveconst + use m_physcoef, only: dynroughveg implicit none @@ -264,6 +265,10 @@ subroutine fm_bott3d() call fm_blchg_no_cmpupd() !Compute bed level changes without actually updating the bed composition ! call fm_apply_bed_boundary_condition(dtmor, timhr) + ! + if (dynroughveg > 0) then + call determine_linkbased_cumblchg() + end if else ! @@ -1257,7 +1262,7 @@ subroutine fm_dry_bed_erosion(dtmor) ! ! If this is a cell in which sediment processes are active then ... ! - if (kfsed(nm) /= 1 .or. (s1(nm) - bl(nm)) < epshs .or. thetsd(nm) <= 0) cycle ! check whether sufficient as condition + if (kfsed(nm) /= 1 .or. (s1(nm) - bl(nm)) <= epshs .or. thetsd(nm) <= 0) cycle ! check whether sufficient as condition ! totdbodsd = 0_dp do l = 1, lsedtot @@ -1619,7 +1624,7 @@ subroutine fm_update_concentrations_after_bed_level_update() ! After review, botcrit as a parameter is a really bad idea, as it causes concentration explosions if chosen poorly or blchg is high. ! Instead, allow bottom level changes up until 5% of the waterdepth to influence concentrations ! This is in line with the bed change messages above. Above that threshold, change the concentrations as if blchg==0.95hs - if (hsk < epshs) cycle + if (hsk <= epshs) cycle botcrit = 0.95 * hsk ddp = hsk / max(hsk - blchg(k), botcrit) do ll = 1, stmpar%lsedsus @@ -1636,11 +1641,11 @@ subroutine fm_update_concentrations_after_bed_level_update() end do end if !ITRA1>0 end do !k - else !kmx==0 + else !kmx>0 do ll = 1, stmpar%lsedsus ! works for sigma only do k = 1, ndx hsk = hs(k) - if (hsk < epshs) cycle + if (hsk <= epshs) cycle botcrit = 0.95 * hsk ddp = hsk / max(hsk - blchg(k), botcrit) call getkbotktop(k, kb, kt) @@ -1653,7 +1658,7 @@ subroutine fm_update_concentrations_after_bed_level_update() if (jasal > 0) then do k = 1, ndx hsk = hs(k) - if (hsk < epshs) cycle + if (hsk <= epshs) cycle botcrit = 0.95 * hsk call getkbotktop(k, kb, kt) do kk = kb, kt @@ -1666,7 +1671,7 @@ subroutine fm_update_concentrations_after_bed_level_update() do itrac = ITRA1, ITRAN do k = 1, ndx hsk = hs(k) - if (hsk < epshs) cycle + if (hsk <= epshs) cycle botcrit = 0.95 * hsk call getkbotktop(k, kb, kt) do kk = kb, kt @@ -1959,7 +1964,7 @@ subroutine fm_correct_water_level() ! bed or maximum water level in surrounding wet cells ! (whichever is higher) ! - if (hs(nm) < epshs) then + if (hs(nm) <= epshs) then s1(nm) = s1(nm) + blchg(nm) s0(nm) = s0(nm) + blchg(nm) end if @@ -2102,4 +2107,23 @@ subroutine fm_diffusion_active_layer() end subroutine fm_diffusion_active_layer + subroutine determine_linkbased_cumblchg() + use m_sediment, only: cumes + use m_fm_erosed, only: blchg + use m_flowgeom, only: lnx, ln, acl + + implicit none + + integer :: L, k1, k2 + real(kind=dp) :: ac1, ac2 + + do L = 1, lnx + k1 = ln(1, L) + k2 = ln(2, L) + ac1 = acl(L); ac2 = 1_fp - ac1 + cumes(L) = cumes(L) + ac1 * (blchg(k1)) + ac2 * (blchg(k2)) + end do + + end subroutine determine_linkbased_cumblchg + end module m_fm_bott3d diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 index a5249550a08..62c9bb03e03 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 @@ -45,23 +45,24 @@ subroutine setwavfu() use precision, only: dp use m_flowparameters, only: jawaveforces, wave_forces_off, jawave, wave_swan_online, wave_nc_offline, wave_surfbeat, epshu use m_flowgeom, only: lnx, lnx1d, ln, acl, csu, snu - use m_waves, only: m_waves_hminlw => hminlw, gammax, facmax, sxwav, sywav, sbxwav, sbywav, twav, hwav + use m_waves, only: m_waves_hminlw => hminlw, gammax, facmax, sxwav, sywav, sbxwav, sbywav, twav, fforc use m_xbeach_data, only: xb_hminlw => hminlw, gammaxxb use m_get_Lbot_Ltop, only: getlbotltop use m_flow, only: hu, huvli, wavfu, wavfv, rhomean, kmx use m_physcoef, only: sag + use precision_basics, only: comparereal implicit none integer :: L, LL, Lb, Lt real(kind=dp) :: wavfx, wavfy, wavfbx, wavfby - real(kind=dp) :: wavfu_loc, wavfbu_loc, twavL, hwavL + real(kind=dp) :: wavfu_loc, wavfbu_loc, twavL real(kind=dp) :: wavfv_loc, wavfbv_loc, wavfmag, wavfbmag, wavfang, wavfbang real(kind=dp) :: fmax, ac1, ac2, hminlwi, rhoL, hminlw, gammaloc integer :: k1, k2 - if (jawaveforces == WAVE_FORCES_OFF) then + if (jawaveforces == WAVE_FORCES_OFF .or. comparereal(fforc, 0.0_dp) == 0) then wavfu = 0.0_dp wavfv = 0.0_dp return @@ -136,7 +137,6 @@ subroutine setwavfu() k1 = ln(1, LL); k2 = ln(2, LL) ac1 = acL(LL); ac2 = 1.0_dp - ac1 ! - hwavL = max(ac1 * hwav(k1) + ac2 * hwav(k2), 0.01_dp) twavL = max(ac1 * twav(k1) + ac2 * twav(k2), 0.1_dp) fmax = facmax * hu(LL)**1.5 / twavL rhoL = rhomean @@ -150,34 +150,6 @@ subroutine setwavfu() wavfu(Lt) = sign(min(abs(wavfu_loc), fmax), wavfu_loc) / rhoL / max(hu(LL) - hu(Lt - 1), hminlw) ! top layer, as in D3D wavfv(Lt) = sign(min(abs(wavfv_loc), fmax), wavfv_loc) / rhoL / max(hu(LL) - hu(Lt - 1), hminlw) ! this limitation only works in sigma layers ! - ! The following is pretty inaccurate for limited nr of layers: - ! - !wavfuL = 4d0*sign(min(abs(wavfu_loc), fmax), wavfu_loc)/hwavL - !wavfvL = 4d0*sign(min(abs(wavfv_loc), fmax), wavfv_loc)/hwavL ! hwavL/4 is integral over 0.5*hwavL waterdepth of linear decrease - !! Check if first layer is thicker than 0.5*hrms - !! In that case, distribute over first layer - !dzu=hu(Lt)-hu(Lt-1) - !halfwav=0.5*hwavL - !! - !if (dzu > halfwav) then - ! wavfu(Lt) = wavfuL*0.25d0*hwavL/rhoL/dzu ! division by 0.5*hrms done above - ! wavfv(Lt) = wavfvL*0.25d0*hwavL/rhoL/dzu - !else - !zw=0.5d0*dzu - !do L=Lt,Lb+1,-1 - ! if (zw<=halfwav) then - ! wavfu(L) = wavfuL*(1d0-2d0*zw/hwavL)/rhoL ! division by 0.5*hrms done above - ! wavfv(L) = wavfvL*(1d0-2d0*zw/hwavL)/rhoL - ! zw = zw + 0.5*(hu(L)-hu(L-2)) - ! elseif (zw>halfwav .and. hu(L)>(hu(LL)-halfwav)) then ! partial layer - ! cc = 0.5*(hu(L)+(hu(LL)-halfwav)) ! replaced layer center - ! zw = hu(LL)-cc ! depth below surface - ! wavfu(L) = wavfuL*(1d0-zw/halfwav)/rhoL ! contribution over partial layer - ! wavfv(L) = wavfvL*(1d0-zw/halfwav)/rhoL - ! endif - !enddo - !endif - ! ! Body forces, uniform over depth ! wavfx = ac1 * sbxwav(k1) + ac2 * sbxwav(k2) @@ -190,6 +162,11 @@ subroutine setwavfu() end do end do end if + ! + if (fforc > 0.0_dp) then + wavfu = fforc * wavfu + wavfv = fforc * wavfv + end if 1234 continue return end subroutine setwavfu diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 index 118e0bdcba5..fdac743cd45 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 @@ -237,7 +237,7 @@ subroutine xbeach_all_input() ARC = readkey_int(md_surfbeatfile, 'ARC', 1, 0, 1) order = readkey_dbl(md_surfbeatfile, 'order', 2.0_dp, 1.0_dp, 2.0_dp) freewave = readkey_int(md_surfbeatfile, 'freewave', 0, 0, 1) - !epsi = readkey_dbl (md_surfbeatfile,'epsi', -1.d0, -1.d0, 0.2d0 ) + !epsi = readkey_dbl (md_surfbeatfile,'epsi', -1._dp, -1._dp, 0.2_dp ) hminlw = readkey_dbl(md_surfbeatfile, 'hmin', 0.2_dp, 0.001_dp, 1.0_dp) allocate (allowednames(2), oldnames(0)) allowednames = ['abs_1d', 'abs_2d'] @@ -289,6 +289,7 @@ subroutine xbeach_all_input() beta = readkey_dbl(md_surfbeatfile, 'beta', 0.10_dp, 0.05_dp, 0.3_dp) varbeta = readkey_int(md_surfbeatfile, 'varbeta', 1, 0, 1, strict=.true.) rfb = readkey_int(md_surfbeatfile, 'rfb', 0, 0, 1, strict=.true.) + DR_minthresh = readkey_dbl(md_surfbeatfile, 'DR_minthresh', 0.0_dp, 0.0_dp, 2.0_dp, strict=.true.) ! ! ! Wave-current interaction parameters @@ -319,13 +320,13 @@ subroutine xbeach_all_input() !if (windmodel .eq. 1) then ! call writelog('l','','--------------------------------') ! call writelog('l','','Wind source parameters: ') - ! mwind = readkey_dbl (md_surfbeatfile,'mwind', 1.d0, 0.5d0, 1.d0) + ! mwind = readkey_dbl (md_surfbeatfile,'mwind', 1._dp, 0.5_dp, 1._dp) ! jawsource = readkey_int (md_surfbeatfile,'windsource', 0, 0, 1, required=(swave==1 .and. jawind==1), strict=.true.) ! jagradcg = readkey_int (md_surfbeatfile,'jagradcg', 1, 0, 1, required=((swave==1 .and. jawind==1) .and. jawsource==1), strict=.true.) ! advecmod = readkey_int (md_surfbeatfile,'advecmod', 1, 1, 2) - ! ndissip = readkey_dbl (md_surfbeatfile,'ndissip', 3.d0, 1.d0, 10.d0) - ! coefdispT = readkey_dbl (md_surfbeatfile,'coefdispT', 3.5d0, 0.d0, 1000.d0) - ! coefdispk = readkey_dbl (md_surfbeatfile,'coefdispk', 1.d0, 0.d0, 1000.d0) + ! ndissip = readkey_dbl (md_surfbeatfile,'ndissip', 3._dp, 1._dp, 10._dp) + ! coefdispT = readkey_dbl (md_surfbeatfile,'coefdispT', 3.5_dp, 0._dp, 1000._dp) + ! coefdispk = readkey_dbl (md_surfbeatfile,'coefdispk', 1._dp, 0._dp, 1000._dp) !endif ! ! @@ -382,7 +383,7 @@ subroutine xbeach_all_input() end if end if ! - !facmax = 0.25d0*sqrt(ag)*rhomean*gamma**2 + !facmax = 0.25_dp*sqrt(ag)*rhomean*gamma**2 ! ! ! Wave-current interaction with non-stationary waves still experimental @@ -472,7 +473,7 @@ subroutine xbeach_wave_init() !if (windmodel.eq.0) then do k = 1, ndx sigmwav(k) = sum(sigt(:, k), dim=1) / dble(ntheta) - L0(k) = 2 * pi * ag / (sigmwav(k)**2) + L0(k) = 2_dp * pi * ag / (sigmwav(k)**2) L1(k) = L0(k) Ltemp(k) = L0(k) end do @@ -548,20 +549,20 @@ subroutine xbeach_wave_init() maxnumbnds = 100 allocate (uave(maxnumbnds), vave(maxnumbnds), dlengthrm(maxnumbnds), stat=ierror) allocate (umeanrm(maxnumbnds), vmeanrm(maxnumbnds), stat=ierror) - uave = 0d0 - vave = 0d0 - dlengthrm = 0d0 - umeanrm = 0d0 - vmeanrm = 0d0 + uave = 0_dp + vave = 0_dp + dlengthrm = 0_dp + umeanrm = 0_dp + vmeanrm = 0_dp end if !if ( windmodel.eq.1) then ! if (jawsource.eq.1) then ! !define source term coefficients - ! CE1 = 8d0/(aa1*aa1*bb1 ) * (16d0/(aa1*aa1 ) )**(1d0/(2d0* bb1) -1d0 ) - ! CE2 = 1d0/(2d0* bb1) -1d0 - ! CT1 = 1d0/(aa2*bb2 ) * (1d0/(aa2 ) )**(1d0/bb2 -1d0 ) - ! CT2 = 1d0/bb2 -1d0 + ! CE1 = 8_dp/(aa1*aa1*bb1 ) * (16_dp/(aa1*aa1 ) )**(1_dp/(2_dp* bb1) -1_dp ) + ! CE2 = 1_dp/(2_dp* bb1) -1_dp + ! CT1 = 1_dp/(aa2*bb2 ) * (1_dp/(aa2 ) )**(1_dp/bb2 -1_dp ) + ! CT2 = 1_dp/bb2 -1_dp ! endif ! !map wind field to cell centers ! call xbeach_map_wind_field(wx, wy, mwind, wmagcc, windspreadfac) @@ -646,45 +647,45 @@ subroutine xbeach_makethetagrid() real(kind=dp) :: thetaminloc if (swave == 1) then - theta0 = (1.5d0 * pi) - dir0 * atan(1.d0) / 45d0 - do while (theta0 < -2d0 * pi) - theta0 = theta0 + 2.d0 * pi + theta0 = (1.5_dp * pi) - dir0 * atan(1._dp) / 45_dp + do while (theta0 < -2_dp * pi) + theta0 = theta0 + 2._dp * pi end do - do while (theta0 > 2d0 * pi) - theta0 = theta0 - 2.d0 * pi + do while (theta0 > 2_dp * pi) + theta0 = theta0 - 2._dp * pi end do if (thetanaut == 1) then thetaminloc = thetamin - thetamin = (270.d0 - thetamax) * dg2rd - thetamax = (270.d0 - thetaminloc) * dg2rd + thetamin = (270._dp - thetamax) * dg2rd + thetamax = (270._dp - thetaminloc) * dg2rd else thetamin = thetamin * dg2rd thetamax = thetamax * dg2rd end if - thetamin = mod(thetamin, 2.d0 * pi) - thetamax = mod(thetamax, 2.d0 * pi) + thetamin = mod(thetamin, 2._dp * pi) + thetamax = mod(thetamax, 2._dp * pi) if (thetamin >= thetamax) then - if (thetamax >= 0.d0) then + if (thetamax >= 0._dp) then do while (thetamin >= thetamax) - thetamin = thetamin - 2.d0 * pi + thetamin = thetamin - 2._dp * pi end do else do while (thetamin > thetamax) - thetamax = thetamax + 2.d0 * pi + thetamax = thetamax + 2._dp * pi end do end if - elseif (thetamax > thetamin + 2.d0 * pi) then - do while (thetamax > thetamin + 2.d0 * pi) - thetamin = thetamin + 2.d0 * pi + elseif (thetamax > thetamin + 2._dp * pi) then + do while (thetamax > thetamin + 2._dp * pi) + thetamin = thetamin + 2._dp * pi end do end if if (single_dir == 0) then dtheta = dtheta * dg2rd - if (dtheta > 0d0) then ! safety + if (dtheta > 0_dp) then ! safety ntheta = max(nint((thetamax - thetamin) / dtheta), 1) else ntheta = 1 @@ -695,37 +696,37 @@ subroutine xbeach_makethetagrid() dtheta = thetamax - thetamin end if else - dtheta = 2d0 * pi + dtheta = 2.0_dp * pi ntheta = 1 end if - call realloc(csx, ntheta, stat=ierr, keepExisting=.false., fill=0d0) + call realloc(csx, ntheta, stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('csx (ntheta)', ierr, ntheta) - call realloc(snx, ntheta, stat=ierr, keepExisting=.false., fill=0d0) + call realloc(snx, ntheta, stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('snx (ntheta)', ierr, ntheta) - call realloc(thet, [ntheta, ndx], stat=ierr, keepExisting=.false., fill=0d0) + call realloc(thet, [ntheta, ndx], stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('thet (ntheta,ndx)', ierr, ntheta * ndx) - call realloc(costh, [ntheta, ndx], stat=ierr, keepExisting=.false., fill=0d0) + call realloc(costh, [ntheta, ndx], stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('costh (ntheta,ndx)', ierr, ntheta * ndx) - call realloc(sinth, [ntheta, ndx], stat=ierr, keepExisting=.false., fill=0d0) + call realloc(sinth, [ntheta, ndx], stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('sinth (ntheta,ndx)', ierr, ntheta * ndx) - call realloc(thetabin, ntheta, stat=ierr, keepExisting=.false., fill=0d0) + call realloc(thetabin, ntheta, stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('thetabin (ntheta)', ierr, ntheta) if (single_dir == 1) then dtheta_s = dtheta_s * dg2rd ntheta_s = nint((thetamax - thetamin) / dtheta_s) - call realloc(thetabin_s, ntheta_s, stat=ierr, keepExisting=.false., fill=0d0) + call realloc(thetabin_s, ntheta_s, stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('thetabin_s (ntheta_s)', ierr, ntheta_s) - call realloc(thet_s, [ntheta_s, ndx], stat=ierr, keepExisting=.false., fill=0d0) + call realloc(thet_s, [ntheta_s, ndx], stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('thet_s (ntheta_s,ndx)', ierr, ntheta_s * ndx) - call realloc(costh_s, [ntheta_s, ndx], stat=ierr, keepExisting=.false., fill=0d0) + call realloc(costh_s, [ntheta_s, ndx], stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('costh_s (ntheta_s,ndx)', ierr, ntheta_s * ndx) - call realloc(sinth_s, [ntheta_s, ndx], stat=ierr, keepExisting=.false., fill=0d0) + call realloc(sinth_s, [ntheta_s, ndx], stat=ierr, keepExisting=.false., fill=0.0_dp) call aerr('sinth_s (ntheta_s,ndx)', ierr, ntheta_s * ndx) else - dtheta_s = 2d0 * pi + dtheta_s = 2.0_dp * pi ntheta_s = 0 allocate (thetabin_s(0)) allocate (thet_s(0, 0)) @@ -734,7 +735,7 @@ subroutine xbeach_makethetagrid() end if do itheta = 1, ntheta - thetabin(itheta) = thetamin + dtheta / 2d0 + dtheta * (itheta - 1) + thetabin(itheta) = thetamin + dtheta / 2.0_dp + dtheta * (itheta - 1) end do do itheta = 1, ntheta @@ -749,14 +750,14 @@ subroutine xbeach_makethetagrid() if (single_dir == 1) then do itheta = 1, ntheta_s - thetabin_s(itheta) = mod(thetamin + dtheta_s / 2.0 + dtheta_s * (itheta - 1), 2d0 * pi) + thetabin_s(itheta) = mod(thetamin + dtheta_s / 2.0_dp + dtheta_s * (itheta - 1), 2.0_dp * pi) end do do itheta = 1, ntheta_s do k = 1, ndx thet_s(itheta, k) = thetabin_s(itheta) - costh_s(itheta, k) = cos(mod(thetabin_s(itheta), 2d0 * pi)) - sinth_s(itheta, k) = sin(mod(thetabin_s(itheta), 2d0 * pi)) + costh_s(itheta, k) = cos(mod(thetabin_s(itheta), 2.0_dp * pi)) + sinth_s(itheta, k) = sin(mod(thetabin_s(itheta), 2.0_dp * pi)) end do end do end if @@ -785,18 +786,18 @@ subroutine xbeach_dispersion(hh) if (hh(k) > epshu) then L0(k) = 2 * pi * ag / (sigmwav(k)**2) else - L0(k) = 0d0 + L0(k) = 0_dp end if end do L1 = L0 do k = 1, ndxi if (hh(k) > epshu) then - if (2 * pi / L0(k) * hh(k) > 5d0) then + if (2 * pi / L0(k) * hh(k) > 5_dp) then Ltemp(k) = L0(k) else Ltemp(k) = iteratedispersion(L0(k), Ltemp(k), pi, hh(k)) - if (Ltemp(k) < 0.d0) then ! this is an error from iteratedispersion + if (Ltemp(k) < 0._dp) then ! this is an error from iteratedispersion Ltemp(k) = -Ltemp(k) call writelog('lws', '', 'Warning: no convergence in dispersion relation iteration at t = ', & time0) @@ -819,15 +820,15 @@ subroutine xbeach_dispersion(hh) do k = 1, ndx kwav(k) = 2 * pi / max(L1(k), epshu) cwav(k) = sigmwav(k) / kwav(k) - kh = min(kwav(k) * hh(k), 10.0d0) - nwav(k) = 0.5d0 + kh / max(sinh(2d0 * kh), epshu) + kh = min(kwav(k) * hh(k), 10.0_dp) + nwav(k) = 0.5_dp + kh / max(sinh(2_dp * kh), epshu) cgwav(k) = cwav(k) * nwav(k) end do where (hh <= epshu) - kwav = 25d0 + kwav = 25_dp cwav = sqrt(ag * epshu) - nwav = 1.d0 + nwav = 1._dp cgwav = sqrt(ag * epshu) end where @@ -848,12 +849,12 @@ function iteratedispersion(L0, Lestimate, px, h) result(L) real(kind=dp) :: L1, L2 integer :: iter real(kind=dp) :: err - real(kind=dp), parameter :: aphi = 1.d0 / (((1.0d0 + sqrt(5.0d0)) / 2) + 1) - real(kind=dp), parameter :: bphi = ((1.0d0 + sqrt(5.0d0)) / 2) / (((1.0d0 + sqrt(5.0d0)) / 2) + 1) + real(kind=dp), parameter :: aphi = 1._dp / (((1.0_dp + sqrt(5.0_dp)) / 2) + 1) + real(kind=dp), parameter :: bphi = ((1.0_dp + sqrt(5.0_dp)) / 2) / (((1.0_dp + sqrt(5.0_dp)) / 2) + 1) integer, parameter :: itermax = 150 - real(kind=dp), parameter :: errmax = 0.00001d0 + real(kind=dp), parameter :: errmax = 0.00001_dp - err = huge(0.0d0) + err = huge(0.0_dp) iter = 0 L1 = Lestimate do while (err > errmax .and. iter < itermax) @@ -908,18 +909,18 @@ subroutine xbeach_wave_instationary() allocate (gammax_correct(1:ndx), stat=ierr) xb_started = 1 - !ee_eps = 0.00001d0 + !ee_eps = 0.00001_dp !tt_eps = waveps !important to limit wave celerities to 1 in case of cells for which hs 0) then @@ -942,7 +943,7 @@ subroutine xbeach_wave_instationary() if (single_dir == 0) then do k = 1, ndx ! stack - thetamean(k) = sum(ee1(:, k) * thet(:, k), dim=1) / max(sum(ee1(:, k), dim=1), 0.00001d0) ! energy weighted wave direction + thetamean(k) = sum(ee1(:, k) * thet(:, k), dim=1) / max(sum(ee1(:, k), dim=1), 0.00001_dp) ! energy weighted wave direction end do else ! thetamean determined in wave_stationary, ntheta=1 @@ -1004,17 +1005,17 @@ subroutine xbeach_wave_instationary() call getcellcentergradients(umwci, xbducxdx, xbducxdy) call getcellcentergradients(vmwci, xbducydx, xbducydy) else - xbducxdx = 0.d0 - xbducydx = 0.d0 - xbducxdy = 0.d0 - xbducydy = 0.d0 + xbducxdx = 0._dp + xbducydx = 0._dp + xbducxdy = 0._dp + xbducydy = 0._dp end if ! ! Calculate sinh(2kh) - where (2d0 * hh * kwav <= 3000.d0) - sinh2kh = sinh(min(2d0 * kwav * hh, 10.0d0)) + where (2_dp * hh * kwav <= 3000._dp) + sinh2kh = sinh(min(2_dp * kwav * hh, 10.0_dp)) elsewhere - sinh2kh = 3000.d0 + sinh2kh = 3000._dp end where ! call xbeach_compute_wave_velocities(1, dhsdx, dhsdy, xbducxdx, xbducxdy, xbducydx, xbducydy, sinh2kh) @@ -1028,22 +1029,22 @@ subroutine xbeach_wave_instationary() if (vol1(k) > epshu * ba(k)) then ee1(itheta, k) = ee1(itheta, k) - dts * (horadvec(itheta, k) * bai(k) + thetaadvec(itheta, k)) else - ee1(itheta, k) = 0d0 + ee1(itheta, k) = 0_dp end if end do end do ee1 = ee1 * sigt ! Back to wave energy - ee1 = max(ee1, 0.0d0) + ee1 = max(ee1, 0.0_dp) !endif ! where (wete == 1) E = sum(ee1, dim=1) * dtheta elsewhere - E = 0.d0 + E = 0._dp end where - H = sqrt(8.d0 * E / rhomean / ag) + H = sqrt(8._dp * E / rhomean / ag) ! ! Correct for gammax in these areas where (H > gammaxxb * hs .and. wete == 1) @@ -1062,7 +1063,7 @@ subroutine xbeach_wave_instationary() H = min(H, gammaxxb * hs) end where ! - rhog8 = rhomean * ag / 8d0 + rhog8 = rhomean * ag / 8_dp where (gammax_correct) E = rhog8 * H**2 end where @@ -1072,30 +1073,30 @@ subroutine xbeach_wave_instationary() call xbeach_wave_breaker_dissipation(dts, break, waveps, hhw, kwav, km, gamma, gamma2, nroelvink, QB, alpha, Trep, cwav, thetamean, H, D, sigmwav, wci, 0) ! Dissipation by bed friction - dfac = 2.d0 * fw * rhomean / (3.d0 * pi) + dfac = 2._dp * fw * rhomean / (3._dp * pi) do k = 1, Ndx - uorb(k) = H(k) * sigmwav(k) / 2d0 * sinhsafei(kwav(k) * hh(k)) ! uorb uit XBeach + uorb(k) = H(k) * sigmwav(k) / 2_dp * sinhsafei(kwav(k) * hh(k)) ! uorb uit XBeach Df(k) = dfac(k) * uorb(k)**3 end do if (jauorb == 0) then ! old d3d convention - uorb = uorb * sqrt(pi) / 2d0 ! only on hrms derived value, not on SWAN read uorb + uorb = uorb * sqrt(pi) / 2_dp ! only on hrms derived value, not on SWAN read uorb end if where (hh > fwcutoff) - Df = 0.d0 + Df = 0._dp end where ! ! Distribution of total dissipation over directions ! do itheta = 1, ntheta - ddlok(itheta, :) = ee1(itheta, :) * D / max(E, 1d-5) ! breaking - dd(itheta, :) = ddlok(itheta, :) + ee1(itheta, :) * Df / max(E, 1d-5) ! breaking plus friction + ddlok(itheta, :) = ee1(itheta, :) * D / max(E, 1e-5_dp) ! breaking + dd(itheta, :) = ddlok(itheta, :) + ee1(itheta, :) * Df / max(E, 1e-5_dp) ! breaking plus friction end do !if (windmodel.eq.1) then ! ! wave period depth limitation - ! call xbeach_wave_compute_period_depth_limitation( 1.d0/8.d0*rhomean*ag*(gammaxxb*hh**2) , Tdeplim) + ! call xbeach_wave_compute_period_depth_limitation( 1._dp/8._dp*rhomean*ag*(gammaxxb*hh**2) , Tdeplim) ! do itheta=1,ntheta ! tt1(itheta,:) = min(tt1(itheta,:) , Tdeplim ) ! enddo @@ -1109,10 +1110,10 @@ subroutine xbeach_wave_instationary() ! if (jawsource.eq.1) then ! call xbeach_windsource(ee1, E, tt1, sigmwav , cgwavt, cgwav, hh, dtmaxwav, wsorE, wsorT,egradcg,SwE,SwT) ! else - ! wsorE=0.d0 - ! wsorT=0.d0 - ! SwE=0.d0 - ! SwT=0.d0 + ! wsorE=0._dp + ! wsorT=0._dp + ! SwE=0._dp + ! SwT=0._dp ! endif !endif ! windmodel @@ -1125,12 +1126,12 @@ subroutine xbeach_wave_instationary() if (vol1(k) > epshu * ba(k)) then rr(itheta, k) = rr(itheta, k) - dts * (rrhoradvec(itheta, k) * bai(k) + rrthetaadvec(itheta, k)) else - rr(itheta, k) = 0d0 + rr(itheta, k) = 0_dp end if end do end do - rr = max(rr, 0.0d0) + rr = max(rr, 0.0_dp) ! euler step roller energy dissipation !if (windmodel.eq.1) then @@ -1141,20 +1142,20 @@ subroutine xbeach_wave_instationary() ! tt1(itheta,k) = tt1(itheta, k) + min( dtmaxwav * (wsorT(itheta, k) - ddT(k) ) , tt1(itheta, k) ) ! ! ! if(roller==1) then - ! drr(itheta, k) = 2*ag*BR(k)*max(rr(itheta, k),0.0d0)/ cwav(k) + ! drr(itheta, k) = 2*ag*BR(k)*max(rr(itheta, k),0.0_dp)/ cwav(k) ! rr(itheta, k)=rr(itheta, k)+dtmaxwav*(ddlok(itheta, k) -drr(itheta, k)) ! else if (roller==0) then - ! rr(itheta, k) = 0.0d0 - ! drr(itheta, k) = 0.0d0 + ! rr(itheta, k) = 0.0_dp + ! drr(itheta, k) = 0.0_dp ! endif ! ! ! ee1(itheta, k) = max(ee1(itheta, k),ee_eps) ! tt1(itheta, k) = max(tt1(itheta, k), tt_eps) - ! rr(itheta, k) = max(rr(itheta, k),0.0d0) + ! rr(itheta, k) = max(rr(itheta, k),0.0_dp) ! else ! ee1(itheta, k) = ee_eps ! tt1(itheta, k) = tt_eps - ! rr(itheta, k) = 0.0d0 + ! rr(itheta, k) = 0.0_dp ! end if ! end do ! end do @@ -1171,17 +1172,17 @@ subroutine xbeach_wave_instationary() if (wete(k) == 1) then ee1(itheta, k) = ee1(itheta, k) - dts * dd(itheta, k) ! totale dissipatie if (roller > 0) then - drr(itheta, k) = 2.0 * ag * BR(k) * max(rr(itheta, k), 0.0d0) / cwav(k) + drr(itheta, k) = 2.0 * ag * BR(k) * max(rr(itheta, k), 0.0_dp) / cwav(k) rr(itheta, k) = rr(itheta, k) + dts * (ddlok(itheta, k) - drr(itheta, k)) ! only wave breaker dissipation else - rr(itheta, k) = 0.0d0 - drr(itheta, k) = 0.0d0 + rr(itheta, k) = 0.0_dp + drr(itheta, k) = 0.0_dp end if - ee1(itheta, k) = max(ee1(itheta, k), 0.0d0) - rr(itheta, k) = max(rr(itheta, k), 0.0d0) + ee1(itheta, k) = max(ee1(itheta, k), 0.0_dp) + rr(itheta, k) = max(rr(itheta, k), 0.0_dp) else - ee1(itheta, k) = 0.0d0 - rr(itheta, k) = 0.0d0 + ee1(itheta, k) = 0.0_dp + rr(itheta, k) = 0.0_dp end if ! wete end do end do @@ -1197,7 +1198,7 @@ subroutine xbeach_wave_instationary() ! OUTPUT Bulk quantities do k = 1, ndx ! stack E(k) = sum(ee1(:, k), dim=1) * dtheta - H(k) = sqrt(8.d0 * E(k) / rhomean / ag) + H(k) = sqrt(8._dp * E(k) / rhomean / ag) end do Dtot = D + Df @@ -1209,7 +1210,7 @@ subroutine xbeach_wave_instationary() else ! need something here for mor rsl = sin(beta) do k = 1, ndx - R(k) = 9d-1 * rhomean * ag * rsl * H(k)**2 ! Martins 2018 + R(k) = 9e-1_dp * rhomean * ag * rsl * H(k)**2 ! Martins 2018 DR(k) = 2.0 * ag * beta * R(k) / cwav(k) end do end if @@ -1218,15 +1219,15 @@ subroutine xbeach_wave_instationary() ! For single_dir, this is done in stationary part if (single_dir == 0) then do k = 1, ndx - thetamean(k) = (sum(ee1(:, k) * thet(:, k), dim=1) / dble(ntheta)) / (max(sum(ee1(:, k), dim=1), 0.00001d0) / dble(ntheta)) + thetamean(k) = (sum(ee1(:, k) * thet(:, k), dim=1) / dble(ntheta)) / (max(sum(ee1(:, k), dim=1), 0.00001_dp) / dble(ntheta)) end do ! ! Copy thetamean to first dry cells next to waterline by simple averaging do k = 1, ndx if (hs(k) > epshu) cycle n = 0 - cost = 0d0 - sint = 0d0 + cost = 0_dp + sint = 0_dp do L = 1, nd(k)%lnx Lf = abs(L) k1 = ln(1, Lf) @@ -1253,7 +1254,7 @@ subroutine xbeach_wave_instationary() ! Energy limitation roller; strictly speaking, I would expect this after advection step gammax_correct = .false. if (rollergammax == 1) then - RH = sqrt(8d0 * R / rhomean / ag) + RH = sqrt(8_dp * R / rhomean / ag) where (RH > gammaxxb * hhw .and. wete == 1) gammax_correct = .true. elsewhere @@ -1271,7 +1272,7 @@ subroutine xbeach_wave_instationary() ! ! Correct roller dissipation, check with Dano !where (hs>epshu) - ! DR = 2d0*ag*beta1*R/cwav + ! DR = 2_dp*ag*beta1*R/cwav !endwhere end if @@ -1317,8 +1318,8 @@ subroutine xbeach_wave_compute_flowforcing2D() ! Radiation stresses nwav = cgwav / max(cwav, sqrt(ag * epshu)) do k = 1, ndx ! stack - Sxx(k) = (nwav(k) * sum((1.d0 + costh(:, k)**2) * ee1(:, k), dim=1) - .5d0 * sum(ee1(:, k), dim=1)) * dtheta ! wave energy contribution - Syy(k) = (nwav(k) * sum((1.d0 + sinth(:, k)**2) * ee1(:, k), dim=1) - .5d0 * sum(ee1(:, k), dim=1)) * dtheta + Sxx(k) = (nwav(k) * sum((1._dp + costh(:, k)**2) * ee1(:, k), dim=1) - .5_dp * sum(ee1(:, k), dim=1)) * dtheta ! wave energy contribution + Syy(k) = (nwav(k) * sum((1._dp + sinth(:, k)**2) * ee1(:, k), dim=1) - .5_dp * sum(ee1(:, k), dim=1)) * dtheta Sxy(k) = nwav(k) * sum(sinth(:, k) * costh(:, k) * ee1(:, k), dim=1) * dtheta Sxx(k) = Sxx(k) + sum((costh(:, k)**2) * rr(:, k), dim=1) * dtheta ! Roller contribution @@ -1327,12 +1328,12 @@ subroutine xbeach_wave_compute_flowforcing2D() end do ! Wave forces Fx, Fy, value on links - Fx_cc = 0d0 - Fy_cc = 0d0 - dsxxdx = 0d0 - dsyydy = 0d0 - dsxydy = 0d0 - dsxydx = 0d0 + Fx_cc = 0_dp + Fy_cc = 0_dp + dsxxdx = 0_dp + dsyydy = 0_dp + dsxydy = 0_dp + dsxydx = 0_dp ! Jipjanneke do L = 1, lnx k1 = ln(1, L) @@ -1386,17 +1387,17 @@ subroutine xbeach_wave_compute_flowforcing2D() if (kmx == 0) then do L = 1, Lnx k1 = ln(1, L); k2 = ln(2, L) - Fx(L) = (acL(L) * Fx_cc(k1) + (1d0 - acL(L)) * Fx_cc(k2)) - Fy(L) = (acL(L) * Fy_cc(k1) + (1d0 - acL(L)) * Fy_cc(k2)) - !rhoL = ( acL(L)*rho(k1) + (1d0-acL(L))*rho(k2) ) + Fx(L) = (acL(L) * Fx_cc(k1) + (1_dp - acL(L)) * Fx_cc(k2)) + Fy(L) = (acL(L) * Fy_cc(k1) + (1_dp - acL(L)) * Fy_cc(k2)) + !rhoL = ( acL(L)*rho(k1) + (1_dp-acL(L))*rho(k2) ) rhoL = rhomean wavfu(L) = (Fx(L) * csu(L) + Fy(L) * snu(L)) / (rhoL * max(hu(L), hminlw)) wavfv(L) = (-Fx(L) * snu(L) + Fy(L) * csu(L)) / (rhoL * max(hu(L), hminlw)) end do where (hu <= epshu) - wavfu = 0d0 - wavfv = 0d0 + wavfu = 0_dp + wavfv = 0_dp end where end if @@ -1415,7 +1416,7 @@ subroutine xbeach_wave_maxtimestep() integer :: k, k1, k2, kk, L, itheta real(kind=dp) :: dum, cgwavL, cwuL, dt, kkcflmxloc - dtmaxwav = huge(0d0) + dtmaxwav = huge(0_dp) kkcflmxloc = 0 ! Calculate max CFL based timestep for wave calculation @@ -1425,7 +1426,7 @@ subroutine xbeach_wave_maxtimestep() if (idomain(k) /= my_rank) cycle end if do itheta = 1, ntheta - dum = 0.d0 + dum = 0._dp do kk = 1, nd(k)%lnx L = abs(nd(k)%ln(kk)) k1 = ln(1, L) @@ -1440,14 +1441,14 @@ subroutine xbeach_wave_maxtimestep() dum = dum + cwuL * wu(L) end if end do - if (dum > tiny(0d0)) then + if (dum > tiny(0.0_dp)) then dt = cflmx * ba(k) / dum if (dt < dtmaxwav) then dtmaxwav = dt end if end if dum = ctheta(itheta, k) / dtheta - if (dum > tiny(0d0)) then + if (dum > tiny(0.0_dp)) then dt = cflmx / dum if (dt < dtmaxwav) then dtmaxwav = dt @@ -1512,10 +1513,10 @@ subroutine xbeach_wave_dispersion(callType) if (wci > 0) then allocate (ulocal(1:ndx)) allocate (vlocal(1:ndx)) - L0 = 0.d0 - L1 = -huge(0.d0) + L0 = 0._dp + L1 = -huge(0._dp) end if - Trepold = 0.d0 + Trepold = 0._dp call xbeach_dispersion(hhw) ! at initialisation, water depth is always hhw==hs km = kwav end if @@ -1541,8 +1542,8 @@ subroutine xbeach_wave_dispersion(callType) end select if (wci > 0) then - arg = min(100.0d0, km * hh) - fac = (1.d0 + ((km * H / 2.d0)**2)) ! use deep water correction + arg = min(100.0_dp, km * hh) + fac = (1._dp + ((km * H / 2._dp)**2)) ! use deep water correction do n = 1, nbndw kb = kbndw(1, n) sigmwav(kb) = sqrt(ag * km(kb) * tanh(arg(kb))) @@ -1551,31 +1552,31 @@ subroutine xbeach_wave_dispersion(callType) kmx = km * cos(thetamean) kmy = km * sin(thetamean) wm = sigmwav + kmx * ulocal * min( & - min(hh / hwci, 1.d0), & - min(1.d0, (1.d0 - hh / hwcimax)) & + min(hh / hwci, 1._dp), & + min(1._dp, (1._dp - hh / hwcimax)) & ) + & kmy * vlocal * min( & - min(hh / hwci, 1.d0), & - min(1.d0, (1.d0 - hh / hwcimax)) & + min(hh / hwci, 1._dp), & + min(1._dp, (1._dp - hh / hwcimax)) & ) ! - where (km > 0.01d0) + where (km > 0.01_dp) cwav = sigmwav / km - cgwav = cwav * (0.5d0 + arg / sinh(2 * arg)) * sqrt(fac) ! & to include more - ! + km*(H/2)**2*sqrt(max(par%g*km*tanh(arg),0.001d0))/sqrt(max(fac,0.001d0)) ! include wave steepness - nwav = 0.5d0 + km * hh / sinh(2 * max(km, 0.00001d0) * hh) + cgwav = cwav * (0.5_dp + arg / sinh(2 * arg)) * sqrt(fac) ! & to include more + ! + km*(H/2)**2*sqrt(max(par%g*km*tanh(arg),0.001_dp))/sqrt(max(fac,0.001_dp)) ! include wave steepness + nwav = 0.5_dp + km * hh / sinh(2 * max(km, 0.00001_dp) * hh) elsewhere cwav = sqrt(ag * epshu) cgwav = sqrt(ag * epshu) - nwav = 1.d0 + nwav = 1._dp end where ! - cgym = cgwav * sin(thetamean) + vlocal * min(min(hh / hwci, 1.d0), min(1.d0, (1.d0 - hh / hwcimax))) - cgxm = cgwav * cos(thetamean) + ulocal * min(min(hh / hwci, 1.d0), min(1.d0, (1.d0 - hh / hwcimax))) + cgym = cgwav * sin(thetamean) + vlocal * min(min(hh / hwci, 1._dp), min(1._dp, (1._dp - hh / hwcimax))) + cgxm = cgwav * cos(thetamean) + ulocal * min(min(hh / hwci, 1._dp), min(1._dp, (1._dp - hh / hwcimax))) ! ! Compute slopes of wave number in cell centres - dkmydx = 0d0 - dkmxdy = 0d0 + dkmydx = 0_dp + dkmxdy = 0_dp do L = 1, lnx k1 = ln(1, L) k2 = ln(2, L) @@ -1586,15 +1587,15 @@ subroutine xbeach_wave_dispersion(callType) end do ! ! Calculate advection part - advel = 1d0 - advec = 0d0 + advel = 1_dp + advec = 0_dp call advec_upw_bulk(thetamean, wm, advel, advec) do k = 1, ndx km(k) = km(k) - dts * advec(k) * bai(k) kmx(k) = kmx(k) - dts * cgym(k) * (dkmydx(k) - dkmxdy(k)) kmy(k) = kmy(k) + dts * cgxm(k) * (dkmydx(k) - dkmxdy(k)) km(k) = km(k) + hypot(kmx(k), kmy(k)) - km(k) = min(km(k), 25d0) + km(k) = min(km(k), 25.0_dp) end do ! do n = 1, nbndw @@ -1613,13 +1614,13 @@ subroutine xbeach_wave_dispersion(callType) end do ! ! non-linear dispersion - arg = min(100.0d0, km * hh) - arg = max(arg, 0.0001d0) + arg = min(100.0_dp, km * hh) + arg = max(arg, 0.0001_dp) ! - fac = (1.d0 + ((km * H / 2.d0)**2)) + fac = (1._dp + ((km * H / 2._dp)**2)) ! sigmwav = sqrt(ag * km * tanh(arg) * fac) - sigmwav = max(sigmwav, 0.010d0) + sigmwav = max(sigmwav, 0.010_dp) ! update intrinsic frequency do itheta = 1, ntheta sigt(itheta, :) = sigmwav @@ -1629,9 +1630,9 @@ subroutine xbeach_wave_dispersion(callType) kwav = km else ! check if we need to recompute sigm and sigt - if (abs(Trep - Trepold) / Trep > 1d-4) then + if (abs(Trep - Trepold) / Trep > 1e-4_dp) then Trepold = Trep - sigmwav = 2d0 * pi / Trep + sigmwav = 2_dp * pi / Trep do itheta = 1, ntheta sigt(itheta, :) = sigmwav end do @@ -1691,11 +1692,11 @@ subroutine xbeach_wave_bc() ierror = 1 if (.not. allocated(dist)) allocate (dist(1:ntheta), factor(1:ntheta), e01(1:ntheta)) ! - eeout = 0d0 - uin = 0d0 - vin = 0d0 - qxbc = 0d0 - qybc = 0d0 + eeout = 0_dp + uin = 0_dp + vin = 0_dp + qxbc = 0_dp + qybc = 0_dp ! ! note: also in xbeach_spectral_wave_init call get_hboundary(hboundary) @@ -1733,7 +1734,7 @@ subroutine xbeach_wave_bc() end if ! do n = 1, nwbnd - Trep = 1d-1 ! safety for max reduction below + Trep = 1e-1_dp ! safety for max reduction below LL1 = L1wbnd(n) LL2 = L2wbnd(n) if (LL1 > LL2) cycle @@ -1747,7 +1748,7 @@ subroutine xbeach_wave_bc() waveBoundaryParameters(n)%hboundary = hboundary(n) waveBoundaryParameters(n)%randomseed = randomseed(n) - call realloc(ees, [ntheta_s, LL2 - LL1 + 1], keepExisting=.false., fill=0d0) + call realloc(ees, [ntheta_s, LL2 - LL1 + 1], keepExisting=.false., fill=0.0_dp) call create_incident_waves_surfbeat(LL2 - LL1 + 1, n, & waveBoundaryParameters(n)%ntheta, time0, & @@ -1761,7 +1762,7 @@ subroutine xbeach_wave_bc() ) ! Watch out: Hbc is Hm0 Trep = Tbc - dir0 = mod(270d0 - Dbc / pi * 180d0, 360d0) ! for single_dir and absgen_bc + dir0 = mod(270.0_dp - Dbc / pi * 180.0_dp, 360.0_dp) ! for single_dir and absgen_bc if (single_dir > 0) then ee_s(:, LL1:LL2) = ees end if @@ -2044,7 +2045,7 @@ subroutine xbeach_wave_bc() end if !if (windmodel .eq. 1) then - ! zbndw(:,n)=max(e01*E1/max(Emean,0.000001d0)*min(time0/taper,1.d0),Eini) + ! zbndw(:,n)=max(e01*E1/max(Emean,0.000001_dp)*min(time0/taper,1._dp),Eini) !else zbndw(:, n) = e01 * E1 / max(Emean, 0.000001_dp) * min(time0 / taper, 1.0_dp) !endif @@ -2219,7 +2220,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k break = trim(break) if (break == 'roelvink1') then ! Dissipation according to Roelvink (1993) - !H = sqrt(8.d0*E/rhomean/ag) + !H = sqrt(8._dp*E/rhomean/ag) H = hwav hr = hhw kmr = min(max(kwav, 0.01_dp), 100.0_dp) @@ -2259,7 +2260,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k gam = gamma end if - !H = sqrt(8.d0/rhomean/ag*E) + !H = sqrt(8._dp/rhomean/ag*E) H = hwav Hb = tanh(gam * kh / 0.88_dp) * (0.88_dp / max(kwav, 1.0e-10_dp)) R = Hb / max(H, 0.00001_dp) @@ -2268,7 +2269,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k D = 0.25_dp * alpha * f * rhomean * ag * (Hb**2 + H**2) * Qb elseif (break == 'roelvink2') then - !H = sqrt(8.d0*E/rhomean/ag) + !H = sqrt(8._dp*E/rhomean/ag) H = hwav hr = hhw hh = max(hs, waveps) @@ -2289,7 +2290,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k D = D / Trep * H / hh end if elseif (trim(break) == 'roelvink_daly') then - !H = sqrt(8.d0*E/rhomean/ag) + !H = sqrt(8._dp*E/rhomean/ag) H = hwav call advec_upw_bulk(thetamean, Qb, cwav, Qb_advec) ! first order upwind, with mean direction do k = 1, ndxi @@ -2310,7 +2311,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k end if elseif (break == 'janssen') then ! Dissipation according to Janssen and Battjes (2007) - !H = sqrt(8.d0*E/rhomean/ag) + !H = sqrt(8._dp*E/rhomean/ag) H = hwav if (wci /= 0) then f = sigmwav / 2.0_dp / pi @@ -2407,7 +2408,7 @@ subroutine advec_horz(dtmaxwav, snx, csx, limtypw, quant, veloc, advec) ds = cf * dslim(ds1, ds2, limtypw) ! reconstructie van totale slope volgens 1 van de 4 schema's ! centraal schema ! if (limtypw == 99) then - ds = cf * dlimiter_nonequi(ds1, ds2, half, 1d0) * ds2 + ds = cf * dlimiter_nonequi(ds1, ds2, half, 1._dp) * ds2 end if ! if (abs(ds) > eps10) then ! als celgemiddelde niet volstaat @@ -2476,15 +2477,15 @@ subroutine advec_upw_bulk(thetamean, quant, veloc, advec) real(kind=dp), intent(in), dimension(ndx) :: quant real(kind=dp), intent(out), dimension(ndx) :: advec - advec = 0d0 + advec = 0_dp do L = 1, lnx ! upwind (supq) + limited high order (dsq), loop over link k1 = ln(1, L); k2 = ln(2, L) ! linker en rechtercelnr geassocieerd aan de links - velocL = acL(L) * veloc(k1) + (1d0 - acL(L)) * veloc(k2) + velocL = acL(L) * veloc(k1) + (1_dp - acL(L)) * veloc(k2) cwuL = velocL * (csu(L) * cos(thetamean(k1)) + snu(L) * sin(thetamean(k1))) ! met cwi: u1(L) + cg*( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) if (cwuL > 0) then ! -> ds1 ds2 - k = k1; kd = k2; is = 1; half = 1d0 - acl(L); ip = 0 ! -> ku k kd + k = k1; kd = k2; is = 1; half = 1_dp - acl(L); ip = 0 ! -> ku k kd else ! <- ds2 ds1 k = k2; kd = k1; is = -1; half = acl(L); ip = 3 ! <- kd k ku end if ! acL = linkse dx fractie van afstand tussen flownodes (slide 83) @@ -2543,20 +2544,20 @@ subroutine advec_dir(quan, veloc, advec) real(kind=dp), dimension(ntheta, ndx), intent(in) :: veloc, quan real(kind=dp), dimension(ntheta, ndx), intent(out) :: advec - advec = 0d0 + advec = 0_dp if (ntheta > 1) then do k = 1, ndx do itheta = 2, ntheta - 2 - ctheta_between = 0.5d0 * (veloc(itheta, k) + veloc(itheta + 1, k)) + ctheta_between = 0.5_dp * (veloc(itheta, k) + veloc(itheta + 1, k)) if (ctheta_between > 0) then - eeup = 1.5d0 * quan(itheta, k) - .5 * quan(itheta - 1, k) - if (eeup < 0.d0) then + eeup = 1.5_dp * quan(itheta, k) - .5 * quan(itheta - 1, k) + if (eeup < 0._dp) then eeup = quan(itheta, k) end if fluxtheta(itheta) = eeup * ctheta_between else - eeup = 1.5d0 * quan(itheta + 1, k) - .5 * quan(itheta + 2, k) - if (eeup < 0.d0) then + eeup = 1.5_dp * quan(itheta + 1, k) - .5 * quan(itheta + 2, k) + if (eeup < 0._dp) then eeup = quan(itheta + 1, k) end if fluxtheta(itheta) = eeup * ctheta_between @@ -2568,27 +2569,27 @@ subroutine advec_dir(quan, veloc, advec) if (ctheta_between > 0) then fluxtheta(itheta) = quan(itheta, k) * ctheta_between else - eeup = 1.5d0 * quan(itheta + 1, k) - .5 * quan(itheta + 2, k) - if (eeup < 0.d0) eeup = quan(itheta + 1, k) + eeup = 1.5_dp * quan(itheta + 1, k) - .5 * quan(itheta + 2, k) + if (eeup < 0._dp) eeup = quan(itheta + 1, k) fluxtheta(itheta) = eeup * ctheta_between end if itheta = ntheta - 1 ! only compute for itheta==ntheta-1 ctheta_between = .5 * (veloc(itheta + 1, k) + veloc(itheta, k)) if (ctheta_between > 0) then - eeup = 1.5d0 * quan(itheta, k) - .5 * quan(itheta - 1, k) - if (eeup < 0.d0) eeup = quan(itheta, k) + eeup = 1.5_dp * quan(itheta, k) - .5 * quan(itheta - 1, k) + if (eeup < 0._dp) eeup = quan(itheta, k) fluxtheta(itheta) = eeup * ctheta_between else eeup = quan(itheta + 1, k) fluxtheta(itheta) = eeup * ctheta_between end if - advec(1, k) = (fluxtheta(1) - 0.d0) / dtheta ! No flux across lower boundary theta grid + advec(1, k) = (fluxtheta(1) - 0._dp) / dtheta ! No flux across lower boundary theta grid do itheta = 2, ntheta - 1 advec(itheta, k) = (fluxtheta(itheta) - fluxtheta(itheta - 1)) / dtheta end do - advec(ntheta, k) = (0.d0 - fluxtheta(ntheta - 1)) / dtheta ! No flux across upper boundary theta grid + advec(ntheta, k) = (0._dp - fluxtheta(ntheta - 1)) / dtheta ! No flux across upper boundary theta grid end do end if @@ -2794,7 +2795,7 @@ subroutine xbeach_spectral_wave_init() ! Ensure all theta directions are between 0 and 2pi, required for some trig. on some compilers do itheta = 1, ntheta - waveBoundaryParameters(ibnd)%theta(itheta) = mod(waveBoundaryParameters(ibnd)%theta(itheta) + twopi, 8.d0 * atan(1.d0)) + waveBoundaryParameters(ibnd)%theta(itheta) = mod(waveBoundaryParameters(ibnd)%theta(itheta) + twopi, 8._dp * atan(1._dp)) end do ! Allocate space for the random seed. This seed should be identical on all processes @@ -2812,7 +2813,7 @@ subroutine xbeach_spectral_wave_init() waveSpectrumAdministration(ibnd)%bccount = 0 ! Initialize bcendtime to zero. ! Stored and defined in spectral_wave_bc_module - waveSpectrumAdministration(ibnd)%spectrumendtime = 0.d0 + waveSpectrumAdministration(ibnd)%spectrumendtime = 0._dp ! Initialise lastwaveheight to zero ! Stored and defined in wave_boundary_main_module allocate (waveSpectrumAdministration(ibnd)%lastwaveelevation(waveBoundaryParameters(ibnd)%np, & @@ -2843,8 +2844,8 @@ subroutine xbeach_spectral_wave_init() ii = ii + 1 waveSpectrumAdministration(ibnd)%nspectra = ii call realloc(waveSpectrumAdministration(ibnd)%ispectra, ii, keepExisting=.true., fill=-999) - call realloc(waveSpectrumAdministration(ibnd)%xspec, ii, keepExisting=.true., fill=-999d0) - call realloc(waveSpectrumAdministration(ibnd)%yspec, ii, keepExisting=.true., fill=-999d0) + call realloc(waveSpectrumAdministration(ibnd)%xspec, ii, keepExisting=.true., fill=dmiss) + call realloc(waveSpectrumAdministration(ibnd)%yspec, ii, keepExisting=.true., fill=dmiss) ! ugly as hell, but no realloc of derived types available ! as number of locations usually small, this should not kill performance if (ii == 1) then @@ -2895,7 +2896,7 @@ subroutine xbeach_spectral_wave_init() ! find nearest point on polyline disall = 1d99 - darc = 0d0 + darc = 0_dp do ip = 1, NPL - 1 xa = XPL(ip) ya = YPL(ip) @@ -2923,7 +2924,7 @@ subroutine xbeach_spectral_wave_init() ! compute weights from mesh to spectrum locations do i = 1, LL2 - LL1 + 1 ! determine arc length along polyline - darc = 0d0 + darc = 0_dp do ip = 1, kL(i) - 1 xa = XPL(ip) ya = YPL(ip) @@ -2951,12 +2952,12 @@ subroutine xbeach_spectral_wave_init() !wavespectrumadministration(ibnd)%kL(i) = iperm(j) wavespectrumadministration(ibnd)%kR(i) = wavespectrumadministration(ibnd)%ispectra(iperm(j)) !wavespectrumadministration(ibnd)%kR(i) = iperm(j) - wavespectrumadministration(ibnd)%wL(i) = 1d0 - wavespectrumadministration(ibnd)%wR(i) = 0d0 + wavespectrumadministration(ibnd)%wL(i) = 1.0_dp + wavespectrumadministration(ibnd)%wR(i) = 0.0_dp if (j + 1 <= waveSpectrumAdministration(ibnd)%nspectra) then wavespectrumadministration(ibnd)%kR(i) = wavespectrumadministration(ibnd)%ispectra(iperm(j + 1)) - wavespectrumadministration(ibnd)%wL(i) = min(max(1d0 - (darc - drL(j)) / (drL(j + 1) - drL(j)), 0d0), 1d0) - wavespectrumadministration(ibnd)%wR(i) = 1d0 - wavespectrumadministration(ibnd)%wL(i) + wavespectrumadministration(ibnd)%wL(i) = min(max(1.0_dp - (darc - drL(j)) / (drL(j + 1) - drL(j)), 0.0_dp), 1.0_dp) + wavespectrumadministration(ibnd)%wR(i) = 1.0_dp - wavespectrumadministration(ibnd)%wL(i) end if end do ! i @@ -2978,9 +2979,9 @@ subroutine xbeach_spectral_wave_init() allocate (wavespectrumadministration(ibnd)%kR(nbndw)) allocate (wavespectrumadministration(ibnd)%wR(nbndw)) wavespectrumadministration(ibnd)%kL = 1 - wavespectrumadministration(ibnd)%wL = 1d0 + wavespectrumadministration(ibnd)%wL = 1_dp wavespectrumadministration(ibnd)%kR = 1 - wavespectrumadministration(ibnd)%wR = 0d0 + wavespectrumadministration(ibnd)%wR = 0_dp else call writelog('ewls', '', 'If nspectrumloc>1 then bcfile should contain spectra locations with LOCLIST header') close (fid) @@ -2990,16 +2991,16 @@ subroutine xbeach_spectral_wave_init() waveBoundaryAdministration(ibnd)%initialized = .true. - waveSpectrumAdministration(ibnd)%Hbc = 0d0 - waveSpectrumAdministration(ibnd)%Tbc = 0d0 - waveSpectrumAdministration(ibnd)%Dbc = 0d0 + waveSpectrumAdministration(ibnd)%Hbc = 0.0_dp + waveSpectrumAdministration(ibnd)%Tbc = 0.0_dp + waveSpectrumAdministration(ibnd)%Dbc = 0.0_dp close (fid) end if if (single_dir > 0) then - call realloc(waveSpectrumAdministration(ibnd)%ee_s, [ntheta_s, LL2 - LL1 + 1], keepExisting=.false., fill=0d0) + call realloc(waveSpectrumAdministration(ibnd)%ee_s, [ntheta_s, LL2 - LL1 + 1], keepExisting=.false., fill=0.0_dp) end if ! Set time to recompute new boundary condition time series to @@ -3024,8 +3025,8 @@ subroutine get_refpoint(xref0, yref0) real(kind=dp), intent(out) :: xref0, yref0 - xref0 = huge(0d0) - yref0 = huge(0d0) + xref0 = huge(0_dp) + yref0 = huge(0_dp) if (nbndw > 0) then xref0 = minval(xbndw(1:nbndw)) yref0 = minval(ybndw(1:nbndw)) @@ -3035,9 +3036,9 @@ subroutine get_refpoint(xref0, yref0) call reduce_double_min(yref0) end if - if (xref0 == huge(0d0)) then ! nbndw=0 for all subdomains, or in sequential run - xref0 = 0d0 - yref0 = 0d0 + if (xref0 == huge(0_dp)) then ! nbndw=0 for all subdomains, or in sequential run + xref0 = 0_dp + yref0 = 0_dp end if end subroutine get_refpoint @@ -3060,8 +3061,8 @@ subroutine get_hboundary(hboundary) integer :: i, k, k2 integer :: LL1, LL2, n - hboundary = 0d0 - dlength = 0d0 + hboundary = 0_dp + dlength = 0_dp if (jampi == 0) then do n = 1, nwbnd ! integrate along wave boundary @@ -3074,10 +3075,10 @@ subroutine get_hboundary(hboundary) end do ! compute average - if (dlength(n) > 0d0) then + if (dlength(n) > 0_dp) then hboundary(n) = hboundary(n) / dlength(n) else - hboundary(n) = 0d0 + hboundary(n) = 0_dp end if end do else @@ -3105,10 +3106,10 @@ subroutine get_hboundary(hboundary) ! compute average k = 0 do k = 1, nwbnd - if (dum(2, k) > 0d0) then + if (dum(2, k) > 0_dp) then hboundary(k) = dum(1, k) / dum(2, k) else - hboundary(k) = 0d0 + hboundary(k) = 0_dp end if end do end if @@ -3136,7 +3137,7 @@ subroutine xbeach_waves(ierr) !> Prepare ! set basic water depth for all wave calculations, dependent on wci, single_dir - if (deltaH > 0.d0) then + if (deltaH > 0._dp) then hhw = max(hs + deltaH * H, epshu) else hhw = max(hs, epshu) @@ -3147,8 +3148,8 @@ subroutine xbeach_waves(ierr) else do k = 1, ndx gammal = H(k) / hhw(k) - if (gammal > 1.d0) then - hstokes(k) = deltahmin * (gammal - 1.d0) * H(k) + hhw(k) + if (gammal > 1._dp) then + hstokes(k) = deltahmin * (gammal - 1._dp) * H(k) + hhw(k) else hstokes(k) = hhw(k) end if @@ -3159,7 +3160,7 @@ subroutine xbeach_waves(ierr) ! rhs is calculated based on time0==time1, and dts==dtprev select case (trim(instat)) case ('stat', 'stat_table') - if ((abs(mod(time0, wavint)) < 0.001d0 * dts) .or. newstatbc == 1) then + if ((abs(mod(time0, wavint)) < 0.001_dp * dts) .or. newstatbc == 1) then call xbeach_wave_dispersion(0) call xbeach_wave_stationary(0) newstatbc = 0 @@ -3170,7 +3171,7 @@ subroutine xbeach_waves(ierr) call update_means_wave_flow() ! ! do refraction - if ((abs(mod(time0, wavint)) < 0.001d0 * dts) .or. newstatbc == 1 .or. time0 == dts) then + if ((abs(mod(time0, wavint)) < 0.001_dp * dts) .or. newstatbc == 1 .or. time0 == dts) then call xbeach_wave_dispersion(1) call xbeach_wave_stationary(1) newstatbc = 0 @@ -3254,23 +3255,23 @@ subroutine xbeach_absgen_bc() ierror = 1 !if (windmodel .eq. 0) then - factime = 1d0 / cats / Trep * dts + factime = 1_dp / cats / Trep * dts !else - ! factime = 1d0/cats/minval(sigmwav)/2d0/pi*dts + ! factime = 1_dp/cats/minval(sigmwav)/2_dp/pi*dts !endif ! compute boundary-averaged velocities numbnd = 0 - uave = 0d0 - vave = 0d0 - dlengthrm = 0d0 + uave = 0_dp + vave = 0_dp + dlengthrm = 0_dp do n = 1, nbndu if (kbndu(4, n) == 5) then Lb = kbndu(3, n) numbnd = kbndu(5, n) if (numbnd > maxnumbnds) then - maxnumbnds = max(int(1.2d0 * numbnd), maxnumbnds + 1) + maxnumbnds = max(int(1.2_dp * numbnd), maxnumbnds + 1) ! if (jampi == 1) then idum(1) = maxnumbnds @@ -3278,11 +3279,11 @@ subroutine xbeach_absgen_bc() maxnumbnds = idum(1) end if ! - call realloc(uave, maxnumbnds, keepExisting=.true., fill=0d0) - call realloc(vave, maxnumbnds, keepExisting=.true., fill=0d0) - call realloc(dlengthrm, maxnumbnds, keepExisting=.true., fill=0d0) - call realloc(umeanrm, maxnumbnds, keepExisting=.true., fill=0d0) - call realloc(vmeanrm, maxnumbnds, keepExisting=.true., fill=0d0) + call realloc(uave, maxnumbnds, keepExisting=.true., fill=0.0_dp) + call realloc(vave, maxnumbnds, keepExisting=.true., fill=0.0_dp) + call realloc(dlengthrm, maxnumbnds, keepExisting=.true., fill=0.0_dp) + call realloc(umeanrm, maxnumbnds, keepExisting=.true., fill=0.0_dp) + call realloc(vmeanrm, maxnumbnds, keepExisting=.true., fill=0.0_dp) end if ! if (jampi == 0) then @@ -3316,10 +3317,10 @@ subroutine xbeach_absgen_bc() if (nubnd > 0) then do n = 1, nubnd - uave(n) = uave(n) / max(dlengthrm(n), 1d-16) - vave(n) = vave(n) / max(dlengthrm(n), 1d-16) - umeanrm(n) = factime * uave(n) + (1d0 - factime) * umeanrm(n) - vmeanrm(n) = factime * vave(n) + (1d0 - factime) * vmeanrm(n) + uave(n) = uave(n) / max(dlengthrm(n), 1e-16_dp) + vave(n) = vave(n) / max(dlengthrm(n), 1e-16_dp) + umeanrm(n) = factime * uave(n) + (1_dp - factime) * umeanrm(n) + vmeanrm(n) = factime * vave(n) + (1_dp - factime) * vmeanrm(n) end do end if @@ -3338,8 +3339,8 @@ subroutine xbeach_absgen_bc() uin_loc = uin(n) * csu(Lb) + vin(n) * snu(Lb) vin_loc = vin(n) * csu(Lb) - uin(n) * snu(Lb) else - uin_loc = 0d0 - vin_loc = 0d0 + uin_loc = 0_dp + vin_loc = 0_dp end if ! check array size @@ -3351,7 +3352,7 @@ subroutine xbeach_absgen_bc() if (trim(absgentype) == 'abs_1d') then ! zbndu for absgen bc is slowly varying tide+surge water level hsk = s1(ki) - bl(ki) - u1(Lb) = (1d0 + sqrt(ag * hsk) / cgwav(ki)) * uin_loc - sqrt(ag / hsk) * (s1(ki) - zbndu(n)) + umeanrm(numbnd) + u1(Lb) = (1_dp + sqrt(ag * hsk) / cgwav(ki)) * uin_loc - sqrt(ag / hsk) * (s1(ki) - zbndu(n)) + umeanrm(numbnd) s0(kb) = s0(ki) s1(kb) = s1(ki) @@ -3362,13 +3363,13 @@ subroutine xbeach_absgen_bc() ! ht(1) = zbndu(n) - bl(kb) ht(2) = zbndu(n) - bl(ki) - hum = max(epshu, 0.5d0 * (ht(1) + ht(2))) + hum = max(epshu, 0.5_dp * (ht(1) + ht(2))) ! umean = umeanrm(numbnd) vmean = vmeanrm(numbnd) ! if (ARC == 0) then - u1(Lb) = (order - 1d0) * uin_loc + umean + u1(Lb) = (order - 1_dp) * uin_loc + umean s1(kb) = s1(ki) u1rm(n) = u1(Lb) cycle ! all done @@ -3380,12 +3381,12 @@ subroutine xbeach_absgen_bc() cycle end if ! - xbducxdx = 0d0 - xbducxdy = 0d0 - xbducydx = 0d0 - xbducydy = 0d0 - dbetadx = 0d0 - dbetady = 0d0 + xbducxdx = 0_dp + xbducxdy = 0_dp + xbducydx = 0_dp + xbducydy = 0_dp + dbetadx = 0_dp + dbetady = 0_dp ! do i = 1, NLNX L = abs(nd(ki)%ln(i)) @@ -3394,8 +3395,8 @@ subroutine xbeach_absgen_bc() k2 = ln(2, L) ! ! Pragmatic way - betak1 = ucx(k1) * csu(Lb) + ucy(k1) * snu(Lb) - 2d0 * sqrt(ag * (s1(k1) - bl(k1))) - betak2 = ucx(k2) * csu(Lb) + ucy(k2) * snu(Lb) - 2d0 * sqrt(ag * (s1(k2) - bl(k2))) + betak1 = ucx(k1) * csu(Lb) + ucy(k1) * snu(Lb) - 2_dp * sqrt(ag * (s1(k1) - bl(k1))) + betak2 = ucx(k2) * csu(Lb) + ucy(k2) * snu(Lb) - 2_dp * sqrt(ag * (s1(k2) - bl(k2))) ! dbetadx(k1) = dbetadx(k1) + wcx1(L) * (betak2 - betak1) * dxi(L) dbetadx(k2) = dbetadx(k2) + wcx2(L) * (betak2 - betak1) * dxi(L) @@ -3428,55 +3429,55 @@ subroutine xbeach_absgen_bc() if (jawind > 0) then Fwin = wdsu(Lb) * huvli(Lb) else - Fwin = 0d0 + Fwin = 0_dp end if c = sqrt(ag * hu(Lb)) ! ! dbetadt = -(u1(Lb) - c) * dbetadn - v(Lb) * dbetads + c * dvds + ag * dhdn + Fn / (rhomean * hu(Lb)) - Ftau + Fwin - beta = u1(Lb) - 2d0 * sqrt(ag * hu(Lb)) + beta = u1(Lb) - 2_dp * sqrt(ag * hu(Lb)) ! thetai = atan2(vin_loc, uin_loc) ! cartesian angle wrt X ! betanp1 = beta + dbetadt * dts - alpha2 = (270d0 - dir0) * dg2rd ! first guess, theta0 not set for spectral bc as dir0 not defined - alphanew = 0.d0 + alpha2 = (270_dp - dir0) * dg2rd ! first guess, theta0 not set for spectral bc as dir0 not defined + alphanew = 0._dp ! cg0 = sqrt(ag * hum) ! do jj = 1, 50 ! if (freewave == 1) then ! assuming incoming long wave propagates at sqrt(g*h) (free wave) - ur = cos(alpha2) / (cos(alpha2) + 1.d0) & - * (betanp1 - umean + 2.d0 * cg0 & - - uin_loc * (cos(thetai) - 1.d0) / cos(thetai)) + ur = cos(alpha2) / (cos(alpha2) + 1._dp) & + * (betanp1 - umean + 2._dp * cg0 & + - uin_loc * (cos(thetai) - 1._dp) / cos(thetai)) else ! assuming incoming long wave propagates at group velocity (bound wave) - cgbound = max(0.5d0 * (cgwav(kb) + cgwav(ki)), eps10) + cgbound = max(0.5_dp * (cgwav(kb) + cgwav(ki)), eps10) dum = uin_loc * (cgbound * cos(thetai) - cg0) / (cgbound * cos(thetai)) - ur = cos(alpha2) / (cos(alpha2) + 1.d0) & - * (betanp1 - umean + 2.d0 * cg0 - dum) + ur = cos(alpha2) / (cos(alpha2) + 1._dp) & + * (betanp1 - umean + 2._dp * cg0 - dum) end if ! vert = v(Lb) - vmean - vin_loc ! tangential component along cell face ! - alphanew = atan2(vert, (ur + 1.d-16)) - if (alphanew > (pi * 0.5d0)) alphanew = alphanew - pi - if (alphanew <= (-pi * 0.5d0)) alphanew = alphanew + pi + alphanew = atan2(vert, (ur + 1e-16_dp)) + if (alphanew > (pi * 0.5_dp)) alphanew = alphanew - pi + if (alphanew <= (-pi * 0.5_dp)) alphanew = alphanew + pi ! - if (abs(alphanew - alpha2) < 1d-3) then + if (abs(alphanew - alpha2) < 1e-3_dp) then exit end if alpha2 = alphanew end do ! - u1(Lb) = (order - 1.d0) * uin_loc + ur + umean + u1(Lb) = (order - 1._dp) * uin_loc + ur + umean u1rm(n) = u1(Lb) ! ! try from cell centre, uses value at old time level anyhow - betaki = ucx(ki) * csu(Lb) + ucy(ki) * snu(Lb) - 2d0 * sqrt(ag * (s1(ki) - bl(ki))) + betaki = ucx(ki) * csu(Lb) + ucy(ki) * snu(Lb) - 2_dp * sqrt(ag * (s1(ki) - bl(ki))) un = ucx(ki) * csu(Lb) + ucy(ki) * snu(Lb) - s1(kb) = 1.5d0 * ((betanp1 - u1rm(n))**2 / 4.d0 / ag + .5d0 * (bl(kb) + bl(ki))) - & - 0.5d0 * ((betaki - un)**2 / 4.d0 / ag + bl(ki)) + s1(kb) = 1.5_dp * ((betanp1 - u1rm(n))**2 / 4._dp / ag + .5_dp * (bl(kb) + bl(ki))) - & + 0.5_dp * ((betaki - un)**2 / 4._dp / ag + bl(ki)) end if end if ! riemannpuntje @@ -3507,14 +3508,14 @@ subroutine rollerturbulence(k) real(kind=dp) :: dcf, dcfin, ML, twothird if (hs(k) <= epshu) then - ktb(k) = 0d0 + ktb(k) = 0_dp return end if ! if (jawave == WAVE_SWAN_ONLINE .or. jawave == WAVE_NC_OFFLINE) then - cw = rlabda(k) / max(1d-1, twav(k)) - rol = 9d-1 * rhomean * ag * sin(1d-1) * hwav(k)**2 ! Martins 2018 - disrol = 2d-1 * ag * rol / cw ! 2.0*beta = 2d-1 + cw = rlabda(k) / max(1e-1_dp, twav(k)) + rol = 9e-1_dp * rhomean * ag * sin(1e-1_dp) * hwav(k)**2 ! Martins 2018 + disrol = 2e-1_dp * ag * rol / cw ! 2.0*beta = 2d-1 Tw = twav(k) Tb = twav(k) end if @@ -3523,7 +3524,7 @@ subroutine rollerturbulence(k) disrol = DR(k) rol = R(k) cw = max(cwav(k), sqrt(ag * epshu)) - Tw = max(2.*pi / sigmwav(k), 1d0) + Tw = max(2.*pi / sigmwav(k), 1.0_dp) if (turb == TURB_BORE_AVERAGED) then Tb = Tbore(k) else @@ -3531,18 +3532,18 @@ subroutine rollerturbulence(k) end if end if - twothird = 2d0 / 3d0 + twothird = 2_dp / 3_dp ktrb = (disrol / rhomean)**twothird ! See Battjes, 1975 / 1985 - hloc = max(s1(k) - bl(k), 0.01d0) + hloc = max(s1(k) - bl(k), 0.01_dp) ! compute mixing length ML = sqrt(2 * rol * Tw / (rhomean * cw)) ML = min(ML, hloc); ! exponential decay turbulence over depth - dcfin = exp(min(100.d0, hloc / max(ML, 1d-10))) - dcf = min(1.d0, 1.d0 / (dcfin - 1.d0)) + dcfin = exp(min(100._dp, hloc / max(ML, 1e-10_dp))) + dcf = min(1._dp, 1._dp / (dcfin - 1._dp)) ! - ktb(k) = ktrb * dcf * Tw / max(1d-1, Tb) + ktb(k) = ktrb * dcf * Tw / max(1e-1_dp, Tb) end subroutine rollerturbulence @@ -3576,10 +3577,10 @@ subroutine borecharacter() allocate (detadxmax(1:ndx), stat=ierr) end if - dh = 0.03d0 - dt = 1.25d0 - nh = floor(0.99d0 / dh); - nt = floor(50.d0 / dt); + dh = 0.03_dp + dt = 1.25_dp + nh = floor(0.99_dp / dh); + nt = floor(50._dp / dt); hh = max(s1 - bl, epshu) ! compute dimensionless wave height and wave period in each grid point.. @@ -3601,19 +3602,19 @@ subroutine borecharacter() f1 = p * (1 - q); f2 = q * (1 - p); f3 = p * q; - if (t0(k) == 50.d0) then - t0fac = 50.d0 / max((Trep * sqrt(ag / hh(k))), 50.d0) + if (t0(k) == 50._dp) then + t0fac = 50._dp / max((Trep * sqrt(ag / hh(k))), 50._dp) elseif (t0(k) == 1.25) then - t0fac = 1.25d0 / min((Trep * sqrt(ag / hh(k))), 1.25d0) + t0fac = 1.25_dp / min((Trep * sqrt(ag / hh(k))), 1.25_dp) else - t0fac = 1.d0 + t0fac = 1._dp end if ! duddtmax = f0 * RF(3, ih0, it0) + f1 * RF(3, ih1, it0) + f2 * RF(3, ih0, it1) + f3 * RF(3, ih1, it1) siguref = f0 * RF(4, ih0, it0) + f1 * RF(4, ih1, it0) + f2 * RF(4, ih0, it1) + f3 * RF(4, ih1, it1) ! dudtmax = uorb(k) / sqrt(2.0) / max(waveps, siguref) * sqrt(ag / hh(k)) * t0fac * duddtmax ! urms_cc is uorb, not urms. Checked, set jauorb=1 in mdu for match - detadxmax(k) = dudtmax * sinh(min(kwav(k) * hh(k), 10d0)) / max(cwav(k), sqrt(H(k) * ag)) / sigmwav(k) ! checked JRE + detadxmax(k) = dudtmax * sinh(min(kwav(k) * hh(k), 10.0_dp)) / max(cwav(k), sqrt(H(k) * ag)) / sigmwav(k) ! checked JRE ! if (rfb == 1) then duddtmean = f0 * RF(5, ih0, it0) + f1 * RF(5, ih1, it0) + f2 * RF(5, ih0, it1) + f3 * RF(5, ih1, it1) @@ -3623,7 +3624,7 @@ subroutine borecharacter() end if end do - Tbore = Tbfac * max(Trep / 25.d0, min(Trep / 4.d0, H / (max(cwav, sqrt(H * ag)) * max(detadxmax, 5d-3)))) + Tbore = Tbfac * max(Trep / 25._dp, min(Trep / 4._dp, H / (max(cwav, sqrt(H * ag)) * max(detadxmax, 5e-3_dp)))) end subroutine borecharacter ! subroutine xbeach_map_wind_field(wx, wy, mwind, wmagcc, windspreadfac) @@ -3653,13 +3654,13 @@ end subroutine borecharacter ! if (.not.allocated(wycc)) allocate(wycc(1:ndx), stat = ierr) ! if (.not.allocated(wdir)) allocate(wdir(1:ndx), stat = ierr) ! -! wxcc=0d0 -! wycc=0d0 -! wdir=0d0 -! wmagcc=0d0 -! dist2=0d0 -! dist0=0d0 -! windspreadfac=0d0 +! wxcc=0_dp +! wycc=0_dp +! wdir=0_dp +! wmagcc=0_dp +! dist2=0_dp +! dist0=0_dp +! windspreadfac=0_dp ! ! do L = 1, lnx ! interpolate face values to cell centered values ! k1 = ln(1,L); k2 = ln(2,L) @@ -3674,15 +3675,15 @@ end subroutine borecharacter ! do k = 1, ndx ! do itheta = 1,ntheta ! dist2(itheta, k)=(cos(thetabin(itheta)-wdir(k)))**mwind -! if(cos(thetabin(itheta)-wdir(k))<0.d0) then -! dist2(itheta,k)=0.0d0 +! if(cos(thetabin(itheta)-wdir(k))<0._dp) then +! dist2(itheta,k)=0.0_dp ! end if ! end do -! if (sum(dist2(:,k))>0.d0) then +! if (sum(dist2(:,k))>0._dp) then ! dist0 = dist2(:,k) ! windspreadfac(:,k) = (dist0/sum(dist0))/dtheta ! else -! windspreadfac(:,k)=0.d0 +! windspreadfac(:,k)=0._dp ! endif ! end do ! @@ -3737,9 +3738,9 @@ end subroutine borecharacter ! ierr = 1 ! ! allocate( gradcg( 1:ntheta, 1:ndx), stat = ierr) -! fE=0d0; fT=0d0; dE=0d0; dT=0d0; -! wsorE=0d0; wsorT=0d0; -! gradcg=0d0; tgradcg=0d0; gradcg=0d0; +! fE=0_dp; fT=0_dp; dE=0_dp; dT=0_dp; +! wsorE=0_dp; wsorT=0_dp; +! gradcg=0_dp; tgradcg=0_dp; gradcg=0_dp; ! ! ! ! velocity gradient operator @@ -3747,7 +3748,7 @@ end subroutine borecharacter ! ! do k = 1, ndxi ! -! dEful = (Tful / (4.0d0 * pi)) / (CE1 * Eful ** CE2) !d +! dEful = (Tful / (4.0_dp * pi)) / (CE1 * Eful ** CE2) !d ! ! do itheta = 1, ntheta ! @@ -3772,22 +3773,22 @@ end subroutine borecharacter ! wsorEdlss = min(dE , dEful) ! wsorTdlss = dT !max(dT,dTful) !windspreadfac(itheta,k) * dT * dtheta !max(dT , dTful) ! -! SwE(k)= max(wmagcc(k)**3 * rhomean * wsorEdlss, 0.d0) ! -! SwT(k)= max(wsorTdlss , 0.d0) ! +! SwE(k)= max(wmagcc(k)**3 * rhomean * wsorEdlss, 0._dp) ! +! SwT(k)= max(wsorTdlss , 0._dp) ! ! ! !distribute growth over the wave bins, add gradcg component and make dimensional ! ! if (jagradcg .eq. 1) then -! ! egradcg = max(-windspreadfac(itheta,k) * ee0(itheta,k) / windspreadfac(itheta,k) * bai(k) * gradcg(itheta,k) , 0d0) ! * Etaper perhaps use gradcg(nodal)? -! egradcg(itheta,k) = max(- ee1(itheta, k) * bai(k) * gradcg(itheta,k) , 0.d0)! -! !tgradcg = max(-windspreadfac(itheta,k) * twopi / sigmwav(k) * bai(k) * gradcg(itheta,k) , 0d0) +! ! egradcg = max(-windspreadfac(itheta,k) * ee0(itheta,k) / windspreadfac(itheta,k) * bai(k) * gradcg(itheta,k) , 0_dp) ! * Etaper perhaps use gradcg(nodal)? +! egradcg(itheta,k) = max(- ee1(itheta, k) * bai(k) * gradcg(itheta,k) , 0._dp)! +! !tgradcg = max(-windspreadfac(itheta,k) * twopi / sigmwav(k) * bai(k) * gradcg(itheta,k) , 0_dp) ! else -! egradcg(itheta,k) = 0.d0 -! !tgardcg = 0.d0 +! egradcg(itheta,k) = 0._dp +! !tgardcg = 0._dp ! endif ! -! wsorE(itheta,k) = max(windspreadfac(itheta,k) * SwE(k) + egradcg(itheta,k), 0.d0 ) -! wsorT(itheta,k) = max(windspreadfac(itheta,k) * dtheta * SwT(k) , 0.d0 ) +! wsorE(itheta,k) = max(windspreadfac(itheta,k) * SwE(k) + egradcg(itheta,k), 0._dp ) +! wsorT(itheta,k) = max(windspreadfac(itheta,k) * dtheta * SwT(k) , 0._dp ) ! ! enddo ! @@ -3822,16 +3823,16 @@ end subroutine borecharacter ! ! integer :: nwalls ! -! gradcg = 0d0 -! velocL = 0d0 -! cwuL = 0d0 +! gradcg = 0_dp +! velocL = 0_dp +! cwuL = 0_dp ! ! do L = 1,lnx ! upwind (supq) + limited high order (dsq), loop over link ! k1 = ln(1,L) ; k2 = ln(2,L) ! linker en rechtercelnr geassocieerd aan de links ! ! do itheta = 1,ntheta ! -! velocL = acL(L)*veloc(itheta,k1) + (1d0-acL(L))*veloc(itheta,k2) +! velocL = acL(L)*veloc(itheta,k1) + (1_dp-acL(L))*veloc(itheta,k2) ! ! cwuL = velocL * wu(L) * ( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) ! *au(L) met cwi: u1(L) + cg*( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) ! ! inproduct cgx*csu+cgy*snu @@ -3892,7 +3893,7 @@ end subroutine borecharacter ! real(kind=dp), dimension(ndx) , intent(in) :: kwav ! real(kind=dp), dimension(ndx) , intent(out) :: DtotT ! -! DtotT = - coefdispT * tanh(coefdispk * kwav) * 1.d0 /(1.d0 -ndissip) * (twopi) / sigmwav / sigmwav * cgwav * kwav / E * Df +! DtotT = - coefdispT * tanh(coefdispk * kwav) * 1._dp /(1._dp -ndissip) * (twopi) / sigmwav / sigmwav * cgwav * kwav / E * Df ! !1234 continue ! return @@ -3917,8 +3918,8 @@ end subroutine borecharacter ! ! allocate(Edls(1:ndx), Tdls(1:ndx), stat = ierr) ! -! Edls=ag / rhomean / wmagcc**4d0 * E -! Tdls=aa2*(16d0* Edls / (aa1*aa1) )**(bb2/(2*bb1)) +! Edls=ag / rhomean / wmagcc**4_dp * E +! Tdls=aa2*(16_dp* Edls / (aa1*aa1) )**(bb2/(2*bb1)) ! Tmaxdep = wmagcc * Tdls / ag ! !1234 continue @@ -3950,16 +3951,16 @@ end subroutine borecharacter ! ! integer :: nwalls ! -! advec = 0d0 +! advec = 0_dp ! do L = 1,lnx ! upwind (supq) + limited high order (dsq), loop over link ! k1 = ln(1,L) ; k2 = ln(2,L) ! linker en rechtercelnr geassocieerd aan de links ! ! do itheta = 1,ntheta -! velocL = acL(L)*veloc(itheta,k1) + (1d0-acL(L))*veloc(itheta,k2) +! velocL = acL(L)*veloc(itheta,k1) + (1_dp-acL(L))*veloc(itheta,k2) ! cwuL = velocL*( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) ! *au(L) met cwi: u1(L) + cg*( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) ! ! inproduct cgx*csu+cgy*snu ! if (cwuL > 0) then ! -> ds1 ds2 -! k = k1 ; kd = k2 ; is = 1 ; half = 1d0 - acl(L) ; ip = 0 ! -> ku k kd +! k = k1 ; kd = k2 ; is = 1 ; half = 1_dp - acl(L) ; ip = 0 ! -> ku k kd ! else ! <- ds2 ds1 ! k = k2 ; kd = k1 ; is = -1 ; half = acl(L) ; ip = 3 ! <- kd k ku ! endif ! acL = linkse dx fractie van afstand tussen flownodes (slide 83) @@ -3985,7 +3986,7 @@ end subroutine borecharacter ! ! sl3 = slnup(3+ip,L) ! cf = dtmaxwav*abs(cwuL)*dxi(L) -! cf = half*max( 0d0,1d0-cf ) +! cf = half*max( 0_dp,1_dp-cf ) ! ds2 = quant(itheta,kd) - quant(itheta,k) ! ds1 = voorlopende slope, ds2 = eigen slope ! ds1 = (quant(itheta,k) - waku )*sl3 ! @@ -4078,12 +4079,12 @@ end subroutine borecharacter ! do k=1,ndxi ! if(hdisp(k).ge.waveps) then ! do itheta = 1,ntheta -! if (2*pi/L0t(itheta,k)*hdisp(k) > 5d0) then +! if (2*pi/L0t(itheta,k)*hdisp(k) > 5_dp) then ! Ltempt(itheta,k) = L0t(itheta,k) ! else -! !Ltempt(k) = (2d0*pi*ag/(sigt(itheta,k)**2))*(1-exp(-(sigt(itheta,k)*sqrt(hdisp(k)/ag))**(5d0/2d0)))**(2d0/5d0) +! !Ltempt(k) = (2_dp*pi*ag/(sigt(itheta,k)**2))*(1-exp(-(sigt(itheta,k)*sqrt(hdisp(k)/ag))**(5_dp/2_dp)))**(2_dp/5_dp) ! Ltempt(itheta,k) = iteratedispersion(L0t(itheta,k),Ltempt(itheta,k),pi,hdisp(k)) -! if (Ltempt(itheta,k)<0.d0) then ! this is an error from iteratedispersion +! if (Ltempt(itheta,k)<0._dp) then ! this is an error from iteratedispersion ! Ltempt(itheta,k) = -Ltempt(itheta,k) ! call writelog('lws','','Warning: no convergence in dispersion relation iteration at t = ', & ! time0) @@ -4112,8 +4113,8 @@ end subroutine borecharacter ! do itheta=1,ntheta ! kwavt(itheta,k) = 2*pi/max(L1t(itheta,k),waveps) ! cwavt(itheta,k) = sigt(itheta,k)/kwavt(itheta,k) -! kh = min(kwavt(itheta,k)*hdisp(k),10.0d0) -! nwavt(itheta,k)=0.5d0+kh/max(sinh(2d0*kh),waveps) +! kh = min(kwavt(itheta,k)*hdisp(k),10.0_dp) +! nwavt(itheta,k)=0.5_dp+kh/max(sinh(2_dp*kh),waveps) ! cgwavt(itheta,k)=cwavt(itheta,k)*nwavt(itheta,k) ! enddo ! end do @@ -4122,7 +4123,7 @@ end subroutine borecharacter ! hh=s1(k)-bl(k) ! if (hh 0) then + call realloc(frcu0, lnx, stat=ierr, fill=frcuni, keepexisting=.false.) + call aerr('frcu0(lnx)', ierr, lnx) + call realloc(dynveg, lnx, stat=ierr, fill=.false., keepexisting=.false.) + call aerr('dynveg(lnx)', ierr, lnx) + end if if (jarhoxu > 0 .or. jased > 0) then call realloc(rhou, lnkx, stat=ierr, fill=rhomean, keepexisting=.false.) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 index 06b12216c52..f8ae13df043 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 @@ -680,18 +680,31 @@ subroutine set_floodfill_water_levels_based_on_sample_file() end subroutine set_floodfill_water_levels_based_on_sample_file -!> sert friction coefficient by initial fields +!> Insert friction coefficient by initial fields subroutine set_friction_coefficient_by_initial_fields() - use m_flowgeom, only: lnx, lnx1D, kcu - use m_flow, only: frcu, ifrcutp - use m_physcoef, only: frcuni1d, frcuni1d2d, frcunistreetinlet, frcuniroofgutterpipe, frcuni, frcmax, ifrctypuni + use m_flowgeom, only: lnx, lnx1D, kcu, xz, yz, kcs + use m_flow, only: frcu, ifrcutp, dynveg, frcu0 + use m_physcoef, only: frcuni1d, frcuni1d2d, frcunistreetinlet, frcuniroofgutterpipe, frcuni, frcumin, frcmax, ifrctypuni, dynroughveg use m_missing, only: dmiss, imiss + use m_alloc + use m_flow, only: kcsveg + use unstruc_model, only: md_dynvegpol + use timespace_parameters, only: LOCTP_POLYGON_FILE + use timespace, only: selectelset_internal_nodes + use m_delpol + use MessageHandling implicit none integer, parameter :: MANNING = 1 integer :: link + integer :: ierr + integer :: k + integer :: pointscount + logical :: ex + + integer, dimension(:), allocatable :: kp do link = 1, lnx if (frcu(link) == dmiss) then @@ -720,6 +733,36 @@ subroutine set_friction_coefficient_by_initial_fields() frcmax = frcu(link) end if end do + ! + if (dynroughveg > 0) then + ! + inquire (file=trim(md_dynvegpol), exist=ex) + if (ex) then + frcu0 = frcu + call realloc(kcsveg, lnx, stat=ierr, fill=0, keepExisting=.false.) + if (allocated(kp)) deallocate (kp) + allocate (kp(1:lnx)) + kp = 0 + ! find cells inside polygon + call selectelset_internal_nodes(xz, yz, kcs, lnx, kp, pointscount, LOC_FILE=md_dynvegpol, LOC_SPEC_TYPE=LOCTP_POLYGON_FILE) + do k = 1, pointscount + kcsveg(kp(k)) = 1 + end do + call delpol() + ! + do link = 1, lnx + if (frcu(link) > frcumin .and. kcsveg(link) > 0) then + dynveg(link) = .true. + else + dynveg(link) = .false. + end if + end do + else + call mess(LEVEL_WARN, 'No polygon found for dynamic vegetation update. Process switched off.') + dynroughveg = 0 + end if + ! + end if end subroutine set_friction_coefficient_by_initial_fields diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 index 2dfd8cc7225..0db3e1967a8 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 @@ -54,7 +54,7 @@ subroutine flow_sedmorinit() use unstruc_files use m_flowgeom use m_flowtimes - use m_physcoef, only: rhomean, ag, vismol + use m_physcoef, only: rhomean, ag, vismol, dynroughveg use m_initsedtra, only: initsedtra use m_rdmorlyr, only: rdinimorlyr use fm_external_forcings_data, only: numfracs, nopenbndsect, openbndname, openbndlin, nopenbndlin @@ -540,6 +540,11 @@ subroutine flow_sedmorinit() case default ! if 0, do nothing. end select + ! + if (dynroughveg > 0) then + if (allocated(cumes)) deallocate(cumes) + call realloc(cumes, lnx,stat=ierr,fill=0.0_dp, keepExisting=.false.) + end if 1234 return end subroutine flow_sedmorinit diff --git a/src/utils_gpl/morphology/packages/morphology_io/src/rdtrafrm.f90 b/src/utils_gpl/morphology/packages/morphology_io/src/rdtrafrm.f90 index 8aaad9e42c1..ae8dbc055fd 100644 --- a/src/utils_gpl/morphology/packages/morphology_io/src/rdtrafrm.f90 +++ b/src/utils_gpl/morphology/packages/morphology_io/src/rdtrafrm.f90 @@ -1464,13 +1464,13 @@ subroutine traparams(iform ,name ,nparreq ,nparopt ,parkeyw , & pardef(2) = 0.3_fp elseif (iform == 19) then name = 'Van Thiel / Van Rijn (2008)' - nparopt = 13 + nparopt = 14 parkeyw(1) = 'facua' - pardef(1) = 0.1_fp + pardef(1) = 0.0_fp parkeyw(2) = 'facAs' - pardef(2) = 0.1_fp + pardef(2) = 0.2_fp parkeyw(3) = 'facSk' - pardef(3) = 0.1_fp + pardef(3) = 0.15_fp parkeyw(4) = 'waveform' pardef(4) = 2.0_fp ! 1=ruessink, 2=van thiel parkeyw(5) = 'sws' @@ -1491,16 +1491,18 @@ subroutine traparams(iform ,name ,nparreq ,nparopt ,parkeyw , & pardef(12) = 30.0_fp parkeyw(13) = 'cmax' pardef(13) = 0.1_fp + parkeyw(14) = 'alfad50' + pardef(14) = 0.0_fp elseif (iform == 20) then name = 'Soulsby / Van Rijn, XBeach flavour' - nparopt = 14 + nparopt = 15 parkeyw(1) = 'facua' - pardef(1) = 0.1_fp + pardef(1) = 0.0_fp parkeyw(2) = 'facAs' - pardef(2) = 0.1_fp + pardef(2) = 0.2_fp parkeyw(3) = 'facSk' - pardef(3) = 0.1_fp + pardef(3) = 0.15_fp parkeyw(4) = 'waveform' pardef(4) = 2.0_fp ! 1=ruessink, 2=van thiel parkeyw(5) = 'sws' @@ -1523,6 +1525,8 @@ subroutine traparams(iform ,name ,nparreq ,nparopt ,parkeyw , & pardef(13) = 0.1_fp parkeyw(14) = 'z0' pardef(14) = 0.006_fp + parkeyw(15) = 'alfad50' + pardef(15) = 0.0_fp elseif (iform == 21) then if (name == ' ') name = 'External subroutine' nparreq = 0 diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/bedbc2004.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/bedbc2004.f90 index 30d673a18e6..3382f3ddb5d 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/bedbc2004.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/bedbc2004.f90 @@ -293,7 +293,7 @@ subroutine bedbc2004(tp ,rhowat , & uon = max(1.0e-5_fp , uon) uoff = max(1.0e-5_fp , uoff) ! - uwbih = (0.5_fp*uon**3.0_fp + 0.5_fp*uoff**3.0_fp)**(1.0_fp/3.0_fp) ! Representative peak orbital velocity + uwbih = (0.5_fp*uon**3.0_fp + 0.5_fp*uoff**3.0_fp)**(1.0_fp/3.0_fp) ! Representative peak orbital velocity magnitude else if (wform==2) then ! Modification by Marcio Boechat Albernaz diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/calseddf1993.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/calseddf1993.f90 index 5f74004e95e..d0cf107e924 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/calseddf1993.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/calseddf1993.f90 @@ -94,7 +94,7 @@ subroutine calseddf1993(ustarc ,ws ,h1 ,num_layers_grid ,s if (ltur==0 .or. ltur==1 .or. difvr) then ! ! if algebraic or K-L turbulence model or difvr = .true. then - ! calculate sediment mixing according to Van Rijn based on his + ! calculate sediment mixing according to Van Rijn based on Coleman's ! parabolic-linear mixing distribution for current-related mixing ! ! set vertical sediment mixing values for waves and currents at water surface diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 index e66c47ff940..21bd9c8ed55 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 @@ -103,6 +103,7 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h real(fp) :: urms2 real(fp) :: ucrb, ucrs, asb, ass, term1, ceqb, ceqs real(fp) :: cmax2h + real(fp) :: alfad50 ! ! !! executable statements ------------------------------------------------------- @@ -122,8 +123,13 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h ag = par(1) delta = par(4) facua = par(11) - facas = par(12) - facsk = par(13) + if (comparereal(facua, 0.0_fp, 1d-10) == 0) then + facas = par(12) + facsk = par(13) + else + facas = facua + facsk = facua + end if waveform = int(par(14)) sws = int(par(15)) lws = int(par(16)) @@ -134,6 +140,7 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h smax = par(21) reposeangle = par(22) cmax = par(23) + alfad50 = par(24) ! ! limit input parameters to sensible values ! @@ -151,6 +158,7 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h if (smax<0.0_fp) smax=huge(0.0_fp)*1.0e-20_fp reposeangle = max(min(reposeangle,45.0_fp),30.0_fp) cmax = max(min(cmax,1.0_fp),0.0_fp) + alfad50 = max(min(alfad50,1.5_fp),0.0_fp) ! cf = ag / chezy / chezy ! @@ -201,6 +209,12 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h ceqs=Ass*(term1-Ucrs)**2.4_fp end if ! + if (alfad50 > 0.0_fp) then + !uamag = uamag * (0.000225_fp/d50)**alfad50 ! hoe kan een snelheidsasymmetrie fie zijn van korrelgrootte? + ceqb = ceqb * (0.000225_fp/d50)**alfad50 + ceqs = ceqs * (0.000225_fp/d50)**alfad50 + endif + ! cmax2h = cmax*h/2.0_fp ceqb = min(ceqb, cmax2h) ! maximum equilibrium bed concentration cesus = min(ceqs, cmax2h)/h ! m2/s/m*s/m = [-], and times rhosol in eqtran diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 index e416cccf5a8..0181a3c9ce2 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 @@ -101,6 +101,7 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h real(fp) :: z0 real(fp) :: cd real(fp) :: cmax2h + real(fp) :: alfad50 ! ! !! executable statements ------------------------------------------------------- @@ -119,8 +120,13 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h ag = par(1) delta = par(4) facua = par(11) - facas = par(12) - facsk = par(13) + if (comparereal(facua, 0.0_fp, 1d-10) == 0) then + facas = par(12) + facsk = par(13) + else + facas = facua + facsk = facua + end if waveform = int(par(14)) sws = int(par(15)) lws = int(par(16)) @@ -132,6 +138,7 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h reposeangle = par(22) cmax = par(23) z0 = par(24) + alfad50 = par(25) ! ! limit input parameters to sensible values ! @@ -150,6 +157,7 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h reposeangle = max(min(reposeangle,45.0_fp),30.0_fp) cmax = max(min(cmax,1.0_fp),0.0_fp) z0 = max(min(z0,0.05_fp),0.0001_fp) + alfad50 = max(min(alfad50,1.5_fp),0.0_fp) ! cf = ag / chezy / chezy ! @@ -191,6 +199,12 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h ceqs=Ass*(term1-Ucrs)**2.4_fp end if ! + if (alfad50 > 0.0_fp) then + !uamag = uamag * (0.000225_fp/d50)**alfad50 ! hoe kan een snelheidsasymmetrie fie zijn van korrelgrootte? + ceqb = ceqb * (0.000225_fp/d50)**alfad50 + ceqs = ceqs * (0.000225_fp/d50)**alfad50 + endif + ! cmax2h = cmax*h/2.0_fp ceqb = min(ceqb, cmax2h) ! maximum equilibrium bed concentration cesus = min(ceqs, cmax2h)/h ! maximum equilibrium suspended concentration From 9c983f02a269796bfc2396b4ebe9b5974f09532e Mon Sep 17 00:00:00 2001 From: reyns Date: Wed, 19 Nov 2025 11:58:41 +0100 Subject: [PATCH 02/18] UNST-9434 Merge part 2 --- .../src/dflowfm_data/m_sediment.f90 | 4 ++-- .../src/dflowfm_data/m_waves.f90 | 4 +++- .../src/dflowfm_data/unstruc_model.f90 | 1 + .../dflowfm_kernel/compute/getustbcfuhi.f90 | 22 +++++++++---------- .../src/dflowfm_kernel/compute/getustwav.f90 | 8 +++---- .../compute/update_verticalprofiles.f90 | 2 +- .../compute_sediment/fm_erosed.f90 | 13 +++++------ src/third_party_open/swan/src/swancom1.F | 3 ++- 8 files changed, 30 insertions(+), 27 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 index ba653d3e4e1..060f275e566 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 @@ -172,8 +172,8 @@ subroutine default_sediment() jamormergedtuser = 0 upperlimitssc = 1.0e6_dp inmorphopol = 1 - difparam = 10_fp - difcal = 1_fp + difparam = 10.0_dp + difcal = 0.0_dp end subroutine default_sediment diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 index 05e4c353057..03592827f03 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 @@ -66,6 +66,7 @@ module m_waves real(kind=dp) :: fbreak !< tune breaking in tke model real(kind=dp) :: fforc !< tune wave forces real(kind=dp) :: fwavpendep !< Layer thickness as proportion of Hrms over which wave breaking adds to TKE source. Default 0.5 + real(kind=dp) :: strlyrfac !< fac*wave boundary layer for streaming character(len=4) :: rouwav !< Friction model for wave induced shear stress @@ -103,7 +104,7 @@ module m_waves integer :: jahissigwav !< 1: sign wave height on his output; 0: hrms wave height on his output. integer :: jamapsigwav !< 1: sign wave height on map output; 0: hrms wave height on map output. integer :: jauorbfromswan !< 1: get uorb from SWAN, compare with Delft3D - integer :: jawavevellogprof + integer :: jawavevellogprof !< 1: set depth-averaged velocity from u1 of base layers logical :: extfor_wave_initialized !< is set to .true. when the "external forcing"-part that must be initialized for WAVE during running (instead of during initialization) has actually been initialized contains @@ -126,6 +127,7 @@ subroutine default_waves() fwavpendep = 1.5_dp ! best setting based on sensitivity jawavevellogprof = 1 fforc = 1.0_dp + strlyrfac = 3.0_dp call reset_waves() end subroutine default_waves diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 index 78e5b035bdd..35e2c7091ed 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 @@ -1655,6 +1655,7 @@ subroutine readMDUFile(filename, istat) call prop_get(md_ptr, 'waves', 'ftauw', ftauw) ! factor for adjusting wave related bottom shear stress call prop_get(md_ptr, 'waves', 'fbreak', fbreak) ! factor for adjusting wave breaking contribution to tke call prop_get(md_ptr, 'waves', 'fforc', fforc) ! factor for adjusting wave forces in momentum equation + call prop_get(md_ptr, 'waves', 'streamlyrfac', strlyrfac) ! factor for adjusting streaming layer thickness in momentum equation if (ftauw < 0.0_dp) then call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: ftauw<0.0, reset to 0.0. Bed shear stress due to waves switched off.') diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 index 2ce4800c3f8..6568b05ef6b 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 @@ -46,7 +46,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte use m_get_czz0, only: getczz0 use m_flowgeom, only: ln, dxi, csu, snu use m_flowtimes, only: dti - use m_waves, only: ustokes, vstokes, wblt, jawavevellogprof + use m_waves, only: ustokes, vstokes, wblt, jawavevellogprof, strlyrfac use m_waveconst, only: NO_WAVES, NO_STOKES_DRIFT, WAVE_STREAMING_OFF use m_sediment, only: stm_included use m_flowtimes, only: dts @@ -75,7 +75,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte real(kind=dp) :: s, sd, er, ers, dzb, uu, vv, alin real(kind=dp) :: cphi, sphi real(kind=dp) :: fsqrtt = sqrt(2.0_dp) - real(kind=dp) :: threedeltau + real(kind=dp) :: slfacdeltau cfuhi3D = 0_dp ustbLL = 0_dp; cfuhiLL = 0_dp; hdzb = 0_dp; z00 = 0_dp; cz = 0_dp; nit = 0 @@ -237,23 +237,23 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte ! if (stm_included) wblt(LL) = deltau ! - ! Streaming below 3*deltau with linear distribution,, see van Rijn 2011 p9.177 - if (jawavestreaming > WAVE_STREAMING_OFF .and. deltau > 1e-4_dp * hu(LL)) then ! weakly turbulent flume cases ~1mm-1cm, real turbulent cases 5-50cm - threedeltau = 3_dp * deltau + ! Streaming below strlyrfac*deltau with linear distribution,, see van Rijn 2011 p9.177 + if (jawavestreaming > WAVE_STREAMING_OFF .and. deltau > 1e-4_dp) then ! weakly turbulent flume cases ~1mm-1cm, real turbulent cases 5-50cm + slfacdeltau = strlyrfac * deltau Dfu0 = Dfuc ! (m/s2) do L = Lb, Ltop(LL) - if (hu(L) <= threedeltau) then - htop = min(hu(L), threedeltau) ! max height within streaming layer - alin = 1_dp - htop / threedeltau ! linear from 1 at bed to 0 at 3*deltau + if (hu(L) <= slfacdeltau) then + htop = min(hu(L), slfacdeltau) ! max height within streaming layer + alin = 1_dp - htop / slfacdeltau ! linear from 1 at bed to 0 at 3*deltau Dfu1 = Dfuc * alin adve(L) = adve(L) - 0.5_dp * (Dfu0 + Dfu1) Dfu0 = Dfu1 end if - if (hu(L) > threedeltau) then + if (hu(L) > slfacdeltau) then if (L == Lb) then - adve(L) = adve(L) - Dfuc * threedeltau / (2.0 * hu(L)) ! everything in bottom layer + adve(L) = adve(L) - Dfuc * slfacdeltau / (2.0_dp * hu(L)) ! everything in bottom layer else - alin = (min(hu(L), threedeltau) - hu(L - 1)) / (2_dp * (hu(L) - hu(L - 1))) + alin = (min(hu(L), slfacdeltau) - hu(L - 1)) / (2.0_dp * (hu(L) - hu(L - 1))) Dfu1 = Dfuc * alin adve(L) = adve(L) - Dfu1 end if diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 index ba7f3b77f6e..a19893f5852 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 @@ -39,9 +39,9 @@ module m_get_ustwav contains subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uorbu) ! at u-point, get ustarwave and get ustokes use precision, only: dp - use m_flow, only: hu, jawavestokes, ag, jawave, rhomean, eps10 + use m_flow, only: hu, jawavestokes, ag, eps10 use m_flowgeom, only: ln, csu, snu - use m_waves, only: twav, ustokes, vstokes, phiwav, hwav, gammax, jauorb, ftauw, alfdeltau, fwfac + use m_waves, only: twav, ustokes, vstokes, phiwav, hwav, gammax, jauorb, ftauw, fwfac, strlyrfac use m_waveconst, only: STOKES_DRIFT_2NDORDER, STOKES_DRIFT_DEPTHUNIFORM, WAVE_SURFBEAT use m_sferic, only: twopi, dg2rd, pi use m_get_Lbot_Ltop, only: getlbotltop @@ -127,12 +127,12 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor aks = asg * shs / dks * fac ! uorbu/(omega*ks), uorbu/omega = particle excursion length deltau = 0.09_dp * dks * aks**0.82_dp ! thickness of wave boundary layer from Fredsoe and Deigaard (1992) - deltau = max(deltau, 20_dp * ee * z00) + deltau = max(deltau, ee * z00) ! ustar / karman deltau = min(0.5_dp * hu(LL), deltau) ! call soulsby(tsig, uorbu, z00, fw) ! streaming with different calibration fac fwfac + soulsby fws Dfu = 0.28_dp * fw * uorbu**3 ! random waves: 0.28=1/2sqrt(pi) (m3/s3) - Dfu = fwfac * Dfu / 3_dp / deltau ! divided by 3*deltau (m2/s3) + Dfu = fwfac * Dfu / strlyrfac / deltau ! divided by strlyrfac*deltau (m2/s3) Dfuc = Dfu * rk / omeg * costu ! Dfuc = dfu/c/delta, (m /s2) is contribution to adve else diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 index 32595014247..5bd81148fcc 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 @@ -826,7 +826,7 @@ subroutine update_verticalprofiles() vicwwu(Lb0:Lt) = min(vicwmax, cmukep * turkin1(Lb0:Lt) * tureps1(Lb0:Lt)) end if - if (jawave == NO_WAVES) then + if (jawave == NO_WAVES .or. (jawave > NO_WAVES .and. jawavebreakerturbulence == WAVE_BREAKER_TURB_OFF)) then vicwwu(Lt) = min(vicwwu(Lt), vicwwu(Lt - 1) * Eddyviscositysurfacmax) end if vicwwu(Lb0) = min(vicwwu(Lb0), vicwwu(Lb) * Eddyviscositybedfacmax) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 index c3c56c4c62b..4aa69f11f38 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 @@ -1157,7 +1157,7 @@ subroutine fm_erosed() rsedeq(nm, l) = rsdqlc(kmaxsd) ! thick0 = max(thicklc(kmaxsd) * h0, epshu) - thick1 = max(thicklc(kmaxsd) * h1, epshu) + !thick1 = max(thicklc(kmaxsd) * h1, epshu) thick1 = thicklc(kmaxsd) * h1 ! call soursin_3d(h1, thick1, thick1, & ! thick1 iso thick0 mass conservation @@ -1167,21 +1167,20 @@ subroutine fm_erosed() & aks_ss3d, sourse(nm, l), sour_im(nm, l), & & sinkse(nm, l)) ! + if (difcal > 0.0_dp) then + seddif(l, kb:kt) = difcal * seddif(l, kb:kt) + end if + ! ! Impose relatively large vertical diffusion ! coefficients for sediment in layer interfaces from ! bottom of reference cell downwards, to ensure little ! gradient in sed. conc. exists in this area. - - if (difparam > 0.0) then + if (difparam > 0.0_dp) then difbot = difparam * ws(kmxsed(nm, l) - 1, l) * thick1 do kk = kb - 1, kmxsed(nm, l) - 1 seddif(l, kk) = difbot end do end if - ! - if (difcal > 0d0) then - seddif = difcal * seddif - end if end if ! suspfrac else ! diff --git a/src/third_party_open/swan/src/swancom1.F b/src/third_party_open/swan/src/swancom1.F index aa4da550773..fe69cfc9860 100644 --- a/src/third_party_open/swan/src/swancom1.F +++ b/src/third_party_open/swan/src/swancom1.F @@ -6047,7 +6047,8 @@ SUBROUTINE SINTGRL(SPCDIR ,KWAVE ,AC2 , 40.02 ! ! --- calculate fraction of breakers ! - IF ( ETOT .GT. 0. ) THEN + QB(KCGRD(1)) = 0. JRE + IF ( ETOT .GT. 0. .AND. ISURF.GT.0) THEN JRE ! ! --- calculate Qb when BJ78 breaker is activated ! From 054d6fca65c931d4ffd4457c3c824be78bab0a06 Mon Sep 17 00:00:00 2001 From: reyns Date: Wed, 19 Nov 2025 14:05:33 +0100 Subject: [PATCH 03/18] UNST-9434 Merge part 3 --- .../src/dflowfm_io/unstruc_netcdf.f90 | 2 +- .../src/dflowfm_kernel/compute/furu.f90 | 5 ++--- .../src/dflowfm_kernel/compute/getustwav.f90 | 11 +++++++---- .../compute_sediment/apply_sediment_bc.f90 | 2 +- .../compute_sediment/bermslopenudging.f90 | 16 ++++++++-------- .../compute_sediment/fm_erosed.f90 | 2 +- .../compute_sediment/m_fm_bott3d.f90 | 4 ++++ .../compute_waves/compute_wave_forcing_rhs.f90 | 3 ++- .../compute_waves/surfbeat/xbeachwaves.f90 | 2 +- .../src/dflowfm_kernel/prepost/setbobs.f90 | 10 +++++----- .../timespace/fm_external_forcings_init.f90 | 6 +++--- .../packages/morphology_kernel/src/bedtr2004.f90 | 2 +- .../packages/morphology_kernel/src/trab19.f90 | 4 ++-- .../packages/morphology_kernel/src/trab20.f90 | 4 ++-- 14 files changed, 40 insertions(+), 33 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 index c0413433f86..1d3430cf19f 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 @@ -6250,7 +6250,7 @@ subroutine unc_write_map_filepointer_ugrid(mapids, tim, jabndnd) ! wrimap end if end if if (jamapwav_twav > 0 .and. allocated(twav)) then - ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'tp', 'sea_surface_wave_period_at_variance_spectral_density_maximum', 'Peak wave period', 's') + ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'twav', 'sea_surface_wave_period_at_variance_spectral_density_maximum', 'Peak wave period', 's') end if if (jamapwav_phiwav > 0 .and. allocated(phiwav)) then ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_thetamean, nc_precision, UNC_LOC_S, 'thetamean', 'sea_surface_wave_from_direction', 'Wave from direction', 'degree') diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/furu.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/furu.f90 index 15691c7f895..d8ff3d783ec 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/furu.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/furu.f90 @@ -183,13 +183,12 @@ subroutine furu() ! set fu, ru and kfs frL = cfuhi(L) * sqrt((u1L - ustokes(L))**2 + (v(L) - vstokes(L))**2 + (1.16_dp * uorbL * fsqrtt)**2) end if ! - du = du0 + frL * ustokes(L) - ! ! and add vegetation stem drag with eulerian velocities, assumes fixed stem if ((jaBaptist >= 2) .or. trachy_resistance) then frL = frL + alfav(L) * hypot(u1L - ustokes(L), v(L) - vstokes(L)) end if - + ! + du = du0 + frL * ustokes(L) else if (ifxedweirfrictscheme > 0) then if (iadv(L) == IADV_SUBGRID_WEIR .or. kcu(L) == 3) then call fixedweirfriction2D(L, k1, k2, frL) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 index a19893f5852..7c1e344c5c4 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 @@ -61,6 +61,8 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor real(kind=dp) :: Tsig, Hrms, asg, rk, shs, phi1, phi2, dks, aks, omeg, f1u, f2u, f3u, sintu real(kind=dp) :: p1, p2, h, z, uusto, fac + real(kind=dp), parameter :: alfaw = 20.0_dp + Dfu = 0.0_dp; Dfuc = 0.0_dp; deltau = 0.0_dp; uorbu = 0.0_dp; csw = 1.0_dp; snw = 0.0_dp; costu = 1.0_dp; fw = 0.0_dp call getLbotLtop(LL, Lb, Lt) @@ -127,13 +129,14 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor aks = asg * shs / dks * fac ! uorbu/(omega*ks), uorbu/omega = particle excursion length deltau = 0.09_dp * dks * aks**0.82_dp ! thickness of wave boundary layer from Fredsoe and Deigaard (1992) - deltau = max(deltau, ee * z00) ! ustar / karman - deltau = min(0.5_dp * hu(LL), deltau) ! + deltau = max(deltau, ee * z00) ! alfaw makes wbl at least ~2ks thick call soulsby(tsig, uorbu, z00, fw) ! streaming with different calibration fac fwfac + soulsby fws - Dfu = 0.28_dp * fw * uorbu**3 ! random waves: 0.28=1/2sqrt(pi) (m3/s3) - Dfu = fwfac * Dfu / strlyrfac / deltau ! divided by strlyrfac*deltau (m2/s3) + Dfu = 0.2821_dp * fw * uorbu**3 ! random waves: 0.28=1/2sqrt(pi) (m3/s3) + Dfu = fwfac * Dfu / strlyrfac / deltau ! divided by 3 deltau (m2/s3) see van Rijn, streaming layer about 3-5 times wbl Dfuc = Dfu * rk / omeg * costu ! Dfuc = dfu/c/delta, (m /s2) is contribution to adve + deltau = alfaw * deltau ! as in delft3d + deltau = min(0.5_dp * hu(LL), deltau) ! else ustw2 = 0.0_dp diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/apply_sediment_bc.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/apply_sediment_bc.f90 index a35994ec000..3b5a24e291d 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/apply_sediment_bc.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/apply_sediment_bc.f90 @@ -132,7 +132,7 @@ subroutine apply_sediment_bc() kb = ln(1, L); ki = ln(2, L) kk = kmxd * (k - 1) + L - Lb + 1 if (q1(L) > 0) then ! inflow - constituents(iconst, kb) = bndsf(ll)%z(k) + constituents(iconst, kb) = bndsf(ll)%z(kk) else ! outflow constituents(iconst, kb) = constituents(iconst, ki) end if diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 index e769f004891..8a4e6688031 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 @@ -116,28 +116,28 @@ subroutine bermslopenudging(error) trmag_u = hypot(e_sbcn(L, lsd), e_sbct(L, lsd)) flx = trmag_u * slpfac e_sbcn(L, lsd) = e_sbcn(L, lsd) - flx - call getfracfixfac(L, k1, k2, lsd, e_sbcn(L, lsd), frc, fixf) - e_sbcn(L, lsd) = e_sbcn(L, lsd) * frc * fixf + call getfixfac(L, k1, k2, lsd, e_sbcn(L, lsd), fixf) + e_sbcn(L, lsd) = e_sbcn(L, lsd) * fixf ! trmag_u = hypot(e_sbwn(L, lsd), e_sbwt(L, lsd)) flx = trmag_u * slpfac e_sbwn(L, lsd) = e_sbwn(L, lsd) - flx - call getfracfixfac(L, k1, k2, lsd, e_sbwn(L, lsd), frc, fixf) - e_sbwn(L, lsd) = e_sbwn(L, lsd) * frc * fixf + call getfixfac(L, k1, k2, lsd, e_sbwn(L, lsd), fixf) + e_sbwn(L, lsd) = e_sbwn(L, lsd) * fixf end if ! if (bermslopeindexsus(L) .and. sus /= 0.0 .and. lsd <= lsed) then trmag_u = abs(e_ssn(L, lsd)) flx = trmag_u * slpfac e_ssn(L, lsd) = e_ssn(L, lsd) - flx - call getfracfixfac(L, k1, k2, lsd, e_ssn(L, lsd), frc, fixf) - e_ssn(L, lsd) = e_ssn(L, lsd) * frc * fixf + call getfixfac(L, k1, k2, lsd, e_ssn(L, lsd), fixf) + e_ssn(L, lsd) = e_ssn(L, lsd) * fixf ! trmag_u = hypot(e_sswn(L, lsd), e_sswt(L, lsd)) flx = trmag_u * slpfac e_sswn(L, lsd) = e_sswn(L, lsd) - flx - call getfracfixfac(L, k1, k2, lsd, e_sswn(L, lsd), frc, fixf) - e_sswn(L, lsd) = e_sswn(L, lsd) * frc * fixf + call getfracfixfac(L, k1, k2, lsd, e_sswn(L, lsd), fixf) + e_sswn(L, lsd) = e_sswn(L, lsd) * fixf end if end do end do diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 index 4aa69f11f38..f887f901ecd 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 @@ -944,7 +944,7 @@ subroutine fm_erosed() if (mfltot > 0.0_fp) fracf = max(0.0_fp, mfluff(l, nm)) / mfltot end if ! - kmaxsd = 1 ! for mud fractions kmaxsd points to the grid cell at the bottom of the water column + kmaxsd = kmaxlc ! for mud fractions kmaxsd points to the grid cell at the bottom of the water column thick0 = max(thicklc(kmaxsd) * h0, epshs) thick1 = max(thicklc(kmaxsd) * h1, epshs) ! diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 index 98b829d6a7f..663e2a183bb 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 @@ -391,6 +391,10 @@ subroutine fm_suspended_sand_correction() aksu = ac1 * aks(k1, l) + ac2 * aks(k2, l) end if ! + if (aksu < 1e-10_dp) then + cycle + end if + ! ! work up through layers integrating transport flux ! below aksu, according to Bert's new implementation ! diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 index 865f8d0750f..02f63bf70a1 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 @@ -102,8 +102,9 @@ subroutine compute_wave_forcing_RHS() ! if (kmx == 0) then call tauwave() - call xbeach_flow_bc() end if + ! + call xbeach_flow_bc() ! JRE todo: make MPI compatible end if ! ! Uniform wave field diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 index fdac743cd45..751da981f5c 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 @@ -5975,7 +5975,7 @@ subroutine xbeach_compute_stokesdrift() ! shortcut to switch off stokes drift if (jawavestokes == NO_STOKES_DRIFT) then ustokes = 0.0_dp; vstokes = 0.0_dp - ustx_cc(k) = 0.0_dp; usty_cc(k) = 0.0_dp ! output + ustx_cc = 0.0_dp; usty_cc = 0.0_dp ! output return end if diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/setbobs.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/setbobs.f90 index 0f1e3be0f13..b72e0771f10 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/setbobs.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/setbobs.f90 @@ -168,13 +168,13 @@ subroutine setbobs() ! and set blu, weigthed depth at u point if (iadv(L) > 20 .and. iadv(L) < 30 .and. (.not. stm_included)) cycle ! skip update of bobs for structures - n1 = ln(1, L); n2 = ln(2, L) ! flow ref - k1 = lncn(1, L); k2 = lncn(2, L) ! net ref - zn1 = zk(k1); if (zn1 == dmiss) zn1 = zkuni - zn2 = zk(k2); if (zn2 == dmiss) zn2 = zkuni - if (kcu(L) == 1) then ! 1D link + n1 = ln(1, L); n2 = ln(2, L) ! flow ref + k1 = lncn(1, L); k2 = lncn(2, L) ! net ref + zn1 = zk(k1); if (zn1 == dmiss) zn1 = zkuni + zn2 = zk(k2); if (zn2 == dmiss) zn2 = zkuni + if (ibedlevtyp == BEDLEV_TYPE_WATERLEVEL .or. ibedlevtyp == BEDLEV_TYPE_WATERLEVEL6) then ! tegeldieptes celcentra ! TODO: [TRUNKMERGE] WO/BJ: do we need stm_included in this if (consistent?) if (stm_included) then bl1 = bl(n1) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 index 78de59d5858..dfdf842166d 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 @@ -808,13 +808,13 @@ function init_meteo_forcings(node_ptr, base_dir, file_name, group_name) result(r case ('qext') ! Only time-independent sample file supported for now: sets Qext initially and this remains constant in time. if (jaQext == 0) then - write (msgbuf, '(a)') 'quantity '''//trim(quantity)//' in file ''', file_name, ''': [', group_name, & + write (msgbuf, '(7a)') 'quantity '''//trim(quantity)//' in file ''', file_name, ''': [', group_name, & '] is missing QExt=1 in MDU.' call err_flush() return end if if (.not. strcmpi(forcing_file_type, 'sample')) then - write (msgbuf, '(a)') 'Unknown forcingFileType '''//trim(forcing_file_type)//' in file ''', file_name, & + write (msgbuf, '(7a)') 'Unknown forcingFileType '''//trim(forcing_file_type)//' in file ''', file_name, & ''': [', group_name, '], quantity=', trim(quantity), '.' call err_flush() return @@ -838,7 +838,7 @@ function init_meteo_forcings(node_ptr, base_dir, file_name, group_name) result(r res = timespaceinitialfield(xz, yz, qext, ndx, forcing_file, filetype, method, oper, transformcoef, UNC_LOC_S, mask) return ! This was a special case, don't continue with timespace processing below. case default - write (msgbuf, '(a)') 'Unknown quantity '''//trim(quantity)//' in file '''//file_name//''': ['//group_name// & + write (msgbuf, '(7a)') 'Unknown quantity '''//trim(quantity)//' in file '''//file_name//''': ['//group_name// & '].' call err_flush() return diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/bedtr2004.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/bedtr2004.f90 index b690c6c0d3c..515ae458000 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/bedtr2004.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/bedtr2004.f90 @@ -390,7 +390,7 @@ subroutine bedtr2004(u2dh ,d50 ,d90 ,h1 ,rhosol , & do k = num_layers_grid, 1, -1 dif_aks = aks/h1 - (1.0_fp+sig(k)-thick(k)/2.0_fp) dif_upp = 3.0_fp*deltas/h1 - (1.0_fp+sig(k)-thick(k)/2.0_fp) - if (dif_aks<=thick(k) .and. dif_aks>=0.0_fp) then + if (k >= 2 .and. dif_aks<=thick(k) .and. dif_aks>=0.0_fp) then ! ! k-layer contains aks (take part above) ! diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 index 21bd9c8ed55..38142514341 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 @@ -190,8 +190,8 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h dzdx, dzdy, dtol, phi, ucr, ucrb, Ucrs) ! ! transport parameters - Asb=0.015_fp*h*(d50/h)**1.2_fp/(delta*ag*d50)**0.75_fp !bed load coefficent - Ass=0.012_fp*d50*dster**(-0.6_fp)/(delta*ag*d50)**1.2_fp !suspended load coeffient + Asb=0.015_fp*h*(d50/h)**1.2_fp/(delta*ag*d50)**0.75_fp !bed load coefficient + Ass=0.012_fp*d50*dster**(-0.6_fp)/(delta*ag*d50)**1.2_fp !suspended load coefficient ! ! Van Rijn use Peak orbital flow velocity --> 0.64 corresponds to 0.4 coefficient regular waves Van Rijn (2007) term1=utot**2+0.64_fp*sws*urms2 diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 index 0181a3c9ce2..c70598ca38d 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 @@ -181,8 +181,8 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h Cd=(0.40_fp/(log(max(h,10.0_fp*z0)/z0)-1.0_fp))**2 ! ! transport parameters - Asb=0.005_fp*h*(d50/h/(delta*ag*d50))**1.2_fp ! bed load coefficent - Ass=0.012_fp*d50*dster**(-0.6_fp)/(delta*ag*d50)**1.2_fp ! suspended load coeffient + Asb=0.005_fp*h*(d50/h/(delta*ag*d50))**1.2_fp ! bed load coefficient + Ass=0.012_fp*d50*dster**(-0.6_fp)/(delta*ag*d50)**1.2_fp ! suspended load coefficient ! term1=utot**2+0.018_fp/Cd*sws*urms2 ! From 773a0c477ab3ff523c35ab6c0250f906dab5b393 Mon Sep 17 00:00:00 2001 From: reyns Date: Thu, 20 Nov 2025 17:53:42 +0100 Subject: [PATCH 04/18] UNST-9434 Merge part 4 --- .../src/dflowfm_data/m_xbeach_data.f90 | 1 - .../src/dflowfm_kernel/compute/compute_dynveg.f90 | 6 +++--- .../src/dflowfm_kernel/compute/set_kbot_ktop.f90 | 2 +- .../compute_sediment/bermslopenudging.f90 | 15 ++++++--------- .../dflowfm_kernel/compute_sediment/duneaval.f90 | 10 ++++++++-- .../compute_sediment/m_fm_bott3d.f90 | 6 +++--- .../compute_waves/surfbeat/xbeach_math_tools.F90 | 4 ++++ .../compute_waves/surfbeat/xbeachwaves.f90 | 4 ++-- .../dflowfm_kernel/prepost/flow_sedmorinit.f90 | 6 ------ 9 files changed, 27 insertions(+), 27 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_xbeach_data.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_xbeach_data.f90 index d6a235f7cc3..e5e1e7da56a 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_xbeach_data.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_xbeach_data.f90 @@ -262,7 +262,6 @@ module m_xbeach_data integer :: tsmult = -123 ! [-] multiplier, maximizes implicit timestep based on CFL based timestep for implicit solver real(kind=dp) :: waveps = -123 ! [-] eps for wave related quantities, for comparison with XBeach real(kind=dp) :: d_relaxfac = -123 ! [-] Relaxation factor for wave dissipation in stationary solver - real(kind=dp) :: DR_minthresh = -123 ! [-] ! ! [Section] Roller and wave turbulence parameters real(kind=dp) :: BRfac = -123 ! [-] (advanced) Calibration factor surface slope diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 index d1edb3d1b46..126a2f5d7b1 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 @@ -44,12 +44,12 @@ subroutine update_dynveg() use m_flow if (dynroughveg > 0) then - where ((dynveg) .and. (cumes > 0_dp)) ! linear function do to deposition ( sedero > 0 ) + where ((dynveg) .and. (cumes > 0_dp)) ! linear function due to deposition ( sedero > 0 ) frcu = frcumin + min(max((dstem - cumes) / dstem, 0._dp), 1.0_dp) * (frcu0 - frcumin) - elsewhere((dynveg) .and. (cumes < (-1_dp * droot))) ! step function do to erosion larger than root than always minimum ( sedero < -droot ) + elsewhere((dynveg) .and. (cumes < (-1_dp * droot))) ! step function due to erosion larger than root than always minimum ( sedero < -droot ) frcu = frcumin dynveg = .false. - elsewhere(dynveg) ! linear function do to deposition ( -droot < sedero < 0 ) + elsewhere(dynveg) ! linear function due to deposition ( -droot < sedero < 0 ) frcu = frcumin + min(max((droot + cumes) / droot, 0._dp), 1.0_dp) * (frcu0 - frcumin) elsewhere ! do nothing diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 index 659291184f4..4bb37a54369 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 @@ -326,7 +326,7 @@ subroutine update_vertical_coordinates_boundary() ktop(n) = kb - 1 + kmxn(n) end do return ! Early exit - no link updates needed for sigma layers, volumes already calculated - + ! JRE todo: z lyr morpho else if (Layertype == LAYTP_Z) then ! z or z-sigma do i_bnd = 1, nbndz n = kbndz(1, i_bnd) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 index 8a4e6688031..acac0a0220f 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 @@ -51,7 +51,7 @@ subroutine bermslopenudging(error) integer :: L, k1, k2 integer :: lsd - real(kind=dp) :: hwavu, slope, flx, frc, fixf, trmag_u, slpfac + real(kind=dp) :: hwavu, slope, flx, fixf, trmag_u, slpfac real(kind=dp) :: cosw, sinw, coswu error = .true. @@ -136,7 +136,7 @@ subroutine bermslopenudging(error) trmag_u = hypot(e_sswn(L, lsd), e_sswt(L, lsd)) flx = trmag_u * slpfac e_sswn(L, lsd) = e_sswn(L, lsd) - flx - call getfracfixfac(L, k1, k2, lsd, e_sswn(L, lsd), fixf) + call getfixfac(L, k1, k2, lsd, e_sswn(L, lsd), fixf) e_sswn(L, lsd) = e_sswn(L, lsd) * fixf end if end do @@ -147,9 +147,9 @@ subroutine bermslopenudging(error) end subroutine bermslopenudging - subroutine getfracfixfac(L, k1, k2, lsd, transp, frc, fixf) + subroutine getfixfac(L, k1, k2, lsd, transp, fixf) use precision, only: dp - use m_fm_erosed, only: fixfac, frac + use m_fm_erosed, only: fixfac use m_flowgeom, only: lnxi use m_flow, only: hu, epshu @@ -157,20 +157,17 @@ subroutine getfracfixfac(L, k1, k2, lsd, transp, frc, fixf) integer, intent(in) :: L, k1, k2, lsd real(kind=dp), intent(in) :: transp - real(kind=dp), intent(out) :: frc, fixf + real(kind=dp), intent(out) :: fixf if (L > lnxi .and. hu(L) > epshu) then fixf = fixfac(k2, lsd) - frc = frac(k2, lsd) else if (transp >= 0) then fixf = fixfac(k1, lsd) - frc = frac(k1, lsd) else fixf = fixfac(k2, lsd) - frc = frac(k2, lsd) end if end if - end subroutine getfracfixfac + end subroutine getfixfac end module m_bermslopenudging diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/duneaval.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/duneaval.f90 index 936b45dc0e8..01f2c8c0f3a 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/duneaval.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/duneaval.f90 @@ -43,7 +43,8 @@ module m_duneaval subroutine duneaval(error) use precision, only: dp use m_fm_erosed, only: hswitch, wetslope, dryslope, e_dzdn, e_dzdt, avaltime, morfac, lsedtot, fixfac, frac, dzmaxdune, rhosol - use m_sediment, only: avalflux + use m_fm_erosed, only: bermslopetransport, bermslope + use m_sediment, only: avalflux, bermslopeindex use m_flowgeom, only: lnx, wu_mor, ln, acl, bl, dx, lnxi, ba use m_flow, only: hs @@ -64,6 +65,11 @@ subroutine duneaval(error) ac1 = acL(L); ac2 = 1.0_dp - ac1 if (hs(k1) > hswitch .or. hs(k2) > hswitch) then slpmax = wetslope + if (bermslopetransport) then + if (bermslopeindex(L)) then + slpmax = bermslope + end if + end if else slpmax = dryslope end if @@ -99,7 +105,7 @@ subroutine duneaval(error) end if end if ! - avalflux(L, lsd) = avalflux(L, lsd) - ba(k1) * ba(k2) / (ba(k1) + ba(k2)) * avflux * rhosol(lsd) / wu_mor(L) + avalflux(L, lsd) = avalflux(L, lsd) - ba(k1) * ba(k2) / (ba(k1) + ba(k2)) * avflux * rhosol(lsd) / wu_mor(L) !m2 m/s kg /m3 /m = kg/s/m end do end if end do diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 index 663e2a183bb..6d4cc49abf5 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 @@ -1177,13 +1177,13 @@ subroutine fm_change_in_sediment_thickness(dtmor) do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) Lf = abs(LL) - flux = avalflux(Lf, l) * wu_mor(Lf) + flux = avalflux(Lf, l) * wu_mor(Lf) ! kg m-1 s-1 m call fm_sumflux(LL, sumflux, flux) end do - trndiv = trndiv + sumflux * bai_mor(nm) + trndiv = trndiv + sumflux * bai_mor(nm) ! kg s-1 end if ! - dsdnm = (trndiv + sedflx - eroflx) * dtmor + dsdnm = (trndiv + sedflx - eroflx) * dtmor ! kg m-2 ! ! Warn if bottom changes are very large, ! depth change NOT LIMITED diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeach_math_tools.F90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeach_math_tools.F90 index 34cd6dd747f..00a57fef6d6 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeach_math_tools.F90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeach_math_tools.F90 @@ -425,19 +425,23 @@ subroutine fftradix(array, ntotal, npass, nspan, inv, stat) if (present(stat)) then allocate (ctmp(maxfactor), sine(maxfactor), cosine(maxfactor), STAT=stat) if (stat /= 0) return + ctmp = (0.0_fftkind, 0.0_fftkind); sine = 0.0_fftkind; cosine= 0.0_fftkind call transform() deallocate (sine, cosine, STAT=stat) if (stat /= 0) return allocate (perm(nperm), STAT=stat) if (stat /= 0) return + perm = 0 call permute() deallocate (perm, ctmp, STAT=stat) if (stat /= 0) return else allocate (ctmp(maxfactor), sine(maxfactor), cosine(maxfactor)) + ctmp = (0.0_fftkind, 0.0_fftkind); sine = 0.0_fftkind; cosine= 0.0_fftkind call transform() deallocate (sine, cosine) allocate (perm(nperm)) + perm = 0 call permute() deallocate (perm, ctmp) end if diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 index 751da981f5c..a814a315707 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 @@ -289,7 +289,6 @@ subroutine xbeach_all_input() beta = readkey_dbl(md_surfbeatfile, 'beta', 0.10_dp, 0.05_dp, 0.3_dp) varbeta = readkey_int(md_surfbeatfile, 'varbeta', 1, 0, 1, strict=.true.) rfb = readkey_int(md_surfbeatfile, 'rfb', 0, 0, 1, strict=.true.) - DR_minthresh = readkey_dbl(md_surfbeatfile, 'DR_minthresh', 0.0_dp, 0.0_dp, 2.0_dp, strict=.true.) ! ! ! Wave-current interaction parameters @@ -1687,7 +1686,8 @@ subroutine xbeach_wave_bc() logical :: isRecomputed integer :: kb, ki, Lb, nw - integer :: LL1, LL2, n, lunfil + integer :: LL1, LL2, n + integer, save :: lunfil ierror = 1 if (.not. allocated(dist)) allocate (dist(1:ntheta), factor(1:ntheta), e01(1:ntheta)) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 index 0db3e1967a8..0508c3340c2 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 @@ -464,12 +464,6 @@ subroutine flow_sedmorinit() end if call realloc(avalflux, [lnx, stmpar%lsedtot], stat=ierr, fill=0.0_dp, keepExisting=.false.) ! - ! Warn user if default wetslope is still 10.0 when using dune avalanching. Reset default to reasonable 1.0 in that case. - if (comparereal(stmpar%morpar%wetslope, 10.0_dp) == 0) then - call mess(LEVEL_WARN, 'unstruc::flow_sedmorinit - Dune avalanching is switched on. Default wetslope reset to 0.1 from 10.0') - stmpar%morpar%wetslope = 1.0e-1_dp - end if - ! ! Warn user if upperlimitssc is set icm with avalanching. This effectively removes sedimentation of the avalanching flux if set too strictly. if (comparereal(upperlimitssc, 1.0e6_dp) /= 0) then call mess(LEVEL_WARN, 'unstruc::flow_sedmorinit - Upper limit imposed on ssc. This will cause large mass errors icm avalanching. Check the mass error at the end of the run.') From 106a563d7c17a0cda8e257a2b28b89570f53534a Mon Sep 17 00:00:00 2001 From: jreyns <35960494+jreyns@users.noreply.github.com> Date: Mon, 22 Dec 2025 23:43:31 +0100 Subject: [PATCH 05/18] Update src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- .../dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 index 6568b05ef6b..14e5aaf4c58 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 @@ -244,7 +244,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte do L = Lb, Ltop(LL) if (hu(L) <= slfacdeltau) then htop = min(hu(L), slfacdeltau) ! max height within streaming layer - alin = 1_dp - htop / slfacdeltau ! linear from 1 at bed to 0 at 3*deltau + alin = 1_dp - htop / slfacdeltau ! linear from 1 at bed to 0 at slfacdeltau (= strlyrfac * deltau) Dfu1 = Dfuc * alin adve(L) = adve(L) - 0.5_dp * (Dfu0 + Dfu1) Dfu0 = Dfu1 From 0c50bcdde0e7a6f6aeebb62fd0f47a495da79198 Mon Sep 17 00:00:00 2001 From: jreyns <35960494+jreyns@users.noreply.github.com> Date: Mon, 22 Dec 2025 23:43:53 +0100 Subject: [PATCH 06/18] Update src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- .../packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 index 35e2c7091ed..c4a6489730a 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 @@ -3344,7 +3344,7 @@ subroutine writeMDUFilepointer(mout, writeall, istat) if (writeall) then call prop_set(prop_ptr, 'physics', 'Umodlin', umodlin, 'Linear friction umod, for friction_type=4,5,6') end if - call prop_set(prop_ptr, 'physics', 'DynRoughVeg', dynroughveg, 'Switch for dynamic vegetation rougness. Default 0.') + call prop_set(prop_ptr, 'physics', 'DynRoughVeg', dynroughveg, 'Switch for dynamic vegetation roughness. Default 0.') call prop_set(prop_ptr, 'physics', 'droot', droot, 'Root depth. Default 0.5m') ! default 0.5 [0-100] call prop_set(prop_ptr, 'physics', 'dstem', dstem, 'Stem height. Default 0.5m') ! default 0.5 [0-100] call prop_set(prop_ptr, 'physics', 'nmanmin', frcumin, 'Base friction Manning value. Default 0.023') ! default 0.023 From c79a179b8d6a550a943761553fcefda8a3d6b77d Mon Sep 17 00:00:00 2001 From: hrajagers Date: Wed, 28 Jan 2026 17:12:44 +0100 Subject: [PATCH 07/18] Fortran styler --- .../src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 index d59736e4a24..59d4ec63502 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 @@ -2195,7 +2195,8 @@ subroutine determine_linkbased_cumblchg() do L = 1, lnx k1 = ln(1, L) k2 = ln(2, L) - ac1 = acl(L); ac2 = 1_fp - ac1 + ac1 = acl(L) + ac2 = 1_fp - ac1 cumes(L) = cumes(L) + ac1 * (blchg(k1)) + ac2 * (blchg(k2)) end do From 7c26555971b3ffd042f707e3bed4012152c8f618 Mon Sep 17 00:00:00 2001 From: hrajagers Date: Thu, 29 Jan 2026 10:32:29 +0100 Subject: [PATCH 08/18] minor changes adding ".0" and some comment updates --- .../compute_sediment/fm_erosed.f90 | 3 +- .../compute_sediment/m_fm_bott3d.f90 | 76 +++++++++---------- .../compute_waves/surfbeat/xbeachwaves.f90 | 6 +- 3 files changed, 42 insertions(+), 43 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 index 8e60d2c9e9e..fc518dc820c 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 @@ -469,7 +469,7 @@ subroutine fm_erosed() ! if (kmx > 0) then ! 3D deltas = 0.05_dp - maxdepfrac = 0.05 + maxdepfrac = 0.05_dp if (jawave > NO_WAVES .and. v2dwbl > 0) then deltas = 0.0_dp do L = 1, lnx @@ -1186,7 +1186,6 @@ subroutine fm_erosed() rsedeq(nm, l) = rsdqlc(kmaxsd) ! thick0 = max(thicklc(kmaxsd) * h0, epshu) - !thick1 = max(thicklc(kmaxsd) * h1, epshu) thick1 = thicklc(kmaxsd) * h1 ! call soursin_3d(h1, thick1, thick1, & ! thick1 iso thick0 mass conservation diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 index 59d4ec63502..abb27d81f2a 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 @@ -371,7 +371,7 @@ subroutine fm_suspended_sand_correction() cycle end if ac1 = acL(Lx) - ac2 = 1_dp - ac1 + ac2 = 1.0_dp - ac1 k1 = ln(1, Lx) k2 = ln(2, Lx) call getLbotLtop(Lx, Lb, Lt) @@ -493,7 +493,7 @@ subroutine fm_suspended_sand_correction() ! cavg*dz = | c(z) dz = c_a/(-R+1)*(z/a)^(-R+1)*a | = c_a/(-R+1)*a^R*z^(-R+1) | ! /a a a ! - cavg1 = (ceavg / (apower + 1.0_dp)) * (1_dp / aksu)**apower + cavg1 = (ceavg / (apower + 1.0_dp)) * (1.0_dp / aksu)**apower cavg2 = zktop**(apower + 1.0_dp) - aksu**(apower + 1.0_dp) cavg = cavg1 * cavg2 ! kg/m3/m ! @@ -611,9 +611,9 @@ subroutine apply_nodal_point_relation() allocate (branInIDLn(network%nds%Count), stat=istat) end if - qb_out(:) = 0_dp - width_out(:) = 0_dp - sb_in(:, :) = 0_dp + qb_out(:) = 0.0_dp + width_out(:) = 0.0_dp + sb_in(:, :) = 0.0_dp sb_dir(:, :, :) = 1 BranInIDLn(:) = 0 @@ -634,7 +634,7 @@ subroutine apply_nodal_point_relation() ! wb1d = wu_mor(L) ! - if (u1(L) * Ldir < 0_dp) then + if (u1(L) * Ldir < 0.0_dp) then ! Outgoing discharge qb1d = -qa(L) * Ldir ! replace with junction advection: to do WO width_out(inod) = width_out(inod) + wb1d @@ -774,7 +774,7 @@ subroutine apply_nodal_point_relation() else e_sbcn(L, ised) = 0.0_fp - e_sbct(L, ised) = 0.0 + e_sbct(L, ised) = 0.0_fp end if end if @@ -915,7 +915,7 @@ subroutine fm_bed_boundary_conditions(timhr) ! ! Prepare loop over boundary points ! - tausum2(1) = 0_dp + tausum2(1) = 0.0_dp do ib = 1, morbnd(jb)%npnt lm = morbnd(jb)%lm(ib) k2 = morbnd(jb)%nxmx(ib) @@ -934,7 +934,7 @@ subroutine fm_bed_boundary_conditions(timhr) ! in combination with non-uniform cells. li = 0 do l = 1, lsedtot - sbsum = 0_dp + sbsum = 0.0_dp ! ! bed load transport only for fractions with bedload component ! @@ -1000,7 +1000,7 @@ subroutine fm_bed_boundary_conditions(timhr) ! if (morbnd(jb)%ibcmt(3) == lsedbed) then call get_tau(ln(2, lm), taucurc, czc, jawaveswartdelwaq_local) - if (tausum2(1) > 0_dp .and. wu_mor(lm) > 0_dp) then ! fix cutcell + if (tausum2(1) > 0.0_dp .and. wu_mor(lm) > 0.0_dp) then ! fix cutcell rate = bc_sed_distribution(li) * taucurc**2 / wu_mor(lm) / tausum2(1) else rate = bc_mor_array(li) @@ -1097,7 +1097,7 @@ subroutine fm_change_in_sediment_thickness(dtmor) ! ! Update quantity of bottom sediment ! - dbodsd(:, :) = 0_dp + dbodsd(:, :) = 0.0_dp ! ! compute change in bodsed (dbodsd) ! @@ -1109,22 +1109,22 @@ subroutine fm_change_in_sediment_thickness(dtmor) ! loop over internal (ndxi) nodes - don't update the boundary nodes ! do nm = 1, Ndxi_mor - trndiv = 0_dp - sedflx = 0_dp - eroflx = 0_dp + trndiv = 0.0_dp + sedflx = 0.0_dp + eroflx = 0.0_dp !FM1DIMP2DO: I do not like this, but I cannot think of a better way. !The added flownodes at junctions are after the boundary ghost nodes. !We have to skip the boundaries but loop over the added flownodes. if ((nm > ndxi) .and. (nm < ndx + 1)) then cycle end if - if (sus /= 0_dp .and. .not. bedload) then + if (sus /= 0.0_dp .and. .not. bedload) then if (neglectentrainment) then ! ! mass balance based on transport fluxes only: entrainment and deposition ! do not lead to erosion/sedimentation. ! - sumflux = 0_dp + sumflux = 0.0_dp if (kmx > 0) then do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) @@ -1133,7 +1133,7 @@ subroutine fm_change_in_sediment_thickness(dtmor) if (Lt < Lb) then cycle end if - flux = 0_dp + flux = 0.0_dp do iL = Lb, Lt flux = flux + fluxhortot(j, iL) end do @@ -1197,12 +1197,12 @@ subroutine fm_change_in_sediment_thickness(dtmor) end if end if end if - ssccum(l, nm) = 0_dp + ssccum(l, nm) = 0.0_dp eroflx = sourse(nm, l) * thick1 ! mass conservation, different from D3D ! ! add suspended transport correction vector ! - sumflux = 0_dp + sumflux = 0.0_dp do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) Lf = abs(LL) @@ -1213,7 +1213,7 @@ subroutine fm_change_in_sediment_thickness(dtmor) end if end if if (bed /= 0.0_dp) then - sumflux = 0_dp + sumflux = 0.0_dp do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) Lf = abs(LL) @@ -1224,7 +1224,7 @@ subroutine fm_change_in_sediment_thickness(dtmor) end if ! if (duneavalan) then ! take fluxes out of timestep restriction - sumflux = 0_dp ! drawback: avalanching fluxes not included in total transports + sumflux = 0.0_dp ! drawback: avalanching fluxes not included in total transports do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) Lf = abs(LL) @@ -1321,7 +1321,7 @@ subroutine fm_dry_bed_erosion(dtmor) cycle ! check whether sufficient as condition end if ! - totdbodsd = 0_dp + totdbodsd = 0.0_dp do l = 1, lsedtot totdbodsd = totdbodsd + real(dbodsd(l, nm), hp) end do @@ -1329,7 +1329,7 @@ subroutine fm_dry_bed_erosion(dtmor) ! If this is a cell where erosion is occuring (accretion is not ! distributed to dry points) then... ! - if (totdbodsd < 0_dp) then + if (totdbodsd < 0.0_dp) then ! ! Note: contrary to the previous implementation, this new ! implementation erodes the sediment from nm and @@ -1342,7 +1342,7 @@ subroutine fm_dry_bed_erosion(dtmor) ! individual fractions. ! bamin = ba(nm) - totfixfrac = 0_dp + totfixfrac = 0.0_dp ! do L = 1, nd(nm)%lnx k1 = ln(1, abs(nd(nm)%ln(L))) @@ -1393,7 +1393,7 @@ subroutine fm_dry_bed_erosion(dtmor) k2 = ln(2, abs(nd(nm)%ln(L))) Lf = abs(nd(nm)%ln(L)) ! cutcells - if (wu_mor(Lf) == 0_dp) then + if (wu_mor(Lf) == 0.0_dp) then cycle end if ! @@ -1406,7 +1406,7 @@ subroutine fm_dry_bed_erosion(dtmor) dv = thet * fixfac(knb, ll) * frac(knb, ll) dbodsd(ll, knb) = dbodsd(ll, knb) - dv * bai_mor(knb) dbodsd(ll, nm) = dbodsd(ll, nm) + dv * bai_mor(nm) - e_sbn(Lf, ll) = e_sbn(Lf, ll) + dv / (dtmor * wu_mor(Lf)) * sign(1_dp, nd(nm)%ln(L) + 0_dp) + e_sbn(Lf, ll) = e_sbn(Lf, ll) + dv / (dtmor * wu_mor(Lf)) * sign(1.0_dp, nd(nm)%ln(L) + 0.0_dp) end if end do ! L end do ! ll @@ -1454,13 +1454,13 @@ subroutine fm_apply_mormerge() jamerge = .false. if (jamormergedtuser > 0) then mergebodsed = mergebodsed + dbodsd - dbodsd(:, :) = 0_dp + dbodsd(:, :) = 0.0_dp if (comparereal(time1, time_user, eps10) >= 0) then jamerge = .true. end if else mergebodsed = dbodsd - dbodsd(:, :) = 0_dp + dbodsd(:, :) = 0.0_dp jamerge = .true. end if if (jamerge) then @@ -1481,7 +1481,7 @@ subroutine fm_apply_mormerge() dbodsd(ll, nm) = real(stmpar%morpar%mergebuf(ii), fp) end do end do - mergebodsed(:, :) = 0_dp + mergebodsed(:, :) = 0.0_dp end if end if @@ -1581,7 +1581,7 @@ subroutine fm_apply_bed_boundary_condition(dtmor, timhr) ! will be equal to 1. ! icond = morbnd(jb)%icond - if (u1(lm) < 0_dp) then + if (u1(lm) < 0.0_dp) then icond = 0 ! to do: 3d end if ! @@ -1779,8 +1779,8 @@ subroutine fm_total_face_normal_suspended_transport() do ll = 1, lsed j = lstart + ll ! constituent index do L = 1, lnx - e_ssn(L, ll) = 0_dp - if (wu_mor(L) == 0_dp) then + e_ssn(L, ll) = 0.0_dp + if (wu_mor(L) == 0.0_dp) then cycle end if call getLbotLtop(L, Lb, Lt) @@ -1815,8 +1815,8 @@ subroutine sum_current_wave_transport_links() !! Execute !! - e_sbn(:, :) = 0_dp - e_sbt(:, :) = 0_dp + e_sbn(:, :) = 0.0_dp + e_sbt(:, :) = 0.0_dp do l = 1, lsedtot if (has_bedload(tratyp(l))) then do nm = 1, lnx @@ -1893,7 +1893,7 @@ subroutine fm_blchg_no_cmpupd() !! if (.not. cmpupd) then - blchg(:) = 0_dp + blchg(:) = 0.0_dp do ll = 1, lsedtot do nm = 1, ndx blchg(nm) = blchg(nm) + dbodsd(ll, nm) / cdryb(ll) @@ -2095,12 +2095,12 @@ subroutine fm_erosion_velocity(dtmor) !! Execute !! - if (dtmor > 0_dp) then + if (dtmor > 0.0_dp) then do nm = 1, ndx dzbdt(nm) = blchg(nm) / dtmor end do else - dzbdt(:) = 0_dp + dzbdt(:) = 0.0_dp end if end subroutine fm_erosion_velocity @@ -2196,7 +2196,7 @@ subroutine determine_linkbased_cumblchg() k1 = ln(1, L) k2 = ln(2, L) ac1 = acl(L) - ac2 = 1_fp - ac1 + ac2 = 1.0_dp - ac1 cumes(L) = cumes(L) + ac1 * (blchg(k1)) + ac2 * (blchg(k2)) end do diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 index a7dfbfbda48..122b90e7ff6 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 @@ -1713,7 +1713,7 @@ subroutine xbeach_wave_bc() integer :: kb, ki, Lb, nw integer :: LL1, LL2, n - integer, save :: lunfil + integer, save :: lunfil ! used for trim(instat) == 'stat_table' ierror = 1 if (.not. allocated(dist)) then @@ -6143,8 +6143,8 @@ subroutine xbeach_compute_stokesdrift() if (jawavestokes == NO_STOKES_DRIFT) then ustokes = 0.0_dp vstokes = 0.0_dp - ustx_cc(k) = 0.0_dp - usty_cc(k) = 0.0_dp ! output + ustx_cc = 0.0_dp + usty_cc = 0.0_dp return end if From faffc99b2edd672d25c930c22c9ac6574097428e Mon Sep 17 00:00:00 2001 From: reyns Date: Wed, 4 Feb 2026 17:06:40 +0100 Subject: [PATCH 09/18] review comments part 1 --- .../packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 | 3 +-- .../packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 | 1 - .../src/dflowfm_kernel/compute_sediment/fm_erosed.f90 | 4 ++-- .../src/dflowfm_kernel/prepost/flow_flowinit.f90 | 7 ++++--- .../dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 | 4 ++-- 5 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 index 2198384e3e6..b8623668d9a 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 @@ -331,9 +331,8 @@ module m_flow ! flow arrays-999 real(kind=dp), allocatable, target :: cftrtfac(:) !< array for optional multiplication factor for trachytopes's returned roughness values integer :: jacftrtfac !< Whether or not (1/0) a multiplication factor field was specified for trachytopes's Chezy roughness values. real(kind=dp), allocatable :: czu(:) !< array for chezy friction at flow links {"location": "edge", "shape": ["lnx"]} - real(kind=dp), allocatable :: frcu0(:) !< array for chezy friction at flow links at start of the run {"location": "edge", "shape": ["lnx"]} + real(kind=dp), allocatable :: frcu0(:) !< array for manning friction at flow links at start of the run {"location": "edge", "shape": ["lnx"]} logical, allocatable :: dynveg(:) !< vegetation present or not {"location": "edge", "shape": ["lnx"]} - integer, allocatable :: kcsveg(:) !< in vegpol or not {"location": "edge", "shape": ["lnx"]} real(kind=dp), allocatable, target :: frculin(:) !< friction coefficient set by initial fields ( todo mag later ook single real worden) integer, allocatable :: ifrcutp(:) !< friction coefficient type initial fields ( todo mag later ook single real worden) real(kind=dp), allocatable, target :: Cdwusp(:) !< Wind friction coefficient at u point set by initial fields ( todo mag later ook single real worden) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 index 1447dc210a5..ceb7b35ee59 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 @@ -40,7 +40,6 @@ module m_zlin contains real(kind=dp) function zlin(LL) ! get various values at flow links - use precision, only: dp use m_getltoplot use m_flow use m_flowgeom diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 index fc518dc820c..7ec29cca972 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 @@ -974,8 +974,8 @@ subroutine fm_erosed() end if ! kmaxsd = kmaxlc ! for mud fractions kmaxsd points to the grid cell at the bottom of the water column - thick0 = max(thicklc(kmaxsd) * h0, epshs) - thick1 = max(thicklc(kmaxsd) * h1, epshs) + thick0 = max(thicklc(kmaxsd) * h0, epshu) + thick1 = thicklc(kmaxsd) * h1 ! call erosilt(thicklc, kmaxlc, wslc, mdia, & & thick1, thick1, fixfac(nm, l), srcmax(nm, l), & ! mass conservation diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 index 7acaa2b52dc..a2234d5c7e9 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 @@ -688,10 +688,9 @@ subroutine set_friction_coefficient_by_initial_fields() use m_physcoef, only: frcuni1d, frcuni1d2d, frcunistreetinlet, frcuniroofgutterpipe, frcuni, frcumin, frcmax, ifrctypuni, dynroughveg use m_missing, only: dmiss, imiss use m_alloc - use m_flow, only: kcsveg use unstruc_model, only: md_dynvegpol use timespace_parameters, only: LOCTP_POLYGON_FILE - use timespace, only: selectelset_internal_nodes + use timespace, only: selectelset_internal_links use m_delpol use MessageHandling @@ -706,6 +705,7 @@ subroutine set_friction_coefficient_by_initial_fields() logical :: ex integer, dimension(:), allocatable :: kp + integer, dimension(:), allocatable :: kcsveg do link = 1, lnx if (frcu(link) == dmiss) then @@ -745,7 +745,8 @@ subroutine set_friction_coefficient_by_initial_fields() allocate (kp(1:lnx)) kp = 0 ! find cells inside polygon - call selectelset_internal_nodes(xz, yz, kcs, lnx, kp, pointscount, LOC_FILE=md_dynvegpol, LOC_SPEC_TYPE=LOCTP_POLYGON_FILE) + call selectelset_internal_links(lnx, kp, pointscount, LOC_SPEC_TYPE=LOCTP_POLYGON_FILE, LOC_FILE=md_dynvegpol) + do k = 1, pointscount kcsveg(kp(k)) = 1 end do diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 index 94a559c5c38..92547af6a8e 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 @@ -5606,9 +5606,9 @@ subroutine selectelset_internal_links(lnx, keg, numg, & !inputs integer, intent(in) :: lnx !< Number of flow links in input. (Currently unused). - integer, intent(out) :: keg(:) !< Output array containing the flow link numbers that were selected. + integer, intent(out) :: keg(:) !< Output array containing the flow link numbers that were selected. kp !< Size of array is responsability of call site, and filling starts at index 1 upon each call. - integer, intent(out) :: numg !< Number of flow links that were selected (i.e., keg(1:numg) will be filled). + integer, intent(out) :: numg !< Number of flow links that were selected (i.e., keg(1:numg) will be filled). nump integer, intent(in) :: loc_spec_type !< Type of spatial input for selecting nodes. One of: LOCTP_POLYGON_FILE, LOCTP_POLYLINE_FILE, LOCTP_POLYGON_XY , LOCTP_POLYLINE_XY, LOCTP_BRANCHID_CHAINAGE or LOCTP_CONTACTID. character(len=*), optional, intent(in) :: loc_file !< (Optional) File name of a polyline file (when loc_spec_type==LOCTP_POLYGON_FILE). integer, optional, intent(in) :: nump !< (Optional) Number of points in polyline coordinate arrays xpin and ypin (when loc_spec_type==LOCTP_POLYGON_XY/LOCTP_POLYLINE_XY). From eabaed87a6f3221fbccec8bfe35af2ab0061546a Mon Sep 17 00:00:00 2001 From: jreyns Date: Wed, 11 Feb 2026 17:26:34 +0100 Subject: [PATCH 10/18] UNST-9434 review comments part 2 --- .../dflowfm_kernel/src/dflowfm_data/m_flow.f90 | 2 +- .../dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 | 8 ++++---- .../dflowfm_kernel/src/dflowfm_data/m_sediment.f90 | 4 ++-- .../dflowfm_kernel/src/dflowfm_data/m_waves.f90 | 8 ++++---- .../src/dflowfm_data/unstruc_model.f90 | 4 ++-- .../src/dflowfm_kernel/compute/compute_dynveg.f90 | 12 ++++++------ .../src/dflowfm_kernel/compute/getustbcfuhi.f90 | 2 +- .../src/dflowfm_kernel/compute/getustwav.f90 | 3 ++- .../dflowfm_kernel/compute_sediment/fm_erosed.f90 | 8 ++++---- .../src/dflowfm_kernel/prepost/flow_flowinit.f90 | 2 +- 10 files changed, 27 insertions(+), 26 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 index b8623668d9a..3f33618da14 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 @@ -331,7 +331,7 @@ module m_flow ! flow arrays-999 real(kind=dp), allocatable, target :: cftrtfac(:) !< array for optional multiplication factor for trachytopes's returned roughness values integer :: jacftrtfac !< Whether or not (1/0) a multiplication factor field was specified for trachytopes's Chezy roughness values. real(kind=dp), allocatable :: czu(:) !< array for chezy friction at flow links {"location": "edge", "shape": ["lnx"]} - real(kind=dp), allocatable :: frcu0(:) !< array for manning friction at flow links at start of the run {"location": "edge", "shape": ["lnx"]} + real(kind=dp), allocatable :: frcu0(:) !< array for Manning friction at flow links at start of the run {"location": "edge", "shape": ["lnx"]} logical, allocatable :: dynveg(:) !< vegetation present or not {"location": "edge", "shape": ["lnx"]} real(kind=dp), allocatable, target :: frculin(:) !< friction coefficient set by initial fields ( todo mag later ook single real worden) integer, allocatable :: ifrcutp(:) !< friction coefficient type initial fields ( todo mag later ook single real worden) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 index d64a6152b06..a61e270b4c3 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 @@ -51,10 +51,10 @@ module m_physcoef real(kind=dp) :: frcuniroof = 0.030 real(kind=dp) :: frcuni1Dgrounlay !< uniform friction coeff groundlayer real(kind=dp) :: frcmax !< max friction coeff in frcu - integer :: dynroughveg - real(kind=dp) :: frcumin - real(kind=dp) :: droot - real(kind=dp) :: dstem + integer :: dynroughveg !< 0=off, 1=on, effect erosion/sedimentation on Manning roughness representative of dune vegetation in storm models, only for 2D friction + real(kind=dp) :: frcumin !< base (Manning) friction (without vegetation) in vegetation polygon area, default 0.023 [s/m^(1/3)] + real(kind=dp) :: droot !< root depth for dynamic roughness vegetation, default 0.5m + real(kind=dp) :: dstem !< stem height for dynamic roughness vegetation, default 0.5m integer :: ifrctypuni !< 0=chezy, 1=manning, 2=white colebrook D3D, 3=white colebrook Waqua (now only 2D) real(kind=dp) :: frcunilin !< uniform friction coeff diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 index 6929a2e400a..034c3e064f9 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 @@ -109,7 +109,7 @@ module m_sediment real(kind=dp) :: upperlimitssc integer :: inmorphopol !< value of the update inside morphopol (only 0 or 1 make sense) real(kind=dp) :: difparam !< scale diffusion below reference level with settling velocity, Default 10.0 - real(kind=dp) :: difcal !< scale seddif + real(kind=dp) :: seddif_cal !< scale seddif ! !-------------------------------------------------- old sediment transport and morphology integer :: mxgrKrone !< mx grainsize index nr that followsKrone. Rest follows v.Rijn @@ -173,7 +173,7 @@ subroutine default_sediment() upperlimitssc = 1.0e6_dp inmorphopol = 1 difparam = 10.0_dp - difcal = 0.0_dp + seddif_cal = 0.0_dp end subroutine default_sediment diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 index 9c88876dbff..0fd4b5b5312 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 @@ -63,10 +63,10 @@ module m_waves real(kind=dp) :: ftauw !< Swartfactor, tune bed shear stress real(kind=dp) :: fwfac !< Soulsby factor, tune streaming - real(kind=dp) :: fbreak !< tune breaking in tke model - real(kind=dp) :: fforc !< tune wave forces - real(kind=dp) :: fwavpendep !< Layer thickness as proportion of Hrms over which wave breaking adds to TKE source. Default 0.5 - real(kind=dp) :: strlyrfac !< fac*wave boundary layer for streaming + real(kind=dp) :: fbreak !< factor for adjusting wave breaking contribution in tke model + real(kind=dp) :: fforc !< factor for adjusting wave forces in momentum equation, default 1 + real(kind=dp) :: fwavpendep !< layer thickness as proportion of Hrms over which wave breaking adds to TKE source. Default 1.5 + real(kind=dp) :: strlyrfac !< streaming layer thickness is strlyrfac*wave boundary layer thickness. Default 3.0 character(len=4) :: rouwav !< Friction model for wave induced shear stress diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 index 9c72232c0ad..44dab9e5f18 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 @@ -151,7 +151,7 @@ module unstruc_model character(len=max_prop_length) :: md_bedformfile = ' ' !< File containing bedform settings (e.g., *.bfm) character(len=max_prop_length) :: md_morphopol = ' ' !< File containing boundaries of morphologic change extent (e.g., *.pol) character(len=max_prop_length) :: md_sedtrailsfile = ' ' !< File containing extent of sedtrails output grid - character(len=255) :: md_dynvegpol = ' ' !< File containing extent of dynymic vegetation application + character(len=max_prop_length) :: md_dynvegpol = ' ' !< File containing extent of dynamic vegetation application character(len=max_prop_length) :: md_obsfile = ' ' !< File containing observation points (e.g., *_obs.xyn, *_obs.ini) integer :: md_delete_observation_points_outside_grid !< 0 - do not delete, 1 - delete @@ -1522,7 +1522,7 @@ subroutine readMDUFile(filename, istat) call prop_get(md_ptr, 'sediment', 'MormergeDtUser', jamormergedtuser, success) ! Mormerge operation at dtuser timesteps (1) or dts (0, default) call prop_get(md_ptr, 'sediment', 'UpperLimitSSC', upperlimitssc, success) ! Upper limit of cell centre SSC concentration after transport timestep. Default 1d6 (effectively switched off) call prop_get(md_ptr, 'sediment', 'DiffusionScaling', difparam, success) ! Scaling factor to increase diffusion below reference level - call prop_get(md_ptr, 'sediment', 'DiffusionCal', difcal, success) ! Scaling factor to change diffusion for ssc + call prop_get(md_ptr, 'sediment', 'DiffusionCal', seddif_cal, success) ! Scaling factor to change diffusion for ssc if (jased > 0 .and. .not. stm_included) then call prop_get(md_ptr, 'sediment', 'Nr_of_sedfractions', Mxgr) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 index 126a2f5d7b1..53f4ffb1760 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 @@ -1,6 +1,6 @@ !----- AGPL -------------------------------------------------------------------- ! -! Copyright (C) Stichting Deltares, 2017-2024. +! Copyright (C) Stichting Deltares, 2017-2026. ! ! This file is part of Delft3D (D-Flow Flexible Mesh component). ! @@ -44,13 +44,13 @@ subroutine update_dynveg() use m_flow if (dynroughveg > 0) then - where ((dynveg) .and. (cumes > 0_dp)) ! linear function due to deposition ( sedero > 0 ) - frcu = frcumin + min(max((dstem - cumes) / dstem, 0._dp), 1.0_dp) * (frcu0 - frcumin) - elsewhere((dynveg) .and. (cumes < (-1_dp * droot))) ! step function due to erosion larger than root than always minimum ( sedero < -droot ) + where ((dynveg) .and. (cumes > 0.0_dp)) ! linear function due to deposition ( cumes > 0 ) + frcu = frcumin + max((dstem - cumes) / dstem, 0.0_dp) * (frcu0 - frcumin) + elsewhere((dynveg) .and. (cumes < (-1.0_dp * droot))) ! erosion larger than root then always minimum ( cumes < -droot ) frcu = frcumin dynveg = .false. - elsewhere(dynveg) ! linear function due to deposition ( -droot < sedero < 0 ) - frcu = frcumin + min(max((droot + cumes) / droot, 0._dp), 1.0_dp) * (frcu0 - frcumin) + elsewhere(dynveg) ! linear function due to deposition ( -droot < cumes < 0 ) + frcu = frcumin + min(max((droot + cumes) / droot, 0.0_dp), 1.0_dp) * (frcu0 - frcumin) elsewhere ! do nothing frcu = frcu0 diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 index 88cbab7c556..827c6078043 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 @@ -244,7 +244,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte ! if (stm_included) wblt(LL) = deltau ! - ! Streaming below strlyrfac*deltau with linear distribution,, see van Rijn 2011 p9.177 + ! Streaming below strlyrfac*deltau with linear distribution, see van Rijn 2011 p9.177 if (jawavestreaming > WAVE_STREAMING_OFF .and. deltau > 1.0e-4_dp) then ! weakly turbulent flume cases ~1mm-1cm, real turbulent cases 5-50cm slfacdeltau = strlyrfac * deltau Dfu0 = Dfuc ! (m/s2) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 index 4d9eccd8158..ca9c55c19ed 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 @@ -62,6 +62,7 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor real(kind=dp) :: p1, p2, h, z, uusto, fac real(kind=dp), parameter :: alfaw = 20.0_dp + real(kind=dp), parameter :: halfsqpi = 1.0_dp/(2.0_dp * acos(-1.0_dp)) Dfu = 0.0_dp Dfuc = 0.0_dp deltau = 0.0_dp @@ -142,7 +143,7 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor deltau = max(deltau, ee * z00) ! alfaw makes wbl at least ~2ks thick call soulsby(tsig, uorbu, z00, fw) ! streaming with different calibration fac fwfac + soulsby fws - Dfu = 0.2821_dp * fw * uorbu**3 ! random waves: 0.28=1/2sqrt(pi) (m3/s3) + Dfu = halfsqpi * fw * uorbu**3 ! random waves: 0.28=1/2sqrt(pi) (m3/s3) Dfu = fwfac * Dfu / strlyrfac / deltau ! divided by 3 deltau (m2/s3) see van Rijn, streaming layer about 3-5 times wbl Dfuc = Dfu * rk / omeg * costu ! Dfuc = dfu/c/delta, (m /s2) is contribution to adve deltau = alfaw * deltau ! as in delft3d diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 index 7ec29cca972..e21c63ba999 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 @@ -76,10 +76,10 @@ subroutine fm_erosed() use sediment_basics_module use m_physcoef, only: ag, vonkar, sag, backgroundsalinity, backgroundwatertemperature, vismol, frcuni, ifrctypuni use m_sediment, only: stmpar, stm_included, jatranspvel, sbcx_raw, sbcy_raw, sswx_raw, sswy_raw, sbwx_raw, sbwy_raw - use m_sediment, only: difparam, difcal + use m_sediment, only: difparam, seddif_cal use m_flowgeom, only: bl, dxi, csu, snu, wcx1, wcx2, wcy1, wcy2, acl, csu, snu, wcl use m_flow, only: s0, s1, u1, v, kmx, zws, hs, iturbulencemodel, z0urou, ifrcutp, hu, spirint, spiratx, spiraty, & - u_to_umain, frcu_mor, javeg, jabaptist, cfuhi, epshs, taubxu, epsz0 + u_to_umain, frcu_mor, javeg, jabaptist, cfuhi, taubxu, epsz0 use m_flowtimes, only: julrefdat, dts, time1 use unstruc_files, only: mdia use unstruc_channel_flow, only: t_branch, t_node, nt_LinkNode @@ -1195,8 +1195,8 @@ subroutine fm_erosed() & aks_ss3d, sourse(nm, l), sour_im(nm, l), & & sinkse(nm, l)) ! - if (difcal > 0.0_dp) then - seddif(l, kb:kt) = difcal * seddif(l, kb:kt) + if (seddif_cal > 0.0_dp) then + seddif(l, kb:kt) = seddif_cal * seddif(l, kb:kt) end if ! ! Impose relatively large vertical diffusion diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 index a2234d5c7e9..923dc5ca25b 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 @@ -683,7 +683,7 @@ end subroutine set_floodfill_water_levels_based_on_sample_file !> Insert friction coefficient by initial fields subroutine set_friction_coefficient_by_initial_fields() - use m_flowgeom, only: lnx, lnx1D, kcu, xz, yz, kcs + use m_flowgeom, only: lnx, lnx1D, kcu use m_flow, only: frcu, ifrcutp, dynveg, frcu0 use m_physcoef, only: frcuni1d, frcuni1d2d, frcunistreetinlet, frcuniroofgutterpipe, frcuni, frcumin, frcmax, ifrctypuni, dynroughveg use m_missing, only: dmiss, imiss From 9641a7be6a6abed738bf0200275b614d7d91ca4d Mon Sep 17 00:00:00 2001 From: reyns Date: Thu, 19 Feb 2026 14:17:57 +0100 Subject: [PATCH 11/18] remove superfluous vars correct use hwavuni/hwavcom --- .../src/dflowfm_kernel/compute_sediment/fm_erosed.f90 | 2 +- .../src/dflowfm_kernel/prepost/flow_flowinit.f90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 index 7ec29cca972..5518a0e8b84 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 @@ -79,7 +79,7 @@ subroutine fm_erosed() use m_sediment, only: difparam, difcal use m_flowgeom, only: bl, dxi, csu, snu, wcx1, wcx2, wcy1, wcy2, acl, csu, snu, wcl use m_flow, only: s0, s1, u1, v, kmx, zws, hs, iturbulencemodel, z0urou, ifrcutp, hu, spirint, spiratx, spiraty, & - u_to_umain, frcu_mor, javeg, jabaptist, cfuhi, epshs, taubxu, epsz0 + u_to_umain, frcu_mor, javeg, jabaptist, cfuhi, taubxu, epsz0 use m_flowtimes, only: julrefdat, dts, time1 use unstruc_files, only: mdia use unstruc_channel_flow, only: t_branch, t_node, nt_LinkNode diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 index a2234d5c7e9..4d7f454247f 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 @@ -683,7 +683,7 @@ end subroutine set_floodfill_water_levels_based_on_sample_file !> Insert friction coefficient by initial fields subroutine set_friction_coefficient_by_initial_fields() - use m_flowgeom, only: lnx, lnx1D, kcu, xz, yz, kcs + use m_flowgeom, only: lnx, lnx1D, kcu use m_flow, only: frcu, ifrcutp, dynveg, frcu0 use m_physcoef, only: frcuni1d, frcuni1d2d, frcunistreetinlet, frcuniroofgutterpipe, frcuni, frcumin, frcmax, ifrctypuni, dynroughveg use m_missing, only: dmiss, imiss @@ -1395,7 +1395,7 @@ subroutine set_wave_modelling() if (jawave == CONST .and. .not. flow_without_waves) then hs = max(hs, 0.0_dp) - hwav = min(hwavcom, gammax * hs) + hwav = min(hwavuni, gammax * hs) call wave_uorbrlabda() if (kmx == 0) then if (jawavestokes > NO_STOKES_DRIFT) then From e0b6bd38fd939ab96425d7a96450a822533a974b Mon Sep 17 00:00:00 2001 From: hrajagers Date: Wed, 25 Mar 2026 21:35:52 +0100 Subject: [PATCH 12/18] push review comment updates --- .../src/dflowfm_data/m_physcoef.f90 | 4 +- .../src/dflowfm_data/m_sediment.f90 | 2 +- .../src/dflowfm_data/m_waves.f90 | 1 - .../src/dflowfm_data/unstruc_model.f90 | 20 ++-- .../src/dflowfm_io/unstruc_netcdf.f90 | 4 +- .../dflowfm_kernel/compute/getustbcfuhi.f90 | 2 +- .../dflowfm_kernel/compute/getvanrijnwci.f90 | 2 +- .../dflowfm_kernel/compute/set_kbot_ktop.f90 | 2 +- .../compute/update_verticalprofiles.f90 | 20 ++-- .../compute_wave_forcing_rhs.f90 | 2 +- .../dflowfm_kernel/compute_waves/setwavfu.f90 | 6 +- .../compute_waves/surfbeat/xbeachwaves.f90 | 7 +- .../wave_comp_stokes_velocities.f90 | 2 +- .../dflowfm_kernel/prepost/flow_flowinit.f90 | 107 ++++++++++-------- .../timespace/fm_external_forcings_init.f90 | 4 +- .../packages/morphology_kernel/src/trab19.f90 | 13 +-- 16 files changed, 106 insertions(+), 92 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 index 4c24cf529ac..20c376777db 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 @@ -53,8 +53,8 @@ module m_physcoef real(kind=dp) :: frcmax !< max friction coeff in frcu integer :: dynroughveg !< 0=off, 1=on, effect erosion/sedimentation on Manning roughness representative of dune vegetation in storm models, only for 2D friction real(kind=dp) :: frcumin !< base (Manning) friction (without vegetation) in vegetation polygon area, default 0.023 [s/m^(1/3)] - real(kind=dp) :: droot !< root depth for dynamic roughness vegetation, default 0.5m - real(kind=dp) :: dstem !< stem height for dynamic roughness vegetation, default 0.5m + real(kind=dp) :: droot !< root depth for dynamic roughness vegetation, range 0-100m, default 0.5m + real(kind=dp) :: dstem !< stem height for dynamic roughness vegetation, range 0-100m, default 0.5m integer :: ifrctypuni !< 0=chezy, 1=manning, 2=white colebrook D3D, 3=white colebrook Waqua (now only 2D) real(kind=dp) :: frcunilin !< uniform friction coeff diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 index 034c3e064f9..c52d7b9fe06 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 @@ -108,7 +108,7 @@ module m_sediment integer :: jamormergedtuser real(kind=dp) :: upperlimitssc integer :: inmorphopol !< value of the update inside morphopol (only 0 or 1 make sense) - real(kind=dp) :: difparam !< scale diffusion below reference level with settling velocity, Default 10.0 + real(kind=dp) :: difparam !< switch (not applied when <= 0) and scale factor between the sediment diffusion and settling velocity (below the reference height), default 10 real(kind=dp) :: seddif_cal !< scale seddif ! !-------------------------------------------------- old sediment transport and morphology diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 index 0fd4b5b5312..62e53af7e75 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 @@ -97,7 +97,6 @@ module m_waves ! parameters, may be overwritten by user in mdu-file real(kind=dp) :: gammax !< Maximum wave height/water depth ratio - real(kind=dp) :: alfdeltau = 20.0_dp !< coeff for thickness of wave bed boundary layer real(kind=dp) :: hminlw !< [m] minimum depth for wave forcing in flow momentum equation RHS. integer :: jatpwav = TPWAVDEFAULT !< TPWAV, TPWAVSMOOTH, TPWAVRELATIVE integer :: jauorb !< multiply with factor sqrt(pi)/2 (=0), or not (=1). Default 0, delft3d style diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 index d6b21bad22d..bf32a009d01 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 @@ -1358,15 +1358,15 @@ subroutine readMDUFile(filename, istat) end if ! Additions for dynamic roughness for storm impacts with morphology - call prop_get(md_ptr, 'physics', 'DynRoughVeg', dynroughveg) + call prop_get(md_ptr, 'physics', 'dynRoughVeg', dynroughveg) if (dynroughveg > 0 .and. ifrctypuni /= 1) then call mess(LEVEL_WARN, 'Dynamic vegetation roughness only implemented for Manning roughness. Switched off.') dynroughveg = 0 else - call prop_get(md_ptr, 'physics', 'droot', droot) ! default 0.5 [0-100] - call prop_get(md_ptr, 'physics', 'dstem', dstem) ! default 0.5 [0-100] - call prop_get(md_ptr, 'physics', 'nmanmin', frcumin) ! default 0.023 - call prop_get(md_ptr, 'physics', 'dynvegpol', md_dynvegpol, success) + call prop_get(md_ptr, 'physics', 'dRoot', droot) + call prop_get(md_ptr, 'physics', 'dStem', dstem) + call prop_get(md_ptr, 'physics', 'nManMin', frcumin) + call prop_get(md_ptr, 'physics', 'dynVegPol', md_dynvegpol, success) end if call prop_get(md_ptr, 'physics', 'Umodlin', umodlin) @@ -3421,11 +3421,11 @@ subroutine writeMDUFilepointer(mout, writeall, istat) if (writeall) then call prop_set(prop_ptr, 'physics', 'Umodlin', umodlin, 'Linear friction umod, for friction_type=4,5,6') end if - call prop_set(prop_ptr, 'physics', 'DynRoughVeg', dynroughveg, 'Switch for dynamic vegetation roughness. Default 0.') - call prop_set(prop_ptr, 'physics', 'droot', droot, 'Root depth. Default 0.5m') ! default 0.5 [0-100] - call prop_set(prop_ptr, 'physics', 'dstem', dstem, 'Stem height. Default 0.5m') ! default 0.5 [0-100] - call prop_set(prop_ptr, 'physics', 'nmanmin', frcumin, 'Base friction Manning value. Default 0.023') ! default 0.023 - call prop_set(prop_ptr, 'physics', 'dynvegpol', md_dynvegpol, 'Area to apply dynamic vegetation roughness. If empty, no roughness update.') + call prop_set(prop_ptr, 'physics', 'dynRoughVeg', dynroughveg, 'Switch for dynamic vegetation roughness. Default 0.') + call prop_set(prop_ptr, 'physics', 'dRoot', droot, 'Root depth (m)') + call prop_set(prop_ptr, 'physics', 'dStem', dstem, 'Stem height (m)') + call prop_set(prop_ptr, 'physics', 'nMaxMin', frcumin, 'Base Manning friction value (s/m^{1/3})') + call prop_set(prop_ptr, 'physics', 'dynVegPol', md_dynvegpol, 'Area to apply dynamic vegetation roughness. If empty, no roughness update.') call prop_set(prop_ptr, 'physics', 'Vicouv', vicouv, 'Uniform horizontal eddy viscosity (m2/s)') call prop_set(prop_ptr, 'physics', 'Dicouv', dicouv, 'Uniform horizontal eddy diffusivity (m2/s)') diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 index 3d2ea8ccb74..54fa104749c 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 @@ -6282,7 +6282,7 @@ subroutine unc_write_map_filepointer_ugrid(mapids, tim, jabndnd) ! wrimap end if end if if (jamapwav_twav > 0 .and. allocated(twav)) then - ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'twav', 'sea_surface_wave_period_at_variance_spectral_density_maximum', 'Peak wave period', 's') + ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'twav', '', 'Peak wave period', 's') end if if (jamapwav_phiwav > 0 .and. allocated(phiwav)) then ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_thetamean, nc_precision, UNC_LOC_S, 'thetamean', 'sea_surface_wave_from_direction', 'Wave from direction', 'degree') @@ -6296,7 +6296,7 @@ subroutine unc_write_map_filepointer_ugrid(mapids, tim, jabndnd) ! wrimap ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_hwav, nc_precision, UNC_LOC_S, 'hwav', 'sea_surface_wave_significant_height', 'Significant wave height', 'm', jabndnd=jabndnd_) end if ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_thetamean, nc_precision, UNC_LOC_S, 'thetamean', 'sea_surface_wave_from_direction', 'Wave from direction', 'degree', jabndnd=jabndnd_) - ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'twav', 'sea_surface_wave_period_at_variance_spectral_density_maximum', 'Wave peak period', 's') ! we assume working with the peak period in all our formulations + ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'twav', '', 'Peak wave period', 's') ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_uorb, nc_precision, UNC_LOC_S, 'uorb', 'sea_surface_wave_orbital_velocity', 'Wave orbital velocity', 'm s-1', jabndnd=jabndnd_) ! not CF ! if (jawavestokes > NO_STOKES_DRIFT) then diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 index 827c6078043..aa9cd9e60f4 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 @@ -245,7 +245,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte if (stm_included) wblt(LL) = deltau ! ! Streaming below strlyrfac*deltau with linear distribution, see van Rijn 2011 p9.177 - if (jawavestreaming > WAVE_STREAMING_OFF .and. deltau > 1.0e-4_dp) then ! weakly turbulent flume cases ~1mm-1cm, real turbulent cases 5-50cm + if (jawavestreaming /= WAVE_STREAMING_OFF .and. deltau > 1.0e-4_dp) then ! weakly turbulent flume cases ~1mm-1cm, real turbulent cases 5-50cm slfacdeltau = strlyrfac * deltau Dfu0 = Dfuc ! (m/s2) do L = Lb, Ltop(LL) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 index bb3a9ac035d..68af2b34dd6 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 @@ -39,7 +39,7 @@ module m_getvanrijnwci subroutine getvanrijnwci(LL, umod, u2dh, taubpuLL, z0urouL) use precision, only: dp use m_flow, only: hu, epshu, epsz0, lbot, u1, jaconveyance2d, v, ag - use m_bedform, only: bfmpar, fp + use m_bedform, only: bfmpar use m_flowgeom, only: ln, acl, csu, snu, lnx1d use m_waves, only: uorb, hwav, twav, rlabda, phiwav, ustokes, vstokes diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 index 08ee4b6b72f..f3cf13c4efc 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 @@ -326,7 +326,7 @@ subroutine update_vertical_coordinates_boundary() ktop(n) = kb - 1 + kmxn(n) end do return ! Early exit - no link updates needed for sigma layers, volumes already calculated - ! JRE todo: z lyr morpho + else if (Layertype == LAYTP_Z) then ! z or z-sigma do i_bnd = 1, nbndz n = kbndz(1, i_bnd) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 index faef709ec80..cc833313729 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 @@ -113,7 +113,7 @@ subroutine update_verticalprofiles() call getustbcfuhi(LL, Lb, ustb(LL), cfuhi(LL), hdzb, z00, cfuhi3D) !Constant advi(Lb) = advi(Lb) + cfuhi3D ! - if (jawave > NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_DEPTHUNIFORM .and. .not. flow_without_waves) then ! Ustokes correction at bed + if (jawave /= NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_DEPTHUNIFORM .and. .not. flow_without_waves) then ! Ustokes correction at bed adve(Lb) = adve(Lb) - cfuhi3D * ustokes(Lb) end if @@ -168,7 +168,7 @@ subroutine update_verticalprofiles() call getustbcfuhi(LL, Lb, ustb(LL), cfuhi(LL), hdzb, z00, cfuhi3D) ! algebraic advi(Lb) = advi(Lb) + cfuhi3D ! - if (jawave > NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_DEPTHUNIFORM .and. .not. flow_without_waves) then ! Ustokes correction at bed + if (jawave /= NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_DEPTHUNIFORM .and. .not. flow_without_waves) then ! Ustokes correction at bed adve(Lb) = adve(Lb) - cfuhi3D * ustokes(Lb) end if @@ -318,12 +318,12 @@ subroutine update_verticalprofiles() vicu = viskin + 0.5_dp * (vicwwu(Lb0) + vicwwu(Lb)) * sigtkei ! Calculate turkin source from wave dissipation: preparation - if (jawave > NO_WAVES) then + if (jawave /= NO_WAVES) then if (jawaveStokes > NO_STOKES_DRIFT .and. .not. flow_without_waves) then ! Ustokes correction at bed adve(Lb) = adve(Lb) - cfuhi3D * ustokes(Lb) end if - if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then + if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then k1 = ln(1, LL) k2 = ln(2, LL) ac1 = acl(LL) @@ -419,7 +419,7 @@ subroutine update_verticalprofiles() ! Addition of production and of dissipation to matrix ; ! observe implicit treatment by Newton linearization. - if (jawave > NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_2NDORDER_VISC .and. .not. flow_without_waves) then ! vertical shear based on eulerian velocity field, see turclo,note JvK, Ardhuin 2006 + if (jawave /= NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_2NDORDER_VISC .and. .not. flow_without_waves) then ! vertical shear based on eulerian velocity field, see turclo,note JvK, Ardhuin 2006 dijdij(k) = ((u1(Lu) - ustokes(Lu) - u1(L) + ustokes(L))**2 + (v(Lu) - vstokes(Lu) - v(L) + vstokes(L))**2) / dzw(k)**2 else dijdij(k) = ((u1(Lu) - u1(L))**2 + (v(Lu) - v(L))**2) / dzw(k)**2 @@ -446,7 +446,7 @@ subroutine update_verticalprofiles() end do ! Lb, Lt-1 - if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then + if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then ! check if first layer is thicker than fwavpendep*wave height ! Then use JvK solution if (hu(LL) - hu(Lt - 1) >= fwavpendep * hrmsLL) then @@ -675,7 +675,7 @@ subroutine update_verticalprofiles() sourtu = c1e * cmukep * turkin0(L) * dijdij(k) ! ! Add wave dissipation production term - if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then + if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then sourtu = sourtu + pkwav(k) * c1e * tureps0(L) / max(turkin0(L), 1.0e-7_dp) end if @@ -728,7 +728,7 @@ subroutine update_verticalprofiles() bk(kxL) = 1.0_dp ck(kxL) = 0.0_dp dk(kxL) = 4.0_dp * abs(ustw(LL))**3 / (vonkar * dzu(Lt - Lb + 1)) - if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then ! wave dissipation at surface, neumann bc, dissipation over fwavpendep*Hrms + if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then ! wave dissipation at surface, neumann bc, dissipation over fwavpendep*Hrms dk(kxL) = dk(kxL) + dzu(Lt - Lb + 1) * pkwmag / (fwavpendep * hrmsLL) end if @@ -840,7 +840,7 @@ subroutine update_verticalprofiles() end do epsbot = tureps1(Lb) + dzu(1) * abs(ustb(LL))**3 / (vonkar * hdzb * hdzb) epssur = tureps1(Lt - 1) - 4.0_dp * abs(ustw(LL))**3 / (vonkar * dzu(Lt - Lb + 1)) - if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then + if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then epssur = epssur - dzu(Lt - Lb + 1) * pkwmag / (hrmsLL * fwavpendep) end if epsbot = max(epsbot, eps_min) @@ -867,7 +867,7 @@ subroutine update_verticalprofiles() vicwwu(Lb0:Lt) = min(vicwmax, cmukep * turkin1(Lb0:Lt) * tureps1(Lb0:Lt)) end if - if (jawave == NO_WAVES .or. (jawave > NO_WAVES .and. jawavebreakerturbulence == WAVE_BREAKER_TURB_OFF)) then + if (jawave == NO_WAVES .or. jawavebreakerturbulence == WAVE_BREAKER_TURB_OFF) then vicwwu(Lt) = min(vicwwu(Lt), vicwwu(Lt - 1) * Eddyviscositysurfacmax) end if vicwwu(Lb0) = min(vicwwu(Lb0), vicwwu(Lb) * Eddyviscositybedfacmax) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 index 4b525ad32ed..e97b24836e2 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 @@ -104,7 +104,7 @@ subroutine compute_wave_forcing_RHS() call tauwave() end if ! - call xbeach_flow_bc() ! JRE todo: make MPI compatible + call xbeach_flow_bc() end if ! ! Uniform wave field diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 index 98a046c0a94..a8d273f3c76 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 @@ -172,10 +172,8 @@ subroutine setwavfu() end do end if ! - if (fforc > 0.0_dp) then - wavfu = fforc * wavfu - wavfv = fforc * wavfv - end if + wavfu = fforc * wavfu + wavfv = fforc * wavfv 1234 continue return end subroutine setwavfu diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 index 122b90e7ff6..d59ca13c157 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 @@ -4897,7 +4897,7 @@ subroutine solve_roller_balance(x, y, mn, prev, hh, c, Dw, thetam, beta, ag, max integer, dimension(:, :), allocatable :: indx integer :: niter integer :: sweep, k, iter, count, k1, k2, ierr - real(dp) :: Afac, Bfac, Cfac, Drst, percok + real(dp) :: Afac, Bfac, Cfac, cfac_lim, Drst, percok real(dp) :: x1, x2, xk, y1, y2, yk real(dp) :: costh1, costh2, costhk, sinth1, sinth2, sinthk real(dp) :: dtol @@ -4966,9 +4966,10 @@ subroutine solve_roller_balance(x, y, mn, prev, hh, c, Dw, thetam, beta, ag, max costhk = cos(thetam(k)) sinthk = sin(thetam(k)) Cfac = x1 * (y2 - yk) + x2 * (yk - y1) + xk * (y1 - y2) + cfac_lim = sign(max(abs(Cfac), dtol), Cfac) Afac = (F(k1) * costh1 * (y2 - yk) + F(k2) * costh2 * (yk - y1) & - - F(k1) * sinth1 * (x2 - xk) - F(k2) * sinth2 * (xk - x1)) / sign(max(abs(Cfac), dtol), Cfac) - Bfac = (costhk * (y1 - y2) - sinthk * (x1 - x2)) / sign(max(abs(Cfac), dtol), Cfac) + - F(k1) * sinth1 * (x2 - xk) - F(k2) * sinth2 * (xk - x1)) / cfac_lim + Bfac = (costhk * (y1 - y2) - sinthk * (x1 - x2)) / cfac_lim Drst = 2.0_dp * ag * beta / c(k)**2 F(k) = (Dw(k) - Afac) / (Bfac + Drst) Er(k) = F(k) / c(k) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/wave_comp_stokes_velocities.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/wave_comp_stokes_velocities.f90 index 009b1e1bf62..53b084b3c1b 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/wave_comp_stokes_velocities.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/wave_comp_stokes_velocities.f90 @@ -78,7 +78,7 @@ subroutine wave_comp_stokes_velocities() deltahmin = 0.1_dp ! should be a parameter ! do k = 1, ndx - massflux_max = 0.125_dp * sag * (hs(k)**1.5) * (gammax**2) + massflux_max = (1.0_dp / 8.0_dp) * sag * (hs(k)**1.5) * (gammax**2) mnorm = min(sqrt(mxwav(k)**2 + mywav(k)**2), massflux_max) mangle = atan2(mywav(k), mxwav(k)) mx(k) = mnorm * cos(mangle) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 index 4d7f454247f..0b82e635165 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 @@ -684,28 +684,15 @@ end subroutine set_floodfill_water_levels_based_on_sample_file !> Insert friction coefficient by initial fields subroutine set_friction_coefficient_by_initial_fields() use m_flowgeom, only: lnx, lnx1D, kcu - use m_flow, only: frcu, ifrcutp, dynveg, frcu0 - use m_physcoef, only: frcuni1d, frcuni1d2d, frcunistreetinlet, frcuniroofgutterpipe, frcuni, frcumin, frcmax, ifrctypuni, dynroughveg + use m_flow, only: frcu, ifrcutp + use m_physcoef, only: frcuni1d, frcuni1d2d, frcunistreetinlet, frcuniroofgutterpipe, frcuni, frcmax, ifrctypuni use m_missing, only: dmiss, imiss - use m_alloc - use unstruc_model, only: md_dynvegpol - use timespace_parameters, only: LOCTP_POLYGON_FILE - use timespace, only: selectelset_internal_links - use m_delpol - use MessageHandling implicit none integer, parameter :: MANNING = 1 integer :: link - integer :: ierr - integer :: k - integer :: pointscount - logical :: ex - - integer, dimension(:), allocatable :: kp - integer, dimension(:), allocatable :: kcsveg do link = 1, lnx if (frcu(link) == dmiss) then @@ -734,39 +721,69 @@ subroutine set_friction_coefficient_by_initial_fields() frcmax = frcu(link) end if end do + + call init_dynamic_vegetation_roughness() + + end subroutine set_friction_coefficient_by_initial_fields + +!> initialize dynamic vegetation roughness + subroutine init_dynamic_vegetation_roughness + use m_flowgeom, only: lnx + use m_flow, only: frcu, frcu0, dynveg + use m_physcoef, only: frcumin, dynroughveg + use m_alloc + use unstruc_model, only: md_dynvegpol + use timespace_parameters, only: LOCTP_POLYGON_FILE + use timespace, only: selectelset_internal_links + use m_delpol + use MessageHandling + + implicit none + + integer, parameter :: MANNING = 1 + + integer :: link + integer :: ierr + integer :: k + integer :: pointscount + logical :: ex + + integer, dimension(:), allocatable :: kp + integer, dimension(:), allocatable :: kcsveg + + if (.not. dynroughveg) then + return + end if + + inquire (file=trim(md_dynvegpol), exist=ex) + if (.not. ex) then + call mess(LEVEL_WARN, 'No polygon found for dynamic vegetation update. Process switched off.') + dynroughveg = 0 + return + end if + + frcu0 = frcu + call realloc(kcsveg, lnx, stat=ierr, fill=0, keepExisting=.false.) + if (allocated(kp)) deallocate (kp) + allocate (kp(1:lnx)) + kp = 0 + ! find links inside polygon + call selectelset_internal_links(lnx, kp, pointscount, LOC_SPEC_TYPE=LOCTP_POLYGON_FILE, LOC_FILE=md_dynvegpol) + + do k = 1, pointscount + kcsveg(kp(k)) = 1 + end do + call delpol() ! - if (dynroughveg > 0) then - ! - inquire (file=trim(md_dynvegpol), exist=ex) - if (ex) then - frcu0 = frcu - call realloc(kcsveg, lnx, stat=ierr, fill=0, keepExisting=.false.) - if (allocated(kp)) deallocate (kp) - allocate (kp(1:lnx)) - kp = 0 - ! find cells inside polygon - call selectelset_internal_links(lnx, kp, pointscount, LOC_SPEC_TYPE=LOCTP_POLYGON_FILE, LOC_FILE=md_dynvegpol) - - do k = 1, pointscount - kcsveg(kp(k)) = 1 - end do - call delpol() - ! - do link = 1, lnx - if (frcu(link) > frcumin .and. kcsveg(link) > 0) then - dynveg(link) = .true. - else - dynveg(link) = .false. - end if - end do + do link = 1, lnx + if (frcu(link) > frcumin .and. kcsveg(link) > 0) then + dynveg(link) = .true. else - call mess(LEVEL_WARN, 'No polygon found for dynamic vegetation update. Process switched off.') - dynroughveg = 0 + dynveg(link) = .false. end if - ! - end if - - end subroutine set_friction_coefficient_by_initial_fields + end do + + end subroutine init_dynamic_vegetation_roughness !> set friction uniform value on links where_friction_is_not_set subroutine set_friction_uniform_value_on_links_where_friction_is_not_set() diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 index d2f32d39fec..6d8cd232b67 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 @@ -817,7 +817,7 @@ function init_meteo_forcings(block_ptr, base_dir, file_name, group_name) result( case ('qext') ! Only time-independent sample file supported for now: sets Qext initially and this remains constant in time. if (jaQext == 0) then - write (msgbuf, '(7a)') 'quantity '''//trim(quantity)//' in file ''', file_name, ''': [', group_name, & + write (msgbuf, '(5a)') 'quantity '''//trim(quantity)//' in file ''', file_name, ''': [', group_name, & '] is missing QExt=1 in MDU.' call err_flush() return @@ -847,7 +847,7 @@ function init_meteo_forcings(block_ptr, base_dir, file_name, group_name) result( res = timespaceinitialfield(xz, yz, qext, ndx, forcing_file, filetype, method, oper, transformcoef, UNC_LOC_S, mask) return ! This was a special case, don't continue with timespace processing below. case default - write (msgbuf, '(7a)') 'Unknown quantity '''//trim(quantity)//' in file '''//file_name//''': ['//group_name// & + write (msgbuf, '(a)') 'Unknown quantity '''//trim(quantity)//' in file '''//file_name//''': ['//group_name// & '].' call err_flush() return diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 index 7ef59256a5a..9b77d88f699 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 @@ -144,7 +144,6 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h ! ! limit input parameters to sensible values ! - facua = max(min(facua,1.0_fp),0.0_fp) facas = max(min(facas,1.0_fp),0.0_fp) facsk = max(min(facsk,1.0_fp),0.0_fp) if (.not. (waveform==1 .or. waveform==2)) waveform=2 ! van Thiel default @@ -199,18 +198,18 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h term1=min(term1,smax*ag/max(cf,1e-10_fp)*d50*delta) term1=sqrt(term1) ! - ceqb = 0.0_fp !initialize ceqb - ceqs = 0.0_fp !initialize ceqs - ! if(term1>Ucrb .and. h>dtol) then - ceqb=Asb*(term1-Ucrb)**1.5_fp + ceqb = Asb*(term1-Ucrb)**1.5_fp + else + ceqb = 0.0_fp end if if(term1>Ucrs .and. h>dtol) then - ceqs=Ass*(term1-Ucrs)**2.4_fp + ceqs = Ass*(term1-Ucrs)**2.4_fp + else + ceqs = 0.0_fp end if ! if (alfad50 > 0.0_fp) then - !uamag = uamag * (0.000225_fp/d50)**alfad50 ! hoe kan een snelheidsasymmetrie fie zijn van korrelgrootte? ceqb = ceqb * (0.000225_fp/d50)**alfad50 ceqs = ceqs * (0.000225_fp/d50)**alfad50 endif From 36be2996cb566ae0b9a881fb62136a8425329cfd Mon Sep 17 00:00:00 2001 From: reyns Date: Thu, 26 Mar 2026 14:05:44 +0100 Subject: [PATCH 13/18] UNST-9434 Apply changes trab19 to trab20 --- .../morphology/packages/morphology_kernel/src/trab20.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 index 269763e7540..97fd45793c0 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 @@ -142,7 +142,6 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h ! ! limit input parameters to sensible values ! - facua = max(min(facua,1.0_fp),0.0_fp) facas = max(min(facas,1.0_fp),0.0_fp) facsk = max(min(facsk,1.0_fp),0.0_fp) if (.not. (waveform==1 .or. waveform==2)) waveform=2 ! van Thiel default @@ -200,7 +199,6 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h end if ! if (alfad50 > 0.0_fp) then - !uamag = uamag * (0.000225_fp/d50)**alfad50 ! hoe kan een snelheidsasymmetrie fie zijn van korrelgrootte? ceqb = ceqb * (0.000225_fp/d50)**alfad50 ceqs = ceqs * (0.000225_fp/d50)**alfad50 endif From 66c1ccfa9c93bade7f7785f1e0dcb82304214188 Mon Sep 17 00:00:00 2001 From: reyns Date: Thu, 26 Mar 2026 15:10:50 +0100 Subject: [PATCH 14/18] UNST-9434 fix build --- .../dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 | 5 +++-- .../dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 | 10 ++++------ .../src/dflowfm_kernel/compute_waves/setwavfu.f90 | 2 +- 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 index 3a0ae2c7b2e..fb1de4fd147 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 @@ -1720,9 +1720,10 @@ subroutine readMDUFile(filename, istat) call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: fbreak<0.0, reset to 0.0. Wave breaking contribution to tke switched off.') fbreak = 0.0_dp end if - if (fforc < 0.0_dp) then - call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: fforc<0.0, reset to 0.0. Wave forces switched off.') + if (fforc <= 0.0_dp) then + call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: fforc<=0.0, reset to 0.0. Wave forces switched off.') fforc = 0.0_dp + jawaveforces = WAVE_FORCES_OFF end if if (jawave <= WAVE_FETCH_YOUNG) then diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 index 8e9594b8513..cef26a71d9d 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 @@ -118,21 +118,18 @@ subroutine fm_bott3d() real(kind=dp) :: sbtot(ndx,stmpar%lsedtot) real(fp), dimension(:), pointer :: dunelength real(fp), dimension(1:0), target :: empty_dunelength - logical, pointer :: cmpupd !! !! Point !! - associate (& - cmpupd => stmpar%morpar%cmpupd & - ) + associate ( cmpupd => stmpar%morpar%cmpupd ) if (associated(bfmpar%dunelength)) then dunelength => bfmpar%dunelength else dunelength => empty_dunelength - end if cmpupd => stmpar%morpar%cmpupd + end if !! !! Execute @@ -314,7 +311,8 @@ subroutine fm_bott3d() ! call timstop(handle_extra(89)) - end associate + ! + end associate end subroutine fm_bott3d !< Calculate suspended sediment transport correction vector (for SAND) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 index a8d273f3c76..47915e96241 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 @@ -62,7 +62,7 @@ subroutine setwavfu() integer :: k1, k2 - if (jawaveforces == WAVE_FORCES_OFF .or. comparereal(fforc, 0.0_dp) == 0) then + if (jawaveforces == WAVE_FORCES_OFF) then wavfu = 0.0_dp wavfv = 0.0_dp return From 7e1d761e30e1e1ee2777389be567ea26bba71e24 Mon Sep 17 00:00:00 2001 From: hrajagers Date: Wed, 15 Apr 2026 20:56:00 +0200 Subject: [PATCH 15/18] Fix merge error: subroutine determine_linkbased_cumblchg() was lost --- .../compute_sediment/m_fm_bott3d.f90 | 22 ++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 index ed092141dbc..298fcfd6ddf 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 @@ -2097,6 +2097,26 @@ subroutine fm_diffusion_active_layer() end subroutine fm_diffusion_active_layer + subroutine determine_linkbased_cumblchg() + use m_sediment, only: cumes + use m_fm_erosed, only: blchg + use m_flowgeom, only: lnx, ln, acl + + implicit none + + integer :: L, k1, k2 + real(kind=dp) :: ac1, ac2 + + do L = 1, lnx + k1 = ln(1, L) + k2 = ln(2, L) + ac1 = acl(L) + ac2 = 1.0_dp - ac1 + cumes(L) = cumes(L) + ac1 * (blchg(k1)) + ac2 * (blchg(k2)) + end do + + end subroutine determine_linkbased_cumblchg + !> Apply the nodal point relation by Bolla and Pittaluga et al. (2003) to compute the sediment transport !rate at the node of a bifurcation. The relation is applied at the junction flownode of a bifurcation, !which has one incoming and two outgoing branches. The sediment transport rate at the node is computed @@ -2198,7 +2218,7 @@ subroutine nodal_point_relation_BollaPittaluga(& Q_sb=Q_sa+Q_sy !Equation (16) (implicit in Bolla-Pittaluga et al. (2003)). sq_sb=Q_sb/B_b !make per unit width. - end subroutine + end subroutine nodal_point_relation_BollaPittaluga subroutine nodal_point_relation_data( & total_water_discharge_out, total_width_out, total_sediment_transport_out,idx_junctions,n_junctions,n_links_out,links_out,link_dir_out,width_out,water_discharge_out,flownode_junction,n_links_in,links_in,& From 702fda86df29738e11dc58235cd5d18e879bf4a5 Mon Sep 17 00:00:00 2001 From: hrajagers Date: Thu, 16 Apr 2026 15:03:28 +0200 Subject: [PATCH 16/18] temporarily undo all changes outside src/utils_gpl/morphology --- .../src/dflowfm_data/m_flow.f90 | 2 - .../src/dflowfm_data/m_physcoef.f90 | 8 - .../src/dflowfm_data/m_sediment.f90 | 6 - .../src/dflowfm_data/m_waves.f90 | 11 +- .../src/dflowfm_data/unstruc_model.f90 | 30 --- .../dflowfm_kernel/src/dflowfm_gui/zlin.f90 | 2 +- .../src/dflowfm_io/unstruc_netcdf.f90 | 4 +- .../dflowfm_kernel/compute/compute_dynveg.f90 | 62 ------ .../compute/flow_initimestep.f90 | 7 - .../src/dflowfm_kernel/compute/furu.f90 | 5 +- .../dflowfm_kernel/compute/getustbcfuhi.f90 | 91 ++++----- .../src/dflowfm_kernel/compute/getustwav.f90 | 53 +++-- .../dflowfm_kernel/compute/getvanrijnwci.f90 | 4 +- .../dflowfm_kernel/compute/set_kbot_ktop.f90 | 2 +- .../compute/update_verticalprofiles.f90 | 24 ++- .../compute_sediment/apply_sediment_bc.f90 | 2 +- .../compute_sediment/bermslopenudging.f90 | 43 ++-- .../compute_sediment/duneaval.f90 | 10 +- .../compute_sediment/fm_erosed.f90 | 29 ++- .../compute_sediment/fm_fallve.f90 | 3 +- .../compute_sediment/m_fm_bott3d.f90 | 144 ++++++-------- .../compute_wave_forcing_rhs.f90 | 3 +- .../dflowfm_kernel/compute_waves/setwavfu.f90 | 37 +++- .../surfbeat/xbeach_math_tools.F90 | 8 - .../compute_waves/surfbeat/xbeachwaves.f90 | 183 +++++++++--------- .../wave_comp_stokes_velocities.f90 | 2 +- .../dflowfm_kernel/prepost/flow_allocflow.f90 | 9 +- .../dflowfm_kernel/prepost/flow_flowinit.f90 | 65 +------ .../prepost/flow_sedmorinit.f90 | 13 +- .../src/dflowfm_kernel/prepost/setbobs.f90 | 25 +-- .../timespace/fm_external_forcings_init.f90 | 4 +- .../src/dflowfm_kernel/timespace/meteo1.f90 | 4 +- src/third_party_open/swan/src/swancom1.F | 3 +- 33 files changed, 353 insertions(+), 545 deletions(-) delete mode 100644 src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 index 0cbfc52a68c..18044513a8f 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_flow.f90 @@ -329,8 +329,6 @@ module m_flow ! flow arrays-999 real(kind=dp), allocatable, target :: cftrtfac(:) !< array for optional multiplication factor for trachytopes's returned roughness values integer :: jacftrtfac !< Whether or not (1/0) a multiplication factor field was specified for trachytopes's Chezy roughness values. real(kind=dp), allocatable :: czu(:) !< array for chezy friction at flow links {"location": "edge", "shape": ["lnx"]} - real(kind=dp), allocatable :: frcu0(:) !< array for Manning friction at flow links at start of the run {"location": "edge", "shape": ["lnx"]} - logical, allocatable :: dynveg(:) !< vegetation present or not {"location": "edge", "shape": ["lnx"]} real(kind=dp), allocatable, target :: frculin(:) !< friction coefficient set by initial fields ( todo mag later ook single real worden) integer, allocatable :: ifrcutp(:) !< friction coefficient type initial fields ( todo mag later ook single real worden) real(kind=dp), allocatable, target :: Cdwusp(:) !< Wind friction coefficient at u point set by initial fields ( todo mag later ook single real worden) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 index 87275b6c174..1e813eb7096 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_physcoef.f90 @@ -51,10 +51,6 @@ module m_physcoef real(kind=dp), parameter :: frcuniroof = 0.030_dp real(kind=dp) :: frcuni1Dgrounlay !< uniform friction coeff groundlayer real(kind=dp) :: frcmax !< max friction coeff in frcu - integer :: dynroughveg !< 0=off, 1=on, effect erosion/sedimentation on Manning roughness representative of dune vegetation in storm models, only for 2D friction - real(kind=dp) :: frcumin !< base (Manning) friction (without vegetation) in vegetation polygon area, default 0.023 [s/m^(1/3)] - real(kind=dp) :: droot !< root depth for dynamic roughness vegetation, range 0-100m, default 0.5m - real(kind=dp) :: dstem !< stem height for dynamic roughness vegetation, range 0-100m, default 0.5m integer :: ifrctypuni !< 0=chezy, 1=manning, 2=white colebrook D3D, 3=white colebrook Waqua (now only 2D) real(kind=dp) :: frcunilin !< uniform friction coeff @@ -177,10 +173,6 @@ subroutine default_physcoef() locsaltmin = 5.0_dp locsaltmax = 10.0_dp NFEntrainmentMomentum = 0 - dynroughveg = 0 - droot = 0.5_dp - dstem = 0.5_dp - frcumin = 2.3e-2_dp end subroutine default_physcoef !> Calculates derived coefficients. diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 index c52d7b9fe06..bb7fcac3f1a 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_sediment.f90 @@ -91,8 +91,6 @@ module m_sediment logical, allocatable :: bermslopeindexsus(:) !< index where nudging needs to be applied for suspended load real(kind=dp), allocatable :: bermslopecontrib(:, :) !< bermslope nudging sediment transport real(kind=dp), allocatable :: ssccum(:, :) !< water column integrated sediment transport in dry points (kg/s) - real(kind=dp), allocatable :: cumes(:) !< cumulative erosion/sedimentation in link positions - integer :: jased !< Include sediment, 1=Krone, 2=Soulsby van Rijn 2007, 4=Delft3D morphology module integer :: jaseddenscoupling = 0 !< Include sediment in rho 1 = yes , 0 = no integer :: jasubstancedensitycoupling = 0 !< Include Delwaq substances in rho 1 = yes , 0 = no @@ -108,8 +106,6 @@ module m_sediment integer :: jamormergedtuser real(kind=dp) :: upperlimitssc integer :: inmorphopol !< value of the update inside morphopol (only 0 or 1 make sense) - real(kind=dp) :: difparam !< switch (not applied when <= 0) and scale factor between the sediment diffusion and settling velocity (below the reference height), default 10 - real(kind=dp) :: seddif_cal !< scale seddif ! !-------------------------------------------------- old sediment transport and morphology integer :: mxgrKrone !< mx grainsize index nr that followsKrone. Rest follows v.Rijn @@ -172,8 +168,6 @@ subroutine default_sediment() jamormergedtuser = 0 upperlimitssc = 1.0e6_dp inmorphopol = 1 - difparam = 10.0_dp - seddif_cal = 0.0_dp end subroutine default_sediment diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 index 62e53af7e75..3f879d9d8b6 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/m_waves.f90 @@ -63,10 +63,8 @@ module m_waves real(kind=dp) :: ftauw !< Swartfactor, tune bed shear stress real(kind=dp) :: fwfac !< Soulsby factor, tune streaming - real(kind=dp) :: fbreak !< factor for adjusting wave breaking contribution in tke model - real(kind=dp) :: fforc !< factor for adjusting wave forces in momentum equation, default 1 - real(kind=dp) :: fwavpendep !< layer thickness as proportion of Hrms over which wave breaking adds to TKE source. Default 1.5 - real(kind=dp) :: strlyrfac !< streaming layer thickness is strlyrfac*wave boundary layer thickness. Default 3.0 + real(kind=dp) :: fbreak !< tune breaking in tke model + real(kind=dp) :: fwavpendep !< Layer thickness as proportion of Hrms over which wave breaking adds to TKE source. Default 0.5 character(len=4) :: rouwav !< Friction model for wave induced shear stress @@ -97,13 +95,13 @@ module m_waves ! parameters, may be overwritten by user in mdu-file real(kind=dp) :: gammax !< Maximum wave height/water depth ratio + real(kind=dp) :: alfdeltau = 20.0_dp !< coeff for thickness of wave bed boundary layer real(kind=dp) :: hminlw !< [m] minimum depth for wave forcing in flow momentum equation RHS. integer :: jatpwav = TPWAVDEFAULT !< TPWAV, TPWAVSMOOTH, TPWAVRELATIVE integer :: jauorb !< multiply with factor sqrt(pi)/2 (=0), or not (=1). Default 0, delft3d style integer :: jahissigwav !< 1: sign wave height on his output; 0: hrms wave height on his output. integer :: jamapsigwav !< 1: sign wave height on map output; 0: hrms wave height on map output. integer :: jauorbfromswan !< 1: get uorb from SWAN, compare with Delft3D - integer :: jawavevellogprof !< 1: set depth-averaged velocity from u1 of base layers logical :: extfor_wave_initialized !< is set to .true. when the "external forcing"-part that must be initialized for WAVE during running (instead of during initialization) has actually been initialized contains @@ -124,9 +122,6 @@ subroutine default_waves() fwfac = 1.0_dp fbreak = 1.0_dp fwavpendep = 1.5_dp ! best setting based on sensitivity - jawavevellogprof = 1 - fforc = 1.0_dp - strlyrfac = 3.0_dp call reset_waves() end subroutine default_waves diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 index e366dc5e3f2..3810d2221f0 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_data/unstruc_model.f90 @@ -151,7 +151,6 @@ module unstruc_model character(len=max_prop_length) :: md_bedformfile = ' ' !< File containing bedform settings (e.g., *.bfm) character(len=max_prop_length) :: md_morphopol = ' ' !< File containing boundaries of morphologic change extent (e.g., *.pol) character(len=max_prop_length) :: md_sedtrailsfile = ' ' !< File containing extent of sedtrails output grid - character(len=max_prop_length) :: md_dynvegpol = ' ' !< File containing extent of dynamic vegetation application character(len=max_prop_length) :: md_obsfile = ' ' !< File containing observation points (e.g., *_obs.xyn, *_obs.ini) integer :: md_delete_observation_points_outside_grid !< 0 - do not delete, 1 - delete @@ -327,7 +326,6 @@ subroutine resetModel() md_bedformfile = ' ' md_morphopol = ' ' md_sedtrailsfile = ' ' - md_dynvegpol = ' ' md_obsfile = ' ' md_delete_observation_points_outside_grid = 0 @@ -1366,18 +1364,6 @@ subroutine readMDUFile(filename, istat) jafrculin = 1 end if - ! Additions for dynamic roughness for storm impacts with morphology - call prop_get(md_ptr, 'physics', 'dynRoughVeg', dynroughveg) - if (dynroughveg > 0 .and. ifrctypuni /= 1) then - call mess(LEVEL_WARN, 'Dynamic vegetation roughness only implemented for Manning roughness. Switched off.') - dynroughveg = 0 - else - call prop_get(md_ptr, 'physics', 'dRoot', droot) - call prop_get(md_ptr, 'physics', 'dStem', dstem) - call prop_get(md_ptr, 'physics', 'nManMin', frcumin) - call prop_get(md_ptr, 'physics', 'dynVegPol', md_dynvegpol, success) - end if - call prop_get(md_ptr, 'physics', 'Umodlin', umodlin) call prop_get(md_ptr, 'physics', 'Vicouv', vicouv) call prop_get(md_ptr, 'physics', 'Dicouv', dicouv) @@ -1544,8 +1530,6 @@ subroutine readMDUFile(filename, istat) call prop_get(md_ptr, 'sediment', 'MasBalMinDep', botcrit, success) ! Minimum depth *after* bottom update for SSC adaptation mass balance call prop_get(md_ptr, 'sediment', 'MormergeDtUser', jamormergedtuser, success) ! Mormerge operation at dtuser timesteps (1) or dts (0, default) call prop_get(md_ptr, 'sediment', 'UpperLimitSSC', upperlimitssc, success) ! Upper limit of cell centre SSC concentration after transport timestep. Default 1d6 (effectively switched off) - call prop_get(md_ptr, 'sediment', 'DiffusionScaling', difparam, success) ! Scaling factor to increase diffusion below reference level - call prop_get(md_ptr, 'sediment', 'DiffusionCal', seddif_cal, success) ! Scaling factor to change diffusion for ssc call prop_get(md_ptr, 'sediment', 'Nr_of_sedfractions', Mxgr) MxgrKrone = -1 @@ -1707,9 +1691,6 @@ subroutine readMDUFile(filename, istat) call prop_get(md_ptr, 'waves', 'fwfac', fwfac) ! factor for adjusting wave boundary layer streaming, default 1.0 call prop_get(md_ptr, 'waves', 'ftauw', ftauw) ! factor for adjusting wave related bottom shear stress call prop_get(md_ptr, 'waves', 'fbreak', fbreak) ! factor for adjusting wave breaking contribution to tke - call prop_get(md_ptr, 'waves', 'fforc', fforc) ! factor for adjusting wave forces in momentum equation - call prop_get(md_ptr, 'waves', 'streamlyrfac', strlyrfac) ! factor for adjusting streaming layer thickness in momentum equation - if (ftauw < 0.0_dp) then call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: ftauw<0.0, reset to 0.0. Bed shear stress due to waves switched off.') ftauw = 0.0_dp @@ -1722,11 +1703,6 @@ subroutine readMDUFile(filename, istat) call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: fbreak<0.0, reset to 0.0. Wave breaking contribution to tke switched off.') fbreak = 0.0_dp end if - if (fforc <= 0.0_dp) then - call mess(LEVEL_WARN, 'unstruc_model::readMDUFile: fforc<=0.0, reset to 0.0. Wave forces switched off.') - fforc = 0.0_dp - jawaveforces = WAVE_FORCES_OFF - end if if (jawave <= WAVE_FETCH_YOUNG) then jawaveStokes = NO_STOKES_DRIFT @@ -3396,12 +3372,6 @@ subroutine writeMDUFilepointer(mout, writeall, istat) if (writeall) then call prop_set(prop_ptr, 'physics', 'Umodlin', umodlin, 'Linear friction umod, for friction_type=4,5,6') end if - call prop_set(prop_ptr, 'physics', 'dynRoughVeg', dynroughveg, 'Switch for dynamic vegetation roughness. Default 0.') - call prop_set(prop_ptr, 'physics', 'dRoot', droot, 'Root depth (m)') - call prop_set(prop_ptr, 'physics', 'dStem', dstem, 'Stem height (m)') - call prop_set(prop_ptr, 'physics', 'nMaxMin', frcumin, 'Base Manning friction value (s/m^{1/3})') - call prop_set(prop_ptr, 'physics', 'dynVegPol', md_dynvegpol, 'Area to apply dynamic vegetation roughness. If empty, no roughness update.') - call prop_set(prop_ptr, 'physics', 'Vicouv', vicouv, 'Uniform horizontal eddy viscosity (m2/s)') call prop_set(prop_ptr, 'physics', 'Dicouv', dicouv, 'Uniform horizontal eddy diffusivity (m2/s)') if (writeall .or. (kmx > 0)) then diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 index ceb7b35ee59..8a6fc49e34c 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_gui/zlin.f90 @@ -33,13 +33,13 @@ module m_zlin use m_waveconst - use precision, only: dp implicit none contains real(kind=dp) function zlin(LL) ! get various values at flow links + use precision, only: dp use m_getltoplot use m_flow use m_flowgeom diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 index 99f91e4b762..22341ab80f8 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_io/unstruc_netcdf.f90 @@ -6282,7 +6282,7 @@ subroutine unc_write_map_filepointer_ugrid(mapids, tim, jabndnd) ! wrimap end if end if if (jamapwav_twav > 0 .and. allocated(twav)) then - ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'twav', '', 'Peak wave period', 's') + ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'tp', 'sea_surface_wave_period_at_variance_spectral_density_maximum', 'Peak wave period', 's') end if if (jamapwav_phiwav > 0 .and. allocated(phiwav)) then ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_thetamean, nc_precision, UNC_LOC_S, 'thetamean', 'sea_surface_wave_from_direction', 'Wave from direction', 'degree') @@ -6296,7 +6296,7 @@ subroutine unc_write_map_filepointer_ugrid(mapids, tim, jabndnd) ! wrimap ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_hwav, nc_precision, UNC_LOC_S, 'hwav', 'sea_surface_wave_significant_height', 'Significant wave height', 'm', jabndnd=jabndnd_) end if ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_thetamean, nc_precision, UNC_LOC_S, 'thetamean', 'sea_surface_wave_from_direction', 'Wave from direction', 'degree', jabndnd=jabndnd_) - ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'twav', '', 'Peak wave period', 's') + ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_twav, nc_precision, UNC_LOC_S, 'twav', 'sea_surface_wave_period_at_variance_spectral_density_maximum', 'Wave peak period', 's') ! we assume working with the peak period in all our formulations ierr = unc_def_var_map(mapids%ncid, mapids%id_tsp, mapids%id_uorb, nc_precision, UNC_LOC_S, 'uorb', 'sea_surface_wave_orbital_velocity', 'Wave orbital velocity', 'm s-1', jabndnd=jabndnd_) ! not CF ! if (jawavestokes > NO_STOKES_DRIFT) then diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 deleted file mode 100644 index 53f4ffb1760..00000000000 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/compute_dynveg.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!----- AGPL -------------------------------------------------------------------- -! -! Copyright (C) Stichting Deltares, 2017-2026. -! -! This file is part of Delft3D (D-Flow Flexible Mesh component). -! -! Delft3D is free software: you can redistribute it and/or modify -! it under the terms of the GNU Affero General Public License as -! published by the Free Software Foundation version 3. -! -! Delft3D is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Affero General Public License for more details. -! -! You should have received a copy of the GNU Affero General Public License -! along with Delft3D. If not, see . -! -! contact: delft3d.support@deltares.nl -! Stichting Deltares -! P.O. Box 177 -! 2600 MH Delft, The Netherlands -! -! All indications and logos of, and references to, "Delft3D", -! "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting -! Deltares, and remain the property of Stichting Deltares. All rights reserved. -! -!------------------------------------------------------------------------------- -module m_update_dynveg -! -! - implicit none - - private - - public :: update_dynveg - -contains - - subroutine update_dynveg() - use precision, only: dp - use m_physcoef - use m_sediment - use m_flow - - if (dynroughveg > 0) then - where ((dynveg) .and. (cumes > 0.0_dp)) ! linear function due to deposition ( cumes > 0 ) - frcu = frcumin + max((dstem - cumes) / dstem, 0.0_dp) * (frcu0 - frcumin) - elsewhere((dynveg) .and. (cumes < (-1.0_dp * droot))) ! erosion larger than root then always minimum ( cumes < -droot ) - frcu = frcumin - dynveg = .false. - elsewhere(dynveg) ! linear function due to deposition ( -droot < cumes < 0 ) - frcu = frcumin + min(max((droot + cumes) / droot, 0.0_dp), 1.0_dp) * (frcu0 - frcumin) - elsewhere - ! do nothing - frcu = frcu0 - end where - end if - - end subroutine update_dynveg - -end module m_update_dynveg diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/flow_initimestep.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/flow_initimestep.f90 index f5df54a1417..55ff033c8ee 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/flow_initimestep.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/flow_initimestep.f90 @@ -70,8 +70,6 @@ subroutine flow_initimestep(jazws0, set_hu, use_u1, iresult) use fm_external_forcings, only: calculate_wind_stresses, set_external_forcings_boundaries use m_wind, only: update_wind_stress_each_time_step, jaheat_eachstep use m_fm_icecover, only: update_icecover - use m_update_dynveg, only: update_dynveg - implicit none integer, intent(in) :: jazws0 @@ -155,11 +153,6 @@ subroutine flow_initimestep(jazws0, set_hu, use_u1, iresult) end if end if - ! Adapt roughness according to burial/erosion - if (dynroughveg > 0) then - call update_dynveg() - end if - call timstrt('Set conveyance ', handle_extra(44)) ! Start cfuhi call setcfuhi() ! set current related frictioncoefficient call timstop(handle_extra(44)) ! End cfuhi diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/furu.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/furu.f90 index e78b9396e41..ee02a9bea22 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/furu.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/furu.f90 @@ -178,12 +178,13 @@ subroutine furu() ! set fu, ru and kfs frL = cfuhi(L) * sqrt((u1L - ustokes(L))**2 + (v(L) - vstokes(L))**2 + (1.16_dp * uorbL * fsqrtt)**2) end if ! + du = du0 + frL * ustokes(L) + ! ! and add vegetation stem drag with eulerian velocities, assumes fixed stem if ((jaBaptist >= 2) .or. trachy_resistance) then frL = frL + alfav(L) * hypot(u1L - ustokes(L), v(L) - vstokes(L)) end if - ! - du = du0 + frL * ustokes(L) + else if (ifxedweirfrictscheme > 0) then if (iadv(L) == IADV_SUBGRID_WEIR .or. kcu(L) == 3) then call fixedweirfriction2D(L, k1, k2, frL) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 index aa9cd9e60f4..b2e7414e164 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustbcfuhi.f90 @@ -46,7 +46,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte use m_get_czz0, only: getczz0 use m_flowgeom, only: ln, dxi, csu, snu use m_flowtimes, only: dti - use m_waves, only: ustokes, vstokes, wblt, jawavevellogprof, strlyrfac + use m_waves, only: ustokes, vstokes, wblt use m_waveconst, only: NO_WAVES, NO_STOKES_DRIFT, WAVE_STREAMING_OFF use m_sediment, only: stm_included use m_flowtimes, only: dts @@ -64,7 +64,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte real(kind=dp) :: taubxuLL ! taubxu = ymxpar*(taucur+tauwav) real(kind=dp) :: csw, snw ! wave direction cosines - real(kind=dp) :: Dfu, Dfu0, Dfu1, htop ! wave dissipation by bed friction, / (rhomean*c*deltau) + real(kind=dp) :: Dfu, Dfu0, Dfu1, htop, dzu ! wave dissipation by bed friction, / (rhomean*c*deltau) real(kind=dp) :: deltau ! wave dissipation layer thickness real(kind=dp) :: u2dh real(kind=dp) :: z0urouL, rhoL, uorbu @@ -75,7 +75,6 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte real(kind=dp) :: s, sd, er, ers, dzb, uu, vv, alin real(kind=dp) :: cphi, sphi real(kind=dp) :: fsqrtt = sqrt(2.0_dp) - real(kind=dp) :: slfacdeltau cfuhi3D = 0.0_dp ustbLL = 0.0_dp @@ -122,7 +121,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte hdzb = 0.5_dp * hu(Lb) + z00 sqcf = vonkar / (log(1.0_dp + 0.5_dp * hu(Lb) / z00)) else if (jaustarint == 4) then - !hdzb = 0.5_dp*hu(Lb) + c9of1*z00/0.65_dp + !hdzb = 0.5d0*hu(Lb) + c9of1*z00/0.65d0 dzb = hu(Lb) / ee + c9of1 * z00 * 0.66_dp sqcf = vonkar / (log(dzb / z00)) else if (jaustarint == 5) then @@ -165,13 +164,18 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte u2dh = umod else ! here we assume that z0/dzb is small and c9of1==1, ie we use jaustarint==1 approach, cf 3D validation doc Mohamed - if (jawavevellogprof == 0) then - u2dh = umod * (log((1_dp + hu(LL)) / z0urou(LL)) - 1_dp) / (log(dzb / z0urou(LL)) - 1_dp) - else - ! use available depth-averaged u1, v - u2dh = sqrt((u1(LL) - ustokes(LL))**2 + & - (v(LL) - vstokes(LL))**2) - end if + !u2dh = umod*(log((1d0+hu(LL))/z0urou(LL))-1d0)/(log(dzb/z0urou(LL))-1d0) + + ! UNST-6297 formulation above gives u2dh of order too big in very shallow water + + ! Delft3D: + !u2dh = (umod/hu(LL) & + ! & *((hu(LL) + z0urou(LL))*log(1d0 + hu(LL)/z0urou(LL)) & + ! & - hu(LL)))/log(1d0 + 0.5d0*(max(dzb,0.01d0))/z0urou(LL)) + + ! use available depth-averaged u1, v + u2dh = sqrt((u1(LL) - ustokes(LL))**2 + & + (v(LL) - vstokes(LL))**2) end if ! if (cz > 0.0_dp) then @@ -190,6 +194,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte sphi = -csw * snu(LL) + snw * csu(LL) abscos = abs(cphi * uu + sphi * vv) / umod call getsoulsbywci(modind, ustc2, ustw2, fw, cdrag, umod, abscos, taubpuLL, taubxuLL) + ! ustbLL = sqrt(umod*taubpuLL) else if (modind == 9) then ! wave-current interaction van Rijn (2004) call getvanrijnwci(LL, umod, u2dh, taubpuLL, z0urouL) taubxuLL = rhoL * (ustc2 + ustw2) ! depth-averaged, see taubot @@ -203,7 +208,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte end if else if (modind == 0) then ! exception where you don't want wave influence on bed shear stress with jawave>0 if (sqcf > 0.0_dp) then - z0urouL = z00 ! no wave enhancement + z0urouL = dzb * exp(-vonkar / sqcf - 1.0_dp) ! inverse of jaustarint == 1 above taubpuLL = ustbLL * ustbLL / umod ! use flow ustar taubxuLL = rhoL * taubpuLL * umod else @@ -229,52 +234,50 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte z0urou(LL) = z0urouL end if z00 = z0urou(LL) ! wave enhanced z0 for turbulence + ! + if (stm_included) then + wblt(LL) = deltau + end if + ! + ! Streaming below deltau with linear distribution + if (jawavestreaming > WAVE_STREAMING_OFF .and. deltau > 1.0e-7_dp) then ! Streaming below deltau with linear distribution + Dfu0 = Dfuc ! (m/s2) + do L = Lb, Ltop(LL) + if (hu(L) <= deltau) then + htop = min(hu(L), deltau) ! max height within waveboundarylayer + alin = 1.0_dp - htop / deltau ! linear from 1 at bed to 0 at deltau + Dfu1 = Dfuc * alin + dzu = htop - hu(L - 1) + adve(L) = adve(L) - 0.5_dp * (Dfu0 + Dfu1) * dzu / deltau + Dfu0 = Dfu1 + end if + if (hu(L) > deltau) then + if (L == Lb) then + adve(L) = adve(L) - Dfuc * deltau / (2.0 * hu(L)) ! everything in bottom layer + end if + exit + end if + end do + end if else - if (sqcf > 0_dp) then + if (sqcf > 0.0_dp) then ! taubu for too small wave case needs to be filled z0urou(LL) = z00 ! just use current only z0 taubpuLL = ustbLL * ustbLL / umod ! use flow ustar taubxuLL = rhoL * taubpuLL * umod else - taubu(LL) = 0_dp - taubxu(LL) = 0_dp + taubu(LL) = 0.0_dp + taubxu(LL) = 0.0_dp z0urou(LL) = epsz0 end if end if - ! - if (stm_included) wblt(LL) = deltau - ! - ! Streaming below strlyrfac*deltau with linear distribution, see van Rijn 2011 p9.177 - if (jawavestreaming /= WAVE_STREAMING_OFF .and. deltau > 1.0e-4_dp) then ! weakly turbulent flume cases ~1mm-1cm, real turbulent cases 5-50cm - slfacdeltau = strlyrfac * deltau - Dfu0 = Dfuc ! (m/s2) - do L = Lb, Ltop(LL) - if (hu(L) <= slfacdeltau) then - htop = min(hu(L), slfacdeltau) ! max height within streaming layer - alin = 1_dp - htop / slfacdeltau ! linear from 1 at bed to 0 at slfacdeltau (= strlyrfac * deltau) - Dfu1 = Dfuc * alin - adve(L) = adve(L) - 0.5_dp * (Dfu0 + Dfu1) - Dfu0 = Dfu1 - end if - if (hu(L) > slfacdeltau) then - if (L == Lb) then - adve(L) = adve(L) - Dfuc * slfacdeltau / (2.0_dp * hu(L)) ! everything in bottom layer - else - alin = (min(hu(L), slfacdeltau) - hu(L - 1)) / (2.0_dp * (hu(L) - hu(L - 1))) - Dfu1 = Dfuc * alin - adve(L) = adve(L) - Dfu1 - end if - exit - end if - end do - end if end if ! end jawave cfuhiLL = sqcf * sqcf / hu(Lb) ! cfuhiLL = g / (H.C.C) = (g.K.K) / (A.A) cfuhi3D = cfuhiLL * umod ! cfuhi3D = frc. contr. to diagonal if (jawave == NO_WAVES .or. flow_without_waves) then - z0urou(LL) = z00 ! morfo, bedforms, trachytopes + z0urou(LL) = z0ucur(LL) ! morfo, bedforms, trachytopes end if else if (friction_type == 10) then ! Hydraulically smooth, glass etc @@ -333,7 +336,7 @@ subroutine getustbcfuhi(LL, Lb, ustbLL, cfuhiLL, hdzb, z00, cfuhi3D) ! see Uitte else if (friction_type == 11) then ! Noslip - ! advi(Lb) = advi(Lb) + 2_dp*(vicwwu(Lb)+vicouv)/hu(Lb)**2 + ! advi(Lb) = advi(Lb) + 2d0*(vicwwu(Lb)+vicouv)/hu(Lb)**2 cfuhi3D = 2.0_dp * (vicwwu(Lb) + vicoww) / hu(Lb)**2 end if diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 index ca9c55c19ed..9b5f03433f7 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getustwav.f90 @@ -39,12 +39,13 @@ module m_get_ustwav contains subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uorbu) ! at u-point, get ustarwave and get ustokes use precision, only: dp - use m_flow, only: hu, jawavestokes, ag, eps10 + use m_flow, only: hu, jawavestokes, ag, jawave, rhomean, eps10 use m_flowgeom, only: ln, csu, snu - use m_waves, only: twav, ustokes, vstokes, phiwav, hwav, gammax, jauorb, ftauw, fwfac, strlyrfac + use m_waves, only: twav, ustokes, vstokes, phiwav, hwav, gammax, jauorb, ftauw, alfdeltau, fwfac use m_waveconst, only: STOKES_DRIFT_2NDORDER, STOKES_DRIFT_DEPTHUNIFORM, WAVE_SURFBEAT use m_sferic, only: twopi, dg2rd, pi use m_get_Lbot_Ltop, only: getlbotltop + use m_xbeach_data, only: R, cwav, gammaxxb, roller use mathconsts, only: ee integer, intent(in) :: LL @@ -57,12 +58,11 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor real(kind=dp), intent(out) :: uorbu real(kind=dp), external :: sinhsafei - integer :: k1, k2, Lb, Lt, L + integer :: k1, k2, Lb, Lt, L, Lmin real(kind=dp) :: Tsig, Hrms, asg, rk, shs, phi1, phi2, dks, aks, omeg, f1u, f2u, f3u, sintu real(kind=dp) :: p1, p2, h, z, uusto, fac + real(kind=dp) :: rolthk, rmax, erol, crol, mass - real(kind=dp), parameter :: alfaw = 20.0_dp - real(kind=dp), parameter :: halfsqpi = 1.0_dp/(2.0_dp * acos(-1.0_dp)) Dfu = 0.0_dp Dfuc = 0.0_dp deltau = 0.0_dp @@ -124,6 +124,38 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor ! depth averaged ustokes(LL) = costu * ag * asg * asg * rk / omeg / 2.0_dp / hu(LL) ! these are needed, also for 3D models (see u bnd furu) vstokes(LL) = sintu * ag * asg * asg * rk / omeg / 2.0_dp / hu(LL) + + ! add 3D roller contribution to stokes drift + if (jawave == WAVE_SURFBEAT .and. roller == 1) then + ! roller mass flux + rmax = 0.125_dp * rhomean * ag * (gammaxxb * h)**2 + erol = min(0.5_dp * (R(k1) + R(k2)), rmax) + crol = max(0.5_dp * (cwav(k1) + cwav(k2)), 1.0e-1_dp) + mass = 2.0_dp * erol / crol / rhomean + ! + if (Lt > Lb) then + ! + ! determine roller thickness + lmin = Lt + rolthk = 0.0_dp + do L = Lt - 1, Lb, -1 + lmin = L + rolthk = hu(Lt) - hu(L) + if (rolthk >= 0.5_dp * hrms) then + exit + end if + end do + ! + ! depth dependent contribution + ustokes(Lmin:Lt) = ustokes(Lmin:Lt) + mass / rolthk * costu + vstokes(Lmin:Lt) = vstokes(Lmin:Lt) + mass / rolthk * sintu + end if + ! + ! depth averaged contribution + ustokes(LL) = ustokes(LL) + mass / h * costu + vstokes(LL) = ustokes(LL) + mass / h * sintu + end if + end if if (shs > eps10) then @@ -139,15 +171,14 @@ subroutine getustwav(LL, z00, fw, ustw2, csw, snw, Dfu, Dfuc, deltau, costu, uor dks = 33.0_dp * z00 ! should be 30 for consistency with getust aks = asg * shs / dks * fac ! uorbu/(omega*ks), uorbu/omega = particle excursion length - deltau = 0.09_dp * dks * aks**0.82_dp ! thickness of wave boundary layer from Fredsoe and Deigaard (1992) - deltau = max(deltau, ee * z00) ! alfaw makes wbl at least ~2ks thick + deltau = 0.09_dp * dks * aks**0.82_dp ! thickness of wave boundary layer from Fredsoe and Deigaard + deltau = alfdeltau * max(deltau, ee * z00) ! alfaw = 20d0 + deltau = min(0.5_dp * hu(LL), deltau) ! call soulsby(tsig, uorbu, z00, fw) ! streaming with different calibration fac fwfac + soulsby fws - Dfu = halfsqpi * fw * uorbu**3 ! random waves: 0.28=1/2sqrt(pi) (m3/s3) - Dfu = fwfac * Dfu / strlyrfac / deltau ! divided by 3 deltau (m2/s3) see van Rijn, streaming layer about 3-5 times wbl + Dfu = 0.28_dp * fw * uorbu**3 ! random waves: 0.28=1/2sqrt(pi) (m3/s3) + Dfu = fwfac * Dfu / deltau ! divided by deltau (m2/s3), missing rho divided out in adve denominator rho*delta Dfuc = Dfu * rk / omeg * costu ! Dfuc = dfu/c/delta, (m /s2) is contribution to adve - deltau = alfaw * deltau ! as in delft3d - deltau = min(0.5_dp * hu(LL), deltau) ! else ustw2 = 0.0_dp diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 index 68af2b34dd6..f05d01a86e7 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/getvanrijnwci.f90 @@ -39,7 +39,7 @@ module m_getvanrijnwci subroutine getvanrijnwci(LL, umod, u2dh, taubpuLL, z0urouL) use precision, only: dp use m_flow, only: hu, epshu, epsz0, lbot, u1, jaconveyance2d, v, ag - use m_bedform, only: bfmpar + use m_bedform, only: bfmpar, fp use m_flowgeom, only: ln, acl, csu, snu, lnx1d use m_waves, only: uorb, hwav, twav, rlabda, phiwav, ustokes, vstokes @@ -118,7 +118,7 @@ subroutine getvanrijnwci(LL, umod, u2dh, taubpuLL, z0urouL) uratio = min(uwbih / (u2dh + waveps), 5.0_dp) ka = ksc * exp(gamma * uratio) ka = min(ka, 10.0_dp * ksc, 0.2_dp * huLL) - ca = 18.0_dp * log10(12.0_dp * huLL / ka) + ca = 18.0_fp * log10(12.0_fp * huLL / ka) taubpuLL = ag * (u2dh * u2dh / umod) / ca**2 z0urouL = max(3.33e-5_dp, ka / 30.0_dp) end subroutine getvanrijnwci diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 index f3cf13c4efc..986c3c356d3 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/set_kbot_ktop.f90 @@ -326,7 +326,7 @@ subroutine update_vertical_coordinates_boundary() ktop(n) = kb - 1 + kmxn(n) end do return ! Early exit - no link updates needed for sigma layers, volumes already calculated - + else if (Layertype == LAYTP_Z) then ! z or z-sigma do i_bnd = 1, nbndz n = kbndz(1, i_bnd) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 index 8255353539f..c6102244ba7 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute/update_verticalprofiles.f90 @@ -113,7 +113,7 @@ subroutine update_verticalprofiles() call getustbcfuhi(LL, Lb, ustb(LL), cfuhi(LL), hdzb, z00, cfuhi3D) !Constant advi(Lb) = advi(Lb) + cfuhi3D ! - if (jawave /= NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_DEPTHUNIFORM .and. .not. flow_without_waves) then ! Ustokes correction at bed + if (jawave > NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_DEPTHUNIFORM .and. .not. flow_without_waves) then ! Ustokes correction at bed adve(Lb) = adve(Lb) - cfuhi3D * ustokes(Lb) end if @@ -168,7 +168,7 @@ subroutine update_verticalprofiles() call getustbcfuhi(LL, Lb, ustb(LL), cfuhi(LL), hdzb, z00, cfuhi3D) ! algebraic advi(Lb) = advi(Lb) + cfuhi3D ! - if (jawave /= NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_DEPTHUNIFORM .and. .not. flow_without_waves) then ! Ustokes correction at bed + if (jawave > NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_DEPTHUNIFORM .and. .not. flow_without_waves) then ! Ustokes correction at bed adve(Lb) = adve(Lb) - cfuhi3D * ustokes(Lb) end if @@ -318,12 +318,12 @@ subroutine update_verticalprofiles() vicu = viskin + 0.5_dp * (vicwwu(Lb0) + vicwwu(Lb)) * sigtkei ! Calculate turkin source from wave dissipation: preparation - if (jawave /= NO_WAVES) then + if (jawave > NO_WAVES) then if (jawaveStokes > NO_STOKES_DRIFT .and. .not. flow_without_waves) then ! Ustokes correction at bed adve(Lb) = adve(Lb) - cfuhi3D * ustokes(Lb) end if - if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then + if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then k1 = ln(1, LL) k2 = ln(2, LL) ac1 = acl(LL) @@ -419,7 +419,7 @@ subroutine update_verticalprofiles() ! Addition of production and of dissipation to matrix ; ! observe implicit treatment by Newton linearization. - if (jawave /= NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_2NDORDER_VISC .and. .not. flow_without_waves) then ! vertical shear based on eulerian velocity field, see turclo,note JvK, Ardhuin 2006 + if (jawave > NO_WAVES .and. jawaveStokes >= STOKES_DRIFT_2NDORDER_VISC .and. .not. flow_without_waves) then ! vertical shear based on eulerian velocity field, see turclo,note JvK, Ardhuin 2006 dijdij(k) = ((u1(Lu) - ustokes(Lu) - u1(L) + ustokes(L))**2 + (v(Lu) - vstokes(Lu) - v(L) + vstokes(L))**2) / dzw(k)**2 else dijdij(k) = ((u1(Lu) - u1(L))**2 + (v(Lu) - v(L))**2) / dzw(k)**2 @@ -446,7 +446,7 @@ subroutine update_verticalprofiles() end do ! Lb, Lt-1 - if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then + if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then ! check if first layer is thicker than fwavpendep*wave height ! Then use JvK solution if (hu(LL) - hu(Lt - 1) >= fwavpendep * hrmsLL) then @@ -675,7 +675,7 @@ subroutine update_verticalprofiles() sourtu = c1e * cmukep * turkin0(L) * dijdij(k) ! ! Add wave dissipation production term - if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then + if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then sourtu = sourtu + pkwav(k) * c1e * tureps0(L) / max(turkin0(L), 1.0e-7_dp) end if @@ -728,7 +728,7 @@ subroutine update_verticalprofiles() bk(kxL) = 1.0_dp ck(kxL) = 0.0_dp dk(kxL) = 4.0_dp * abs(ustw(LL))**3 / (vonkar * dzu(Lt - Lb + 1)) - if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then ! wave dissipation at surface, neumann bc, dissipation over fwavpendep*Hrms + if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then ! wave dissipation at surface, neumann bc, dissipation over fwavpendep*Hrms dk(kxL) = dk(kxL) + dzu(Lt - Lb + 1) * pkwmag / (fwavpendep * hrmsLL) end if @@ -840,8 +840,8 @@ subroutine update_verticalprofiles() end do epsbot = tureps1(Lb) + dzu(1) * abs(ustb(LL))**3 / (vonkar * hdzb * hdzb) epssur = tureps1(Lt - 1) - 4.0_dp * abs(ustw(LL))**3 / (vonkar * dzu(Lt - Lb + 1)) - if (jawave /= NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then - epssur = epssur - dzu(Lt - Lb + 1) * pkwmag / (hrmsLL * fwavpendep) + if (jawave > NO_WAVES .and. jawavebreakerturbulence > WAVE_BREAKER_TURB_OFF) then + epssur = epssur - dzu(Lt - Lb + 1) * fwavpendep * pkwmag / hrmsLL end if epsbot = max(epsbot, eps_min) epssur = max(epssur, eps_min) @@ -867,9 +867,7 @@ subroutine update_verticalprofiles() vicwwu(Lb0:Lt) = min(vicwmax, cmukep * turkin1(Lb0:Lt) * tureps1(Lb0:Lt)) end if - if (jawave == NO_WAVES .or. jawavebreakerturbulence == WAVE_BREAKER_TURB_OFF) then - vicwwu(Lt) = min(vicwwu(Lt), vicwwu(Lt - 1) * Eddyviscositysurfacmax) - end if + vicwwu(Lt) = min(vicwwu(Lt), vicwwu(Lt - 1) * Eddyviscositysurfacmax) vicwwu(Lb0) = min(vicwwu(Lb0), vicwwu(Lb) * Eddyviscositybedfacmax) call vertical_profile_u0(dzu, womegu, Lb, Lt, kxL, LL) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/apply_sediment_bc.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/apply_sediment_bc.f90 index feb5d657bf7..ff82e96b9b8 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/apply_sediment_bc.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/apply_sediment_bc.f90 @@ -148,7 +148,7 @@ subroutine apply_sediment_bc() ki = ln(2, L) kk = kmxd * (k - 1) + L - Lb + 1 if (q1(L) > 0) then ! inflow - constituents(iconst, kb) = bndsf(ll)%z(kk) + constituents(iconst, kb) = bndsf(ll)%z(k) else ! outflow constituents(iconst, kb) = constituents(iconst, ki) end if diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 index c35c05f1434..4166661daff 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/bermslopenudging.f90 @@ -43,16 +43,14 @@ subroutine bermslopenudging(error) use m_fm_erosed, only: bermslopegamma, bermslopedepth, bermslopebed, bermslopesus, e_dzdn, e_dzdt, bermslopefac, bermslope, morfac, lsedtot, bed, has_bedload, e_sbcn, e_sbct, e_sbwn, e_sbwt, sus, lsed, e_ssn, e_sswn, e_sswt use m_waveconst, only: no_waves use m_flow, only: hu, epshu - use m_flowgeom, only: lnx, ln, wu_mor, snu, csu + use m_flowgeom, only: lnx, ln, wu_mor use m_flowparameters, only: jawave - use m_waves, only: phiwav logical, intent(out) :: error integer :: L, k1, k2 integer :: lsd - real(kind=dp) :: hwavu, slope, flx, fixf, trmag_u, slpfac - real(kind=dp) :: cosw, sinw, coswu + real(kind=dp) :: hwavu, slope, flx, frc, fixf, trmag_u, slpfac error = .true. ! @@ -110,15 +108,7 @@ subroutine bermslopenudging(error) ! Transports positive outgoing ! slope = max(hypot(e_dzdn(L), e_dzdt(L)), 1.0e-8_dp) - if (jawave > NO_WAVES) then - cosw = 0.5_dp * (cosd(phiwav(k1)) + cosd(phiwav(k2))) - sinw = 0.5_dp * (sind(phiwav(k1)) + sind(phiwav(k2))) - coswu = cosw * csu(L) + sinw * snu(L) - slpfac = bermslopefac * (-e_dzdn(L) + bermslope * coswu) / max(morfac, 1.0_dp) - else - ! we have no good substitute, so old approach - slpfac = bermslopefac * (-e_dzdn(L) + bermslope * e_dzdn(L) / slope) / max(morfac, 1.0_dp) - end if + slpfac = bermslopefac * (-e_dzdn(L) + bermslope * e_dzdn(L) / slope) / max(morfac, 1.0_dp) do lsd = 1, lsedtot ! ! slope magnitude smaller than bermslope leads to transport away from the cell, ie outward @@ -130,28 +120,28 @@ subroutine bermslopenudging(error) trmag_u = hypot(e_sbcn(L, lsd), e_sbct(L, lsd)) flx = trmag_u * slpfac e_sbcn(L, lsd) = e_sbcn(L, lsd) - flx - call getfixfac(L, k1, k2, lsd, e_sbcn(L, lsd), fixf) - e_sbcn(L, lsd) = e_sbcn(L, lsd) * fixf + call getfracfixfac(L, k1, k2, lsd, e_sbcn(L, lsd), frc, fixf) + e_sbcn(L, lsd) = e_sbcn(L, lsd) * frc * fixf ! trmag_u = hypot(e_sbwn(L, lsd), e_sbwt(L, lsd)) flx = trmag_u * slpfac e_sbwn(L, lsd) = e_sbwn(L, lsd) - flx - call getfixfac(L, k1, k2, lsd, e_sbwn(L, lsd), fixf) - e_sbwn(L, lsd) = e_sbwn(L, lsd) * fixf + call getfracfixfac(L, k1, k2, lsd, e_sbwn(L, lsd), frc, fixf) + e_sbwn(L, lsd) = e_sbwn(L, lsd) * frc * fixf end if ! if (bermslopeindexsus(L) .and. sus /= 0.0 .and. lsd <= lsed) then trmag_u = abs(e_ssn(L, lsd)) flx = trmag_u * slpfac e_ssn(L, lsd) = e_ssn(L, lsd) - flx - call getfixfac(L, k1, k2, lsd, e_ssn(L, lsd), fixf) - e_ssn(L, lsd) = e_ssn(L, lsd) * fixf + call getfracfixfac(L, k1, k2, lsd, e_ssn(L, lsd), frc, fixf) + e_ssn(L, lsd) = e_ssn(L, lsd) * frc * fixf ! trmag_u = hypot(e_sswn(L, lsd), e_sswt(L, lsd)) flx = trmag_u * slpfac e_sswn(L, lsd) = e_sswn(L, lsd) - flx - call getfixfac(L, k1, k2, lsd, e_sswn(L, lsd), fixf) - e_sswn(L, lsd) = e_sswn(L, lsd) * fixf + call getfracfixfac(L, k1, k2, lsd, e_sswn(L, lsd), frc, fixf) + e_sswn(L, lsd) = e_sswn(L, lsd) * frc * fixf end if end do end do @@ -161,9 +151,9 @@ subroutine bermslopenudging(error) end subroutine bermslopenudging - subroutine getfixfac(L, k1, k2, lsd, transp, fixf) + subroutine getfracfixfac(L, k1, k2, lsd, transp, frc, fixf) use precision, only: dp - use m_fm_erosed, only: fixfac + use m_fm_erosed, only: fixfac, frac use m_flowgeom, only: lnxi use m_flow, only: hu, epshu @@ -171,17 +161,20 @@ subroutine getfixfac(L, k1, k2, lsd, transp, fixf) integer, intent(in) :: L, k1, k2, lsd real(kind=dp), intent(in) :: transp - real(kind=dp), intent(out) :: fixf + real(kind=dp), intent(out) :: frc, fixf if (L > lnxi .and. hu(L) > epshu) then fixf = fixfac(k2, lsd) + frc = frac(k2, lsd) else if (transp >= 0) then fixf = fixfac(k1, lsd) + frc = frac(k1, lsd) else fixf = fixfac(k2, lsd) + frc = frac(k2, lsd) end if end if - end subroutine getfixfac + end subroutine getfracfixfac end module m_bermslopenudging diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/duneaval.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/duneaval.f90 index a2eca2e0138..5c2f43f2055 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/duneaval.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/duneaval.f90 @@ -43,8 +43,7 @@ module m_duneaval subroutine duneaval(error) use precision, only: dp use m_fm_erosed, only: hswitch, wetslope, dryslope, e_dzdn, e_dzdt, avaltime, morfac, lsedtot, fixfac, frac, dzmaxdune, rhosol - use m_fm_erosed, only: bermslopetransport, bermslope - use m_sediment, only: avalflux, bermslopeindex + use m_sediment, only: avalflux use m_flowgeom, only: lnx, wu_mor, ln, acl, bl, dx, lnxi, ba use m_flow, only: hs @@ -69,11 +68,6 @@ subroutine duneaval(error) ac2 = 1.0_dp - ac1 if (hs(k1) > hswitch .or. hs(k2) > hswitch) then slpmax = wetslope - if (bermslopetransport) then - if (bermslopeindex(L)) then - slpmax = bermslope - end if - end if else slpmax = dryslope end if @@ -109,7 +103,7 @@ subroutine duneaval(error) end if end if ! - avalflux(L, lsd) = avalflux(L, lsd) - ba(k1) * ba(k2) / (ba(k1) + ba(k2)) * avflux * rhosol(lsd) / wu_mor(L) !m2 m/s kg /m3 /m = kg/s/m + avalflux(L, lsd) = avalflux(L, lsd) - ba(k1) * ba(k2) / (ba(k1) + ba(k2)) * avflux * rhosol(lsd) / wu_mor(L) end do end if end do diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 index 70c25b1c6d8..fe3d19ccb27 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_erosed.f90 @@ -76,10 +76,9 @@ subroutine fm_erosed() use sediment_basics_module use m_physcoef, only: ag, vonkar, sag, backgroundsalinity, backgroundwatertemperature, vismol, frcuni, ifrctypuni use m_sediment, only: stmpar, stm_included, jatranspvel, sbcx_raw, sbcy_raw, sswx_raw, sswy_raw, sbwx_raw, sbwy_raw - use m_sediment, only: difparam, seddif_cal use m_flowgeom, only: bl, dxi, csu, snu, wcx1, wcx2, wcy1, wcy2, acl, csu, snu, wcl use m_flow, only: s0, s1, u1, v, kmx, zws, hs, iturbulencemodel, z0urou, ifrcutp, hu, spirint, spiratx, spiraty, & - u_to_umain, frcu_mor, javeg, jabaptist, cfuhi, taubxu, epsz0 + u_to_umain, frcu_mor, javeg, jabaptist, cfuhi, epshs, taubxu, epsz0 use m_flowtimes, only: julrefdat, dts, time1 use unstruc_files, only: mdia use unstruc_channel_flow, only: t_branch, t_node, nt_LinkNode @@ -470,7 +469,7 @@ subroutine fm_erosed() ! if (kmx > 0) then ! 3D deltas = 0.05_dp - maxdepfrac = 0.05_dp + maxdepfrac = 0.05 if (jawave > NO_WAVES .and. v2dwbl > 0) then deltas = 0.0_dp do L = 1, lnx @@ -488,7 +487,7 @@ subroutine fm_erosed() do k = kb, kt zcc = 0.5_dp * (zws(k - 1) + zws(k)) ! cell centre position in vertical layer admin, using absolute height kmxvel = k - if (zcc >= (bl(kk) + maxdepfrac * hs(kk)) .or. (jawave > NO_WAVES .and. zcc >= (bl(kk) + deltas(kk)))) then + if (zcc >= (bl(kk) + maxdepfrac * hs(kk)) .or. zcc >= (bl(kk) + deltas(kk))) then exit end if end do @@ -990,9 +989,9 @@ subroutine fm_erosed() end if end if ! - kmaxsd = kmaxlc ! for mud fractions kmaxsd points to the grid cell at the bottom of the water column - thick0 = max(thicklc(kmaxsd) * h0, epshu) - thick1 = thicklc(kmaxsd) * h1 + kmaxsd = 1 ! for mud fractions kmaxsd points to the grid cell at the bottom of the water column + thick0 = max(thicklc(kmaxsd) * h0, epshs) + thick1 = max(thicklc(kmaxsd) * h1, epshs) ! call erosilt(thicklc, kmaxlc, wslc, mdia, & & thick1, thick1, fixfac(nm, l), srcmax(nm, l), & ! mass conservation @@ -1203,6 +1202,7 @@ subroutine fm_erosed() rsedeq(nm, l) = rsdqlc(kmaxsd) ! thick0 = max(thicklc(kmaxsd) * h0, epshu) + thick1 = max(thicklc(kmaxsd) * h1, epshu) thick1 = thicklc(kmaxsd) * h1 ! call soursin_3d(h1, thick1, thick1, & ! thick1 iso thick0 mass conservation @@ -1212,20 +1212,15 @@ subroutine fm_erosed() & aks_ss3d, sourse(nm, l), sour_im(nm, l), & & sinkse(nm, l)) ! - if (seddif_cal > 0.0_dp) then - seddif(l, kb:kt) = seddif_cal * seddif(l, kb:kt) - end if - ! ! Impose relatively large vertical diffusion ! coefficients for sediment in layer interfaces from ! bottom of reference cell downwards, to ensure little ! gradient in sed. conc. exists in this area. - if (difparam > 0.0_dp) then - difbot = difparam * ws(kmxsed(nm, l) - 1, l) * thick1 - do kk = kb - 1, kmxsed(nm, l) - 1 - seddif(l, kk) = difbot - end do - end if + + difbot = 10.0_fp * ws(kmxsed(nm, l) - 1, l) * thick1 + do kk = kb - 1, kmxsed(nm, l) - 1 + seddif(l, kk) = difbot + end do end if ! suspfrac else ! diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_fallve.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_fallve.f90 index b90997c9168..c29cdb0090e 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_fallve.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/fm_fallve.f90 @@ -185,7 +185,6 @@ subroutine fm_fallve() end if ! ! loop over the interfaces in the vertical - ! this does not work kmx==1 ! if (kmx > 0) then ! 3D call getkbotktop(k, kb, kt) @@ -340,7 +339,7 @@ subroutine fm_fallve() ws(kk, ll) = wsloc end do ! ll end do ! kk - if (kmx > 1) then ! what about kmx==1 + if (kmx > 1) then do ll = 1, lsed ws(kb - 1, ll) = ws(kb, ll) ! to check end do ! ll diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 index 298fcfd6ddf..221fcf8f6c0 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_sediment/m_fm_bott3d.f90 @@ -78,10 +78,10 @@ subroutine fm_bott3d() use m_flowtimes, only: dts, tstart_user, time1, tfac, ti_sed, ti_seds, handle_extra use unstruc_files, only: mdia use m_fm_erosed, only: mtd, tmor, bc_mor_array, lsedtot, e_ssn, bermslopetransport, duneavalan, & - bedw,bed,dbodsd,e_sbcn,e_sbct,e_sbwn,e_sswn,e_sswt,lsed,morfac,& - stmpar,susw,tcmp,sbcx,sbcy,morft,ucxq_mor,ucyq_mor,blchg,e_sbwt,& - hs_mor,hydrt,sbwx,sbwy,sscx,sscy,sswx,sswy,sedd50,taub,rhosol,& - hidexp + bedw, bed, dbodsd, e_sbcn, e_sbct, e_sbwn, e_sswn, e_sswt, lsed, morfac, & + stmpar, susw, tcmp, sbcx, sbcy, morft, ucxq_mor, ucyq_mor, blchg, e_sbwt,& + hs_mor, hydrt, sbwx, sbwy, sscx, sscy, sswx, sswy, sedd50, taub, rhosol, & + hidexp use m_sediment, only: kcsmor use m_partitioninfo, only: jampi, ITYPE_Sall, update_ghosts use m_fm_morstatistics, only: morstats, morstatt0 @@ -91,7 +91,7 @@ subroutine fm_bott3d() use m_waveconst use m_physcoef, only: ag, rhomean use m_bedform, only: bfmpar - use m_physcoef, only: dynroughveg + implicit none !! @@ -123,13 +123,16 @@ subroutine fm_bott3d() !! Point !! - associate ( cmpupd => stmpar%morpar%cmpupd ) + associate (& + cmpupd => stmpar%morpar%cmpupd & + ) if (associated(bfmpar%dunelength)) then dunelength => bfmpar%dunelength else dunelength => empty_dunelength end if + !! !! Execute @@ -242,7 +245,7 @@ subroutine fm_bott3d() ! Determine new thickness of transport layer ! call compthick() - ! + ! ! Compute mobile fractions ! if (stmpar%morlyr%settings%imobility > MOBILITY_OFF) then @@ -294,10 +297,6 @@ subroutine fm_bott3d() call fm_blchg_no_cmpupd() !Compute bed level changes without actually updating the bed composition ! call fm_apply_bed_boundary_condition(dtmor, timhr) - ! - if (dynroughveg > 0) then - call determine_linkbased_cumblchg() - end if else ! @@ -311,8 +310,7 @@ subroutine fm_bott3d() ! call timstop(handle_extra(89)) - ! - end associate + end associate end subroutine fm_bott3d !< Calculate suspended sediment transport correction vector (for SAND) @@ -426,10 +424,6 @@ subroutine fm_suspended_sand_correction() aksu = ac1 * aks(k1, l) + ac2 * aks(k2, l) end if ! - if (aksu < 1e-10_dp) then - cycle - end if - ! ! work up through layers integrating transport flux ! below aksu, according to Bert's new implementation ! @@ -519,7 +513,7 @@ subroutine fm_suspended_sand_correction() ! cavg*dz = | c(z) dz = c_a/(-R+1)*(z/a)^(-R+1)*a | = c_a/(-R+1)*a^R*z^(-R+1) | ! /a a a ! - cavg1 = (ceavg / (apower + 1.0_dp)) * (1.0_dp / aksu)**apower + cavg1 = (ceavg / (apower + 1.0_dp)) * (1_dp / aksu)**apower cavg2 = zktop**(apower + 1.0_dp) - aksu**(apower + 1.0_dp) cavg = cavg1 * cavg2 ! kg/m3/m ! @@ -830,7 +824,7 @@ subroutine fm_bed_boundary_conditions(timhr) ! ! Prepare loop over boundary points ! - tausum2(1) = 0.0_dp + tausum2(1) = 0_dp do ib = 1, morbnd(jb)%npnt lm = morbnd(jb)%lm(ib) k2 = morbnd(jb)%nxmx(ib) @@ -849,7 +843,7 @@ subroutine fm_bed_boundary_conditions(timhr) ! in combination with non-uniform cells. li = 0 do l = 1, lsedtot - sbsum = 0.0_dp + sbsum = 0_dp ! ! bed load transport only for fractions with bedload component ! @@ -915,7 +909,7 @@ subroutine fm_bed_boundary_conditions(timhr) ! if (morbnd(jb)%ibcmt(3) == lsedbed) then call get_tau(ln(2, lm), taucurc, czc, jawaveswartdelwaq_local) - if (tausum2(1) > 0.0_dp .and. wu_mor(lm) > 0.0_dp) then ! fix cutcell + if (tausum2(1) > 0_dp .and. wu_mor(lm) > 0_dp) then ! fix cutcell rate = bc_sed_distribution(li) * taucurc**2 / wu_mor(lm) / tausum2(1) else rate = bc_mor_array(li) @@ -1012,7 +1006,7 @@ subroutine fm_change_in_sediment_thickness(dtmor) ! ! Update quantity of bottom sediment ! - dbodsd(:, :) = 0.0_dp + dbodsd(:, :) = 0_dp ! ! compute change in bodsed (dbodsd) ! @@ -1024,22 +1018,22 @@ subroutine fm_change_in_sediment_thickness(dtmor) ! loop over internal (ndxi) nodes - don't update the boundary nodes ! do nm = 1, Ndxi_mor - trndiv = 0.0_dp - sedflx = 0.0_dp - eroflx = 0.0_dp + trndiv = 0_dp + sedflx = 0_dp + eroflx = 0_dp !FM1DIMP2DO: I do not like this, but I cannot think of a better way. !The added flownodes at junctions are after the boundary ghost nodes. !We have to skip the boundaries but loop over the added flownodes. if ((nm > ndxi) .and. (nm < ndx + 1)) then cycle end if - if (sus /= 0.0_dp .and. .not. bedload) then + if (sus /= 0_dp .and. .not. bedload) then if (neglectentrainment) then ! ! mass balance based on transport fluxes only: entrainment and deposition ! do not lead to erosion/sedimentation. ! - sumflux = 0.0_dp + sumflux = 0_dp if (kmx > 0) then do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) @@ -1048,7 +1042,7 @@ subroutine fm_change_in_sediment_thickness(dtmor) if (Lt < Lb) then cycle end if - flux = 0.0_dp + flux = 0_dp do iL = Lb, Lt flux = flux + fluxhortot(j, iL) end do @@ -1112,12 +1106,12 @@ subroutine fm_change_in_sediment_thickness(dtmor) end if end if end if - ssccum(l, nm) = 0.0_dp + ssccum(l, nm) = 0_dp eroflx = sourse(nm, l) * thick1 ! mass conservation, different from D3D ! ! add suspended transport correction vector ! - sumflux = 0.0_dp + sumflux = 0_dp do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) Lf = abs(LL) @@ -1128,7 +1122,7 @@ subroutine fm_change_in_sediment_thickness(dtmor) end if end if if (bed /= 0.0_dp) then - sumflux = 0.0_dp + sumflux = 0_dp do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) Lf = abs(LL) @@ -1139,17 +1133,17 @@ subroutine fm_change_in_sediment_thickness(dtmor) end if ! if (duneavalan) then ! take fluxes out of timestep restriction - sumflux = 0.0_dp ! drawback: avalanching fluxes not included in total transports + sumflux = 0_dp ! drawback: avalanching fluxes not included in total transports do ii = 1, nd(nm)%lnx LL = nd(nm)%ln(ii) Lf = abs(LL) - flux = avalflux(Lf, l) * wu_mor(Lf) ! kg m-1 s-1 m + flux = avalflux(Lf, l) * wu_mor(Lf) call fm_sumflux(LL, sumflux, flux) end do - trndiv = trndiv + sumflux * bai_mor(nm) ! kg s-1 + trndiv = trndiv + sumflux * bai_mor(nm) end if ! - dsdnm = (trndiv + sedflx - eroflx) * dtmor ! kg m-2 + dsdnm = (trndiv + sedflx - eroflx) * dtmor ! ! Warn if bottom changes are very large, ! depth change NOT LIMITED @@ -1232,11 +1226,11 @@ subroutine fm_dry_bed_erosion(dtmor) ! ! If this is a cell in which sediment processes are active then ... ! - if (kfsed(nm) /= 1 .or. (s1(nm) - bl(nm)) <= epshs .or. thetsd(nm) <= 0) then + if (kfsed(nm) /= 1 .or. (s1(nm) - bl(nm)) < epshs .or. thetsd(nm) <= 0) then cycle ! check whether sufficient as condition end if ! - totdbodsd = 0.0_dp + totdbodsd = 0_dp do l = 1, lsedtot totdbodsd = totdbodsd + real(dbodsd(l, nm), hp) end do @@ -1244,7 +1238,7 @@ subroutine fm_dry_bed_erosion(dtmor) ! If this is a cell where erosion is occuring (accretion is not ! distributed to dry points) then... ! - if (totdbodsd < 0.0_dp) then + if (totdbodsd < 0_dp) then ! ! Note: contrary to the previous implementation, this new ! implementation erodes the sediment from nm and @@ -1257,7 +1251,7 @@ subroutine fm_dry_bed_erosion(dtmor) ! individual fractions. ! bamin = ba(nm) - totfixfrac = 0.0_dp + totfixfrac = 0_dp ! do L = 1, nd(nm)%lnx k1 = ln(1, abs(nd(nm)%ln(L))) @@ -1308,7 +1302,7 @@ subroutine fm_dry_bed_erosion(dtmor) k2 = ln(2, abs(nd(nm)%ln(L))) Lf = abs(nd(nm)%ln(L)) ! cutcells - if (wu_mor(Lf) == 0.0_dp) then + if (wu_mor(Lf) == 0_dp) then cycle end if ! @@ -1321,7 +1315,7 @@ subroutine fm_dry_bed_erosion(dtmor) dv = thet * fixfac(knb, ll) * frac(knb, ll) dbodsd(ll, knb) = dbodsd(ll, knb) - dv * bai_mor(knb) dbodsd(ll, nm) = dbodsd(ll, nm) + dv * bai_mor(nm) - e_sbn(Lf, ll) = e_sbn(Lf, ll) + dv / (dtmor * wu_mor(Lf)) * sign(1.0_dp, nd(nm)%ln(L) + 0.0_dp) + e_sbn(Lf, ll) = e_sbn(Lf, ll) + dv / (dtmor * wu_mor(Lf)) * sign(1_dp, nd(nm)%ln(L) + 0_dp) end if end do ! L end do ! ll @@ -1369,13 +1363,13 @@ subroutine fm_apply_mormerge() jamerge = .false. if (jamormergedtuser > 0) then mergebodsed = mergebodsed + dbodsd - dbodsd(:, :) = 0.0_dp + dbodsd(:, :) = 0_dp if (comparereal(time1, time_user, eps10) >= 0) then jamerge = .true. end if else mergebodsed = dbodsd - dbodsd(:, :) = 0.0_dp + dbodsd(:, :) = 0_dp jamerge = .true. end if if (jamerge) then @@ -1396,7 +1390,7 @@ subroutine fm_apply_mormerge() dbodsd(ll, nm) = real(stmpar%morpar%mergebuf(ii), fp) end do end do - mergebodsed(:, :) = 0.0_dp + mergebodsed(:, :) = 0_dp end if end if @@ -1496,7 +1490,7 @@ subroutine fm_apply_bed_boundary_condition(dtmor, timhr) ! will be equal to 1. ! icond = morbnd(jb)%icond - if (u1(lm) < 0.0_dp) then + if (u1(lm) < 0_dp) then icond = 0 ! to do: 3d end if ! @@ -1602,7 +1596,7 @@ subroutine fm_update_concentrations_after_bed_level_update() ! After review, botcrit as a parameter is a really bad idea, as it causes concentration explosions if chosen poorly or blchg is high. ! Instead, allow bottom level changes up until 5% of the waterdepth to influence concentrations ! This is in line with the bed change messages above. Above that threshold, change the concentrations as if blchg==0.95hs - if (hsk <= epshs) then + if (hsk < epshs) then cycle end if botcrit = 0.95 * hsk @@ -1621,11 +1615,11 @@ subroutine fm_update_concentrations_after_bed_level_update() end do end if !ITRA1>0 end do !k - else !kmx>0 + else !kmx==0 do ll = 1, stmpar%lsedsus ! works for sigma only do k = 1, ndx hsk = hs(k) - if (hsk <= epshs) then + if (hsk < epshs) then cycle end if botcrit = 0.95 * hsk @@ -1640,7 +1634,7 @@ subroutine fm_update_concentrations_after_bed_level_update() if (jasal > 0) then do k = 1, ndx hsk = hs(k) - if (hsk <= epshs) then + if (hsk < epshs) then cycle end if botcrit = 0.95 * hsk @@ -1655,7 +1649,7 @@ subroutine fm_update_concentrations_after_bed_level_update() do itrac = ITRA1, ITRAN do k = 1, ndx hsk = hs(k) - if (hsk <= epshs) then + if (hsk < epshs) then cycle end if botcrit = 0.95 * hsk @@ -1694,8 +1688,8 @@ subroutine fm_total_face_normal_suspended_transport() do ll = 1, lsed j = lstart + ll ! constituent index do L = 1, lnx - e_ssn(L, ll) = 0.0_dp - if (wu_mor(L) == 0.0_dp) then + e_ssn(L, ll) = 0_dp + if (wu_mor(L) == 0_dp) then cycle end if call getLbotLtop(L, Lb, Lt) @@ -1730,8 +1724,8 @@ subroutine sum_current_wave_transport_links() !! Execute !! - e_sbn(:, :) = 0.0_dp - e_sbt(:, :) = 0.0_dp + e_sbn(:, :) = 0_dp + e_sbt(:, :) = 0_dp do l = 1, lsedtot if (has_bedload(tratyp(l))) then do nm = 1, lnx @@ -1808,7 +1802,7 @@ subroutine fm_blchg_no_cmpupd() !! if (.not. cmpupd) then - blchg(:) = 0.0_dp + blchg(:) = 0_dp do ll = 1, lsedtot do nm = 1, ndx blchg(nm) = blchg(nm) + dbodsd(ll, nm) / cdryb(ll) @@ -1954,7 +1948,7 @@ subroutine fm_correct_water_level() ! bed or maximum water level in surrounding wet cells ! (whichever is higher) ! - if (hs(nm) <= epshs) then + if (hs(nm) < epshs) then s1(nm) = s1(nm) + blchg(nm) s0(nm) = s0(nm) + blchg(nm) end if @@ -2010,12 +2004,12 @@ subroutine fm_erosion_velocity(dtmor) !! Execute !! - if (dtmor > 0.0_dp) then + if (dtmor > 0_dp) then do nm = 1, ndx dzbdt(nm) = blchg(nm) / dtmor end do else - dzbdt(:) = 0.0_dp + dzbdt(:) = 0_dp end if end subroutine fm_erosion_velocity @@ -2097,26 +2091,6 @@ subroutine fm_diffusion_active_layer() end subroutine fm_diffusion_active_layer - subroutine determine_linkbased_cumblchg() - use m_sediment, only: cumes - use m_fm_erosed, only: blchg - use m_flowgeom, only: lnx, ln, acl - - implicit none - - integer :: L, k1, k2 - real(kind=dp) :: ac1, ac2 - - do L = 1, lnx - k1 = ln(1, L) - k2 = ln(2, L) - ac1 = acl(L) - ac2 = 1.0_dp - ac1 - cumes(L) = cumes(L) + ac1 * (blchg(k1)) + ac2 * (blchg(k2)) - end do - - end subroutine determine_linkbased_cumblchg - !> Apply the nodal point relation by Bolla and Pittaluga et al. (2003) to compute the sediment transport !rate at the node of a bifurcation. The relation is applied at the junction flownode of a bifurcation, !which has one incoming and two outgoing branches. The sediment transport rate at the node is computed @@ -2218,7 +2192,7 @@ subroutine nodal_point_relation_BollaPittaluga(& Q_sb=Q_sa+Q_sy !Equation (16) (implicit in Bolla-Pittaluga et al. (2003)). sq_sb=Q_sb/B_b !make per unit width. - end subroutine nodal_point_relation_BollaPittaluga + end subroutine subroutine nodal_point_relation_data( & total_water_discharge_out, total_width_out, total_sediment_transport_out,idx_junctions,n_junctions,n_links_out,links_out,link_dir_out,width_out,water_discharge_out,flownode_junction,n_links_in,links_in,& @@ -2364,11 +2338,11 @@ subroutine nodal_point_relation_data( & end if !Initialize - total_water_discharge_out(:) = 0.0_dp - total_width_out(:) = 0.0_dp - total_sediment_transport_out(:, :) = 0.0_dp - width_out = 0.0_dp - water_discharge_out = 0.0_dp + total_water_discharge_out(:) = 0_dp + total_width_out(:) = 0_dp + total_sediment_transport_out(:, :) = 0_dp + width_out = 0_dp + water_discharge_out = 0_dp n_links_out=0 n_links_in=0 links_out=0 @@ -2401,7 +2375,7 @@ subroutine nodal_point_relation_data( & link_dir = sign(1, nd_mor(flownode_idx)%ln(ilink)) wb1d = wu_mor(link_junction) - if (u1(link_junction) * link_dir < 0.0_dp) then + if (u1(link_junction) * link_dir < 0_dp) then ! Outgoing discharge n_links_out(n_junctions)=n_links_out(n_junctions)+1 n_links=n_links_out(n_junctions) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 index e97b24836e2..272cc4f9004 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/compute_wave_forcing_rhs.f90 @@ -102,9 +102,8 @@ subroutine compute_wave_forcing_RHS() ! if (kmx == 0) then call tauwave() + call xbeach_flow_bc() end if - ! - call xbeach_flow_bc() end if ! ! Uniform wave field diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 index 47915e96241..b8bdcd16fb5 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/setwavfu.f90 @@ -45,18 +45,17 @@ subroutine setwavfu() use precision, only: dp use m_flowparameters, only: jawaveforces, wave_forces_off, jawave, wave_swan_online, wave_nc_offline, wave_surfbeat, epshu use m_flowgeom, only: lnx, lnx1d, ln, acl, csu, snu - use m_waves, only: m_waves_hminlw => hminlw, gammax, facmax, sxwav, sywav, sbxwav, sbywav, twav, fforc + use m_waves, only: m_waves_hminlw => hminlw, gammax, facmax, sxwav, sywav, sbxwav, sbywav, twav, hwav use m_xbeach_data, only: xb_hminlw => hminlw, gammaxxb use m_get_Lbot_Ltop, only: getlbotltop use m_flow, only: hu, huvli, wavfu, wavfv, rhomean, kmx use m_physcoef, only: sag - use precision_basics, only: comparereal implicit none integer :: L, LL, Lb, Lt real(kind=dp) :: wavfx, wavfy, wavfbx, wavfby - real(kind=dp) :: wavfu_loc, wavfbu_loc, twavL + real(kind=dp) :: wavfu_loc, wavfbu_loc, twavL, hwavL real(kind=dp) :: wavfv_loc, wavfbv_loc, wavfmag, wavfbmag, wavfang, wavfbang real(kind=dp) :: fmax, ac1, ac2, hminlwi, rhoL, hminlw, gammaloc @@ -146,6 +145,7 @@ subroutine setwavfu() ac1 = acL(LL) ac2 = 1.0_dp - ac1 ! + hwavL = max(ac1 * hwav(k1) + ac2 * hwav(k2), 0.01_dp) twavL = max(ac1 * twav(k1) + ac2 * twav(k2), 0.1_dp) fmax = facmax * hu(LL)**1.5 / twavL rhoL = rhomean @@ -159,6 +159,34 @@ subroutine setwavfu() wavfu(Lt) = sign(min(abs(wavfu_loc), fmax), wavfu_loc) / rhoL / max(hu(LL) - hu(Lt - 1), hminlw) ! top layer, as in D3D wavfv(Lt) = sign(min(abs(wavfv_loc), fmax), wavfv_loc) / rhoL / max(hu(LL) - hu(Lt - 1), hminlw) ! this limitation only works in sigma layers ! + ! The following is pretty inaccurate for limited nr of layers: + ! + !wavfuL = 4d0*sign(min(abs(wavfu_loc), fmax), wavfu_loc)/hwavL + !wavfvL = 4d0*sign(min(abs(wavfv_loc), fmax), wavfv_loc)/hwavL ! hwavL/4 is integral over 0.5*hwavL waterdepth of linear decrease + !! Check if first layer is thicker than 0.5*hrms + !! In that case, distribute over first layer + !dzu=hu(Lt)-hu(Lt-1) + !halfwav=0.5*hwavL + !! + !if (dzu > halfwav) then + ! wavfu(Lt) = wavfuL*0.25d0*hwavL/rhoL/dzu ! division by 0.5*hrms done above + ! wavfv(Lt) = wavfvL*0.25d0*hwavL/rhoL/dzu + !else + !zw=0.5d0*dzu + !do L=Lt,Lb+1,-1 + ! if (zw<=halfwav) then + ! wavfu(L) = wavfuL*(1d0-2d0*zw/hwavL)/rhoL ! division by 0.5*hrms done above + ! wavfv(L) = wavfvL*(1d0-2d0*zw/hwavL)/rhoL + ! zw = zw + 0.5*(hu(L)-hu(L-2)) + ! elseif (zw>halfwav .and. hu(L)>(hu(LL)-halfwav)) then ! partial layer + ! cc = 0.5*(hu(L)+(hu(LL)-halfwav)) ! replaced layer center + ! zw = hu(LL)-cc ! depth below surface + ! wavfu(L) = wavfuL*(1d0-zw/halfwav)/rhoL ! contribution over partial layer + ! wavfv(L) = wavfvL*(1d0-zw/halfwav)/rhoL + ! endif + !enddo + !endif + ! ! Body forces, uniform over depth ! wavfx = ac1 * sbxwav(k1) + ac2 * sbxwav(k2) @@ -171,9 +199,6 @@ subroutine setwavfu() end do end do end if - ! - wavfu = fforc * wavfu - wavfv = fforc * wavfv 1234 continue return end subroutine setwavfu diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeach_math_tools.F90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeach_math_tools.F90 index 22948a8a41d..6d937176c7f 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeach_math_tools.F90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeach_math_tools.F90 @@ -431,9 +431,6 @@ subroutine fftradix(array, ntotal, npass, nspan, inv, stat) if (stat /= 0) then return end if - ctmp = (0.0_fftkind, 0.0_fftkind) - sine = 0.0_fftkind - cosine= 0.0_fftkind call transform() deallocate (sine, cosine, STAT=stat) if (stat /= 0) then @@ -443,7 +440,6 @@ subroutine fftradix(array, ntotal, npass, nspan, inv, stat) if (stat /= 0) then return end if - perm = 0 call permute() deallocate (perm, ctmp, STAT=stat) if (stat /= 0) then @@ -451,13 +447,9 @@ subroutine fftradix(array, ntotal, npass, nspan, inv, stat) end if else allocate (ctmp(maxfactor), sine(maxfactor), cosine(maxfactor)) - ctmp = (0.0_fftkind, 0.0_fftkind) - sine = 0.0_fftkind - cosine= 0.0_fftkind call transform() deallocate (sine, cosine) allocate (perm(nperm)) - perm = 0 call permute() deallocate (perm, ctmp) end if diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 index d59ca13c157..b5ba7e86fc0 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/compute_waves/surfbeat/xbeachwaves.f90 @@ -237,7 +237,7 @@ subroutine xbeach_all_input() ARC = readkey_int(md_surfbeatfile, 'ARC', 1, 0, 1) order = readkey_dbl(md_surfbeatfile, 'order', 2.0_dp, 1.0_dp, 2.0_dp) freewave = readkey_int(md_surfbeatfile, 'freewave', 0, 0, 1) - !epsi = readkey_dbl (md_surfbeatfile,'epsi', -1._dp, -1._dp, 0.2_dp ) + !epsi = readkey_dbl (md_surfbeatfile,'epsi', -1.d0, -1.d0, 0.2d0 ) hminlw = readkey_dbl(md_surfbeatfile, 'hmin', 0.2_dp, 0.001_dp, 1.0_dp) allocate (allowednames(2), oldnames(0)) allowednames = ['abs_1d', 'abs_2d'] @@ -321,13 +321,13 @@ subroutine xbeach_all_input() !if (windmodel .eq. 1) then ! call writelog('l','','--------------------------------') ! call writelog('l','','Wind source parameters: ') - ! mwind = readkey_dbl (md_surfbeatfile,'mwind', 1._dp, 0.5_dp, 1._dp) + ! mwind = readkey_dbl (md_surfbeatfile,'mwind', 1.d0, 0.5d0, 1.d0) ! jawsource = readkey_int (md_surfbeatfile,'windsource', 0, 0, 1, required=(swave==1 .and. jawind==1), strict=.true.) ! jagradcg = readkey_int (md_surfbeatfile,'jagradcg', 1, 0, 1, required=((swave==1 .and. jawind==1) .and. jawsource==1), strict=.true.) ! advecmod = readkey_int (md_surfbeatfile,'advecmod', 1, 1, 2) - ! ndissip = readkey_dbl (md_surfbeatfile,'ndissip', 3._dp, 1._dp, 10._dp) - ! coefdispT = readkey_dbl (md_surfbeatfile,'coefdispT', 3.5_dp, 0._dp, 1000._dp) - ! coefdispk = readkey_dbl (md_surfbeatfile,'coefdispk', 1._dp, 0._dp, 1000._dp) + ! ndissip = readkey_dbl (md_surfbeatfile,'ndissip', 3.d0, 1.d0, 10.d0) + ! coefdispT = readkey_dbl (md_surfbeatfile,'coefdispT', 3.5d0, 0.d0, 1000.d0) + ! coefdispk = readkey_dbl (md_surfbeatfile,'coefdispk', 1.d0, 0.d0, 1000.d0) !endif ! ! @@ -384,7 +384,7 @@ subroutine xbeach_all_input() end if end if ! - !facmax = 0.25_dp*sqrt(ag)*rhomean*gamma**2 + !facmax = 0.25d0*sqrt(ag)*rhomean*gamma**2 ! ! ! Wave-current interaction with non-stationary waves still experimental @@ -471,7 +471,7 @@ subroutine xbeach_wave_init() !if (windmodel.eq.0) then do k = 1, ndx sigmwav(k) = sum(sigt(:, k), dim=1) / real(ntheta, kind=dp) - L0(k) = 2_dp * pi * ag / (sigmwav(k)**2) + L0(k) = 2 * pi * ag / (sigmwav(k)**2) L1(k) = L0(k) Ltemp(k) = L0(k) end do @@ -557,10 +557,10 @@ subroutine xbeach_wave_init() !if ( windmodel.eq.1) then ! if (jawsource.eq.1) then ! !define source term coefficients - ! CE1 = 8_dp/(aa1*aa1*bb1 ) * (16_dp/(aa1*aa1 ) )**(1_dp/(2_dp* bb1) -1_dp ) - ! CE2 = 1_dp/(2_dp* bb1) -1_dp - ! CT1 = 1_dp/(aa2*bb2 ) * (1_dp/(aa2 ) )**(1_dp/bb2 -1_dp ) - ! CT2 = 1_dp/bb2 -1_dp + ! CE1 = 8d0/(aa1*aa1*bb1 ) * (16d0/(aa1*aa1 ) )**(1d0/(2d0* bb1) -1d0 ) + ! CE2 = 1d0/(2d0* bb1) -1d0 + ! CT1 = 1d0/(aa2*bb2 ) * (1d0/(aa2 ) )**(1d0/bb2 -1d0 ) + ! CT2 = 1d0/bb2 -1d0 ! endif ! !map wind field to cell centers ! call xbeach_map_wind_field(wx, wy, mwind, wmagcc, windspreadfac) @@ -748,7 +748,7 @@ subroutine xbeach_makethetagrid() if (single_dir == 1) then do itheta = 1, ntheta_s - thetabin_s(itheta) = mod(thetamin + dtheta_s / 2.0_dp + dtheta_s * (itheta - 1), 2.0_dp * pi) + thetabin_s(itheta) = mod(thetamin + dtheta_s / 2.0 + dtheta_s * (itheta - 1), 2.0_dp * pi) end do do itheta = 1, ntheta_s @@ -909,7 +909,7 @@ subroutine xbeach_wave_instationary() allocate (gammax_correct(1:ndx), stat=ierr) xb_started = 1 - !ee_eps = 0.00001_dp + !ee_eps = 0.00001d0 !tt_eps = waveps !important to limit wave celerities to 1 in case of cells for which hsepshu) - ! DR = 2_dp*ag*beta1*R/cwav + ! DR = 2d0*ag*beta1*R/cwav !endwhere end if @@ -1407,7 +1407,7 @@ subroutine xbeach_wave_compute_flowforcing2D() k2 = ln(2, L) Fx(L) = (acL(L) * Fx_cc(k1) + (1.0_dp - acL(L)) * Fx_cc(k2)) Fy(L) = (acL(L) * Fy_cc(k1) + (1.0_dp - acL(L)) * Fy_cc(k2)) - !rhoL = (acL(L) * rho(k1) + (1.0_dp - acL(L)) * rho(k2)) + !rhoL = ( acL(L)*rho(k1) + (1d0-acL(L))*rho(k2) ) rhoL = rhomean wavfu(L) = (Fx(L) * csu(L) + Fy(L) * snu(L)) / (rhoL * max(hu(L), hminlw)) wavfv(L) = (-Fx(L) * snu(L) + Fy(L) * csu(L)) / (rhoL * max(hu(L), hminlw)) @@ -1585,7 +1585,7 @@ subroutine xbeach_wave_dispersion(callType) where (km > 0.01_dp) cwav = sigmwav / km cgwav = cwav * (0.5_dp + arg / sinh(2 * arg)) * sqrt(fac) ! & to include more - ! + km*(H/2)**2*sqrt(max(par%g*km*tanh(arg),0.001_dp))/sqrt(max(fac,0.001_dp)) ! include wave steepness + ! + km*(H/2)**2*sqrt(max(par%g*km*tanh(arg),0.001d0))/sqrt(max(fac,0.001d0)) ! include wave steepness nwav = 0.5_dp + km * hh / sinh(2 * max(km, 0.00001_dp) * hh) elsewhere cwav = sqrt(ag * epshu) @@ -1712,8 +1712,7 @@ subroutine xbeach_wave_bc() logical :: isRecomputed integer :: kb, ki, Lb, nw - integer :: LL1, LL2, n - integer, save :: lunfil ! used for trim(instat) == 'stat_table' + integer :: LL1, LL2, n, lunfil ierror = 1 if (.not. allocated(dist)) then @@ -2089,7 +2088,7 @@ subroutine xbeach_wave_bc() end if !if (windmodel .eq. 1) then - ! zbndw(:,n)=max(e01*E1/max(Emean,0.000001_dp)*min(time0/taper,1._dp),Eini) + ! zbndw(:,n)=max(e01*E1/max(Emean,0.000001d0)*min(time0/taper,1.d0),Eini) !else zbndw(:, n) = e01 * E1 / max(Emean, 0.000001_dp) * min(time0 / taper, 1.0_dp) !endif @@ -2272,7 +2271,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k break = trim(break) if (break == 'roelvink1') then ! Dissipation according to Roelvink (1993) - !H = sqrt(8._dp*E/rhomean/ag) + !H = sqrt(8.d0*E/rhomean/ag) H = hwav hr = hhw kmr = min(max(kwav, 0.01_dp), 100.0_dp) @@ -2312,7 +2311,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k gam = gamma end if - !H = sqrt(8._dp/rhomean/ag*E) + !H = sqrt(8.d0/rhomean/ag*E) H = hwav Hb = tanh(gam * kh / 0.88_dp) * (0.88_dp / max(kwav, 1.0e-10_dp)) R = Hb / max(H, 0.00001_dp) @@ -2321,7 +2320,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k D = 0.25_dp * alpha * f * rhomean * ag * (Hb**2 + H**2) * Qb elseif (break == 'roelvink2') then - !H = sqrt(8._dp*E/rhomean/ag) + !H = sqrt(8.d0*E/rhomean/ag) H = hwav hr = hhw hh = max(hs, waveps) @@ -2342,7 +2341,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k D = D / Trep * H / hh end if elseif (trim(break) == 'roelvink_daly') then - !H = sqrt(8._dp*E/rhomean/ag) + !H = sqrt(8.d0*E/rhomean/ag) H = hwav call advec_upw_bulk(thetamean, Qb, cwav, Qb_advec) ! first order upwind, with mean direction do k = 1, ndxi @@ -2363,7 +2362,7 @@ subroutine xbeach_wave_breaker_dissipation(dtmaxwav, break, waveps, hhw, kwav, k end if elseif (break == 'janssen') then ! Dissipation according to Janssen and Battjes (2007) - !H = sqrt(8._dp*E/rhomean/ag) + !H = sqrt(8.d0*E/rhomean/ag) H = hwav if (wci /= 0) then f = sigmwav / 2.0_dp / pi @@ -2622,13 +2621,13 @@ subroutine advec_dir(quan, veloc, advec) do itheta = 2, ntheta - 2 ctheta_between = 0.5_dp * (veloc(itheta, k) + veloc(itheta + 1, k)) if (ctheta_between > 0) then - eeup = 1.5_dp * quan(itheta, k) - 0.5_dp * quan(itheta - 1, k) + eeup = 1.5_dp * quan(itheta, k) - .5 * quan(itheta - 1, k) if (eeup < 0.0_dp) then eeup = quan(itheta, k) end if fluxtheta(itheta) = eeup * ctheta_between else - eeup = 1.5_dp * quan(itheta + 1, k) - 0.5_dp * quan(itheta + 2, k) + eeup = 1.5_dp * quan(itheta + 1, k) - .5 * quan(itheta + 2, k) if (eeup < 0.0_dp) then eeup = quan(itheta + 1, k) end if @@ -2641,7 +2640,7 @@ subroutine advec_dir(quan, veloc, advec) if (ctheta_between > 0) then fluxtheta(itheta) = quan(itheta, k) * ctheta_between else - eeup = 1.5_dp * quan(itheta + 1, k) - 0.5_dp * quan(itheta + 2, k) + eeup = 1.5_dp * quan(itheta + 1, k) - .5 * quan(itheta + 2, k) if (eeup < 0.0_dp) then eeup = quan(itheta + 1, k) end if @@ -2651,7 +2650,7 @@ subroutine advec_dir(quan, veloc, advec) itheta = ntheta - 1 ! only compute for itheta==ntheta-1 ctheta_between = .5 * (veloc(itheta + 1, k) + veloc(itheta, k)) if (ctheta_between > 0) then - eeup = 1.5_dp * quan(itheta, k) - 0.5_dp * quan(itheta - 1, k) + eeup = 1.5_dp * quan(itheta, k) - .5 * quan(itheta - 1, k) if (eeup < 0.0_dp) then eeup = quan(itheta, k) end if @@ -3355,7 +3354,7 @@ subroutine xbeach_absgen_bc() !if (windmodel .eq. 0) then factime = 1.0_dp / cats / Trep * dts !else - ! factime = 1_dp/cats/minval(sigmwav)/2_dp/pi*dts + ! factime = 1d0/cats/minval(sigmwav)/2d0/pi*dts !endif ! compute boundary-averaged velocities @@ -3756,13 +3755,13 @@ end subroutine borecharacter ! if (.not.allocated(wycc)) allocate(wycc(1:ndx), stat = ierr) ! if (.not.allocated(wdir)) allocate(wdir(1:ndx), stat = ierr) ! -! wxcc=0_dp -! wycc=0_dp -! wdir=0_dp -! wmagcc=0_dp -! dist2=0_dp -! dist0=0_dp -! windspreadfac=0_dp +! wxcc=0d0 +! wycc=0d0 +! wdir=0d0 +! wmagcc=0d0 +! dist2=0d0 +! dist0=0d0 +! windspreadfac=0d0 ! ! do L = 1, lnx ! interpolate face values to cell centered values ! k1 = ln(1,L); k2 = ln(2,L) @@ -3777,15 +3776,15 @@ end subroutine borecharacter ! do k = 1, ndx ! do itheta = 1,ntheta ! dist2(itheta, k)=(cos(thetabin(itheta)-wdir(k)))**mwind -! if(cos(thetabin(itheta)-wdir(k))<0._dp) then -! dist2(itheta,k)=0.0_dp +! if(cos(thetabin(itheta)-wdir(k))<0.d0) then +! dist2(itheta,k)=0.0d0 ! end if ! end do -! if (sum(dist2(:,k))>0._dp) then +! if (sum(dist2(:,k))>0.d0) then ! dist0 = dist2(:,k) ! windspreadfac(:,k) = (dist0/sum(dist0))/dtheta ! else -! windspreadfac(:,k)=0._dp +! windspreadfac(:,k)=0.d0 ! endif ! end do ! @@ -3840,9 +3839,9 @@ end subroutine borecharacter ! ierr = 1 ! ! allocate( gradcg( 1:ntheta, 1:ndx), stat = ierr) -! fE=0_dp; fT=0_dp; dE=0_dp; dT=0_dp; -! wsorE=0_dp; wsorT=0_dp; -! gradcg=0_dp; tgradcg=0_dp; gradcg=0_dp; +! fE=0d0; fT=0d0; dE=0d0; dT=0d0; +! wsorE=0d0; wsorT=0d0; +! gradcg=0d0; tgradcg=0d0; gradcg=0d0; ! ! ! ! velocity gradient operator @@ -3850,7 +3849,7 @@ end subroutine borecharacter ! ! do k = 1, ndxi ! -! dEful = (Tful / (4.0_dp * pi)) / (CE1 * Eful ** CE2) !d +! dEful = (Tful / (4.0d0 * pi)) / (CE1 * Eful ** CE2) !d ! ! do itheta = 1, ntheta ! @@ -3875,22 +3874,22 @@ end subroutine borecharacter ! wsorEdlss = min(dE , dEful) ! wsorTdlss = dT !max(dT,dTful) !windspreadfac(itheta,k) * dT * dtheta !max(dT , dTful) ! -! SwE(k)= max(wmagcc(k)**3 * rhomean * wsorEdlss, 0._dp) ! -! SwT(k)= max(wsorTdlss , 0._dp) ! +! SwE(k)= max(wmagcc(k)**3 * rhomean * wsorEdlss, 0.d0) ! +! SwT(k)= max(wsorTdlss , 0.d0) ! ! ! !distribute growth over the wave bins, add gradcg component and make dimensional ! ! if (jagradcg .eq. 1) then -! ! egradcg = max(-windspreadfac(itheta,k) * ee0(itheta,k) / windspreadfac(itheta,k) * bai(k) * gradcg(itheta,k) , 0_dp) ! * Etaper perhaps use gradcg(nodal)? -! egradcg(itheta,k) = max(- ee1(itheta, k) * bai(k) * gradcg(itheta,k) , 0._dp)! -! !tgradcg = max(-windspreadfac(itheta,k) * twopi / sigmwav(k) * bai(k) * gradcg(itheta,k) , 0_dp) +! ! egradcg = max(-windspreadfac(itheta,k) * ee0(itheta,k) / windspreadfac(itheta,k) * bai(k) * gradcg(itheta,k) , 0d0) ! * Etaper perhaps use gradcg(nodal)? +! egradcg(itheta,k) = max(- ee1(itheta, k) * bai(k) * gradcg(itheta,k) , 0.d0)! +! !tgradcg = max(-windspreadfac(itheta,k) * twopi / sigmwav(k) * bai(k) * gradcg(itheta,k) , 0d0) ! else -! egradcg(itheta,k) = 0._dp -! !tgardcg = 0._dp +! egradcg(itheta,k) = 0.d0 +! !tgardcg = 0.d0 ! endif ! -! wsorE(itheta,k) = max(windspreadfac(itheta,k) * SwE(k) + egradcg(itheta,k), 0._dp ) -! wsorT(itheta,k) = max(windspreadfac(itheta,k) * dtheta * SwT(k) , 0._dp ) +! wsorE(itheta,k) = max(windspreadfac(itheta,k) * SwE(k) + egradcg(itheta,k), 0.d0 ) +! wsorT(itheta,k) = max(windspreadfac(itheta,k) * dtheta * SwT(k) , 0.d0 ) ! ! enddo ! @@ -3925,16 +3924,16 @@ end subroutine borecharacter ! ! integer :: nwalls ! -! gradcg = 0_dp -! velocL = 0_dp -! cwuL = 0_dp +! gradcg = 0d0 +! velocL = 0d0 +! cwuL = 0d0 ! ! do L = 1,lnx ! upwind (supq) + limited high order (dsq), loop over link ! k1 = ln(1,L) ; k2 = ln(2,L) ! linker en rechtercelnr geassocieerd aan de links ! ! do itheta = 1,ntheta ! -! velocL = acL(L)*veloc(itheta,k1) + (1_dp-acL(L))*veloc(itheta,k2) +! velocL = acL(L)*veloc(itheta,k1) + (1d0-acL(L))*veloc(itheta,k2) ! ! cwuL = velocL * wu(L) * ( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) ! *au(L) met cwi: u1(L) + cg*( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) ! ! inproduct cgx*csu+cgy*snu @@ -3995,7 +3994,7 @@ end subroutine borecharacter ! real(kind=dp), dimension(ndx) , intent(in) :: kwav ! real(kind=dp), dimension(ndx) , intent(out) :: DtotT ! -! DtotT = - coefdispT * tanh(coefdispk * kwav) * 1._dp /(1._dp -ndissip) * (twopi) / sigmwav / sigmwav * cgwav * kwav / E * Df +! DtotT = - coefdispT * tanh(coefdispk * kwav) * 1.d0 /(1.d0 -ndissip) * (twopi) / sigmwav / sigmwav * cgwav * kwav / E * Df ! !1234 continue ! return @@ -4020,8 +4019,8 @@ end subroutine borecharacter ! ! allocate(Edls(1:ndx), Tdls(1:ndx), stat = ierr) ! -! Edls=ag / rhomean / wmagcc**4_dp * E -! Tdls=aa2*(16_dp* Edls / (aa1*aa1) )**(bb2/(2*bb1)) +! Edls=ag / rhomean / wmagcc**4d0 * E +! Tdls=aa2*(16d0* Edls / (aa1*aa1) )**(bb2/(2*bb1)) ! Tmaxdep = wmagcc * Tdls / ag ! !1234 continue @@ -4053,16 +4052,16 @@ end subroutine borecharacter ! ! integer :: nwalls ! -! advec = 0_dp +! advec = 0d0 ! do L = 1,lnx ! upwind (supq) + limited high order (dsq), loop over link ! k1 = ln(1,L) ; k2 = ln(2,L) ! linker en rechtercelnr geassocieerd aan de links ! ! do itheta = 1,ntheta -! velocL = acL(L)*veloc(itheta,k1) + (1_dp-acL(L))*veloc(itheta,k2) +! velocL = acL(L)*veloc(itheta,k1) + (1d0-acL(L))*veloc(itheta,k2) ! cwuL = velocL*( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) ! *au(L) met cwi: u1(L) + cg*( csu(L)*csx(itheta) + snu(L)*snx(itheta) ) ! ! inproduct cgx*csu+cgy*snu ! if (cwuL > 0) then ! -> ds1 ds2 -! k = k1 ; kd = k2 ; is = 1 ; half = 1_dp - acl(L) ; ip = 0 ! -> ku k kd +! k = k1 ; kd = k2 ; is = 1 ; half = 1d0 - acl(L) ; ip = 0 ! -> ku k kd ! else ! <- ds2 ds1 ! k = k2 ; kd = k1 ; is = -1 ; half = acl(L) ; ip = 3 ! <- kd k ku ! endif ! acL = linkse dx fractie van afstand tussen flownodes (slide 83) @@ -4088,7 +4087,7 @@ end subroutine borecharacter ! ! sl3 = slnup(3+ip,L) ! cf = dtmaxwav*abs(cwuL)*dxi(L) -! cf = half*max( 0_dp,1_dp-cf ) +! cf = half*max( 0d0,1d0-cf ) ! ds2 = quant(itheta,kd) - quant(itheta,k) ! ds1 = voorlopende slope, ds2 = eigen slope ! ds1 = (quant(itheta,k) - waku )*sl3 ! @@ -4181,12 +4180,12 @@ end subroutine borecharacter ! do k=1,ndxi ! if(hdisp(k).ge.waveps) then ! do itheta = 1,ntheta -! if (2*pi/L0t(itheta,k)*hdisp(k) > 5_dp) then +! if (2*pi/L0t(itheta,k)*hdisp(k) > 5d0) then ! Ltempt(itheta,k) = L0t(itheta,k) ! else -! !Ltempt(k) = (2_dp*pi*ag/(sigt(itheta,k)**2))*(1-exp(-(sigt(itheta,k)*sqrt(hdisp(k)/ag))**(5_dp/2_dp)))**(2_dp/5_dp) +! !Ltempt(k) = (2d0*pi*ag/(sigt(itheta,k)**2))*(1-exp(-(sigt(itheta,k)*sqrt(hdisp(k)/ag))**(5d0/2d0)))**(2d0/5d0) ! Ltempt(itheta,k) = iteratedispersion(L0t(itheta,k),Ltempt(itheta,k),pi,hdisp(k)) -! if (Ltempt(itheta,k)<0._dp) then ! this is an error from iteratedispersion +! if (Ltempt(itheta,k)<0.d0) then ! this is an error from iteratedispersion ! Ltempt(itheta,k) = -Ltempt(itheta,k) ! call writelog('lws','','Warning: no convergence in dispersion relation iteration at t = ', & ! time0) @@ -4215,8 +4214,8 @@ end subroutine borecharacter ! do itheta=1,ntheta ! kwavt(itheta,k) = 2*pi/max(L1t(itheta,k),waveps) ! cwavt(itheta,k) = sigt(itheta,k)/kwavt(itheta,k) -! kh = min(kwavt(itheta,k)*hdisp(k),10.0_dp) -! nwavt(itheta,k)=0.5_dp+kh/max(sinh(2_dp*kh),waveps) +! kh = min(kwavt(itheta,k)*hdisp(k),10.0d0) +! nwavt(itheta,k)=0.5d0+kh/max(sinh(2d0*kh),waveps) ! cgwavt(itheta,k)=cwavt(itheta,k)*nwavt(itheta,k) ! enddo ! end do @@ -4225,7 +4224,7 @@ end subroutine borecharacter ! hh=s1(k)-bl(k) ! if (hh 0) then - call realloc(frcu0, lnx, stat=ierr, fill=frcuni, keepexisting=.false.) - call aerr('frcu0(lnx)', ierr, lnx) - call realloc(dynveg, lnx, stat=ierr, fill=.false., keepexisting=.false.) - call aerr('dynveg(lnx)', ierr, lnx) - end if if (jarhoxu > 0 .or. jased > 0) then call realloc(rhou, lnkx, stat=ierr, fill=rhomean, keepexisting=.false.) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 index 0b82e635165..1705bf3fb43 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_flowinit.f90 @@ -681,7 +681,7 @@ subroutine set_floodfill_water_levels_based_on_sample_file() end subroutine set_floodfill_water_levels_based_on_sample_file -!> Insert friction coefficient by initial fields +!> sert friction coefficient by initial fields subroutine set_friction_coefficient_by_initial_fields() use m_flowgeom, only: lnx, lnx1D, kcu use m_flow, only: frcu, ifrcutp @@ -721,70 +721,9 @@ subroutine set_friction_coefficient_by_initial_fields() frcmax = frcu(link) end if end do - - call init_dynamic_vegetation_roughness() end subroutine set_friction_coefficient_by_initial_fields -!> initialize dynamic vegetation roughness - subroutine init_dynamic_vegetation_roughness - use m_flowgeom, only: lnx - use m_flow, only: frcu, frcu0, dynveg - use m_physcoef, only: frcumin, dynroughveg - use m_alloc - use unstruc_model, only: md_dynvegpol - use timespace_parameters, only: LOCTP_POLYGON_FILE - use timespace, only: selectelset_internal_links - use m_delpol - use MessageHandling - - implicit none - - integer, parameter :: MANNING = 1 - - integer :: link - integer :: ierr - integer :: k - integer :: pointscount - logical :: ex - - integer, dimension(:), allocatable :: kp - integer, dimension(:), allocatable :: kcsveg - - if (.not. dynroughveg) then - return - end if - - inquire (file=trim(md_dynvegpol), exist=ex) - if (.not. ex) then - call mess(LEVEL_WARN, 'No polygon found for dynamic vegetation update. Process switched off.') - dynroughveg = 0 - return - end if - - frcu0 = frcu - call realloc(kcsveg, lnx, stat=ierr, fill=0, keepExisting=.false.) - if (allocated(kp)) deallocate (kp) - allocate (kp(1:lnx)) - kp = 0 - ! find links inside polygon - call selectelset_internal_links(lnx, kp, pointscount, LOC_SPEC_TYPE=LOCTP_POLYGON_FILE, LOC_FILE=md_dynvegpol) - - do k = 1, pointscount - kcsveg(kp(k)) = 1 - end do - call delpol() - ! - do link = 1, lnx - if (frcu(link) > frcumin .and. kcsveg(link) > 0) then - dynveg(link) = .true. - else - dynveg(link) = .false. - end if - end do - - end subroutine init_dynamic_vegetation_roughness - !> set friction uniform value on links where_friction_is_not_set subroutine set_friction_uniform_value_on_links_where_friction_is_not_set() use m_flowparameters, only: jafrculin @@ -1412,7 +1351,7 @@ subroutine set_wave_modelling() if (jawave == CONST .and. .not. flow_without_waves) then hs = max(hs, 0.0_dp) - hwav = min(hwavuni, gammax * hs) + hwav = min(hwavcom, gammax * hs) call wave_uorbrlabda() if (kmx == 0) then if (jawavestokes > NO_STOKES_DRIFT) then diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 index 08c1d195d3c..81e5040f304 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/flow_sedmorinit.f90 @@ -54,7 +54,7 @@ subroutine flow_sedmorinit() use unstruc_files use m_flowgeom use m_flowtimes - use m_physcoef, only: rhomean, ag, vismol, dynroughveg + use m_physcoef, only: rhomean, ag, vismol use m_initsedtra, only: initsedtra use m_rdmorlyr, only: rdinimorlyr use fm_external_forcings_data, only: numfracs, nopenbndsect, openbndname, openbndlin, nopenbndlin @@ -472,6 +472,12 @@ subroutine flow_sedmorinit() end if call realloc(avalflux, [lnx, stmpar%lsedtot], stat=ierr, fill=0.0_dp, keepExisting=.false.) ! + ! Warn user if default wetslope is still 10.0 when using dune avalanching. Reset default to reasonable 1.0 in that case. + if (comparereal(stmpar%morpar%wetslope, 10.0_dp) == 0) then + call mess(LEVEL_WARN, 'unstruc::flow_sedmorinit - Dune avalanching is switched on. Default wetslope reset to 0.1 from 10.0') + stmpar%morpar%wetslope = 1.0e-1_dp + end if + ! ! Warn user if upperlimitssc is set icm with avalanching. This effectively removes sedimentation of the avalanching flux if set too strictly. if (comparereal(upperlimitssc, 1.0e6_dp) /= 0) then call mess(LEVEL_WARN, 'unstruc::flow_sedmorinit - Upper limit imposed on ssc. This will cause large mass errors icm avalanching. Check the mass error at the end of the run.') @@ -542,11 +548,6 @@ subroutine flow_sedmorinit() case default ! if 0, do nothing. end select - ! - if (dynroughveg > 0) then - if (allocated(cumes)) deallocate(cumes) - call realloc(cumes, lnx,stat=ierr,fill=0.0_dp, keepExisting=.false.) - end if 1234 return end subroutine flow_sedmorinit diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/setbobs.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/setbobs.f90 index 1829afa9522..3c951d008e4 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/setbobs.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/prepost/setbobs.f90 @@ -177,20 +177,21 @@ subroutine setbobs() ! and set blu, weigthed depth at u point cycle ! skip update of bobs for structures end if + n1 = ln(1, L) + n2 = ln(2, L) ! flow ref + k1 = lncn(1, L) + k2 = lncn(2, L) ! net ref + zn1 = zk(k1) + if (zn1 == dmiss) then + zn1 = zkuni + end if + zn2 = zk(k2) + if (zn2 == dmiss) then + zn2 = zkuni + end if + if (kcu(L) == 1) then ! 1D link - n1 = ln(1, L) - n2 = ln(2, L) ! flow ref - k1 = lncn(1, L) - k2 = lncn(2, L) ! net ref - zn1 = zk(k1) - if (zn1 == dmiss) then - zn1 = zkuni - end if - zn2 = zk(k2) - if (zn2 == dmiss) then - zn2 = zkuni - end if if (ibedlevtyp == BEDLEV_TYPE_WATERLEVEL .or. ibedlevtyp == BEDLEV_TYPE_WATERLEVEL6) then ! tegeldieptes celcentra ! TODO: [TRUNKMERGE] WO/BJ: do we need stm_included in this if (consistent?) if (stm_included) then bl1 = bl(n1) diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 index 1623746db29..dc8f2502427 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 @@ -817,13 +817,13 @@ function init_meteo_forcings(block_ptr, base_dir, file_name, group_name) result( case ('qext') ! Only time-independent sample file supported for now: sets Qext initially and this remains constant in time. if (jaQext == 0) then - write (msgbuf, '(5a)') 'quantity '''//trim(quantity)//' in file ''', file_name, ''': [', group_name, & + write (msgbuf, '(a)') 'quantity '''//trim(quantity)//' in file ''', file_name, ''': [', group_name, & '] is missing QExt=1 in MDU.' call err_flush() return end if if (.not. strcmpi(forcing_file_type, 'sample')) then - write (msgbuf, '(7a)') 'Unknown forcingFileType '''//trim(forcing_file_type)//' in file ''', file_name, & + write (msgbuf, '(a)') 'Unknown forcingFileType '''//trim(forcing_file_type)//' in file ''', file_name, & ''': [', group_name, '], quantity=', trim(quantity), '.' call err_flush() return diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 index d41a0c40772..992efb2dc51 100644 --- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 +++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/meteo1.f90 @@ -2934,9 +2934,9 @@ subroutine selectelset_internal_links(lnx, keg, numg, & !inputs integer, intent(in) :: lnx !< Number of flow links in input. (Currently unused). - integer, intent(out) :: keg(:) !< Output array containing the flow link numbers that were selected. kp + integer, intent(out) :: keg(:) !< Output array containing the flow link numbers that were selected. !< Size of array is responsability of call site, and filling starts at index 1 upon each call. - integer, intent(out) :: numg !< Number of flow links that were selected (i.e., keg(1:numg) will be filled). nump + integer, intent(out) :: numg !< Number of flow links that were selected (i.e., keg(1:numg) will be filled). integer, intent(in) :: loc_spec_type !< Type of spatial input for selecting nodes. One of: LOCTP_POLYGON_FILE, LOCTP_POLYLINE_FILE, LOCTP_POLYGON_XY , LOCTP_POLYLINE_XY, LOCTP_BRANCHID_CHAINAGE or LOCTP_CONTACTID. character(len=*), optional, intent(in) :: loc_file !< (Optional) File name of a polyline file (when loc_spec_type==LOCTP_POLYGON_FILE). integer, optional, intent(in) :: nump !< (Optional) Number of points in polyline coordinate arrays xpin and ypin (when loc_spec_type==LOCTP_POLYGON_XY/LOCTP_POLYLINE_XY). diff --git a/src/third_party_open/swan/src/swancom1.F b/src/third_party_open/swan/src/swancom1.F index fe69cfc9860..aa4da550773 100644 --- a/src/third_party_open/swan/src/swancom1.F +++ b/src/third_party_open/swan/src/swancom1.F @@ -6047,8 +6047,7 @@ SUBROUTINE SINTGRL(SPCDIR ,KWAVE ,AC2 , 40.02 ! ! --- calculate fraction of breakers ! - QB(KCGRD(1)) = 0. JRE - IF ( ETOT .GT. 0. .AND. ISURF.GT.0) THEN JRE + IF ( ETOT .GT. 0. ) THEN ! ! --- calculate Qb when BJ78 breaker is activated ! From d43da29d6af52070ec0a2532d3bd88c6f96a52b7 Mon Sep 17 00:00:00 2001 From: hrajagers Date: Thu, 16 Apr 2026 17:11:17 +0200 Subject: [PATCH 17/18] consistently use fp arguments to build both for fp=dp and fp=sp. --- .../morphology/packages/morphology_kernel/src/trab19.f90 | 2 +- .../morphology/packages/morphology_kernel/src/trab20.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 index 9b77d88f699..c580b22ffa5 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 @@ -123,7 +123,7 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h ag = par(1) delta = par(4) facua = par(11) - if (comparereal(facua, 0.0_fp, 1d-10) == 0) then + if (comparereal(facua, 0.0_fp, 1e-10_fp) == 0) then facas = par(12) facsk = par(13) else diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 index 97fd45793c0..c1ceb45b405 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 @@ -120,7 +120,7 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h ag = par(1) delta = par(4) facua = par(11) - if (comparereal(facua, 0.0_fp, 1d-10) == 0) then + if (comparereal(facua, 0.0_fp, 1e-10_fp) == 0) then facas = par(12) facsk = par(13) else From 56af017c8758f7ea2788b29e58a54e936bc6c454 Mon Sep 17 00:00:00 2001 From: hrajagers Date: Fri, 17 Apr 2026 11:25:16 +0200 Subject: [PATCH 18/18] updates based on review --- .../morphology_kernel/src/bedtr2004.f90 | 12 +- .../morphology_kernel/src/calseddf1993.f90 | 2 +- .../packages/morphology_kernel/src/trab19.f90 | 125 +++++++++--------- .../packages/morphology_kernel/src/trab20.f90 | 114 ++++++++-------- 4 files changed, 131 insertions(+), 122 deletions(-) diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/bedtr2004.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/bedtr2004.f90 index 356c55f7d9d..b5fe9e23128 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/bedtr2004.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/bedtr2004.f90 @@ -390,18 +390,22 @@ subroutine bedtr2004(u2dh ,d50 ,d90 ,h1 ,rhosol , & do k = num_layers_grid, 1, -1 dif_aks = aks/h1 - (1.0_fp+sig(k)-thick(k)/2.0_fp) dif_upp = 3.0_fp*deltas/h1 - (1.0_fp+sig(k)-thick(k)/2.0_fp) - if (k >= 2 .and. dif_aks<=thick(k) .and. dif_aks>=0.0_fp) then + if (dif_aks<=thick(k) .and. dif_aks>=0.0_fp) then ! ! k-layer contains aks (take part above) ! - if (concin(k-1)<1.0e-6_fp .or. concin(k)<1.0e-6_fp) then - ceavg = ceavg + concin(k)*(1.0_fp-dif_aks/thick(k))*thick(k)*h1 + if (dif_upp <= thick(k)) then ! this must be true if k = 1 since aks < 3*deltas < h1 + ! k-layer contains also 3*deltas (take part below) + ceavg = ceavg + concin(k)*(dif_upp-dif_aks)*h1 + exit + elseif (concin(k-1)<1.0e-6_fp .or. concin(k)<1.0e-6_fp) then + ceavg = ceavg + concin(k)*(thick(k)-dif_aks)*h1 else rpower = log(concin(k-1)/concin(k)) / log( (h1*(1.0_fp+sig(k ))*(h1-h1*(1.0_fp+sig(k-1)))) & & / (h1*(1.0_fp+sig(k-1))*(h1-h1*(1.0_fp+sig(k )))) ) z = ((1.0_fp+sig(k)+0.5_fp*thick(k))*h1 + aks) / 2.0_fp ceavgtmp = concin(k) * ((h1*(1.0_fp+sig(k))*(h1-z))/(z*(h1-h1*(1.0_fp+sig(k)))))**rpower - ceavg = ceavg + ceavgtmp*(1.0_fp-dif_aks/thick(k))*thick(k)*h1 + ceavg = ceavg + ceavgtmp*(thick(k)-dif_aks)*h1 endif elseif (dif_aks<=0.0_fp .and. dif_upp>=0.0_fp) then ! diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/calseddf1993.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/calseddf1993.f90 index 1a28edab0a8..5ad0fadb580 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/calseddf1993.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/calseddf1993.f90 @@ -94,7 +94,7 @@ subroutine calseddf1993(ustarc ,ws ,h1 ,num_layers_grid ,s if (ltur==0 .or. ltur==1 .or. difvr) then ! ! if algebraic or K-L turbulence model or difvr = .true. then - ! calculate sediment mixing according to Van Rijn based on Coleman's + ! calculate sediment mixing according to Van Rijn, using Coleman's ! parabolic-linear mixing distribution for current-related mixing ! ! set vertical sediment mixing values for waves and currents at water surface diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 index c580b22ffa5..50fccf9f247 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab19.f90 @@ -24,15 +24,12 @@ ! Stichting Deltares. All rights reserved. ! !------------------------------------------------------------------------------- -! -! + !> computes sediment transport according to the transport formula of Van Thiel / Van Rijn (2008) subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h ,tp , & & d50 ,d15 ,d90 ,npar ,par ,dzbdt ,vicmol , & & poros ,chezy ,dzdx ,dzdy ,sbotx ,sboty ,cesus , & & ua ,va ,ubot ,kwtur ,ubot_from_com ) -!!--pseudo code and references-------------------------------------------------- -! NONE !!--declarations---------------------------------------------------------------- use precision use mathconsts @@ -49,17 +46,17 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h real(fp) , intent(in) :: d50 real(fp) , intent(in) :: d90 real(fp) , intent(in) :: dzbdt !< Erosion/sedimentation velocity - real(fp) , intent(in) :: dzdx - real(fp) , intent(in) :: dzdy + real(fp) , intent(in) :: dzdx + real(fp) , intent(in) :: dzdy real(fp) :: h real(fp) :: hrms real(fp) , intent(in) :: kwtur !< Breaker induced turbulence real(fp), dimension(npar), intent(in) :: par real(fp) , intent(in) :: poros - real(fp) , intent(in) :: rlabda - real(fp) , intent(in) :: teta - real(fp) :: tp - real(fp) , intent(in) :: ubot + real(fp) , intent(in) :: rlabda + real(fp) , intent(in) :: teta + real(fp) :: tp + real(fp) , intent(in) :: ubot real(fp) , intent(in) :: u real(fp) , intent(in) :: v real(fp) , intent(in) :: vicmol @@ -74,6 +71,7 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h ! real(fp), parameter :: DTOL = 1e-6_fp real(fp), parameter :: ONETHIRD = 1.0_fp/3.0_fp + real(fp), parameter :: D50_REF = 0.000225_fp !< Reference sand diameter [m] integer :: waveform integer :: dilatancy @@ -90,16 +88,16 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h real(fp) :: cmax real(fp) :: reposeangle real(fp) :: rheea - real(fp) :: cf - real(fp) :: utot - real(fp) :: uamag - real(fp) :: phi - real(fp) :: b2 - real(fp) :: ucrw - real(fp) :: ucrc - real(fp) :: dster + real(fp) :: cf + real(fp) :: utot !< Velocity magnitude + real(fp) :: uamag + real(fp) :: phi + real(fp) :: b2 + real(fp) :: ucrw + real(fp) :: ucrc + real(fp) :: dster real(fp) :: ucr - real(fp) :: urms + real(fp) :: urms real(fp) :: urms2 real(fp) :: ucrb, ucrs, asb, ass, term1, ceqb, ceqs real(fp) :: cmax2h @@ -120,6 +118,7 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h if ( utot < DTOL .or. h > 200.0_fp .or. h < 0.01_fp ) return ! ! Initialisations + ! ag = par(1) delta = par(4) facua = par(11) @@ -152,7 +151,7 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h if (.not. (dilatancy==1 .or. dilatancy==0)) dilatancy = 0 ! default off rheea = max(min(rheea,2.0_fp),0.75_fp) pormax = max(min(pormax,0.6_fp),poros) - if (.not. (bedslpeffini==0 .or. bedslpeffini==1 .or. bedslpeffini==2)) bedslpeffini=0 + if (.not. (bedslpeffini==0 .or. bedslpeffini==1 .or. bedslpeffini==2)) bedslpeffini=0 smax = max(min(smax,3.0_fp),-1.0_fp) if (smax<0.0_fp) smax=huge(0.0_fp)*1.0e-20_fp reposeangle = max(min(reposeangle,45.0_fp),30.0_fp) @@ -173,54 +172,54 @@ subroutine trab19(u ,v ,hrms ,rlabda ,teta ,h dster=(delta*ag/1e-12_fp)**onethird*d50 ! 1e-12 = nu**2 ! if(d50<=0.0005_fp) then - Ucrc=0.19_fp*d50**0.1_fp*log10(4.0_fp*h/d90) !Shields - Ucrw=0.24_fp*(delta*ag)**0.66_fp*d50**0.33_fp*tp**0.33_fp !Komar and Miller (1975) + Ucrc=0.19_fp*d50**0.1_fp*log10(4.0_fp*h/d90) ! Shields + Ucrw=0.24_fp*(delta*ag)**0.66_fp*d50**0.33_fp*tp**0.33_fp ! Komar and Miller (1975) else if(d50<=0.002_fp) then - Ucrc=8.5_fp*d50**0.6_fp*log10(4.0_fp*h/d90) !Shields - Ucrw=0.95_fp*(delta*ag)**0.57_fp*d50**0.43_fp*tp**0.14_fp !Komar and Miller (1975) + Ucrc=8.5_fp*d50**0.6_fp*log10(4.0_fp*h/d90) ! Shields + Ucrw=0.95_fp*(delta*ag)**0.57_fp*d50**0.43_fp*tp**0.14_fp ! Komar and Miller (1975) else if(d50>0.002_fp) then - Ucrc=1.3_fp*sqrt(delta*ag*d50)*(h/d50)**(0.5_fp*onethird) !Maynord (1978) --> also Neill (1968) where 1.3_fp = 1.4_fp - Ucrw=0.95_fp*(delta*ag)**0.57_fp*d50**0.43_fp*tp**0.14_fp !Komar and Miller (1975) + Ucrc=1.3_fp*sqrt(delta*ag*d50)*(h/d50)**(0.5_fp*onethird) ! Maynord (1978) --> also Neill (1968) where 1.3_fp = 1.4_fp + Ucrw=0.95_fp*(delta*ag)**0.57_fp*d50**0.43_fp*tp**0.14_fp ! Komar and Miller (1975) end if B2 = utot/max(utot+sqrt(urms2),5e-3_fp) - Ucr = B2*Ucrc + (1.0_fp-B2)*Ucrw !Van Rijn 2007 (Bed load transport paper) + Ucr = B2*Ucrc + (1.0_fp-B2)*Ucrw ! Van Rijn 2007 (Bed load transport paper) ! call calculate_critical_velocities(dilatancy, bedslpeffini, dzbdt, ag, vicmol, d15, poros, pormax, rheea, delta, u, v, & dzdx, dzdy, dtol, phi, ucr, ucrb, Ucrs) - ! - ! transport parameters - Asb=0.015_fp*h*(d50/h)**1.2_fp/(delta*ag*d50)**0.75_fp !bed load coefficient - Ass=0.012_fp*d50*dster**(-0.6_fp)/(delta*ag*d50)**1.2_fp !suspended load coefficient - ! - ! Van Rijn use Peak orbital flow velocity --> 0.64 corresponds to 0.4 coefficient regular waves Van Rijn (2007) - term1=utot**2+0.64_fp*sws*urms2 - ! reduce sediment suspensions for (inundation) overwash conditions with critical flow velocities - term1=min(term1,smax*ag/max(cf,1e-10_fp)*d50*delta) - term1=sqrt(term1) - ! - if(term1>Ucrb .and. h>dtol) then - ceqb = Asb*(term1-Ucrb)**1.5_fp - else - ceqb = 0.0_fp - end if - if(term1>Ucrs .and. h>dtol) then - ceqs = Ass*(term1-Ucrs)**2.4_fp - else - ceqs = 0.0_fp - end if - ! - if (alfad50 > 0.0_fp) then - ceqb = ceqb * (0.000225_fp/d50)**alfad50 - ceqs = ceqs * (0.000225_fp/d50)**alfad50 - endif - ! - cmax2h = cmax*h/2.0_fp - ceqb = min(ceqb, cmax2h) ! maximum equilibrium bed concentration - cesus = min(ceqs, cmax2h)/h ! m2/s/m*s/m = [-], and times rhosol in eqtran - ua = uamag*cos(teta*degrad) - va = uamag*sin(teta*degrad) - sbotx = (u+ua)*ceqb ! m2/s - sboty = (v+va)*ceqb - ! - 999 continue + ! + ! transport parameters + Asb=0.015_fp*h*(d50/h)**1.2_fp/(delta*ag*d50)**0.75_fp ! bed load coefficient + Ass=0.012_fp*d50*dster**(-0.6_fp)/(delta*ag*d50)**1.2_fp ! suspended load coefficient + ! + ! Van Rijn use Peak orbital flow velocity --> 0.64 corresponds to 0.4 coefficient regular waves Van Rijn (2007) + term1=utot**2+0.64_fp*sws*urms2 + ! reduce sediment suspensions for (inundation) overwash conditions with critical flow velocities + term1=min(term1,smax*ag/max(cf,1e-10_fp)*d50*delta) + term1=sqrt(term1) + ! + if(term1>Ucrb .and. h>dtol) then + ceqb = Asb*(term1-Ucrb)**1.5_fp + else + ceqb = 0.0_fp + end if + if(term1>Ucrs .and. h>dtol) then + ceqs = Ass*(term1-Ucrs)**2.4_fp + else + ceqs = 0.0_fp + end if + ! + if (alfad50 > 0.0_fp) then + ceqb = ceqb * (D50_REF/d50)**alfad50 + ceqs = ceqs * (D50_REF/d50)**alfad50 + endif + ! + cmax2h = cmax*h/2.0_fp + ceqb = min(ceqb, cmax2h) ! maximum equilibrium bed concentration + cesus = min(ceqs, cmax2h)/h ! maximum equilibrium suspended concentration [m2/s/m*s/m] = [-], and times rhosol in eqtran + ua = uamag*cos(teta*degrad) + va = uamag*sin(teta*degrad) + sbotx = (u+ua)*ceqb ! [m2/s] + sboty = (v+va)*ceqb + ! + 999 continue end subroutine trab19 diff --git a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 index c1ceb45b405..de7d7edc896 100644 --- a/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 +++ b/src/utils_gpl/morphology/packages/morphology_kernel/src/trab20.f90 @@ -24,8 +24,6 @@ ! Stichting Deltares. All rights reserved. ! !------------------------------------------------------------------------------- -! -! !> computes sediment transport according to the transport formula of Soulsby / Van Rijn, XBeach flavour subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h ,tp , & @@ -48,17 +46,17 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h real(fp) , intent(in) :: d50 real(fp) , intent(in) :: d90 real(fp) , intent(in) :: dzbdt !< Erosion/sedimentation velocity - real(fp) , intent(in) :: dzdx + real(fp) , intent(in) :: dzdx real(fp) , intent(in) :: dzdy real(fp) :: h real(fp) :: hrms real(fp) , intent(in) :: kwtur !< Breaker induced turbulence real(fp), dimension(npar), intent(in) :: par real(fp) , intent(in) :: poros - real(fp) , intent(in) :: rlabda - real(fp) , intent(in) :: teta - real(fp) :: tp - real(fp) , intent(in) :: ubot + real(fp) , intent(in) :: rlabda + real(fp) , intent(in) :: teta + real(fp) :: tp + real(fp) , intent(in) :: ubot real(fp) , intent(in) :: u real(fp) , intent(in) :: v real(fp) , intent(in) :: vicmol @@ -73,6 +71,7 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h ! real(fp), parameter :: DTOL = 1e-6_fp real(fp), parameter :: ONETHIRD = 1.0_fp/3.0_fp + real(fp), parameter :: D50_REF = 0.000225_fp !< Reference sand diameter [m] integer :: waveform integer :: dilatancy @@ -91,11 +90,11 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h real(fp) :: rheea real(fp) :: cf real(fp) :: utot !< Velocity magnitude - real(fp) :: uamag - real(fp) :: phi - real(fp) :: dster - real(fp) :: ucr - real(fp) :: urms + real(fp) :: uamag + real(fp) :: phi + real(fp) :: dster + real(fp) :: ucr + real(fp) :: urms real(fp) :: urms2 real(fp) :: ucrb, ucrs, asb, ass, term1, ceqb, ceqs real(fp) :: z0 @@ -106,12 +105,14 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h ! !! executable statements ------------------------------------------------------- ! + ! + ! Initialize Transports to zero + ! sbotx = 0.0_fp sboty = 0.0_fp - cesus = 0.0_fp ua = 0.0_fp va = 0.0_fp - + cesus = 0.0_fp utot = sqrt(u**2 + v**2) if ( utot < DTOL .or. h > 200.0_fp .or. h < 0.01_fp ) return ! @@ -150,7 +151,7 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h if (.not. (dilatancy==1 .or. dilatancy==0)) dilatancy = 0 ! default off rheea = max(min(rheea,2.0_fp),0.75_fp) pormax = max(min(pormax,0.6_fp),poros) - if (.not. (bedslpeffini==0 .or. bedslpeffini==1 .or. bedslpeffini==2)) bedslpeffini=0 + if (.not. (bedslpeffini==0 .or. bedslpeffini==1 .or. bedslpeffini==2)) bedslpeffini=0 smax = max(min(smax,3.0_fp),-1.0_fp) if (smax<0.0_fp) smax=huge(0.0_fp)*1.0e-20_fp reposeangle = max(min(reposeangle,45.0_fp),30.0_fp) @@ -162,54 +163,59 @@ subroutine trab20(u ,v ,hrms ,rlabda ,teta ,h ! call calculate_urms(hrms, tp, h, ag, ubot_from_com, ubot, kwtur, urms, urms2) ! + ! velocity asymmetry + ! call calculate_velocity_asymmetry(waveform, facas, facsk, sws, h, hrms, rlabda, ag, tp, urms, uamag) ! + ! Velocity magnitude + ! phi = reposeangle*degrad ! Angle of internal friction dster=(delta*ag/1e-12_fp)**onethird*d50 ! 1e-12 = nu**2 ! if(d50<=0.0005_fp) then Ucr=0.19_fp*d50**0.1_fp*log10(4.0_fp*h/d90) - else + else Ucr=8.5_fp*d50**0.6_fp*log10(4.0_fp*h/d90) - end if + end if ! call calculate_critical_velocities(dilatancy, bedslpeffini, dzbdt, ag, vicmol, d15, poros, pormax, rheea, delta, u, v, & dzdx, dzdy, dtol, phi, ucr, ucrb, Ucrs) - ! - ! drag coefficient - Cd=(0.40_fp/(log(max(h,10.0_fp*z0)/z0)-1.0_fp))**2 - ! - ! transport parameters - Asb=0.005_fp*h*(d50/h/(delta*ag*d50))**1.2_fp ! bed load coefficient - Ass=0.012_fp*d50*dster**(-0.6_fp)/(delta*ag*d50)**1.2_fp ! suspended load coefficient - ! - term1=utot**2+0.018_fp/Cd*sws*urms2 - ! - term1=min(term1,smax*ag/cf*d50*delta) - term1=sqrt(term1) - ! - ceqb = 0.0_fp - ceqs = 0.0_fp - ! - if(term1>Ucrb .and. h>dtol) then - ceqb=Asb*(term1-Ucrb)**2.4_fp - end if - if(term1>Ucrs .and. h>dtol) then - ceqs=Ass*(term1-Ucrs)**2.4_fp - end if - ! - if (alfad50 > 0.0_fp) then - ceqb = ceqb * (0.000225_fp/d50)**alfad50 - ceqs = ceqs * (0.000225_fp/d50)**alfad50 - endif - ! - cmax2h = cmax*h/2.0_fp - ceqb = min(ceqb, cmax2h) ! maximum equilibrium bed concentration - cesus = min(ceqs, cmax2h)/h ! maximum equilibrium suspended concentration - ua = uamag*cos(teta*degrad) - va = uamag*sin(teta*degrad) - sbotx = (u+ua)*ceqb - sboty = (v+va)*ceqb - ! - 999 continue + ! + ! drag coefficient + Cd=(0.40_fp/(log(max(h,10.0_fp*z0)/z0)-1.0_fp))**2 + ! + ! transport parameters + Asb=0.005_fp*h*(d50/h/(delta*ag*d50))**1.2_fp ! bed load coefficient + Ass=0.012_fp*d50*dster**(-0.6_fp)/(delta*ag*d50)**1.2_fp ! suspended load coefficient + ! + term1=utot**2+0.018_fp/Cd*sws*urms2 + ! + term1=min(term1,smax*ag/cf*d50*delta) + term1=sqrt(term1) + ! + if(term1>Ucrb .and. h>dtol) then + ceqb = Asb*(term1-Ucrb)**2.4_fp + else + ceqb = 0.0_fp + end if + if(term1>Ucrs .and. h>dtol) then + ceqs = Ass*(term1-Ucrs)**2.4_fp + else + ceqs = 0.0_fp + end if + ! + if (alfad50 > 0.0_fp) then + ceqb = ceqb * (D50_REF/d50)**alfad50 + ceqs = ceqs * (D50_REF/d50)**alfad50 + endif + ! + cmax2h = cmax*h/2.0_fp + ceqb = min(ceqb, cmax2h) ! maximum equilibrium bed concentration + cesus = min(ceqs, cmax2h)/h ! maximum equilibrium suspended concentration [m2/s/m*s/m] = [-], and times rhosol in eqtran + ua = uamag*cos(teta*degrad) + va = uamag*sin(teta*degrad) + sbotx = (u+ua)*ceqb ! [m2/s] + sboty = (v+va)*ceqb + ! + 999 continue end subroutine trab20