diff --git a/.gitignore b/.gitignore index 04acf563a..028a42412 100644 --- a/.gitignore +++ b/.gitignore @@ -65,12 +65,16 @@ source/third_party_open/netcdf/x64 source/sfincs/sfincs.opt.yaml /source/sfincs_lib/*.yaml /source/third_party_open/netcdf/netcdf-fortran-4.6.1/Debug + +# Local Claude Code agents / settings (not shared with co-developers) +.claude/ +# Sphinx build output +/docs/_build /source/build_nvfortran_gpu_h7.sh /source/build_nvfortran_gpu.sh /source/Singularityfile-gpu.def /source/Dockerfile.xpu -/source/Dockerfile.gpu.test /source/Dockerfile.gpu.update01 -/source/Dockerfile.gpu +/source/Dockerfile.gpu.test /source/Dockerfile.gpu.25.5.ccall -/docs/_build +/source/Dockerfile.gpu diff --git a/docs/index.rst b/docs/index.rst index 5b740dcb0..fb11ce5e1 100644 --- a/docs/index.rst +++ b/docs/index.rst @@ -103,10 +103,11 @@ The SFINCS team also includes Koen van Asselt, Tycho Bovenschen, Ap van Dongeren :maxdepth: 3 :hidden: :caption: User manual: - + input input_forcing - input_structures + input_structures + input_urban_drainage .. toctree:: :maxdepth: 3 diff --git a/docs/input.rst b/docs/input.rst index 755da9746..05fab9d18 100644 --- a/docs/input.rst +++ b/docs/input.rst @@ -1,5 +1,5 @@ -User manual - general -===== +General +======= Overview ----- @@ -359,14 +359,37 @@ SFINCS allows the specification of the following options for accounting for infi 3. The Curve Number method: empirical rainfall-runoff model 4. The Green-Ampt method: empirical rainfall-runoff model 5. The Horton infiltration method +6. The bucket model: linear reservoir with losses -Infiltration is specified with either constant in time values in mm/hr (both uniform and spatially varying), or using more detailed parameters for the Curve Number method, The Green-Ampt method or Horton method. +Spatially uniform infiltration is still specified directly in sfincs.inp with ``qinf``. All modern spatially varying infiltration and bucket-model input should be provided through ``infiltrationfile`` together with ``infiltrationtype``. The older binary keywords (``qinffile``, ``scsfile``, ``smaxfile``, ``sefffile``, ``ksfile``, ``psifile``, ``sigmafile``, ``f0file``, ``fcfile`` and ``kdfile``) remain available for backward compatibility only and should be removed in a future cleanup. **NOTE - Infiltration in SFINCS is only turned on when any rainfall is forced** **NOTE - Infiltration methods in SFINCS are not designed to be stacked** +NetCDF infiltration input (recommended): +%%%%% + +For all spatially varying infiltration methods the recommended interface is: + +.. code-block:: text + + infiltrationfile = sfincs.infiltration.nc + infiltrationtype = c2d | cna | cnb | gai | hor | bkt + +The required variables in ``infiltrationfile`` depend on ``infiltrationtype``: + +* ``c2d``: ``qinf`` +* ``cna``: ``scs`` +* ``cnb``: ``smax``, ``seff``, ``ks`` +* ``gai``: ``psi``, ``sigma``, ``ks`` +* ``hor``: ``f0``, ``fc``, ``kd`` +* ``bkt``: ``bucket_smax``, ``bucket_k``, ``bucket_loss`` + +The older separate binary infiltration keywords are still supported for backward compatibility only. The former separate inputs ``bucketfile`` and ``bucket_loss_frac`` have been removed; for the bucket model, all required variables must now be present in ``infiltrationfile``. + + Spatially uniform constant in time: %%%%% @@ -383,7 +406,7 @@ Specify the keyword: Spatially varying constant in time: %%%%% -For spatially varying infiltration values per cell use the qinffile option, with the same grid based input as the depfile using a binary file. +For spatially varying infiltration values per cell use ``infiltrationfile`` with ``infiltrationtype = c2d``. The ``qinffile`` option below is kept for backward compatibility only and should be removed in a future cleanup. **qinffile = sfincs.qinf** @@ -426,7 +449,7 @@ where Smax = the soil's maximum moisture storage capacity. Smax typically derive **Without recovery** -For spatially varying infiltration values per cell using the Curve Number method without recovery use the scsfile option, with the same grid based input as the depfile using a binary file. Note here that in pre-processing the wanted CN values should be converted to S values following: +For spatially varying infiltration values per cell using the Curve Number method without recovery use ``infiltrationfile`` with ``infiltrationtype = cna``. The ``scsfile`` option below is kept for backward compatibility only and should be removed in a future cleanup. Note here that in pre-processing the wanted CN values should be converted to S values following: * scsfile: maximum soil moisture storage capacity in inches .. code-block:: text @@ -458,7 +481,7 @@ This option doesn't support restart functionality. **With recovery** -Within SFINCS, the Curve number method with recovery can be used as follows. The user needs to provide the following variables. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: +Within SFINCS, the Curve number method with recovery is preferably supplied through ``infiltrationfile`` with ``infiltrationtype = cnb``. The separate binary files listed below are kept for backward compatibility only. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: * smaxfile: maximum soil moisture storage capacity in m * sefffile: soil moisture storage capacity at the start in m @@ -498,7 +521,7 @@ The basic form of the Green-Ampt equation is expressed as follows: In which t is time, K is the saturated hydraulic conductivity, delta_theta is defined as the soil capacity (the difference between the saturated and initial moisture content) and sigma is the soil suction head. -Within SFINCS, the Green-Ampt method can be used as follows. The user needs to provide the following variables. For a range of typical values see Table 1. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: +Within SFINCS, the Green-Ampt method is preferably supplied through ``infiltrationfile`` with ``infiltrationtype = gai``. The separate binary files listed below are kept for backward compatibility only. For a range of typically values see Table 1. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: * ksfile: saturated hydraulic conductivity in mm/hr * sigmafile: soil moisture deficit in [-] @@ -522,7 +545,7 @@ The basic form of the Horton equation is expressed as follows: In which f_t is the infiltration rate at time, f_c is the final, constant infiltration rate, f_0 is the initial infiltration rate, k is a decay constant and t is the time since the start of infiltration. -Within SFINCS, the Horton method can be used as follows. The user needs to provide the following variables. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: +Within SFINCS, the Horton method is preferably supplied through ``infiltrationfile`` with ``infiltrationtype = hor``. The separate binary files listed below are kept for backward compatibility only. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: * f0file: maximum (Initial) Infiltration Capacity in mm/hr * fcfile: Minimum (Asymptotic) Infiltration Rate in mm/hr @@ -533,6 +556,37 @@ The recovery of the infiltration rate during dry weather (kr) is calculated as f This option also supports restart functionality. +The bucket model: +%%%%% + +The bucket model is a linear-reservoir representation of infiltration and losses. It is configured with: + +.. code-block:: text + + infiltrationfile = sfincs.infiltration.nc + infiltrationtype = bkt + +The ``infiltrationfile`` must contain the following variables: + +* ``bucket_smax``: maximum bucket storage in mm +* ``bucket_k``: drainage coefficient in 1/hr +* ``bucket_loss``: loss fraction in the range 0-1 + +The former separate inputs ``bucketfile`` and ``bucket_loss_frac`` are no longer supported. + + +Drainage mimic: +%%%%% + +Drainage mimic is configured separately from infiltration and now only supports ``drainagefile``: + +.. code-block:: text + + drainagefile = sfincs.drainage + +This file may be a binary map or a NetCDF file containing ``drainage_rate`` in mm/hr. The former uniform ``qdrain`` keyword has been removed. + + Storage volume ^^^^^ diff --git a/docs/input_forcing.rst b/docs/input_forcing.rst index 666853b54..b442c1839 100644 --- a/docs/input_forcing.rst +++ b/docs/input_forcing.rst @@ -1,4 +1,4 @@ -User manual - forcing +Forcing ======= Overview diff --git a/docs/input_structures.rst b/docs/input_structures.rst index 82847e3c4..42095f947 100644 --- a/docs/input_structures.rst +++ b/docs/input_structures.rst @@ -1,14 +1,13 @@ -User manual - structures -===== +Structures +========== Overview ----- The input for SFINCS is supplied using various text and binary files, which are linked through the main input file: sfincs.inp. -Within this section of the user manual all different types of structures to reduce flood hazards with input settings and files are discussed. -The figure below gives an overview of all different types of input files and whether they are required or not. -Below an example is given of this file, which uses a keyword/value layout. -For more information regarding specific parameters see the pages 'Input parameters' or 'Output parameters'. +This section of the user manual describes the different types of structures that can be used to represent flood hazard reduction measures, together with their input settings and files. +The figure below gives an overview of the input files and indicates whether each one is required or optional. +For more information regarding specific parameters, see the pages 'Input parameters' or 'Output parameters'. **NOTE - In the manual below, blocks named 'Python example using HydroMT-SFINCS' are included, referring to easy setup functions of the HydroMT-SFINCS Python toolbox: https://deltares.github.io/hydromt_sfincs/latest/** @@ -16,18 +15,18 @@ For more information regarding specific parameters see the pages 'Input paramete :width: 800px :align: center - Overview of input file of SFINCS with indication whther they are required or not + Overview of input file of SFINCS with indication whether they are required or not -Structures ------ +Flow-blocking structures +------------------------ -SFINCS consists of multiple options for adding structures that can divert or block flow of water, which can be used to simulate flood hazard reduction methods. +SFINCS provides several types of structures that block or throttle the flow of water between grid cells, which can be used to simulate flood hazard reduction measures. Thin dam ^^^^^ -With a thin dam flow through certain grid cells is completely blocked (i.e. an infinitely high wall). -One can provide multiple polylines within one file, a maximum of 5000 supplied points is supported. +A thin dam blocks the cell-to-cell connections (u/v faces) that the polyline snaps to, acting as an infinitely high wall along those faces. Flow parallel to the dam is unaffected — only the normal-component fluxes across the snapped faces are set to zero. +Multiple polylines can be supplied within a single file. The supplied polylines are snapped onto the SFINCS grid within the model. .. figure:: ./figures/SFINCS_thindam_grid.png @@ -77,14 +76,27 @@ The supplied polylines are snapped onto the SFINCS grid within the model. Weirs ^^^^^ -Weirs are in principle the same as a thin dam, but then with a certain height (levee). -When the water level on either or both sides of the weir are higher than that of the weir, a flux over the weir is calculated. -Hereby a situation where the weir is partly or fully submerged is distinguished. -Besides the x&y locations per points, also the elevation z and a Cd coefficient for the weir formula (recommended to use 0.6). +Weirs are similar to a thin dam, but with a finite crest elevation (like a levee). +When the water level on either or both sides of the weir is higher than the weir crest, a flux over the weir is calculated. +A distinction is made between free (modular) flow and submerged flow, using a broad-crested weir formula: + +.. math:: + + q = + \begin{cases} + C_d \cdot 1.7049 \cdot h_1^{3/2}, & h_2 \le \tfrac{2}{3}\, h_1 \quad\text{(free flow)} \\ + C_d \cdot h_2 \cdot \sqrt{2\, g\, (h_1 - h_2)}, & h_2 > \tfrac{2}{3}\, h_1 \quad\text{(submerged)} + \end{cases} + +where :math:`h_1 = \max(z_{s,\text{up}} - z_\text{weir},\, 0)` is the head above the crest on the upstream side, :math:`h_2 = \max(z_{s,\text{dn}} - z_\text{weir},\, 0)` is the head on the downstream side, :math:`z_\text{weir}` is the user-supplied crest elevation, :math:`C_d` is the user-supplied discharge coefficient (0.6 is a typical value), and :math:`g = 9.81` m/s². The discharge :math:`q` is per unit width; SFINCS multiplies by the length of the weir segment inside each grid cell. The constant 1.7049 is :math:`\tfrac{2}{3}\sqrt{\tfrac{2}{3} g}`, the standard broad-crested free-flow coefficient. + +Each point in the weir file carries its x and y location, the crest elevation z, and the :math:`C_d` coefficient. The supplied polylines are snapped onto the SFINCS grid within the model. -While running SFINCS the number of structure uv points found is displayed, e.g.: - Info : 7932 structure u/v points found -Note that SFINCS displays the points found after snapping to the grid (max 2 per grid cell), not how many were specified in the input. +While running SFINCS, the number of structure uv-points found (after snapping) is displayed, e.g.:: + + Info : 7932 structure u/v points found + +Note that this is the count after snapping to the grid (at most 2 per grid cell), not the number of points supplied in the input. The snapped coordinates are available in sfincs_his.nc as structure_x, structure_y & structure_height from SFINCS v2.0.2 onwards. @@ -131,30 +143,38 @@ The snapped coordinates are available in sfincs_his.nc as structure_x, structure **NOTE - If your weir elevation is unknown a priori, you can also let HydroMT-SFINCS derive this from an input (low-resolution) DEM by specifying 'dep' and adding a certain assumed elevation 'dz'** -Drainage Pumps and Culverts -^^^^^ +Drainage Structures +------------------- -**Introduction** +.. important:: -In SFINCS, drainage pumps, culverts and check valves (one way culverts) are specified using the same input file format, with the structure type distinguished by an indicator: + **Drainage structures do not block flow.** They simply transfer water + from one grid cell (the intake, ``src_1``) to another (the outfall, + ``src_2``), without representing any physical barrier. If the drainage + path passes through an embankment, dam face, or culvert wall that is + not already resolved by the model topography, that blocking + geometry must be added separately using a thin dam or a weir. Without + it, water will simply flow around the drainage structure as if it were + not there. -- type=1: Drainage pump -- type=2: Culvert -- type=3: Check valve +**Overview** -A drainage pump moves water from a retraction point (source location) to an outflow point (sink location) at a specified discharge rate, as long as there is enough water available at the retraction point. The discharge rate is defined using the par1 parameter. +SFINCS supports four types of internal drainage structures that move water between two grid cells without resolving the flow through a physical momentum equation. They are configured through a single file (typically sfincs.drn, TOML format), referenced from ``sfincs.inp`` with the ``drnfile`` keyword: -For culverts, par1 represents the discharge capacity. The actual flow through the culvert depends on the water level difference (head difference) between the upstream and downstream ends. This gradient determines how much water flows through the culvert based on the capacity defined in par1. +.. code-block:: text -The check valve requires the same par1 discharge capacity input as a culvert, but only allows flow in one direction, preventing backflow (e.g. for a one-way tide gate). Water is only flowing if the water level at input point 1 is larger than the water level at output point 2. + drnfile = sfincs.drn -**Input Parameters** +The four structure types are: -- x & y locations: Coordinates for the retraction (source) and outflow (sink) points. -- Type: Specifies if the structure is a drainage pump (type=1), a culvert (type=2) or a check valve (type=3). -- par1: Sets the discharge capacity. Additional parameters (par2 to par5) are included as placeholders for future updates. +- ``pump`` — drainage pump. Moves a prescribed discharge ``q`` from ``src_1`` to ``src_2``, limited by available water. +- ``culvert_simple`` — lumped one-coefficient culvert. Bidirectional by default. +- ``culvert`` — regime-aware detailed culvert with geometry (width, height, invert elevations) and a submergence threshold. +- ``gate`` — bidirectional gate with a sill and an inertial culvert-style momentum update (Bates et al., 2010). -You can know how much discharge is extracted by the model in the sfincs_his.nc output by specifying 'storeqdrain=1' from SFINCS v2.0.2 onwards, see the description in "Input parameters". +All structures can be driven by optional rule expressions (see :ref:`open/close rules ` below) that open or close the structure based on water levels at user-chosen observation cells. + +You can record how much discharge each structure extracts in the ``sfincs_his.nc`` output by setting ``storeqdrain = 1`` in ``sfincs.inp``. .. figure:: ./figures/SFINCS_drainage_grid.png :width: 400px @@ -162,61 +182,392 @@ You can know how much discharge is extracted by the model in the sfincs_his.nc o Example of how drainage pump/culvert input points with sink and source locations from 2 different structures are snapped to the grid of SFINCS. -**drnfile = sfincs.drn** +**Common input keys** + +Every ``[[src_structure]]`` block carries a small set of keys that are shared across all four types. Per-type required and optional keys are documented in the sub-subsections further below. + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **name** + - string + - Unique identifier for the structure. Required. + * - **type** + - string + - One of ``"pump"``, ``"culvert_simple"``, ``"culvert"``, ``"gate"``. The legacy alias ``"check_valve"`` maps to ``culvert_simple`` with ``direction = "positive"``. Required. + * - **src_1_x, src_1_y** + - real + - Coordinates of the intake (``src_1``) cell, in the grid CRS. Required. + * - **src_2_x, src_2_y** + - real + - Coordinates of the outfall (``src_2``) cell, in the grid CRS. Required. + * - obs_1_x, obs_1_y + - real + - Coordinates of the observation cell feeding the ``z1`` atom in rule expressions. Default: the ``src_1`` coordinates. + * - obs_2_x, obs_2_y + - real + - Coordinates of the observation cell feeding the ``z2`` atom in rule expressions. Default: the ``src_2`` coordinates. + * - direction + - string + - Flow-direction filter. One of ``"both"`` (default), ``"positive"`` (allow flow ``src_1 -> src_2`` only), ``"negative"`` (allow flow ``src_2 -> src_1`` only). Meaningful for bidirectional types (``culvert_simple``, ``culvert``); ``pump`` is one-way by construction and ``gate`` is typically left bidirectional. + * - opening_duration + - real + - Ramp time (s) for the closed → open transition. Default: **600.0** for ``gate``; **0.0** (instant) for ``pump``, ``culvert_simple``, ``culvert``. + * - closing_duration + - real + - Ramp time (s) for the open → closed transition. Same defaults as ``opening_duration``. + * - rules_open + - string + - Water-level expression that triggers opening. See :ref:`open/close rules `. + * - rules_close + - string + - Water-level expression that triggers closing. See :ref:`open/close rules `. + +Pump +^^^^ + +A drainage pump moves water from the intake cell ``src_1`` to the outfall cell ``src_2`` at a prescribed discharge ``q`` (m³/s). The discharge is signed in the sense that ``q > 0`` pumps from ``src_1`` to ``src_2``; ``q < 0`` reverses the direction. As the upstream depth drops below a small internal threshold (0.1 m, hard-coded), the discharge is scaled linearly so the pump cannot pump a cell dry: + +.. math:: + + Q = q \cdot \min\!\left(1,\, \frac{h_\text{up}}{0.1~\text{m}}\right) + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **q** + - real + - Nominal pump discharge in m³/s. Required. The dry-prevention scaling above is an internal safety and is not user-tunable. + +All common keys (``name``, ``type``, ``src_*``, ``obs_*``, ``direction``, ``opening_duration``, ``closing_duration``, ``rules_open``, ``rules_close``) are accepted as documented in the common-keys table above. + +.. code-block:: toml + + [[src_structure]] + name = "south_pump" + type = "pump" + src_1_x = 50.0 + src_1_y = 25.0 + src_2_x = 150.0 + src_2_y = 25.0 + q = 0.345 + rules_open = "z1 > 0.20" + rules_close = "z1 < 0.05" + +Culvert (simple) +^^^^^^^^^^^^^^^^ + +The simple culvert uses a single lumped coefficient and a square-root head-difference law. It is the fastest choice when geometry is unknown or unimportant. Setting ``direction = "positive"`` (or equivalently using the ``check_valve`` type alias) turns the structure into a check valve that blocks backflow — useful for one-way tide gates and similar features. + +.. math:: + + Q = c_f \cdot \operatorname{sign}(\Delta h) \cdot \sqrt{|\Delta h|} + +with :math:`\Delta h = z_{s,1} - z_{s,2}`. + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **flow_coef** + - real + - Lumped discharge coefficient :math:`c_f` from the formula above (units chosen so the formula returns m³/s when ``Δh`` is in m). Required. + +All common keys are accepted. Set ``direction = "positive"`` (or use ``type = "check_valve"``) to block backflow. + +.. code-block:: toml + + [[src_structure]] + name = "north_check_valve" + type = "culvert_simple" + direction = "positive" + src_1_x = 75.0 + src_1_y = 25.0 + src_2_x = 125.0 + src_2_y = 25.0 + flow_coef = 0.345 + +Culvert (detailed) +^^^^^^^^^^^^^^^^^^ + +The detailed culvert resolves the two usual culvert regimes — submerged (orifice-like) and free / inlet-controlled — based on the ratio of downstream to upstream heads above the controlling sill. The controlling sill is the higher of the two inverts, :math:`z_\text{sill} = \max(\text{invert}_1, \text{invert}_2)`; upstream and downstream are assigned on the fly from the sign of :math:`\Delta h`, so the structure is bidirectional (restrict with ``direction`` if needed). + +Let :math:`h_\text{up}`, :math:`h_\text{dn}` be the upstream and downstream depths above :math:`z_\text{sill}`, and :math:`A_\text{eff} = w \cdot \min(h_\text{up}, H)` (capped at barrel height). Then + +.. math:: + + Q = + \begin{cases} + c_f \cdot A_\text{eff} \cdot \sqrt{2 g\, |\Delta h|}, & h_\text{dn}/h_\text{up} \ge r_\text{sub} \quad\text{(submerged)} \\ + c_f \cdot A_\text{eff} \cdot \sqrt{2 g\, h_\text{up}}, & h_\text{dn}/h_\text{up} < r_\text{sub} \quad\text{(free / inlet-controlled)} + \end{cases} + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **width** + - real + - Culvert barrel width (m). Required. + * - **height** + - real + - Culvert barrel height (m). Used to cap the flow area. Required. + * - **invert_1** + - real + - Invert elevation at the ``src_1`` end (m, same datum as ``zb``). Required. + * - **invert_2** + - real + - Invert elevation at the ``src_2`` end (m, same datum as ``zb``). Required. + * - flow_coef + - real + - Orifice discharge coefficient :math:`c_f`. Default: **0.6**. + * - submergence_ratio + - real + - Threshold :math:`r_\text{sub}` on :math:`h_\text{dn}/h_\text{up}` that switches between the two regimes. Default: **0.667** (the classic broad-crested-weir / Villemonte value). + +All common keys are accepted. + +.. code-block:: toml + + [[src_structure]] + name = "west_culvert" + type = "culvert" + src_1_x = 100.0 + src_1_y = 50.0 + src_2_x = 100.0 + src_2_y = 150.0 + width = 1.2 + height = 1.0 + invert_1 = 0.20 + invert_2 = 0.15 + flow_coef = 0.6 + submergence_ratio = 0.667 + +Gate +^^^^ + +The gate is a bidirectional opening with a horizontal sill. Discharge is computed from an inertial culvert-style momentum update (Bates et al., 2010), per unit width, and then multiplied by the gate ``width``. The previous-step discharge :math:`q^n` is carried through the relaxation blend, so the gate has memory on the order of ``structure_relax`` time steps. + +With :math:`h = \max(\max(z_{s,1}, z_{s,2}) - z_\text{sill},\, 0)` and :math:`\partial z_s/\partial s = (z_{s,2} - z_{s,1})/L`: + +.. math:: + + q^{n+1} = + \frac{q^n - g\, h\, (\partial z_s/\partial s)\, \Delta t} + {1 + g\, n^2\, \Delta t\, |q^n| / h^{7/3}} + +then :math:`Q = c_f \cdot q^{n+1} \cdot w \cdot \text{fraction\_open}`, where :math:`c_f` is ``flow_coef``. + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **width** + - real + - Gate width (m). Required. + * - **sill_elevation** + - real + - Sill elevation :math:`z_\text{sill}` (m, same datum as ``zb``). Required. + * - mannings_n + - real + - Manning's roughness coefficient on the gate sill. Default: **0.024** (concrete-lined). + * - flow_coef + - real + - Lumped discharge coefficient :math:`c_f` from the formula above, accounting for additional losses not captured by the Manning friction term. Default: **1.0** (no extra loss). + +All common keys are accepted. The gate defaults ``opening_duration`` and ``closing_duration`` to **600 s** (matching legacy ``dtype = 4`` behaviour) rather than the 0 s default used by the other three types. + +.. code-block:: toml + + [[src_structure]] + name = "east_tide_gate" + type = "gate" + src_1_x = 200.0 + src_1_y = 25.0 + src_2_x = 250.0 + src_2_y = 25.0 + obs_2_x = 260.0 # observe water level just outside the gate + obs_2_y = 25.0 + width = 3.0 + sill_elevation = 0.20 + mannings_n = 0.024 + opening_duration = 300.0 + closing_duration = 300.0 + rules_open = "z2-z1 > 0.10" + rules_close = "z2-z1 < 0.0 | z2>1.0" + +.. _drn_rules: + +**Open/close rules and the state machine** + +Each structure has an internal state machine with four states: + +- ``0`` — closed +- ``1`` — open +- ``2`` — opening (transient, time-based) +- ``3`` — closing (transient, time-based) + +At every time step, SFINCS checks the current state of the structure. If the structure is closed, it evaluates the ``rules_open`` expression; when that rule becomes true, the structure starts opening and ``fraction_open`` increases linearly from 0 to 1 over ``opening_duration`` seconds. If the structure is open, it evaluates the ``rules_close`` expression; when that rule becomes true, the structure starts closing and ``fraction_open`` decreases linearly from 1 to 0 over ``closing_duration`` seconds. While a structure is opening or closing, SFINCS only looks at the clock — the rules are not re-checked — so the structure cannot rapidly toggle on and off. Set ``opening_duration`` or ``closing_duration`` to ``0.0`` for an instantaneous transition. A structure without rules simply stays fully open for the entire simulation. + +The rules use a small expression language. The building blocks are: + +- ``z1`` — water level at the ``obs_1`` cell (m) +- ``z2`` — water level at the ``obs_2`` cell (m) +- ``z2-z1`` — the head difference (m); note there is no ``z1-z2`` form, so flip the comparison sign instead (``z1-z2 > 0.1`` becomes ``z2-z1 < -0.1``) + +You compare one of these against a number using ``<`` or ``>`` (the ``<=`` and ``>=`` forms are not supported). Multiple comparisons can be combined with ``&`` for "and" and ``|`` for "or", and you can use parentheses to group them. All names are case-insensitive. + +Examples: .. code-block:: text - par2-1 par3-1 par4-1 par5-1 - par2-2 par3-2 par4-2 par5-2 + rules_open = "z1 > 0.5" # open whenever intake rises above 0.5 m + rules_close = "z2 > 2.0" # close when the outfall floods above 2 m + rules_open = "(z1 < 0.5 | z2-z1 > 0.05) & z2 < 1.5" # complex trigger + rules_close = "z2-z1 > 0.3" # close when outfall gets 0.3 m higher than intake + +**Discharge relaxation: structure_relax** + +Discharges from drainage structures are relaxation-blended between time steps to damp oscillations: + +.. math:: + + q^{n+1}_{\text{blended}} = \alpha \, q^{n+1}_{\text{raw}} + (1 - \alpha) \, q^{n}, \qquad \alpha = \frac{1}{N} + +where :math:`N` is set by the ``structure_relax`` keyword in ``sfincs.inp`` — a dimensionless step count: a value of :math:`N` damps the discharge response over roughly :math:`N` time steps. Default is ``4.0``; typical range is 1 (no smoothing) to 10. + +**Output: storing structure discharges** + +Set ``storeqdrain = 1`` in ``sfincs.inp`` to write the time-series discharge per structure into ``sfincs_his.nc``. + +**Example sfincs.drn file** + +.. code-block:: toml + + # sfincs.drn + + [[src_structure]] + name = "south_pump" + type = "pump" + src_1_x = 50.0 + src_1_y = 25.0 + src_2_x = 150.0 + src_2_y = 25.0 + q = 0.345 # pump discharge (m^3/s) + rules_open = "z1 > 0.20" # start pumping when intake > 0.20 m + rules_close = "z1 < 0.05" # stop pumping when intake drops below 0.05 m + + [[src_structure]] + name = "north_check_valve" + type = "culvert_simple" + direction = "positive" # one-way; blocks backflow + src_1_x = 75.0 + src_1_y = 25.0 + src_2_x = 125.0 + src_2_y = 25.0 + flow_coef = 0.345 + + [[src_structure]] + name = "west_culvert" + type = "culvert" + src_1_x = 100.0 + src_1_y = 50.0 + src_2_x = 100.0 + src_2_y = 150.0 + width = 1.2 + height = 1.0 + invert_1 = 0.20 + invert_2 = 0.15 + flow_coef = 0.6 # orifice discharge coefficient + submergence_ratio = 0.667 # h_dn/h_up threshold between submerged and inlet control + + [[src_structure]] + name = "east_tide_gate" + type = "gate" + src_1_x = 200.0 + src_1_y = 25.0 + src_2_x = 250.0 + src_2_y = 25.0 + obs_2_x = 260.0 # observe water level just outside the gate + obs_2_y = 25.0 + width = 3.0 + sill_elevation = 0.20 + mannings_n = 0.024 + opening_duration = 300.0 # 5-minute ramp open + closing_duration = 300.0 + rules_open = "z2-z1 > 0.10" # open when outer level exceeds inner by 0.10 m + rules_close = "z2-z1 < 0.0 | z2>1.0" # close on reversal (prevents backflow) or when outer water level exceeds 1.0 m - e.g. pump: - 50.00 25.00 150.00 25.00 1 0.345 0.000 0.000 0.000 0.000 - 75.00 25.00 125.00 25.00 1 0.345 0.000 0.000 0.000 0.000 - - e.g. culvert: - 50.00 25.00 150.00 25.00 2 0.345 0.000 0.000 0.000 0.000 - 75.00 25.00 125.00 25.00 2 0.345 0.000 0.000 0.000 0.000 - **Python example using HydroMT-SFINCS** .. code-block:: python - sf.drainage_structures.create( - locations="drainage_input.geojson", - stype='pump', - discharge=100.0, - merge=True - ) + sf.drainage_structures.create( + locations="drainage_input.geojson", + stype='pump', + discharge=100.0, + merge=True + ) - OR as a culvert: +The ``discharge`` argument above is the pump discharge and applies to pumps only. Culverts and gates carry their own geometry-based parameters (width, height, inverts, flow coefficients, etc.) rather than a single discharge value — see the HydroMT-SFINCS documentation for the full argument list per structure type: - sf.drainage_structures.create( - locations="drainage_input.geojson", - stype='culvert', - discharge=100.0, - merge=True - ) +https://deltares.github.io/hydromt_sfincs/latest/_generated/hydromt_sfincs.components.geometries.SfincsDrainageStructures.create.html - More information: - https://deltares.github.io/hydromt_sfincs/latest/_generated/hydromt_sfincs.components.geometries.SfincsDrainageStructures.create.html +**Legacy fixed-column drn format** -**Calculating Culvert Discharge Capacity** +The legacy ASCII fixed-column ``.drn`` format is still accepted for back-compatibility. Each non-blank, non-comment line describes one structure with the columns: -For culverts, par1 (discharge capacity) can be calculated as: +.. code-block:: text -``par1 = \(\mu \cdot A \cdot \sqrt{2g}\)`` + + +where ``type`` is: + +- ``1`` — pump (``par1`` = pump discharge) +- ``2`` — culvert (``par1`` = ``flow_coef``; maps to ``culvert_simple``) +- ``3`` — check valve (``par1`` = ``flow_coef``; maps to ``culvert_simple`` with ``direction = "positive"``) + +Example: + +.. code-block:: text -where: + # pump: + 50.00 25.00 150.00 25.00 1 0.345 + 75.00 25.00 125.00 25.00 1 0.345 -* \(\mu\) = dimensionless culvert loss coefficient, typically between 0 and 1 -* \(A\) = area of the culvert opening (m²) -* \(g\) = gravitational acceleration (9.81 m/s²) + # culvert: + 50.00 25.00 150.00 25.00 2 0.345 + 75.00 25.00 125.00 25.00 2 0.345 -This formula is derived from the Bernoulli Equation, which estimates flow based on the head difference. +When SFINCS sees a legacy ``.drn`` file it automatically transcribes it to a sibling TOML file (``sfincs.toml.drn`` if the input was ``sfincs.drn``) and then reads that. Water-level-triggered legacy gates (``type = 4``) are converted to TOML ``gate`` blocks with synthesised ``rules_open`` / ``rules_close`` expressions derived from the legacy ``zmin`` / ``zmax`` columns. Schedule-triggered legacy gates (``type = 5``) are refused; the rule grammar is water-level-only and has no time atom — rewrite those as TOML gates driven by observed water levels. -* If \(\mu = 1\), the flow is assumed to be driven entirely by the head difference, with no friction or length-based losses. -* If \(\mu < 1\), it accounts for additional energy losses, such as friction and entry/exit losses. +.. important:: -**Planned Enhancements** + **After a legacy transcription, strongly consider renaming the generated + ``sfincs.toml.drn`` file to ``sfincs.drn`` (overwriting the original legacy + file) and pointing ``drnfile`` at it.** Future simulations will then read + the TOML directly, skipping the transcription step and giving you a single + source of truth that you can edit, version-control, and extend with the + newer keywords (``rules_open`` / ``rules_close``, ``reduction_depth``, + ``submergence_ratio``, ``direction``, per-structure invert pairs, etc.) + that the legacy format cannot express. Keep a backup of the original + legacy file elsewhere if you need it for reference. -Future updates will incorporate the Darcy–Weisbach equation for more accurate discharge estimates by considering frictional and minor losses along the culvert length, which is particularly useful for longer or rougher conduits. +New models should be written directly in TOML; the legacy reader exists purely so that pre-TOML input decks keep running. diff --git a/docs/input_urban_drainage.rst b/docs/input_urban_drainage.rst new file mode 100644 index 000000000..874f3640f --- /dev/null +++ b/docs/input_urban_drainage.rst @@ -0,0 +1,199 @@ +Urban Drainage +============== + +Overview +-------- + +Urban drainage is a simple bulk sink/source model for two kinds of lumped drainage infrastructure: buried pipe networks that discharge to a receiving water body (**piped drainage**) and pumps that remove water from the model and store it underground (**injection wells**). Each **drainage zone** is a polygon in the horizontal plane and has exactly one ``type``: + +- ``piped_drainage`` — cells inside the polygon drain to a single outfall cell through a conceptual pipe network. Flow is bidirectional: during high water at the outfall (tide or surge), water can push back into the zone cells unless a check valve is configured. The per-zone net flux is deposited as a point source/sink at the outfall cell. +- ``injection_well`` — cells inside the polygon are pumped down at a fixed total rate, split evenly across the cells, and the extracted water is *removed from the model* (it does not reappear at an outfall). Pumping stops when the cumulative injected volume reaches the well's maximum capacity. + +The approach is deliberately coarse: there is no pipe network, no hydraulic routing, no pressure head other than the difference between cell water level and outfall water level (piped_drainage) and no subsurface storage model (injection_well beyond the single capacity cap). It is intended for compound-flood applications where detailed geometry is unknown but municipal-scale design parameters (rainfall intensity, outfall pipe capacity, or pump rate + well capacity) are available. + +**IMPORTANT** — urban drainage does not represent physical pipes or wells. It is a mass-balance abstraction: water disappears from urban cells, and for ``piped_drainage`` reappears summed at the outfall cell. It does not block or route flow between cells. + +Inputs +------ + +The feature is activated by the ``urbfile`` keyword in ``sfincs.inp``: + +.. code-block:: text + + urbfile = sfincs.urb + store_urban_drainage_discharge = 1 + store_cumulative_urban_drainage = 1 + +``store_urban_drainage_discharge`` writes per-zone time series to ``sfincs_his.nc``: the zone total discharge and (for injection wells) the cumulative injection volume. ``store_cumulative_urban_drainage`` writes the cumulative drained depth (m) per cell to ``sfincs_map.nc``. + +The ``.urb`` file is a TOML document with one or more ``[[urban_drainage_zone]]`` entries. + +Zone definition +--------------- + +Every zone has three required keys regardless of type: ``name``, ``type``, and ``polygon_file``. The rest depends on the type. + +Piped drainage example +^^^^^^^^^^^^^^^^^^^^^^ + +.. code-block:: toml + + [[urban_drainage_zone]] + name = "downtown" + type = "piped_drainage" + polygon_file = "zones.tek" + outfall = [950.0, 150.0] + design_precip = 20.0 + check_valve = true + + [[urban_drainage_zone]] + name = "harbor_district" + type = "piped_drainage" + polygon_file = "zones.tek" + outfall = [1020.0, 180.0] + max_outfall_rate = 6.0 + +Injection well example +^^^^^^^^^^^^^^^^^^^^^^ + +.. code-block:: toml + + [[urban_drainage_zone]] + name = "north_well_field" + type = "injection_well" + polygon_file = "zones.tek" + injection_rate = 0.5 + maximum_capacity = 5000.0 + +Common keys (both types) +^^^^^^^^^^^^^^^^^^^^^^^^ + +``name`` (required, string) + Zone name. Must match a polygon name in ``polygon_file``. Used as the station identifier in ``sfincs_his.nc`` when discharge output is enabled. + +``type`` (required, string) + One of ``"piped_drainage"`` or ``"injection_well"``. Selects the per-zone physics and the set of remaining required keys. + +``polygon_file`` (required, string) + Path to a Delft3D-style ``.tek`` polygon file. Multiple zones can share the same file — each zone's ``name`` is matched against polygon names inside the file. See "Polygon file format" below. + +``h_threshold`` (optional, m, default ``0.0``) + Depth over which the drainage rate ramps linearly from zero to ``q_max``. At cell ponding depth ``h_cell = 0`` the drainage is zero; at ``h_cell >= h_threshold`` it is at full ``q_max``; in between it is ``(h_cell / h_threshold) * q_max``. Smooths the discharge time series compared to a hard on/off gate. Typical values: 0.02–0.05 m. Set to ``0.0`` to reproduce the hard-cap behaviour (full ``q_max`` for any ``h_cell > 0``). + +Piped drainage keys +^^^^^^^^^^^^^^^^^^^ + +``design_precip`` (conditional, mm/hr) + Design rainfall intensity the zone's drainage is sized for. Per-cell capacity is ``qmax = design_precip * cell_area / 3.6e6`` [m³/s]. Typical municipal values: 10–20 mm/hr for suburban residential, 20–40 mm/hr for dense city centre. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided for piped_drainage zones.** + +``max_outfall_rate`` (conditional, m³/s) + Total zone outfall capacity. Useful when you know what the outfall pipe can deliver but not the design storm it was sized for. SFINCS derives ``design_precip = max_outfall_rate / zone_area * 3.6e6`` from the zone's total polygon-covered area, so per-cell capacity is distributed proportionally to cell area. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided for piped_drainage zones.** + +``outfall`` (required when ``include_outfall = true``, 2-element array ``[x, y]``) + Coordinates of the single point where all zone discharge is summed and deposited. Snapped to the nearest active cell. If no active cell can be found, zone contributions are silently discarded and a warning is logged. + +``include_outfall`` (optional, bool, default ``true``) + Set to ``false`` to disable the outfall deposit step. Flow still leaves (or enters) cells, but does not reappear anywhere — treats the zone as an unconnected sink. Mostly useful for sensitivity tests. + +``check_valve`` (optional, bool, default ``false``) + When ``true``, the zone only drains outward. Backflow from the outfall into the cells (bay flooding through the pipe) is suppressed. Represents a flap valve / tide gate at the outfall. + +``dh_design_min`` (optional, m, default ``0.1``) + Floor on the per-cell design head used to compute the backflow coefficient. Per-cell backflow discharge is + + .. math:: + Q_{back}(nm) = \frac{q_{max}(nm)}{\sqrt{\max(z_b(nm) - z_b(outfall),\,\Delta h_{design,min})}} \cdot \sqrt{z_s(outfall) - z_s(nm)} + + so that a cell at the outfall bed elevation, or below it, doesn't produce an infinite backflow coefficient. + +Injection well keys +^^^^^^^^^^^^^^^^^^^ + +``injection_rate`` (required, m³/s) + Total pumping rate across the zone. Distributed over the zone cells by cell area so the sum across zone cells is exactly ``injection_rate`` and quadtree refinement inside the polygon does not shift the per-cell flux relative to cell area: + + .. math:: + q_{max}(nm) = \text{injection\_rate} \cdot \frac{A(nm)}{A_{zone}} + +``maximum_capacity`` (required, m³) + Total volume the injection well can accept over the simulation. SFINCS tracks ``cumulative_injection_volume`` over time; once it reaches ``maximum_capacity`` pumping is skipped for that zone (flow drops to zero). There is a potential one-time-step overshoot at the transition step (per-cell flux is not scaled to hit the cap exactly). + +Polygon file format +------------------- + +Zones are defined in a Delft3D-style ``.tek`` file — one or more named polygon blocks: + +.. code-block:: text + + downtown + 6 2 + 900.0 100.0 + 900.0 200.0 + 1000.0 200.0 + 1000.0 100.0 + 950.0 80.0 + 900.0 100.0 + harbor_district + 5 2 + 1000.0 150.0 + 1000.0 250.0 + 1100.0 250.0 + 1100.0 150.0 + 1000.0 150.0 + +Each block has a name line, a ``nrows ncols`` line, and ``nrows`` vertex lines. If the last vertex does not equal the first, SFINCS closes the ring automatically at read time. A cell center falling inside multiple polygons is assigned to the **last** zone encountered — overlap warnings are not emitted, so order your zones with intent. + +Flow formulas +------------- + +For each active cell ``nm`` inside zone ``iz``, with ``h_cell`` the cell ponding depth (``zs - subgrid_z_zmin`` in subgrid mode, ``zs - zb`` otherwise) and the rate ramp + +.. math:: + r = \min(h_{cell} / h_{threshold},\; 1) \text{ if } h_{threshold} > 0, \text{ else } 1 + +**Piped drainage** (``outfall cell io``): + +.. math:: + \Delta z_s = z_s(nm) - z_s(io) + +Outflow (``Δz_s > 0`` and ``h_cell > 0``): + +.. math:: + q = \min\left(r \cdot q_{max}(nm),\; \frac{h_{cell} \cdot A(nm)}{\Delta t}\right) + +Backflow (``Δz_s < 0`` and check valve off): + +.. math:: + q = -\frac{q_{max}(nm)}{\sqrt{\max(z_b(nm) - z_b(io),\,\Delta h_{design,min})}} \cdot \sqrt{-\Delta z_s} + +capped at ``-q_{max}(nm)``. With ``check_valve = true`` backflow is skipped entirely. + +The zone's per-step net flux is deposited at the outfall cell, so mass is conserved (up to the outfall-snap warning above). + +**Injection well** (no outfall): + +.. math:: + q = \min\left(r \cdot q_{max}(nm),\; \frac{h_{cell} \cdot A(nm)}{\Delta t}\right) + +where :math:`q_{max}(nm) = \text{injection\_rate} \cdot A(nm) / A_{zone}` (area-weighted split; sums to ``injection_rate`` across the zone). Flow is positive (water leaves cells) only; there is no backflow. Pumping is skipped entirely once :math:`\text{cumulative\_injection\_volume}(iz) \geq \text{maximum\_capacity}(iz)`. + +Outputs +------- + +**``sfincs_his.nc``** — when ``store_urban_drainage_discharge = 1``: + +``urban_drainage_discharge(urban_drainage_zones, time)`` + Per-zone total discharge in m³/s. Positive means net outflow from the cells (to outfall or to injection well); negative means net inflow (backflow from the outfall, piped_drainage with check valve off). Named ``urban drainage zone total discharge`` in the long_name attribute. + +``cumulative_injection_volume(urban_drainage_zones, time)`` + Per-zone cumulative injection volume in m³. Tracked for all zones, but only physically meaningful for ``injection_well`` zones; ``piped_drainage`` zones keep this at 0.0 (there is no underground storage). + +``urban_drainage_zone_name(urban_drainage_zones)`` + Zone names, in the order they appear in the ``.urb`` file. + +**``sfincs_map.nc``** — when ``store_cumulative_urban_drainage = 1``: + +``urban_drainage_cumulative_depth(m, n, timemax)`` (regular) or ``(nmesh2d_face, timemax)`` (quadtree) + Cumulative drained volume divided by cell area (m), written at the ``dtmaxout`` interval. Positive means net outflow from the cell over the simulation; negative means net inflow. + +At init time a per-zone summary block is written to the SFINCS log listing zone name, type, polygon file, number of cells assigned, total area, design precipitation / max outfall rate / qmax (piped_drainage) or injection rate / maximum capacity (injection_well), thresholds, outfall coords + snapped cell index (piped_drainage), and check-valve state. diff --git a/docs/overview.rst b/docs/overview.rst index e1470b001..d0952f118 100644 --- a/docs/overview.rst +++ b/docs/overview.rst @@ -35,6 +35,24 @@ Compound flooding? Compound flooding is described as events occurring in coastal areas where the interaction of high sea levels, large river discharges and local precipitation causes (extreme) flooding (Wahl et al., 2015). To simulate compound flooding events, a model needs to be able to model all these types of forcings. Therefore, SFINCS includes fluvial, pluvial, tidal, wind- and wave-driven processes! +How to cite? +^^^^^^^^^^^^ +When using SFINCS in academic work, please cite the following references as appropriate: + +* **For any reference to SFINCS** (introduction and validation of the base model): + + Leijnse, T., van Ormondt, M., Nederhoff, C.M., van Dongeren, A. (2021). Modeling compound flooding in coastal systems using a computationally efficient reduced-physics solver: including fluvial, pluvial, tidal, wind- and wave-driven processes. *Coastal Engineering*, 165, 103852. https://doi.org/10.1016/j.coastaleng.2021.103852 + +* **When using subgrid features**: + + van Ormondt, M., Leijnse, T., de Goede, R., Nederhoff, K., and van Dongeren, A. (2025). Subgrid corrections for the linear inertial equations of a compound flood model – a case study using SFINCS 2.1.1 Dollerup release. *Geoscientific Model Development*, 18, 843–861. https://doi.org/10.5194/gmd-18-843-2025 + +* **When referring to a specific SFINCS executable / release**, cite the Zenodo archive for that version. For the current 2.3.0 Mt Faber release: + + van Ormondt, M., Leijnse, T., Nederhoff, K., de Goede, R., van Dongeren, A., Bovenschen, T., van Asselt, K., Roelvink, D., Reyns, J., & van der Lugt, M. (2025). *SFINCS: Super-Fast INundation of CoastS model (2.3.0 mt Faber Release 2025.02)*. Zenodo. https://doi.org/10.5281/zenodo.17651112 + +For a broader list of SFINCS-related publications, see the "Publications" section at the end of this page. + Application areas ----------------- diff --git a/docs/parameters.rst b/docs/parameters.rst index 5cbf274d5..71683a31e 100644 --- a/docs/parameters.rst +++ b/docs/parameters.rst @@ -396,7 +396,15 @@ Parameters for model output storeqdrain :description: Flag to turn on writing away drainage discharge during simulation (storeqdrain = 1) :units: - - :default: 0 + :default: 0 + store_urban_drainage_discharge + :description: Flag to turn on writing away per-zone outfall discharge to 'sfincs_his.nc' on 'dthisout' interval (only effective when 'urbfile' is specified). + :units: - + :default: 0 + store_cumulative_urban_drainage + :description: Flag to turn on writing away cumulative urban drainage depth (drained volume / cell area, in m) per cell to 'sfincs_map.nc' on 'dtmaxout' interval (only effective when 'urbfile' is specified). + :units: - + :default: 0 storezvolume :description: Flag to turn on writing away water volumes for the subgrid mode during simulation (storezvolume = 1) :units: - @@ -475,54 +483,68 @@ Domain :units: s/m^(1/3) :required: no in case of regular mode, ignored in case of subgrid mode :format: bin + infiltrationfile = sfincs.infiltration.nc + :description: Recommended NetCDF input for spatially varying infiltration and bucket-model losses. Use together with infiltrationtype. + :units: depends on selected infiltrationtype and variables in the NetCDF file + :required: no + :format: net + infiltrationtype = c2d | cna | cnb | gai | hor | bkt + :description: Selects which infiltration method is read from infiltrationfile. Bucket mode requires bucket_smax, bucket_k and bucket_loss in infiltrationfile. + :units: - + :required: Only when infiltrationfile is used + :format: asc + drainagefile = sfincs.drainage + :description: Spatially varying drainage mimic input in mm/hr. Can be a binary map or a NetCDF file with variable drainage_rate. This replaces the removed qdrain keyword. + :units: mm/hr + :required: no + :format: bin or net qinffile = sfincs.qinf - :description: For spatially varying constant in time infiltration values per cell use the qinffile option, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For spatially varying constant in time infiltration values per cell prefer infiltrationfile with infiltrationtype = c2d. :units: mm/hr :required: no :format: bin scsfile = sfincs.scs - :description: For spatially varying infiltration values per cell using the Curve Number method A (without recovery) use the scsfile option, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Curve Number method A (without recovery) prefer infiltrationfile with infiltrationtype = cna. :units: - :required: no :format: bin smaxfile = sfincs.smax - :description: For spatially varying infiltration values per cell using the Curve Number method B (with recovery) provide the smaxfile (as well as the sefffile and ksfile) as maximum soil moisture storage capacity in m, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Curve Number method B (with recovery) prefer infiltrationfile with infiltrationtype = cnb. The smaxfile contains the maximum soil moisture storage capacity in m. :units: m :required: no :format: bin sefffile = sfincs.seff - :description: For spatially varying infiltration values per cell using the Curve Number method B (with recovery) provide the sefffile (as well as the smaxfile and ksfile) as soil moisture storage capacity at the start in m, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Curve Number method B (with recovery) prefer infiltrationfile with infiltrationtype = cnb. The sefffile contains soil moisture storage capacity at the start in m. :units: m :required: no :format: bin ksfile = sfincs.ks - :description: For spatially varying infiltration values per cell using the Curve Number method B (with recovery) provide the ksfile (as well as the smaxfile and sefffile) as saturated hydraulic conductivity in mm/hr, with the same grid based input as the depfile using a binary file. - :description: For spatially varying infiltration values per cell using the Green & Ampt method (with recovery) provide the ksfile (as well as the sigmafile and psifile) as saturated hydraulic conductivity in mm/hr, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Curve Number method B (with recovery) and Green & Ampt infiltration prefer infiltrationfile with infiltrationtype = cnb or gai. The ksfile contains saturated hydraulic conductivity in mm/hr. :units: mm/hr :required: no :format: bin sigmafile = sfincs.sigma - :description: For spatially varying infiltration values per cell using the Green & Ampt method (with recovery) provide the sigmafile (as well as the psifile and ksfile) as suction head at the wetting front in mm, with the same grid based input as the depfile using a binary file. - :units: mm + :description: Backward compatibility only. For Green & Ampt infiltration prefer infiltrationfile with infiltrationtype = gai. The sigmafile contains soil moisture deficit in [-]. + :units: - :required: no :format: bin psifile = sfincs.psi - :description: For spatially varying infiltration values per cell using the Green & Ampt method (with recovery) provide the psifile (as well as the sigmafile and ksfile) as soil moisture deficit in [-], with the same grid based input as the depfile using a binary file. - :units: - + :description: Backward compatibility only. For Green & Ampt infiltration prefer infiltrationfile with infiltrationtype = gai. The psifile contains suction head at the wetting front in mm. + :units: mm :required: no :format: bin f0file = sfincs.f0 - :description: For spatially varying infiltration values per cell using the Horton method (with recovery) provide the f0file (as well as the fcfile and kdfile) as maximum (Initial) Infiltration Capacity in mm/hr, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Horton infiltration prefer infiltrationfile with infiltrationtype = hor. The f0file contains maximum (initial) infiltration capacity in mm/hr. :units: mm/hr :required: no :format: bin fcfile = sfincs.fc - :description: For spatially varying infiltration values per cell using the Horton method (with recovery) provide the fcfile (as well as the f0file and kdfile) as Minimum (Asymptotic) Infiltration Rate in mm/hr, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Horton infiltration prefer infiltrationfile with infiltrationtype = hor. The fcfile contains the minimum (asymptotic) infiltration rate in mm/hr. :units: mm/hr :required: no :format: bin kdfile = sfincs.kd - :description: For spatially varying infiltration values per cell using the Horton method (with recovery) provide the kdfile (as well as the f0file and fcfile) as empirical constant (hr-1) of decay, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Horton infiltration prefer infiltrationfile with infiltrationtype = hor. The kdfile contains the empirical decay constant in hr-1. :units: hr-1 :required: no :format: bin @@ -676,5 +698,14 @@ Structures :description: Drainage pumps, culverts and check valves are both specified using the same format file, put with a different indication of the type (type=1 is drainage pump, type=2 is culvert and type=3 is check valve). :units: coordinates: m in projected UTM zone, discharges in m^3/s. :required: no - :format: asc - + :format: asc + +Urban drainage +----- + + urbfile = sfincs.urb + :description: TOML file declaring one or more urban-drainage zones. Each zone is a polygon mapped to a single outfall cell; zone cells drain to the outfall at a design rate (specified either as design_precip in mm/hr or max_outfall_rate in m^3/s), and the outfall can push water back into the cells unless a check valve is set. See 'Urban Drainage' in the user manual for the full schema. + :units: coordinates: m in projected UTM zone; design rate in mm/hr or m^3/s; thresholds in m. + :required: no + :format: toml + diff --git a/source/build_scripts/Dockerfile.cpu.ifx b/source/build_scripts/Dockerfile.cpu.ifx new file mode 100644 index 000000000..820f69d1e --- /dev/null +++ b/source/build_scripts/Dockerfile.cpu.ifx @@ -0,0 +1,58 @@ +# SFINCS CPU image built with the Intel ifx compiler. +# +# Build from the SFINCS source ROOT (so the COPY context is the whole tree): +# docker build -f build_scripts/Dockerfile.cpu.ifx -t sfincs-cpu-ifx:local . +# +# Mirrors HurryWave's build_scripts/Dockerfile.cpu.ifx. Two stages: compile on +# the oneAPI HPC kit (which ships ifx) with the Intel runtime linked statically +# (-static-intel -qopenmp-link=static), then copy the install onto a slim ubuntu +# base. Static-linking keeps the final image ~1 GB instead of dragging in the +# multi-GB intel/oneapi-runtime image (MKL/MPI/TBB that SFINCS never uses). +# +# netcdf: Ubuntu's libnetcdff is gfortran-built and its .mod files are +# ABI-incompatible with ifx, so we let ./configure compile the BUNDLED +# netcdf-fortran (third_party_open/netcdf) with ifx. libnetcdf-dev supplies only +# the C library. (This is also why the gfortran -fallow-argument-mismatch flag +# from the gfortran Dockerfile is dropped here — it was a gfortran-only +# workaround for building netcdf-fortran; ifx neither needs nor understands it.) + +# ---- build stage ---------------------------------------------------------- +FROM intel/oneapi-hpckit:latest AS build +ENV DEBIAN_FRONTEND=noninteractive +RUN apt update && apt install -y dos2unix libnetcdf-dev build-essential \ + autoconf automake libtool pkg-config tzdata m4 + +COPY . /usr/src/sfincs +WORKDIR /usr/src/sfincs + +# Normalise line endings of anything that may have arrived as CRLF (Windows checkout). +RUN find . \( -name '*.m4' -o -name '*.ac' -o -name '*.am' \ + -o -name '*.f90' -o -name '*.F90' -o -name '*.sh' \) | xargs dos2unix + +# Build with ifx. +# -static-intel / -qopenmp-link=static : link the Intel runtime into the +# binary so it runs on the slim runtime stage (no oneAPI libs needed). +# --disable-openacc : pure CPU/OpenMP build (matches the gfortran CPU image). +# --disable-shared : force static libs, incl. the bundled netcdf-fortran. +# The oneAPI image already sourced setvars.sh (SETVARS_COMPLETED set, ifx on +# PATH) — do NOT re-source it: re-running setvars.sh without --force exits +# non-zero and would abort this RUN. +# +# NOTE: -fp-model fast=2 / -no-prec-div / -fno-alias / -fno-fnalias match +# HurryWave's ifx build (aggressive floating-point optimisation). Switch to +# -fp-model precise if you need tighter FP reproducibility vs the gfortran build. +RUN autoreconf -vif && \ + FC=ifx \ + FCFLAGS="-fpp -qopenmp -O3 -fp-model fast=2 -no-prec-div -fno-alias -fno-fnalias -w -static-intel -qopenmp-link=static" \ + FFLAGS="-fpp -qopenmp -O3 -fp-model fast=2 -no-prec-div -fno-alias -fno-fnalias -w -static-intel -qopenmp-link=static" \ + ./configure --disable-openacc --disable-shared && \ + make && make install + +# ---- runtime stage -------------------------------------------------------- +FROM ubuntu:jammy +ENV DEBIAN_FRONTEND=noninteractive +RUN apt update && apt install -y libnetcdf-dev tzdata && rm -rf /var/lib/apt/lists/* +COPY --from=build /usr/local /usr/local +VOLUME /data +WORKDIR /data +CMD ["sfincs"] diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 36e826f67..d32fb1890 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -29,6 +29,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -107,12 +144,15 @@ - - + + + - + + + + - @@ -166,6 +206,8 @@ + + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index 2711d1a2b..7f3e0c0f5 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -38,6 +38,7 @@ libsfincs_la_SOURCES = \ ../third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 \ ../third_party_open/utils/toml-f/src/tomlf/type/table.f90 \ ../third_party_open/utils/toml-f/src/tomlf/type.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/ser.f90 \ ../third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 \ ../third_party_open/utils/toml-f/src/tomlf/de/parser.f90 \ ../third_party_open/utils/toml-f/src/tomlf/de.f90 \ @@ -50,6 +51,7 @@ libsfincs_la_SOURCES = \ ../third_party_open/utils/toml-f/src/tomlf/all.f90 \ ../third_party_open/utils/toml-f/src/tomlf.f90 \ sfincs_log.f90 \ + sfincs_timers.f90 \ sfincs_date.f90 \ sfincs_read.f90 \ sfincs_spiderweb.f90 \ @@ -77,6 +79,10 @@ libsfincs_la_SOURCES = \ sfincs_continuity.f90 \ sfincs_crosssections.f90 \ sfincs_discharges.f90 \ + sfincs_rule_expression.f90 \ + sfincs_src_structures.f90 \ + utils/sfincs_polygons.f90 \ + sfincs_urban_drainage.f90 \ sfincs_subgrid.F90 \ sfincs_timestep_analysis.f90 \ sfincs_infiltration.f90 \ diff --git a/source/src/sfincs.f90 b/source/src/sfincs.f90 index 38fe30bb2..bab831811 100644 --- a/source/src/sfincs.f90 +++ b/source/src/sfincs.f90 @@ -15,8 +15,9 @@ program sfincs ! ! Set BMI flags to false ! - bmi = .false. + bmi = .false. use_qext = .false. + use_dzbext = .false. ! ierr = sfincs_initialize() ! diff --git a/source/src/sfincs_bathtub.f90 b/source/src/sfincs_bathtub.f90 index 76e1c60f9..4f67e2b61 100644 --- a/source/src/sfincs_bathtub.f90 +++ b/source/src/sfincs_bathtub.f90 @@ -114,23 +114,18 @@ subroutine initialize_bathtub() end subroutine - subroutine bathtub_compute_water_levels(tloop) + subroutine bathtub_compute_water_levels() ! use sfincs_data + use sfincs_timers use geometry ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! integer :: nm, i1, i2 real*4 :: zbt, w1, w2 ! - call system_clock(count0, count_rate, count_max) + call timer_start('continuity') ! !$omp parallel & !$omp private ( nm, i1, i2, w1, w2 ) @@ -168,8 +163,7 @@ subroutine bathtub_compute_water_levels(tloop) ! !$acc update device( zs, zsmax ) ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate + call timer_stop('continuity') ! end subroutine diff --git a/source/src/sfincs_bmi.f90 b/source/src/sfincs_bmi.f90 index 388bcefa2..3ab7e83f3 100644 --- a/source/src/sfincs_bmi.f90 +++ b/source/src/sfincs_bmi.f90 @@ -23,7 +23,7 @@ module sfincs_bmi public :: get_end_time public :: get_time_step public :: get_current_time - public :: update_zbuv + public :: bmi_update_bed_level public :: update_apparent_roughness public :: get_sfincs_cell_index public :: get_sfincs_cell_indices @@ -119,6 +119,8 @@ function get_value_ptr(c_var_name, c_data) result(ierr) & c_data = c_loc(subgrid_z_zmin) case("qext") c_data = c_loc(qext) + case("dzbext") + c_data = c_loc(dzbext) case("uorb") c_data = c_loc(uorb) case default @@ -150,6 +152,8 @@ function get_var_shape(c_var_name, var_shape) result(ierr) & var_shape(1) = size(z_index_z_n) case("qext") var_shape(1) = size(qext) + case("dzbext") + var_shape(1) = size(dzbext) case default ierr = -1 end select @@ -170,7 +174,7 @@ function get_var_type(c_var_name, c_type) result(ierr) & var_name = char_array_to_string(c_var_name, strlen(c_var_name, BMI_LENVARADDRESS)) select case(var_name) - case("z_xz", "z_yz", "zb", "subgrid_z_zmin", "qext", "uorb") + case("z_xz", "z_yz", "zb", "subgrid_z_zmin", "qext", "dzbext", "uorb") type_name = "float" case("zs") type_name = "double" @@ -198,7 +202,7 @@ function get_var_rank(c_var_name, rank) result(ierr) & var_name = char_array_to_string(c_var_name, strlen(c_var_name, BMI_LENVARADDRESS)) select case(var_name) - case("z_xz", "z_yz", "zs", "zb", "subgrid_z_zmin", "qext", "uorb") + case("z_xz", "z_yz", "zs", "zb", "subgrid_z_zmin", "qext", "dzbext", "uorb") rank = 1 case default ierr = -1 @@ -227,7 +231,23 @@ function set_logical(c_flag_name, ival) result(ierr) bind(C, name="set_logical") select case(flag_name) case("qext") use_qext = bval - !write(*,*)'use_qext = ', use_qext + !write(*,*)'use_qext = ', use_qext + case("dzbext") + ! + ! Lazily allocate the external delta-bed-level array on first enable. + ! Once allocated we keep it around; toggling the flag off later just + ! disables the update path without freeing memory (same pattern as + ! qext is handled elsewhere). + ! + if (bval .and. .not. allocated(dzbext)) then + ! + allocate(dzbext(np)) + dzbext = 0.0 + ! + endif + ! + use_dzbext = bval + ! case default ierr = -1 end select @@ -274,14 +294,15 @@ function get_current_time(tcurrent) result(ierr) bind(C, name="get_current_time" end function get_current_time - function update_zbuv() result(ierr) bind(C, name="update_zbuv") - ! Update bed level at uv points - !DEC$ ATTRIBUTES DLLEXPORT :: update_zbuv + function bmi_update_bed_level() result(ierr) bind(C, name="update_bed_level") + ! Apply dzbext to the bed-level arrays (zb or subgrid_z_zmin/zmax and + ! subgrid_uv_zmin/zmax) and rebuild zbuvmx for non-subgrid runs. + !DEC$ ATTRIBUTES DLLEXPORT :: bmi_update_bed_level integer(kind=c_int) :: ierr - call compute_zbuvmx() + call update_bed_level() ierr = 0 - - end function update_zbuv + + end function bmi_update_bed_level function update_apparent_roughness() result(ierr) bind(C, name="update_apparent_roughness") ! Update apparent roughness at uv points diff --git a/source/src/sfincs_boundaries.f90 b/source/src/sfincs_boundaries.f90 index 34d8d64c5..82a6c469d 100644 --- a/source/src/sfincs_boundaries.f90 +++ b/source/src/sfincs_boundaries.f90 @@ -1123,26 +1123,21 @@ subroutine update_boundary_fluxes(dt, t) - subroutine update_boundaries(t, dt, tloop) + subroutine update_boundaries(t, dt) ! ! Update all boundary conditions ! use sfincs_data + use sfincs_timers ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*8 :: t real*4 :: dt ! - call system_clock(count0, count_rate, count_max) - ! if (boundaries_in_mask) then + ! + call timer_start('boundaries') ! if (nbnd > 0) then ! @@ -1156,7 +1151,7 @@ subroutine update_boundaries(t, dt, tloop) ! as these are not used in bathtub mode ! if (.not. bathtub) then - ! + ! ! Update boundary conditions at grid points (water levels) ! call update_boundary_conditions(t, dt) @@ -1167,11 +1162,10 @@ subroutine update_boundaries(t, dt, tloop) ! endif ! + call timer_stop('boundaries') + ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate - ! end subroutine ! ! diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index 592477666..f3fa94ae7 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -1,165 +1,490 @@ module sfincs_continuity - -contains - - subroutine compute_water_levels(t, dt, tloop) ! - use sfincs_data + ! Water-level / volume update stage of the SFINCS time step. Runs after + ! sfincs_momentum has produced the face fluxes q on each cell edge and + ! is responsible for closing the volume balance on every active cell. ! - implicit none + ! See the breakdown at the top of update_continuity for exactly + ! which terms are accumulated into qsrc, which operate on qinfmap, and + ! which come from the hydrodynamic fluxes q already computed upstream. ! - real*4 :: dt - real*8 :: t + ! Data flow per step: + ! input : q(nuv), qext(np) (optional BMI), river/structure state, + ! qinfmap, storage_volume (subgrid), zs/z_volume at t + ! output : zs (all paths) and z_volume (subgrid path) advanced to + ! t+dt; optional zsmax, vmax, qmax, twet accumulators ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop + ! Subroutines: ! - call system_clock(count0, count_rate, count_max) + ! update_continuity(t, dt) + ! Main per-timestep entry. Orchestrates river discharges, drainage + ! structures, optional BMI qext, infiltration, and dispatches the + ! water-level update. Called from sfincs_lib (main time-stepping + ! loop). ! - if (subgrid) then - ! - call compute_water_levels_subgrid(dt,t) - ! - else - ! - call compute_water_levels_regular(dt,t) - ! - endif - ! - ! Put non-default store options in a separate subroutine (all but zsmax) to save computation time when not used (both regular and subgrid): + ! compute_water_levels_regular(dt, t) + ! Non-subgrid (bathtub / simple bathy) water-level update. Called + ! from update_continuity. ! - if ((store_maximum_velocity .eqv. .true.) .or. (store_maximum_flux .eqv. .true.) .or. (store_twet .eqv. .true.)) then - ! - call compute_store_variables(dt) - ! - endif - ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + ! compute_water_levels_subgrid(dt, t) + ! Subgrid-tables water-level update with storage-volume + ! bookkeeping. Called from update_continuity. ! - end subroutine - - - subroutine compute_water_levels_regular(dt,t) + ! compute_store_variables(dt) + ! Update optional per-cell vmax / qmax / twet diagnostics. Called + ! from update_continuity only when any of store_maximum_velocity, + ! store_maximum_flux or store_twet is enabled. ! - use sfincs_data - ! - implicit none - ! - real*4 :: dt - real*8 :: t - ! - integer :: nm - integer :: isrc - ! - integer :: iwm - ! - integer :: nmu - integer :: nmd - integer :: num - integer :: ndm +contains ! - real*4 :: qnmu - real*4 :: qnmd - real*4 :: qnum - real*4 :: qndm - real*4 :: factime - real*4 :: dvol + !-----------------------------------------------------------------------------------------------------! ! - if (snapwave) then ! need to compute filtered water levels for snapwave + subroutine update_continuity(t, dt) ! - factime = min(dt / wavemaker_filter_time, 1.0) + ! Unified continuity update: orchestrates all water balance terms + ! for one time step. Advances zs (and z_volume on the subgrid path), + ! and optionally updates the store_* running maxima. ! - endif - ! - !$acc parallel present( kcs, zs, zb, netprcp, prcp, q, qext, zsmax, zsm, maxzsm, & - !$acc z_flags_iref, uv_flags_iref, & - !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & - !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & - !$acc nmindsrc, qtsrc, & - !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num ) - ! - ! First discharges (don't do this parallel, as it's probably not worth it) + ! Called from: sfincs_lib (main time-stepping loop). + ! + ! Sources and sinks (all accumulated into qsrc, in m3/s): + ! 1. Precipitation (+) => update_meteo_forcing (prcp * cell area), + ! already done before entering this routine + ! 2. River discharges (+/-) => update_discharges (adds to qsrc) + ! 3. Drainage structures (+/-) => update_src_structures (adds to qsrc) + ! 4. Infiltration rate field qinfmap (-) => update_infiltration_map (-qinfmap * cell area, + ! flavors: con, c2d, cna, cnb, gai, hor, bkt) + ! 5. Urban drainage (+/-) => update_urban_drainage + ! 6. External source/sink qext (+/-) => added to qsrc here (BMI coupling) + ! + ! qsrc itself is cleared at the end of compute_water_levels_{regular, + ! subgrid} (per active cell), so steps 1-6 above start from zero every + ! step without an explicit reset here. + ! + ! Hydrodynamic fluxes q => computed in sfincs_momentum + ! + ! compute_water_levels_{regular,subgrid} then updates zs/z_volume using: + ! - qsrc * dt => all sources/sinks above + ! - div(q) * dt => horizontal flux divergence + ! - storage volume => absorbs excess volume (subgrid only) + ! + use sfincs_data + use sfincs_timers + use sfincs_infiltration + use sfincs_discharges + use sfincs_src_structures + use sfincs_urban_drainage + ! + implicit none + ! + real*8 :: t + real*4 :: dt + ! + integer :: nm + ! + ! 1. Precipitation was already accumulated into qsrc by + ! update_meteo_forcing (called from sfincs_lib before this routine). + ! + ! 2. River discharges => update_discharges (adds to qsrc) + ! + call update_discharges(t, dt) + ! + ! 3. Drainage structures (pumps/gates/culverts/...) => update_src_structures (adds to qsrc) + ! + call update_src_structures(t, dt) + ! + ! 4. Compute infiltration rates; update_infiltration_map also subtracts + ! qinfmap * cell_area from qsrc. + ! + if (infiltration) then + ! + call update_infiltration_map(dt) + ! + endif + ! + ! 5. Urban drainage => update_urban_drainage (adds to qsrc) + ! + if (urban_drainage) then + ! + call update_urban_drainage(t, dt) + ! + endif + ! + ! 6. External source/sink (+/-) => add qext to qsrc (set via BMI coupling) + ! + if (use_qext) then + ! + !$omp parallel & + !$omp private ( nm ) + !$omp do + !$acc loop gang vector + do nm = 1, np + ! + qsrc(nm) = qsrc(nm) + qext(nm) + ! + enddo + !$acc end loop + !$omp end parallel + ! + endif + ! + ! Update water levels: applies qsrc * dt and flux divergence to zs/z_volume + ! + call timer_start('continuity') + ! + if (subgrid) then + ! + call compute_water_levels_subgrid(dt, t) + ! + else + ! + call compute_water_levels_regular(dt, t) + ! + endif + ! + ! Put non-default store options in a separate subroutine (all but zsmax) to save computation time when not used (both regular and subgrid): + ! + if ((store_maximum_velocity .eqv. .true.) .or. (store_maximum_flux .eqv. .true.) .or. (store_twet .eqv. .true.)) then + ! + call compute_store_variables(dt) + ! + endif + ! + call timer_stop('continuity') + ! + end subroutine ! - if (nsrcdrn > 0) then - ! - !$acc loop - do isrc = 1, nsrcdrn - ! - nm = nmindsrc(isrc) - ! - if (crsgeo) then - ! - zs(nmindsrc(isrc)) = max(zs(nm) + qtsrc(isrc) * dt / cell_area_m2(nm), zb(nm)) - ! - else - ! - zs(nmindsrc(isrc)) = max(zs(nm) + qtsrc(isrc) * dt / cell_area(z_flags_iref(nm)), zb(nm)) - ! - endif - ! - enddo - ! - endif + !-----------------------------------------------------------------------------------------------------! ! - !$omp parallel & - !$omp private ( nm,dvol,nmd,nmu,ndm,num,qnmd,qnmu,qndm,qnum,iwm) - !$omp do schedule ( dynamic, 256 ) - !$acc loop gang vector - do nm = 1, np - ! - if (kcs(nm) == 1) then ! Regular point + subroutine compute_water_levels_regular(dt, t) + ! + ! Advance zs(np) by dt on the non-subgrid (bathtub / simple bathy) + ! path. Applies cell-wise qsrc contributions and the horizontal + ! flux divergence, handles the optional wavemaker cells (kcs == 4), + ! updates the snapwave-filtered water level zsm, and accumulates + ! zsmax / t_zsmax when requested. + ! + ! Called from: update_continuity (when subgrid is false). + ! + use sfincs_data + ! + implicit none + ! + real*4 :: dt + real*8 :: t + ! + integer :: nm + ! + integer :: iwm + ! + integer :: nmu + integer :: nmd + integer :: num + integer :: ndm + ! + real*4 :: qnmu + real*4 :: qnmd + real*4 :: qnum + real*4 :: qndm + real*4 :: factime + ! + if (snapwave) then ! need to compute filtered water levels for snapwave + ! + factime = min(dt / wavemaker_filter_time, 1.0) + ! + endif + ! + !$acc parallel present( kcs, zs, zb, q, qext, zsmax, zsm, maxzsm, & + !$acc z_flags_iref, uv_flags_iref, & + !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & + !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & + !$acc qsrc, & + !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num ) + ! + !$omp parallel & + !$omp private ( nm, nmd, nmu, ndm, num, qnmd, qnmu, qndm, qnum, iwm ) + !$omp do schedule ( dynamic, 256 ) + !$acc loop gang vector + do nm = 1, np ! - if (precip) then + if (kcs(nm) == 1) then ! Regular point ! - zs(nm) = zs(nm) + netprcp(nm) * dt + ! Apply cell-wise discharges qsrc (rivers, drainage structures, qext) + ! + if (qsrc(nm) /= 0.0) then + ! + if (crsgeo) then + zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area_m2(nm), zb(nm)) + else + zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area(z_flags_iref(nm)), zb(nm)) + endif + ! + endif + ! + nmd = z_index_uv_md(nm) + nmu = z_index_uv_mu(nm) + ndm = z_index_uv_nd(nm) + num = z_index_uv_nu(nm) + ! + if (crsgeo) then + ! + ! Use cell width dxm (which varies with latitude) + ! + zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) / dxm(nm) + (q(ndm) - q(num)) * dyrinv(z_flags_iref(nm)) ) * dt + ! + ! Should really be: + ! + ! zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) / dxm(nm) + (q(ndm) * f - q(num) / f) * dyrinv(z_flags_iref(nm)) ) * dt + ! + ! Where f if a correction factor for the ratio between cell width at cell centre and cell bottom: + ! + ! f = cos(y - 0.5*dy) / cos(y) (this holds both in northern and southern hemisphere) + ! + else + ! + zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) * dxrinv(z_flags_iref(nm)) + (q(ndm) - q(num)) * dyrinv(z_flags_iref(nm)) ) * dt + ! + endif ! endif ! - if (use_qext) then + if (wavemaker) then ! - ! Add external source (e.g. from XMI coupling) - ! - zs(nm) = zs(nm) + qext(nm) * dt + if (kcs(nm) == 4) then + ! + ! Wave maker point (seaward of wave maker) + ! Here we use the mean flux at the location of the wave maker + ! + iwm = z_index_wavemaker(nm) + ! + if (wavemaker_nmd(iwm) > 0) then + ! + ! Wave paddle on the left + ! + qnmd = wavemaker_uvmean(wavemaker_nmd(iwm)) + ! + else + ! + qnmd = q(z_index_uv_md(nm)) + ! + endif + ! + if (wavemaker_nmu(iwm) > 0) then + ! + ! Wave paddle on the right + ! + qnmu = wavemaker_uvmean(wavemaker_nmu(iwm)) + ! + else + ! + qnmu = q(z_index_uv_mu(nm)) + ! + endif + ! + if (wavemaker_ndm(iwm) > 0) then + ! + ! Wave paddle below + ! + qndm = wavemaker_uvmean(wavemaker_ndm(iwm)) + ! + else + ! + qndm = q(z_index_uv_nd(nm)) + ! + endif + ! + if (wavemaker_num(iwm) > 0) then + ! + ! Wave paddle above + ! + qnum = wavemaker_uvmean(wavemaker_num(iwm)) + ! + else + ! + qnum = q(z_index_uv_nu(nm)) + ! + endif + ! + zs(nm) = zs(nm) + (((qnmd - qnmu) * dxrinv(z_flags_iref(nm)) + (qndm - qnum) * dyrinv(z_flags_iref(nm)))) * dt + ! + endif ! endif ! - nmd = z_index_uv_md(nm) - nmu = z_index_uv_mu(nm) - ndm = z_index_uv_nd(nm) - num = z_index_uv_nu(nm) - ! - if (crsgeo) then + if (snapwave) then ! - ! Use cell width dxm (which varies with latitude) + ! Time-averaged water level used for SnapWave using exponential filter ! - zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) / dxm(nm) + (q(ndm) - q(num)) * dyrinv(z_flags_iref(nm)) ) * dt + ! Would double exponential filtering be better? ! - ! Should really be: + zsm(nm) = factime * zs(nm) + (1.0 - factime) * zsm(nm) ! - ! zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) / dxm(nm) + (q(ndm) * f - q(num) / f) * dyrinv(z_flags_iref(nm)) ) * dt + if (store_maximum_waterlevel) then + ! + maxzsm(nm) = max(maxzsm(nm), zsm(nm)) + ! + endif ! - ! Where f if a correction factor for the ratio between cell width at cell centre and cell bottom: + endif + ! + ! No continuity update but keeping track of variables + ! zsmax used by default, therefore keep in standard continuity loop: + ! + if (store_maximum_waterlevel) then + ! + ! Store when the maximum water level changed ! - ! f = cos(y - 0.5*dy) / cos(y) (this holds both in northern and southern hemisphere) - ! - else + if (store_t_zsmax) then + if (zs(nm) > zsmax(nm)) then + if ( (zs(nm) - zb(nm)) > huthresh) then + t_zsmax(nm) = t + endif + endif + endif ! - zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) * dxrinv(z_flags_iref(nm)) + (q(ndm) - q(num)) * dyrinv(z_flags_iref(nm)) ) * dt + ! Store the maximum water level itself + ! + zsmax(nm) = max(zsmax(nm), zs(nm)) ! endif ! - endif + ! Reset qsrc to zero for the next time step + ! + qsrc(nm) = 0.0 + ! + enddo + !$omp end do + !$omp end parallel + !$acc end parallel + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine compute_water_levels_subgrid(dt,t) + ! + ! Advance z_volume(np) and zs(np) by dt on the subgrid-tables path. + ! Accumulates the cell volume change dvol from qsrc and the + ! horizontal flux divergence, routes excess volume through + ! storage_volume (when use_storage_volume is set), updates + ! z_volume, and recovers the new water level via subgrid table + ! interpolation. Also handles wavemaker cells (kcs == 4), the + ! snapwave-filtered zsm, and zsmax / t_zsmax accumulation. + ! + ! Called from: update_continuity (when subgrid is true). + ! + use sfincs_data + ! + implicit none + ! + real*4 :: dt + real*8 :: t + ! + integer :: nm + ! + integer :: iwm + ! + integer :: nmu + integer :: nmd + integer :: num + integer :: ndm + ! + real*4 :: factime + real*4 :: dvol + ! + real*4 :: qnmu + real*4 :: qnmd + real*4 :: qnum + real*4 :: qndm + ! + integer :: iuv + real*4 :: dzvol + real*4 :: facint + real*4 :: a + real*4 :: dv + real*4 :: zs00 + real*4 :: zs11 ! if (wavemaker) then - ! - if (kcs(nm) == 4) then + ! + factime = min(dt / wavemaker_filter_time, 1.0) + ! + endif + ! + !$omp parallel & + !$omp private ( dvol, nmd, nmu, ndm, num, a, iuv, facint, dzvol, iwm, & + !$omp qnmd, qnmu, qndm, qnum, dv, zs00, zs11 ) + !$omp do schedule ( dynamic, 256 ) + !$acc parallel present( kcs, zs, zs0, zb, z_volume, zsmax, zsm, maxzsm, zsderv, & + !$acc subgrid_z_zmin, subgrid_z_zmax, subgrid_z_dep, subgrid_z_volmax, & + !$acc q, qext, z_flags_iref, uv_flags_iref, & + !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & + !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & + !$acc z_index_wavemaker, wavemaker_uvmean, & + !$acc wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, storage_volume) + !$acc loop gang vector + do nm = 1, np + ! + ! And now water level changes due to horizontal fluxes + ! + dvol = 0.0 + ! + if (kcs(nm) == 1) then + ! + ! Apply cell-wise discharges qsrc (rivers, drainage structures, qext) + ! + if (qsrc(nm) /= 0.0) then + ! + dvol = dvol + qsrc(nm) * dt + ! + endif + ! + nmd = z_index_uv_md(nm) + nmu = z_index_uv_mu(nm) + ndm = z_index_uv_nd(nm) + num = z_index_uv_nu(nm) + ! + if (crsgeo) then + ! + ! dxm = size of cell in x - direction (it varies for all cells) + ! dyrm = size of cell in y - direction (it varies for all zoom levels) + ! + dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) - q(num)) * dxm(nm) ) * dt + ! + ! Should really be: + ! + ! dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) * f - q(num) / f) * dxm(nm) ) * dt + ! + ! where f if a correction factor for the ratio between cell width at cell centre and cell bottom: + ! + ! f = cos(y - 0.5*dy) / cos(y) (this holds both in northern and southern hemisphere) + ! + ! This assumes that we can use the same factor f for q(ndm) and q(num), i.e.: + ! + ! cos(y - 0.5*dy) / cos(y) ~= cos(y + 0.5*dy) / cos(y) or: cos(y - 0.5*dy) ~= cos(y + 0.5*dy) which is pretty much true for dy < 1.0 degree + ! + else + ! + if (use_quadtree) then + ! + ! dxrm = size of cell in x - direction (it varies for all zoom levels) + ! dyrm = size of cell in y - direction (it varies for all zoom levels) + ! + dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) - q(num)) * dxrm(z_flags_iref(nm)) ) * dt + ! + else + ! + dvol = dvol + ( (q(nmd) - q(nmu)) * dy + (q(ndm) - q(num)) * dx ) * dt + ! + endif + ! + endif + endif ! kcs==1 + ! + if (wavemaker .and. kcs(nm) == 4) then ! ! Wave maker point (seaward of wave maker) - ! Here we use the mean flux at the location of the wave maker + ! Here we use the mean flux at the location of the wave maker ! iwm = z_index_wavemaker(nm) ! @@ -173,7 +498,7 @@ subroutine compute_water_levels_regular(dt,t) ! qnmd = q(z_index_uv_md(nm)) ! - endif + endif ! if (wavemaker_nmu(iwm) > 0) then ! @@ -185,7 +510,7 @@ subroutine compute_water_levels_regular(dt,t) ! qnmu = q(z_index_uv_mu(nm)) ! - endif + endif ! if (wavemaker_ndm(iwm) > 0) then ! @@ -197,7 +522,7 @@ subroutine compute_water_levels_regular(dt,t) ! qndm = q(z_index_uv_nd(nm)) ! - endif + endif ! if (wavemaker_num(iwm) > 0) then ! @@ -209,514 +534,279 @@ subroutine compute_water_levels_regular(dt,t) ! qnum = q(z_index_uv_nu(nm)) ! - endif + endif ! - zs(nm) = zs(nm) + (((qnmd - qnmu) * dxrinv(z_flags_iref(nm)) + (qndm - qnum) * dyrinv(z_flags_iref(nm)))) * dt + if (use_quadtree) then + ! + dvol = dvol + ( (qnmd - qnmu) * dyrm(z_flags_iref(nm)) + (qndm - qnum) * dxrm(z_flags_iref(nm)) ) * dt + ! + else + ! + dvol = dvol + ( (qnmd - qnmu) * dy + (qndm - qnum) * dx ) * dt + ! + endif ! - endif - ! - endif - ! - if (snapwave) then - ! - ! Time-averaged water level used for SnapWave using exponential filter - ! - ! Would double exponential filtering be better? - ! - zsm(nm) = factime * zs(nm) + (1.0 - factime) * zsm(nm) - ! - if (store_maximum_waterlevel) then - ! - maxzsm(nm) = max(maxzsm(nm), zsm(nm)) - ! - endif - ! - endif - ! - ! No continuity update but keeping track of variables - ! zsmax used by default, therefore keep in standard continuity loop: - ! - if (store_maximum_waterlevel) then - ! - ! Store when the maximum water level changed - ! - if (store_t_zsmax) then - if (zs(nm) > zsmax(nm)) then - if ( (zs(nm) - zb(nm)) > huthresh) then - t_zsmax(nm) = t - endif - endif - endif - ! - ! Store the maximum water level itself - ! - zsmax(nm) = max(zsmax(nm), zs(nm)) - ! - endif - ! - enddo - !$omp end do - !$omp end parallel - !$acc end parallel - ! - end subroutine - - - subroutine compute_water_levels_subgrid(dt,t) - ! - use sfincs_data - ! - implicit none - ! - real*4 :: dt - real*8 :: t - ! - integer :: nm - integer :: isrc - ! - integer :: iwm - integer :: ind - ! - integer :: nmu - integer :: nmd - integer :: num - integer :: ndm - ! - real*4 :: factime - real*4 :: dvol - real*4 :: dzsdt - ! - real*4 :: qnmu - real*4 :: qnmd - real*4 :: qnum - real*4 :: qndm - ! - integer :: iuv - real*4 :: dzvol - real*4 :: facint - real*4 :: a - real*4 :: dv - real*4 :: zs00 - real*4 :: zs11 - ! - if (wavemaker) then - ! - factime = min(dt / wavemaker_filter_time, 1.0) - ! - endif - ! - ! First discharges (don't do this parallel, as it's probably not worth it) - ! NVFORTAN turns this into a sequential loop (!$acc loop seq) - ! - if (nsrcdrn > 0) then - ! - !$acc serial present( z_volume, nmindsrc, qtsrc ) - do isrc = 1, nsrcdrn - ! - nm = nmindsrc(isrc) - ! - if ((z_volume(nm) >= 0) .or. ((qtsrc(isrc)<0.0) .and. (z_volume(nm) >= 0))) then - z_volume(nm) = z_volume(nm) + qtsrc(isrc) * dt endif ! - enddo - !$acc end serial - ! - endif - ! - !$omp parallel & - !$omp private ( dvol,dzsdt,nmd,nmu,ndm,num,a,iuv,facint,dzvol,ind,iwm,qnmd,qnmu,qndm,qnum,dv,zs00,zs11 ) - !$omp do schedule ( dynamic, 256 ) - !$acc parallel present( kcs, zs, zs0, zb, z_volume, zsmax, zsm, maxzsm, zsderv, & - !$acc subgrid_z_zmin, subgrid_z_zmax, subgrid_z_dep, subgrid_z_volmax, & - !$acc netprcp, prcp, q, qext, z_flags_iref, uv_flags_iref, & - !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & - !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & - !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, storage_volume) - !$acc loop gang vector - do nm = 1, np - ! - ! And now water level changes due to horizontal fluxes - ! - dvol = 0.0 - ! - if (kcs(nm) == 1) then - ! - nmd = z_index_uv_md(nm) - nmu = z_index_uv_mu(nm) - ndm = z_index_uv_nd(nm) - num = z_index_uv_nu(nm) + ! We got the volume change dvol in each active cell from fluxes + ! Now first add precip and qext + ! Then adjust for storage volume + ! Then update the volume and compute new water level ! - if (crsgeo) then + if (kcs(nm) == 1 .or. kcs(nm) == 4) then ! - ! dxm = size of cell in x - direction (it varies for all cells) - ! dyrm = size of cell in y - direction (it varies for all zoom levels) + ! Obtain cell area ! - dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) - q(num)) * dxm(nm) ) * dt - ! - ! Should really be: + if (crsgeo) then + ! + a = cell_area_m2(nm) + ! + else + ! + a = cell_area(z_flags_iref(nm)) + ! + endif ! - ! dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) * f - q(num) / f) * dxm(nm) ) * dt + ! C5. Storage volume ! - ! where f if a correction factor for the ratio between cell width at cell centre and cell bottom: + if (use_storage_volume) then + ! + ! If water enters the cell through a point discharge, it will NOT end up in storage volume ! + ! + if (storage_volume(nm) > 1.0e-6 .and. dvol > 0.0) then + ! + ! There is still some storage left, and water is entering the cell + ! + ! Compute remaining storage volume + ! + dv = storage_volume(nm) - dvol + ! + ! Update storage volume (it cannot become negative)) + ! + storage_volume(nm) = max(dv, 0.0) + ! + if (dv < 0.0) then + ! + ! Overshoot, so add remaining volume to z_volume + ! + dvol = - dv + ! + else + ! + ! Everything went into storage + ! + dvol = 0.0 + ! + endif + ! + endif + ! + endif ! - ! f = cos(y - 0.5*dy) / cos(y) (this holds both in northern and southern hemisphere) + ! Update volume ! - ! This assumes that we can use the same factor f for q(ndm) and q(num), i.e.: + z_volume(nm) = z_volume(nm) + dvol ! - ! cos(y - 0.5*dy) / cos(y) ~= cos(y + 0.5*dy) / cos(y) or: cos(y - 0.5*dy) ~= cos(y + 0.5*dy) which is pretty much true for dy < 1.0 degree + if (wiggle_suppression) then + ! + ! Store previous water level to determine gradient + ! + zs00 = zs0(nm) ! previous time step + zs11 = zs(nm) ! current time step before updating + zs0(nm) = zs11 ! next previous time step + ! + endif ! - else + ! Obtain new water level from subgrid tables ! - if (use_quadtree) then + if (z_volume(nm) >= subgrid_z_volmax(nm) * 0.999) then + ! + ! Entire cell is wet, no interpolation needed + ! + zs(nm) = max(subgrid_z_zmax(nm), -20.0) + (z_volume(nm) - subgrid_z_volmax(nm)) / a + ! + elseif (z_volume(nm) <= 1.0e-6) then + ! + ! No water in this cell. Set zs to z_zmin. + ! + zs(nm) = max(subgrid_z_zmin(nm), -20.0) ! - ! dxrm = size of cell in x - direction (it varies for all zoom levels) - ! dyrm = size of cell in y - direction (it varies for all zoom levels) - ! - dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) - q(num)) * dxrm(z_flags_iref(nm)) ) * dt - ! else - ! - dvol = dvol + ( (q(nmd) - q(nmu)) * dy + (q(ndm) - q(num)) * dx ) * dt - ! - endif - ! - endif - endif ! kcs==1 - ! - if (wavemaker .and. kcs(nm) == 4) then - ! - ! Wave maker point (seaward of wave maker) - ! Here we use the mean flux at the location of the wave maker - ! - iwm = z_index_wavemaker(nm) - ! - if (wavemaker_nmd(iwm) > 0) then - ! - ! Wave paddle on the left - ! - qnmd = wavemaker_uvmean(wavemaker_nmd(iwm)) + ! + ! Interpolation from subgrid tables needed. + ! + dzvol = subgrid_z_volmax(nm) / (subgrid_nlevels - 1) + iuv = int(z_volume(nm) / dzvol) + 1 + facint = (z_volume(nm) - (iuv - 1) * dzvol ) / dzvol + zs(nm) = subgrid_z_dep(iuv, nm) + (subgrid_z_dep(iuv + 1, nm) - subgrid_z_dep(iuv, nm)) * facint + ! + endif ! - else ! - qnmd = q(z_index_uv_md(nm)) + if (wiggle_suppression) then + ! + zsderv(nm) = zs(nm) - 2 * zs11 + zs00 + ! + endif ! - endif + endif ! - if (wavemaker_nmu(iwm) > 0) then + if (snapwave) then ! - ! Wave paddle on the right + ! Time-averaged water level used for SnapWave using exponential filter ! - qnmu = wavemaker_uvmean(wavemaker_nmu(iwm)) + ! Would double exponential filtering be better? ! - else + zsm(nm) = factime * zs(nm) + (1.0 - factime) * zsm(nm) ! - qnmu = q(z_index_uv_mu(nm)) + if (store_maximum_waterlevel) then + ! + maxzsm(nm) = max(maxzsm(nm), zsm(nm)) + ! + endif ! - endif + endif ! - if (wavemaker_ndm(iwm) > 0) then - ! - ! Wave paddle below - ! - qndm = wavemaker_uvmean(wavemaker_ndm(iwm)) - ! - else - ! - qndm = q(z_index_uv_nd(nm)) - ! - endif + ! No continuity update but keeping track of variables + ! zsmax used by default, therefore keep in standard continuity loop: ! - if (wavemaker_num(iwm) > 0) then + if (store_maximum_waterlevel) then ! - ! Wave paddle above + ! Store when the maximum water level changed ! - qnum = wavemaker_uvmean(wavemaker_num(iwm)) + if (store_t_zsmax) then + if (zs(nm) > zsmax(nm)) then + if ( (zs(nm) - subgrid_z_zmin(nm)) > huthresh) then + t_zsmax(nm) = t + endif + endif + endif ! - else + ! Store the maximum water level itself ! - qnum = q(z_index_uv_nu(nm)) + zsmax(nm) = max(zsmax(nm), zs(nm)) ! - endif + endif ! - if (use_quadtree) then - ! - dvol = dvol + ( (qnmd - qnmu) * dyrm(z_flags_iref(nm)) + (qndm - qnum) * dxrm(z_flags_iref(nm)) ) * dt - ! - else - ! - dvol = dvol + ( (qnmd - qnmu) * dy + (qndm - qnum) * dx ) * dt - ! - endif + ! Reset qsrc to zero for the next time step ! - endif + qsrc(nm) = 0.0 + ! + enddo + !$omp end do + !$omp end parallel ! - ! We got the volume change dvol in each active cell from fluxes - ! Now first add precip and qext - ! Then adjust for storage volume - ! Then update the volume and compute new water level + !$acc end parallel ! - if (kcs(nm) == 1 .or. kcs(nm) == 4) then + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine compute_store_variables(dt) + ! + ! Update the optional per-cell running diagnostics vmax, qmax and + ! twet from the edge-centred uv / q fields at the current step. + ! Cell-centred vmax / qmax are reconstructed as the 2D magnitude + ! of the mean of the four surrounding edge values. twet is the + ! cumulative time a cell has been wet above twet_threshold. Kept + ! in a separate routine to avoid the overhead when unused. + ! + ! Called from: update_continuity (only when any of + ! store_maximum_velocity, store_maximum_flux or store_twet is + ! enabled). + ! + use sfincs_data + ! + implicit none + ! + real*4 :: dt + ! + integer :: nm + ! + integer :: nmu + integer :: nmd + integer :: num + integer :: ndm + ! + real*4 :: quz + real*4 :: qvz + real*4 :: qz + real*4 :: uvz + ! + !$omp parallel & + !$omp private ( nmd, nmu, ndm, num, quz, qvz, qz, uvz ) + !$omp do schedule ( dynamic, 256 ) + !$acc parallel present( kcs, zs, zb, subgrid_z_zmin, q, uv, vmax, qmax, twet, & + !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu ) + !$acc loop gang vector + do nm = 1, np ! - ! Obtain cell area + ! And now water level changes due to horizontal fluxes ! - if (crsgeo) then + qz = 0.0 + uvz = 0.0 + ! + if (kcs(nm) == 1 .or. kcs(nm) == 4) then ! TL: kcs(nm)==4 also correct for regular? ! - a = cell_area_m2(nm) + ! Regular point with four surrounding cells of the same size ! - else + nmd = z_index_uv_md(nm) + nmu = z_index_uv_mu(nm) + ndm = z_index_uv_nd(nm) + num = z_index_uv_nu(nm) ! - a = cell_area(z_flags_iref(nm)) + if (store_maximum_velocity) then + quz = (uv(nmd) + uv(nmu)) / 2 + qvz = (uv(ndm) + uv(num)) / 2 + uvz = sqrt(quz**2 + qvz**2) + endif ! - endif - ! - if (precip .or. use_qext) then + if (store_maximum_flux) then + quz = (q(nmd) + q(nmu)) / 2 + qvz = (q(ndm) + q(num)) / 2 + qz = sqrt(quz**2 + qvz**2) + endif ! - dzsdt = 0.0 - ! - if (precip) then + ! No continuity update but keeping track of variables + ! 1. store vmax + if (store_maximum_velocity) then ! - ! Add nett rainfall - ! - dzsdt = dzsdt + netprcp(nm) + vmax(nm) = max(vmax(nm), uvz) ! endif ! - if (use_qext) then + ! 2. store qmax + if (store_maximum_flux) then ! - ! Add external source (e.g. from XMI coupling) - ! - dzsdt = dzsdt + qext(nm) + qmax(nm) = max(qmax(nm), qz) ! endif ! - ! dzsdt is still in m/s, so multiply with a * dt to get m^3 - ! - dvol = dvol + dzsdt * a * dt - ! - endif - ! - if (use_storage_volume) then - ! - ! If water enters the cell through a point discharge, it will NOT end up in storage volume ! - ! - if (storage_volume(nm) > 1.0e-6 .and. dvol > 0.0) then - ! - ! There is still some storage left, and water is entering the cell - ! - ! Compute remaining storage volume - ! - dv = storage_volume(nm) - dvol - ! - ! Update storage volume (it cannot become negative)) - ! - storage_volume(nm) = max(dv, 0.0) - ! - if (dv < 0.0) then - ! - ! Overshoot, so add remaining volume to z_volume - ! - dvol = - dv - ! - else - ! - ! Everything went into storage - ! - dvol = 0.0 - ! + ! 3. store Twet + if (store_twet) then + if (subgrid) then + ! + if ( (zs(nm) - subgrid_z_zmin(nm)) > twet_threshold) then + twet(nm) = twet(nm) + dt + endif + ! + else + ! + if ( (zs(nm) - zb(nm)) > twet_threshold) then + ! + twet(nm) = twet(nm) + dt + ! + endif + ! endif - ! endif ! endif - ! - ! Update volume - ! - z_volume(nm) = z_volume(nm) + dvol - ! - if (wiggle_suppression) then - ! - ! Store previous water level to determine gradient - ! - zs00 = zs0(nm) ! previous time step - zs11 = zs(nm) ! current time step before updating - zs0(nm) = zs11 ! next previous time step - ! - endif - ! - ! Obtain new water level from subgrid tables - ! - if (z_volume(nm) >= subgrid_z_volmax(nm) * 0.999) then - ! - ! Entire cell is wet, no interpolation needed - ! - zs(nm) = max(subgrid_z_zmax(nm), -20.0) + (z_volume(nm) - subgrid_z_volmax(nm)) / a - ! - elseif (z_volume(nm) <= 1.0e-6) then - ! - ! No water in this cell. Set zs to z_zmin. - ! - zs(nm) = max(subgrid_z_zmin(nm), -20.0) - ! - else - ! - ! Interpolation from subgrid tables needed. - ! - dzvol = subgrid_z_volmax(nm) / (subgrid_nlevels - 1) - iuv = int(z_volume(nm) / dzvol) + 1 - facint = (z_volume(nm) - (iuv - 1) * dzvol ) / dzvol - zs(nm) = subgrid_z_dep(iuv, nm) + (subgrid_z_dep(iuv + 1, nm) - subgrid_z_dep(iuv, nm)) * facint - ! - endif - ! - ! - if (wiggle_suppression) then - ! - zsderv(nm) = zs(nm) - 2 * zs11 + zs00 - ! - endif - ! - endif - ! - if (snapwave) then - ! - ! Time-averaged water level used for SnapWave using exponential filter - ! - ! Would double exponential filtering be better? - ! - zsm(nm) = factime * zs(nm) + (1.0 - factime) * zsm(nm) - ! - if (store_maximum_waterlevel) then - ! - maxzsm(nm) = max(maxzsm(nm), zsm(nm)) - ! - endif - ! - endif - ! - ! No continuity update but keeping track of variables - ! zsmax used by default, therefore keep in standard continuity loop: - ! - if (store_maximum_waterlevel) then - ! - ! Store when the maximum water level changed - ! - if (store_t_zsmax) then - if (zs(nm) > zsmax(nm)) then - if ( (zs(nm) - subgrid_z_zmin(nm)) > huthresh) then - t_zsmax(nm) = t - endif - endif - endif - ! - ! Store the maximum water level itself - ! - zsmax(nm) = max(zsmax(nm), zs(nm)) - ! - endif + enddo + !$omp end do + !$omp end parallel + !$acc end parallel ! - enddo - !$omp end do - !$omp end parallel - ! - !$acc end parallel - ! end subroutine - - subroutine compute_store_variables(dt) ! - use sfincs_data - ! - implicit none - ! - real*4 :: dt - ! - integer :: nm - ! - integer :: nmu - integer :: nmd - integer :: num - integer :: ndm - ! - real*4 :: quz - real*4 :: qvz - real*4 :: qz - real*4 :: uvz - ! - !$omp parallel & - !$omp private ( nmd, nmu, ndm, num, quz, qvz, qz, uvz ) - !$omp do schedule ( dynamic, 256 ) - !$acc parallel present( kcs, zs, zb, subgrid_z_zmin, q, uv, vmax, qmax, twet, & - !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu ) - !$acc loop gang vector - do nm = 1, np - ! - ! And now water level changes due to horizontal fluxes - ! - qz = 0.0 - uvz = 0.0 - ! - if (kcs(nm) == 1 .or. kcs(nm) == 4) then ! TL: kcs(nm)==4 also correct for regular? - ! - ! Regular point with four surrounding cells of the same size - ! - nmd = z_index_uv_md(nm) - nmu = z_index_uv_mu(nm) - ndm = z_index_uv_nd(nm) - num = z_index_uv_nu(nm) - ! - if (store_maximum_velocity) then - quz = (uv(nmd) + uv(nmu)) / 2 - qvz = (uv(ndm) + uv(num)) / 2 - uvz = sqrt(quz**2 + qvz**2) - endif - ! - if (store_maximum_flux) then - quz = (q(nmd) + q(nmu)) / 2 - qvz = (q(ndm) + q(num)) / 2 - qz = sqrt(quz**2 + qvz**2) - endif - ! - ! No continuity update but keeping track of variables - ! 1. store vmax - if (store_maximum_velocity) then - ! - vmax(nm) = max(vmax(nm), uvz) - ! - endif - ! - ! 2. store qmax - if (store_maximum_flux) then - ! - qmax(nm) = max(qmax(nm), qz) - ! - endif - ! - ! 3. store Twet - if (store_twet) then - if (subgrid) then - ! - if ( (zs(nm) - subgrid_z_zmin(nm)) > twet_threshold) then - twet(nm) = twet(nm) + dt - endif - ! - else - ! - if ( (zs(nm) - zb(nm)) > twet_threshold) then - ! - twet(nm) = twet(nm) + dt - ! - endif - ! - endif - endif - ! - endif - enddo - !$omp end do - !$omp end parallel - !$acc end parallel - ! - end subroutine - end module diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index c5ada99dd..2099a7f3d 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -4,7 +4,6 @@ module sfincs_data character*256 :: build_revision, build_date !!!! !!! Time variables - real :: tstart_all, tfinish_all real*4 :: dtavg real*4 :: min_dt !!! @@ -16,6 +15,7 @@ module sfincs_data !!! logical :: bmi logical :: use_qext + logical :: use_dzbext !!! !!! Constants !!! @@ -34,8 +34,6 @@ module sfincs_data real*4 gn2 real*4 t0 real*4 t1 - real*4 t3 - real*4 t4 real*4 dx real*4 dy real*4 dxinv @@ -125,9 +123,7 @@ module sfincs_data character*256 :: obsfile character*256 :: crsfile character*256 :: rugfile - character*256 :: srcfile - character*256 :: disfile - character*256 :: drnfile + character*256 :: urbfile character*256 :: zsinifile character*256 :: rstfile character*256 :: indexfile @@ -147,7 +143,6 @@ module sfincs_data character*256 :: weirfile character*256 :: qinffile character*256 :: netbndbzsbzifile - character*256 :: netsrcdisfile character*256 :: netamuamvfile character*256 :: netampfile character*256 :: netamprfile @@ -208,6 +203,7 @@ module sfincs_data logical :: store_hsubgrid logical :: store_hmean logical :: store_qdrain + logical :: store_river_discharge logical :: store_zvolume logical :: store_storagevolume logical :: store_meteo @@ -222,6 +218,12 @@ module sfincs_data logical :: write_time_output logical :: bziwaves logical :: infiltration + logical :: discharges + logical :: drainage_structures + logical :: dike_breaching + logical :: urban_drainage + logical :: store_urban_drainage_discharge + logical :: store_cumulative_urban_drainage LOGICAL :: netcdf_infiltration logical :: debug logical :: radstr @@ -261,20 +263,6 @@ module sfincs_data logical :: bathtub logical :: bathtub_snapwave !!! - !!! sfincs_input.f90 switches - integer storevelmax - integer storefluxmax - integer storevel - integer storecumprcp - integer storetwet - integer storetzsmax - integer storeqdrain - integer storezvolume - integer storestoragevolume - integer storemeteo - integer storehsubgrid - integer wrttimeoutput - !!! !!! Static data !!! integer*4 :: np @@ -404,6 +392,16 @@ module sfincs_data ! real*4, dimension(:), allocatable :: storage_volume ! Storage volume green infra ! + ! Bucket model - finite capacity reservoir with linear drainage + ! + logical :: use_bucket_model = .false. + real*4, dimension(:), allocatable :: bucket_volume ! current storage (m) + real*4, dimension(:), allocatable :: bucket_capacity ! max capacity S_max (m) + real*4, dimension(:), allocatable :: bucket_k ! drainage coefficient (1/s) + real*4, dimension(:), allocatable :: bucket_drain_rate ! net removal from surface this step (m/s) + real*4, dimension(:), allocatable :: bucket_loss ! loss fraction per cell (0-1), ET/deep percolation + real*4, dimension(:), allocatable :: bucket_runoff ! bucket drainage returned as surface runoff (m/s) + ! ! Wind reduction for spiderweb winds ! real*4, dimension(:,:), allocatable :: z0land ! z0 values over land for spiderweb wind speed reduction @@ -597,6 +595,7 @@ module sfincs_data real*4, dimension(:), allocatable :: zs0 real*4, dimension(:), allocatable :: zsderv real*4, dimension(:), allocatable, target :: qext + real*4, dimension(:), allocatable, target :: dzbext real*4, dimension(:), allocatable, target :: uorb real*4, dimension(:), allocatable :: gnapp2 ! @@ -791,22 +790,26 @@ module sfincs_data !!! !!! Discharges and drainage !!! - integer :: nsrc - integer :: ndrn - integer :: nsrcdrn + ! Cell-wise accumulated discharge used by continuity. Size np. Zeroed + ! each step, then both sfincs_discharges and sfincs_src_structures + ! accumulate into it. + ! + real*4, dimension(:), allocatable :: qsrc ! (np) cell-wise discharge [m3/s] + ! + ! River point discharges (sfincs_discharges) + ! + ! Identifiers that are read by sfincs_input / sfincs_ncinput stay here; + ! the pure discharge-module-only state (itsrclast, nmindsrc, qtsrc, + ! src_name, src_name_len) has been moved into sfincs_discharges. + ! integer :: ntsrc - integer :: itsrclast - real*4, dimension(:), allocatable :: tsrc - real*4, dimension(:,:), allocatable :: qsrc - real*4, dimension(:), allocatable :: qtsrc - integer*4, dimension(:), allocatable :: nmindsrc - integer*1, dimension(:), allocatable :: drainage_type - real*4, dimension(:,:), allocatable :: drainage_params - real*4, dimension(:), allocatable :: drainage_distance - integer*1, dimension(:), allocatable :: drainage_status - real*4, dimension(:), allocatable :: drainage_fraction_open + real*4, dimension(:), allocatable :: tsrc ! (ntsrc) time stamps of river discharge time series + real*4, dimension(:,:), allocatable :: qsrc_ts ! (nr_discharge_points, ntsrc) river discharge time series matrix real*4, dimension(:), allocatable :: xsrc real*4, dimension(:), allocatable :: ysrc + ! + ! Src-point structures (pumps, culverts, check valves, controlled gates) + ! live in module sfincs_src_structures. !!! !!! Structures !!! @@ -974,7 +977,13 @@ subroutine finalize_parameters() if(allocated(qinffield)) deallocate(qinffield) if(allocated(ksfield)) deallocate(ksfield) if(allocated(scs_Se)) deallocate(scs_Se) - if(allocated(nuvisc)) deallocate(nuvisc) + if(allocated(bucket_volume)) deallocate(bucket_volume) + if(allocated(bucket_capacity)) deallocate(bucket_capacity) + if(allocated(bucket_k)) deallocate(bucket_k) + if(allocated(bucket_drain_rate)) deallocate(bucket_drain_rate) + if(allocated(bucket_loss)) deallocate(bucket_loss) + if(allocated(bucket_runoff)) deallocate(bucket_runoff) + if(allocated(nuvisc)) deallocate(nuvisc) ! ! Boundary velocity points ! @@ -1032,6 +1041,7 @@ subroutine finalize_parameters() if(allocated(uv0)) deallocate(uv0) if(allocated(twet)) deallocate(twet) if(allocated(qext)) deallocate(qext) + if(allocated(dzbext)) deallocate(dzbext) ! ! if(allocated(huu)) deallocate(huu) ! if(allocated(hvv)) deallocate(hvv) @@ -1130,10 +1140,15 @@ subroutine finalize_parameters() !!! !!! Discharges !!! - if(allocated(tsrc)) deallocate(tsrc) if(allocated(qsrc)) deallocate(qsrc) - if(allocated(qtsrc)) deallocate(qtsrc) - if(allocated(nmindsrc)) deallocate(nmindsrc) + if(allocated(tsrc)) deallocate(tsrc) + if(allocated(qsrc_ts)) deallocate(qsrc_ts) + ! + ! River-point-discharge module-private state (qtsrc, nmindsrc, src_name) + ! is owned by sfincs_discharges and is deallocated there. + ! + ! Src-point structure state is owned by sfincs_src_structures and is + ! deallocated there. !!! !!! Structures !!! diff --git a/source/src/sfincs_date.f90 b/source/src/sfincs_date.f90 index ec732196d..6988958d1 100644 --- a/source/src/sfincs_date.f90 +++ b/source/src/sfincs_date.f90 @@ -365,7 +365,7 @@ function time_to_vector(t_sec, tref_string) result (date_time_vector) ! subroutine timer(t) real*4,intent(out) :: t - integer*4 :: count,count_rate,count_max + integer*8 :: count,count_rate,count_max call system_clock (count,count_rate,count_max) t = dble(count)/count_rate end subroutine timer diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index 2d3a7262f..7efce042a 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -1,301 +1,269 @@ module sfincs_discharges - - use sfincs_log - use sfincs_error ! -contains + ! River point discharges: nr_discharge_points (x,y) locations from srcfile with matching + ! time series qsrc_ts(:,:) from disfile, OR from a FEWS-style netCDF input + ! via netsrcdisfile. Interpolates to the current model time every step, + ! stores the interpolated value in qtsrc(nr_discharge_points) (for his output), and + ! accumulates the per-cell discharge into the global qsrc(np) array used + ! by sfincs_continuity. + ! + ! Drainage structures (pumps, check valves, culverts, controlled gates) + ! live in sfincs_src_structures. The two modules no longer share any + ! arrays -- they cooperate only by both writing into qsrc(np). + ! + ! Subroutines: + ! + ! initialize_discharges() + ! Read srcfile/disfile (ascii) or netsrcdisfile (netcdf), resolve + ! each source to its quadtree cell, and allocate runtime state. + ! Called from sfincs_lib at init time. ! - subroutine read_discharges() + ! update_discharges(t, dt) + ! Zero qsrc(np), interpolate the river discharge time series to the + ! current time, and accumulate into qsrc at each source cell. + ! Called from update_continuity (sfincs_continuity) once per + ! time step, before update_src_structures. ! - ! Reads discharge files + ! count_tokens(line, ntok) + ! Count whitespace-separated tokens in a string; used to decide + ! between the 2-column (x y) and 3-column (x y name) src formats. + ! Called from initialize_discharges (this module). ! - use sfincs_data - use sfincs_ncinput - use quadtree + use sfincs_log + use sfincs_error ! implicit none ! - real*4, dimension(:), allocatable :: xsnk - real*4, dimension(:), allocatable :: ysnk + ! Module-level runtime state for river point discharges (moved from + ! sfincs_data). The count, coordinate arrays, file-path strings, and + ! qsrc_ts / tsrc / ntsrc stay in sfincs_data because they are also + ! set by sfincs_input (keyword reader) or sfincs_ncinput (which this + ! module uses, so a back-reference would be circular). ! - real*4 dummy, xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp + ! Public so downstream output modules (sfincs_output, sfincs_ncoutput) + ! and the openacc bookkeeping module can reference them. ! - integer isrc, itsrc, idrn, nm, m, n, stat, j, iref, nmq, npars + ! Input file paths (sfincs.inp keywords 'srcfile' / 'disfile' / + ! 'netsrcdisfile'); 'none' when the corresponding input is not supplied. ! - logical :: ok + character(len=256), public :: srcfile + character(len=256), public :: disfile + character(len=256), public :: netsrcdisfile ! - character(len=256) :: drainage_line, message + ! Number of river discharge points resolved from the input files. ! - ! Read discharge points + integer, public :: nr_discharge_points ! - nsrc = 0 - ndrn = 0 - ntsrc = 0 - itsrclast = 1 + ! Name length (matches src_struc_name_len from sfincs_src_structures). ! - if (srcfile(1:4) /= 'none') then - ! - ok = check_file_exists(srcfile, 'Source points file', .true.) - ! - write(logstr,'(a)')'Info : reading discharges' - call write_log(logstr, 0) - ! - ok = check_file_exists(srcfile, 'River input locations src file', .true.) - ! - open(500, file=trim(srcfile)) - do while(.true.) - read(500,*,iostat = stat)dummy - if (stat < 0) exit - nsrc = nsrc + 1 - ! - enddo - ! - rewind(500) - ! - elseif (netsrcdisfile(1:4) /= 'none') then ! FEWS compatible Netcdf discharge time-series input - ! - ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) - ! - call read_netcdf_discharge_data() ! reads nsrc, ntsrc, xsrc, ysrc, qsrc, and tsrc - ! - if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then - ! - write(logstr,'(a)')' WARNING! Times in discharge file do not cover entire simulation period!' - call write_log(logstr, 1) - ! - endif - ! - endif + integer, parameter, public :: src_name_len = 128 ! - if (drnfile(1:4) /= 'none') then - ! - write(logstr,'(a)')'Info : reading drainage file' - call write_log(logstr, 0) - ! - ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) - ! - open(501, file=trim(drnfile)) - do while(.true.) - read(501,*,iostat = stat)dummy - if (stat < 0) exit - ndrn = ndrn + 1 - enddo - rewind(501) - endif + ! Per-river-source names ! - nsrcdrn = nsrc + 2 * ndrn + character(len=src_name_len), dimension(:), allocatable, public :: src_name ! (nr_discharge_points) user-supplied or auto-generated names for river point sources ! - if (nsrcdrn > 0) then - allocate(nmindsrc(nsrcdrn)) - allocate(qtsrc(nsrcdrn)) - nmindsrc = 0 - qtsrc = 0.0 - endif + ! Runtime state ! - if (srcfile(1:4) /= 'none') then - ! - ! Actually read src and dis files + integer, public :: itsrclast ! last-used bracket index into tsrc, for time-series interpolation + real*4, dimension(:), allocatable, public :: qtsrc ! (nr_discharge_points) interpolated discharge at current time, for his output + integer*4, dimension(:), allocatable, public :: nmindsrc ! (nr_discharge_points) river source cell indices + ! +contains + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine initialize_discharges() ! - allocate(xsrc(nsrc)) - allocate(ysrc(nsrc)) + ! Read the river-point-discharge input and wire each source up to a grid + ! cell. Two mutually-exclusive input paths: + ! - srcfile (+ disfile): ascii, 2-column (x y) or 3-column (x y name) + ! location file plus a separate time-series file. + ! - netsrcdisfile: FEWS-style netcdf with locations and time series + ! in one file (no per-point names; auto-generated). + ! Allocates nmindsrc(nr_discharge_points) and qtsrc(nr_discharge_points), + ! and populates shared tsrc/qsrc_ts arrays in sfincs_data. ! - do n = 1, nsrc - read(500,*)xsrc(n), ysrc(n) - enddo + ! Called from: sfincs_lib (once, at init time). ! - close(500) + use sfincs_data + use sfincs_ncinput + use quadtree ! - ! Read discharge time series + implicit none ! - ok = check_file_exists(disfile, 'River discharge timeseries dis file', .true.) - ! - open(502, file=trim(disfile)) - do while(.true.) - read(502,*,iostat = stat)dummy - if (stat < 0) exit - ntsrc = ntsrc + 1 - ! - enddo + real*4 :: dummy + integer :: isrc, itsrc, nmq, n, stat, ntok + logical :: ok + character(len=1024) :: line, line_trim + character(len=src_name_len) :: name_tmp ! - rewind(502) - allocate(tsrc(ntsrc)) - allocate(qsrc(nsrc,ntsrc)) - do itsrc = 1, ntsrc - read(502,*)tsrc(itsrc), (qsrc(isrc, itsrc), isrc = 1, nsrc) - enddo - close(502) + discharges = .false. + nr_discharge_points = 0 + ntsrc = 0 + itsrclast = 1 ! - endif - ! - if (nsrc > 0) then - ! - ! Check times at once for either srcfile or netsrcdisfile - ! - if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then - ! - write(logstr,'(a)')'Warning! Times in discharge file do not cover entire simulation period !' - call write_log(logstr, 1) + if (srcfile(1:4) /= 'none') then ! - if (tsrc(1) > (t0 + 1.0)) then - ! - write(logstr,'(a)')'Warning! Adjusting first time in discharge time series !' - call write_log(logstr, 1) - ! - tsrc(1) = t0 - 1.0 - ! - else - ! - write(logstr,'(a)')'Warning! Adjusting last time in discharge time series !' - call write_log(logstr, 1) - ! - tsrc(ntsrc) = t1 + 1.0 - ! - endif - ! - endif - ! - ! Determine m and n indices of sources - ! - do isrc = 1, nsrc + write(logstr,'(a)') 'Info : reading discharges' + call write_log(logstr, 0) ! - ! Find cell in quadtree first + ok = check_file_exists(srcfile, 'River input locations src file', .true.) ! - nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) + open(500, file=trim(srcfile)) ! - if (nmq > 0) then + do while (.true.) ! - nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) + read(500, *, iostat=stat) dummy + if (stat < 0) exit + nr_discharge_points = nr_discharge_points + 1 ! - endif - ! - enddo - ! - ! Don't need coordinates anymore, and xsrc and ysrc may be used for drainage points as well - ! - deallocate(xsrc) - deallocate(ysrc) - ! - endif - ! - ! And now the drainage points - ! - if (ndrn>0) then - ! - write(logstr,'(a,a,a,i0,a)')' Reading ',trim(drnfile),' (', ndrn, ' drainage points found) ...' - call write_log(logstr, 0) - ! - allocate(xsrc(ndrn)) - allocate(ysrc(ndrn)) - allocate(xsnk(ndrn)) - allocate(ysnk(ndrn)) - ! - allocate(drainage_type(ndrn)) - allocate(drainage_params(ndrn, 6)) - allocate(drainage_status(ndrn)) - allocate(drainage_distance(ndrn)) - allocate(drainage_fraction_open(ndrn)) - ! - drainage_params = 0.0 - drainage_distance = 0.0 - drainage_fraction_open = 1.0 ! initially fully open (should fix this based on zmin and zmax in params) - drainage_status = 1 ! open (0=closed, 1=open, 2=closing, 3=opening) - ! - do idrn = 1, ndrn + enddo ! - read(501, '(a)') drainage_line + rewind(500) ! - ! First find out what type of drainage structure it is (integer 5th item in line) + elseif (netsrcdisfile(1:4) /= 'none') then ! FEWS-compatible NetCDF discharge time series ! - read(drainage_line,*,iostat=stat)xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp, drainage_type(idrn) + ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) ! - npars = 0 ! Default (if npars stays 0, throw error) + call read_netcdf_discharge_data(netsrcdisfile, nr_discharge_points) ! also sets ntsrc, xsrc, ysrc, qsrc_ts, tsrc (in sfincs_data) ! - if (drainage_type(idrn) == 1 .or. drainage_type(idrn) == 2 .or. drainage_type(idrn) == 3) then - ! - ! Pump, culvert or check valve (1 parameter) - ! - npars = 1 + ! The netcdf discharge file does not carry per-point names; auto-generate + ! the same way as the 2-column srcfile path. + ! + if (nr_discharge_points > 0) then ! - elseif (drainage_type(idrn) == 4 .or. drainage_type(idrn) == 5) then + allocate(src_name(nr_discharge_points)) ! - ! Controlled gate (6 parameters : width, sill elevation, manning, zmin, zmax, closing time) + src_name = ' ' ! - npars = 6 + do n = 1, nr_discharge_points + ! + write(src_name(n), '(a,i4.4)') 'discharge_', n + ! + enddo ! endif ! - if (npars == 0) then + if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then ! - write(logstr,'(a,i0,a)')'Drainage type ', drainage_type(idrn), ' not recognized !' - call stop_sfincs(logstr, -1) + write(logstr,'(a)') ' WARNING! Times in discharge file do not cover entire simulation period!' + call write_log(logstr, 1) ! - endif + endif ! - if (npars == 1) then - ! - ! Pump, culvert or check valve - ! - read(drainage_line,*,iostat=stat)xsnk(idrn), ysnk(idrn), xsrc(idrn), ysrc(idrn), drainage_type(idrn), drainage_params(idrn,1) - ! - elseif (npars == 6) then + endif + ! + if (nr_discharge_points <= 0) return + ! + discharges = .true. + ! + allocate(nmindsrc(nr_discharge_points)) + allocate(qtsrc(nr_discharge_points)) + ! + nmindsrc = 0 + qtsrc = 0.0 + ! + ! Read src/dis contents for the srcfile case + ! + if (srcfile(1:4) /= 'none') then + ! + allocate(xsrc(nr_discharge_points)) + allocate(ysrc(nr_discharge_points)) + allocate(src_name(nr_discharge_points)) + ! + src_name = ' ' + ! + do n = 1, nr_discharge_points ! - ! Controlled gate, needs 6 parameters + read(500, '(a)') line + line_trim = adjustl(line) ! - read(drainage_line,*,iostat=stat)xsnk(idrn), ysnk(idrn), xsrc(idrn), ysrc(idrn), drainage_type(idrn), drainage_params(idrn,1), drainage_params(idrn,2), drainage_params(idrn,3), drainage_params(idrn,4), drainage_params(idrn,5), drainage_params(idrn,6) + ! Count whitespace-separated tokens on the line. ! - endif - ! - if (stat /= 0) then + call count_tokens(line_trim, ntok) ! - write(logstr,'(a,i0,a,i0,a)')'Drainage type ', drainage_type(idrn), ' requires ', npars, ' parameters !' - call stop_sfincs(logstr, -1) + if (ntok == 2) then + ! + read(line_trim, *) xsrc(n), ysrc(n) + write(src_name(n), '(a,i4.4)') 'discharge_', n + ! + elseif (ntok == 3) then + ! + read(line_trim, *) xsrc(n), ysrc(n), name_tmp + src_name(n) = adjustl(trim(name_tmp)) + ! + else + ! + write(logstr,'(a,i0,a,i0,a)') ' Error ! src file line ', n, ' has ', ntok, & + ' tokens -- expected 2 (x y) or 3 (x y name) !' + call write_log(logstr, 1) + error = 1 + return + ! + endif ! - endif + enddo ! - enddo - ! - close(501) - ! - ! Determine nm indices of source and sinks - ! - do idrn = 1, ndrn + close(500) ! - ! Determine index of sink first + ! Read discharge time series ! - j = nsrc + idrn*2 - 1 + ok = check_file_exists(disfile, 'River discharge timeseries dis file', .true.) ! - nmq = find_quadtree_cell(xsnk(idrn), ysnk(idrn)) + open(502, file=trim(disfile)) ! - if (nmq > 0) then + do while (.true.) ! - nmindsrc(j) = index_sfincs_in_quadtree(nmq) + read(502, *, iostat=stat) dummy + if (stat < 0) exit + ntsrc = ntsrc + 1 ! - endif + enddo ! - ! And now the index of the source + rewind(502) + allocate(tsrc(ntsrc)) + allocate(qsrc_ts(nr_discharge_points, ntsrc)) ! - j = nsrc + idrn * 2 + do itsrc = 1, ntsrc + ! + read(502, *) tsrc(itsrc), (qsrc_ts(isrc, itsrc), isrc = 1, nr_discharge_points) + ! + enddo ! - nmq = find_quadtree_cell(xsrc(idrn), ysrc(idrn)) + close(502) ! - if (nmq > 0) then + if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then + ! + write(logstr,'(a)') 'Warning! Times in discharge file do not cover entire simulation period !' + call write_log(logstr, 1) ! - nmindsrc(j) = index_sfincs_in_quadtree(nmq) + if (tsrc(1) > (t0 + 1.0)) then + ! + write(logstr,'(a)') 'Warning! Adjusting first time in discharge time series !' + call write_log(logstr, 1) + tsrc(1) = t0 - 1.0 + ! + else + ! + write(logstr,'(a)') 'Warning! Adjusting last time in discharge time series !' + call write_log(logstr, 1) + tsrc(ntsrc) = t1 + 1.0 + ! + endif ! endif ! - ! Get coords of source and sink points, and compute distance between them. - ! Only do this when both points were found inside the active grid (nmindsrc > 0); - ! if either point is outside, skip to avoid an index-0 array access. + endif + ! + ! Map river sources to grid cells + ! + do isrc = 1, nr_discharge_points ! - if (nmindsrc(nsrc + idrn * 2 - 1) > 0 .and. nmindsrc(nsrc + idrn * 2) > 0) then - ! - xsnk_tmp = z_xz(nmindsrc(nsrc + idrn * 2 - 1)) - ysnk_tmp = z_yz(nmindsrc(nsrc + idrn * 2 - 1)) - xsrc_tmp = z_xz(nmindsrc(nsrc + idrn * 2)) - ysrc_tmp = z_yz(nmindsrc(nsrc + idrn * 2)) + nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) + ! + if (nmq > 0) then ! - drainage_distance(idrn) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) ! endif ! @@ -303,360 +271,142 @@ subroutine read_discharges() ! deallocate(xsrc) deallocate(ysrc) - deallocate(xsnk) - deallocate(ysnk) - ! - ! Check if all sink/source points have found an index - if (any(nmindsrc == 0)) then - ! - write(logstr,'(a)')'Warning ! For some sink/source drainage points no matching active grid cell was found!' - call write_log(logstr, 0) - write(logstr,'(a)')'Warning ! These points will be skipped, please check your input!' - call write_log(logstr, 0) - ! - endif ! - endif - ! end subroutine ! + !-----------------------------------------------------------------------------------------------------! ! - ! - subroutine update_discharges(t, dt, tloop) - ! - ! Update discharges - ! - use sfincs_data - ! - implicit none - ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! - real*8 :: t - real*4 :: dt - real*4 :: qq - real*4 :: qq0 - ! - real*4 :: dzds, frac, wdt, zsill, zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose - integer :: idir - ! - integer isrc, itsrc, idrn, jin, jout, nmin, nmout - ! - call system_clock(count0, count_rate, count_max) - ! - ! Compute instantaneous discharges from point sources - ! - if (nsrc > 0) then + subroutine update_discharges(t, dt) + ! + ! Zero qsrc(np); interpolate the river discharge time series to t, + ! store in qtsrc(1..nr_discharge_points), and accumulate into qsrc(nmindsrc(:)). + ! + ! update_discharges is called BEFORE update_src_structures -- that is + ! why it owns the qsrc zeroing. Both routines then additively write + ! their contributions. + ! + ! Called from: update_continuity (sfincs_continuity), once per time step. + ! + use sfincs_data + use sfincs_timers + ! + implicit none + ! + real*8 :: t + real*4 :: dt + ! + integer :: isrc, itsrc, nm, it_prev, it_next + real*4 :: wt + ! + ! qsrc is not zeroed here. The water-level update at the end of the + ! previous step clears qsrc(nm) for every active cell, and + ! update_meteo_forcing has by now accumulated prcp*area into it for + ! the current step. update_discharges and the remaining continuity + ! steps just keep adding on top. + ! + if (nr_discharge_points <= 0) return + ! + call timer_start('discharges') + ! + ! Locate the bracketing interval in tsrc and compute the interpolation + ! weight once. Then run a single parallel loop that both interpolates + ! qtsrc and accumulates it into qsrc. + ! + it_prev = itsrclast + it_next = itsrclast + 1 + ! do itsrc = itsrclast, ntsrc - ! Find first point in time series large than t + ! if (tsrc(itsrc) > t) then - do isrc = 1, nsrc - qtsrc(isrc) = qsrc(isrc, itsrc - 1) + (qsrc(isrc, itsrc) - qsrc(isrc, itsrc - 1)) * (t - tsrc(itsrc - 1)) / (tsrc(itsrc) - tsrc(itsrc - 1)) - enddo - itsrclast = itsrc - 1 + ! + it_prev = itsrc - 1 + it_next = itsrc + itsrclast = it_prev exit ! endif ! enddo ! - !$acc update device(qtsrc) + ! Clamp to valid bracket. If t is outside [tsrc(1), tsrc(ntsrc)] (which + ! can happen on the netcdf path, where the srcfile pre-padding is not + ! applied), hold the endpoint value rather than read out of bounds. ! - endif - ! - if (ndrn > 0) then + it_prev = min(max(it_prev, 1), ntsrc - 1) + it_next = it_prev + 1 + ! + wt = (t - tsrc(it_prev)) / (tsrc(it_next) - tsrc(it_prev)) ! - !$acc serial, present( z_volume, zs, zb, nmindsrc, qtsrc, drainage_type, drainage_params ) - do idrn = 1, ndrn + ! Atomic accumulation because two river sources (or a river and a + ! structure) can share a cell. + ! + !$acc parallel loop present( qsrc, qtsrc, nmindsrc, qsrc_ts ) private( nm ) + !$omp parallel do private( nm ) schedule ( static ) + do isrc = 1, nr_discharge_points + ! + qtsrc(isrc) = qsrc_ts(isrc, it_prev) + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt + nm = nmindsrc(isrc) + ! + if (nm > 0) then + ! + !$acc atomic update + !$omp atomic + qsrc(nm) = qsrc(nm) + qtsrc(isrc) + ! + endif ! - jin = nsrc + idrn * 2 - 1 - jout = nsrc + idrn * 2 + enddo + !$omp end parallel do + !$acc end parallel loop + ! + call timer_stop('discharges') + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine count_tokens(line, ntok) + ! + ! Count the number of whitespace-separated tokens in a string. + ! Whitespace = spaces and tabs. Empty string returns 0. + ! + ! Called from: initialize_discharges (this module) to disambiguate the + ! 2-column vs 3-column srcfile layout. + ! + implicit none + ! + character(len=*), intent(in) :: line + integer, intent(out) :: ntok + ! + integer :: i, n + logical :: in_tok + character(len=1) :: c + ! + ntok = 0 + in_tok = .false. + n = len_trim(line) + ! + do i = 1, n ! - nmin = nmindsrc(jin) - nmout = nmindsrc(jout) + c = line(i:i) ! - if (nmin > 0 .and. nmout > 0) then + if (c == ' ' .or. c == char(9)) then ! - select case(drainage_type(idrn)) - ! - case(1) - ! - ! Pump - ! - qq = drainage_params(idrn, 1) - ! - case(2) - ! - ! Culvert - ! - if (zs(nmin)>zs(nmout)) then - ! - qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) - ! - else - ! - qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) - ! - endif - ! - case(3) - ! - ! Check valve (same as culvert, but only works in one direction) - ! - if (zs(nmin) > zs(nmout)) then - ! - qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) - ! - else - ! - qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) - ! - endif - ! - ! Make sure it can only flow from intake to outfall point - ! - qq = max(qq, 0.0) - ! - case(4) - ! - ! Controlled gate. Gate opens when water level at intake point is between zmin and zmax. - ! - wdt = drainage_params(idrn, 1) ! width - zsill = drainage_params(idrn, 2) ! sill elevation - mng = drainage_params(idrn, 3) ! Manning's n - zmin = drainage_params(idrn, 4) ! min water level for open - zmax = drainage_params(idrn, 5) ! max water level for open - tcls = drainage_params(idrn, 6) ! closing time (seconds) - ! - dzds = (zs(nmout) - zs(nmin)) / drainage_distance(idrn) ! water level slope - frac = drainage_fraction_open(idrn) ! fraction open (from previous time step) - hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) ! water depth - dfrac = dt / tcls ! change in fraction open per time step - ! - qq0 = -qtsrc(jin) / (wdt * max(frac, 0.001)) ! discharge (in m2/s) from previous time step, excluding fraction open - ! - ! Get status of gate - ! - if (drainage_status(idrn) == 0) then - ! - ! Gate fully closed - ! - if (zs(nmin) > zmin .and. zs(nmin) < zmax) then - ! - ! Water level is in allowable range, so need to open the gate - ! - drainage_status(idrn) = 3 - ! - ! Lines below only work with Windows intel compiler, can be used for debugging - ! - ! Actual discharges through drainage structure can always be checked if 'storeqdrain=1' in sfincs.inp - ! - !write(logstr,'(a,i0,a,f0.1)')'INFO Gates - Opening structure ',idrn,' at t= ',t - !call write_log(logstr, 0) - ! - endif - ! - elseif (drainage_status(idrn) == 1) then - ! - ! Gate fully open - ! - if (zs(nmin) <= zmin .or. zs(nmin) >= zmax) then - ! - ! Water level is NOT in allowable range, so need to close the gate - ! - drainage_status(idrn) = 2 - ! - !write(logstr,'(a,i0,a,f0.1)')'INFO Gates - Closing structure ',idrn,' at t= ',t - !call write_log(logstr, 0) - ! - endif - ! - endif - ! - ! Update fraction open - ! - if (drainage_status(idrn) == 2) then - ! - ! Gate is closing - ! - frac = frac - dfrac - ! - if (frac < 0.0) then - ! - ! Gate is now fully closed - ! - frac = 0.0 - drainage_status(idrn) = 0 - ! - endif - ! - elseif (drainage_status(idrn) == 3) then - ! - ! Gate is opening - ! - frac = frac + dfrac - ! - if (frac > 1.0) then - ! - ! Gate is now fully open - ! - frac = 1.0 - drainage_status(idrn) = 1 - ! - endif - ! - endif - ! - drainage_fraction_open(idrn) = frac - ! - ! Use Bates et al. (2010) formulation to include inertia effects - ! - qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) - ! - ! Multiply with width and fraction open to get discharge in m3/s - ! - qq = qq * wdt * frac - ! - case(5) - ! - ! Controlled gate. Gate opens and closes at set user input times (only, and once), still using closing time. - ! - wdt = drainage_params(idrn, 1) ! width - zsill = drainage_params(idrn, 2) ! sill elevation - mng = drainage_params(idrn, 3) ! Manning's n - tclose = drainage_params(idrn, 4) ! time wrt tref for closing gate - topen = drainage_params(idrn, 5) ! time wrt tref for opening gate - tcls = drainage_params(idrn, 6) ! closing time (seconds) - ! - dzds = (zs(nmout) - zs(nmin)) / drainage_distance(idrn) ! water level slope - frac = drainage_fraction_open(idrn) ! fraction open (from previous time step) - hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) ! water depth - dfrac = dt / tcls ! change in fraction open per time step - ! - qq0 = -qtsrc(jin) / (wdt * max(frac, 0.001)) ! discharge (in m2/s) from previous time step, excluding fraction open - ! - ! Get status of gate - ! - if (drainage_status(idrn) == 0) then - ! - ! Gate fully closed - ! - if (t >= topen) then - ! - ! Time has passed 'topen', so need to open the gate - ! - drainage_status(idrn) = 3 - ! - !write(logstr,'(a,i0,a,f0.1)')'INFO Gates - Opening structure ',idrn,' at t= ',t - !call write_log(logstr, 0) - ! - endif - ! - elseif (drainage_status(idrn) == 1) then - ! - ! Gate fully open - ! - if (t >= tclose .and. t < topen) then - ! - ! Time has passed 'tclose', so need to close the gate - ! - drainage_status(idrn) = 2 - ! - !write(logstr,'(a,i0,a,f0.1)')'INFO Gates - Closing structure ',idrn,' at t= ',t - !call write_log(logstr, 0) - ! - endif - ! - endif - ! - ! Update fraction open - ! - if (drainage_status(idrn) == 2) then - ! - ! Gate is closing - ! - frac = frac - dfrac - ! - if (frac < 0.0) then - ! - ! Gate is now fully closed - ! - frac = 0.0 - drainage_status(idrn) = 0 - ! - endif - ! - elseif (drainage_status(idrn) == 3) then - ! - ! Gate is opening - ! - frac = frac + dfrac - ! - if (frac > 1.0) then - ! - ! Gate is now fully open - ! - frac = 1.0 - drainage_status(idrn) = 1 - ! - endif - ! - endif - ! - drainage_fraction_open(idrn) = frac - ! - ! Use Bates et al. (2010) formulation to include inertia effects - ! - qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) - ! - ! Multiply with width and fraction open to get discharge in m3/s - ! - qq = qq * wdt * frac - ! - end select + in_tok = .false. ! - ! Add some relaxation - ! structure_relax in seconds => gives ratio between new and old discharge (default 10s) - ! - qq = 1.0 / (structure_relax / dt) * qq + (1.0 - (1.0 / (structure_relax / dt))) * -qtsrc(jin) - ! - ! Limit discharge based on available volume in cell (regular or subgrid) - ! - if (subgrid) then - ! - if (qq > 0.0) then - qq = min(qq, max(z_volume(nmin), 0.0) / dt) - else - qq = max(qq, -max(z_volume(nmout), 0.0) / dt) - endif - ! - else + else + ! + if (.not. in_tok) then ! - if (qq > 0.0) then - qq = min(qq, max((zs(nmin) - zb(nmin)) * cell_area(z_flags_iref(nmin)), 0.0) / dt) - else - qq = max(qq, -max((zs(nmout) - zb(nmout)) * cell_area(z_flags_iref(nmout)), 0.0) / dt) - endif + ntok = ntok + 1 + in_tok = .true. ! endif - ! - qtsrc(jin) = -qq - qtsrc(jout) = qq ! endif ! enddo - !$acc end serial ! - endif - ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate - ! end subroutine - + ! end module diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index d754dee73..006cb8d76 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -25,8 +25,6 @@ subroutine initialize_domain() ! call initialize_roughness() ! - call initialize_infiltration() ! see: sfincs_infiltration.f90 - ! call initialize_storage_volume() ! call initialize_vegetation() @@ -1743,24 +1741,88 @@ subroutine initialize_bathymetry() ! end subroutine - subroutine compute_zbuvmx() + subroutine update_bed_level() + ! + ! Apply the externally-supplied delta bed level (dzbext) to the kernel's + ! bed-level arrays and refresh derived quantities at uv points. + ! + ! Non-subgrid mode: + ! zb = zb + dzbext (cell centres) + ! zbuvmx(ip) = max(zb(nm), zb(nmu)) + huthresh (uv points, rebuilt) + ! + ! Subgrid mode: + ! subgrid_z_zmin/zmax shift rigidly by dzbext at the cell centre. + ! subgrid_uv_zmin/zmax shift rigidly by the average dzbext of the two + ! neighbouring cells, with subgrid_uv_zmin clamped from below by the + ! larger of the two updated cell-centre subgrid_z_zmin values so the uv + ! minimum can never sit below either neighbour's minimum. + ! + ! The caller (Python via BMI) owns the lifecycle of dzbext: this routine + ! does not zero it out after applying. When use_dzbext is .false. the + ! routine still rebuilds zbuvmx in non-subgrid mode (cheap, and matches the + ! historical behaviour of compute_zbuvmx). ! use sfincs_data ! integer :: ip integer :: nm integer :: nmu + real*4 :: avg_dzb ! - do ip = 1, npuv + if (.not. subgrid) then ! - nm = uv_index_z_nm(ip) - nmu = uv_index_z_nmu(ip) + ! Non-subgrid path: shift zb, then rebuild zbuvmx for every uv point. ! - zbuvmx(ip) = max(zb(nm), zb(nmu)) + huthresh - ! - enddo + if (use_dzbext) then + ! + zb(:) = zb(:) + dzbext(:) + ! + endif + ! + do ip = 1, npuv + ! + nm = uv_index_z_nm(ip) + nmu = uv_index_z_nmu(ip) + ! + zbuvmx(ip) = max(zb(nm), zb(nmu)) + huthresh + ! + enddo + ! + else + ! + ! Subgrid path: only do anything when an external delta has been set. + ! + if (use_dzbext) then + ! + ! Cell-centre arrays shift rigidly with dzbext. + ! + subgrid_z_zmin(:) = subgrid_z_zmin(:) + dzbext(:) + subgrid_z_zmax(:) = subgrid_z_zmax(:) + dzbext(:) + ! + ! UV-point arrays shift by the average delta of the two neighbours, + ! then clamp uv_zmin from below by the higher of the two updated + ! cell-centre minima. + ! + do ip = 1, npuv + ! + nm = uv_index_z_nm(ip) + nmu = uv_index_z_nmu(ip) + ! + avg_dzb = 0.5 * (dzbext(nm) + dzbext(nmu)) + ! + subgrid_uv_zmin(ip) = subgrid_uv_zmin(ip) + avg_dzb + subgrid_uv_zmax(ip) = subgrid_uv_zmax(ip) + avg_dzb + ! + subgrid_uv_zmin(ip) = max(subgrid_uv_zmin(ip), & + max(subgrid_z_zmin(nm), subgrid_z_zmin(nmu))) + ! + enddo + ! + endif + ! + endif ! - end subroutine + end subroutine update_bed_level subroutine initialize_boundaries() ! @@ -2202,12 +2264,18 @@ subroutine initialize_hydro() allocate(uv0(npuv + ncuv + 1)) ! allocate(kfuv(npuv)) - ! - zs = 0.0 - q = 0.0 - q0 = 0.0 - uv = 0.0 - uv0 = 0.0 + ! + ! Cell-wise discharge accumulator (point sources + drainage structures), + ! read by sfincs_continuity. + ! + allocate(qsrc(np)) + ! + zs = 0.0 + q = 0.0 + q0 = 0.0 + uv = 0.0 + uv0 = 0.0 + qsrc = 0.0 ! kfuv = 0 ! diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index 147004080..291a3ffe0 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -18,8 +18,8 @@ subroutine initialize_infiltration() ! character*256 :: varname ! - character(len=3), parameter :: allowed_types(5) = & - ['c2d', 'cna', 'cnb', 'gai', 'hor'] + character(len=3), parameter :: allowed_types(6) = & + ['c2d', 'cna', 'cnb', 'gai', 'hor', 'bkt'] logical :: inftype_exists ! @@ -32,20 +32,22 @@ subroutine initialize_infiltration() infiltration = .false. netcdf_infiltration = .false. ! - ! Four options for infiltration: + ! Seven infiltration flavors (inftype): ! - ! 1) Spatially-uniform constant infiltration - ! Requires: - - ! 2) Spatially-varying constant infiltration - ! Requires: qinfmap (does not require qinffield !) - ! 3) Spatially-varying infiltration with CN numbers (old) - ! Requires: cumprcp, cuminf, qinfmap, qinffield - ! 4) Spatially-varying infiltration with CN numbers (new) - ! Requires: qinfmap, qinffield, qinffield, ksfield, scs_P1, scs_F1, scs_Se and scs_rain (but not necessarily cuminf and cumprcp) - ! 5) Spatially-varying infiltration with the Green-Ampt (GA) model - ! Requires: qinfmap, qinffield, ksfield, GA_head, GA_sigma_max, GA_Lu - ! 6) Spatially-varying infiltration with the modified Horton Equation - ! Requires: qinfmap, qinffield, horton_fc, horton_f0 + ! 1) 'con' - Spatially-uniform constant infiltration + ! Requires: qinf (mm/hr in sfincs.inp) + ! 2) 'c2d' - Spatially-varying constant infiltration + ! Requires: qinffile or infiltrationfile + ! 3) 'cna' - SCS Curve Number (old, no recovery) + ! Requires: scsfile or infiltrationfile + ! 4) 'cnb' - SCS Curve Number (new, with recovery) + ! Requires: sefffile or infiltrationfile + ! 5) 'gai' - Green-Ampt infiltration + ! Requires: psifile or infiltrationfile + ! 6) 'hor' - Modified Horton equation + ! Requires: f0file or infiltrationfile + ! 7) 'bkt' - Bucket model (linear reservoir, HBV/wflow style) + ! Requires: infiltrationfile with bucket_smax, bucket_k and bucket_loss ! ! cumprcp and cuminf are stored in the netcdf output if store_cumulative_precipitation == .true. which is the default ! @@ -61,6 +63,12 @@ subroutine initialize_infiltration() ! 1) First we determine infiltration type ! if (precip) then + ! + if (inftype == 'bkt' .and. infiltrationfile == 'none') then + ! + call stop_sfincs('Error ! Bucket model requires infiltrationfile together with infiltrationtype = bkt !', 1) + ! + endif ! if (infiltrationfile /= 'none') then ! @@ -83,7 +91,7 @@ subroutine initialize_infiltration() ! else ! - write(logstr,*)'Error : infiltration input type ',trim(inftype),' is not part of supported types c2d cna cnb gai hor !' + write(logstr,*)'Error : infiltration input type ',trim(inftype),' is not part of supported types c2d cna cnb gai hor bkt !' call stop_sfincs(trim(logstr), 1) ! end if @@ -124,7 +132,7 @@ subroutine initialize_infiltration() inftype = 'gai' infiltration = .true. ! - elseif (f0file /= 'none') then + elseif (f0file /= 'none') then ! ! The Horton Equation model for infiltration ! @@ -168,22 +176,19 @@ subroutine initialize_infiltration() ! 5) Check whether infiltration input type (orignal vs netcdf) are correctly matched to grid type (regular vs quadtree) ! if (infiltration .and. inftype /= 'con') then !constant uniform works for both options - ! - if (netcdf_infiltration) then - ! - if (use_quadtree .eqv. .false.) then - ! - call stop_sfincs('Error ! Netcdf infiltration input format can only be specified for quadtree mesh model !', 1) + ! + ! Netcdf infiltration works for both regular and quadtree grids + ! (regular grids populate quadtree_nr_points and index_sfincs_in_quadtree + ! via make_quadtree_from_indices) + ! + if (.not. netcdf_infiltration) then + ! + if (use_quadtree .eqv. .true.) then + ! + call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) ! endif ! - else ! Original - ! - if (use_quadtree .eqv. .true.) then - ! - call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) - endif - ! endif ! endif @@ -498,7 +503,7 @@ subroutine initialize_infiltration() ! Allocate support variables: ! allocate(qinffield(np)) - qinffield(nm) = 0.0 + qinffield = 0.0 ! elseif (inftype == 'hor') then ! @@ -591,6 +596,14 @@ subroutine initialize_infiltration() allocate(rain_T1(np)) rain_T1 = 0.0 ! + elseif (inftype == 'bkt') then + ! + ! Bucket model (linear reservoir) - mimics hydrology models like wflow/HBV + ! + call write_log('Info : turning on process infiltration (via bucket model)', 0) + ! + call initialize_bucket_model() + ! endif ! else @@ -604,11 +617,12 @@ subroutine initialize_infiltration() end subroutine - subroutine update_infiltration_map(dt, tloop) + subroutine update_infiltration_map(dt) ! ! Update infiltration rates in each grid cell ! use sfincs_data + use sfincs_timers ! implicit none ! @@ -617,15 +631,9 @@ subroutine update_infiltration_map(dt, tloop) real*4 :: Qq real*4 :: I real*4 :: hh_local, a - real*4 :: dt - ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop + real*4 :: dt ! - call system_clock(count0, count_rate, count_max) + call timer_start('infiltration') ! if (inftype == 'con' .or. inftype == 'c2d') then ! @@ -634,7 +642,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( nm ) !$omp do - !$acc parallel present( qinfmap, qinffield, z_volume, zs, zb, netprcp, cuminf ) + !$acc parallel present( qinfmap, qinffield, z_volume, zs, zb, cuminf ) !$acc loop independent gang vector do nm = 1, np ! @@ -656,17 +664,13 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - ! Compute nett precip - ! - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration ! cuminf(nm) = cuminf(nm) + qinfmap(nm) * dt ! - endif + endif ! enddo !$omp end do @@ -680,7 +684,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( Qq,I,nm ) !$omp do - !$acc parallel present( qinfmap, qinffield, prcp, netprcp, cumprcp, cuminf ) + !$acc parallel present( qinfmap, qinffield, prcp, cumprcp, cuminf ) !$acc loop independent gang vector do nm = 1, np ! @@ -702,10 +706,6 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - ! Compute nett precip - ! - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration @@ -726,7 +726,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( Qq,I,nm ) !$omp do - !$acc parallel present( qinfmap, prcp, netprcp, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, qinffield, inf_kr ) + !$acc parallel present( qinfmap, prcp, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, qinffield, inf_kr ) !$acc loop independent gang vector do nm = 1, np ! @@ -808,10 +808,6 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - ! Compute nett precip - ! - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration @@ -822,7 +818,7 @@ subroutine update_infiltration_map(dt, tloop) ! enddo !$omp end do - !$omp end parallel + !$omp end parallel !$acc end parallel ! elseif (inftype == 'gai') then @@ -832,7 +828,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( nm ) !$omp do - !$acc parallel present( qinfmap, prcp, netprcp, cuminf, rain_T1, & + !$acc parallel present( qinfmap, prcp, cuminf, rain_T1, & !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr ) !$acc loop independent gang vector do nm = 1, np @@ -853,8 +849,18 @@ subroutine update_infiltration_map(dt, tloop) ! ! Larger amounts of rainfall - Equation 4-27 from SWMM manual ! - qinfmap(nm) = (ksfield(nm) * (1.0 + (GA_head(np) * GA_sigma(np)) / GA_F(nm))) - qinfmap(nm) = max(min(qinfmap(nm), prcp(nm)), 0.0) ! never more than rainfall and and never negative + if (GA_F(nm) < 1.0e-10) then + ! + ! No cumulative infiltration yet (first timestep) - all rainfall infiltrates + ! + qinfmap(nm) = prcp(nm) + ! + else + ! + qinfmap(nm) = (ksfield(nm) * (1.0 + (GA_head(nm) * GA_sigma(nm)) / GA_F(nm))) + qinfmap(nm) = max(min(qinfmap(nm), prcp(nm)), 0.0) ! never more than rainfall and never negative + ! + endif ! endif ! @@ -891,11 +897,6 @@ subroutine update_infiltration_map(dt, tloop) endif endif ! - ! Compute nett precip - ! - !qinffield(nm) = qinfmap(nm) ! Really ? Why ? - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration @@ -906,7 +907,7 @@ subroutine update_infiltration_map(dt, tloop) ! enddo !$omp end do - !$omp end parallel + !$omp end parallel !$acc end parallel ! elseif (inftype == 'hor') then @@ -916,7 +917,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( nm, Qq, I, a, hh_local ) !$omp do - !$acc parallel present( qinfmap, prcp, netprcp, cuminf, cell_area_m2, cell_area, z_flags_iref, z_volume, zs, zb, rain_T1, & + !$acc parallel present( qinfmap, prcp, cuminf, cell_area_m2, cell_area, z_flags_iref, z_volume, zs, zb, rain_T1, & !$acc horton_kd, horton_fc, horton_f0 ) !$acc loop independent gang vector do nm = 1, np @@ -1012,10 +1013,6 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - ! Compute nett precip - ! - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration @@ -1026,14 +1023,218 @@ subroutine update_infiltration_map(dt, tloop) ! enddo !$omp end do - !$omp end parallel + !$omp end parallel !$acc end parallel ! + elseif (inftype == 'bkt') then + ! + ! Bucket model (linear reservoir) + ! + call compute_bucket_drainage(dt) + ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate + ! Apply the resulting infiltration-rate field to the point-source field + ! qsrc (m3/s). qinfmap is m/s, so multiply by cell area and subtract. + ! qsrc already holds this step's prcp*area contribution (from + ! update_meteo_forcing) plus any discharges / src-structures updates + ! done earlier in update_continuity. + ! + !$acc parallel loop present( qsrc, qinfmap, cell_area, cell_area_m2, z_flags_iref ) + !$omp parallel do default(shared) private(nm) schedule(static) + do nm = 1, np + ! + if (crsgeo) then + qsrc(nm) = qsrc(nm) - qinfmap(nm) * cell_area_m2(nm) + else + qsrc(nm) = qsrc(nm) - qinfmap(nm) * cell_area(z_flags_iref(nm)) + endif + ! + enddo + !$omp end parallel do + ! + call timer_stop('infiltration') ! - end subroutine + end subroutine + + + subroutine initialize_bucket_model() + ! + use netcdf + use sfincs_data + use sfincs_ncinput + ! + implicit none + ! + integer :: status, ncid, varid + character*256 :: varname + ! + if (netcdf_infiltration) then + ! + use_bucket_model = .true. + ! + write(logstr,'(a)')'Info : turning on bucket model (linear reservoir)' + call write_log(logstr, 0) + ! + allocate(bucket_capacity(np)) + allocate(bucket_k(np)) + allocate(bucket_volume(np)) + allocate(bucket_drain_rate(np)) + allocate(bucket_loss(np)) + allocate(bucket_runoff(np)) + ! + bucket_capacity = 0.0 + bucket_k = 0.0 + bucket_volume = 0.0 + bucket_drain_rate = 0.0 + bucket_loss = 0.0 + bucket_runoff = 0.0 + ! + ! + ! Read from infiltrationfile (netcdf) - works for both regular and quadtree grids + ! + varname = 'bucket_smax' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_capacity) + bucket_capacity = bucket_capacity / 1000.0 ! mm to m + ! + varname = 'bucket_k' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_k) + bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s + ! + status = nf90_open(trim(infiltrationfile), NF90_NOWRITE, ncid) + if (status /= nf90_noerr) then + call stop_sfincs('Error ! Cannot open infiltrationfile for bucket model input !', 1) + endif + ! + status = nf90_inq_varid(ncid, 'bucket_loss', varid) + if (nf90_close(ncid) /= nf90_noerr) then + call stop_sfincs('Error ! Cannot close infiltrationfile after checking bucket model variables !', 1) + endif + ! + if (status /= nf90_noerr) then + call stop_sfincs('Error ! Bucket model requires variable bucket_loss in infiltrationfile !', 1) + endif + ! + varname = 'bucket_loss' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_loss) + call write_log('Info : read spatially-varying bucket_loss from infiltrationfile', 0) + ! + write(logstr,'(a,f10.4,a)')'Info : bucket max capacity = ', maxval(bucket_capacity) * 1000.0, ' mm' + call write_log(logstr, 0) + write(logstr,'(a,f6.3)')'Info : bucket loss fraction = ', maxval(bucket_loss) + call write_log(logstr, 0) + ! + else + ! + ! Allocate minimal arrays for OpenACC compatibility + ! + allocate(bucket_capacity(1)) + allocate(bucket_k(1)) + allocate(bucket_volume(1)) + allocate(bucket_drain_rate(1)) + allocate(bucket_loss(1)) + allocate(bucket_runoff(1)) + bucket_capacity = 0.0 + bucket_k = 0.0 + bucket_volume = 0.0 + bucket_drain_rate = 0.0 + bucket_loss = 0.0 + bucket_runoff = 0.0 + ! + endif + ! + end subroutine + + + subroutine compute_bucket_drainage(dt) + ! + ! Bucket model with loss: linear reservoir + loss fraction (HBV/wflow style) + ! + ! Steps per cell: + ! 1. P_eff = P * (1 - loss) -- fraction lost to ET/deep percolation + ! 2. Fill bucket with P_eff (up to Smax capacity) + ! 3. Drain bucket: S(t+dt) = S(t)*exp(-k*dt), drainage returned as runoff + ! 4. qinfmap = P - runoff -- net removal from surface + ! + ! In continuity: zs += prcp*dt - qinfmap*dt = bucket_runoff*dt + ! => Only bucket drainage reaches the surface water level + ! + ! Literature: Linear reservoir (Nash, 1957), HBV soil moisture bucket (Bergstrom, 1995) + ! + use sfincs_data + ! + implicit none + ! + real*4 :: dt + integer :: nm + real*4 :: exp_factor + real*4 :: drain_vol + real*4 :: P_eff + real*4 :: available_cap + real*4 :: actual_inflow + real*4 :: precip_rate + ! + !$omp parallel do private(nm, exp_factor, drain_vol, P_eff, available_cap, actual_inflow, precip_rate) + !$acc parallel present( kcs, prcp, qinfmap, cuminf, bucket_volume, bucket_capacity, bucket_k, & + !$acc bucket_drain_rate, bucket_loss, bucket_runoff ) + !$acc loop independent gang vector + do nm = 1, np + ! + if (kcs(nm) == 1 .and. bucket_k(nm) > 0.0) then + ! + ! Step 1: Compute effective precipitation (after loss) + ! + precip_rate = max(prcp(nm), 0.0) + P_eff = precip_rate * (1.0 - bucket_loss(nm)) ! m/s after loss + ! + ! Step 2: Fill bucket with effective precip (up to capacity) + ! + if (bucket_capacity(nm) > 0.0) then + available_cap = bucket_capacity(nm) - bucket_volume(nm) + actual_inflow = min(P_eff * dt, available_cap) ! m + else + ! No capacity limit (Smax = 0 means infinite) + actual_inflow = P_eff * dt ! m + endif + bucket_volume(nm) = bucket_volume(nm) + actual_inflow + ! + ! Step 3: Drain bucket (analytical linear reservoir) + ! S(t+dt) = S(t) * exp(-k*dt), drainage = S(t) - S(t+dt) + ! + exp_factor = exp(-bucket_k(nm) * dt) + drain_vol = bucket_volume(nm) * (1.0 - exp_factor) ! m drained this step + bucket_volume(nm) = bucket_volume(nm) * exp_factor + ! + ! Step 4: Bucket drainage becomes runoff returned to surface + ! + bucket_runoff(nm) = drain_vol / dt ! m/s + ! + ! Step 5: Set qinfmap = loss + what entered bucket - what drained back + ! In continuity: zs += prcp*dt - qinfmap*dt + ! Water balance: qinfmap = prcp*loss + actual_inflow/dt - bucket_runoff + ! When bucket has room: actual_inflow = P_eff*dt => qinfmap = prcp - bucket_runoff + ! When bucket is full: actual_inflow = 0 => qinfmap can be negative (drainage > inflow) + ! + qinfmap(nm) = precip_rate * bucket_loss(nm) + actual_inflow / dt - bucket_runoff(nm) + ! + bucket_drain_rate(nm) = bucket_runoff(nm) + ! + if (store_cumulative_precipitation) then + cuminf(nm) = cuminf(nm) + qinfmap(nm) * dt + endif + ! + else + ! + qinfmap(nm) = 0.0 + bucket_drain_rate(nm) = 0.0 + bucket_runoff(nm) = 0.0 + ! + endif + ! + enddo + !$acc end parallel + !$omp end parallel do + ! + end subroutine end module diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 40dc39105..428c33ff7 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -1,750 +1,1067 @@ module sfincs_input - -contains - - subroutine read_sfincs_input() - ! - ! Reads sfincs.inp ! - use sfincs_data - use sfincs_date - use sfincs_log - use sfincs_error - use sfincs_read + ! Parser for the SFINCS main input file `sfincs.inp` plus a small set + ! of primitive helpers that read one keyword at a time from that file. + ! + ! `sfincs.inp` is a flat keyword / value text file (one `key = value` + ! pair per line, comment lines start with `#`, `!`, or `@`). Reads go + ! through the generic `get_keyword(...)` interface below. Every call + ! accepts an optional array of deprecated keyword aliases — the new + ! key is tried first, then each legacy alias in order, then the + ! caller's supplied default. A one-line warning is written to the log + ! the first time an alias is matched, so users see that their .inp is + ! using a deprecated name. + ! + ! The module does not own the variables it fills — it writes directly + ! into module-level state declared in sfincs_data, sfincs_src_structures, + ! sfincs_discharges, etc. + ! + ! Subroutines: + ! + ! read_sfincs_input() + ! Main driver. Opens sfincs.inp, pulls every keyword it knows + ! about via get_keyword(), then derives secondary flags (CRS / + ! Coriolis, subgrid vs. regular, bathtub overrides). Called once + ! from sfincs_initialize (sfincs_lib). + ! + ! get_keyword(fileid, keyword, value, default [, legacy]) + ! Generic interface; resolves by the type of `value`. Type- + ! specific module procedures do the actual scan: + ! get_keyword_real (real*4 scalar) + ! get_keyword_int (integer scalar) + ! get_keyword_char (character*(*) scalar) + ! get_keyword_logical (logical scalar) + ! Called from read_sfincs_input. + ! + ! get_keyword_real_array(fileid, keyword, value, default, nr [, legacy]) + ! Variant for whitespace-separated real arrays (sized nr). + ! Called from read_sfincs_input. + ! + ! find_value(fileid, keyword, valstr, found) + ! Scan the file once for a single keyword; return the raw value + ! string and whether it was found. Called from each + ! get_keyword_* procedure. + ! + ! warn_legacy(legacy_key, new_key) + ! Emit a deprecation warning to the log. Called from each + ! get_keyword_* procedure when a legacy alias has been resolved. + ! + ! read_line(line0, keystr, valstr) + ! Strip tab/line-ending noise, split `key = value` on the first + ! `=`, strip any trailing `# ...` inline comment. Called from + ! find_value. + ! + ! notabs(instr, outstr, ilen) + ! Expand embedded tab characters into spaces preserving 8-column + ! tab stops. Called from read_line. + ! + use sfincs_log, only: write_log, logstr ! implicit none ! - integer*8 dtsec - ! - ! Temporary variables - ! - integer iradstr - integer igeo - integer icoriolis - integer iamprblock - integer iglobal - integer itsunamitime - integer ispinupmeteo - integer isnapwave - integer iwindmax - integer iwind - integer ioutfixed - integer iadvection - integer istorefw - integer istorewavdir - integer imanning2d - integer isubgrid - integer iwavemaker - integer iwavemaker_spectrum - integer ispwprecip - logical iviscosity - logical ok - ! - character*256 wmsigstr - character*256 advstr - ! - ok = check_file_exists('sfincs.inp', 'SFINCS input file', .true.) - ! - open(500, file='sfincs.inp') - ! - call read_int_input(500,'mmax',mmax,0) - call read_int_input(500,'nmax',nmax,0) - call read_real_input(500,'dx',dx,0.0) - call read_real_input(500,'dy',dy,0.0) - call read_real_input(500,'x0',x0,0.0) - call read_real_input(500,'y0',y0,0.0) - call read_real_input(500,'rotation',rotation,0.0) - call read_char_input(500,'tref',trefstr,'none') - call read_char_input(500,'tstart',tstartstr,'20000101 000000') - call read_char_input(500,'tstop',tstopstr,'20000101 000000') - call read_real_input(500,'tspinup',tspinup,0.0) - call read_real_input(500,'t0out',t0out,-999.0) - call read_real_input(500,'t1out',t1out,-999.0) - call read_real_input(500,'dtout',dtmapout,0.0) - call read_real_input(500,'dtmaxout',dtmaxout,9999999.0) - call read_real_input(500,'dtrstout',dtrstout,0.0) - call read_real_input(500,'trstout',trst,-999.0) - call read_real_input(500,'dthisout',dthisout,600.0) - call read_real_input(500,'dtwave',dtwave,3600.0) - call read_real_input(500,'dtwnd',dtwindupd,1800.0) - call read_real_input(500,'alpha',alfa,0.50) - call read_real_input(500,'theta',theta,1.0) - call read_real_input(500,'hmin_cfl',hmin_cfl,0.1) - call read_real_input(500,'manning',manning,0.04) - call read_real_input(500,'manning_land',manning_land,-999.0) - call read_real_input(500,'manning_sea',manning_sea,-999.0) - call read_real_input(500,'rgh_lev_land',rghlevland,0.0) - call read_real_input(500,'zsini',zini,0.0) - call read_real_input(500,'qinf',qinf,0.0) - call read_real_input(500,'dtmax',dtmax,60.0) - call read_real_input(500,'huthresh',huthresh,0.05) - call read_real_input(500,'huvmin', huvmin, 0.0) ! Minimum depth for calculating velocity (uv = q / max(hu, huvmin) used for output and advection) - call read_real_input(500,'rhoa',rhoa,1.25) - call read_real_input(500,'rhow',rhow,1024.0) - call read_char_input(500,'inputformat',inputtype,'bin') - call read_char_input(500,'outputformat',outputtype,'net') - call read_char_input(500,'outputtype_map',outputtype_map,'nil') - call read_char_input(500,'outputtype_his',outputtype_his,'nil') - call read_int_input(500,'nc_deflate_level',nc_deflate_level,2) - call read_int_input(500,'bndtype',bndtype,1) - call read_int_input(500,'advection',iadvection,1) - call read_real_input(500,'latitude',latitude,0.0) - call read_real_input(500,'pavbnd',pavbnd,0.0) - call read_real_input(500,'gapres',gapres,101200.0) - call read_int_input(500,'baro',baro,1) - call read_char_input(500,'utmzone',utmzone,'nil') - call read_int_input(500,'epsg',epsg,0) - call read_char_input(500,'epsg',epsg_code,'nil') - call read_real_input(500, 'advlim', advlim, 1.0) - call read_real_input(500,'slopelim',slopelim,9999.9) - call read_real_input(500,'qinf_zmin',qinf_zmin,0.0) - call read_real_input(500,'btfilter',btfilter,60.0) - call read_real_input(500,'sfacinf',sfacinf,0.2) - call read_int_input(500,'radstr',iradstr,0) - call read_int_input(500,'crsgeo',igeo,0) - call read_logical_input(500, 'coriolis', coriolis, .true.) - call read_int_input(500,'amprblock',iamprblock,1) - call read_real_input(500,'spwmergefrac',spw_merge_frac,0.5) - call read_int_input(500,'usespwprecip',ispwprecip,1) - call read_int_input(500,'global',iglobal,0) - call read_real_input(500,'nuvisc',nuviscdim,0.01) - call read_logical_input(500,'viscosity',iviscosity,.false.) - call read_int_input(500,'spinup_meteo', ispinupmeteo, 0) - call read_real_input(500,'waveage',waveage,-999.0) - call read_int_input(500,'snapwave', isnapwave, 0) - call read_int_input(500,'dtoutfixed', ioutfixed, 1) - ! - ! Wave maker parameters - ! - ! First read some deprecated keywords for backward compatibility (to be removed later) - ! - call read_char_input(500, 'wavemaker_wvmfile', wavemaker_wvmfile, 'none') ! wavemaker polyline file - if (wavemaker_wvmfile(1:4) == 'none') call read_char_input(500, 'wvmfile', wavemaker_wvmfile, 'none') ! old keyword - ! - call read_char_input(500, 'wavemaker_wfpfile', wavemaker_wfpfile, 'none') ! wavemaker forcing points file - if (wavemaker_wfpfile(1:4) == 'none') call read_char_input(500, 'wfpfile', wavemaker_wfpfile, 'none') - ! - call read_char_input(500, 'wavemaker_whifile', wavemaker_whifile, 'none') ! wavemaker wave height time series file - if (wavemaker_whifile(1:4) == 'none') call read_char_input(500, 'whifile', wavemaker_whifile, 'none') - ! - call read_char_input(500, 'wavemaker_wtifile', wavemaker_wtifile, 'none') ! wavemaker wave period time series file - if (wavemaker_wtifile(1:4) == 'none') call read_char_input(500, 'wtifile', wavemaker_wtifile, 'none') - ! - call read_char_input(500, 'wavemaker_wstfile', wavemaker_wstfile, 'none') ! wavemaker wave set-up time series file - if (wavemaker_wstfile(1:4) == 'none') call read_char_input(500, 'wstfile', wavemaker_wstfile, 'none') - ! - ! Overwrite with new keywords, if provided by user (for backward compatibility, to be removed later) - call read_real_input(500, 'wmtfilter', wavemaker_filter_time, 600.0) ! time scale for wavemaker filter (in seconds) - call read_real_input(500, 'wavemaker_filter_time', wavemaker_filter_time, wavemaker_filter_time) - ! - call read_real_input(500, 'wmfred', wavemaker_filter_fred, 0.99) ! fred for wavemaker filter (reduces chance of jets) - call read_real_input(500, 'wavemaker_filter_fred', wavemaker_filter_fred, wavemaker_filter_fred) - ! - call read_char_input(500, 'wmsignal', wmsigstr, 'spectrum') ! wavemaker signal type (spectrum or monochromatic) - call read_char_input(500, 'wavemaker_signal', wmsigstr, trim(wmsigstr)) - ! - call read_real_input(500, 'wmhmin', wavemaker_hmin, 0.1) ! minimum water depth for wave generation (in m) - call read_real_input(500, 'wavemaker_hmin', wavemaker_hmin, wavemaker_hmin) - ! - call read_int_input(500, 'nfreqsinc', wavemaker_nfreqs_inc, 100) ! wavemaker number of frequencies for incident wave spectrum - call read_int_input(500, 'wavemaker_nfreqs_inc', wavemaker_nfreqs_inc, wavemaker_nfreqs_inc) - ! - call read_real_input(500, 'freqmininc', wavemaker_freqmin_inc, 0.04) ! wavemaker minimum frequency for incident wave spectrum (in Hz) - call read_real_input(500, 'wavemaker_freqmin_inc', wavemaker_freqmin_inc, wavemaker_freqmin_inc) - ! - call read_real_input(500, 'freqmaxinc', wavemaker_freqmax_inc, 1.0) ! wavemaker maximum frequency for incident wave spectrum (in Hz) - call read_real_input(500, 'wavemaker_freqmax_inc', wavemaker_freqmax_inc, wavemaker_freqmax_inc) - ! - call read_int_input(500, 'nfreqsig', wavemaker_nfreqs_ig, 100) ! wavemaker number of frequencies for IG wave spectrum - call read_int_input(500, 'wavemaker_nfreqs_ig', wavemaker_nfreqs_ig, wavemaker_nfreqs_ig) - ! - call read_real_input(500, 'freqminig', wavemaker_freqmin_ig, 0.0) ! wavemaker minimum frequency for IG wave spectrum (in Hz) - call read_real_input(500, 'wavemaker_freqmin_ig', wavemaker_freqmin_ig, wavemaker_freqmin_ig) - ! - call read_real_input(500, 'freqmaxig', wavemaker_freqmax_ig, 0.1) ! wavemaker maximum frequency for IG wave spectrum (in Hz) - call read_real_input(500, 'wavemaker_freqmax_ig', wavemaker_freqmax_ig, wavemaker_freqmax_ig) - ! New variables that have no backward compatibility version - ! - call read_real_input(500, 'wavemaker_tinc2ig', wavemaker_tinc2ig, -1.0) ! wavemaker ig/inc wave period ratio (set <= 0.0 to use Herbers) - call read_real_input(500, 'wavemaker_surfslope', wavemaker_surfslope, -1.0) ! wavemaker surf zone slope to compute Tp_ig with empirical run-up equation (van Ormondt et al., 2021)) - call read_real_input(500, 'wavemaker_hm0_ig_factor', wavemaker_hm0_ig_factor, 1.0) ! wavemaker Hm0 IG wave factor - call read_real_input(500, 'wavemaker_hm0_inc_factor', wavemaker_hm0_inc_factor, 1.0) ! wavemaker Hm0 inc wave factor - call read_real_input(500, 'wavemaker_gammax', wavemaker_gammax, 1.0) ! wavemaker gammax - call read_real_input(500, 'wavemaker_tpmin', wavemaker_tpmin, 1.0) ! wavemaker tpmin - call read_logical_input(500, 'wavemaker_hig', wavemaker_hig, .true.) ! wavemaker include IG waves - call read_logical_input(500, 'wavemaker_hinc', wavemaker_hinc, .false.) ! wavemaker include incident waves - ! - ! Numerical parameters - call read_char_input(500,'advection_scheme',advstr,'upw1') - call read_real_input(500,'btrelax',btrelax,3600.0) - call read_logical_input(500,'wiggle_suppression', wiggle_suppression, .true.) - call read_real_input(500,'structure_relax',structure_relax,10.0) - call read_real_input(500,'wiggle_factor',wiggle_factor,0.1) - call read_real_input(500,'wiggle_threshold',wiggle_threshold,0.1) - call read_real_input(500, 'uvlim', uvlim, 10.0) - call read_real_input(500, 'uvmax', uvmax, 1000.0) - call read_logical_input(500,'friction2d',friction2d,.true.) - call read_logical_input(500,'advection_mask',advection_mask,.true.) - ! call read_real_input(500, 'dzdsbnd', dzdsbnd, 0.0001) - ! call read_real_input(500, 'manningbnd', manningbnd, 0.024) - call read_real_input(500, 'nuviscfac', nuviscfac, 100.0) - call read_logical_input(500, 'nonh', nonhydrostatic, .false.) - call read_real_input(500, 'nh_fnudge', nh_fnudge, 0.9) - call read_real_input(500, 'nh_tstop', nh_tstop, -999.0) - call read_real_input(500, 'nh_tol', nh_tol, 0.001) - call read_int_input(500, 'nh_itermax', nh_itermax, 100) - call read_logical_input(500, 'h73table', h73table, .false.) - call read_real_input(500, 'rugdepth', runup_gauge_depth, 0.05) - call read_logical_input(500, 'wave_enhanced_roughness', wave_enhanced_roughness, .false.) - call read_logical_input(500, 'use_bcafile', use_bcafile, .true.) - call read_real_input(500, 'factor_wind', factor_wind, 1.0) - call read_real_input(500, 'factor_pres', factor_pres, 1.0) - call read_real_input(500, 'factor_prcp', factor_prcp, 1.0) - call read_real_input(500, 'factor_spw_size', factor_spw_size, 1.0) - call read_logical_input(500, 'bathtub', bathtub, .false.) - call read_real_input(500, 'bathtub_fachs', bathtub_fac_hs, 0.2) - call read_real_input(500, 'bathtub_dt', bathtub_dt, -999.0) - call read_logical_input(500,'vegetation',vegetation,.false.) - ! - ! Domain - ! - call read_char_input(500,'qtrfile',qtrfile,'none') - call read_char_input(500,'depfile',depfile,'none') - call read_char_input(500,'inifile',zsinifile,'none') - call read_char_input(500,'rstfile',rstfile,'none') - call read_char_input(500,'mskfile',mskfile,'none') - call read_char_input(500,'indexfile',indexfile,'none') - call read_char_input(500,'cstfile',cstfile,'none') - call read_char_input(500,'sbgfile',sbgfile,'none') - call read_char_input(500,'thdfile',thdfile,'none') - call read_char_input(500,'weirfile',weirfile,'none') - call read_char_input(500,'manningfile',manningfile,'none') - call read_char_input(500,'drnfile',drnfile,'none') - call read_char_input(500,'volfile',volfile,'none') - call read_char_input(500,'vegetationfile',veggiefile,'none') - call read_char_input(500,'vegetationtype_toml',veggietype_toml,'none') ! companion TOML lookup table; if set, veggiefile holds only vegetation_type integers - ! - ! Forcing - ! - call read_char_input(500,'bndfile',bndfile,'none') - call read_char_input(500,'bzsfile',bzsfile,'none') - call read_char_input(500,'bcafile',bcafile,'none') - call read_char_input(500,'bzifile',bzifile,'none') - call read_char_input(500, 'bdrfile', bdrfile, 'none') - call read_char_input(500,'srcfile',srcfile,'none') - call read_char_input(500,'disfile',disfile,'none') - call read_char_input(500,'spwfile',spwfile,'none') - call read_char_input(500,'wndfile',wndfile,'none') - call read_char_input(500,'prcfile',prcpfile,'none') - if (prcpfile(1:4) == 'none') then - ! Try with old keyword - call read_char_input(500,'precipfile',prcpfile,'none') - endif - call read_char_input(500,'amufile',amufile,'none') - call read_char_input(500,'amvfile',amvfile,'none') - call read_char_input(500,'ampfile',ampfile,'none') - call read_char_input(500,'amprfile',amprfile,'none') - call read_char_input(500,'z0lfile',z0lfile,'none') - call read_char_input(500,'qinffile',qinffile,'none') - ! Curve Number files - call read_char_input(500,'scsfile',scsfile,'none') - call read_char_input(500,'smaxfile',smaxfile,'none') - call read_char_input(500,'sefffile',sefffile,'none') - ! Green and Ampt files - call read_char_input(500,'psifile',psifile,'none') ! suction head [mm] - call read_char_input(500,'sigmafile',sigmafile,'none') ! maximum moisture deficit θdmax [-] - call read_char_input(500,'ksfile',ksfile,'none') ! saturated hydraulic conductivity [mm/hr] - ! Horton file - call read_char_input(500,'f0file',f0file,'none') ! Maximum (Initial) Infiltration Capacity, F0 - call read_char_input(500,'fcfile',fcfile,'none') ! Minimum (Asymptotic) Infiltration Rate, Fc - call read_char_input(500,'kdfile',kdfile,'none') ! k = empirical constant (hr-1) of decay - call read_real_input(500,'horton_kr_kd',horton_kr_kd,10.0) ! recovery goes 10 times as SLOW as decay - ! Netcdf input - call read_char_input(500,'netbndbzsbzifile',netbndbzsbzifile,'none') - call read_char_input(500,'netsrcdisfile',netsrcdisfile,'none') - call read_char_input(500,'netamuamvfile',netamuamvfile,'none') - call read_char_input(500,'netamprfile',netamprfile,'none') - call read_char_input(500,'netampfile',netampfile,'none') - call read_char_input(500,'netspwfile',netspwfile,'none') - ! - call read_char_input(500,'infiltration_file',infiltrationfile,'none') - call read_char_input(500,'infiltration_type',inftype,'none') - ! - ! Output - call read_char_input(500,'obsfile',obsfile,'none') - call read_char_input(500,'crsfile',crsfile,'none') - call read_char_input(500, 'rugfile', rugfile, 'none') - call read_int_input(500,'storevelmax',storevelmax,0) - call read_int_input(500,'storefluxmax',storefluxmax,0) - call read_int_input(500,'storevel',storevel,0) - call read_int_input(500,'storecumprcp',storecumprcp,0) - call read_int_input(500,'storetwet',storetwet,0) - call read_int_input(500,'storetzsmax',storetzsmax,0) - call read_int_input(500,'storehsubgrid',storehsubgrid,0) - call read_logical_input(500, 'storehmean', store_hmean, .false.) - call read_real_input(500,'twet_threshold',twet_threshold,0.01) - call read_int_input(500,'store_tsunami_arrival_time',itsunamitime,0) - call read_real_input(500,'tsunami_arrival_threshold',tsunami_arrival_threshold,0.01) - call read_logical_input(500,'timestep_analysis',timestep_analysis,.false.) - call read_int_input(500,'storeqdrain',storeqdrain,1) - call read_int_input(500,'storezvolume',storezvolume,0) - call read_int_input(500,'storestoragevolume',storestoragevolume,0) - call read_int_input(500,'writeruntime',wrttimeoutput,0) - call read_logical_input(500,'debug',debug,.false.) - call read_int_input(500,'storemeteo',storemeteo,0) - call read_int_input(500,'storemaxwind',iwindmax,0) - call read_int_input(500,'storefw', istorefw, 0) - call read_int_input(500,'storewavdir', istorewavdir, 0) - call read_logical_input(500,'regular_output_on_mesh',use_quadtree_output,.false.) - call read_logical_input(500, 'store_dynamic_bed_level', store_dynamic_bed_level, .false.) - call read_logical_input(500,'snapwave_use_nearest',snapwave_use_nearest,.true.) - call read_int_input(500,'percentage_done',percdoneval,5) - ! Limit to range (0,100) - percdoneval = max(min(percdoneval,100), 0) - ! - ! Coupled SnapWave solver related - call read_int_input(500,'snapwave_wind',iwind,0) - call read_logical_input(500,'snapwave_vegetation',snapwave_vegetation,.false.) - call read_real_input(500,'snapwave_waveforces_ratio',waveforces_ratio,1.0) - ! - ! Wind drag - ! - call read_int_input(500,'cdnrb',cd_nr,0) - ! - if (cd_nr==0) then - ! - ! Use defaults - ! - cd_nr = 3 - ! - allocate(cd_wnd(cd_nr)) - allocate(cd_val(cd_nr)) - ! - cd_wnd(1) = 0.0 - cd_wnd(2) = 28.0 - cd_wnd(3) = 50.0 - cd_val(1) = 0.0010 - cd_val(2) = 0.0025 - cd_val(3) = 0.0015 - ! - else - ! - ! Use defaults - ! - call read_real_array_input(500,'cdwnd',cd_wnd,0.0,cd_nr) - call read_real_array_input(500,'cdval',cd_val,0.0,cd_nr) - ! - endif - ! - ! Try new keywords for sfincs.inp file (ensure backward compatibility) - ! - if (dtmapout==0.0) then - call read_real_input(500,'dtmapout',dtmapout,0.0) - endif - ! - close(500) - ! - ! Check whether epsg code has been specified: - if (epsg == 0) then - call write_log('Warning : no EPSG code defined', 0) - endif - ! - ! If tref not provided, assume tref=tstart - ! - if (trefstr(1:4) == 'none') then - ! - trefstr = tstartstr - ! - write(logstr,*)'Warning : no tref provided, set to tstart: ',trefstr - call write_log(logstr, 1) - ! - endif - ! - ! Compute simulation time - ! - call time_difference(trefstr,tstartstr,dtsec) ! time difference in seconds between tstart and tref - t0 = dtsec*1.0 ! time difference in seconds between tstop and tstart - call time_difference(trefstr,tstopstr,dtsec) - t1 = dtsec*1.0 ! time difference in seconds between tstop and tstart - tspinup = t0 + tspinup - ! - ! Set constants - g = 9.81 - pi = 3.14159 - gn2 = 9.81*0.02*0.02 ! Only to be used in subgrid - ! - qinf = qinf/(3600*1000) - ! - rotation = rotation*pi/180 - cosrot = cos(rotation) - sinrot = sin(rotation) - ! - area = dx*dy + private + public :: read_sfincs_input + public :: get_keyword, get_keyword_real_array ! - dxy = min(dx, dy) - dxinv = 1.0/dx - dyinv = 1.0/dy + interface get_keyword + module procedure get_keyword_real + module procedure get_keyword_int + module procedure get_keyword_char + module procedure get_keyword_logical + end interface ! - manning2d = .false. - imanning2d = 0 - if (manningfile/='none') then - manning2d = .true. - imanning2d = 1 - endif - ! - ! CRS and Coriolis parameter +contains ! - fcorio = 0.0 + !-----------------------------------------------------------------------------------------------------! ! - if (igeo == 0) then + subroutine read_sfincs_input() + ! + ! Top-level driver: open sfincs.inp, pull every keyword the solver + ! knows about into the appropriate module-level variable, then + ! compute derived flags (CRS / Coriolis, subgrid vs. regular, + ! wavemaker modes, bathtub overrides, advection scheme). + ! + ! Called from: sfincs_initialize (sfincs_lib). + ! + use sfincs_data + use sfincs_date + use sfincs_error + use sfincs_src_structures, only: drnfile, dkbfile + use sfincs_discharges, only: srcfile, disfile, netsrcdisfile + ! + implicit none + ! + integer*8 :: dtsec + logical :: ok + character(len=256) :: wmsigstr + character(len=256) :: advstr + character(len=256) :: removed_input + ! + ok = check_file_exists('sfincs.inp', 'SFINCS input file', .true.) + ! + open(500, file='sfincs.inp') + ! + ! Grid geometry and time window + ! + call get_keyword(500, 'mmax', mmax, 0) ! number of grid cells in m-direction + call get_keyword(500, 'nmax', nmax, 0) ! number of grid cells in n-direction + call get_keyword(500, 'dx', dx, 0.0) ! cell size in m-direction (m) + call get_keyword(500, 'dy', dy, 0.0) ! cell size in n-direction (m) + call get_keyword(500, 'x0', x0, 0.0) ! grid origin x (m or deg) + call get_keyword(500, 'y0', y0, 0.0) ! grid origin y (m or deg) + call get_keyword(500, 'rotation', rotation, 0.0) ! grid rotation (deg, counter-clockwise from east) + call get_keyword(500, 'tref', trefstr, 'none') ! reference time (yyyymmdd HHMMSS); defaults to tstart + call get_keyword(500, 'tstart', tstartstr, '20000101 000000') ! simulation start time + call get_keyword(500, 'tstop', tstopstr, '20000101 000000') ! simulation stop time + call get_keyword(500, 'tspinup', tspinup, 0.0) ! spin-up interval after t0 (s) + call get_keyword(500, 't0out', t0out, -999.0) ! output start time (s rel. tref); -999 = t0 + call get_keyword(500, 't1out', t1out, -999.0) ! output stop time (s rel. tref); -999 = t1 + call get_keyword(500, 'dtmapout', dtmapout, 0.0, ['dtout']) ! map output interval (s); 0 = no map output + call get_keyword(500, 'dtmaxout', dtmaxout, 9999999.0) ! zsmax etc. interval (s); 0 = end-of-run only + call get_keyword(500, 'dtrstout', dtrstout, 0.0) ! restart interval (s); 0 = no periodic restart + call get_keyword(500, 'trstout', trst, -999.0) ! single restart time (s rel. tref); -999 = unused + call get_keyword(500, 'dthisout', dthisout, 600.0) ! his output interval (s) + call get_keyword(500, 'dtwave', dtwave, 3600.0) ! SnapWave update interval (s) + call get_keyword(500, 'dtwnd', dtwindupd, 1800.0) ! 2D meteo update interval (s) + ! + ! Solver and physical constants + ! + call get_keyword(500, 'alpha', alfa, 0.50) ! CFL Courant factor + call get_keyword(500, 'theta', theta, 1.0) ! semi-implicit theta; <1 adds smoothing + call get_keyword(500, 'hmin_cfl', hmin_cfl, 0.1) ! minimum depth used in CFL check (m) + call get_keyword(500, 'manning', manning, 0.04) ! uniform Manning n (s/m^(1/3)) + call get_keyword(500, 'manning_land', manning_land, -999.0) ! Manning n above rghlevland (s/m^(1/3)) + call get_keyword(500, 'manning_sea', manning_sea, -999.0) ! Manning n below rghlevland (s/m^(1/3)) + call get_keyword(500, 'rgh_lev_land', rghlevland, 0.0) ! bed level separating land/sea friction (m) + call get_keyword(500, 'zsini', zini, 0.0) ! initial water level (m) + call get_keyword(500, 'qinf', qinf, 0.0) ! uniform infiltration rate (mm/hr); converted below + call get_keyword(500, 'dtmax', dtmax, 60.0) ! upper bound on computational dt (s) + call get_keyword(500, 'huthresh', huthresh, 0.05) ! wet/dry depth threshold (m) + call get_keyword(500, 'huvmin', huvmin, 0.0) ! minimum depth for uv = q / max(hu, huvmin) + call get_keyword(500, 'rhoa', rhoa, 1.25) ! air density (kg/m3) + call get_keyword(500, 'rhow', rhow, 1024.0) ! water density (kg/m3) + call get_keyword(500, 'inputformat', inputtype, 'bin') ! legacy bin/asc toggle for binary inputs + call get_keyword(500, 'outputformat', outputtype, 'net') ! global output format (bin/asc/net) + call get_keyword(500, 'outputtype_map', outputtype_map, 'nil') ! map-file output format (nil = follow outputformat) + call get_keyword(500, 'outputtype_his', outputtype_his, 'nil') ! his-file output format (nil = follow outputformat) + call get_keyword(500, 'nc_deflate_level', nc_deflate_level, 2) ! netCDF deflate level (0-9) + call get_keyword(500, 'bndtype', bndtype, 1) ! boundary condition type + call get_keyword(500, 'advection', advection, .true.) ! enable momentum advection terms + call get_keyword(500, 'latitude', latitude, 0.0) ! reference latitude for projected Coriolis (deg) + call get_keyword(500, 'pavbnd', pavbnd, 0.0) ! atmospheric pressure applied at boundary (Pa) + call get_keyword(500, 'gapres', gapres, 101200.0) ! atmospheric reference pressure (Pa) + call get_keyword(500, 'baro', baro, 1) ! include atmospheric-pressure gradient (1=on, 0=off) + call get_keyword(500, 'utmzone', utmzone, 'nil') ! UTM zone string (e.g. '17N') + call get_keyword(500, 'epsg', epsg, 0) ! EPSG integer code for the grid + call get_keyword(500, 'epsg', epsg_code, 'nil') ! EPSG as string (fallback) + call get_keyword(500, 'advlim', advlim, 1.0) ! cap on advection term + call get_keyword(500, 'slopelim', slopelim, 9999.9) ! cap on bed-slope water-level gradient + call get_keyword(500, 'qinf_zmin', qinf_zmin, 0.0) ! minimum bed level for infiltration to apply (m) + call get_keyword(500, 'btfilter', btfilter, 60.0) ! bathtub filter time scale (s) + call get_keyword(500, 'sfacinf', sfacinf, 0.2) ! SCS initial-abstraction fraction (0.2S) + call get_keyword(500, 'radstr', radstr, .false.) ! radiation-stress forcing from SnapWave + call get_keyword(500, 'crsgeo', crsgeo, .false.) ! interpret grid coords as geographic (WGS84) + call get_keyword(500, 'coriolis', coriolis, .true.) ! include Coriolis force + call get_keyword(500, 'amprblock', ampr_block, .true.) ! treat 2D rainfall as block (true) or linearly interpolated (false) + call get_keyword(500, 'spwmergefrac', spw_merge_frac, 0.5) ! merge factor for spiderweb wind composite + call get_keyword(500, 'usespwprecip', use_spw_precip, .true.) ! use precipitation field from spiderweb file + call get_keyword(500, 'global', global, .false.) ! treat grid as global (wrap in x) + call get_keyword(500, 'nuvisc', nuviscdim, 0.01) ! viscosity coefficient (m2/s) + call get_keyword(500, 'viscosity', viscosity, .false.) ! enable horizontal viscosity term + call get_keyword(500, 'spinup_meteo', spinup_meteo, .false.) ! ramp wind/pressure from zero during tspinup + call get_keyword(500, 'waveage', waveage, -999.0) ! wave age (for SnapWave wind growth) + call get_keyword(500, 'snapwave', snapwave, .false.) ! enable coupled SnapWave wave solver + call get_keyword(500, 'dtoutfixed', fixed_output_intervals, .true.) ! snap map/his to exact intervals (true) or let them drift with dt (false) + ! + ! Wave maker parameters + ! + call get_keyword(500, 'wavemaker_wvmfile', wavemaker_wvmfile, 'none', ['wvmfile']) ! wavemaker polyline file + call get_keyword(500, 'wavemaker_wfpfile', wavemaker_wfpfile, 'none', ['wfpfile']) ! wavemaker forcing points file + call get_keyword(500, 'wavemaker_whifile', wavemaker_whifile, 'none', ['whifile']) ! wavemaker wave-height time series file + call get_keyword(500, 'wavemaker_wtifile', wavemaker_wtifile, 'none', ['wtifile']) ! wavemaker wave-period time series file + call get_keyword(500, 'wavemaker_wstfile', wavemaker_wstfile, 'none', ['wstfile']) ! wavemaker wave set-up time series file + call get_keyword(500, 'wavemaker_filter_time', wavemaker_filter_time, 600.0, ['wmtfilter']) ! wavemaker filter time scale (s) + call get_keyword(500, 'wavemaker_filter_fred', wavemaker_filter_fred, 0.99, ['wmfred']) ! wavemaker filter fred + call get_keyword(500, 'wavemaker_signal', wmsigstr, 'spectrum',['wmsignal']) ! wavemaker signal type (spectrum or monochromatic) + call get_keyword(500, 'wavemaker_hmin', wavemaker_hmin, 0.1, ['wmhmin']) ! wavemaker minimum depth for wave generation (m) + call get_keyword(500, 'wavemaker_nfreqs_inc', wavemaker_nfreqs_inc, 100, ['nfreqsinc']) ! wavemaker number of incident-wave frequencies + call get_keyword(500, 'wavemaker_freqmin_inc', wavemaker_freqmin_inc, 0.04, ['freqmininc']) ! wavemaker incident-wave min frequency (Hz) + call get_keyword(500, 'wavemaker_freqmax_inc', wavemaker_freqmax_inc, 1.0, ['freqmaxinc']) ! wavemaker incident-wave max frequency (Hz) + call get_keyword(500, 'wavemaker_nfreqs_ig', wavemaker_nfreqs_ig, 100, ['nfreqsig']) ! wavemaker number of IG-wave frequencies + call get_keyword(500, 'wavemaker_freqmin_ig', wavemaker_freqmin_ig, 0.0, ['freqminig']) ! wavemaker IG-wave min frequency (Hz) + call get_keyword(500, 'wavemaker_freqmax_ig', wavemaker_freqmax_ig, 0.1, ['freqmaxig']) ! wavemaker IG-wave max frequency (Hz) + call get_keyword(500, 'wavemaker_tinc2ig', wavemaker_tinc2ig, -1.0) ! wavemaker ig/inc period ratio (<=0 uses Herbers) + call get_keyword(500, 'wavemaker_surfslope', wavemaker_surfslope, -1.0) ! wavemaker surf-zone slope for empirical Tp_ig (van Ormondt et al., 2021) + call get_keyword(500, 'wavemaker_hm0_ig_factor', wavemaker_hm0_ig_factor, 1.0) ! wavemaker IG Hm0 scaling factor + call get_keyword(500, 'wavemaker_hm0_inc_factor', wavemaker_hm0_inc_factor, 1.0) ! wavemaker incident Hm0 scaling factor + call get_keyword(500, 'wavemaker_gammax', wavemaker_gammax, 1.0) ! wavemaker maximum Hrms/h + call get_keyword(500, 'wavemaker_tpmin', wavemaker_tpmin, 1.0) ! wavemaker minimum Tp (s) + call get_keyword(500, 'wavemaker_hig', wavemaker_hig, .true.) ! wavemaker include IG waves + call get_keyword(500, 'wavemaker_hinc', wavemaker_hinc, .false.) ! wavemaker include incident waves + ! + ! Numerical parameters + ! + call get_keyword(500, 'advection_scheme', advstr, 'upw1') ! advection scheme label ('upw1' = 1st-order upwind, 'original' = legacy) + call get_keyword(500, 'btrelax', btrelax, 3600.0) ! bathtub relaxation time (s) + call get_keyword(500, 'wiggle_suppression', wiggle_suppression, .true.) ! suppress spurious free-surface oscillations + call get_keyword(500, 'structure_relax', structure_relax, 4.0) ! drainage-structure state-machine smoothing steps + call get_keyword(500, 'wiggle_factor', wiggle_factor, 0.1) ! wiggle-suppression amplitude factor + call get_keyword(500, 'wiggle_threshold', wiggle_threshold, 0.1) ! wiggle-suppression trigger threshold + call get_keyword(500, 'uvlim', uvlim, 10.0) ! clipping velocity for momentum (m/s) + call get_keyword(500, 'uvmax', uvmax, 1000.0) ! error-trigger velocity for momentum (m/s) + call get_keyword(500, 'friction2d', friction2d, .true.) ! apply friction at every UV point (true) or cell-wise (false) + call get_keyword(500, 'advection_mask', advection_mask, .true.) ! mask advection near dry cells + call get_keyword(500, 'nuviscfac', nuviscfac, 100.0) ! multiplier on nuvisc near "difficult" points + call get_keyword(500, 'nonh', nonhydrostatic, .false.) ! enable non-hydrostatic pressure corrector + call get_keyword(500, 'nh_fnudge', nh_fnudge, 0.9) ! non-hydrostatic nudging factor + call get_keyword(500, 'nh_tstop', nh_tstop, -999.0) ! non-hydrostatic stop time (s rel. tref); -999 = t1+999 + call get_keyword(500, 'nh_tol', nh_tol, 0.001) ! non-hydrostatic solver tolerance + call get_keyword(500, 'nh_itermax', nh_itermax, 100) ! non-hydrostatic solver max iterations + call get_keyword(500, 'h73table', h73table, .false.) ! tabulate h^(7/3) for friction + call get_keyword(500, 'rugdepth', runup_gauge_depth, 0.05) ! runup gauge trigger depth (m) + call get_keyword(500, 'wave_enhanced_roughness', wave_enhanced_roughness, .false.) ! augment bed roughness with wave orbital velocity + call get_keyword(500, 'use_bcafile', use_bcafile, .true.) ! use tidal components from bca file + call get_keyword(500, 'factor_wind', factor_wind, 1.0) ! scaling factor on wind forcing + call get_keyword(500, 'factor_pres', factor_pres, 1.0) ! scaling factor on atmospheric pressure + call get_keyword(500, 'factor_prcp', factor_prcp, 1.0) ! scaling factor on precipitation + call get_keyword(500, 'factor_spw_size', factor_spw_size, 1.0) ! scaling factor on spiderweb radius + call get_keyword(500, 'bathtub', bathtub, .false.) ! run in bathtub (no momentum) mode + call get_keyword(500, 'bathtub_fachs', bathtub_fac_hs, 0.2) ! bathtub Hs multiplier + call get_keyword(500, 'bathtub_dt', bathtub_dt, -999.0) ! bathtub time step (s); -999 = use dtmapout + ! + ! Domain files + ! + call get_keyword(500, 'qtrfile', qtrfile, 'none') ! quadtree netCDF file + call get_keyword(500, 'depfile', depfile, 'none') ! bed-level (depth) file + call get_keyword(500, 'inifile', zsinifile, 'none') ! initial water-level file + call get_keyword(500, 'rstfile', rstfile, 'none') ! restart input file + call get_keyword(500, 'mskfile', mskfile, 'none') ! active-cell mask file + call get_keyword(500, 'indexfile', indexfile, 'none') ! index-to-active-cell mapping file + call get_keyword(500, 'cstfile', cstfile, 'none') ! coastline polyline file + call get_keyword(500, 'sbgfile', sbgfile, 'none') ! subgrid tables netCDF file + call get_keyword(500, 'thdfile', thdfile, 'none') ! thin dams polyline file + call get_keyword(500, 'weirfile', weirfile, 'none') ! weirs polyline file + call get_keyword(500, 'manningfile', manningfile, 'none') ! spatially-varying Manning n file + call get_keyword(500, 'drnfile', drnfile, 'none') ! drainage-structures (pumps/gates/culverts) TOML file + call get_keyword(500, 'dkbfile', dkbfile, 'none') ! dike breach structures TOML file + call get_keyword(500, 'urbfile', urbfile, 'none') ! urban drainage zones TOML file + call get_keyword(500, 'volfile', volfile, 'none') ! depression-storage volume file + ! + ! Forcing files (ascii / binary) + ! + call get_keyword(500, 'bndfile', bndfile, 'none') ! water-level boundary points + call get_keyword(500, 'bzsfile', bzsfile, 'none') ! water-level boundary time series + call get_keyword(500, 'bcafile', bcafile, 'none') ! tidal components per boundary point + call get_keyword(500, 'bzifile', bzifile, 'none') ! IG wave boundary time series + call get_keyword(500, 'bdrfile', bdrfile, 'none') ! downstream river boundary file + call get_keyword(500, 'srcfile', srcfile, 'none') ! river-point source locations + call get_keyword(500, 'disfile', disfile, 'none') ! river-point discharge time series + call get_keyword(500, 'spwfile', spwfile, 'none') ! spiderweb tropical-cyclone file + call get_keyword(500, 'wndfile', wndfile, 'none') ! uniform wind time series + call get_keyword(500, 'prcfile', prcpfile, 'none', ['precipfile']) ! uniform precipitation time series + call get_keyword(500, 'amufile', amufile, 'none') ! 2D wind u-component file + call get_keyword(500, 'amvfile', amvfile, 'none') ! 2D wind v-component file + call get_keyword(500, 'ampfile', ampfile, 'none') ! 2D atmospheric pressure file + call get_keyword(500, 'amrfile', amprfile, 'none', ['amprfile']) ! 2D precipitation rate file + call get_keyword(500, 'z0lfile', z0lfile, 'none') ! 2D land roughness (z0) file + ! + ! NetCDF-format forcing files (FEWS-style) + ! + call get_keyword(500, 'netbndbzsbzifile', netbndbzsbzifile, 'none') ! combined bnd/bzs/bzi netCDF file + call get_keyword(500, 'netsrcdisfile', netsrcdisfile, 'none') ! combined src/dis netCDF file + call get_keyword(500, 'netamuamvfile', netamuamvfile, 'none') ! combined amu/amv netCDF file + call get_keyword(500, 'netamprfile', netamprfile, 'none') ! 2D precipitation netCDF file + call get_keyword(500, 'netampfile', netampfile, 'none') ! 2D pressure netCDF file + call get_keyword(500, 'netspwfile', netspwfile, 'none') ! netCDF spiderweb file + ! + ! Infiltration and losses + ! + call get_keyword(500, 'infiltrationfile', infiltrationfile, 'none') ! infiltration parameters TOML file + call get_keyword(500, 'infiltrationtype', inftype, 'none') ! infiltration flavor (con, c2d, cna, cnb, gai, hor, bkt) + ! + ! Legacy binary infiltration inputs (kept for backward compatibility). + ! + call get_keyword(500, 'qinffile', qinffile, 'none') ! binary spatially-varying infiltration field + call get_keyword(500, 'scsfile', scsfile, 'none') ! SCS curve-number S field (legacy binary) + call get_keyword(500, 'smaxfile', smaxfile, 'none') ! SCS max storage S field (legacy binary) + call get_keyword(500, 'sefffile', sefffile, 'none') ! SCS effective storage S_e field (legacy binary) + call get_keyword(500, 'psifile', psifile, 'none') ! Green-Ampt suction head (legacy binary, mm) + call get_keyword(500, 'sigmafile', sigmafile, 'none') ! Green-Ampt maximum moisture deficit (legacy binary) + call get_keyword(500, 'ksfile', ksfile, 'none') ! Green-Ampt saturated hydraulic conductivity (legacy binary, mm/hr) + call get_keyword(500, 'f0file', f0file, 'none') ! Horton initial infiltration capacity F0 (legacy binary) + call get_keyword(500, 'fcfile', fcfile, 'none') ! Horton asymptotic infiltration rate Fc (legacy binary) + call get_keyword(500, 'kdfile', kdfile, 'none') ! Horton decay constant k (legacy binary, 1/hr) + call get_keyword(500, 'horton_kr_kd', horton_kr_kd, 10.0) ! Horton recovery/decay ratio + ! + ! Output + ! + call get_keyword(500, 'obsfile', obsfile, 'none') ! observation-point locations file + call get_keyword(500, 'crsfile', crsfile, 'none') ! cross-section polyline file + call get_keyword(500, 'rugfile', rugfile, 'none') ! runup-gauge locations file + call get_keyword(500, 'store_maximum_waterlevel', store_maximum_waterlevel, .true.) ! store maximum water level on dtmaxout interval (only if dtmaxout > 0) + call get_keyword(500, 'storevelmax', store_maximum_velocity, .false.) ! store maximum flow velocity on dtmaxout interval (only if dtmaxout > 0) + call get_keyword(500, 'storefluxmax', store_maximum_flux, .false.) ! store maximum flux on dtmaxout interval (only if dtmaxout > 0) + call get_keyword(500, 'storevel', store_velocity, .false.) ! store velocity on dtout interval + call get_keyword(500, 'storecumprcp', store_cumulative_precipitation, .false.) ! store cumulative precipitation + infiltration on dtmaxout interval + call get_keyword(500, 'storetwet', store_twet, .false.) ! store per-cell wet duration + call get_keyword(500, 'storetzsmax', store_t_zsmax, .false.) ! store time stamp of zsmax occurrence + call get_keyword(500, 'storehsubgrid', store_hsubgrid, .false.) ! store hmax in subgrid mode (zsmax - subgrid_z_zmin) + call get_keyword(500, 'storehmean', store_hmean, .false.) ! store hmax as subgrid-mean depth instead of max (requires storehsubgrid) + call get_keyword(500, 'twet_threshold', twet_threshold, 0.01) ! water-depth threshold counting a cell as wet (storetwet) + call get_keyword(500, 'store_tsunami_arrival_time', store_tsunami_arrival_time, .false.) ! store tsunami arrival time per cell + call get_keyword(500, 'tsunami_arrival_threshold', tsunami_arrival_threshold, 0.01) ! water-depth threshold for tsunami arrival + call get_keyword(500, 'timestep_analysis', timestep_analysis, .false.) ! write per-cell timestep limiter diagnostics + call get_keyword(500, 'storeqdrain', store_qdrain, .true.) ! store per-drainage-structure discharge in his file + call get_keyword(500, 'store_river_discharge', store_river_discharge, .false.) ! store per-river-point discharge in his file + call get_keyword(500, 'store_urban_drainage_discharge', store_urban_drainage_discharge, .false.) ! store per-urban-zone outfall discharge in his file + call get_keyword(500, 'store_cumulative_urban_drainage', store_cumulative_urban_drainage, .false.) ! store cumulative urban drainage depth per cell in map file + call get_keyword(500, 'storezvolume', store_zvolume, .false.) ! store subgrid cell volume (requires subgrid) + call get_keyword(500, 'storestoragevolume', store_storagevolume, .false.) ! store remaining storage volume (requires subgrid + volfile) + call get_keyword(500, 'writeruntime', write_time_output, .false.) ! write runtimes.txt at end of simulation + call get_keyword(500, 'debug', debug, .false.) ! debug output at every time step + call get_keyword(500, 'storemeteo', store_meteo, .false.) ! store 2D meteo forcing fields in map file + call get_keyword(500, 'storemaxwind', store_wind_max, .false.) ! store maximum wind speed (requires storemeteo) + call get_keyword(500, 'storefw', store_wave_forces, .false.) ! store wave-radiation forces + call get_keyword(500, 'storewavdir', store_wave_direction, .false.) ! store wave direction + call get_keyword(500, 'output_on_quadtree_mesh', use_quadtree_output, .false., ['regular_output_on_mesh']) ! write quadtree output to quadtree mesh (only relevant for regular meshed grids) + call get_keyword(500, 'store_dynamic_bed_level', store_dynamic_bed_level, .false.) ! store time-varying bed level (subgrid) + call get_keyword(500, 'snapwave_use_nearest', snapwave_use_nearest, .true.) ! use nearest-neighbour lookup for SnapWave boundary points + call get_keyword(500, 'percentage_done', percdoneval, 5) ! progress-reporter interval (% complete) ! - ! Projected (default with coriolis, unless latitude is 0.0) + ! Coupled SnapWave solver parameters ! - crsgeo = .false. - fcorio = 2 * 7.2921e-05 * sin(latitude * pi / 180) + call get_keyword(500, 'snapwave_wind', snapwavewind, .false.) ! feed wind into SnapWave (implies storing wind speed/direction) + call get_keyword(500, 'snapwave_waveforces_ratio', waveforces_ratio, 1.0, ['snapwave_waveforces_factor']) ! multiplier on SnapWave wave forces + call get_keyword(500, 'snapwave_vegetation', snapwave_vegetation, .false.) ! enable vegetation dissipation in SnapWave ! - if (latitude < 0.01 .and. latitude > -0.01) then + ! Vegetation + ! + call get_keyword(500, 'vegetation', vegetation, .false.) ! enable vegetation drag in SFINCS + call get_keyword(500, 'vegetationfile', veggiefile, 'none') ! vegetation characteristics file + call get_keyword(500, 'vegetationtype_toml', veggietype_toml, 'none') ! companion TOML lookup table; if set, vegetationfile holds only vegetation_type integers + ! + ! Vegetation can be used in SnapWave and/or SFINCS calculations + ! + store_vegetation = (vegetation .or. snapwave_vegetation) + ! + ! Wind drag coefficient table + ! + call get_keyword(500, 'cdnrb', cd_nr, 0) ! number of wind-drag breakpoints (0 = use defaults) + ! + if (cd_nr == 0) then + ! + ! Standard Smith & Banke-style Cd curve: constant at low wind, + ! linear rise, then plateau at high wind. + ! + cd_nr = 3 + ! + allocate(cd_wnd(cd_nr)) + allocate(cd_val(cd_nr)) + ! + cd_wnd(1) = 0.0 + cd_wnd(2) = 28.0 + cd_wnd(3) = 50.0 + cd_val(1) = 0.0010 + cd_val(2) = 0.0025 + cd_val(3) = 0.0025 + ! + else + ! + call get_keyword_real_array(500, 'cdwnd', cd_wnd, 0.0, cd_nr) + call get_keyword_real_array(500, 'cdval', cd_val, 0.0, cd_nr) + ! + endif + ! + close(500) + ! + ! Done with reading input + ! + ! Now do some post-processing and consistency checks on the inputs, and emit + ! + ! Limit progress reporter to (0, 100]% + ! + percdoneval = max(min(percdoneval, 100), 0) + ! + if (epsg == 0) then + ! + call write_log('Warning : no EPSG code defined', 0) ! - ! No Coriolis force - ! - coriolis = .false. - ! endif ! - else - ! - ! Geographic (default included coriolis, unless coriolis is turned off in input file) - ! fcorio2d will be determined in sfincs_domain.f90 - ! - crsgeo = .true. - ! - endif - ! - if (crsgeo) then - call write_log('Info : input grid interpreted as geographic coordinates', 0) - else - call write_log('Info : input grid interpreted as projected coordinates', 0) - endif - ! - if (coriolis) then - call write_log('Info : turning on Coriolis', 0) - else - call write_log('Info : turning off Coriolis', 0) - endif - ! - if (.not. crsgeo .AND. .NOT. coriolis) then - call write_log('Info : no Coriolis, as latitude is not specified in sfincs.inp', 0) - endif - ! - ! Output - ! - if (t0out<-900.0) then - t0out = t0 - endif - t0out = max(t0out, t0) - if (t1out<-900.0) then - t1out = t1 - endif - ! - store_maximum_waterlevel = .false. - if (dtmaxout>0.0) then - store_maximum_waterlevel = .true. - endif - ! - store_maximum_velocity = .false. - if (storevelmax==1 .and. dtmaxout>0.0) then - store_maximum_velocity = .true. - endif - ! - store_maximum_flux = .false. - if (storefluxmax==1 .and. dtmaxout>0.0) then - store_maximum_flux = .true. - endif - ! - store_velocity = .false. - if (storevel==1) then - store_velocity = .true. - endif - ! - store_meteo = .false. - store_wind = .false. - store_wind_max = .false. - if (storemeteo==1) then - store_meteo = .true. - store_wind = .true. - if (iwindmax==1) then - store_wind_max = .true. + ! If tref not provided, assume tref = tstart. + ! + if (trefstr(1:4) == 'none') then + ! + trefstr = tstartstr + ! + write(logstr, *) 'Warning : no tref provided, set to tstart: ', trefstr + call write_log(logstr, 1) + ! endif - endif - ! - snapwave = .false. - snapwavewind = .false. - if (isnapwave==1) then - snapwave = .true. - ! - if (iwind==1) then - store_wind = .true. - snapwavewind = .true. - ! For running SnapWave with wind growth, we need to store the wind speed & direction to be able to pass it from SFINCS to SnapWave. - ! Independent from wndfile or 2D meteo input, handled by store_wind. - endif - endif - ! - store_vegetation = .false. - if (vegetation .or. snapwave_vegetation) then - ! - store_vegetation = .true. - ! vegetation can be used in SnapWave and/or SFINCS calculations - ! - endif - ! - store_twet = .false. - if (storetwet==1) then - store_twet = .true. - endif - ! - store_t_zsmax = .false. - if (storetzsmax==1) then - store_t_zsmax = .true. - endif - ! - store_cumulative_precipitation = .false. - if (storecumprcp==1) then - store_cumulative_precipitation = .true. - endif - ! - if (storeqdrain==0) then - store_qdrain = .false. - else - store_qdrain = .true. - endif - ! - write_time_output = .false. - if (wrttimeoutput==1) then - write_time_output = .true. - endif - ! - radstr = .false. - if (iradstr==1) then - radstr = .true. - endif - ! - if ((outputtype_map == 'nil') .OR. (outputtype_his == 'nil')) then - outputtype_map = outputtype - outputtype_his = outputtype - endif - ! - ampr_block = .true. ! Default use data in ampr file as block rather than linear interpolation - if (iamprblock==0) then - ampr_block = .false. - endif - ! - global = .false. ! Default use data in ampr file as block rather than linear interpolation - if (iglobal==1) then - global = .true. - endif - ! - if (sbgfile(1:4) /= 'none') then - ! - subgrid = .true. - isubgrid = 1 - call write_log('Info : running SFINCS with subgrid bathymetry', 0) - ! - else - ! - subgrid = .false. - isubgrid = 0 - call write_log('Info : running SFINCS with regular bathymetry', 0) - ! - endif - ! - ! - store_hsubgrid = .false. - if (storehsubgrid==1) then - store_hsubgrid = .true. - endif - ! - if (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .false.) then - ! - call write_log('Info : storing maximum depth in subgrid cell for hmax output', 0) - ! - elseif (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .true.) then - ! - call write_log('Info : storing mean depth in subgrid cell for hmax output', 0) - ! - endif - ! - store_zvolume = .false. - ! - if (subgrid) then - if (storezvolume==1) then - store_zvolume = .true. - endif - endif - ! - store_tsunami_arrival_time = .false. - if (itsunamitime==1) then - store_tsunami_arrival_time = .true. - endif - ! - viscosity = .false. - if (iviscosity) then - viscosity = .true. - call write_log('Info : turning on process: Viscosity', 0) - endif - ! - spinup_meteo = .true. - if (ispinupmeteo==0) then - spinup_meteo = .false. - endif - ! - use_spw_precip = .true. - if (ispwprecip==0) then - use_spw_precip = .false. - endif - ! - fixed_output_intervals = .true. - if (ioutfixed==0) then - fixed_output_intervals = .false. - endif - ! - advection = .false. - if (iadvection>0) then - advection = .true. - endif - ! - thetasmoothing = .false. - if (theta<0.9999) then ! Note, for reliability in terms of precision, is written as 0.9999 - thetasmoothing = .true. - endif - ! - store_wave_forces = .false. - if (istorefw==1) then - store_wave_forces = .true. - endif - ! - wavemaker = .false. - wavemaker_spectrum = .true. - ! - if (wavemaker_wvmfile(1:4) /= 'none') then ! - wavemaker = .true. - iwavemaker = 1 + ! Compute simulation time span in seconds, relative to tref. + ! + call time_difference(trefstr, tstartstr, dtsec) + t0 = dtsec * 1.0 + call time_difference(trefstr, tstopstr, dtsec) + t1 = dtsec * 1.0 + tspinup = t0 + tspinup + ! + g = 9.81 + pi = 3.14159 + gn2 = 9.81 * 0.02 * 0.02 ! only used in subgrid mode + ! + qinf = qinf / (3600 * 1000) ! mm/hr -> m/s + ! + rotation = rotation * pi / 180 + cosrot = cos(rotation) + sinrot = sin(rotation) + ! + area = dx * dy + dxy = min(dx, dy) + dxinv = 1.0 / dx + dyinv = 1.0 / dy ! - call write_log('Info : turning on process: Dynamic waves', 0) + manning2d = .false. + if (manningfile /= 'none') manning2d = .true. ! - if (wmsigstr(1:3) == 'mon') then - ! - ! Monochromatic - ! - wavemaker_spectrum = .false. + ! CRS and Coriolis parameter + ! + fcorio = 0.0 + ! + if (.not. crsgeo) then ! - call write_log('Info : use monochromatic wave spectrum', 0) + ! Projected: compute fcorio from latitude; zero it out at the + ! equator or if the user did not set a latitude at all. ! - endif - endif - ! - store_wave_direction = .false. - if (istorewavdir==1) then - store_wave_direction = .true. - endif - ! - use_storage_volume = .false. - store_storagevolume = .false. - ! - if (volfile(1:4) /= 'none') then - if (subgrid) then - use_storage_volume = .true. + fcorio = 2 * 7.2921e-05 * sin(latitude * pi / 180) + ! + if (latitude < 0.01 .and. latitude > -0.01) coriolis = .false. ! - if (storestoragevolume==1) then - store_storagevolume = .true. - endif - ! else - call write_log('Warning : storage volume only supported for subgrid topographies!', 1) + ! + ! Geographic: fcorio2d is filled in later by sfincs_domain. + ! endif - endif - ! - if (advection) then ! - ! Make 1st order upwind the default scheme - ! - advection_scheme = 1 + if (crsgeo) then + call write_log('Info : input grid interpreted as geographic coordinates', 0) + else + call write_log('Info : input grid interpreted as projected coordinates', 0) + endif ! - call write_log('Info : turning on advection', 0) - ! - if (trim(advstr) == 'original') then - advection_scheme = 0 - call write_log('Info : advection scheme : Original', 0) - elseif (trim(advstr) == 'upw1') then - advection_scheme = 1 - call write_log('Info : advection scheme : first-order upwind', 0) + if (.not. crsgeo .and. .not. coriolis) then + call write_log('Info : no Coriolis, as latitude is not specified in sfincs.inp', 0) + endif + ! + ! Map/his output window: default to tstart..tstop. + ! + if (t0out < -900.0) t0out = t0 + t0out = max(t0out, t0) + if (t1out < -900.0) t1out = t1 + ! + if (dtmaxout > 0.0) store_maximum_waterlevel = .true. + ! + ! Apply gates to the flags now that the full set of inputs has been read. + ! + if (dtmaxout <= 0.0) then + ! + ! Are there more to be added here? + ! + store_maximum_waterlevel = .false. + store_maximum_velocity = .false. + store_maximum_flux = .false. + ! + endif + ! + ! storemeteo implies store_wind (SFINCS needs 2D wind to feed the + ! meteo map output); storemaxwind is only meaningful if we are + ! storing the wind in the first place. + ! + if (store_meteo) store_wind = .true. + if (.not. store_wind) store_wind_max = .false. + ! + ! SnapWave with wind-growth needs wind stored and a dedicated + ! snapwavewind flag; snapwavewind is ignored when SnapWave is off. + ! + if (.not. snapwave) snapwavewind = .false. + if (snapwavewind) store_wind = .true. + ! + ! Map/his format fallback: inherit the global outputformat when either + ! per-file format was left at 'nil'. + ! + if ((outputtype_map == 'nil') .or. (outputtype_his == 'nil')) then + outputtype_map = outputtype + outputtype_his = outputtype + endif + ! + if (sbgfile(1:4) /= 'none') then + ! + subgrid = .true. + ! else - write(logstr,*)'Warning : advection scheme ', trim(advstr), ' not recognized! Using default upw1 instead!' - call write_log(logstr, 1) + ! + subgrid = .false. + ! endif ! - endif - ! - if (nonhydrostatic) then + if (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .false.) then + ! + call write_log('Info : storing maximum depth in subgrid cell for hmax output', 0) + ! + elseif (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .true.) then + ! + call write_log('Info : storing mean depth in subgrid cell for hmax output', 0) + ! + endif + ! + ! store_zvolume / store_storagevolume are subgrid-only. + ! + if (.not. subgrid) store_zvolume = .false. + ! + thetasmoothing = .false. + if (theta < 0.9999) thetasmoothing = .true. ! use 0.9999 instead of 1.0 for numerical robustness ! - if (nh_tstop > 0.0) then + wavemaker = .false. + wavemaker_spectrum = .true. + ! + if (wavemaker_wvmfile(1:4) /= 'none') then ! - ! tstopnonh is provided so set it with respect to model reference time + wavemaker = .true. ! - nh_tstop = t0 + nh_tstop + if (wmsigstr(1:3) == 'mon') then + ! + wavemaker_spectrum = .false. + ! + call write_log('Info : use monochromatic wave spectrum for wave makers', 0) + ! + endif ! + endif + ! + use_storage_volume = .false. + ! + if (volfile(1:4) /= 'none') then + if (subgrid) then + use_storage_volume = .true. + else + call write_log('Warning : storage volume only supported for subgrid topographies!', 1) + store_storagevolume = .false. + endif else + store_storagevolume = .false. + endif + ! + if (advection) then + ! + ! Default scheme is 1st-order upwind; 'original' keeps the legacy form. + ! + advection_scheme = 1 ! - ! tstopnonh is not provided so set it to tstop time + 999.0 s + if (trim(advstr) == 'original') then + advection_scheme = 0 + call write_log('Info : advection scheme : Original', 0) + elseif (trim(advstr) == 'upw1') then + advection_scheme = 1 + call write_log('Info : advection scheme : first-order upwind', 0) + else + write(logstr, *) 'Warning : advection scheme ', trim(advstr), ' not recognized! Using default upw1 instead!' + call write_log(logstr, 1) + endif ! - nh_tstop = t1 + 999.0 - ! - endif + endif ! - endif + if (nonhydrostatic) then + ! + if (nh_tstop > 0.0) then + nh_tstop = t0 + nh_tstop + else + nh_tstop = t1 + 999.0 + endif + ! + endif + ! + if (bathtub) then + ! + call write_log('Info : turning on process: Bathtub flooding', 0) + ! + ! Time step defaults to dtmapout when the user does not set it. + ! + if (bathtub_dt < 0.0) bathtub_dt = dtmapout + ! + dthisout = bathtub_dt + ! + ! Turn off processes not needed for bathtub flooding. Forcing the + ! input file paths to 'none' makes each initialize_* routine take + ! its standard early-return path; that way the counters + ! (nr_discharge_points, nr_src_structures, nr_urban_drainage_zones) + ! and derived logicals (discharges, drainage_structures, + ! urban_drainage) stay consistent with the "no input" state. + ! + srcfile = 'none' + disfile = 'none' + netsrcdisfile = 'none' + drnfile = 'none' + dkbfile = 'none' + urbfile = 'none' + ! + meteo3d = .false. + wind = .false. + store_meteo = .false. + store_wind = .false. + store_wind_max = .false. + precip = .false. + patmos = .false. + if (snapwave) bathtub_snapwave = .true. + snapwave = .false. + infiltration = .false. + store_velocity = .false. + store_maximum_velocity = .false. + ! + endif + ! + end subroutine ! - if (bathtub) then + !-----------------------------------------------------------------------------------------------------! + ! + subroutine get_keyword_real(fileid, keyword, value, default, legacy) + ! + ! Read one real*4 keyword. Tries `keyword` first; if absent, walks + ! the optional `legacy` list of deprecated aliases and emits a + ! one-line deprecation warning per matched alias. Falls back to + ! `default` when nothing matches. + ! + ! Called from: read_sfincs_input (this module). ! - call write_log('Info : turning on process: Bathtub flooding', 0) + implicit none ! - ! Set time step + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + real*4, intent(out) :: value + real*4, intent(in) :: default + character(len=*), dimension(:), intent(in), optional :: legacy ! - if (bathtub_dt < 0.0) then + character(len=256) :: valstr + logical :: found + integer :: i + ! + call find_value(fileid, keyword, valstr, found) + if (found) then + read(valstr, *) value + return + endif + ! + if (present(legacy)) then ! - ! Time step for simulation not defined so use same as map output + do i = 1, size(legacy) + ! + call find_value(fileid, trim(legacy(i)), valstr, found) + ! + if (found) then + read(valstr, *) value + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo ! - bathtub_dt = dtmapout + endif + ! + value = default + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine get_keyword_int(fileid, keyword, value, default, legacy) + ! + ! Read one integer keyword. See get_keyword_real for the semantics. + ! + ! Called from: read_sfincs_input (this module). + ! + implicit none + ! + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + integer, intent(out) :: value + integer, intent(in) :: default + character(len=*), dimension(:), intent(in), optional :: legacy + ! + character(len=256) :: valstr + logical :: found + integer :: i + ! + call find_value(fileid, keyword, valstr, found) + if (found) then + read(valstr, *) value + return + endif + ! + if (present(legacy)) then + ! + do i = 1, size(legacy) + ! + call find_value(fileid, trim(legacy(i)), valstr, found) + ! + if (found) then + read(valstr, *) value + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo ! endif ! - dthisout = bathtub_dt + value = default + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine get_keyword_char(fileid, keyword, value, default, legacy) + ! + ! Read one character-string keyword. See get_keyword_real for the + ! semantics. The entire right-hand side (after trailing comments + ! are stripped) becomes `value`. + ! + ! Called from: read_sfincs_input (this module). ! - ! Turn off some processes not needed for bathtub flooding + implicit none ! - nsrc = 0 - ndrn = 0 + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + character(*), intent(out) :: value + character(*), intent(in) :: default + character(len=*), dimension(:), intent(in), optional :: legacy ! - meteo3d = .false. - wind = .false. - store_meteo = .false. - store_wind = .false. - store_wind_max = .false. - precip = .false. - patmos = .false. - if (snapwave) then - bathtub_snapwave = .true. + character(len=256) :: valstr + logical :: found + integer :: i + ! + call find_value(fileid, keyword, valstr, found) + if (found) then + value = valstr + return + endif + ! + if (present(legacy)) then + ! + do i = 1, size(legacy) + ! + call find_value(fileid, trim(legacy(i)), valstr, found) + ! + if (found) then + value = valstr + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo + ! endif - snapwave = .false. - infiltration = .false. - store_velocity = .false. - store_maximum_velocity = .false. ! - endif + value = default + ! + end subroutine ! - ! normbnd = sqrt(dzdsbnd) / manningbnd + !-----------------------------------------------------------------------------------------------------! ! + subroutine get_keyword_logical(fileid, keyword, value, default, legacy) + ! + ! Read one logical keyword. Accepts `1`, `y`, `Y`, `t`, `T` as true; + ! anything else (including absence → `default`, and `0`, `n`, `N`, + ! `f`, `F`) as false. + ! + ! Called from: read_sfincs_input (this module). + ! + implicit none + ! + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + logical, intent(out) :: value + logical, intent(in) :: default + character(len=*), dimension(:), intent(in), optional :: legacy + ! + character(len=256) :: valstr + logical :: found + integer :: i + ! + call find_value(fileid, keyword, valstr, found) + if (found) then + value = parse_logical(valstr) + return + endif + ! + if (present(legacy)) then + ! + do i = 1, size(legacy) + ! + call find_value(fileid, trim(legacy(i)), valstr, found) + ! + if (found) then + value = parse_logical(valstr) + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo + ! + endif + ! + value = default + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine get_keyword_real_array(fileid, keyword, value, default, nr, legacy) + ! + ! Read one whitespace-separated real*4 array keyword. Allocates + ! `value(nr)` on the way in and fills it from the matching line. + ! Same fallback semantics as get_keyword_real. + ! + ! Called from: read_sfincs_input (this module). + ! + implicit none + ! + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + integer, intent(in) :: nr + real*4, intent(in) :: default + real*4, dimension(:), intent(out), allocatable :: value + character(len=*), dimension(:), intent(in), optional :: legacy + ! + character(len=256) :: valstr + logical :: found + integer :: i, m + ! + allocate(value(nr)) + ! + call find_value(fileid, keyword, valstr, found) + if (found) then + read(valstr, *) (value(m), m = 1, nr) + return + endif + ! + if (present(legacy)) then + ! + do i = 1, size(legacy) + ! + call find_value(fileid, trim(legacy(i)), valstr, found) + ! + if (found) then + read(valstr, *) (value(m), m = 1, nr) + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo + ! + endif + ! + value = default + ! end subroutine - - -end module \ No newline at end of file + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine find_value(fileid, keyword, valstr, found) + ! + ! Scan an already-open sfincs.inp once for the given `keyword`. + ! Returns the raw right-hand-side value string and whether the key + ! was matched. + ! + ! Called from: get_keyword_real / get_keyword_int / get_keyword_char / + ! get_keyword_logical / get_keyword_real_array. + ! + implicit none + ! + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + character(*), intent(out) :: valstr + logical, intent(out) :: found + ! + character(len=256) :: keystr + character(len=256) :: line + integer :: stat + ! + found = .false. + valstr = '' + ! + rewind(fileid) + ! + do while (.true.) + ! + read(fileid, '(a)', iostat=stat) line + if (stat == -1) exit + ! + call read_line(line, keystr, valstr) + ! + if (trim(keystr) == trim(keyword)) then + found = .true. + return + endif + ! + enddo + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine warn_legacy(legacy_key, new_key) + ! + ! Emit a one-line deprecation warning to the log. Called whenever + ! a legacy keyword alias was matched; the user can silence this + ! by migrating the keyword in their sfincs.inp. + ! + ! Called from: get_keyword_real / get_keyword_int / get_keyword_char / + ! get_keyword_logical / get_keyword_real_array. + ! + implicit none + ! + character(*), intent(in) :: legacy_key + character(*), intent(in) :: new_key + ! + character(len=512) :: msg + ! + write(msg, '(a,a,a,a,a)') ' Warning : sfincs.inp keyword "', trim(legacy_key), & + '" is deprecated, use "', trim(new_key), '" instead' + call write_log(trim(msg), 1) + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + function parse_logical(valstr) result(value) + ! + ! Map an sfincs.inp value string to a logical. `1`, `y`, `Y`, `t`, + ! `T` at position 1 are true; everything else is false. + ! + ! Called from: get_keyword_logical (this module). + ! + implicit none + ! + character(*), intent(in) :: valstr + logical :: value + ! + value = (valstr(1:1) == '1' .or. valstr(1:1) == 'y' .or. valstr(1:1) == 'Y' .or. & + valstr(1:1) == 't' .or. valstr(1:1) == 'T') + ! + end function + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine read_line(line0, keystr, valstr) + ! + ! Split one `key = value` line into key and value substrings. + ! Strips leading/trailing whitespace, any tab characters (replaced + ! by spaces via notabs), and a trailing `#`-delimited inline + ! comment. Blank lines and lines starting with `#`, `!`, or `@` + ! return empty strings. + ! + ! Called from: find_value. + ! + implicit none + ! + character(*), intent(in) :: line0 + character(*), intent(out) :: keystr + character(*), intent(out) :: valstr + ! + character(len=256) :: line + integer :: j, ilen, jn + ! + keystr = '' + valstr = '' + ! + ! Expand tabs to spaces in-place. + ! + call notabs(line0, line, ilen) + ! + ! Remove Windows-style `\r` line ending if present. + ! + jn = index(line, '\r') + if (jn > 0) line = line(1:jn - 1) + ! + line = trim(line) + ! + if (line(1:1) == '#' .or. line(1:1) == '!' .or. line(1:1) == '@') return + ! + j = index(line, '=') + if (j == 0) return + ! + keystr = trim(line(1:j - 1)) + valstr = trim(line(j + 1:)) + ! + ! Strip inline comment after `#`. + ! + jn = index(valstr, '#') + if (jn > 0) valstr = trim(valstr(1:jn - 1)) + ! + valstr = adjustl(trim(valstr)) + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine notabs(instr, outstr, ilen) + ! + ! Expand embedded tab characters into spaces while keeping columns + ! aligned (tab stops every 8 characters). Lets downstream tokenizers + ! treat `key=value` and `key = value` identically. + ! + ! Author: John S. Urban. See also GNU/Unix commands expand(1) / + ! unexpand(1). + ! + ! Called from: read_line (this module). + ! + use iso_fortran_env, only : error_unit + ! + implicit none + ! + character(len=*), intent(in) :: instr ! input line (may contain tab characters) + character(len=*), intent(out) :: outstr ! tab-expanded output + integer, intent(out) :: ilen ! column position of last character written + ! + integer, parameter :: tabsize = 8 ! tab stops every 8th column + character(len=1) :: c + integer :: ipos ! position in outstr for next character + integer :: lenin ! length of instr (trailing blanks trimmed) + integer :: lenout ! capacity of outstr + integer :: i10 ! cursor through instr + ! + ipos = 1 + lenin = len(instr) + lenin = len_trim(instr(1:lenin)) + lenout = len(outstr) + outstr = ' ' + ! + do i10 = 1, lenin + ! + c = instr(i10:i10) + ! + if (ichar(c) == 9) then + ! + ! Tab character: advance ipos to the next tab stop. + ! + ipos = ipos + (tabsize - (mod(ipos - 1, tabsize))) + ! + else + ! + if (ipos > lenout) then + write(error_unit, *) '*notabs* output string overflow' + exit + else + outstr(ipos:ipos) = c + ipos = ipos + 1 + endif + ! + endif + ! + enddo + ! + ilen = len_trim(outstr(:ipos)) + ! + end subroutine + ! +end module diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 804e1017a..f82c7dde4 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -11,6 +11,8 @@ module sfincs_lib use sfincs_crosssections use sfincs_runup_gauges use sfincs_discharges + use sfincs_src_structures + use sfincs_urban_drainage use sfincs_meteo use sfincs_infiltration use sfincs_data @@ -26,6 +28,7 @@ module sfincs_lib use sfincs_bathtub use sfincs_openacc use sfincs_log + use sfincs_timers use sfincs_timestep_analysis ! implicit none @@ -41,13 +44,6 @@ module sfincs_lib ! private ! - integer*8 :: count0 - integer*8 :: count00 - integer*8 :: countdt0 - integer*8 :: countdt1 - integer*8 :: count1 - integer*8 :: count_rate - integer*8 :: count_max integer :: nt ! integer :: ntmapout @@ -75,10 +71,7 @@ module sfincs_lib logical :: update_meteo logical :: update_waves ! - real :: tstart, tfinish, tloopflux, tloopcont, tloopstruc, tloopbnd, tloopsrc, tloopwnd1, tloopwnd2, tloopinf, tloopoutput, tloopsnapwave, tloopwavemaker, tloopnonh real :: time_per_timestep - real :: tinput - real :: percdone,percdonenext,trun,trem ! contains ! @@ -94,47 +87,12 @@ function sfincs_initialize() result(ierr) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - build_revision = "$Rev: v2.4.0 Galibier Release" - build_date = "$Date: 2026-06-11" + build_revision = "$Rev: v2.4.0 Galibier Release + urban_drainage" + build_date = "$Date: 2026-07-13" ! - call write_log('', 1) - call write_log('------------ Welcome to SFINCS ------------', 1) - call write_log('', 1) - call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) - call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) - call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) - call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) - call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) - call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) - call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) - call write_log('', 1) - call write_log(' .............. ', 1) - call write_log(' ......:@@@@@@@@:...... ', 1) - call write_log(' ..::::..@@........@@.:::::.. ', 1) - call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) - call write_log(' .::::::..@@............@@.:::::::. ', 1) - call write_log(' .::::::..@@..............@@.:::::::. ', 1) - call write_log(' .::::::::..@@............@@..::::::::. ', 1) - call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) - call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) - call write_log(' ............@@.@@..@@..@@.@@............ ', 1) - call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) - call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) - call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) - call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) - call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) - call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) - call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) - call write_log(' ...................... ', 1) - call write_log(' .............. ', 1) - call write_log('', 1) - call write_log('------------------------------------------', 1) - call write_log('', 1) - call write_log('Build-Revision: '//trim(build_revision), 1) - call write_log('Build-Date: '//trim(build_date), 1) - call write_log('', 1) + call write_startup_log() ! - call system_clock(count0, count_rate, count_max) + call timer_start('input') ! call write_log('------ Preparing model simulation --------', 1) call write_log('', 1) @@ -150,7 +108,8 @@ function sfincs_initialize() result(ierr) ! endif ! - call write_log('Preparing domain ...', 0) + call write_log('Preparing domain ...', 0) + ! call initialize_domain() ! Reads dep, msk, index files, creates index, flag and depth arrays, initializes hydro quantities ! call read_structures() ! Reads thd files and sets kcuv to zero where necessary @@ -165,7 +124,13 @@ function sfincs_initialize() result(ierr) ! call read_rug_file() ! Read runup gauge file ! - call read_discharges() ! Reads dis and src file + call initialize_infiltration() ! Reads qinf / scs / gai / horton / bucket infiltration inputs + ! + call initialize_discharges() ! Reads dis and src file (river point discharges) + ! + call initialize_src_structures() ! Reads drn file (pumps / culverts / check valves / gates) + ! + call initialize_urban_drainage() ! Reads urb file (per-zone polygon drainage + outfall) ! if (nonhydrostatic) then ! @@ -191,78 +156,6 @@ function sfincs_initialize() result(ierr) ! endif ! - call write_log('', 1) - call write_log('------------------------------------------', 1) - call write_log('Processes', 1) - call write_log('------------------------------------------', 1) - if (subgrid) then - call write_log('Subgrid topography : yes', 1) - else - call write_log('Subgrid topography : no', 1) - endif - if (use_quadtree) then - call write_log('Quadtree refinement : yes', 1) - else - call write_log('Quadtree refinement : no', 1) - endif - if (advection) then - call write_log('Advection : yes', 1) - else - call write_log('Advection : no', 1) - endif - if (viscosity) then - call write_log('Viscosity : yes', 1) - else - call write_log('Viscosity : no', 1) - endif - if (coriolis) then - call write_log('Coriolis : yes', 1) - else - call write_log('Coriolis : no', 1) - endif - if (wind) then - call write_log('Wind : yes', 1) - else - call write_log('Wind : no', 1) - endif - if (patmos) then - call write_log('Atmospheric pressure : yes', 1) - else - call write_log('Atmospheric pressure : no', 1) - endif - if (precip) then - call write_log('Precipitation : yes', 1) - else - call write_log('Precipitation : no', 1) - endif - if (infiltration) then - call write_log('Infiltration : yes', 1) - else - call write_log('Infiltration : no', 1) - endif - if (snapwave) then - call write_log('SnapWave : yes', 1) - else - call write_log('SnapWave : no', 1) - endif - if (wavemaker) then - call write_log('Wave paddles : yes', 1) - else - call write_log('Wave paddles : no', 1) - endif - if (nonhydrostatic) then - call write_log('Non-hydrostatic : yes', 1) - else - ! call write_log('Non-hydrostatic : no', 1) - endif - if (bathtub) then - call write_log('Bathtub : yes', 1) - else - ! call write_log('Bathtub : no', 1) - endif - call write_log('------------------------------------------', 1) - call write_log('', 1) - ! if (snapwave) then ! call write_log('Coupling with SnapWave ...', 1) @@ -270,9 +163,9 @@ function sfincs_initialize() result(ierr) ! endif ! - call system_clock(count1, count_rate, count_max) + call timer_stop('input') ! - tinput = 1.0 * (count1 - count0) / count_rate + call write_processes_log() ! ! Initialize some parameters ! @@ -298,18 +191,6 @@ function sfincs_initialize() result(ierr) update_meteo = .false. ! update meteo fields update_waves = .false. ! update wave fields ! - tloopflux = 0.0 - tloopcont = 0.0 - tloopstruc = 0.0 - tloopbnd = 0.0 - tloopsrc = 0.0 - tloopwnd1 = 0.0 - tloopwnd2 = 0.0 - tloopinf = 0.0 - tloopsnapwave = 0.0 - tloopwavemaker = 0.0 - tloopnonh = 0.0 - ! call write_log('Initializing output ...', 0) ! call initialize_output(tmapout, tmaxout, thisout, trstout) @@ -328,7 +209,7 @@ function sfincs_initialize() result(ierr) call write_log(logstr, 1) call write_log('', 1) ! - call system_clock(count00, count_rate, count_max) + call timer_start('simulation') ! end function sfincs_initialize ! @@ -377,8 +258,6 @@ function sfincs_update(dtrange) result(ierr) ! Start computational loop ! do while (t < tend) - ! - call system_clock(countdt0, count_rate, count_max) ! write_map = .false. write_his = .false. @@ -404,11 +283,6 @@ function sfincs_update(dtrange) result(ierr) ! endif ! - ! A bit unclear why this happens, but large jumps in the time step lead to weird oscillations. - ! In the 'original' sfincs v11 version, this behavior was supressed by the use of theta. - ! Avoid this, by not not changing time step dt (used in momentum equation), but only changing dtt, - ! which is used in the time updating and continuity equation. - ! ! Update time ! t = t + dt @@ -433,11 +307,14 @@ function sfincs_update(dtrange) result(ierr) ntmaxout = ntmaxout + 1 ! now also keep track of nr of max output tout = max(tmaxout, t - dt) ! - if (t < t1) then - tmaxout = tmaxout + dtmaxout + if (t < t1) then + ! + tmaxout = tmaxout + dtmaxout + ! ! in case the last 'dt' made us exactly past tstop time 't1', ! then we don't want to flag later another dtmax output timestep in 'finalize_output' check, - ! so if t > t1 don't add 'dtmaxout' again + ! so if t > t1 don't add 'dtmaxout' again + ! endif ! endif @@ -521,59 +398,35 @@ function sfincs_update(dtrange) result(ierr) ! Update spatially-varying meteo (this does not happen every time step) ! Read and interpolate to grid ! - call update_meteo_fields(t, tloopwnd1) + call update_meteo_fields(t) ! endif ! ! Update forcing used in momentum and continuity equations (this does happen every time step) ! - call update_meteo_forcing(t, dt, tloopwnd2) - ! - ! Update infiltration + call update_meteo_forcing(t, dt) ! - if (infiltration) then - ! - ! Compute infiltration rates - ! - call update_infiltration_map(dt, tloopinf) - ! - endif - ! - endif + endif ! ! Update boundary conditions ! - call update_boundaries(t, dt, tloopbnd) + call update_boundaries(t, dt) ! - ! Update discharges - ! - call update_discharges(t, dt, tloopsrc) + ! Update SnapWave ! if (snapwave .and. update_waves) then ! - call timer(t3) - ! - call update_wave_field(t, tloopsnapwave) - ! - call timer(t4) - write(logstr,'(a,f10.1,a,f6.2,a)')'Computing SnapWave at t = ', t, ' s took ', t4 - t3, ' seconds' - call write_log(logstr, 0) + ! Update wave fields from SnapWave coupling (this happens at intervals of dtwave) ! - ! Maybe we'll add moving wave makers back at some point + call update_wave_field(t) ! - ! if (wavemaker) then - ! ! - ! call update_wavemaker_points(tloopwavemaker) - ! ! - ! endif - ! - endif + endif ! if (bathtub) then ! ! In bathtub mode, only update water levels based on boundary conditions ! - call bathtub_compute_water_levels(tloopcont) + call bathtub_compute_water_levels() ! else ! @@ -581,7 +434,7 @@ function sfincs_update(dtrange) result(ierr) ! ! First compute fluxes ! - call compute_fluxes(dt, tloopflux) + call compute_fluxes(dt) ! if (timestep_analysis) then ! @@ -591,13 +444,13 @@ function sfincs_update(dtrange) result(ierr) ! if (wavemaker) then ! - call update_wavemaker_fluxes(t, dt, tloopwavemaker) + call update_wavemaker_fluxes(t, dt) ! endif ! if (nrstructures>0) then ! - call compute_fluxes_over_structures(tloopstruc) + call compute_fluxes_over_structures() ! endif ! @@ -607,15 +460,15 @@ function sfincs_update(dtrange) result(ierr) ! ! Apply non-hydrostatic pressure corrections to q and uv ! - call compute_nonhydrostatic(dt, tloopnonh) + call compute_nonhydrostatic(dt) ! endif ! endif ! - ! Update water levels + ! Update continuity (discharges, drainage structures, infiltration, urban drainage, qext, water levels) ! - call compute_water_levels(t, dt, tloopcont) + call update_continuity(t, dt) ! endif ! @@ -625,7 +478,7 @@ function sfincs_update(dtrange) result(ierr) ! ! if (.not. fixed_output_intervals) tout = t ! - call write_output(tout, write_map, write_his, write_max, write_rst, ntmapout, ntmaxout, nthisout, tloopoutput) + call write_output(tout, write_map, write_his, write_max, write_rst, ntmapout, ntmaxout, nthisout) ! endif ! @@ -641,33 +494,13 @@ function sfincs_update(dtrange) result(ierr) ! ntmaxout = ntmaxout + 1 ! Max sure that max output is not called again through 'finalize_output' ! - call write_output(t, .true., .true., .true., .false., ntmapout + 1, ntmaxout, nthisout + 1, tloopoutput) + call write_output(t, .true., .true., .true., .false., ntmapout + 1, ntmaxout, nthisout + 1) ! t = t1 + 1.0 ! endif ! - percdone = min(100 * (t - t0) / (t1 - t0), 100.0) - ! - if (percdone >= percdonenext) then - ! - ! percdoneval is increment of % to show to log, default=+5% - percdonenext = 1.0 * (int(percdone) + percdoneval) - ! - call system_clock(count1, count_rate, count_max) - ! - trun = 1.0*(count1 - count00)/count_rate - trem = trun / max(0.01*percdone, 1.0e-6) - trun - ! - if (int(percdone)>0) then - write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, ',trem,' s remaining ...' - call write_log(logstr, 1) - else - write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, - s remaining ...' - call write_log(logstr, 1) - endif - ! - endif + call write_progress_log(t, t0, t1) ! if (single_time_step) then ! @@ -688,114 +521,32 @@ function sfincs_finalize() result(ierr) ! integer :: ierr ! - call system_clock(count1, count_rate, count_max) - ! - tstart_all = 0.0 - tfinish_all = 1.0 * (count1 - count00) / count_rate + call timer_stop('simulation') ! if (timestep_analysis) then ! call timestep_analysis_finalize(nt) ! - endif + endif ! - call finalize_output(t, ntmaxout, tloopoutput, tmaxout) + call finalize_output(t, ntmaxout, tmaxout) ! call finalize_openacc() ! Exit data region ! dtavg = dtavg / (nt - 1) ! - call write_log('', 1) - call write_log('---------- Simulation finished -----------', 1) - call write_log('', 1) - write(logstr,'(a,f10.3)') ' Total time : ', tinput + tfinish_all - tstart_all - call write_log(logstr, 1) - write(logstr,'(a,f10.3)') ' Total simulation time : ', tfinish_all - tstart_all - call write_log(logstr, 1) - write(logstr,'(a,f10.3)') ' Time in input : ', tinput - call write_log(logstr, 1) - ! - if (boundaries_in_mask) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in boundaries : ', tloopbnd, ' (', 100 * tloopbnd / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (nsrc>0 .or. ndrn>0) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in discharges : ', tloopsrc, ' (', 100 * tloopsrc / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (meteo3d) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in meteo fields : ', tloopwnd1, ' (', 100 * tloopwnd1 / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (wind .or. patmos .or. precip) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in meteo forcing : ', tloopwnd2, ' (', 100 * tloopwnd2 / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (infiltration) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in infiltration : ', tloopinf, ' (', 100 * tloopinf / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in momentum : ', tloopflux, ' (', 100 * tloopflux / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - ! - if (nonhydrostatic) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in non-hydrostatic: ', tloopnonh, ' (', 100 * tloopnonh / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (nrstructures>0) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in structures : ', tloopstruc, ' (', 100 * tloopstruc / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in continuity : ', tloopcont, ' (', 100 * tloopcont / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - ! - if (snapwave) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in SnapWave : ', tloopsnapwave, ' (', 100 * tloopsnapwave / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (wavemaker) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in wave maker : ', tloopwavemaker, ' (', 100 * tloopwavemaker / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in output : ', tloopoutput, ' (', 100 * tloopoutput / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - ! - call write_log('', 1) - ! - write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg - call write_log(logstr, 1) - ! - call write_log('', 1) + call write_finished_log(dtavg) ! if (timestep_analysis) then ! call timestep_analysis_write_log() ! - endif + endif ! if (write_time_output) then - open(123,file='runtimes.txt') - write(123,'(f10.3,a)')tfinish_all - tstart_all,' % total' - write(123,'(f10.3,a)')tinput,' % input' - write(123,'(f10.3,a)')tloopbnd,' % boundaries' - write(123,'(f10.3,a)')tloopsrc,' % discharges' - write(123,'(f10.3,a)')tloopwnd1,' % meteo1' - write(123,'(f10.3,a)')tloopwnd2,' % meteo2' - write(123,'(f10.3,a)')tloopinf,' % infiltration' - write(123,'(f10.3,a)')tloopflux,' % momentum' - write(123,'(f10.3,a)')tloopstruc,' % structures' - write(123,'(f10.3,a)')tloopcont,' % continuity' - write(123,'(f10.3,a)')tloopoutput,' % output' - close(123) + ! + call write_runtimes_file(123, 'runtimes.txt') + ! endif ! call write_log('----------- Closing off SFINCS -----------', 1) diff --git a/source/src/sfincs_log.f90 b/source/src/sfincs_log.f90 index b78b7cd83..c79d35565 100644 --- a/source/src/sfincs_log.f90 +++ b/source/src/sfincs_log.f90 @@ -1,40 +1,538 @@ module sfincs_log + ! + ! User-facing log / screen output for SFINCS. + ! + ! Owns sfincs.log (fid, open_log/close_log/write_log) and all the + ! formatted blocks that the driver writes to it. + ! + ! Rendering of named-timer data (headers, per-phase summary, the + ! runtimes.txt payload) also lives here, so that sfincs_timers can + ! remain a pure data module with no dependency on sfincs_log. This + ! breaks what used to be a circular dependency between the two. + ! + ! Subroutines: + ! + ! open_log() / close_log() / write_log(str, to_screen) + ! File handle management and the single-line writer. Called from + ! every SFINCS module that emits user-facing output. + ! + ! write_startup_log() + ! Welcome banner + ASCII logo + build-revision / build-date lines. + ! Called once from sfincs_initialize (sfincs_lib). + ! + ! write_processes_log() + ! "Processes" yes/no summary. Called once from sfincs_initialize. + ! + ! write_progress_log(t, t0, t1) + ! Per-timestep progress / ETA line. Called every time step from + ! the main loop in sfincs_lib. Uses timer_elapsed('simulation'). + ! + ! write_finished_log(dtavg) + ! End-of-run banner + per-phase timer summary + average time step. + ! Called once from sfincs_finalize (sfincs_lib). + ! + ! write_timer_headers_log(to_screen) + ! Three-line "Total / Total simulation / Input" header block. + ! Called from write_finished_log. + ! + ! write_timer_summary_log(to_screen, total_wall, min_elapsed) + ! Per-timer summary table (name, seconds, % of total, #calls). + ! Walks the timer list via the iteration API on sfincs_timers. + ! Called from write_finished_log. + ! + ! write_runtimes_file(unit, filename) + ! Writes the runtimes.txt payload (simulation-loop wall time, + ! input wall time, and each phase timer) in the format the + ! original inline code in sfincs_lib produced. Called from + ! sfincs_finalize (sfincs_lib) when write_time_output is set. + ! + ! fmt_real(val, decimals) result(s) + ! Format a real value with the minimum necessary field width and + ! a guaranteed leading zero for |val| < 1. Works around a quirk + ! in ifx that drops the leading zero for the "f0.d" edit + ! descriptor. Returns a 32-char string, left-justified; callers + ! use trim(fmt_real(...)) when embedding it in a larger format. + ! + use sfincs_timers ! integer :: fid character(256) :: logstr ! -contains - - subroutine open_log() + ! Next percentage threshold at which the progress reporter prints a + ! line. Incremented in steps of percdoneval (set from the + ! 'percentage_done' input keyword). Zero-initialised so the first + ! call prints at 0%. ! - implicit none + real, save :: percdonenext = 0.0 ! - fid = 777 - open(unit = fid, file = 'sfincs.log') +contains ! - end subroutine - - subroutine write_log(str, to_screen) + !-----------------------------------------------------------------------------------------------------! ! - implicit none + subroutine open_log() + ! + ! Open sfincs.log on the module-local unit fid=777. Called once + ! at the very start of sfincs_initialize (sfincs_lib). + ! + implicit none + ! + fid = 777 + open(unit = fid, file = 'sfincs.log') + ! + end subroutine open_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_log(str, to_screen) + ! + ! Write one line to sfincs.log, optionally echoed to stdout. + ! Called from every SFINCS module that emits user-facing output. + ! + implicit none + ! + character(*), intent(in) :: str + integer, intent(in) :: to_screen + ! + write(fid,'(a)') trim(str) + ! + if (to_screen == 1) then + write(*,'(a)') trim(str) + endif + ! + end subroutine write_log ! - character(*), intent(in) :: str - integer, intent(in) :: to_screen + !-----------------------------------------------------------------------------------------------------! ! - write(fid,'(a)')trim(str) + function fmt_real(val, decimals) result(s) + ! + ! Format a real with minimum width and a guaranteed leading zero + ! for |val| < 1. ifx's "f0.d" descriptor drops the leading zero in + ! that range, which is not standard-conforming; this helper rewrites + ! the result so the log output always reads "0.6670" rather than + ! ".6670". + ! + ! Called from: write_src_structures_log_summary (sfincs_src_structures), + ! urban_drainage log summary (sfincs_urban_drainage), and anywhere + ! else a real needs to be embedded in a log line with the smallest + ! reasonable field width. + ! + implicit none + ! + real, intent(in) :: val + integer, intent(in) :: decimals + character(len=32) :: s + ! + character(len=16) :: fmt + ! + write(fmt,'(a,i0,a)') '(f0.', decimals, ')' + write(s,fmt) val + s = adjustl(s) + ! + if (s(1:1) == '.') then + ! + s = '0' // s(1:len_trim(s)) + ! + else if (s(1:2) == '-.') then + ! + s = '-0' // trim(s(2:)) + ! + endif + ! + end function fmt_real ! - if (to_screen==1) then - write(*,'(a)')trim(str) - endif + !-----------------------------------------------------------------------------------------------------! ! - end subroutine - subroutine close_log() + ! + ! Close the sfincs.log file handle. Called once at the end of + ! sfincs_finalize (sfincs_lib). + ! + implicit none + ! + close(fid) + ! + end subroutine close_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_startup_log() + ! + ! Welcome banner, ASCII logo and build-revision / build-date lines. + ! Called once at the start of sfincs_initialize (sfincs_lib), + ! after build_revision and build_date have been set in sfincs_data. + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------ Welcome to SFINCS ------------', 1) + call write_log('', 1) + call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) + call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) + call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) + call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) + call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) + call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) + call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) + call write_log('', 1) + call write_log(' .............. ', 1) + call write_log(' ......:@@@@@@@@:...... ', 1) + call write_log(' ..::::..@@........@@.:::::.. ', 1) + call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) + call write_log(' .::::::..@@............@@.:::::::. ', 1) + call write_log(' .::::::..@@..............@@.:::::::. ', 1) + call write_log(' .::::::::..@@............@@..::::::::. ', 1) + call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) + call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) + call write_log(' ............@@.@@..@@..@@.@@............ ', 1) + call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) + call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) + call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) + call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) + call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) + call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) + call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) + call write_log(' ...................... ', 1) + call write_log(' .............. ', 1) + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('', 1) + call write_log('Build-Revision: '//trim(build_revision), 1) + call write_log('Build-Date: '//trim(build_date), 1) + call write_log('', 1) + ! + end subroutine write_startup_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_processes_log() + ! + ! "Processes" summary block listing which physical processes are + ! enabled for this run. Reads the process flags from sfincs_data. + ! Called once from sfincs_initialize (sfincs_lib). + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('Processes', 1) + call write_log('------------------------------------------', 1) + ! + if (subgrid) then + call write_log('Subgrid topography : yes', 1) + else + call write_log('Subgrid topography : no', 1) + endif + ! + if (use_quadtree) then + call write_log('Quadtree refinement : yes', 1) + else + call write_log('Quadtree refinement : no', 1) + endif + ! + if (advection) then + call write_log('Advection : yes', 1) + else + call write_log('Advection : no', 1) + endif + ! + if (viscosity) then + call write_log('Viscosity : yes', 1) + else + call write_log('Viscosity : no', 1) + endif + ! + if (coriolis) then + call write_log('Coriolis : yes', 1) + else + call write_log('Coriolis : no', 1) + endif + ! + if (wind) then + call write_log('Wind : yes', 1) + else + call write_log('Wind : no', 1) + endif + ! + if (patmos) then + call write_log('Atmospheric pressure : yes', 1) + else + call write_log('Atmospheric pressure : no', 1) + endif + ! + if (precip) then + call write_log('Precipitation : yes', 1) + else + call write_log('Precipitation : no', 1) + endif + ! + if (infiltration) then + call write_log('Infiltration : yes', 1) + else + call write_log('Infiltration : no', 1) + endif + ! + if (discharges) then + call write_log('Discharges : yes', 1) + else + call write_log('Discharges : no', 1) + endif + ! + if (drainage_structures) then + call write_log('Drainage structures : yes', 1) + else + call write_log('Drainage structures : no', 1) + endif + ! + if (dike_breaching) then + call write_log('Dike breaching : yes', 1) + else + call write_log('Dike breaching : no', 1) + endif + ! + if (urban_drainage) then + call write_log('Urban drainage : yes', 1) + else + call write_log('Urban drainage : no', 1) + endif + ! + if (snapwave) then + call write_log('SnapWave : yes', 1) + else + call write_log('SnapWave : no', 1) + endif + ! + if (wavemaker) then + call write_log('Wave paddles : yes', 1) + else + call write_log('Wave paddles : no', 1) + endif + ! + if (nonhydrostatic) then + call write_log('Non-hydrostatic : yes', 1) + else + ! call write_log('Non-hydrostatic : no', 1) + endif + ! + if (bathtub) then + call write_log('Bathtub : yes', 1) + else + ! call write_log('Bathtub : no', 1) + endif + ! + call write_log('------------------------------------------', 1) + call write_log('', 1) + ! + end subroutine write_processes_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_progress_log(t, t0, t1) + ! + ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s + ! remaining ..." line each time the simulated-time percentage + ! crosses the next percdoneval threshold. Remaining time is + ! estimated from the wall-clock elapsed in the 'simulation' + ! timer. + ! + ! Called every time step from the main loop in sfincs_lib. + ! + use sfincs_data, only: percdoneval + ! + implicit none + ! + real*8, intent(in) :: t + real*4, intent(in) :: t0, t1 + ! + real :: percdone, trun, trem + character(len=256) :: logstr + ! + percdone = min(100.0 * (real(t, 4) - t0) / (t1 - t0), 100.0) + ! + if (percdone >= percdonenext) then + ! + ! percdoneval is increment of % to show to log, default=+5% + ! + percdonenext = 1.0 * (int(percdone) + percdoneval) + ! + trun = real(timer_elapsed('simulation'), 4) + trem = trun / max(0.01*percdone, 1.0e-6) - trun + ! + if (int(percdone) > 0) then + ! + write(logstr,'(i4,a,f7.1,a)') int(percdone),'% complete, ',trem,' s remaining ...' + call write_log(logstr, 1) + ! + else + ! + write(logstr,'(i4,a,f7.1,a)') int(percdone),'% complete, - s remaining ...' + call write_log(logstr, 1) + ! + endif + ! + endif + ! + end subroutine write_progress_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_finished_log(dtavg) + ! + ! End-of-run log block: "Simulation finished" banner, per-phase + ! timer summary, and the average time step line. Called once from + ! sfincs_finalize (sfincs_lib), after the simulation loop has + ! stopped and dtavg has been averaged. + ! + implicit none + ! + real, intent(in) :: dtavg + ! + character(len=256) :: logstr + ! + call write_log('', 1) + call write_log('---------- Simulation finished -----------', 1) + call write_log('', 1) + ! + call write_timer_headers_log(1) + ! + ! Per-phase timing summary. Percentages are relative to the total + ! wall time of the simulation loop. + ! + call write_timer_summary_log(1, timer_elapsed('simulation'), 0.0005_8) + ! + call write_log('', 1) + ! + write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg + call write_log(logstr, 1) + ! + call write_log('', 1) + ! + end subroutine write_finished_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_timer_headers_log(to_screen) + ! + ! Write the three 'Total time / Total simulation time / Time in input' header + ! lines to the log, using the 'input' and 'simulation' named timers. + ! + ! Called from: write_finished_log. + ! + integer, intent(in) :: to_screen + ! + real(8) :: t_input + real(8) :: t_loop + ! + t_input = timer_elapsed('input') + t_loop = timer_elapsed('simulation') + ! + write(logstr, '(a,f10.3)') ' Total time : ', t_input + t_loop + call write_log(trim(logstr), to_screen) + ! +! write(logstr, '(a,f10.3)') ' Total simulation time : ', t_loop +! call write_log(trim(logstr), to_screen) + ! + write(logstr, '(a,f10.3)') ' Time in input : ', t_input + call write_log(trim(logstr), to_screen) + ! + end subroutine write_timer_headers_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_timer_summary_log(to_screen, total_wall, min_elapsed) + ! + ! Pretty-print a summary of all registered timers via write_log. + ! Walks the timer list via the iteration API on sfincs_timers + ! (timer_num_registered, timer_name_by_index, timer_elapsed_by_index, + ! timer_count_by_index) so this module does not need to know about + ! the internal storage of sfincs_timers. + ! + ! to_screen : passed to write_log (1 = also echo to stdout). + ! total_wall : reference total wall time used for the '%' column. + ! If <= 0, the sum across all timers is used instead. + ! min_elapsed : timers with accumulated time below this threshold (in s) + ! are skipped. Pass a negative value to print every timer. + ! + ! Called from: write_finished_log. + ! + integer, intent(in) :: to_screen + real(8), intent(in) :: total_wall + real(8), intent(in) :: min_elapsed + ! + real(8) :: denom + real(8) :: t_el + real(8) :: pct + integer :: i + integer :: n + integer :: ncalls + character(32) :: tname + character(256) :: line + ! + if (total_wall > 0.0_8) then + denom = total_wall + else + denom = max(timer_total_wall(), 1.0e-12_8) + endif + ! + n = timer_num_registered() + ! + do i = 1, n + ! + t_el = timer_elapsed_by_index(i) + ! + if (t_el < min_elapsed) cycle + ! + ! Skip input (was already added in header) + ! + if (trim(timer_name_by_index(i)) == 'input') cycle + ! + pct = 100.0_8 * t_el / denom + tname = timer_name_by_index(i) + ! + write(line, '(1x,a,1x,a,t31,a,f10.3,a,f5.1,a,a,a)') & + 'Time in', trim(tname), ': ', t_el, ' (', pct, '%)' + ! + call write_log(trim(line), to_screen) + ! + enddo + ! + end subroutine write_timer_summary_log ! - implicit none + !-----------------------------------------------------------------------------------------------------! ! - close(fid) + subroutine write_runtimes_file(unit, filename) + ! + ! Write the runtimes.txt payload: simulation-loop wall time, input wall time, + ! and each phase timer, in the same order and with the same keys as the + ! previous inline implementation in sfincs_lib.f90. + ! + ! Called from: sfincs_finalize (sfincs_lib) when write_time_output + ! is set. + ! + integer, intent(in) :: unit + character(len=*), intent(in) :: filename + ! + open(unit, file=filename) + ! + write(unit, '(f10.3,a)') real(timer_elapsed('simulation'), 4), ' % total' + write(unit, '(f10.3,a)') real(timer_elapsed('input'), 4), ' % input' + write(unit, '(f10.3,a)') real(timer_elapsed('boundaries'), 4), ' % boundaries' + write(unit, '(f10.3,a)') real(timer_elapsed('discharges'), 4), ' % discharges' + write(unit, '(f10.3,a)') real(timer_elapsed('drainage structures'), 4), ' % drainage_structures' + write(unit, '(f10.3,a)') real(timer_elapsed('urban drainage'), 4), ' % urban_drainage' + write(unit, '(f10.3,a)') real(timer_elapsed('meteo fields'), 4), ' % meteo1' + write(unit, '(f10.3,a)') real(timer_elapsed('meteo forcing'), 4), ' % meteo2' + write(unit, '(f10.3,a)') real(timer_elapsed('infiltration'), 4), ' % infiltration' + write(unit, '(f10.3,a)') real(timer_elapsed('momentum'), 4), ' % momentum' + write(unit, '(f10.3,a)') real(timer_elapsed('structures'), 4), ' % structures' + write(unit, '(f10.3,a)') real(timer_elapsed('continuity'), 4), ' % continuity' + write(unit, '(f10.3,a)') real(timer_elapsed('output'), 4), ' % output' + ! + close(unit) + ! + end subroutine write_runtimes_file ! - end subroutine - -end module +end module sfincs_log diff --git a/source/src/sfincs_log.f90.reformatted b/source/src/sfincs_log.f90.reformatted new file mode 100644 index 000000000..b9052fec2 --- /dev/null +++ b/source/src/sfincs_log.f90.reformatted @@ -0,0 +1,298 @@ +module sfincs_log + ! + ! User-facing log / screen output for SFINCS. + ! + ! Core: + ! - open_log / close_log / write_log : file handle + line writer + ! + ! Formatted blocks (moved here from the former sfincs_screendump): + ! - write_startup_log : welcome banner + ASCII art + build info + ! - write_processes_log: yes/no "Processes" summary + ! - write_progress_log : per-timestep progress / ETA line + ! - write_finished_log : end-of-run banner + timer summary + + ! average time step + ! + integer :: fid + character(256) :: logstr + ! + ! Next percentage threshold at which the progress reporter prints a + ! line. Incremented in steps of percdoneval (set from the + ! 'percentage_done' input keyword). Zero-initialised so the first + ! call prints at 0%. + ! + real, save :: percdonenext = 0.0 + ! +contains + ! + subroutine open_log() + ! + implicit none + ! + fid = 777 + open(unit = fid, file = 'sfincs.log') + ! + end subroutine + ! + ! + subroutine write_log(str, to_screen) + ! + implicit none + ! + character(*), intent(in) :: str + integer, intent(in) :: to_screen + ! + write(fid,'(a)')trim(str) + ! + if (to_screen==1) then + write(*,'(a)')trim(str) + endif + ! + end subroutine + ! + ! + subroutine close_log() + ! + implicit none + ! + close(fid) + ! + end subroutine + ! + ! + subroutine write_startup_log() + ! + ! Welcome banner, ASCII logo and build-revision / build-date lines. + ! Called once at the start of sfincs_initialize, after build_revision + ! and build_date have been set in sfincs_data. + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------ Welcome to SFINCS ------------', 1) + call write_log('', 1) + call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) + call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) + call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) + call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) + call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) + call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) + call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) + call write_log('', 1) + call write_log(' .............. ', 1) + call write_log(' ......:@@@@@@@@:...... ', 1) + call write_log(' ..::::..@@........@@.:::::.. ', 1) + call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) + call write_log(' .::::::..@@............@@.:::::::. ', 1) + call write_log(' .::::::..@@..............@@.:::::::. ', 1) + call write_log(' .::::::::..@@............@@..::::::::. ', 1) + call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) + call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) + call write_log(' ............@@.@@..@@..@@.@@............ ', 1) + call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) + call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) + call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) + call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) + call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) + call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) + call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) + call write_log(' ...................... ', 1) + call write_log(' .............. ', 1) + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('', 1) + call write_log('Build-Revision: '//trim(build_revision), 1) + call write_log('Build-Date: '//trim(build_date), 1) + call write_log('', 1) + ! + end subroutine write_startup_log + ! + ! + subroutine write_processes_log() + ! + ! "Processes" summary block listing which physical processes are + ! enabled for this run. Reads the process flags from sfincs_data. + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('Processes', 1) + call write_log('------------------------------------------', 1) + ! + if (subgrid) then + call write_log('Subgrid topography : yes', 1) + else + call write_log('Subgrid topography : no', 1) + endif + ! + if (use_quadtree) then + call write_log('Quadtree refinement : yes', 1) + else + call write_log('Quadtree refinement : no', 1) + endif + ! + if (advection) then + call write_log('Advection : yes', 1) + else + call write_log('Advection : no', 1) + endif + ! + if (viscosity) then + call write_log('Viscosity : yes', 1) + else + call write_log('Viscosity : no', 1) + endif + ! + if (coriolis) then + call write_log('Coriolis : yes', 1) + else + call write_log('Coriolis : no', 1) + endif + ! + if (wind) then + call write_log('Wind : yes', 1) + else + call write_log('Wind : no', 1) + endif + ! + if (patmos) then + call write_log('Atmospheric pressure : yes', 1) + else + call write_log('Atmospheric pressure : no', 1) + endif + ! + if (precip) then + call write_log('Precipitation : yes', 1) + else + call write_log('Precipitation : no', 1) + endif + ! + if (infiltration) then + call write_log('Infiltration : yes', 1) + else + call write_log('Infiltration : no', 1) + endif + ! + if (drainage) then + call write_log('Drainage : yes', 1) + else + call write_log('Drainage : no', 1) + endif + ! + if (snapwave) then + call write_log('SnapWave : yes', 1) + else + call write_log('SnapWave : no', 1) + endif + ! + if (wavemaker) then + call write_log('Wave paddles : yes', 1) + else + call write_log('Wave paddles : no', 1) + endif + ! + if (nonhydrostatic) then + call write_log('Non-hydrostatic : yes', 1) + else + ! call write_log('Non-hydrostatic : no', 1) + endif + ! + if (bathtub) then + call write_log('Bathtub : yes', 1) + else + ! call write_log('Bathtub : no', 1) + endif + ! + call write_log('------------------------------------------', 1) + call write_log('', 1) + ! + end subroutine write_processes_log + ! + ! + subroutine write_progress_log(t, t0, t1) + ! + ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s + ! remaining ..." line each time the simulated-time percentage + ! crosses the next percdoneval threshold. Remaining time is + ! estimated from the wall-clock elapsed in the 'Simulation loop' + ! timer. + ! + use sfincs_data, only: percdoneval + use sfincs_timers, only: timer_elapsed + ! + implicit none + ! + real*8, intent(in) :: t + real*4, intent(in) :: t0, t1 + ! + real :: percdone, trun, trem + character(len=256) :: logstr + ! + percdone = min(100.0 * (real(t, 4) - t0) / (t1 - t0), 100.0) + ! + if (percdone >= percdonenext) then + ! + ! percdoneval is increment of % to show to log, default=+5% + ! + percdonenext = 1.0 * (int(percdone) + percdoneval) + ! + trun = real(timer_elapsed('Simulation loop'), 4) + trem = trun / max(0.01*percdone, 1.0e-6) - trun + ! + if (int(percdone)>0) then + ! + write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, ',trem,' s remaining ...' + call write_log(logstr, 1) + ! + else + ! + write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, - s remaining ...' + call write_log(logstr, 1) + ! + endif + ! + endif + ! + end subroutine write_progress_log + ! + ! + subroutine write_finished_log(dtavg) + ! + ! End-of-run log block: "Simulation finished" banner, per-phase + ! timer summary, and the average time step line. Called once from + ! sfincs_finalize, after the simulation loop has stopped and + ! dtavg has been averaged. + ! + use sfincs_timers, only: timer_write_headers, timer_write_summary, timer_elapsed + ! + implicit none + ! + real, intent(in) :: dtavg + ! + character(len=256) :: logstr + ! + call write_log('', 1) + call write_log('---------- Simulation finished -----------', 1) + call write_log('', 1) + ! + call timer_write_headers(1) + ! + ! Per-phase timing summary. Percentages are relative to the total + ! wall time of the simulation loop. + ! + call timer_write_summary(1, timer_elapsed('Simulation loop'), 0.0005_8) + ! + call write_log('', 1) + ! + write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg + call write_log(logstr, 1) + ! + call write_log('', 1) + ! + end subroutine write_finished_log + +end module diff --git a/source/src/sfincs_meteo.f90 b/source/src/sfincs_meteo.f90 index 7e40d2df5..bc7eed63c 100644 --- a/source/src/sfincs_meteo.f90 +++ b/source/src/sfincs_meteo.f90 @@ -1230,19 +1230,14 @@ subroutine update_ampr_data() end subroutine - subroutine update_meteo_forcing(t, dt, tloop) + subroutine update_meteo_forcing(t, dt) ! ! Update wind stresses and precipitation (this happens every time step) ! use sfincs_data + use sfincs_timers ! implicit none - ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop ! real*8 :: t real*4 :: dt @@ -1252,7 +1247,7 @@ subroutine update_meteo_forcing(t, dt, tloop) real*4 :: oneminsmfac integer :: nm, ib ! - call system_clock(count0, count_rate, count_max) + call timer_start('meteo forcing') ! if (meteo3d) then ! @@ -1265,7 +1260,7 @@ subroutine update_meteo_forcing(t, dt, tloop) !$acc parallel, present( tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & !$acc patm, patm0, patm1, & - !$acc prcp, prcp0, prcp1, cumprcp, netprcp, & + !$acc prcp, prcp0, prcp1, cumprcp, & !$acc zs, zb, z_volume ) !$acc loop independent gang vector do nm = 1, np @@ -1341,40 +1336,38 @@ subroutine update_meteo_forcing(t, dt, tloop) !$omp parallel & !$omp private ( nm ) !$omp do - !$acc parallel, present( tauwu, tauwv, patm, prcp, netprcp, zs, zb, z_volume ) - !$acc loop independent gang vector + !$acc parallel, present( tauwu, tauwv, patm, prcp, zs, zb, z_volume ) + !$acc loop gang vector do nm = 1, np ! if (wind) then tauwu(nm) = tauwu(nm) * smfac tauwv(nm) = tauwv(nm) * smfac - endif + endif ! if (patmos) then patm(nm) = patm(nm) * smfac + gapres * oneminsmfac endif ! if (precip) then - ! - netprcp(nm) = netprcp(nm) * smfac - ! - ! Don't allow negative netprcp during spinup (e.g. hardfixing infiltration/evaporation on model when forcing effective rainfall) when there's no water in the cell (same as check for constant infiltration) - ! - if (netprcp(nm) < 0.0) then - ! - ! No effective infiltration if there is no water - ! + ! + prcp(nm) = prcp(nm) * smfac + ! + ! Don't allow negative precip during spinup when there's no water in the cell + ! + if (prcp(nm) < 0.0) then + ! if (subgrid) then if (z_volume(nm) <= 0.0) then - netprcp(nm) = 0.0 + prcp(nm) = 0.0 endif else if (zs(nm) <= zb(nm)) then - netprcp(nm) = 0.0 + prcp(nm) = 0.0 endif - endif - ! - endif + endif + ! + endif endif ! enddo @@ -1419,13 +1412,34 @@ subroutine update_meteo_forcing(t, dt, tloop) ! if (prcpfile(1:4) /= 'none') then ! - call update_precipitation_from_timeseries(t, dt) + call update_precipitation_from_timeseries(t, dt) + ! + endif + ! + ! Apply rainfall to the point-source field qsrc (m3/s). prcp is m/s, + ! so multiply by cell area. qsrc was zeroed at the end of the previous + ! step inside the water-level update loops, so this is the first + ! accumulation into qsrc for the current step. + ! + if (precip) then + ! + !$acc parallel loop present( qsrc, prcp, cell_area, cell_area_m2, z_flags_iref ) + !$omp parallel do default(shared) private(nm) schedule(static) + do nm = 1, np + ! + if (crsgeo) then + qsrc(nm) = qsrc(nm) + prcp(nm) * cell_area_m2(nm) + else + qsrc(nm) = qsrc(nm) + prcp(nm) * cell_area(z_flags_iref(nm)) + endif + ! + enddo + !$omp end parallel do ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate - ! + call timer_stop('meteo forcing') + ! end subroutine @@ -1524,12 +1538,11 @@ subroutine update_precipitation_from_timeseries(t, dt) !$omp parallel & !$omp private ( nm ) !$omp do - !$acc parallel present( prcp, cumprcp, netprcp ) - !$acc loop independent gang vector + !$acc parallel present( prcp, cumprcp ) + !$acc loop gang vector do nm = 1, np ! prcp(nm) = ptmp - netprcp(nm) = ptmp ! if (store_cumulative_precipitation) then cumprcp(nm) = cumprcp(nm) + ptmp * dt @@ -1545,25 +1558,20 @@ subroutine update_precipitation_from_timeseries(t, dt) end subroutine - subroutine update_meteo_fields(t, tloop) + subroutine update_meteo_fields(t) ! ! Update values at boundary points ! use sfincs_data + use sfincs_timers ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! integer :: nm ! real*8 :: t ! - call system_clock(count0, count_rate, count_max) + call timer_start('meteo fields') ! if (amufile(1:4) /= 'none' .or. netamuamvfile(1:4) /= 'none') then ! @@ -1605,9 +1613,8 @@ subroutine update_meteo_fields(t, tloop) ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate - ! - end subroutine + call timer_stop('meteo fields') + ! + end subroutine end module diff --git a/source/src/sfincs_momentum.f90 b/source/src/sfincs_momentum.f90 index 66f9a2192..04e941f66 100644 --- a/source/src/sfincs_momentum.f90 +++ b/source/src/sfincs_momentum.f90 @@ -1,21 +1,16 @@ module sfincs_momentum ! use sfincs_data + use sfincs_timers ! implicit none ! contains ! - subroutine compute_fluxes(dt, tloop) + subroutine compute_fluxes(dt) ! ! Computes fluxes over subgrid u and v points ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*4 :: dt ! integer :: ip @@ -94,7 +89,7 @@ subroutine compute_fluxes(dt, tloop) ! logical :: iok ! - call system_clock(count0, count_rate, count_max) + call timer_start('momentum') ! min_dt = dtmax ! @@ -738,6 +733,7 @@ subroutine compute_fluxes(dt, tloop) ! timestep_analysis_required_timestep(ip) = min_dt_ip ! + endif ! else @@ -778,10 +774,9 @@ subroutine compute_fluxes(dt, tloop) ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + call timer_stop('momentum') ! - end subroutine + end subroutine ! ! function power7over3(hu) result(hu73) diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index 3c9686d4e..853a690a1 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -170,13 +170,21 @@ subroutine read_netcdf_boundary_data() - subroutine read_netcdf_discharge_data() + subroutine read_netcdf_discharge_data(netsrcdisfile, nr_discharge_points) ! - use sfincs_date + ! Read FEWS-compatible netCDF river-discharge input. netsrcdisfile is + ! passed in rather than pulled from a module to avoid a circular + ! dependency (the owning module sfincs_discharges `use`s this module + ! for the procedure). + ! + use sfincs_date use netcdf - use sfincs_data + use sfincs_data ! - implicit none + implicit none + ! + character(len=*), intent(in) :: netsrcdisfile + integer, intent(out) :: nr_discharge_points ! ! Variable names for Fews compatible netcdf input ! @@ -206,7 +214,7 @@ subroutine read_netcdf_discharge_data() ! ! Get dimensions sizes: time, stations NF90(nf90_inquire_dimension(net_file_srcdis%ncid, net_file_srcdis%time_dimid, len = ntsrc)) !nr of timesteps in file - NF90(nf90_inquire_dimension(net_file_srcdis%ncid, net_file_srcdis%points_dimid, len = nsrc)) !nr of discharge points + NF90(nf90_inquire_dimension(net_file_srcdis%ncid, net_file_srcdis%points_dimid, len = nr_discharge_points)) !nr of discharge points ! ! Get variable id's NF90(nf90_inq_varid(net_file_srcdis%ncid, x_varname, net_file_srcdis%x_varid) ) ! Has to be in the same UTM zone as SFINCS grid @@ -215,16 +223,16 @@ subroutine read_netcdf_discharge_data() NF90(nf90_inq_varid(net_file_srcdis%ncid, q_varname, net_file_srcdis%q_varid) ) ! ! Allocate variables - allocate(xsrc(nsrc)) - allocate(ysrc(nsrc)) + allocate(xsrc(nr_discharge_points)) + allocate(ysrc(nr_discharge_points)) allocate(tsrc(ntsrc)) - allocate(qsrc(nsrc,ntsrc)) + allocate(qsrc_ts(nr_discharge_points,ntsrc)) ! ! Read values NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%x_varid, xsrc(:)) ) NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%y_varid, ysrc(:)) ) - NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%time_varid, tsrc(:)) ) - NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%q_varid, qsrc(:,:)) ) + NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%time_varid, tsrc(:)) ) + NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%q_varid, qsrc_ts(:,:)) ) ! ! Read time attibute ! diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 2618849df..be977cb11 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -18,6 +18,7 @@ module sfincs_ncoutput integer :: zs_varid, zsmax_varid, h_varid, u_varid, v_varid, tmax_varid, Seff_varid, t_zsmax_varid integer :: zvolume_varid, storagevolume_varid integer :: hmax_varid, vmax_varid, qmax_varid, cumprcp_varid, cuminf_varid, windmax_varid + integer :: cumulative_urbdrain_varid integer :: patm_varid, wind_u_varid, wind_v_varid, precip_varid integer :: hm0_varid, hm0ig_varid, snapwavemsk_varid, tp_varid, tpig_varid, wavdir_varid, dirspr_varid integer :: fwx_varid, fwy_varid, beta_varid, snapwavedepth_varid @@ -45,14 +46,17 @@ module sfincs_ncoutput integer :: ncid integer :: time_dimid integer :: points_dimid, pointnamelength_dimid - integer :: crosssections_dimid, structures_dimid, thindams_dimid, drain_dimid, runup_gauges_dimid + integer :: crosssections_dimid, structures_dimid, thindams_dimid, drain_dimid, runup_gauges_dimid, river_dimid + integer :: urbdrain_dimid integer :: runtime_dimid integer :: point_x_varid, point_y_varid, station_x_varid, station_y_varid, crs_varid, qinf_varid, S_varid integer :: station_id_varid, station_name_varid integer :: crosssection_name_varid integer :: structure_height_varid, structure_x_varid, structure_y_varid integer :: thindam_x_varid, thindam_y_varid - integer :: drain_varid, drain_name_varid + integer :: drain_varid, drain_name_varid, breach_width_varid, drain_fraction_open_varid + integer :: river_varid, river_name_varid + integer :: urbdrain_varid, urbdrain_name_varid integer :: zb_varid integer :: time_varid integer :: zs_varid, h_varid, u_varid, v_varid, prcp_varid, cumprcp_varid, discharge_varid, uvmag_varid, uvdir_varid @@ -218,12 +222,16 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'suction head at the wetting front - Green and Ampt')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'm')) elseif (inftype == 'hor') then - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'f0')) - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'initial infiltration rate - Horton')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'f0')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'initial infiltration rate - Horton')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'm')) + elseif (inftype == 'bkt') then + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'bucket_capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'maximum bucket storage capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm')) else - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'qinf')) - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'infiltration rate - constant in time')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'qinf')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'infiltration rate - constant in time')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm h-1')) endif endif @@ -374,14 +382,25 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'coordinates', 'corner_x corner_y')) endif ! - ! Store current infiltration (only for Horton) + ! Store current infiltration capacity (only for Horton) ! if (inftype == 'hor') then - NF90(nf90_def_var(map_file%ncid, 'f', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%Seff_varid)) ! time-varying sigma - NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_def_var(map_file%ncid, 'f', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%Seff_varid)) ! time-varying f + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'units', 'mm h-1')) - NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'standard_name', 'sigma')) - NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'long_name', 'current infiltration capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'standard_name', 'f')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'long_name', 'current infiltration capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'coordinates', 'corner_x corner_y')) + endif + ! + ! Store current bucket storage (only for Bucket model) + ! + if (inftype == 'bkt') then + NF90(nf90_def_var(map_file%ncid, 'bucket_volume', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%Seff_varid)) ! time-varying bucket volume + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'standard_name', 'bucket_volume')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'long_name', 'current bucket storage')) NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'coordinates', 'corner_x corner_y')) endif ! @@ -407,7 +426,7 @@ subroutine ncoutput_regular_map_init() if (store_cumulative_precipitation) then NF90(nf90_def_var(map_file%ncid, 'cumprcp', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%timemax_dimid/), map_file%cumprcp_varid)) ! time-varying maximum water level map NF90(nf90_def_var_deflate(map_file%ncid, map_file%cumprcp_varid, 1, 1, nc_deflate_level)) ! deflate - NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'long_name', 'cumulative_precipitation_depth')) NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'standard_name', 'Cumulative precipitation depth')) @@ -415,6 +434,16 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'coordinates', 'x y')) endif ! + if (store_cumulative_urban_drainage .and. urban_drainage) then + NF90(nf90_def_var(map_file%ncid, 'urban_drainage_cumulative_depth', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%timemax_dimid/), map_file%cumulative_urbdrain_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%cumulative_urbdrain_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'long_name', 'cumulative_urban_drainage_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'cell_methods', 'time: sum')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'coordinates', 'x y')) + endif + ! if (store_twet) then NF90(nf90_def_var(map_file%ncid, 'tmax', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%timemax_dimid/), map_file%tmax_varid)) ! time-varying duration wet cell NF90(nf90_def_var_deflate(map_file%ncid, map_file%tmax_varid, 1, 1, nc_deflate_level)) ! deflate @@ -830,9 +859,9 @@ subroutine ncoutput_regular_map_init() ! ! Write infiltration map ! - if (infiltration) then + if (infiltration .and. allocated(qinffield)) then ! - zsg = FILL_VALUE + zsg = FILL_VALUE ! do nm = 1, np ! @@ -848,13 +877,29 @@ subroutine ncoutput_regular_map_init() zsg(m, n) = qinffield(nm) ! endif - ! + ! enddo ! NF90(nf90_put_var(map_file%ncid, map_file%qinf_varid, zsg, (/1, 1/))) ! write infiltration map ! endif ! + ! Write bucket capacity map (static) + ! + if (inftype == 'bkt' .and. allocated(bucket_capacity)) then + ! + zsg = FILL_VALUE + ! + do nm = 1, np + n = z_index_z_n(nm) + m = z_index_z_m(nm) + zsg(m, n) = bucket_capacity(nm) * 1000.0 ! m to mm + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%qinf_varid, zsg, (/1, 1/))) ! write bucket capacity map + ! + endif + ! ! write away intermediate data ! NF90(nf90_sync(map_file%ncid)) !write away intermediate data @@ -1084,12 +1129,29 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_def_var(map_file%ncid, 'crs', NF90_INT, map_file%crs_varid)) ! For EPSG code NF90(nf90_put_att(map_file%ncid, map_file%crs_varid, 'epsg', epsg)) NF90(nf90_put_att(map_file%ncid, map_file%crs_varid, 'epsg_code', 'EPSG:' // trim(epsg_code) )) !--> add epsg_code like FEWS wants - NF90(nf90_def_var(map_file%ncid, 'zb', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%zb_varid)) ! bed level in cell centre - NF90(nf90_def_var_deflate(map_file%ncid, map_file%zb_varid, 1, 1, nc_deflate_level)) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, '_FillValue', FILL_VALUE)) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'units', 'm')) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'standard_name', 'altitude')) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'Bed level above reference level')) + if (store_dynamic_bed_level) then + ! + ! Time-varying bed level: define zb with an extra time dimension + ! + NF90(nf90_def_var(map_file%ncid, 'zb', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%zb_varid)) ! bed level in cell centre + NF90(nf90_def_var_deflate(map_file%ncid, map_file%zb_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'standard_name', 'altitude')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'Bed level above reference level')) + ! + else + ! + ! Static bed level: define zb without a time dimension + ! + NF90(nf90_def_var(map_file%ncid, 'zb', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%zb_varid)) ! bed level in cell centre + NF90(nf90_def_var_deflate(map_file%ncid, map_file%zb_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'standard_name', 'altitude')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'Bed level above reference level')) + ! + endif ! if (.not. subgrid) then ! @@ -1320,13 +1382,24 @@ subroutine ncoutput_quadtree_map_init() ! NF90(nf90_def_var(map_file%ncid, 'cuminf', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%timemax_dimid/), map_file%cuminf_varid)) ! cumulative infiltration map NF90(nf90_def_var_deflate(map_file%ncid, map_file%cuminf_varid, 1, 1, nc_deflate_level)) - NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'long_name', 'Cumulative infiltration depth')) NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'cell_methods', 'time: sum')) ! endif ! + if (store_cumulative_urban_drainage .and. urban_drainage) then + ! + NF90(nf90_def_var(map_file%ncid, 'urban_drainage_cumulative_depth', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%timemax_dimid/), map_file%cumulative_urbdrain_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%cumulative_urbdrain_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'long_name', 'cumulative_urban_drainage_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'cell_methods', 'time: sum')) + ! + endif + ! if (store_meteo) then ! if (wind) then @@ -1498,12 +1571,16 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'suction head at the wetting front - Green and Ampt')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'm')) elseif (inftype == 'hor') then - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'f0')) - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'initial infiltration rate - Horton')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'f0')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'initial infiltration rate - Horton')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm h-1')) + elseif (inftype == 'bkt') then + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'bucket_capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'maximum bucket storage capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm')) else - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'qinf')) - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'infiltration rate - constant in time')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'qinf')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'infiltration rate - constant in time')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm h-1')) endif endif @@ -1589,22 +1666,30 @@ subroutine ncoutput_quadtree_map_init() ! vtmp = FILL_VALUE ! - if (subgrid) then - do nmq = 1, quadtree_nr_points - nm = index_sfincs_in_quadtree(nmq) - if (nm>0) then - vtmp(nmq) = subgrid_z_zmin(nm) - endif - enddo - NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp)) - else - do nmq = 1, quadtree_nr_points - nm = index_sfincs_in_quadtree(nmq) - if (nm>0) then - vtmp(nmq) = zb(nm) - endif - enddo - NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp)) + ! When store_dynamic_bed_level is enabled, zb has a time dimension, so the + ! static-shaped write is invalid here and must be skipped (the per-step + ! writer fills the variable instead). + ! + if (.not. store_dynamic_bed_level) then + ! + if (subgrid) then + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm>0) then + vtmp(nmq) = subgrid_z_zmin(nm) + endif + enddo + NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp)) + else + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm>0) then + vtmp(nmq) = zb(nm) + endif + enddo + NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp)) + endif + ! endif ! ! Subgrid slope @@ -1682,7 +1767,7 @@ subroutine ncoutput_quadtree_map_init() ! vtmp = FILL_VALUE ! - if (infiltration) then + if (infiltration .and. allocated(qinffield)) then ! if (inftype == 'con' .or. inftype == 'c2d') then do nmq = 1, quadtree_nr_points @@ -1690,20 +1775,37 @@ subroutine ncoutput_quadtree_map_init() if (nm>0) then vtmp(nmq) = qinffield(nm) * 3600 * 1000 endif - enddo + enddo else do nmq = 1, quadtree_nr_points nm = index_sfincs_in_quadtree(nmq) if (nm>0) then vtmp(nmq) = qinffield(nm) endif - enddo + enddo endif ! NF90(nf90_put_var(map_file%ncid, map_file%qinf_varid, vtmp)) ! write infiltration map ! endif ! + ! Write bucket capacity map (static) + ! + if (inftype == 'bkt' .and. allocated(bucket_capacity)) then + ! + vtmp = FILL_VALUE + ! + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm>0) then + vtmp(nmq) = bucket_capacity(nm) * 1000.0 ! m to mm + endif + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%qinf_varid, vtmp)) ! write bucket capacity map + ! + endif + ! ! Write vegetation fields (static, written once at init) ! if (store_vegetation) then @@ -1771,13 +1873,16 @@ subroutine ncoutput_his_init() ! 2. write grid/msk/zb to file ! use sfincs_date - use sfincs_data + use sfincs_data use sfincs_structures + use sfincs_src_structures, only: nr_src_structures, src_struc_name, src_struc_type, structure_dike_breach + use sfincs_discharges, only: src_name, nr_discharge_points + use sfincs_urban_drainage, only: nr_urban_drainage_zones, urb_zone_name ! - implicit none + implicit none + ! + integer :: istruc ! - integer :: istruc - ! real*4, dimension(:,:), allocatable :: struc_info real*4, dimension(:), allocatable :: struc_x real*4, dimension(:), allocatable :: struc_y @@ -1785,9 +1890,13 @@ subroutine ncoutput_his_init() ! real*4, dimension(:,:), allocatable :: thindam_info real*4, dimension(:), allocatable :: thindam_x - real*4, dimension(:), allocatable :: thindam_y + real*4, dimension(:), allocatable :: thindam_y + ! + character*256, dimension(:), allocatable :: drain_name_buf + character*256, dimension(:), allocatable :: river_name_buf + character*256, dimension(:), allocatable :: urbdrain_name_buf ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. ndrn==0 .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains or run-up gauges; his file is not created + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nr_src_structures==0 .and. .not. (nr_discharge_points>0 .and. store_river_discharge) .and. .not. (nr_urban_drainage_zones>0 .and. store_urban_drainage_discharge) .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources, urban drainage zones or run-up gauges; his file is not created return endif ! @@ -1807,11 +1916,19 @@ subroutine ncoutput_his_init() NF90(nf90_def_dim(his_file%ncid, 'crosssections', nrcrosssections, his_file%crosssections_dimid)) ! nr of crosssections endif ! - if (ndrn>0) then - NF90(nf90_def_dim(his_file%ncid, 'drainage', ndrn, his_file%drain_dimid)) ! nr of drainage structures + if (nr_src_structures>0) then + NF90(nf90_def_dim(his_file%ncid, 'drainage', nr_src_structures, his_file%drain_dimid)) ! nr of drainage structures + endif + ! + if (nr_discharge_points>0 .and. store_river_discharge) then + NF90(nf90_def_dim(his_file%ncid, 'rivers', nr_discharge_points, his_file%river_dimid)) ! nr of river point sources endif ! - if (nrstructures>0) then + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + NF90(nf90_def_dim(his_file%ncid, 'urban_drainage_zones', nr_urban_drainage_zones, his_file%urbdrain_dimid)) ! nr of urban drainage zones + endif + ! + if (nrstructures>0) then NF90(nf90_def_dim(his_file%ncid, 'structures', nrstructures, his_file%structures_dimid)) ! nr of structures (weir) endif ! @@ -1852,9 +1969,21 @@ subroutine ncoutput_his_init() ! if (nr_runup_gauges > 0) then NF90(nf90_def_var(his_file%ncid, 'runup_gauge_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%runup_gauges_dimid/), his_file%runup_gauge_name_varid)) - endif + endif ! - !NF90(nf90_put_att(his_file%ncid, his_file%station_name_varid, 'units', '-')) !not wanted in fews + if (nr_src_structures > 0) then + NF90(nf90_def_var(his_file%ncid, 'drainage_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%drain_dimid/), his_file%drain_name_varid)) + endif + ! + if (nr_discharge_points > 0 .and. store_river_discharge) then + NF90(nf90_def_var(his_file%ncid, 'river_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%river_dimid/), his_file%river_name_varid)) + endif + ! + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + NF90(nf90_def_var(his_file%ncid, 'urban_drainage_zone_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%urbdrain_dimid/), his_file%urbdrain_name_varid)) + endif + ! + !NF90(nf90_put_att(his_file%ncid, his_file%station_name_varid, 'units', '-')) !not wanted in fews ! ! Domain NF90(nf90_def_var(his_file%ncid, 'station_x', NF90_FLOAT, (/his_file%points_dimid/), his_file%station_x_varid)) ! non snapped input coordinate @@ -2017,9 +2146,29 @@ subroutine ncoutput_his_init() ! if (inftype == 'gai') then NF90(nf90_def_var(his_file%ncid, 'point_S', NF90_FLOAT, (/his_file%points_dimid, his_file%time_dimid/), his_file%S_varid)) ! time-varying S - NF90(nf90_put_att(his_file%ncid, his_file%S_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'units', 'm')) - NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'long_name', 'maximum soil moisture deficit')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'long_name', 'maximum soil moisture deficit')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'coordinates', 'station_id station_name point_x point_y')) + endif + ! + ! More output for Horton method + ! + if (inftype == 'hor') then + NF90(nf90_def_var(his_file%ncid, 'point_S', NF90_FLOAT, (/his_file%points_dimid, his_file%time_dimid/), his_file%S_varid)) ! time-varying f + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'units', 'mm hr-1')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'long_name', 'current infiltration capacity')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'coordinates', 'station_id station_name point_x point_y')) + endif + ! + ! More output for Bucket model + ! + if (inftype == 'bkt') then + NF90(nf90_def_var(his_file%ncid, 'point_S', NF90_FLOAT, (/his_file%points_dimid, his_file%time_dimid/), his_file%S_varid)) ! time-varying bucket volume + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'units', 'm')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'long_name', 'current bucket storage')) NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'coordinates', 'station_id station_name point_x point_y')) endif ! @@ -2203,15 +2352,49 @@ subroutine ncoutput_his_init() ! endif ! - if (ndrn>0) then + if (nr_src_structures>0) then ! NF90(nf90_def_var(his_file%ncid, 'drainage_discharge', NF90_FLOAT, (/his_file%drain_dimid, his_file%time_dimid/), his_file%drain_varid)) ! time-varying discharge through drainage structure - NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'units', 'm3 s-1')) NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'long_name', 'discharge through drainage structure')) NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'coordinates', 'drainage_name')) ! - endif + if (any(src_struc_type == structure_dike_breach)) then + NF90(nf90_def_var(his_file%ncid, 'breach_width', NF90_FLOAT, (/his_file%drain_dimid, his_file%time_dimid/), his_file%breach_width_varid)) + NF90(nf90_put_att(his_file%ncid, his_file%breach_width_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%breach_width_varid, 'units', 'm')) + NF90(nf90_put_att(his_file%ncid, his_file%breach_width_varid, 'long_name', 'dike breach width')) + NF90(nf90_put_att(his_file%ncid, his_file%breach_width_varid, 'coordinates', 'drainage_name')) + endif + ! + NF90(nf90_def_var(his_file%ncid, 'drainage_fraction_open', NF90_FLOAT, (/his_file%drain_dimid, his_file%time_dimid/), his_file%drain_fraction_open_varid)) ! time-varying gate open fraction (1=open, 0=closed) + NF90(nf90_put_att(his_file%ncid, his_file%drain_fraction_open_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%drain_fraction_open_varid, 'units', '1')) + NF90(nf90_put_att(his_file%ncid, his_file%drain_fraction_open_varid, 'long_name', 'gate open fraction (1 = fully open, 0 = fully closed)')) + NF90(nf90_put_att(his_file%ncid, his_file%drain_fraction_open_varid, 'coordinates', 'drainage_name')) + ! + endif + ! + if (nr_discharge_points>0 .and. store_river_discharge) then + ! + NF90(nf90_def_var(his_file%ncid, 'river_discharge', NF90_FLOAT, (/his_file%river_dimid, his_file%time_dimid/), his_file%river_varid)) ! time-varying river point discharge + NF90(nf90_put_att(his_file%ncid, his_file%river_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'units', 'm3 s-1')) + NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'long_name', 'river point discharge')) + NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'coordinates', 'river_name')) + ! + endif + ! + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + ! + NF90(nf90_def_var(his_file%ncid, 'urban_drainage_discharge', NF90_FLOAT, (/his_file%urbdrain_dimid, his_file%time_dimid/), his_file%urbdrain_varid)) ! per-zone outfall discharge + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'units', 'm3 s-1')) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'long_name', 'urban drainage zone net outfall discharge')) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'coordinates', 'urban_drainage_zone_name')) + ! + endif ! if (nr_runup_gauges > 0) then ! @@ -2251,7 +2434,62 @@ subroutine ncoutput_his_init() ! if (nr_runup_gauges > 0) then NF90(nf90_put_var(his_file%ncid, his_file%runup_gauge_name_varid, runup_gauge_name)) ! write rug name - endif + endif + ! + if (nr_src_structures > 0) then + ! + ! Copy src_struc_name (length src_struc_name_len = 128) into a length-256 buffer + ! to match the pointnamelength netCDF dimension used for all his_file name + ! variables. + ! + allocate(drain_name_buf(nr_src_structures)) + ! + do istruc = 1, nr_src_structures + ! + drain_name_buf(istruc) = src_struc_name(istruc) + ! + enddo + ! + NF90(nf90_put_var(his_file%ncid, his_file%drain_name_varid, drain_name_buf)) ! write drainage_name + ! + deallocate(drain_name_buf) + ! + endif + ! + if (nr_discharge_points > 0 .and. store_river_discharge) then + ! + ! Copy src_name (length src_name_len) into a length-256 buffer to match + ! the pointnamelength netCDF dimension. + ! + allocate(river_name_buf(nr_discharge_points)) + ! + do istruc = 1, nr_discharge_points + ! + river_name_buf(istruc) = src_name(istruc) + ! + enddo + ! + NF90(nf90_put_var(his_file%ncid, his_file%river_name_varid, river_name_buf)) ! write river_name + ! + deallocate(river_name_buf) + ! + endif + ! + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + ! + allocate(urbdrain_name_buf(nr_urban_drainage_zones)) + ! + do istruc = 1, nr_urban_drainage_zones + ! + urbdrain_name_buf(istruc) = urb_zone_name(istruc) + ! + enddo + ! + NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_name_varid, urbdrain_name_buf)) ! write urban_drainage_zone_name + ! + deallocate(urbdrain_name_buf) + ! + endif ! if (nrstructures>0) then ! @@ -2358,20 +2596,24 @@ subroutine ncoutput_update_regular_map(t,ntmapout) ! NF90(nf90_put_var(map_file%ncid, map_file%zs_varid, zsg, (/1, 1, ntmapout/))) ! write zs ! - if (store_dynamic_bed_level .and. .not. subgrid) then + if (store_dynamic_bed_level) then ! do nm = 1, np ! n = z_index_z_n(nm) m = z_index_z_m(nm) - ! - zsg(m, n) = zb(nm) - ! + ! + if (subgrid) then + zsg(m, n) = subgrid_z_zmin(nm) + else + zsg(m, n) = zb(nm) + endif + ! enddo ! - NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, zsg, (/1, 1, ntmapout/))) ! write zb + NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, zsg, (/1, 1, ntmapout/))) ! write zb (subgrid_z_zmin for subgrid runs) ! - endif + endif ! if (subgrid .eqv. .false. .or. store_hsubgrid .eqv. .true.) then ! @@ -2521,13 +2763,30 @@ subroutine ncoutput_update_regular_map(t,ntmapout) ! n = z_index_z_n(nm) m = z_index_z_m(nm) - ! + ! zsg(m, n) = qinfmap(nm) ! enddo ! NF90(nf90_put_var(map_file%ncid, map_file%Seff_varid, zsg, (/1, 1, ntmapout/))) ! + elseif (inftype == 'bkt') then + ! + ! Store current bucket volume + ! + zsg = FILL_VALUE + ! + do nm = 1, np + ! + n = z_index_z_n(nm) + m = z_index_z_m(nm) + ! + zsg(m, n) = bucket_volume(nm) + ! + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%Seff_varid, zsg, (/1, 1, ntmapout/))) + ! endif ! if (store_meteo) then @@ -2808,8 +3067,34 @@ subroutine ncoutput_update_quadtree_map(t,ntmapout) enddo ! NF90(nf90_put_var(map_file%ncid, map_file%zs_varid, vtmp, (/1, ntmapout/))) ! write zs - ! - ! Water depth + ! + ! Time-varying bed level + ! + if (store_dynamic_bed_level) then + ! + vtmp = FILL_VALUE + ! + do nmq = 1, quadtree_nr_points + ! + nm = index_sfincs_in_quadtree(nmq) + ! + if (nm>0) then + ! + if (subgrid) then + vtmp(nmq) = subgrid_z_zmin(nm) + else + vtmp(nmq) = zb(nm) + endif + ! + endif + ! + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp, (/1, ntmapout/))) ! write zb (subgrid_z_zmin for subgrid runs) + ! + endif + ! + ! Water depth ! if (subgrid .eqv. .false. .or. store_hsubgrid .eqv. .true.) then ! @@ -3159,14 +3444,17 @@ subroutine ncoutput_update_quadtree_map(t,ntmapout) subroutine ncoutput_update_his(t,nthisout) ! Write time, zs, u, v, prcp of points ! - use sfincs_data + use sfincs_data use sfincs_crosssections use sfincs_runup_gauges use sfincs_snapwave + use sfincs_src_structures, only: nr_src_structures, src_struc_q_now, src_struc_breach_width, src_struc_type, structure_dike_breach, src_struc_fraction_open + use sfincs_discharges, only: qtsrc, nr_discharge_points + use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_total ! - implicit none + implicit none ! - integer :: iobs, nm, idrn + integer :: iobs, nm, istruc ! integer :: nthisout integer :: nmd1, nmu1, ndm1, num1 @@ -3192,7 +3480,6 @@ subroutine ncoutput_update_his(t,nthisout) real*4, dimension(nobs) :: tpigobs real*4, dimension(nobs) :: wavdirobs real*4, dimension(nobs) :: dirsprobs - real*4, dimension(ndrn) :: q_drain real*4, dimension(nobs) :: dwobs real*4, dimension(nobs) :: dfobs real*4, dimension(nobs) :: dwigobs @@ -3218,7 +3505,6 @@ subroutine ncoutput_update_his(t,nthisout) tpatm = FILL_VALUE twndmag = FILL_VALUE twnddir = FILL_VALUE - q_drain = FILL_VALUE dwobs = FILL_VALUE dfobs = FILL_VALUE cgobs = FILL_VALUE @@ -3271,10 +3557,12 @@ subroutine ncoutput_update_his(t,nthisout) elseif (inftype == 'gai') then ! tS_effective(iobs) = GA_sigma(nm) - ! + elseif (inftype == 'hor') then + tS_effective(iobs) = qinfmap(nm)*3.6e3*1.0e3 ! current f in mm/hr + elseif (inftype == 'bkt') then + tS_effective(iobs) = bucket_volume(nm) ! current bucket storage in m endif - ! - endif + endif ! if (store_meteo) then ! @@ -3359,9 +3647,7 @@ subroutine ncoutput_update_his(t,nthisout) ! NF90(nf90_put_var(his_file%ncid, his_file%qinf_varid, tqinf, (/1, nthisout/))) ! write qinf ! - if (inftype == 'cnb') then - NF90(nf90_put_var(his_file%ncid, his_file%S_varid, tS_effective, (/1, nthisout/))) ! write S - elseif (inftype == 'gai') then + if (inftype == 'cnb' .or. inftype == 'gai' .or. inftype == 'hor' .or. inftype == 'bkt') then NF90(nf90_put_var(his_file%ncid, his_file%S_varid, tS_effective, (/1, nthisout/))) ! write S endif ! @@ -3456,19 +3742,32 @@ subroutine ncoutput_update_his(t,nthisout) ! endif ! - if (ndrn>0) then + if (nr_src_structures>0) then + ! + !$acc update host(src_struc_q_now, src_struc_fraction_open) + ! + NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, src_struc_q_now, (/1, nthisout/))) ! write per-structure discharge + NF90(nf90_put_var(his_file%ncid, his_file%drain_fraction_open_varid, src_struc_fraction_open, (/1, nthisout/))) ! write per-structure gate open fraction + ! + if (any(src_struc_type == structure_dike_breach)) then + !$acc update host(src_struc_breach_width) + NF90(nf90_put_var(his_file%ncid, his_file%breach_width_varid, src_struc_breach_width, (/1, nthisout/))) ! write breach width + endif + ! + endif + ! + if (nr_discharge_points>0 .and. store_river_discharge) then ! !$acc update host(qtsrc) - ! Get fluxes through drainage structure ! - idrn = 0 - do iobs = nsrc + 1, nsrcdrn, 2 !TL: as in sfincs_output.f90 - idrn = idrn + 1 - q_drain(idrn) = qtsrc(iobs) - enddo + NF90(nf90_put_var(his_file%ncid, his_file%river_varid, qtsrc, (/1, nthisout/))) ! write per-river-source discharge + ! + endif + ! + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + ! + NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_varid, urban_drainage_q_total, (/1, nthisout/))) ! write per-zone total discharge ! - NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, q_drain, (/1, nthisout/))) ! write discharge of sink point - ! endif ! if (store_velocity) then @@ -3490,9 +3789,10 @@ subroutine ncoutput_update_max(t,ntmaxout) ! ! write zsmax per dtmaxout ! - use sfincs_data + use sfincs_data + use sfincs_urban_drainage, only: urban_drainage_cumulative_volume ! - implicit none + implicit none ! integer :: nm, n, m ! @@ -3614,7 +3914,30 @@ subroutine ncoutput_update_max(t,ntmaxout) zstmp(m, n) = cuminf(nm) enddo ! - NF90(nf90_put_var(map_file%ncid, map_file%cuminf_varid, zstmp, (/1, 1, ntmaxout/))) ! write cuminf + NF90(nf90_put_var(map_file%ncid, map_file%cuminf_varid, zstmp, (/1, 1, ntmaxout/))) ! write cuminf + ! + endif + ! + ! Cumulative urban drainage depth (volume / cell_area) + ! + if (store_cumulative_urban_drainage .and. urban_drainage) then + ! + zstmp = FILL_VALUE + ! + do nm = 1, np + ! + n = z_index_z_n(nm) + m = z_index_z_m(nm) + ! + if (crsgeo) then + zstmp(m, n) = urban_drainage_cumulative_volume(nm) / cell_area_m2(nm) + else + zstmp(m, n) = urban_drainage_cumulative_volume(nm) / cell_area(z_flags_iref(nm)) + endif + ! + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%cumulative_urbdrain_varid, zstmp, (/1, 1, ntmaxout/))) ! write cumulative urban drainage depth ! endif ! @@ -3687,11 +4010,12 @@ subroutine ncoutput_update_quadtree_max(t,ntmaxout) ! ! write zsmax per dtmaxout ! - use sfincs_data + use sfincs_data !use sfincs_snapwave use quadtree + use sfincs_urban_drainage, only: urban_drainage_cumulative_volume ! - implicit none + implicit none ! integer :: nmq, nm, ntmaxout real*8 :: t @@ -3815,9 +4139,32 @@ subroutine ncoutput_update_quadtree_max(t,ntmaxout) endif endif enddo - NF90(nf90_put_var(map_file%ncid, map_file%cuminf_varid, zstmp, (/1, ntmaxout/))) ! write cuminf - ! - endif + NF90(nf90_put_var(map_file%ncid, map_file%cuminf_varid, zstmp, (/1, ntmaxout/))) ! write cuminf + ! + endif + ! + ! Cumulative urban drainage depth (volume / cell_area) + ! + if (store_cumulative_urban_drainage .and. urban_drainage) then + ! + zstmp = FILL_VALUE + ! + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm > 0) then + if (kcs(nm) > 0) then + if (crsgeo) then + zstmp(nmq) = urban_drainage_cumulative_volume(nm) / cell_area_m2(nm) + else + zstmp(nmq) = urban_drainage_cumulative_volume(nm) / cell_area(z_flags_iref(nm)) + endif + endif + endif + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%cumulative_urbdrain_varid, zstmp, (/1, ntmaxout/))) ! write cumulative urban drainage depth + ! + endif ! ! Maximum flow velocity if (store_maximum_velocity) then @@ -3893,13 +4240,14 @@ subroutine ncoutput_update_quadtree_max(t,ntmaxout) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - subroutine ncoutput_map_finalize() + subroutine ncoutput_map_finalize() ! ! Add total runtime, dtavg to file and close ! use sfincs_data - ! - implicit none + use sfincs_timers, only: timer_elapsed + ! + implicit none ! if (store_tsunami_arrival_time) then ! @@ -3911,9 +4259,9 @@ subroutine ncoutput_map_finalize() ! call ncoutput_write_timestep_analysis() ! - endif + endif ! - NF90(nf90_put_var(map_file%ncid, map_file%total_runtime_varid, tfinish_all - tstart_all)) + NF90(nf90_put_var(map_file%ncid, map_file%total_runtime_varid, real(timer_elapsed('simulation'), 4))) NF90(nf90_put_var(map_file%ncid, map_file%average_dt_varid, dtavg)) NF90(nf90_put_var(map_file%ncid, map_file%status_varid, error)) ! @@ -4051,14 +4399,18 @@ subroutine ncoutput_his_finalize() ! Add total runtime, dtavg to file and close ! use sfincs_data - ! - implicit none - ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. ndrn==0) then ! If no observation points, cross-sections, structures 9weir or thin dam), or drains; hisfile + use sfincs_src_structures, only: nr_src_structures + use sfincs_discharges, only: nr_discharge_points + use sfincs_timers, only: timer_elapsed + use sfincs_urban_drainage, only: nr_urban_drainage_zones + ! + implicit none + ! + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. nr_src_structures==0 .and. .not. (nr_discharge_points>0 .and. store_river_discharge) .and. .not. (nr_urban_drainage_zones>0 .and. store_urban_drainage_discharge)) then ! If no observation points, cross-sections, structures (weir or thin dam), drains, river sources or urban drainage zones; hisfile return - endif + endif ! - NF90(nf90_put_var(his_file%ncid, his_file%total_runtime_varid, tfinish_all - tstart_all)) + NF90(nf90_put_var(his_file%ncid, his_file%total_runtime_varid, real(timer_elapsed('simulation'), 4))) NF90(nf90_put_var(his_file%ncid, his_file%average_dt_varid, dtavg)) NF90(nf90_put_var(his_file%ncid, his_file%status_varid, error)) ! @@ -4071,6 +4423,8 @@ subroutine ncoutput_his_finalize() subroutine ncoutput_add_params(ncid, varid) ! Add user params to netcdf file (both map & his) use sfincs_data + use sfincs_src_structures, only: drnfile + use sfincs_discharges, only: srcfile, disfile, netsrcdisfile ! ! Because of overlapping names, only important specific values from snapwave_data use snapwave_data, only: gamma, gammax, alpha, hmin, fw0, fw0_ig, dt, tol, dtheta, crit, nr_sweeps, baldock_exponent, baldock_ratio, & @@ -4206,13 +4560,18 @@ subroutine ncoutput_add_params(ncid, varid) NF90(nf90_put_att(ncid, varid, 'amvfile',amvfile)) NF90(nf90_put_att(ncid, varid, 'ampfile',ampfile)) NF90(nf90_put_att(ncid, varid, 'amprfile',amprfile)) - NF90(nf90_put_att(ncid, varid, 'qinffile',qinffile)) + NF90(nf90_put_att(ncid, varid, 'infiltrationfile',infiltrationfile)) + NF90(nf90_put_att(ncid, varid, 'infiltrationtype',inftype)) + NF90(nf90_put_att(ncid, varid, 'qinffile',qinffile)) NF90(nf90_put_att(ncid, varid, 'scsfile',scsfile)) NF90(nf90_put_att(ncid, varid, 'smaxfile',smaxfile)) NF90(nf90_put_att(ncid, varid, 'sefffile',sefffile)) NF90(nf90_put_att(ncid, varid, 'ksfile',ksfile)) NF90(nf90_put_att(ncid, varid, 'psifile',psifile)) NF90(nf90_put_att(ncid, varid, 'sigmafile',sigmafile)) + NF90(nf90_put_att(ncid, varid, 'f0file',f0file)) + NF90(nf90_put_att(ncid, varid, 'fcfile',fcfile)) + NF90(nf90_put_att(ncid, varid, 'kdfile',kdfile)) NF90(nf90_put_att(ncid, varid, 'z0lfile',z0lfile)) NF90(nf90_put_att(ncid, varid, 'wavemaker_wvmfile',wavemaker_wvmfile)) ! @@ -4230,20 +4589,20 @@ subroutine ncoutput_add_params(ncid, varid) NF90(nf90_put_att(ncid, varid, 'nobs',nobs)) NF90(nf90_put_att(ncid, varid, 'crsfile',crsfile)) ! - NF90(nf90_put_att(ncid, varid, 'storevelmax',storevelmax)) - NF90(nf90_put_att(ncid, varid, 'storefluxmax',storefluxmax)) - NF90(nf90_put_att(ncid, varid, 'storevel',storevel)) - NF90(nf90_put_att(ncid, varid, 'storecumprcp',storecumprcp)) - NF90(nf90_put_att(ncid, varid, 'storetwet',storetwet)) - NF90(nf90_put_att(ncid, varid, 'storehsubgrid',storehsubgrid)) - NF90(nf90_put_att(ncid, varid, 'twet_threshold',twet_threshold)) - NF90(nf90_put_att(ncid, varid, 'store_tsunami_arrival_time',logical2int(store_tsunami_arrival_time))) - NF90(nf90_put_att(ncid, varid, 'tsunami_arrival_threshold',tsunami_arrival_threshold)) - NF90(nf90_put_att(ncid, varid, 'storeqdrain',storeqdrain)) - NF90(nf90_put_att(ncid, varid, 'storezvolume',storezvolume)) - NF90(nf90_put_att(ncid, varid, 'writeruntime',wrttimeoutput)) - NF90(nf90_put_att(ncid, varid, 'debug',logical2int(debug))) - NF90(nf90_put_att(ncid, varid, 'storemeteo',storemeteo)) + NF90(nf90_put_att(ncid, varid, 'storevelmax',logical2int(store_maximum_velocity))) + NF90(nf90_put_att(ncid, varid, 'storefluxmax',logical2int(store_maximum_flux))) + NF90(nf90_put_att(ncid, varid, 'storevel',logical2int(store_velocity))) + NF90(nf90_put_att(ncid, varid, 'storecumprcp',logical2int(store_cumulative_precipitation))) + NF90(nf90_put_att(ncid, varid, 'storetwet',logical2int(store_twet))) + NF90(nf90_put_att(ncid, varid, 'storehsubgrid',logical2int(store_hsubgrid))) + NF90(nf90_put_att(ncid, varid, 'twet_threshold',twet_threshold)) + NF90(nf90_put_att(ncid, varid, 'store_tsunami_arrival_time',logical2int(store_tsunami_arrival_time))) + NF90(nf90_put_att(ncid, varid, 'tsunami_arrival_threshold',tsunami_arrival_threshold)) + NF90(nf90_put_att(ncid, varid, 'storeqdrain',logical2int(store_qdrain))) + NF90(nf90_put_att(ncid, varid, 'storezvolume',logical2int(store_zvolume))) + NF90(nf90_put_att(ncid, varid, 'writeruntime',logical2int(write_time_output))) + NF90(nf90_put_att(ncid, varid, 'debug',logical2int(debug))) + NF90(nf90_put_att(ncid, varid, 'storemeteo',logical2int(store_meteo))) NF90(nf90_put_att(ncid, varid, 'storemaxwind',logical2int(store_wind_max))) NF90(nf90_put_att(ncid, varid, 'storefw',logical2int(store_wave_forces))) NF90(nf90_put_att(ncid, varid, 'storewavdir', logical2int(store_wave_direction))) diff --git a/source/src/sfincs_nonhydrostatic.f90 b/source/src/sfincs_nonhydrostatic.f90 index 6200a1b5b..e8214f830 100644 --- a/source/src/sfincs_nonhydrostatic.f90 +++ b/source/src/sfincs_nonhydrostatic.f90 @@ -388,21 +388,16 @@ subroutine initialize_nonhydrostatic() end subroutine - subroutine compute_nonhydrostatic(dt, tloop) + subroutine compute_nonhydrostatic(dt) ! - ! Non-hydrostatic pressure correction on fluxes and velocities + ! Non-hydrostatic pressure correction on fluxes and velocities ! use sfincs_data + use sfincs_timers use bicgstab_solver_ilu ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*4 :: dt ! integer :: ip @@ -439,7 +434,7 @@ subroutine compute_nonhydrostatic(dt, tloop) real*4, dimension(:), allocatable :: AA real*4 :: relres ! - call system_clock(count0, count_rate, count_max) + call timer_start('non-hydrostatic') ! allocate(QQ(nrows)) allocate(AA(nr_vals_in_matrix)) @@ -738,9 +733,8 @@ subroutine compute_nonhydrostatic(dt, tloop) !$omp end do !$omp end parallel ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + call timer_stop('non-hydrostatic') ! - end subroutine + end subroutine end module diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 5f090b64c..dfdf9a333 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -1,6 +1,17 @@ module sfincs_openacc ! use sfincs_data + use sfincs_src_structures + use sfincs_discharges, only: qtsrc, nmindsrc + use sfincs_rule_expression, only: rule_opcode, rule_atom, rule_cmp, rule_threshold, & + rule_start, rule_length + use sfincs_urban_drainage, only: urban_drainage_zone_indices, urban_drainage_outfall_index, & + urban_drainage_qmax, urban_drainage_backflow_coef, & + urban_drainage_q_total, urban_drainage_cumulative_volume, & + urb_zone_type_id, urb_zone_injection_rate, urb_zone_maximum_capacity, & + urb_zone_cumulative_injection, & + urb_zone_h_threshold, urb_zone_check_valve, & + urb_zone_dh_design_min ! implicit none ! @@ -21,7 +32,21 @@ subroutine initialize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc nmindsrc, qtsrc, drainage_type, drainage_params, & + !$acc qsrc, qtsrc, src_struc_q_now, nmindsrc, src_struc_nm_s1, src_struc_nm_s2, src_struc_type, & + !$acc src_struc_direction, & + !$acc src_struc_nm_o1, src_struc_nm_o2, & + !$acc src_struc_q, src_struc_flow_coef, & + !$acc src_struc_width, src_struc_sill_elevation, src_struc_mannings_n, & + !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_height, & + !$acc src_struc_invert_1, src_struc_invert_2, & + !$acc src_struc_submergence_ratio, & + !$acc src_struc_z_crest, src_struc_t_breach, src_struc_z_min, & + !$acc src_struc_B0, src_struc_t0, src_struc_dike_core, & + !$acc src_struc_breach_width, src_struc_breach_level, & + !$acc src_struc_distance, src_struc_fraction_open, & + !$acc src_struc_rule_start, src_struc_rule_count, rule_list_op, rule_list_id, & + !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc wavemaker_index_uv, wavemaker_index_nmi, wavemaker_index_nmb, & !$acc wavemaker_idir, wavemaker_angfac, wavemaker_uvtrend, & @@ -40,7 +65,13 @@ subroutine initialize_openacc() !$acc gnapp2, & !$acc timestep_analysis_required_timestep, timestep_analysis_average_required_timestep, timestep_analysis_times_wet, timestep_analysis_times_limiting, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & - !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0 ) + !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & + !$acc bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & + !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, urban_drainage_qmax, urban_drainage_backflow_coef, & + !$acc urban_drainage_q_total, urban_drainage_cumulative_volume, & + !$acc urb_zone_type_id, urb_zone_injection_rate, urb_zone_maximum_capacity, & + !$acc urb_zone_cumulative_injection, & + !$acc urb_zone_h_threshold, urb_zone_check_valve, urb_zone_dh_design_min ) ! end subroutine ! @@ -55,7 +86,21 @@ subroutine finalize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc nmindsrc, qtsrc, drainage_type, drainage_params, & + !$acc qsrc, qtsrc, src_struc_q_now, nmindsrc, src_struc_nm_s1, src_struc_nm_s2, src_struc_type, & + !$acc src_struc_direction, & + !$acc src_struc_nm_o1, src_struc_nm_o2, & + !$acc src_struc_q, src_struc_flow_coef, & + !$acc src_struc_width, src_struc_sill_elevation, src_struc_mannings_n, & + !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_height, & + !$acc src_struc_invert_1, src_struc_invert_2, & + !$acc src_struc_submergence_ratio, & + !$acc src_struc_z_crest, src_struc_t_breach, src_struc_z_min, & + !$acc src_struc_B0, src_struc_t0, src_struc_dike_core, & + !$acc src_struc_breach_width, src_struc_breach_level, & + !$acc src_struc_distance, src_struc_fraction_open, & + !$acc src_struc_rule_start, src_struc_rule_count, rule_list_op, rule_list_id, & + !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc wavemaker_index_uv, wavemaker_index_nmi, wavemaker_index_nmb, & !$acc wavemaker_idir, wavemaker_angfac, wavemaker_uvtrend, & @@ -66,7 +111,7 @@ subroutine finalize_openacc() !$acc tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & !$acc patm, patm0, patm1, patmb, nmindbnd, & - !$acc prcp, prcp0, prcp1, cumprcp, netprcp, prcp, qext, & + !$acc prcp, prcp0, prcp1, cumprcp, qext, & !$acc dxminv, dxrinv, dyrinv, dxm2inv, dxr2inv, dyr2inv, dxrinvc, dxm, dxrm, dyrm, cell_area_m2, cell_area, & !$acc gn2uv, fcorio2d, storage_volume, nuvisc, & !$acc cuv_index_uv, cuv_index_uv1, cuv_index_uv2, & @@ -74,8 +119,14 @@ subroutine finalize_openacc() !$acc gnapp2, & !$acc timestep_analysis_required_timestep, timestep_analysis_average_required_timestep, timestep_analysis_times_wet, timestep_analysis_times_limiting, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & - !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0 ) + !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & + !$acc bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & + !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, urban_drainage_qmax, urban_drainage_backflow_coef, & + !$acc urban_drainage_q_total, urban_drainage_cumulative_volume, & + !$acc urb_zone_type_id, urb_zone_injection_rate, urb_zone_maximum_capacity, & + !$acc urb_zone_cumulative_injection, & + !$acc urb_zone_h_threshold, urb_zone_check_valve, urb_zone_dh_design_min ) ! - end subroutine finalize_openacc + end ! end module diff --git a/source/src/sfincs_output.f90 b/source/src/sfincs_output.f90 index 6137dcd4a..5f00efa6a 100644 --- a/source/src/sfincs_output.f90 +++ b/source/src/sfincs_output.f90 @@ -8,6 +8,7 @@ module sfincs_output subroutine initialize_output(tmapout,tmaxout,thisout, trstout) ! use sfincs_data + use sfincs_src_structures, only: nr_src_structures ! implicit none ! @@ -62,7 +63,7 @@ subroutine initialize_output(tmapout,tmaxout,thisout, trstout) ! ! Create his file if either observation points, cross-sections, structures or drains present ! - if (dthisout>1.0e-6 .and. (nobs>0 .or. nrcrosssections>0 .or. nrstructures>0 .or. nrthindams>0 .or. ndrn>0 .or. nr_runup_gauges>0 )) then + if (dthisout>1.0e-6 .and. (nobs>0 .or. nrcrosssections>0 .or. nrstructures>0 .or. nrthindams>0 .or. nr_src_structures>0 .or. nr_runup_gauges>0 )) then ! thisout = t0 ! @@ -81,30 +82,26 @@ subroutine initialize_output(tmapout,tmaxout,thisout, trstout) end subroutine - subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmaxout,nthisout,tloop) + subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmaxout,nthisout) ! use sfincs_data + use sfincs_timers + use sfincs_src_structures, only: nr_src_structures ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! - logical :: write_map + logical :: write_map logical :: write_max - logical :: write_his - logical :: write_rst + logical :: write_his + logical :: write_rst ! - integer :: ntmapout + integer :: ntmapout integer :: ntmaxout - integer :: nthisout + integer :: nthisout ! real*8 :: t ! - call system_clock(count0, count_rate, count_max) + call timer_start('output') ! ! Time-varying water level output maps ! @@ -250,7 +247,7 @@ subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmax ! ! Water level time series ! - if (write_his .and. (nobs>0 .or. nrcrosssections>0 .or. nr_runup_gauges>0)) then + if (write_his .and. (nobs>0 .or. nrcrosssections>0 .or. nr_src_structures>0 .or. nr_runup_gauges>0)) then ! if (outputtype_his == 'net') then ! @@ -264,12 +261,11 @@ subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmax ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate - ! + call timer_stop('output') + ! end subroutine - - subroutine finalize_output(t, ntmaxout, tloopoutput, tmaxout) + + subroutine finalize_output(t, ntmaxout, tmaxout) ! use sfincs_data ! @@ -277,17 +273,16 @@ subroutine finalize_output(t, ntmaxout, tloopoutput, tmaxout) ! integer :: ntmaxout real*8 :: t, t2 - real :: tloopoutput - real*8 :: tmaxout - ! - if (dtmaxout>1.e-6 .and. ntmaxout == 0) then - !write dtmax output if 1) value for dtmaxout wasn't achieved yet, + real*8 :: tmaxout + ! + if (dtmaxout>1.e-6 .and. ntmaxout == 0) then + !write dtmax output if 1) value for dtmaxout wasn't achieved yet, !or 2) in the last timeinterval, the full 'dtmaxout' wasn't achieved yet, but we still want the max over this interval - ! + ! call write_log('', 1) call write_log('Info : Write maximum values at final timestep since t=dtmaxout was not reached yet...', 1) ntmaxout = 1 - call write_output(t,.false.,.false.,.true.,.false.,0,ntmaxout,0,tloopoutput) + call write_output(t,.false.,.false.,.true.,.false.,0,ntmaxout,0) ! elseif (dtmaxout>1.e-6 .and. ntmaxout>0 .and. t < tmaxout) then ! @@ -298,7 +293,7 @@ subroutine finalize_output(t, ntmaxout, tloopoutput, tmaxout) ! Write 'tstop' as timemax instead of actual (unrounded) 't' t2 = t1 ! - call write_output(t2,.false.,.false.,.true.,.false.,0,ntmaxout,0,tloopoutput) + call write_output(t2,.false.,.false.,.true.,.false.,0,ntmaxout,0) ! endif ! @@ -579,6 +574,8 @@ subroutine close_max_output() subroutine open_his_output() ! use sfincs_data + use sfincs_src_structures, only: nr_src_structures + use sfincs_discharges, only: nr_discharge_points ! implicit none ! @@ -592,7 +589,11 @@ subroutine open_his_output() open(unit = 966, file = trim('qt.txt')) close(unit = 966 ,status='delete') endif - if (nsrcdrn>0) then + if (nr_discharge_points>0) then + open(unit = 969, file = trim('qriver.txt')) + close(unit = 969 ,status='delete') + endif + if (nr_src_structures>0) then open(unit = 970, file = trim('qdrain.txt')) close(unit = 970 ,status='delete') endif @@ -606,6 +607,8 @@ subroutine write_his_output(t) ! use sfincs_data use sfincs_crosssections + use sfincs_src_structures, only: nr_src_structures, src_struc_q_now + use sfincs_discharges, only: qtsrc, nr_discharge_points ! implicit none ! @@ -657,10 +660,17 @@ subroutine write_his_output(t) ! endif ! - if (ndrn>0 .and. store_qdrain) then + if (nr_discharge_points>0) then !$acc update host(qtsrc) + open(unit = 969, file = trim('qriver.txt'), access='append') + write(969,'(f12.1,10000f9.3)')t,(qtsrc(iobs), iobs = 1, nr_discharge_points) + close(969) + endif + ! + if (nr_src_structures>0 .and. store_qdrain) then + !$acc update host(src_struc_q_now) open(unit = 970, file = trim('qdrain.txt'), access='append') - write(970,'(f12.1,10000f9.3)')t,(qtsrc(iobs), iobs = nsrc + 1, nsrcdrn, 2) + write(970,'(f12.1,10000f9.3)')t,(src_struc_q_now(iobs), iobs = 1, nr_src_structures) close(970) endif ! diff --git a/source/src/sfincs_rule_expression.f90 b/source/src/sfincs_rule_expression.f90 new file mode 100644 index 000000000..aba5f3e55 --- /dev/null +++ b/source/src/sfincs_rule_expression.f90 @@ -0,0 +1,1187 @@ +module sfincs_rule_expression + ! + ! Boolean rule mini-language used by gate-like src_structures to decide + ! when to open or close. The grammar is: + ! + ! expr := or_expr + ! or_expr := and_expr ( '|' and_expr )* + ! and_expr := comp ( '&' comp )* + ! comp := '(' expr ')' | atom cmp_op number + ! atom := 'z1' | 'z2' | 'z2-z1' | 'z1-z2' (case-insensitive) + ! cmp_op := '<' | '>' | '<=' | '>=' | '=' | '==' + ! number := real literal + ! + ! Precedence: paren > comp > '&' > '|'. Left-associative. + ! + ! Each rule is compiled to a reverse-polish bytecode stream in four + ! parallel module-level arrays (opcode / atom / cmp / threshold) and + ! registered in a small parallel (start, length) registry indexed by + ! integer rule_id. Callers keep only that rule_id per-structure; the + ! module owns both the op stream (so all rules across all structures + ! concatenate into one buffer) and the registry. + ! + ! The evaluator is a small fixed-depth logical stack machine that is + ! ACC-safe (no allocations, no strings, no I/O). + ! + implicit none + ! + private + ! + ! Public bytecode storage. These four parallel arrays hold the + ! concatenated op streams for every rule that has been parsed. They + ! are public so sfincs_openacc can name them in !$acc directives. + ! + public :: rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_n_ops + ! + ! Public rule registry. rule_start(id) / rule_length(id) index into + ! the op streams above. n_rules is the highest rule_id currently + ! allocated; entries at index 0 are not used (rule_id == 0 is the + ! "no rule" sentinel). + ! + public :: rule_start, rule_length, n_rules + ! + ! Public API. + ! + public :: add_rule, evaluate_rule, finalize_rule_storage + ! + ! --------------------------------------------------------------- + ! Opcodes. + ! + integer, parameter :: op_cmp = 1 + integer, parameter :: op_and = 2 + integer, parameter :: op_or = 3 + ! + ! Atom codes (the z value being compared). + ! + integer, parameter :: atom_z1 = 1 + integer, parameter :: atom_z2 = 2 + integer, parameter :: atom_z2_minus_z1 = 3 + integer, parameter :: atom_z1_minus_z2 = 4 + ! + ! Comparator codes. + ! + integer, parameter :: cmp_lt = 1 + integer, parameter :: cmp_gt = 2 + integer, parameter :: cmp_le = 3 + integer, parameter :: cmp_ge = 4 + integer, parameter :: cmp_eq = 5 + ! + ! Parser / evaluator capacity limits. + ! + integer, parameter :: expr_stack_max = 16 ! evaluator logical-stack depth + integer, parameter :: expr_ops_max_per_rule = 64 ! max bytecode length per rule (parser rejects longer) + integer, parameter :: expr_tokens_max = 128 ! max tokens in a single rule string + ! + ! --------------------------------------------------------------- + ! Shared bytecode storage. + ! + ! add_rule appends into these arrays and auto-grows them. Handles + ! (rule_start, rule_length) in the registry index into them. + ! + integer, allocatable, save :: rule_opcode(:) + integer, allocatable, save :: rule_atom(:) + integer, allocatable, save :: rule_cmp(:) + real, allocatable, save :: rule_threshold(:) + integer, save :: rule_n_ops = 0 + integer, save :: rule_capacity = 0 + ! + ! Rule registry. Indexed by rule_id in [1 .. n_rules]. rule_id == 0 + ! is the "never fires" sentinel and has no registry entry. + ! + integer, allocatable, save :: rule_start(:) + integer, allocatable, save :: rule_length(:) + integer, save :: n_rules = 0 + integer, save :: rule_registry_capacity = 0 + ! + integer, parameter :: initial_capacity = 256 + integer, parameter :: initial_registry_capacity = 16 + ! +contains + ! + ! + subroutine add_rule(src, rule_id, ierr, errmsg) + ! + ! Parse the boolean expression in src, append its bytecode to the + ! module-level rule_* arrays, and register a new rule entry that + ! points at it. Returns the new rule_id. An empty or whitespace-only + ! src returns rule_id = 0 (the "never fires" sentinel; no registry + ! entry is created). On parse failure ierr /= 0, rule_id = 0, and + ! errmsg carries the diagnostic. + ! + implicit none + ! + character(len=*), intent(in) :: src + integer, intent(out) :: rule_id + integer, intent(out) :: ierr + character(len=*), optional, intent(out) :: errmsg + ! + ! Per-call scratch buffers for the parsed bytecode; sized to the + ! parser's per-rule cap. Copied into the module storage on success. + ! + integer :: ops_buf (expr_ops_max_per_rule) + integer :: atoms_buf (expr_ops_max_per_rule) + integer :: cmps_buf (expr_ops_max_per_rule) + real :: thr_buf (expr_ops_max_per_rule) + integer :: nops, new_start + character(len=256):: local_errmsg + ! + character(len=len(src)) :: src_nospace + integer :: ic, ip, jp + ! + rule_id = 0 + ierr = 0 + if (present(errmsg)) errmsg = '' + ! + ! Empty / whitespace-only source: never fires, no registry entry. + ! + if (len_trim(src) == 0) return + ! + ! Strip all whitespace (space, tab, LF, CR) so callers can write + ! 'z1 < 0.5' or 'z2 - z1 > 0.05' as freely as 'z1<0.5' / 'z2-z1>0.05'. + ! + jp = 0 + do ip = 1, len(src) + ! + ic = iachar(src(ip:ip)) + ! + if (ic /= iachar(' ') .and. ic /= 9 .and. ic /= 10 .and. ic /= 13) then + ! + jp = jp + 1 + src_nospace(jp:jp) = src(ip:ip) + ! + endif + ! + enddo + ! + if (jp == 0) return + ! + call parse_rule_expression(src_nospace(1:jp), ops_buf, atoms_buf, cmps_buf, thr_buf, & + nops, ierr, local_errmsg) + ! + if (ierr /= 0) then + ! + if (present(errmsg)) errmsg = local_errmsg + return + ! + endif + ! + if (nops <= 0) then + ! + ierr = 1 + if (present(errmsg)) errmsg = 'rule parse produced no ops' + return + ! + endif + ! + ! Ensure the op stream has room for the new ops. + ! + call grow_rule_storage(rule_n_ops + nops) + ! + new_start = rule_n_ops + 1 + ! + rule_opcode (new_start : new_start + nops - 1) = ops_buf (1:nops) + rule_atom (new_start : new_start + nops - 1) = atoms_buf(1:nops) + rule_cmp (new_start : new_start + nops - 1) = cmps_buf (1:nops) + rule_threshold(new_start : new_start + nops - 1) = thr_buf (1:nops) + ! + rule_n_ops = rule_n_ops + nops + ! + ! Register the new rule and return its id. + ! + call grow_rule_registry(n_rules + 1) + ! + n_rules = n_rules + 1 + rule_start(n_rules) = new_start + rule_length(n_rules)= nops + rule_id = n_rules + ! + end subroutine + ! + ! + subroutine finalize_rule_storage() + ! + ! Shrink the rule_* op streams to exactly rule_n_ops and the registry + ! to exactly n_rules. If nothing was ever allocated (no rules parsed) + ! everything is allocated to size 0 so downstream openacc directives + ! can reference the arrays safely. + ! + implicit none + ! + integer, allocatable :: tmp_i(:) + real, allocatable :: tmp_r(:) + ! + ! Op streams. + ! + if (.not. allocated(rule_opcode)) then + ! + allocate(rule_opcode(0)) + allocate(rule_atom(0)) + allocate(rule_cmp(0)) + allocate(rule_threshold(0)) + rule_capacity = 0 + rule_n_ops = 0 + ! + else if (rule_capacity /= rule_n_ops) then + ! + allocate(tmp_i(rule_n_ops)) + if (rule_n_ops > 0) tmp_i = rule_opcode(1:rule_n_ops) + call move_alloc(tmp_i, rule_opcode) + ! + allocate(tmp_i(rule_n_ops)) + if (rule_n_ops > 0) tmp_i = rule_atom(1:rule_n_ops) + call move_alloc(tmp_i, rule_atom) + ! + allocate(tmp_i(rule_n_ops)) + if (rule_n_ops > 0) tmp_i = rule_cmp(1:rule_n_ops) + call move_alloc(tmp_i, rule_cmp) + ! + allocate(tmp_r(rule_n_ops)) + if (rule_n_ops > 0) tmp_r = rule_threshold(1:rule_n_ops) + call move_alloc(tmp_r, rule_threshold) + ! + rule_capacity = rule_n_ops + ! + endif + ! + ! Registry. + ! + if (.not. allocated(rule_start)) then + ! + allocate(rule_start(0)) + allocate(rule_length(0)) + rule_registry_capacity = 0 + n_rules = 0 + ! + else if (rule_registry_capacity /= n_rules) then + ! + allocate(tmp_i(n_rules)) + if (n_rules > 0) tmp_i = rule_start(1:n_rules) + call move_alloc(tmp_i, rule_start) + ! + allocate(tmp_i(n_rules)) + if (n_rules > 0) tmp_i = rule_length(1:n_rules) + call move_alloc(tmp_i, rule_length) + ! + rule_registry_capacity = n_rules + ! + endif + ! + end subroutine + ! + ! + pure function evaluate_rule(rule_id, z1, z2) result(fired) + ! + ! Fixed-depth stack machine that evaluates a compiled rule against + ! the two water levels z1 (intake) and z2 (outfall). A rule_id of 0 + ! short-circuits to .false. ("never fires"). + ! + !$acc routine seq + ! + implicit none + ! + integer, intent(in) :: rule_id + real, intent(in) :: z1, z2 + logical :: fired + ! + logical :: stack(expr_stack_max) + integer :: sp, k, idx, rs, rl + real :: zval + logical :: a, b + ! + fired = .false. + ! + if (rule_id <= 0) return + ! + rs = rule_start(rule_id) + rl = rule_length(rule_id) + ! + if (rl <= 0) return + ! + sp = 0 + ! + do k = 1, rl + ! + idx = rs + k - 1 + ! + select case (rule_opcode(idx)) + ! + case (op_cmp) + ! + select case (rule_atom(idx)) + ! + case (atom_z1) + ! + zval = z1 + ! + case (atom_z2) + ! + zval = z2 + ! + case (atom_z2_minus_z1) + ! + zval = z2 - z1 + ! + case (atom_z1_minus_z2) + ! + zval = z1 - z2 + ! + case default + ! + zval = 0.0 + ! + end select + ! + if (sp >= expr_stack_max) return + sp = sp + 1 + ! + select case (rule_cmp(idx)) + ! + case (cmp_lt) + ! + stack(sp) = zval < rule_threshold(idx) + ! + case (cmp_gt) + ! + stack(sp) = zval > rule_threshold(idx) + ! + case (cmp_le) + ! + stack(sp) = zval <= rule_threshold(idx) + ! + case (cmp_ge) + ! + stack(sp) = zval >= rule_threshold(idx) + ! + case (cmp_eq) + ! + stack(sp) = zval == rule_threshold(idx) + ! + case default + ! + stack(sp) = .false. + ! + end select + ! + case (op_and) + ! + b = stack(sp) + a = stack(sp - 1) + sp = sp - 1 + stack(sp) = a .and. b + ! + case (op_or) + ! + b = stack(sp) + a = stack(sp - 1) + sp = sp - 1 + stack(sp) = a .or. b + ! + end select + ! + enddo + ! + if (sp >= 1) fired = stack(1) + ! + end function + ! + ! + subroutine grow_rule_storage(min_capacity) + ! + ! Ensure rule_capacity >= min_capacity. On first growth, allocates to + ! max(initial_capacity, min_capacity). On subsequent growth, doubles + ! until the requested capacity fits. Existing contents are preserved. + ! + implicit none + ! + integer, intent(in) :: min_capacity + ! + integer :: new_capacity + integer, allocatable :: tmp_i(:) + real, allocatable :: tmp_r(:) + ! + if (.not. allocated(rule_opcode)) then + ! + new_capacity = max(initial_capacity, min_capacity) + allocate(rule_opcode (new_capacity)) + allocate(rule_atom (new_capacity)) + allocate(rule_cmp (new_capacity)) + allocate(rule_threshold(new_capacity)) + rule_capacity = new_capacity + return + ! + endif + ! + if (min_capacity <= rule_capacity) return + ! + new_capacity = max(2 * rule_capacity, min_capacity) + ! + allocate(tmp_i(new_capacity)) + if (rule_n_ops > 0) tmp_i(1:rule_n_ops) = rule_opcode(1:rule_n_ops) + call move_alloc(tmp_i, rule_opcode) + ! + allocate(tmp_i(new_capacity)) + if (rule_n_ops > 0) tmp_i(1:rule_n_ops) = rule_atom(1:rule_n_ops) + call move_alloc(tmp_i, rule_atom) + ! + allocate(tmp_i(new_capacity)) + if (rule_n_ops > 0) tmp_i(1:rule_n_ops) = rule_cmp(1:rule_n_ops) + call move_alloc(tmp_i, rule_cmp) + ! + allocate(tmp_r(new_capacity)) + if (rule_n_ops > 0) tmp_r(1:rule_n_ops) = rule_threshold(1:rule_n_ops) + call move_alloc(tmp_r, rule_threshold) + ! + rule_capacity = new_capacity + ! + end subroutine + ! + ! + subroutine grow_rule_registry(min_capacity) + ! + ! Ensure rule_registry_capacity >= min_capacity. On first growth, + ! allocates to max(initial_registry_capacity, min_capacity). On + ! subsequent growth, doubles until the requested capacity fits. + ! Existing contents are preserved. + ! + implicit none + ! + integer, intent(in) :: min_capacity + ! + integer :: new_capacity + integer, allocatable :: tmp_i(:) + ! + if (.not. allocated(rule_start)) then + ! + new_capacity = max(initial_registry_capacity, min_capacity) + allocate(rule_start (new_capacity)) + allocate(rule_length(new_capacity)) + rule_registry_capacity = new_capacity + return + ! + endif + ! + if (min_capacity <= rule_registry_capacity) return + ! + new_capacity = max(2 * rule_registry_capacity, min_capacity) + ! + allocate(tmp_i(new_capacity)) + if (n_rules > 0) tmp_i(1:n_rules) = rule_start(1:n_rules) + call move_alloc(tmp_i, rule_start) + ! + allocate(tmp_i(new_capacity)) + if (n_rules > 0) tmp_i(1:n_rules) = rule_length(1:n_rules) + call move_alloc(tmp_i, rule_length) + ! + rule_registry_capacity = new_capacity + ! + end subroutine + ! + ! + subroutine parse_rule_expression(src, ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + ! Recursive-descent parser that compiles a rule string to reverse- + ! polish bytecode in four parallel arrays. op_cmp entries use all + ! three of atoms / cmps / thresholds; op_and / op_or use only opcode. + ! + implicit none + ! + character(len=*), intent(in) :: src + integer, intent(out) :: ops(:) + integer, intent(out) :: atoms(:) + integer, intent(out) :: cmps(:) + real, intent(out) :: thresholds(:) + integer, intent(out) :: nops + integer, intent(out) :: ierr + character(len=*), intent(out) :: errmsg + ! + ! Token kinds: + ! 1 = ident (z1/z2/z2-z1/z1-z2) payload: atom code in tok_atom + ! 2 = number payload: real in tok_num + ! 3 = lparen + ! 4 = rparen + ! 5 = and + ! 6 = or + ! 7 = lt + ! 8 = gt + ! 9 = le + ! 10 = ge + ! 11 = eq + ! + integer :: tok_kind(expr_tokens_max) + integer :: tok_atom(expr_tokens_max) + real :: tok_num (expr_tokens_max) + integer :: tok_pos (expr_tokens_max) + integer :: n_tokens, ip + ! + nops = 0 + ierr = 0 + errmsg = '' + ! + call tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ierr, errmsg) + ! + if (ierr /= 0) return + ! + if (n_tokens == 0) then + ! + ierr = 1 + errmsg = 'empty rule expression' + return + ! + endif + ! + ip = 1 + ! + call parse_or_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + if (ierr /= 0) return + ! + if (ip <= n_tokens) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'unexpected trailing token at position ', tok_pos(ip) + return + ! + endif + ! + end subroutine + ! + ! + subroutine tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ierr, errmsg) + ! + ! One-pass tokenizer. Emits fixed-size parallel arrays: kind, atom + ! code, number value, source position. Token kinds match the + ! parameters above in parse_rule_expression. + ! + implicit none + ! + character(len=*), intent(in) :: src + integer, intent(out) :: tok_kind(:) + integer, intent(out) :: tok_atom(:) + real, intent(out) :: tok_num(:) + integer, intent(out) :: tok_pos(:) + integer, intent(out) :: n_tokens + integer, intent(inout) :: ierr + character(len=*), intent(inout) :: errmsg + ! + integer, parameter :: tok_ident = 1 + integer, parameter :: tok_number = 2 + integer, parameter :: tok_lparen = 3 + integer, parameter :: tok_rparen = 4 + integer, parameter :: tok_and = 5 + integer, parameter :: tok_or = 6 + integer, parameter :: tok_lt = 7 + integer, parameter :: tok_gt = 8 + integer, parameter :: tok_le = 9 + integer, parameter :: tok_ge = 10 + integer, parameter :: tok_eq = 11 + ! + integer :: pos, slen, start, kstart, ic, atom_code, iostat_read + character(len=:), allocatable :: lower + character(len=32) :: num_buf + logical :: matched + ! + lower = to_lower_local(src) + slen = len(lower) + pos = 1 + n_tokens = 0 + ! + do while (pos <= slen) + ! + ! Skip whitespace. + ! + ic = iachar(lower(pos:pos)) + ! + if (ic == iachar(' ') .or. ic == 9 .or. ic == 10 .or. ic == 13) then + ! + pos = pos + 1 + cycle + ! + endif + ! + if (n_tokens >= expr_tokens_max) then + ! + ierr = 1 + write(errmsg,'(a,i0,a)') 'too many tokens (>', expr_tokens_max, ') in rule expression' + return + ! + endif + ! + start = pos + ! + ! Single-character tokens. + ! + matched = .true. + ! + select case (lower(pos:pos)) + ! + case ('(') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_lparen + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case (')') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_rparen + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case ('&') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_and + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case ('|') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_or + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case ('<') + ! + n_tokens = n_tokens + 1 + tok_pos (n_tokens) = start + if (pos + 1 <= slen .and. lower(min(pos+1,slen):min(pos+1,slen)) == '=') then + ! + tok_kind(n_tokens) = tok_le + pos = pos + 2 + ! + else + ! + tok_kind(n_tokens) = tok_lt + pos = pos + 1 + ! + endif + ! + case ('>') + ! + n_tokens = n_tokens + 1 + tok_pos (n_tokens) = start + if (pos + 1 <= slen .and. lower(min(pos+1,slen):min(pos+1,slen)) == '=') then + ! + tok_kind(n_tokens) = tok_ge + pos = pos + 2 + ! + else + ! + tok_kind(n_tokens) = tok_gt + pos = pos + 1 + ! + endif + ! + case ('=') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_eq + tok_pos (n_tokens) = start + if (pos + 1 <= slen .and. lower(min(pos+1,slen):min(pos+1,slen)) == '=') then + ! + pos = pos + 2 + ! + else + ! + pos = pos + 1 + ! + endif + ! + case default + ! + matched = .false. + ! + end select + ! + if (matched) cycle + ! + ! Number: optional sign is not part of the grammar (z2-z1 is a + ! fixed atom, not arithmetic). A leading '-' or '+' is only + ! treated as a number's sign when the next char is digit or dot. + ! + ic = iachar(lower(pos:pos)) + ! + if (ic == iachar('-') .or. ic == iachar('+') .or. & + ic == iachar('.') .or. (ic >= iachar('0') .and. ic <= iachar('9'))) then + ! + if (lower(pos:pos) == '-' .or. lower(pos:pos) == '+') then + ! + if (pos + 1 > slen) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'trailing sign without digits at position ', pos + return + ! + endif + ! + ic = iachar(lower(pos+1:pos+1)) + ! + if (.not. (ic == iachar('.') .or. (ic >= iachar('0') .and. ic <= iachar('9')))) then + ! + ierr = 1 + write(errmsg,'(a,a,a,i0)') 'unexpected character "', lower(pos:pos), & + '" at position ', pos + return + ! + endif + ! + endif + ! + kstart = pos + ! + ! Leading sign. + ! + if (lower(pos:pos) == '-' .or. lower(pos:pos) == '+') pos = pos + 1 + ! + ! Integer part. + ! + do while (pos <= slen) + ! + ic = iachar(lower(pos:pos)) + if (.not. (ic >= iachar('0') .and. ic <= iachar('9'))) exit + pos = pos + 1 + ! + enddo + ! + ! Fractional part. + ! + if (pos <= slen) then + ! + if (lower(pos:pos) == '.') then + ! + pos = pos + 1 + ! + do while (pos <= slen) + ! + ic = iachar(lower(pos:pos)) + if (.not. (ic >= iachar('0') .and. ic <= iachar('9'))) exit + pos = pos + 1 + ! + enddo + ! + endif + ! + endif + ! + ! Exponent. + ! + if (pos <= slen) then + ! + if (lower(pos:pos) == 'e') then + ! + pos = pos + 1 + ! + if (pos <= slen) then + ! + if (lower(pos:pos) == '+' .or. lower(pos:pos) == '-') pos = pos + 1 + ! + endif + ! + do while (pos <= slen) + ! + ic = iachar(lower(pos:pos)) + if (.not. (ic >= iachar('0') .and. ic <= iachar('9'))) exit + pos = pos + 1 + ! + enddo + ! + endif + ! + endif + ! + num_buf = lower(kstart:pos-1) + ! + read(num_buf, *, iostat=iostat_read) tok_num(n_tokens + 1) + ! + if (iostat_read /= 0) then + ! + ierr = 1 + write(errmsg,'(a,a,a,i0)') 'invalid number "', trim(num_buf), & + '" at position ', kstart + return + ! + endif + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_number + tok_pos (n_tokens) = kstart + ! + cycle + ! + endif + ! + ! Identifiers: z1, z2, z2-z1, z1-z2. The 'z2-z1' / 'z1-z2' atoms + ! contain a '-', which would otherwise be eaten by the number path; + ! we match them as longest-match-first prefixes here. + ! + kstart = pos + ! + select case (lower(pos:pos)) + ! + case ('z') + ! + if (pos + 4 <= slen) then + ! + if (lower(pos:pos+4) == 'z2-z1') then + ! + atom_code = atom_z2_minus_z1 + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_ident + tok_atom(n_tokens) = atom_code + tok_pos (n_tokens) = kstart + pos = pos + 5 + cycle + ! + elseif (lower(pos:pos+4) == 'z1-z2') then + ! + atom_code = atom_z1_minus_z2 + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_ident + tok_atom(n_tokens) = atom_code + tok_pos (n_tokens) = kstart + pos = pos + 5 + cycle + ! + endif + ! + endif + ! + if (pos + 1 <= slen) then + ! + if (lower(pos:pos+1) == 'z1') then + ! + atom_code = atom_z1 + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_ident + tok_atom(n_tokens) = atom_code + tok_pos (n_tokens) = kstart + pos = pos + 2 + cycle + ! + elseif (lower(pos:pos+1) == 'z2') then + ! + atom_code = atom_z2 + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_ident + tok_atom(n_tokens) = atom_code + tok_pos (n_tokens) = kstart + pos = pos + 2 + cycle + ! + endif + ! + endif + ! + ierr = 1 + write(errmsg,'(a,i0)') 'unknown z-identifier at position ', pos + return + ! + case default + ! + ierr = 1 + write(errmsg,'(a,a,a,i0)') 'unexpected character "', lower(pos:pos), & + '" at position ', pos + return + ! + end select + ! + enddo + ! + end subroutine + ! + ! + recursive subroutine parse_or_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + ! Parse an or-expression. Emits a parse_and_expr, then while the + ! next token is 'or', consumes it, parses another and-expression, + ! and emits op_or. + ! + implicit none + ! + integer, intent(in) :: tok_kind(:), tok_atom(:), tok_pos(:) + real, intent(in) :: tok_num(:) + integer, intent(in) :: n_tokens + integer, intent(inout) :: ip + integer, intent(inout) :: ops(:), atoms(:), cmps(:) + real, intent(inout) :: thresholds(:) + integer, intent(inout) :: nops + integer, intent(inout) :: ierr + character(len=*), intent(inout) :: errmsg + ! + integer, parameter :: tok_or = 6 + ! + call parse_and_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + do while (ip <= n_tokens) + ! + if (tok_kind(ip) /= tok_or) exit + ! + ip = ip + 1 + ! + call parse_and_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + if (nops >= expr_ops_max_per_rule) then + ! + ierr = 1 + errmsg = 'rule expression too long (op buffer full)' + return + ! + endif + ! + nops = nops + 1 + ops(nops) = op_or + atoms(nops) = 0 + cmps(nops) = 0 + thresholds(nops) = 0.0 + ! + enddo + ! + end subroutine + ! + ! + recursive subroutine parse_and_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + ! Parse an and-expression. Emits a parse_comp, then while the next + ! token is 'and', consumes it, parses another comp, and emits op_and. + ! + implicit none + ! + integer, intent(in) :: tok_kind(:), tok_atom(:), tok_pos(:) + real, intent(in) :: tok_num(:) + integer, intent(in) :: n_tokens + integer, intent(inout) :: ip + integer, intent(inout) :: ops(:), atoms(:), cmps(:) + real, intent(inout) :: thresholds(:) + integer, intent(inout) :: nops + integer, intent(inout) :: ierr + character(len=*), intent(inout) :: errmsg + ! + integer, parameter :: tok_and = 5 + ! + call parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + do while (ip <= n_tokens) + ! + if (tok_kind(ip) /= tok_and) exit + ! + ip = ip + 1 + ! + call parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + if (nops >= expr_ops_max_per_rule) then + ! + ierr = 1 + errmsg = 'rule expression too long (op buffer full)' + return + ! + endif + ! + nops = nops + 1 + ops(nops) = op_and + atoms(nops) = 0 + cmps(nops) = 0 + thresholds(nops) = 0.0 + ! + enddo + ! + end subroutine + ! + ! + recursive subroutine parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + ! Parse either a parenthesised expression or a leaf comparison + ! "atom <|> number". Emits op_cmp for the leaf case. + ! + implicit none + ! + integer, intent(in) :: tok_kind(:), tok_atom(:), tok_pos(:) + real, intent(in) :: tok_num(:) + integer, intent(in) :: n_tokens + integer, intent(inout) :: ip + integer, intent(inout) :: ops(:), atoms(:), cmps(:) + real, intent(inout) :: thresholds(:) + integer, intent(inout) :: nops + integer, intent(inout) :: ierr + character(len=*), intent(inout) :: errmsg + ! + integer, parameter :: tok_ident = 1 + integer, parameter :: tok_number = 2 + integer, parameter :: tok_lparen = 3 + integer, parameter :: tok_rparen = 4 + integer, parameter :: tok_lt = 7 + integer, parameter :: tok_gt = 8 + integer, parameter :: tok_le = 9 + integer, parameter :: tok_ge = 10 + integer, parameter :: tok_eq = 11 + ! + integer :: atom_code, cmp_code + ! + if (ip > n_tokens) then + ! + ierr = 1 + errmsg = 'unexpected end of expression' + return + ! + endif + ! + if (tok_kind(ip) == tok_lparen) then + ! + ip = ip + 1 + ! + call parse_or_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + if (ip > n_tokens) then + ! + ierr = 1 + errmsg = 'missing closing ")"' + return + ! + endif + ! + if (tok_kind(ip) /= tok_rparen) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'expected ")" at position ', tok_pos(ip) + return + ! + endif + ! + ip = ip + 1 + return + ! + endif + ! + ! Leaf: atom cmp_op number. + ! + if (tok_kind(ip) /= tok_ident) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'expected atom (z1/z2/z2-z1/z1-z2) at position ', tok_pos(ip) + return + ! + endif + ! + atom_code = tok_atom(ip) + ip = ip + 1 + ! + if (ip > n_tokens) then + ! + ierr = 1 + errmsg = 'expected comparator after atom' + return + ! + endif + ! + select case (tok_kind(ip)) + ! + case (tok_lt) + ! + cmp_code = cmp_lt + ! + case (tok_gt) + ! + cmp_code = cmp_gt + ! + case (tok_le) + ! + cmp_code = cmp_le + ! + case (tok_ge) + ! + cmp_code = cmp_ge + ! + case (tok_eq) + ! + cmp_code = cmp_eq + ! + case default + ! + ierr = 1 + write(errmsg,'(a,i0)') 'expected comparator ("<", ">", "<=", ">=", "=") at position ', tok_pos(ip) + return + ! + end select + ! + ip = ip + 1 + ! + if (ip > n_tokens) then + ! + ierr = 1 + errmsg = 'expected number after comparator' + return + ! + endif + ! + if (tok_kind(ip) /= tok_number) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'expected numeric threshold at position ', tok_pos(ip) + return + ! + endif + ! + if (nops >= expr_ops_max_per_rule) then + ! + ierr = 1 + errmsg = 'rule expression too long (op buffer full)' + return + ! + endif + ! + nops = nops + 1 + ops(nops) = op_cmp + atoms(nops) = atom_code + cmps(nops) = cmp_code + thresholds(nops) = tok_num(ip) + ! + ip = ip + 1 + ! + end subroutine + ! + ! + function to_lower_local(str) result(lower) + ! + ! Return a lowercase copy of str (ASCII only). Local to this module + ! so rule-parsing doesn't depend on sfincs_src_structures for a case + ! fold; the trivial duplication is worth the decoupling. + ! + implicit none + ! + character(len=*), intent(in) :: str + character(len=:), allocatable :: lower + ! + integer :: k, ic + ! + lower = str + ! + do k = 1, len(lower) + ! + ic = iachar(lower(k:k)) + ! + if (ic >= iachar('A') .and. ic <= iachar('Z')) then + ! + lower(k:k) = achar(ic + 32) + ! + endif + ! + enddo + ! + end function + ! +end module diff --git a/source/src/sfincs_snapwave.f90 b/source/src/sfincs_snapwave.f90 index 5810c62df..b025dbff2 100644 --- a/source/src/sfincs_snapwave.f90 +++ b/source/src/sfincs_snapwave.f90 @@ -286,35 +286,34 @@ subroutine find_matching_cells(index_quadtree_in_snapwave, index_snapwave_in_qua end subroutine - subroutine update_wave_field(t, tloop) + subroutine update_wave_field(t) ! use sfincs_data + use sfincs_timers + use sfincs_date, only: timer ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*4 :: u10, u10dir - ! + ! real*4, dimension(:), allocatable :: fwx0 real*4, dimension(:), allocatable :: fwy0 real*4, dimension(:), allocatable :: dw0 - real*4, dimension(:), allocatable :: df0 + real*4, dimension(:), allocatable :: df0 real*4, dimension(:), allocatable :: dwig0 - real*4, dimension(:), allocatable :: dfig0 - real*4, dimension(:), allocatable :: cg0 - !real*4, dimension(:), allocatable :: qb0 - real*4, dimension(:), allocatable :: beta0 - real*4, dimension(:), allocatable :: srcig0 - real*4, dimension(:), allocatable :: alphaig0 + real*4, dimension(:), allocatable :: dfig0 + real*4, dimension(:), allocatable :: cg0 + !real*4, dimension(:), allocatable :: qb0 + real*4, dimension(:), allocatable :: beta0 + real*4, dimension(:), allocatable :: srcig0 + real*4, dimension(:), allocatable :: alphaig0 integer :: ip, nm, nmu, idir real*8 :: t + real*4 :: t3, t4 ! - call system_clock(count0, count_rate, count_max) + call timer(t3) + ! + call timer_start('SnapWave') ! allocate(fwx0(np)) allocate(fwy0(np)) @@ -514,10 +513,14 @@ subroutine update_wave_field(t, tloop) !$acc update device(fwuv) ! ! Set wave forces fwmaxfac factor - fwmaxfac = snapwave_fwmaxfac + fwmaxfac = snapwave_fwmaxfac + ! + call timer_stop('SnapWave') + ! + call timer(t4) ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + write(logstr,'(a,f10.1,a,f6.2,a)')'Computing SnapWave at t = ', t, ' s took ', t4 - t3, ' seconds' + call write_log(logstr, 0) ! end subroutine diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 new file mode 100644 index 000000000..601569ed1 --- /dev/null +++ b/source/src/sfincs_src_structures.f90 @@ -0,0 +1,2589 @@ +module sfincs_src_structures + ! + ! Point structures that move water between two grid cells by user-specified + ! rules rather than by momentum conservation: + ! type 1 - pump (fixed discharge) + ! type 2 - culvert_simple (bidirectional, optional direction filter) + ! type 3 - culvert (physics-based pipe flow with entrance / + ! friction / exit losses, bidirectional, + ! optional direction filter) + ! type 4 - gate (rule-driven state machine, bidirectional) + ! + ! Legacy TOML alias accepted by the parser: + ! "check_valve" -> culvert_simple + direction = "positive" + ! + ! Orifice behaviour is not a first-class type; use type = "culvert" + ! with submergence_ratio = 0.0 to reproduce it. + ! + ! These used to live in sfincs_discharges.f90 alongside the river point + ! discharges read from src/dis/netsrcdis. They have been split out so that + ! each module has a single responsibility. + ! + ! Runtime handoff to the continuity module is via the cell-wise qsrc(np) + ! array (in sfincs_data): this module accumulates qq on endpoint-1 + ! (src_struc_nm_s1) and endpoint-2 (src_struc_nm_s2) cells. Per-structure + ! signed discharge is also stored in src_struc_q_now(nr_src_structures) + ! for his output. + ! + ! Sign convention: a positive qq means flow from nm_s1 to nm_s2. + ! No direction is baked into the endpoint names themselves; for pumps, + ! endpoint 1 (nm_s1) is the intake and endpoint 2 (nm_s2) is the discharge, + ! and the pump logic enforces qq >= 0. All other structure types are + ! bidirectional and the sign of qq carries the flow direction. + ! + ! Concurrency: qsrc updates use atomic because two structures (or a river + ! source and a structure) can land in the same cell. + ! + ! Subroutines: + ! + ! initialize_src_structures() + ! Main entry point. Detects legacy vs TOML, dispatches through the + ! TOML reader, flattens into src_struc_* arrays, resolves grid-cell + ! indices, and seeds rule-driven gate positions from the initial zs. + ! Called from sfincs_lib at init time. + ! + ! update_src_structures(t, dt) + ! Evaluates each rule-driven structure's ordered rule list to set a + ! target gate position and ramps fraction_open toward it, evaluates the + ! per-type flux formula, and accumulates signed discharges into qsrc and + ! src_struc_q_now. Called from update_continuity (sfincs_continuity) + ! once per time step, after update_discharges. + ! + ! read_toml_src_structures(filename, structures, ierr) + ! Parse a TOML drn file into an allocatable t_src_structure(:) array. + ! Validates required per-type keys; returns ierr /= 0 on failure. + ! Called from initialize_src_structures (this module). + ! + ! check_required(table, keys, seq_index, ierr) + ! Helper for read_toml_src_structures: verifies that every key in a + ! required-key list is present in a given TOML table. Called from + ! read_toml_src_structures (this module). + ! + ! parse_structure_type(str, code, ierr) + ! Translate a TOML "type" string to one of the structure_* codes. + ! Called from read_toml_src_structures (this module). + ! + ! parse_direction(str, code, ierr) + ! Translate a TOML "direction" string to one of the direction_* codes. + ! Called from read_toml_src_structures (this module). + ! + ! to_lower(str) result(lower) + ! Return a lowercase copy of a string (ASCII). Called from + ! parse_structure_type, parse_direction, and convert_legacy_to_toml + ! (all in this module). + ! + ! write_src_structures_log_summary() + ! Emit a one-block-per-structure human-readable description to the + ! log file; called from initialize_src_structures (this module) once + ! at init time after marshalling. + ! + ! convert_legacy_to_toml(legacy_path, toml_path, ierr) + ! Transcribe a legacy fixed-column .drn file into a TOML sibling so + ! the downstream code only has to consume the TOML schema. Called + ! from initialize_src_structures (this module) when the drn file + ! fails TOML probing. + ! + use sfincs_log + use sfincs_error + use sfincs_rule_expression, only: add_rule, evaluate_rule, finalize_rule_storage + ! + private :: parse_structure_type, parse_direction, parse_operation, to_lower, check_required + private :: convert_legacy_to_toml + private :: write_src_structures_log_summary + ! + ! Structure type codes + ! + integer, parameter :: structure_pump = 1 + integer, parameter :: structure_culvert_simple = 2 + integer, parameter :: structure_culvert = 3 + integer, parameter :: structure_gate = 4 + integer, parameter :: structure_dike_breach = 5 + ! + ! Direction filter codes (culvert_simple / culvert). Controls which sign + ! of discharge is allowed through the structure. Default is "both". + ! + integer, parameter :: direction_both = 1 + integer, parameter :: direction_positive = 2 + integer, parameter :: direction_negative = 3 + ! + ! Pump reduction curve depth (m). Pump discharge is scaled by + ! min(1, h_up/pump_reduction_depth) so the pump cannot pump the intake + ! cell dry. Fixed constant, not user-tunable. + ! + real*4, parameter :: pump_reduction_depth = 0.1 + ! + ! Gate operation codes for rule-driven structures. Each rule sets a + ! target gate position: open -> fraction 1.0, close -> 0.0, hold -> + ! freeze at the current fraction. These are the only operations. + ! + integer, parameter :: gate_op_close = 0 + integer, parameter :: gate_op_open = 1 + integer, parameter :: gate_op_hold = 2 + ! + ! A single gate control rule: an operation plus the boolean expression + ! (in the sfincs_rule_expression mini-language, e.g. "z1>-0.15 & z1-z2>0.09") + ! that, when true, selects that operation. Rules are evaluated in order + ! and the first whose expression fires wins; if none fires the gate holds. + ! + type :: t_gate_rule + integer :: op ! gate_op_* + character(len=:), allocatable :: when ! trigger expression (raw string) + end type t_gate_rule + ! + ! Derived type for the TOML-based src structure input. + ! + ! Gate control is an ordered list of (operation, when) rules; the parser + ! runs during marshalling and emits each "when" expression as bytecode + ! into the shared rule_* streams owned by the sfincs_rule_expression module. + ! + type :: t_src_structure + ! + ! Identification (populated by the TOML reader). name is the sole + ! identifier and is required for every structure type. + ! + character(len=:), allocatable :: name + ! + ! Structure kind (one of the structure_* codes) + ! + integer :: structure_type + ! + ! Direction filter (one of direction_both / _positive / _negative). + ! Honoured only for culvert_simple and culvert; other types ignore it. + ! + integer :: direction + ! + ! Geometry - x_s1/y_s1 and x_s2/y_s2 define the two endpoint cell + ! coordinates; x_o1/y_o1 and x_o2/y_o2 are optional observation-point + ! coordinates and default to the endpoint coordinates in the marshal + ! when the TOML reader did not see the keys (tracked via has_o1 / has_o2). + ! + real :: x_s1, y_s1 + real :: x_s2, y_s2 + real :: x_o1, y_o1 + real :: x_o2, y_o2 + logical :: has_o1 + logical :: has_o2 + ! + ! Parameters + ! + ! q - pump discharge + ! width - gate / culvert width + ! sill_elevation - gate sill elevation + ! mannings_n - gate Manning's n + ! opening_duration - time (s) to go from closed to fully open + ! closing_duration - time (s) to go from open to fully closed + ! flow_coef - culvert_simple / check_valve / culvert flow coefficient + ! height - culvert pipe height (m, rectangular cross-section) + ! invert_1 - culvert bed elevation at endpoint 1 (m) + ! invert_2 - culvert bed elevation at endpoint 2 (m) + ! submergence_ratio - culvert submergence threshold h_dn/h_up (-) + ! + real :: q + real :: width + real :: sill_elevation + real :: mannings_n + real :: opening_duration + real :: closing_duration + real :: flow_coef + ! + ! Detailed-culvert geometry + submergence threshold + ! + real :: height + real :: invert_1 + real :: invert_2 + real :: submergence_ratio + ! + ! Dike breach parameters (structure_dike_breach only) + ! + real :: z_crest ! initial crest elevation (m) + real :: t_breach ! breach start time (s since t=0) + real :: z_min ! minimum breach level (m) + real :: B0 ! initial breach width at start of phase 2 (m) + real :: t0 ! duration of phase 1: crest lowering (s) + integer :: dike_core ! core material: 1=sand, 2=clay + ! + ! Ordered list of gate control rules (parsed by marshal). Unallocated + ! or zero-length means "no rules": the structure stays fully open and + ! the runtime skips the rule machinery entirely. + ! + type(t_gate_rule), allocatable :: rules(:) + ! + end type t_src_structure + ! + ! Module-level storage for structures parsed from a TOML input file. + ! Populated by the dispatcher and flattened into the flat arrays below + ! by the marshal. + ! + type(t_src_structure), allocatable :: src_structures(:) ! intermediate derived-type array; flattened + deallocated by marshal_src_structures_to_flat_arrays on the toml path (gpu deep-copy avoidance). + ! + ! Module-level runtime state for src structures (moved from sfincs_data). + ! Populated by the legacy reader or by marshal_src_structures_to_flat_arrays + ! from the TOML path; consumed by update_src_structures and the his output. + ! Public so downstream modules (sfincs_openacc, sfincs_output, sfincs_ncoutput, + ! sfincs_lib) can reference them. + ! + ! Meta / name + ! + integer, parameter :: src_struc_name_len = 128 ! max length of struct name strings + character(len=src_struc_name_len), dimension(:), allocatable, public :: src_struc_name + ! + ! Kind / state + ! + integer*1, dimension(:), allocatable, public :: src_struc_type + integer, dimension(:), allocatable, public :: src_struc_direction ! direction_* code; honoured by culvert_simple and culvert + real*4, dimension(:), allocatable, public :: src_struc_distance + real*4, dimension(:), allocatable, public :: src_struc_fraction_open + ! + ! Input file path (sfincs.inp keyword 'drnfile'); 'none' when no drainage + ! structures file is supplied. + ! + character(len=256), public :: drnfile + ! + ! Input file path (sfincs.inp keyword 'dkbfile'); 'none' when no dike + ! breach file is supplied. Entries are appended to the same flat arrays + ! as drnfile structures so the runtime sees one unified pool. + ! + character(len=256), public :: dkbfile + ! + ! Cell mapping + ! + integer, public :: nr_src_structures + integer*4, dimension(:), allocatable, public :: src_struc_nm_s1 ! (nr_src_structures) endpoint-1 cell indices + integer*4, dimension(:), allocatable, public :: src_struc_nm_s2 ! (nr_src_structures) endpoint-2 cell indices + integer*4, dimension(:), allocatable, public :: src_struc_nm_o1 ! (nr_src_structures) obs-1 cell indices (gate rule inputs; defaults to endpoint-1 cell) + integer*4, dimension(:), allocatable, public :: src_struc_nm_o2 ! (nr_src_structures) obs-2 cell indices (gate rule inputs; defaults to endpoint-2 cell) + ! + ! Coordinates + ! + real*4, dimension(:), allocatable, public :: src_struc_x_s1, src_struc_y_s1 + real*4, dimension(:), allocatable, public :: src_struc_x_s2, src_struc_y_s2 + real*4, dimension(:), allocatable, public :: src_struc_x_o1, src_struc_y_o1 + real*4, dimension(:), allocatable, public :: src_struc_x_o2, src_struc_y_o2 + ! + ! Named parameters + ! + real*4, dimension(:), allocatable, public :: src_struc_q ! pump discharge + real*4, dimension(:), allocatable, public :: src_struc_flow_coef ! culvert_simple / check_valve / culvert flow coefficient + real*4, dimension(:), allocatable, public :: src_struc_width ! gate / culvert width + real*4, dimension(:), allocatable, public :: src_struc_sill_elevation ! gate sill elevation + real*4, dimension(:), allocatable, public :: src_struc_mannings_n ! gate / culvert Manning's n + real*4, dimension(:), allocatable, public :: src_struc_opening_duration ! gate opening duration (s) + real*4, dimension(:), allocatable, public :: src_struc_closing_duration ! gate closing duration (s) + ! + ! Detailed-culvert geometry + ! + real*4, dimension(:), allocatable, public :: src_struc_height ! culvert pipe height (m) + real*4, dimension(:), allocatable, public :: src_struc_invert_1 ! culvert bed elevation at endpoint 1 (m) + real*4, dimension(:), allocatable, public :: src_struc_invert_2 ! culvert bed elevation at endpoint 2 (m) + ! + ! Detailed-culvert submergence threshold + ! + real*4, dimension(:), allocatable, public :: src_struc_submergence_ratio ! culvert submergence threshold h_dn/h_up (-) + ! + ! Dike breach parameters + ! + real*4, dimension(:), allocatable, public :: src_struc_z_crest ! initial crest elevation (m) + real*4, dimension(:), allocatable, public :: src_struc_t_breach ! breach start time (s) + real*4, dimension(:), allocatable, public :: src_struc_z_min ! minimum breach level (m) + real*4, dimension(:), allocatable, public :: src_struc_B0 ! initial breach width (m) + real*4, dimension(:), allocatable, public :: src_struc_t0 ! phase-1 duration (s) + integer, dimension(:), allocatable, public :: src_struc_dike_core ! 1=sand, 2=clay + ! + ! Dike breach runtime state + ! + real*4, dimension(:), allocatable, public :: src_struc_breach_width ! current breach width (m) + real*4, dimension(:), allocatable, public :: src_struc_breach_level ! current breach crest level (m) + ! + ! Runtime state + ! + real*4, dimension(:), allocatable, public :: src_struc_q_now ! (nr_src_structures) signed discharge this step per structure, mirrors the qsrc pattern + ! + ! Ordered gate-rule lists, flattened across all structures into shared + ! concatenated arrays (mirrors the rule_* bytecode registry pattern so + ! the data is GPU-friendly - no ragged arrays, no allocatable components). + ! + ! src_struc_rule_start(i) is the 1-based offset into rule_list_* of the + ! first rule for structure i (0 = structure has no rules); src_struc_rule_count(i) + ! is how many rules it has. rule_list_op(j) is the operation (gate_op_*) and + ! rule_list_id(j) the rule_id into the sfincs_rule_expression registry. + ! rule_list_src(j) holds the raw "when" string for log emission only and + ! does not travel to GPU. + ! + integer, dimension(:), allocatable, public :: src_struc_rule_start ! (nr_src_structures) 1-based start in rule_list_*, 0 = no rules + integer, dimension(:), allocatable, public :: src_struc_rule_count ! (nr_src_structures) number of rules + ! + integer, public :: nr_rule_list = 0 ! total length of the concatenated rule lists + integer, dimension(:), allocatable, public :: rule_list_op ! (nr_rule_list) gate_op_* per rule + integer, dimension(:), allocatable, public :: rule_list_id ! (nr_rule_list) rule_id into sfincs_rule_expression registry + ! + integer, parameter :: src_struc_rule_src_len = 256 + character(len=src_struc_rule_src_len), dimension(:), allocatable, public :: rule_list_src ! (nr_rule_list) raw "when" string, log only + ! +contains + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine initialize_src_structures() + ! + ! Dispatcher for the src_structures / drainage input file. + ! + ! Probes the file with toml-f. If it parses as TOML, the TOML reader + ! populates the module-level src_structures(:) array. If toml-f rejects + ! it, the file is assumed to be in the legacy fixed-column format and + ! is transcribed on-the-fly into a TOML sibling file, which is then + ! read via the same TOML path. This keeps only one parser alive in the + ! source tree. + ! + ! If a file parses as TOML but fails semantic validation (e.g. a + ! missing required field), that is treated as a hard error. + ! + ! After parsing, the derived-type src_structures(:) array is flattened + ! into the src_struc_* 1D arrays (the runtime's sole state representation), + ! grid-cell indices and distances are resolved, a descriptive block is + ! written to the log, and gate statuses are seeded from the initial + ! water-level field. + ! + ! Called from: sfincs_lib (once, at init time). + ! + use sfincs_data + use quadtree + use tomlf, only : toml_table, toml_error, toml_load + ! + implicit none + ! + ! Dispatcher locals + ! + type(toml_table), allocatable :: probe_top + type(toml_error), allocatable :: probe_err + integer :: ierr_toml, ierr_conv + logical :: ok, is_toml + character(len=512) :: toml_path + ! + ! dkbfile locals + ! + type(t_src_structure), allocatable :: src_structures_dkb(:) + type(t_src_structure), allocatable :: src_structures_all(:) + integer :: n_drn, n_dkb + ! + ! Marshal locals + ! + integer :: i, j, ierr_parse, irule, nr_rules_i + character(len=256) :: errmsg + ! + ! Cell-index / distance locals + ! + integer :: istruc, nmq + real*4 :: x_s1_tmp, y_s1_tmp, x_s2_tmp, y_s2_tmp + ! + ! Gate-position seeding locals + ! + integer :: nm_o1, nm_o2, k, iop + real :: zs_o1, zs_o2 + character(len=16) :: status_str + ! + drainage_structures = .false. + ! + if (drnfile(1:4) == 'none' .and. dkbfile(1:4) == 'none') return + ! + ! Read drnfile (drainage structures: pumps / culverts / gates). + ! Skipped when drnfile = 'none'; dkbfile-only runs are valid. + ! + if (drnfile(1:4) /= 'none') then + ! + ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) + ! + ! Probe TOML / convert legacy / re-read TOML + ! + call toml_load(probe_top, drnfile, error=probe_err) + ! + is_toml = .not. allocated(probe_err) + ! + if (allocated(probe_err)) deallocate(probe_err) + if (allocated(probe_top)) deallocate(probe_top) + ! + if (is_toml) then + toml_path = drnfile + else + call convert_legacy_to_toml(drnfile, toml_path, ierr_conv) + if (ierr_conv /= 0) then + write(logstr,'(a,a,a)')' Error ! Failed to convert legacy drn file "', trim(drnfile), & + '" to TOML; see preceding log entries for the reason' + call stop_sfincs(trim(logstr), -1) + endif + endif + ! + call read_toml_src_structures(trim(toml_path), src_structures, ierr_toml) + ! + if (ierr_toml /= 0) then + write(logstr,'(a,a,a)')' Error ! Failed to load TOML src_structures file ', trim(toml_path), ' !' + call stop_sfincs(trim(logstr), -1) + endif + ! + endif + ! + ! If a dike breach file is also provided, read it and append its + ! entries to src_structures so the marshal sees one unified array. + ! + if (dkbfile(1:4) /= 'none') then + ! + ok = check_file_exists(dkbfile, 'Dike breach dkb file', .true.) + ! + call read_toml_src_structures(trim(dkbfile), src_structures_dkb, ierr_toml) + ! + if (ierr_toml /= 0) then + write(logstr,'(a,a,a)')' Error ! Failed to load TOML dkb file ', trim(dkbfile), ' !' + call stop_sfincs(trim(logstr), -1) + endif + ! + if (allocated(src_structures_dkb)) then + ! + n_drn = 0 + if (allocated(src_structures)) n_drn = size(src_structures) + n_dkb = size(src_structures_dkb) + ! + allocate(src_structures_all(n_drn + n_dkb)) + ! + if (n_drn > 0) src_structures_all(1:n_drn) = src_structures(1:n_drn) + src_structures_all(n_drn+1 : n_drn+n_dkb) = src_structures_dkb(1:n_dkb) + ! + if (allocated(src_structures)) deallocate(src_structures) + if (allocated(src_structures_dkb)) deallocate(src_structures_dkb) + ! + call move_alloc(src_structures_all, src_structures) + ! + endif + ! + endif + ! + ! Marshal src_structures(:) -> src_struc_* flat arrays. + ! + ! The runtime reads all src-structure state from flat per-struct + ! arrays (the src_struc_* family: src_struc_type, src_struc_q, src_struc_flow_coef, ...). + ! The TOML reader, however, naturally produces a derived-type array + ! src_structures(:) of t_src_structure, which carries allocatable + ! components: character(len=:), allocatable :: name, plus the rule + ! expression strings. + ! + ! nvfortran's openacc implicit deep-copy of derived types that + ! contain allocatable components has been unreliable in practice: + ! pushing a type(...), allocatable :: arr(:) with nested allocatables + ! to the device tends to produce runtime issues. Flat arrays of + ! primitive types (real, integer, fixed-length character) copy + ! cleanly across !$acc enter data copyin(...), so we keep the live + ! runtime state in those. + ! + ! The marshal is the one-shot bridge: toml -> src_structures(:) + ! -> src_struc_* flat arrays -> deallocate(src_structures). After it + ! runs, nothing of the derived-type array survives, so no gpu + ! region ever sees a problematic allocatable-in-derived-type. + ! + if (.not. allocated(src_structures)) then + ! + nr_src_structures = 0 + ! + call write_src_structures_log_summary() + ! + return + ! + endif + ! + nr_src_structures = size(src_structures) + ! + if (nr_src_structures <= 0) then + ! + deallocate(src_structures) + ! + call write_src_structures_log_summary() + ! + return + ! + endif + ! + ! drainage_structures is set after marshalling once src_struc_type is + ! populated; dike_breaching is set the same way (line ~755). + ! Both are resolved below via any() on the flat type array. + ! + ! Allocate flat arrays to size nr_src_structures and seed defaults. + ! + allocate(src_struc_nm_s1(nr_src_structures)) + allocate(src_struc_nm_s2(nr_src_structures)) + allocate(src_struc_nm_o1(nr_src_structures)) + allocate(src_struc_nm_o2(nr_src_structures)) + allocate(src_struc_q_now(nr_src_structures)) + allocate(src_struc_type(nr_src_structures)) + allocate(src_struc_direction(nr_src_structures)) + allocate(src_struc_distance(nr_src_structures)) + allocate(src_struc_fraction_open(nr_src_structures)) + allocate(src_struc_rule_start(nr_src_structures)) + allocate(src_struc_rule_count(nr_src_structures)) + allocate(src_struc_name(nr_src_structures)) + allocate(src_struc_x_s1(nr_src_structures)) + allocate(src_struc_y_s1(nr_src_structures)) + allocate(src_struc_x_s2(nr_src_structures)) + allocate(src_struc_y_s2(nr_src_structures)) + allocate(src_struc_x_o1(nr_src_structures)) + allocate(src_struc_y_o1(nr_src_structures)) + allocate(src_struc_x_o2(nr_src_structures)) + allocate(src_struc_y_o2(nr_src_structures)) + allocate(src_struc_q(nr_src_structures)) + allocate(src_struc_flow_coef(nr_src_structures)) + allocate(src_struc_width(nr_src_structures)) + allocate(src_struc_sill_elevation(nr_src_structures)) + allocate(src_struc_mannings_n(nr_src_structures)) + allocate(src_struc_opening_duration(nr_src_structures)) + allocate(src_struc_closing_duration(nr_src_structures)) + allocate(src_struc_height(nr_src_structures)) + allocate(src_struc_invert_1(nr_src_structures)) + allocate(src_struc_invert_2(nr_src_structures)) + allocate(src_struc_submergence_ratio(nr_src_structures)) + allocate(src_struc_z_crest(nr_src_structures)) + allocate(src_struc_t_breach(nr_src_structures)) + allocate(src_struc_z_min(nr_src_structures)) + allocate(src_struc_B0(nr_src_structures)) + allocate(src_struc_t0(nr_src_structures)) + allocate(src_struc_dike_core(nr_src_structures)) + allocate(src_struc_breach_width(nr_src_structures)) + allocate(src_struc_breach_level(nr_src_structures)) + ! + src_struc_rule_start = 0 + src_struc_rule_count = 0 + ! + src_struc_nm_s1 = 0 + src_struc_nm_s2 = 0 + src_struc_nm_o1 = 0 + src_struc_nm_o2 = 0 + src_struc_q_now = 0.0 + src_struc_type = 0 + src_struc_direction = direction_both + src_struc_distance = 0.0 + src_struc_fraction_open = 1.0 ! default "fully open": structures without rules use this as a no-op multiplier in the common-tail scaling. Rule-driven structures are re-seeded at init below. + src_struc_name = ' ' + src_struc_x_s1 = 0.0 + src_struc_y_s1 = 0.0 + src_struc_x_s2 = 0.0 + src_struc_y_s2 = 0.0 + src_struc_x_o1 = 0.0 + src_struc_y_o1 = 0.0 + src_struc_x_o2 = 0.0 + src_struc_y_o2 = 0.0 + src_struc_q = 0.0 + src_struc_flow_coef = 1.0 + src_struc_width = 0.0 + src_struc_sill_elevation = 0.0 + src_struc_mannings_n = 0.024 + src_struc_opening_duration = 600.0 + src_struc_closing_duration = 600.0 + src_struc_height = 0.0 + src_struc_invert_1 = 0.0 + src_struc_invert_2 = 0.0 + src_struc_submergence_ratio = 0.667 + src_struc_z_crest = 0.0 + src_struc_t_breach = 0.0 + src_struc_z_min = 0.0 + src_struc_B0 = 0.0 + src_struc_t0 = 0.0 + src_struc_dike_core = 1 + src_struc_breach_width = 0.0 + src_struc_breach_level = 0.0 + ! + ! Count the total number of gate rules across all structures and allocate + ! the concatenated rule_list_* arrays (size 0 when no structure has rules, + ! so the downstream openacc directives can still reference them safely). + ! + nr_rule_list = 0 + do i = 1, nr_src_structures + if (allocated(src_structures(i)%rules)) nr_rule_list = nr_rule_list + size(src_structures(i)%rules) + enddo + ! + allocate(rule_list_op(nr_rule_list)) + allocate(rule_list_id(nr_rule_list)) + allocate(rule_list_src(nr_rule_list)) + ! + ! Copy scalar / coord / string / parameter fields from src_structures(:) + ! into the flat arrays, and concatenate each structure's gate-rule list + ! into rule_list_* (parsing each "when" expression via add_rule). + ! + irule = 0 + ! + do i = 1, nr_src_structures + ! + ! String fields: truncation warning if longer than src_struc_name_len. + ! + if (allocated(src_structures(i)%name)) then + ! + if (len(src_structures(i)%name) > src_struc_name_len) then + ! + write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure name length > ', src_struc_name_len, & + ' at entry ', i, '; truncating' + call write_log(logstr, 0) + ! + endif + ! + src_struc_name(i) = src_structures(i)%name + ! + endif + ! + src_struc_type(i) = int(src_structures(i)%structure_type, 1) + src_struc_direction(i) = src_structures(i)%direction + ! + src_struc_x_s1(i) = src_structures(i)%x_s1 + src_struc_y_s1(i) = src_structures(i)%y_s1 + src_struc_x_s2(i) = src_structures(i)%x_s2 + src_struc_y_s2(i) = src_structures(i)%y_s2 + ! + ! obs 1 / obs 2 default to the corresponding endpoint when the TOML + ! reader did not see the key (tracked via has_o1 / has_o2). + ! This lets 0.0 remain a legal coordinate value. + ! + if (src_structures(i)%has_o1) then + ! + src_struc_x_o1(i) = src_structures(i)%x_o1 + src_struc_y_o1(i) = src_structures(i)%y_o1 + ! + else + ! + src_struc_x_o1(i) = src_structures(i)%x_s1 + src_struc_y_o1(i) = src_structures(i)%y_s1 + ! + endif + ! + if (src_structures(i)%has_o2) then + ! + src_struc_x_o2(i) = src_structures(i)%x_o2 + src_struc_y_o2(i) = src_structures(i)%y_o2 + ! + else + ! + src_struc_x_o2(i) = src_structures(i)%x_s2 + src_struc_y_o2(i) = src_structures(i)%y_s2 + ! + endif + ! + src_struc_q(i) = src_structures(i)%q + src_struc_flow_coef(i) = src_structures(i)%flow_coef + src_struc_width(i) = src_structures(i)%width + src_struc_sill_elevation(i) = src_structures(i)%sill_elevation + src_struc_mannings_n(i) = src_structures(i)%mannings_n + src_struc_opening_duration(i) = src_structures(i)%opening_duration + src_struc_closing_duration(i) = src_structures(i)%closing_duration + src_struc_height(i) = src_structures(i)%height + src_struc_invert_1(i) = src_structures(i)%invert_1 + src_struc_invert_2(i) = src_structures(i)%invert_2 + src_struc_submergence_ratio(i) = src_structures(i)%submergence_ratio + ! + if (src_structures(i)%structure_type == structure_dike_breach) then + src_struc_z_crest(i) = src_structures(i)%z_crest + src_struc_t_breach(i) = src_structures(i)%t_breach + src_struc_z_min(i) = src_structures(i)%z_min + src_struc_B0(i) = src_structures(i)%B0 + src_struc_t0(i) = src_structures(i)%t0 + src_struc_dike_core(i) = src_structures(i)%dike_core + src_struc_breach_level(i) = src_structures(i)%z_crest ! starts at crest + src_struc_breach_width(i) = 0.0 + endif + ! + ! Gate control rules: concatenate this structure's ordered list into + ! the shared rule_list_* arrays. Each "when" expression is compiled to + ! bytecode via add_rule; the operation code and raw string travel + ! alongside the resulting rule_id. + ! + if (allocated(src_structures(i)%rules)) then + ! + nr_rules_i = size(src_structures(i)%rules) + ! + if (nr_rules_i > 0) then + ! + src_struc_rule_start(i) = irule + 1 + src_struc_rule_count(i) = nr_rules_i + ! + do j = 1, nr_rules_i + ! + irule = irule + 1 + ! + call add_rule(src_structures(i)%rules(j)%when, & + rule_list_id(irule), ierr_parse, errmsg) + ! + if (ierr_parse /= 0) then + ! + write(logstr,'(a,a,a,i0,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & + '" rule ', j, ' parse failed: ', trim(errmsg) + call write_log(logstr, 1) + call stop_sfincs(trim(logstr), -1) + ! + endif + ! + rule_list_op(irule) = src_structures(i)%rules(j)%op + rule_list_src(irule) = src_structures(i)%rules(j)%when + ! + enddo + ! + endif + ! + endif + ! + enddo + ! + ! Shrink the shared rule bytecode stream to exactly the concatenated + ! length (also allocates zero-length arrays when no rules were seen). + ! + call finalize_rule_storage() + ! + ! Drop the derived-type array; flat arrays carry all runtime state now. + ! + deallocate(src_structures) + ! + ! Resolve cell-index lookups (src_struc_nm_s1 / _s2 / _o1 / _o2) + ! and centre-to-centre distance from coordinate pairs. + ! + do istruc = 1, nr_src_structures + ! + nmq = find_quadtree_cell(src_struc_x_s1(istruc), src_struc_y_s1(istruc)) + if (nmq > 0) src_struc_nm_s1(istruc) = index_sfincs_in_quadtree(nmq) + ! + nmq = find_quadtree_cell(src_struc_x_s2(istruc), src_struc_y_s2(istruc)) + if (nmq > 0) src_struc_nm_s2(istruc) = index_sfincs_in_quadtree(nmq) + ! + ! obs cell indices feed the gate rule evaluator. The marshal has + ! already defaulted x_o1/y_o1 and x_o2/y_o2 to the endpoint + ! coordinates when the TOML reader did not see the keys, so this + ! lookup gives us obs-1 == endpoint-1 and obs-2 == endpoint-2 for + ! those cases without extra branching. + ! + nmq = find_quadtree_cell(src_struc_x_o1(istruc), src_struc_y_o1(istruc)) + if (nmq > 0) src_struc_nm_o1(istruc) = index_sfincs_in_quadtree(nmq) + ! + nmq = find_quadtree_cell(src_struc_x_o2(istruc), src_struc_y_o2(istruc)) + if (nmq > 0) src_struc_nm_o2(istruc) = index_sfincs_in_quadtree(nmq) + ! + if (src_struc_nm_s1(istruc) > 0 .and. src_struc_nm_s2(istruc) > 0) then + ! + x_s1_tmp = z_xz(src_struc_nm_s1(istruc)) + y_s1_tmp = z_yz(src_struc_nm_s1(istruc)) + x_s2_tmp = z_xz(src_struc_nm_s2(istruc)) + y_s2_tmp = z_yz(src_struc_nm_s2(istruc)) + src_struc_distance(istruc) = sqrt( (x_s2_tmp - x_s1_tmp)**2 + (y_s2_tmp - y_s1_tmp)**2 ) + ! + endif + ! + enddo + ! + if (any(src_struc_nm_s1 == 0) .or. any(src_struc_nm_s2 == 0)) then + ! + write(logstr,'(a)') 'Warning ! For some source-structure endpoints no matching active grid cell was found!' + call write_log(logstr, 0) + write(logstr,'(a)') 'Warning ! These points will be skipped, please check your input!' + call write_log(logstr, 0) + ! + endif + ! + dike_breaching = any(src_struc_type == structure_dike_breach) + drainage_structures = any(src_struc_type /= structure_dike_breach) + ! + ! Write the per-structure descriptive block to the log file. + ! Emitted before the gate-position seeding so the per-gate init lines + ! trail the structure block they annotate. + ! + call write_src_structures_log_summary() + ! + ! Initial-position seeding for rule-driven structures. + ! + ! zs(:) has already been populated by initialize_domain -> initialize_hydro + ! -> set_initial_conditions by the time we get here, so obs-point lookups + ! against zs are valid. Structures without rules keep the default + ! fraction_open = 1.0 ("always open"), a no-op in the common-tail scaling. + ! + ! For rule-driven structures the rule list is evaluated once (first match + ! wins) and the gate is snapped to the resulting target: open -> 1.0, + ! close -> 0.0. If the first match is "hold", or no rule fires, there is + ! no prior position to hold, so the gate starts closed (0.0). + ! + do istruc = 1, nr_src_structures + ! + ! Skip structures without rules - keep the "always open" default. + ! + if (src_struc_rule_count(istruc) <= 0) cycle + ! + nm_o1 = src_struc_nm_o1(istruc) + nm_o2 = src_struc_nm_o2(istruc) + ! + if (nm_o1 > 0) then + zs_o1 = real(zs(nm_o1), 4) + else + zs_o1 = 0.0 + endif + ! + if (nm_o2 > 0) then + zs_o2 = real(zs(nm_o2), 4) + else + zs_o2 = 0.0 + endif + ! + ! First matching rule wins; default to hold (-> closed at init). + ! + iop = gate_op_hold + ! + do k = 1, src_struc_rule_count(istruc) + ! + if (evaluate_rule(rule_list_id(src_struc_rule_start(istruc) + k - 1), zs_o1, zs_o2)) then + ! + iop = rule_list_op(src_struc_rule_start(istruc) + k - 1) + exit + ! + endif + ! + enddo + ! + if (iop == gate_op_open) then + ! + src_struc_fraction_open(istruc) = 1.0 + status_str = 'open' + ! + else + ! + ! close, or hold/none at init (no prior position to hold) + ! + src_struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + endif + ! + write(logstr,'(a,a,a,a)')'structure ', trim(src_struc_name(istruc)), & + ' initialised ', trim(status_str) + call write_log(logstr, 0) + ! + enddo + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine update_src_structures(t, dt) + ! + ! Compute discharges through each drainage structure, accumulate them + ! into qsrc(np) (endpoint 1: -qq, endpoint 2: +qq), and store + ! per-structure signed discharge in src_struc_q_now(nr_src_structures) + ! for his output. Sign convention: qq > 0 means flow from endpoint 1 + ! to endpoint 2. + ! + ! Called AFTER update_discharges, which zeros qsrc first. + ! + ! Atomic updates on qsrc(nm) guard against two structures (or a river + ! and a structure) writing to the same cell under parallel execution. + ! + ! Called from: update_continuity (sfincs_continuity), once per time step. + ! + use sfincs_data + use sfincs_timers + ! + implicit none + ! + real*8 :: t + real*4 :: dt + ! + integer :: istruc, nm_s1, nm_s2, nm_o1, nm_o2, k, iop + real*4 :: qq, zs_o1, zs_o2, target_frac + real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha + real*4 :: dh, a_eff + real*4 :: h_up, h_dn, qq_sign + ! + real*4 :: crest_breach, width_breach, z_crest_breach, z_min_breach + real*4 :: tstart_breach, tstart_widening, t_phase1_deepening + real*4 :: vk_f1, vk_f2, uc_material, elapsed_widening_hr, dt_hr + real*4 :: widening_deceleration, widening_rate + ! + if (nr_src_structures <= 0) return + ! + call timer_start('drainage structures') + ! + !$acc parallel loop present( z_volume, zs, zb, qsrc, src_struc_q_now, & + !$acc src_struc_nm_s1, src_struc_nm_s2, & + !$acc src_struc_nm_o1, src_struc_nm_o2, & + !$acc src_struc_type, src_struc_direction, & + !$acc src_struc_q, src_struc_flow_coef, & + !$acc src_struc_width, src_struc_sill_elevation, & + !$acc src_struc_mannings_n, & + !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_height, & + !$acc src_struc_invert_1, src_struc_invert_2, & + !$acc src_struc_submergence_ratio, & + !$acc src_struc_z_crest, src_struc_t_breach, src_struc_z_min, & + !$acc src_struc_B0, src_struc_t0, src_struc_dike_core, & + !$acc src_struc_breach_width, src_struc_breach_level, & + !$acc src_struc_distance, src_struc_fraction_open, & + !$acc src_struc_rule_start, src_struc_rule_count, & + !$acc rule_list_op, rule_list_id, & + !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, & + !$acc rule_start, rule_length ) & + !$acc private( nm_s1, nm_s2, nm_o1, nm_o2, qq, k, iop, target_frac, & + !$acc zs_o1, zs_o2, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & + !$acc dh, a_eff, & + !$acc h_up, h_dn, qq_sign, & + !$acc crest_breach, width_breach, z_crest_breach, z_min_breach, & + !$acc tstart_breach, tstart_widening, t_phase1_deepening, & + !$acc vk_f1, vk_f2, uc_material, elapsed_widening_hr, dt_hr, & + !$acc widening_deceleration, widening_rate ) + !$omp parallel do & + !$omp private( nm_s1, nm_s2, nm_o1, nm_o2, qq, k, iop, target_frac, & + !$omp zs_o1, zs_o2, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & + !$omp dh, a_eff, & + !$omp h_up, h_dn, qq_sign, & + !$omp crest_breach, width_breach, z_crest_breach, z_min_breach, & + !$omp tstart_breach, tstart_widening, t_phase1_deepening, & + !$omp vk_f1, vk_f2, uc_material, elapsed_widening_hr, dt_hr, & + !$omp widening_deceleration, widening_rate ) & + !$omp schedule ( static ) + do istruc = 1, nr_src_structures + ! + nm_s1 = src_struc_nm_s1(istruc) + nm_s2 = src_struc_nm_s2(istruc) + ! + if (nm_s1 > 0 .and. nm_s2 > 0) then + ! + ! Ordered gate-rule list (any structure type). + ! + ! Only runs if the structure has rules. Structures without rules + ! stay at the init-time default fraction_open = 1.0 ("always open"), + ! which turns the common-tail scaling below into a no-op. + ! + ! Each step the rules are evaluated in order; the first whose "when" + ! expression fires sets the target gate position (open -> 1.0, + ! close -> 0.0, hold -> freeze at the current fraction). If no rule + ! fires the gate holds. The gate then ramps toward the target at + ! 1/opening_duration (opening) or 1/closing_duration (closing); a + ! target that flips mid-ramp simply reverses direction from the + ! current fraction, so the scheme is interruptible by construction. + ! Obs points feed the rule inputs and default to the src pair. + ! + if (src_struc_rule_count(istruc) > 0) then + ! + nm_o1 = src_struc_nm_o1(istruc) + nm_o2 = src_struc_nm_o2(istruc) + ! + if (nm_o1 > 0) then + zs_o1 = real(zs(nm_o1), 4) + else + zs_o1 = 0.0 + endif + ! + if (nm_o2 > 0) then + zs_o2 = real(zs(nm_o2), 4) + else + zs_o2 = 0.0 + endif + ! + ! First matching rule wins; default to hold when none fires. + ! + iop = gate_op_hold + ! + do k = 1, src_struc_rule_count(istruc) + ! + if (evaluate_rule(rule_list_id(src_struc_rule_start(istruc) + k - 1), zs_o1, zs_o2)) then + ! + iop = rule_list_op(src_struc_rule_start(istruc) + k - 1) + exit + ! + endif + ! + enddo + ! + frac = src_struc_fraction_open(istruc) + ! + if (iop == gate_op_open) then + target_frac = 1.0 + elseif (iop == gate_op_close) then + target_frac = 0.0 + else + target_frac = frac ! hold: freeze at current fraction + endif + ! + ! Ramp toward the target. A zero/negative duration snaps instantly. + ! + if (target_frac > frac) then + ! + if (src_struc_opening_duration(istruc) <= 0.0) then + frac = target_frac + else + frac = min(frac + dt / src_struc_opening_duration(istruc), target_frac) + endif + ! + elseif (target_frac < frac) then + ! + if (src_struc_closing_duration(istruc) <= 0.0) then + frac = target_frac + else + frac = max(frac - dt / src_struc_closing_duration(istruc), target_frac) + endif + ! + endif + ! + src_struc_fraction_open(istruc) = frac + ! + endif + ! + ! Per-type flux formula. Produces a raw signed discharge qq in + ! m^3/s, before the common-tail scaling by fraction_open and + ! direction filter. + ! + select case(src_struc_type(istruc)) + ! + case(structure_pump) + ! + ! Pump endpoint mapping: endpoint 1 (nm_s1) is the intake, + ! endpoint 2 (nm_s2) is the discharge. The pump enforces + ! qq >= 0 (no reverse flow); the sign convention in the + ! common tail below then sends water from nm_s1 to nm_s2. + ! + qq = src_struc_q(istruc) + ! + ! Reduction curve: scale by upstream depth so the pump cannot + ! pump the intake cell dry. pump_reduction_depth is a module-level + ! constant (see top of module); not user-tunable. + ! + ! Turn this off for now. Does not work with subgrid. + ! + !h_up = max(real(zs(nm_s1), 4) - zb(nm_s1), 0.0) + !qq = qq * min(1.0, h_up / pump_reduction_depth) + ! + case(structure_culvert_simple) + ! + ! Bidirectional: Q = flow_coef * sign(dh) * sqrt(|dh|). + ! The legacy "check_valve" alias maps to direction_positive + ! in the parser; the direction filter in the common tail + ! below restricts the allowed sign when requested. + ! + if (zs(nm_s1) > zs(nm_s2)) then + ! + qq = src_struc_flow_coef(istruc) * sqrt(zs(nm_s1) - zs(nm_s2)) + ! + else + ! + qq = -src_struc_flow_coef(istruc) * sqrt(zs(nm_s2) - zs(nm_s1)) + ! + endif + ! + case(structure_culvert) + ! + ! Regime-aware culvert. The controlling sill is the higher + ! of the two inverts (flow cannot pass until the upstream + ! water level reaches it). Upstream / downstream are picked + ! by the water-level difference, so the structure is + ! bidirectional and the direction filter in the common tail + ! below restricts the sign when requested. + ! + ! Two regimes, selected by h_dn/h_up against the user-set + ! submergence_ratio threshold (default 2/3 = 0.667, the + ! standard broad-crested-weir / Villemonte value): + ! + ! submerged (h_dn/h_up >= threshold): + ! qq = flow_coef * a_eff * sqrt(2 g |dh|) + ! free / inlet-controlled (h_dn/h_up < threshold): + ! qq = flow_coef * a_eff * sqrt(2 g h_up) + ! + ! The flow area a_eff = width * min(h_up, height) caps at + ! the barrel height, so a deeply-submerged inlet can't + ! give unbounded discharge. + ! + zsill = max(src_struc_invert_1(istruc), src_struc_invert_2(istruc)) + ! + dh = real(zs(nm_s1), 4) - real(zs(nm_s2), 4) + ! + if (dh >= 0.0) then + ! + h_up = max(real(zs(nm_s1), 4) - zsill, 0.0) + h_dn = max(real(zs(nm_s2), 4) - zsill, 0.0) + qq_sign = 1.0 + ! + else + ! + h_up = max(real(zs(nm_s2), 4) - zsill, 0.0) + h_dn = max(real(zs(nm_s1), 4) - zsill, 0.0) + qq_sign = -1.0 + ! + endif + ! + if (h_up <= 0.0) then + ! + qq = 0.0 + ! + else + ! + a_eff = src_struc_width(istruc) * min(h_up, src_struc_height(istruc)) + ! + if (h_dn / h_up >= src_struc_submergence_ratio(istruc)) then + ! + qq = qq_sign * src_struc_flow_coef(istruc) * a_eff * sqrt(2.0 * g * abs(dh)) + ! + else + ! + qq = qq_sign * src_struc_flow_coef(istruc) * a_eff * sqrt(2.0 * g * h_up) + ! + endif + ! + endif + ! + case(structure_gate) + ! + ! Bidirectional culvert-style flow. Flow uses the src pair + ! (nm_s1/nm_s2), not the obs pair. Bates et al. (2010) + ! inertial formulation, per unit width: + ! q^{n+1} = (q^n - g*h*(dzs/ds)*dt) / + ! (1 + g*n^2*dt*|q^n| / h^{7/3}) + ! with h = max(max(zs_s1, zs_s2) - zsill, 0). + ! Multiply by width to get the full structure discharge; + ! scaling by fraction_open happens in the common tail. + ! src_struc_q_now(istruc) holds the previous step's discharge + ! after the full common-tail scaling (width*fraction_open), + ! so unscale by (width*fraction_open) to recover qq0 in + ! per-unit-width form. Sign convention: qq > 0 means flow + ! nm_s1 -> nm_s2, matching dzds = (zs_s2 - zs_s1)/dist. + ! + frac = src_struc_fraction_open(istruc) + wdt = src_struc_width(istruc) + mng = src_struc_mannings_n(istruc) + zsill = src_struc_sill_elevation(istruc) + dist = src_struc_distance(istruc) + ! + dzds = (real(zs(nm_s2), 4) - real(zs(nm_s1), 4)) / dist + hgate = max(max(real(zs(nm_s1), 4), real(zs(nm_s2), 4)) - zsill, 0.0) + ! + if (hgate > 0.0 .and. frac > 0.0) then + ! + qq0 = src_struc_q_now(istruc) / (wdt * max(frac, 0.001)) + qq = (qq0 - g * hgate * dzds * dt) / & + (1.0 + g * mng * mng * dt * abs(qq0) / hgate**(7.0/3.0)) + qq = qq * wdt + qq = src_struc_flow_coef(istruc) * qq + ! + else + ! + qq = 0.0 + ! + endif + ! + case(structure_dike_breach) + ! + ! Verheij-Knaap (2003): two-phase dike breach. + ! Water levels are read from the obs pair (obs_1 = inside / + ! high-head side; obs_2 = outside / low-head side), which + ! default to the src pair when not user-specified. + ! Flow direction and submergence follow the same pattern + ! as structure_culvert (h_up / h_dn / src_struc_submergence_ratio). + ! + nm_o1 = src_struc_nm_o1(istruc) + nm_o2 = src_struc_nm_o2(istruc) + ! + z_crest_breach = src_struc_z_crest(istruc) + z_min_breach = src_struc_z_min(istruc) + tstart_breach = src_struc_t_breach(istruc) + tstart_widening = src_struc_t0(istruc) + t_phase1_deepening = tstart_breach + tstart_widening + ! + width_breach = src_struc_breach_width(istruc) + crest_breach = src_struc_breach_level(istruc) + ! + if (src_struc_dike_core(istruc) == 1) then + vk_f1 = 1.3; vk_f2 = 0.04; uc_material = 0.2 ! sand + else + vk_f1 = 1.3; vk_f2 = 0.04; uc_material = 0.5 ! clay + endif + ! + ! --- Breach geometry update --- + ! + if (real(t, 4) >= tstart_breach) then + ! + if (real(t, 4) < t_phase1_deepening) then + ! + ! Phase 1: crest lowers linearly to z_min over t0; width = B0 + ! + crest_breach = z_crest_breach - (z_crest_breach - z_min_breach) * & + (real(t, 4) - tstart_breach) / tstart_widening + width_breach = src_struc_B0(istruc) + ! + else + ! + ! Phase 2: crest at z_min, breach widens via Verheij formula. + ! Driving head H = upstream head above z_min minus downstream. + ! + crest_breach = z_min_breach + elapsed_widening_hr = (real(t, 4) - t_phase1_deepening) / 3600.0 + dt_hr = dt / 3600.0 + ! Only widen when obs_1 (inside) is higher than obs_2 (outside). + ! Reversed flow (ebb/return) is allowed but does not erode further. + if (real(zs(nm_o1), 4) > real(zs(nm_o2), 4)) then + h_up = max(real(zs(nm_o1), 4) - z_min_breach, 0.0) + h_dn = max(real(zs(nm_o2), 4) - z_min_breach, 0.0) + dh = max(h_up - h_dn, 0.0) + widening_deceleration = max(1.0 + (vk_f2 * g / uc_material) * elapsed_widening_hr, 1.0e-12) + widening_rate = (vk_f1 * vk_f2 / log(10.0)) * (g * dh)**1.5 / & + (uc_material * uc_material * widening_deceleration) + width_breach = width_breach + max(widening_rate, 0.0) * dt_hr + endif + ! + endif + ! + else + crest_breach = z_crest_breach + width_breach = 0.0 + endif + ! + src_struc_breach_level(istruc) = crest_breach + src_struc_breach_width(istruc) = width_breach + ! + ! --- Discharge through breach (culvert-style, obs-point WLs) --- + ! + dh = real(zs(nm_o1), 4) - real(zs(nm_o2), 4) + if (dh >= 0.0) then + h_up = max(real(zs(nm_o1), 4) - crest_breach, 0.0) + h_dn = max(real(zs(nm_o2), 4) - crest_breach, 0.0) + qq_sign = 1.0 + else + h_up = max(real(zs(nm_o2), 4) - crest_breach, 0.0) + h_dn = max(real(zs(nm_o1), 4) - crest_breach, 0.0) + qq_sign = -1.0 + endif + ! + if (h_up <= 0.0 .or. width_breach <= 0.0) then + qq = 0.0 + elseif (h_dn / h_up >= src_struc_submergence_ratio(istruc)) then + qq = qq_sign * width_breach * h_up * sqrt(2.0 * g * abs(dh)) + else + qq = qq_sign * 1.71 * width_breach * sqrt(g) * h_up**1.5 + endif + ! + end select + ! + ! Common tail: scale by fraction_open (state-machine output) and + ! apply the direction filter. Structures without rules sit at + ! fraction_open=1.0 so the scaling is a no-op; structures with + ! direction_both (the default) see the filter as a no-op too. + ! + qq = qq * src_struc_fraction_open(istruc) + ! + if (src_struc_direction(istruc) == direction_positive .and. qq < 0.0) qq = 0.0 + if (src_struc_direction(istruc) == direction_negative .and. qq > 0.0) qq = 0.0 + ! + ! Relaxation: blend new and previous discharge to damp oscillations. + ! structure_relax is a dimensionless step count: alpha = 1/N damps + ! the discharge response over roughly N time steps. Typical 1-10. + ! + alpha = 1.0 / structure_relax + qq = alpha * qq + (1.0 - alpha) * src_struc_q_now(istruc) + ! + ! Limit discharge by available volume in the donor cell (endpoint 1 + ! for qq > 0, endpoint 2 for qq < 0). + ! + if (subgrid) then + ! + if (qq > 0.0) then + ! + qq = min(qq, max(z_volume(nm_s1), 0.0) / dt) + ! + else + ! + qq = max(qq, -max(z_volume(nm_s2), 0.0) / dt) + ! + endif + ! + else + ! + if (qq > 0.0) then + ! + qq = min(qq, max((zs(nm_s1) - zb(nm_s1)) * cell_area(z_flags_iref(nm_s1)), 0.0) / dt) + ! + else + ! + qq = max(qq, -max((zs(nm_s2) - zb(nm_s2)) * cell_area(z_flags_iref(nm_s2)), 0.0) / dt) + ! + endif + ! + endif + ! + src_struc_q_now(istruc) = qq + ! + ! Accumulate into cell-wise qsrc. Atomic guards against multiple + ! structures (or a river and a structure) in the same cell. Sign + ! convention qq > 0 means flow nm_s1 -> nm_s2, so qq is subtracted + ! at endpoint 1 and added at endpoint 2. + ! + !$acc atomic update + !$omp atomic + qsrc(nm_s1) = qsrc(nm_s1) - qq + !$acc atomic update + !$omp atomic + qsrc(nm_s2) = qsrc(nm_s2) + qq + ! + endif + ! + enddo + !$omp end parallel do + !$acc end parallel loop + ! + call timer_stop('drainage structures') + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine read_toml_src_structures(filename, structures, ierr) + ! + ! Parse a TOML input file describing point source structures into an + ! allocatable array of t_src_structure. + ! + ! The TOML schema is an array of tables under the key "src_structure": + ! + ! [[src_structure]] + ! name = "south_tide_gate" ! required, string (sole identifier) + ! type = "gate" ! required, one of pump/culvert_simple/gate/culvert + ! ! legacy alias: "check_valve" -> culvert_simple + direction="positive" + ! ! note: "culvert" now resolves to the detailed-culvert physics type; + ! ! users wanting the lumped one-coefficient form must say + ! ! "culvert_simple" explicitly. Orifice behaviour is recoverable + ! ! as "culvert" with submergence_ratio = 0.0. + ! direction = "both" ! optional, culvert_simple/culvert only + ! ! one of "both" (default), "positive", "negative" + ! ! positive: allow flow src_1 -> src_2 only + ! ! negative: allow flow src_2 -> src_1 only + ! src_1 = [x, y] ; src_2 = [x, y] + ! obs_1 = [x, y] ; obs_2 = [x, y] + ! q = ... ! pump discharge + ! width = ... ; sill_elevation = ... ; mannings_n = ... + ! opening_duration = ... ; closing_duration = ... + ! flow_coef = ... ! culvert_simple / culvert flow coefficient + ! height = ... ! culvert pipe height (m) + ! invert_1 = ... ; invert_2 = ... ! culvert invert elevations at src_1/src_2 ends + ! submergence_ratio = ... ! culvert submergence threshold h_dn/h_up (-) + ! [[src_structure.rule]] ! optional, ordered list of gate control rules + ! operation = "close" ! one of "open" / "close" / "hold" + ! when = "z1-z2 < -0.03" ! trigger expression (rule mini-language) + ! [[src_structure.rule]] + ! operation = "open" + ! when = "z1 > -0.15 & z1-z2 > 0.09" + ! ! Rules are evaluated in order; the first whose + ! ! "when" fires sets the target (open=1, close=0, + ! ! hold=freeze). If none fires the gate holds. + ! ! The gate ramps toward the target over + ! ! opening_duration / closing_duration; a target + ! ! flip mid-ramp reverses smoothly (interruptible). + ! + ! Per-type required keys (enforced on parse): + ! pump : name, src_1, src_2, q + ! culvert_simple : name, src_1, src_2, flow_coef + ! gate : name, src_1, src_2, width, sill_elevation + ! culvert : name, src_1, src_2, + ! width, height, invert_1, invert_2 + ! (optional: flow_coef=0.6, submergence_ratio=0.667) + ! + ! On success, structures is allocated to the exact number of entries + ! (can be 0). On any I/O or parse failure, structures is left + ! unallocated and ierr is non-zero. + ! + ! This routine does not modify module state; it is the caller's job to + ! decide what to do with the parsed array. + ! + ! Called from: initialize_src_structures (this module). + ! + use tomlf + ! + implicit none + ! + character(len=*), intent(in) :: filename + type(t_src_structure), allocatable, intent(out) :: structures(:) + integer, intent(out) :: ierr + ! + type(toml_table), allocatable :: top + type(toml_error), allocatable :: err + type(toml_array), pointer :: arr_structs + type(toml_table), pointer :: tbl_struct + type(toml_array), pointer :: arr_rules + type(toml_table), pointer :: tbl_rule + character(len=:), allocatable :: name_str, type_str, rule_str, dir_str, type_str_lc, op_str + integer :: n_struct, n_rule, i, j, stat, ierr_parse + ! + ierr = 0 + ! + ! Parse the file. toml_load returns an allocatable table; on failure the + ! table is not allocated and err carries the diagnostic. + ! + call toml_load(top, filename, error=err) + ! + if (allocated(err)) then + ! + write(logstr,'(a,a,a,a)')' Error ! Failed to parse TOML file ', trim(filename), ': ', trim(err%message) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + if (.not. allocated(top)) then + ! + write(logstr,'(a,a)')' Error ! Could not load TOML file ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + ! Look for the top-level array of tables "src_structure". If it is not + ! present at all, treat that as "zero entries" (empty but valid). + ! + nullify(arr_structs) + call get_value(top, 'src_structure', arr_structs, requested=.false., stat=stat) + ! + if (.not. associated(arr_structs)) then + ! + allocate(structures(0)) + return + ! + endif + ! + if (.not. is_array_of_tables(arr_structs)) then + ! + write(logstr,'(a,a)')' Error ! Key "src_structure" must be an array of tables in ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + n_struct = len(arr_structs) + allocate(structures(n_struct)) + ! + do i = 1, n_struct + ! + nullify(tbl_struct) + call get_value(arr_structs, i, tbl_struct, stat=stat) + ! + if (.not. associated(tbl_struct)) then + ! + write(logstr,'(a,i0,a)')' Error ! src_structure entry ', i, ' is not a table' + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + ! Required name string (presence enforced by check_required below, + ! so that the missing-key error path flows through a single place). + ! + if (allocated(name_str)) deallocate(name_str) + call get_value(tbl_struct, 'name', name_str, stat=stat) + if (allocated(name_str)) structures(i)%name = name_str + ! + ! Required type string, mapped to structure_* code + ! + if (allocated(type_str)) deallocate(type_str) + call get_value(tbl_struct, 'type', type_str, stat=stat) + ! + if (.not. allocated(type_str)) then + ! + write(logstr,'(a,i0,a,a)')' Error ! Missing required "type" in src_structure entry ', i, & + ' of ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + ! + endif + ! + call parse_structure_type(type_str, structures(i)%structure_type, ierr_parse) + ! + if (ierr_parse /= 0) then + ! + ierr = ierr_parse + write(logstr,'(a,a,a,i0)')' Error ! Unknown structure type "', trim(type_str), & + '" in src_structure entry ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + ! Per-type required-field validation. Checked by key presence + ! (has_key) so that 0.0 remains a legal input value. + ! + select case (structures(i)%structure_type) + ! + case (structure_pump) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'q' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) + ! + case (structure_culvert_simple) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'flow_coef' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) + ! + case (structure_culvert) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'width', 'height', 'invert_1', 'invert_2' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) + ! + case (structure_gate) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'width', 'sill_elevation' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) + ! + case (structure_dike_breach) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'z_crest', 't_breach', 'z_min', 'B0', 't0' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) + ! + end select + ! + if (ierr /= 0) then + ! + call cleanup_on_error() + return + ! + endif + ! + ! Coordinates - src pair is required (enforced above). obs pair + ! defaults to src in the marshal when the key is absent; track + ! presence here so the marshal can distinguish "user gave (0,0)" + ! from "user gave nothing". + ! + call read_coord_pair(tbl_struct, 'src_1', structures(i)%x_s1, structures(i)%y_s1, i, ierr) + call read_coord_pair(tbl_struct, 'src_2', structures(i)%x_s2, structures(i)%y_s2, i, ierr) + ! + structures(i)%has_o1 = tbl_struct%has_key('obs_1') + structures(i)%has_o2 = tbl_struct%has_key('obs_2') + ! + call read_coord_pair(tbl_struct, 'obs_1', structures(i)%x_o1, structures(i)%y_o1, i, ierr) + call read_coord_pair(tbl_struct, 'obs_2', structures(i)%x_o2, structures(i)%y_o2, i, ierr) + ! + ! Named physical parameters. Defaults are picked to avoid NaN in + ! arithmetic and to match the legacy-reader fallbacks. + ! + call get_value(tbl_struct, 'q', structures(i)%q, 0.0, stat=stat) + call get_value(tbl_struct, 'width', structures(i)%width, 0.0, stat=stat) + call get_value(tbl_struct, 'sill_elevation', structures(i)%sill_elevation, 0.0, stat=stat) + ! + ! opening_duration / closing_duration default depends on type: gate keeps + ! its historical 600 s (legacy "dtype 4" gates always had finite ramp + ! durations), pump / culvert_simple / culvert default to 0 s (instant + ! open/close when a rule fires; skips the transient states 2 and 3). + ! + if (structures(i)%structure_type == structure_gate) then + ! + call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 600.0, stat=stat) + call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 600.0, stat=stat) + ! + else + ! + call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 0.0, stat=stat) + call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 0.0, stat=stat) + ! + endif + ! + ! flow_coef default differs by type: 1.0 for culvert_simple (legacy + ! lumped one-coefficient form), 0.6 for the detailed culvert + ! (standard orifice discharge coefficient). + ! + if (structures(i)%structure_type == structure_culvert) then + ! + call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 0.6, stat=stat) + ! + else + ! + call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 1.0, stat=stat) + ! + endif + ! + ! mannings_n (gate only). Default 0.024 for concrete-lined gate sill. + ! + call get_value(tbl_struct, 'mannings_n', structures(i)%mannings_n, 0.024, stat=stat) + ! + ! Detailed-culvert geometry + submergence threshold. Geometry keys + ! are required (enforced above); submergence_ratio defaults to 2/3 + ! (0.667), the standard broad-crested-weir / Villemonte value. + ! + call get_value(tbl_struct, 'height', structures(i)%height, 0.0, stat=stat) + call get_value(tbl_struct, 'invert_1', structures(i)%invert_1, 0.0, stat=stat) + call get_value(tbl_struct, 'invert_2', structures(i)%invert_2, 0.0, stat=stat) + call get_value(tbl_struct, 'submergence_ratio', structures(i)%submergence_ratio, 0.667, stat=stat) + ! + ! Dike breach parameters (ignored for other types) + ! + call get_value(tbl_struct, 'z_crest', structures(i)%z_crest, 0.0, stat=stat) + call get_value(tbl_struct, 't_breach', structures(i)%t_breach, 0.0, stat=stat) + call get_value(tbl_struct, 'z_min', structures(i)%z_min, 0.0, stat=stat) + call get_value(tbl_struct, 'B0', structures(i)%B0, 0.0, stat=stat) + call get_value(tbl_struct, 't0', structures(i)%t0, 0.0, stat=stat) + call get_value(tbl_struct, 'dike_core', structures(i)%dike_core, 1, stat=stat) + ! + ! Optional direction filter (culvert_simple / culvert). Default is + ! direction_both. Unknown strings are a hard error. + ! + structures(i)%direction = direction_both + ! + if (allocated(dir_str)) deallocate(dir_str) + call get_value(tbl_struct, 'direction', dir_str, stat=stat) + ! + if (allocated(dir_str)) then + ! + call parse_direction(dir_str, structures(i)%direction, ierr_parse) + ! + if (ierr_parse /= 0) then + ! + ierr = ierr_parse + write(logstr,'(a,a,a,i0)')' Error ! Unknown direction "', trim(dir_str), & + '" in src_structure entry ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + endif + ! + ! Legacy alias side-effect: "check_valve" always pins direction_positive + ! regardless of any explicit direction key. Detect on the lowered type + ! string so "Check_Valve" etc. are handled identically. + ! + type_str_lc = to_lower(type_str) + ! + if (type_str_lc == 'check_valve') then + ! + structures(i)%direction = direction_positive + ! + endif + ! + ! Optional ordered list of gate control rules under the sub-key + ! "rule" (an array of tables). Absent / empty leaves rules(:) + ! unallocated, which the marshal treats as "no rules". + ! + nullify(arr_rules) + call get_value(tbl_struct, 'rule', arr_rules, requested=.false., stat=stat) + ! + if (associated(arr_rules)) then + ! + if (.not. is_array_of_tables(arr_rules)) then + ! + write(logstr,'(a,i0,a)')' Error ! Key "rule" must be an array of tables in src_structure entry ', i, & + ' (use [[src_structure.rule]])' + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + ! + endif + ! + n_rule = len(arr_rules) + ! + if (n_rule > 0) then + ! + allocate(structures(i)%rules(n_rule)) + ! + do j = 1, n_rule + ! + nullify(tbl_rule) + call get_value(arr_rules, j, tbl_rule, stat=stat) + ! + if (.not. associated(tbl_rule)) then + write(logstr,'(a,i0,a,i0,a)')' Error ! rule ', j, ' in src_structure entry ', i, ' is not a table' + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + endif + ! + ! operation (required): open / close / hold + ! + if (allocated(op_str)) deallocate(op_str) + call get_value(tbl_rule, 'operation', op_str, stat=stat) + ! + if (.not. allocated(op_str)) then + write(logstr,'(a,i0,a,i0)')' Error ! Missing "operation" in rule ', j, & + ' of src_structure entry ', i + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + endif + ! + call parse_operation(op_str, structures(i)%rules(j)%op, ierr_parse) + ! + if (ierr_parse /= 0) then + write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown operation "', trim(op_str), & + '" in rule ', j, ' of src_structure entry ', i + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + endif + ! + ! when (required): the trigger expression + ! + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_rule, 'when', rule_str, stat=stat) + ! + if (.not. allocated(rule_str)) then + write(logstr,'(a,i0,a,i0)')' Error ! Missing "when" in rule ', j, & + ' of src_structure entry ', i + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + endif + ! + structures(i)%rules(j)%when = rule_str + ! + enddo + ! + endif + ! + endif + ! + enddo + ! + contains + ! + subroutine cleanup_on_error() + ! + ! Internal helper for the parse loop: drop the partially-filled + ! structures(:) array so the caller always sees it unallocated on + ! error exit. Trivial deallocator. + ! + ! Called from: read_toml_src_structures (host routine) on every + ! error bail-out path. + ! + if (allocated(structures)) deallocate(structures) + ! + end subroutine + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine check_required(table, keys, seq_index, ierr) + ! + ! Verify that every key in "keys" is present in the TOML table. Missing + ! keys are reported to the log (naming the structure by its 1-based + ! sequence index, since "name" itself may be the missing key) and ierr + ! is set non-zero. Presence is checked via has_key so that a legal + ! value of 0.0 is not mistaken for "missing". + ! + ! Called from: read_toml_src_structures (this module), once per + ! structure entry in the per-type required-field validation block. + ! + use tomlf + ! + implicit none + ! + type(toml_table), pointer, intent(in) :: table + character(len=*), intent(in) :: keys(:) + integer, intent(in) :: seq_index + integer, intent(inout) :: ierr + ! + integer :: k + ! + do k = 1, size(keys) + ! + if (.not. table%has_key(trim(keys(k)))) then + ! + write(logstr,'(a,i0,a,a,a)')' Error ! Structure #', seq_index, & + ' is missing required key "', trim(keys(k)), '"' + call write_log(logstr, 1) + ierr = 1 + ! + endif + ! + enddo + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine check_required_coord_pair(table, key_base, seq_index, ierr) + ! + ! Verify that a coordinate pair " = [x, y]" is present in the + ! TOML table. Emits a single missing-key error when absent. + ! + ! Called from: read_toml_src_structures (this module), once per required + ! coordinate pair (src_1, src_2) in the per-type validation block. + ! + use tomlf + ! + implicit none + ! + type(toml_table), pointer, intent(in) :: table + character(len=*), intent(in) :: key_base + integer, intent(in) :: seq_index + integer, intent(inout) :: ierr + ! + if (.not. table%has_key(trim(key_base))) then + ! + write(logstr,'(a,i0,a,a,a)')' Error ! Structure #', seq_index, & + ' is missing required coordinate pair "', trim(key_base), ' = [x, y]"' + call write_log(logstr, 1) + ierr = 1 + ! + endif + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine read_coord_pair(table, key_base, x, y, seq_index, ierr) + ! + ! Read a coordinate pair " = [x, y]" from a TOML table. + ! + ! If the key is absent, x and y are left at 0.0 and no error is raised + ! here — presence of required pairs is enforced separately by + ! check_required_coord_pair. + ! + ! Called from: read_toml_src_structures (this module), once per + ! coordinate pair (src_1, src_2, obs_1, obs_2) per structure entry. + ! + use tomlf + ! + implicit none + ! + type(toml_table), pointer, intent(in) :: table + character(len=*), intent(in) :: key_base + real, intent(out) :: x, y + integer, intent(in) :: seq_index + integer, intent(inout) :: ierr + ! + type(toml_array), pointer :: arr + integer :: n, stat + ! + x = 0.0 + y = 0.0 + ! + if (.not. table%has_key(trim(key_base))) return + ! + nullify(arr) + call get_value(table, trim(key_base), arr, requested=.false., stat=stat) + ! + if (.not. associated(arr)) then + ! + write(logstr,'(a,a,a,i0,a)')' Error ! Key "', trim(key_base), & + '" in src_structure #', seq_index, ' must be a 2-element array [x, y]' + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + n = len(arr) + ! + if (n /= 2) then + ! + write(logstr,'(a,a,a,i0,a,i0,a)')' Error ! Key "', trim(key_base), & + '" in src_structure #', seq_index, ' must have exactly 2 elements (got ', n, ')' + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + call get_value(arr, 1, x, stat=stat) + call get_value(arr, 2, y, stat=stat) + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine parse_structure_type(str, code, ierr) + ! + ! Translate a TOML "type" string to one of the structure_* codes. + ! + ! Legacy alias accepted (quietly, no warning): + ! "check_valve" -> structure_culvert_simple + ! (caller is responsible for pinning direction_positive) + ! + ! Note: "culvert" now resolves to structure_culvert (the detailed + ! physics-based pipe-flow type). Users wanting the lumped one-coefficient + ! form must say "culvert_simple" explicitly. + ! + ! Called from: read_toml_src_structures (this module), once per entry + ! to resolve the required "type" key. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = 0 + s = to_lower(str) + ! + select case (s) + ! + case ('pump') + ! + code = structure_pump + ! + case ('culvert_simple', 'check_valve') + ! + code = structure_culvert_simple + ! + case ('gate') + ! + code = structure_gate + ! + case ('culvert') + ! + code = structure_culvert + ! + case ('dike_breach') + ! + code = structure_dike_breach + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine parse_direction(str, code, ierr) + ! + ! Translate a TOML "direction" string to one of the direction_* codes. + ! Accepts "both" / "positive" / "negative" case-insensitively. + ! + ! Called from: read_toml_src_structures (this module) when an optional + ! "direction" key is present on a structure entry. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = 0 + s = to_lower(str) + ! + select case (s) + ! + case ('both') + ! + code = direction_both + ! + case ('positive') + ! + code = direction_positive + ! + case ('negative') + ! + code = direction_negative + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine parse_operation(str, code, ierr) + ! + ! Translate a gate-rule "operation" string to one of the gate_op_* codes. + ! Accepts "open" / "close" / "hold" case-insensitively. + ! + ! Called from: read_toml_src_structures (this module), once per rule in + ! a structure's [[src_structure.rule]] list. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = gate_op_hold + s = to_lower(str) + ! + select case (s) + ! + case ('open') + ! + code = gate_op_open + ! + case ('close') + ! + code = gate_op_close + ! + case ('hold') + ! + code = gate_op_hold + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + function to_lower(str) result(lower) + ! + ! Return a lowercase copy of str (ASCII only). + ! + ! Called from: parse_structure_type, parse_direction, and + ! convert_legacy_to_toml (all in this module). + ! + implicit none + ! + character(len=*), intent(in) :: str + character(len=:), allocatable :: lower + ! + integer :: k, ic + ! + lower = str + ! + do k = 1, len(lower) + ! + ic = iachar(lower(k:k)) + ! + if (ic >= iachar('A') .and. ic <= iachar('Z')) then + ! + lower(k:k) = achar(ic + 32) + ! + endif + ! + enddo + ! + end function + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_src_structures_log_summary() + ! + ! Emit a one-block-per-structure description of every parsed src + ! structure to the log file. Intended for operator review at init + ! time; not printed to stdout. + ! + ! Called from: initialize_src_structures (this module), once after + ! the marshal runs and cell indices have been resolved. + ! + implicit none + ! + integer :: i, k + character(len=32) :: type_str, dir_str, op_str + ! + if (nr_src_structures <= 0) return + ! + call write_log('------------------------------------------', 0) + call write_log('Flow control structures', 0) + call write_log('------------------------------------------', 0) + ! + write(logstr,'(a,i0,a)')'Added ', nr_src_structures, ' flow control structures' + call write_log(logstr, 0) + call write_log('', 0) + ! + do i = 1, nr_src_structures + ! + select case (int(src_struc_type(i))) + ! + case (structure_pump) + ! + type_str = 'pump' + ! + case (structure_culvert_simple) + ! + type_str = 'culvert_simple' + ! + case (structure_culvert) + ! + type_str = 'culvert' + ! + case (structure_gate) + ! + type_str = 'gate' + ! + case (structure_dike_breach) + ! + type_str = 'dike_breach' + ! + case default + ! + type_str = 'unknown' + ! + end select + ! + write(logstr,'(a,i0,a)')'Structure ', i, ':' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a)') ' name :', trim(src_struc_name(i)) + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a)') ' type :', trim(type_str) + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a,a,a,a)') ' src_1 :', '(', trim(fmt_real(src_struc_x_s1(i), 3)), ', ', trim(fmt_real(src_struc_y_s1(i), 3)), ')' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a,a,a,a)') ' src_2 :', '(', trim(fmt_real(src_struc_x_s2(i), 3)), ', ', trim(fmt_real(src_struc_y_s2(i), 3)), ')' + call write_log(logstr, 0) + ! + ! obs coords are meaningful for culvert_simple / gate / dike_breach. + ! + if (src_struc_type(i) == structure_culvert_simple .or. & + src_struc_type(i) == structure_gate .or. & + src_struc_type(i) == structure_dike_breach) then + ! + write(logstr,'(a22,1x,a,a,a,a,a)') ' obs_1 :', '(', trim(fmt_real(src_struc_x_o1(i), 3)), ', ', trim(fmt_real(src_struc_y_o1(i), 3)), ')' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a,a,a,a)') ' obs_2 :', '(', trim(fmt_real(src_struc_x_o2(i), 3)), ', ', trim(fmt_real(src_struc_y_o2(i), 3)), ')' + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_type(i) == structure_pump) then + ! + write(logstr,'(a22,1x,a,a)') ' discharge :', trim(fmt_real(src_struc_q(i), 4)), ' (m3/s)' + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_type(i) == structure_culvert_simple) then + ! + write(logstr,'(a22,1x,a)') ' flow_coef :', trim(fmt_real(src_struc_flow_coef(i), 4)) + call write_log(logstr, 0) + ! + endif + ! + ! Direction filter (culvert_simple / culvert) + ! + if (src_struc_type(i) == structure_culvert_simple .or. & + src_struc_type(i) == structure_culvert) then + ! + select case (src_struc_direction(i)) + ! + case (direction_both) + ! + dir_str = 'both' + ! + case (direction_positive) + ! + dir_str = 'positive' + ! + case (direction_negative) + ! + dir_str = 'negative' + ! + case default + ! + dir_str = 'unknown' + ! + end select + ! + write(logstr,'(a22,1x,a)') ' direction :', trim(dir_str) + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_type(i) == structure_culvert) then + ! + write(logstr,'(a22,1x,a,a)') ' width :', trim(fmt_real(src_struc_width(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a)') ' height :', trim(fmt_real(src_struc_height(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a)') ' invert_1 :', trim(fmt_real(src_struc_invert_1(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a)') ' invert_2 :', trim(fmt_real(src_struc_invert_2(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a)') ' flow_coef :', trim(fmt_real(src_struc_flow_coef(i), 4)) + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a)') ' submergence_ratio :', trim(fmt_real(src_struc_submergence_ratio(i), 4)) + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_type(i) == structure_gate) then + ! + write(logstr,'(a22,1x,a,a)') ' width :', trim(fmt_real(src_struc_width(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a)') ' sill_elevation :', trim(fmt_real(src_struc_sill_elevation(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a)') ' mannings_n :', trim(fmt_real(src_struc_mannings_n(i), 4)) + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a)') ' opening_duration :', trim(fmt_real(src_struc_opening_duration(i), 2)), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a)') ' closing_duration :', trim(fmt_real(src_struc_closing_duration(i), 2)), ' (s)' + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_type(i) == structure_dike_breach) then + ! + write(logstr,'(a22,a,a)') ' z_crest:', trim(fmt_real(src_struc_z_crest(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,a,a)') ' z_min:', trim(fmt_real(src_struc_z_min(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,a,a)') ' t_breach:', trim(fmt_real(src_struc_t_breach(i), 2)), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,a,a)') ' t0:', trim(fmt_real(src_struc_t0(i), 2)), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,a,a)') ' B0:', trim(fmt_real(src_struc_B0(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + if (src_struc_dike_core(i) == 1) then + write(logstr,'(a22,a)') ' dike_core:', 'sand (1)' + else + write(logstr,'(a22,a)') ' dike_core:', 'clay (2)' + endif + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_rule_count(i) > 0) then + ! + write(logstr,'(a22,1x,i0)') ' rules :', src_struc_rule_count(i) + call write_log(logstr, 0) + ! + do k = 1, src_struc_rule_count(i) + ! + select case (rule_list_op(src_struc_rule_start(i) + k - 1)) + case (gate_op_open); op_str = 'open' + case (gate_op_close); op_str = 'close' + case default; op_str = 'hold' + end select + ! + write(logstr,'(a,i0,1x,a8,1x,a,a,a)') ' ', k, adjustl(op_str), & + '"', trim(rule_list_src(src_struc_rule_start(i) + k - 1)), '"' + call write_log(logstr, 0) + ! + enddo + ! + endif + ! + ! Opening/closing durations. For gate structures these are always + ! printed (above); for other types only print if rules are set and + ! the duration is non-zero (non-default). + ! + if (src_struc_type(i) /= structure_gate) then + ! + if (src_struc_rule_count(i) > 0 .and. & + (src_struc_opening_duration(i) > 0.0 .or. src_struc_closing_duration(i) > 0.0)) then + ! + write(logstr,'(a22,1x,a,a)') ' opening_duration :', trim(fmt_real(src_struc_opening_duration(i), 2)), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,1x,a,a)') ' closing_duration :', trim(fmt_real(src_struc_closing_duration(i), 2)), ' (s)' + call write_log(logstr, 0) + ! + endif + ! + endif + ! + call write_log('', 0) + ! + enddo + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) + ! + ! Transcribe a legacy fixed-column drn file into a TOML sibling file, + ! so that downstream code only has to consume the TOML schema. One + ! [[src_structure]] block is emitted per non-blank, non-comment line + ! of the legacy file. Water-level-triggered gates (legacy dtype 4) are + ! converted to TOML gate blocks with synthesised rule expressions. + ! Schedule-triggered gates (legacy dtype 5) are refused; the new rule + ! grammar is water-level-only and has no time atom. + ! + ! The output path is derived from legacy_path: if it ends in ".drn" + ! (case-insensitive) the suffix ".toml" is inserted before the ".drn", + ! otherwise ".toml" is appended. The resolved path is returned in + ! toml_path for the caller to feed into the TOML reader. + ! + ! The converter is deliberately minimal: no coord sanity checks, no + ! duplicate-name detection, no preservation of comments. It exists only + ! to remove the parallel legacy parsing machinery that used to live + ! in this module. + ! + ! Called from: initialize_src_structures (this module) when toml-f + ! rejects the drn file on the initial probe. + ! + implicit none + ! + character(len=*), intent(in) :: legacy_path + character(len=*), intent(out) :: toml_path + integer, intent(out) :: ierr + ! + integer :: u_in, u_out, stat, n_struct, dtype + integer :: len_in, ext_pos + real*4 :: x2, y2, x1, y1, par + real*4 :: g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls + character(len=512) :: line, trimmed + character(len=32) :: name_str + character(len=16) :: type_name, par_name, dir_name + character(len=13) :: zmin_str, zmax_str + character(len=128) :: rule_open_str, rule_close_str + ! + ierr = 0 + n_struct = 0 + u_in = 501 + u_out = 502 + ! + ! Derive the TOML sibling path from legacy_path. If legacy_path ends + ! in ".drn" (case-insensitive), insert ".toml" before the extension; + ! else append ".toml". + ! + len_in = len_trim(legacy_path) + ext_pos = 0 + ! + if (len_in >= 4) then + ! + if (to_lower(legacy_path(len_in-3:len_in)) == '.drn') then + ! + ext_pos = len_in - 3 + ! + endif + ! + endif + ! + if (ext_pos > 0) then + ! + toml_path = legacy_path(1:ext_pos-1) // '.toml' // legacy_path(ext_pos:len_in) + ! + else + ! + toml_path = legacy_path(1:len_in) // '.toml' + ! + endif + ! + open(u_in, file=trim(legacy_path), status='old', action='read', iostat=stat) + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not open legacy drn file "', trim(legacy_path), '" for reading' + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + open(u_out, file=trim(toml_path), status='replace', action='write', iostat=stat) + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not open TOML output file "', trim(toml_path), '" for writing' + close(u_in) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + write(u_out,'(a)') '# Auto-generated from legacy drn file by SFINCS.' + write(u_out,'(a)') '# Do not edit; edit the legacy source or rewrite as TOML directly.' + write(u_out,'(a)') '' + ! + do while (.true.) + ! + read(u_in,'(a)', iostat=stat) line + ! + if (stat /= 0) exit + ! + ! Skip blank / comment lines. + ! + trimmed = adjustl(line) + ! + if (len_trim(trimmed) == 0) cycle + if (trimmed(1:1) == '#' .or. trimmed(1:1) == '!') cycle + ! + ! Columns: x1, y1, x2, y2, dtype, par. + ! (legacy xsnk=intake -> src_1; legacy xsrc=outfall -> src_2). + ! + read(line, *, iostat=stat) x1, y1, x2, y2, dtype, par + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not parse legacy drn line in "', trim(legacy_path), '"' + call write_log(logstr, 1) + write(logstr,'(a,a)')' line: ', trim(line) + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + endif + ! + ! Branch on dtype. Gates (4, 5) and unknown codes set ierr and bail. + ! + ! dir_name is left blank unless dtype pins a direction filter; a blank + ! dir_name causes the emitter below to skip the direction key entirely, + ! which reads back as direction_both (the default). + ! + dir_name = '' + ! + select case (dtype) + ! + case (1) + ! + type_name = 'pump' + par_name = 'q' + ! + case (2) + ! + ! legacy culvert -> bidirectional culvert_simple + ! + type_name = 'culvert_simple' + par_name = 'flow_coef' + ! + case (3) + ! + ! legacy check_valve -> culvert_simple with direction = "positive" + ! + type_name = 'culvert_simple' + par_name = 'flow_coef' + dir_name = 'positive' + ! + case (4) + ! + ! Water-level-triggered gate. Legacy columns past dtype: + ! width, sill_elevation, mannings_n, zmin, zmax, t_close. + ! Re-read the whole line to pull those extra columns. + ! + read(line, *, iostat=stat) x1, y1, x2, y2, dtype, & + g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not parse legacy dtype-4 gate line in "', trim(legacy_path), '"' + call write_log(logstr, 1) + write(logstr,'(a,a)')' line: ', trim(line) + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + endif + ! + ! Synthesise rule strings with the legacy numeric values baked in. + ! Grammar accepts '<', '>', '&', '|' only (no '<=' / '>='). + ! + write(zmin_str,'(es13.6)') g_zmin + write(zmax_str,'(es13.6)') g_zmax + write(rule_open_str, '(a,a,a,a)') 'z1>', trim(adjustl(zmin_str)), ' & z1<', trim(adjustl(zmax_str)) + write(rule_close_str,'(a,a,a,a)') 'z1<', trim(adjustl(zmin_str)), ' | z1>', trim(adjustl(zmax_str)) + ! + n_struct = n_struct + 1 + ! + if (g_zmin >= g_zmax) then + ! + write(logstr,'(a,i0,a)')' Warning ! legacy gate entry ', n_struct, ': zmin >= zmax, open rule will never fire' + call write_log(logstr, 0) + ! + endif + ! + write(name_str,'(a,i0)') 'legacy_', n_struct + ! + write(u_out,'(a)') '[[src_structure]]' + write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' + write(u_out,'(a)') 'type = "gate"' + write(u_out,'(a,es14.6,a,es14.6,a)') 'src_1 = [', x1, ', ', y1, ']' + write(u_out,'(a,es14.6,a,es14.6,a)') 'src_2 = [', x2, ', ', y2, ']' + write(u_out,'(a,es14.6)') 'width = ', g_width + write(u_out,'(a,es14.6)') 'sill_elevation = ', g_sill + write(u_out,'(a,es14.6)') 'mannings_n = ', g_mann + write(u_out,'(a,es14.6)') 'opening_duration = ', g_tcls + write(u_out,'(a,es14.6)') 'closing_duration = ', g_tcls + write(u_out,'(a)') '[[src_structure.rule]]' + write(u_out,'(a)') 'operation = "open"' + write(u_out,'(a,a,a)') 'when = "', trim(rule_open_str), '"' + write(u_out,'(a)') '[[src_structure.rule]]' + write(u_out,'(a)') 'operation = "close"' + write(u_out,'(a,a,a)') 'when = "', trim(rule_close_str), '"' + write(u_out,'(a)') '' + ! + cycle + ! + case (5) + ! + write(logstr,'(a)')' Error ! legacy schedule-triggered gate (dtype 5) not supported - rewrite as TOML with rule-based triggers or file an issue to add a time atom to the rule grammar' + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + case default + ! + write(logstr,'(a,i0,a)')' Error ! unknown drainage_type ', dtype, ' in legacy drn file' + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + end select + ! + n_struct = n_struct + 1 + write(name_str,'(a,i0)') 'legacy_', n_struct + ! + write(u_out,'(a)') '[[src_structure]]' + write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' + write(u_out,'(a,a,a)') 'type = "', trim(type_name),'"' + ! + if (len_trim(dir_name) > 0) then + ! + write(u_out,'(a,a,a)') 'direction = "', trim(dir_name), '"' + ! + endif + ! + write(u_out,'(a,es14.6,a,es14.6,a)') 'src_1 = [', x1, ', ', y1, ']' + write(u_out,'(a,es14.6,a,es14.6,a)') 'src_2 = [', x2, ', ', y2, ']' + write(u_out,'(a,a,a,es14.6)') trim(par_name), repeat(' ', max(1, 7 - len_trim(par_name))), '= ', par + write(u_out,'(a)') '' + ! + enddo + ! + close(u_in) + close(u_out) + ! + write(logstr,'(a,a,a,a,a)')' Converted legacy drn file "', trim(legacy_path), & + '" to TOML "', trim(toml_path), '"' + call write_log(logstr, 0) + ! + end subroutine + ! +end module diff --git a/source/src/sfincs_structures.f90 b/source/src/sfincs_structures.f90 index bc51ffa1b..e4a2ffb9e 100644 --- a/source/src/sfincs_structures.f90 +++ b/source/src/sfincs_structures.f90 @@ -589,11 +589,12 @@ subroutine give_thindam_information(struc_info) end subroutine - subroutine compute_fluxes_over_structures(tloop) + subroutine compute_fluxes_over_structures() ! ! Computes fluxes over structures (THIS HAS TO BE SERIOUSLY IMPROVED!!!) ! use sfincs_data + use sfincs_timers ! use quadtree ! implicit none @@ -614,13 +615,7 @@ subroutine compute_fluxes_over_structures(tloop) real*4 :: h2 real*4 :: qstruc ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! - call system_clock(count0, count_rate, count_max) + call timer_start('structures') ! !$acc parallel, present(zs, q, uv, structure_uv_index, uv_index_z_nm, uv_index_z_nmu, structure_parameters, structure_type, structure_length) !$acc loop independent gang vector @@ -691,9 +686,8 @@ subroutine compute_fluxes_over_structures(tloop) enddo !$acc end parallel ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate - ! + call timer_stop('structures') + ! end subroutine diff --git a/source/src/sfincs_timers.f90 b/source/src/sfincs_timers.f90 new file mode 100644 index 000000000..77d91d13b --- /dev/null +++ b/source/src/sfincs_timers.f90 @@ -0,0 +1,407 @@ +module sfincs_timers + ! + ! Named wall-clock timers for SFINCS. + ! + ! Lightweight replacement for the scattered tloop*/tstart_*/tend_* + ! bookkeeping that used to live in each module. Timers are registered + ! lazily: the first timer_start('name') with a new name creates it; + ! subsequent calls find the existing record and accumulate. + ! + ! All timing is done via omp_get_wtime(), which returns real(8) wall + ! seconds and is guaranteed monotonic by OpenMP. This avoids two + ! pitfalls of system_clock: 32-bit count overflow on nanosecond clocks + ! (rolls over every ~2.15 s) and, under nvfortran + OpenACC GPU + ! offload, system_clock can return CPU time rather than wall time. + ! + ! Thread safety: timer_start / timer_stop are intended to be called + ! from the serial driver, outside of !$omp parallel regions. They are + ! NOT thread-safe. + ! + ! This module is a pure data module and deliberately has NO dependency + ! on sfincs_log: rendering/pretty-printing of timer data lives in + ! sfincs_log (write_timer_headers_log, write_timer_summary_log, + ! write_runtimes_file), which walks the timer list via the iteration + ! API below. Keeping the two modules separated avoids a circular + ! dependency (sfincs_log already uses timer_elapsed internally). + ! + ! Subroutines / functions: + ! + ! timer_start(name) / timer_stop(name) + ! Start / stop a named timer. Lazily registers on first start. + ! Called from every phase in sfincs_lib (Input, Simulation loop, + ! Boundaries, Momentum, Continuity, Output, ...) and from + ! update_wave_field in sfincs_snapwave. + ! + ! timer_reset(name) + ! Zero a single timer. Currently unused by the main driver but + ! kept as part of the public API. + ! + ! timer_elapsed(name) / timer_count(name) + ! Read accumulated wall time / call count for a named timer. + ! Called from sfincs_log (write_progress_log, + ! write_finished_log, write_timer_headers_log, + ! write_runtimes_file). + ! + ! timer_total_wall() + ! Sum of accumulated wall time across all registered timers. + ! Called from write_timer_summary_log in sfincs_log. + ! + ! timer_num_registered() + ! Number of timers currently registered. Called from + ! write_timer_summary_log in sfincs_log. + ! + ! timer_name_by_index(i) / timer_elapsed_by_index(i) / + ! timer_count_by_index(i) + ! Iteration API: read a timer's stored name / accumulated wall + ! time / call count by index. Indices run 1 .. timer_num_registered(). + ! Called from write_timer_summary_log in sfincs_log. + ! + use omp_lib + ! + implicit none + ! + private + ! + public :: timer_start + public :: timer_stop + public :: timer_reset + public :: timer_elapsed + public :: timer_count + public :: timer_total_wall + public :: timer_num_registered + public :: timer_name_by_index + public :: timer_elapsed_by_index + public :: timer_count_by_index + ! + integer, parameter :: name_len = 32 + integer, parameter :: max_timers = 64 + ! + type :: timer_record + character(len=name_len) :: name = '' + real(8) :: accumulated = 0.0_8 + real(8) :: last_start = 0.0_8 + integer :: n_calls = 0 + logical :: running = .false. + logical :: warned_start = .false. + logical :: warned_stop = .false. + end type timer_record + ! + type(timer_record), save :: timers(max_timers) + integer, save :: n_timers = 0 + logical, save :: warned_full = .false. + ! +contains + ! + !-----------------------------------------------------------------------------------------------------! + ! + integer function timer_find(name) result(idx) + ! + ! Return the index of the timer with the given name, or 0 if not present. + ! + ! Called from: timer_find_or_register, timer_stop, timer_reset, + ! timer_elapsed, timer_count (all within this module). + ! + character(len=*), intent(in) :: name + integer :: i + ! + idx = 0 + ! + do i = 1, n_timers + ! + if (trim(timers(i)%name) == trim(name)) then + idx = i + return + endif + ! + enddo + ! + end function timer_find + ! + !-----------------------------------------------------------------------------------------------------! + ! + integer function timer_find_or_register(name) result(idx) + ! + ! Return the index of the timer with the given name, creating a new + ! record if it did not yet exist. Returns 0 if the table is full. + ! + ! Called from: timer_start (within this module). + ! + character(len=*), intent(in) :: name + ! + idx = timer_find(name) + ! + if (idx > 0) return + ! + if (n_timers >= max_timers) then + ! + if (.not. warned_full) then + ! + write(*, '(a)') ' Warning: sfincs_timers table full, timer ignored: '//trim(name) + warned_full = .true. + ! + endif + ! + idx = 0 + return + ! + endif + ! + n_timers = n_timers + 1 + idx = n_timers + ! + timers(idx)%name = name + timers(idx)%accumulated = 0.0_8 + timers(idx)%last_start = 0.0_8 + timers(idx)%n_calls = 0 + timers(idx)%running = .false. + timers(idx)%warned_start = .false. + timers(idx)%warned_stop = .false. + ! + end function timer_find_or_register + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_start(name) + ! + ! Start (or resume-and-accumulate-on-stop) the timer with the given name. + ! Lazily registers a new timer on first call. + ! + ! Called from: sfincs_lib (main driver, every phase) and + ! update_wave_field in sfincs_snapwave. + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find_or_register(name) + ! + if (idx == 0) return + ! + if (timers(idx)%running) then + ! + if (.not. timers(idx)%warned_start) then + ! + write(*, '(a)') ' Warning: timer_start on already-running timer: '//trim(name) + timers(idx)%warned_start = .true. + ! + endif + ! + return + ! + endif + ! + timers(idx)%last_start = omp_get_wtime() + timers(idx)%running = .true. + ! + end subroutine timer_start + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_stop(name) + ! + ! Stop the timer and add the elapsed interval to its accumulated total. + ! + ! Called from: sfincs_lib (main driver, every phase) and + ! update_wave_field in sfincs_snapwave. + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find(name) + ! + if (idx == 0) then + ! + write(*, '(a)') ' Warning: timer_stop on unknown timer: '//trim(name) + return + ! + endif + ! + if (.not. timers(idx)%running) then + ! + if (.not. timers(idx)%warned_stop) then + ! + write(*, '(a)') ' Warning: timer_stop on non-running timer: '//trim(name) + timers(idx)%warned_stop = .true. + ! + endif + ! + return + ! + endif + ! + timers(idx)%accumulated = timers(idx)%accumulated + (omp_get_wtime() - timers(idx)%last_start) + timers(idx)%n_calls = timers(idx)%n_calls + 1 + timers(idx)%running = .false. + ! + end subroutine timer_stop + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_reset(name) + ! + ! Reset a single timer's accumulated time and call count to zero. + ! + ! Called from: (currently no live callers; part of the public API.) + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find(name) + ! + if (idx == 0) return + ! + timers(idx)%accumulated = 0.0_8 + timers(idx)%n_calls = 0 + timers(idx)%running = .false. + ! + end subroutine timer_reset + ! + !-----------------------------------------------------------------------------------------------------! + ! + real(8) function timer_elapsed(name) result(elapsed) + ! + ! Accumulated wall time (in seconds) for the named timer. + ! Returns 0 if the timer is unknown. If the timer is currently running, + ! the interval since the most recent timer_start is included (without + ! modifying the stored accumulated value). + ! + ! Called from: sfincs_log (write_progress_log, write_finished_log, + ! write_timer_headers_log, write_runtimes_file). + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find(name) + ! + if (idx == 0) then + elapsed = 0.0_8 + return + endif + ! + elapsed = timers(idx)%accumulated + ! + if (timers(idx)%running) then + ! + elapsed = elapsed + (omp_get_wtime() - timers(idx)%last_start) + ! + endif + ! + end function timer_elapsed + ! + !-----------------------------------------------------------------------------------------------------! + ! + integer function timer_count(name) result(n) + ! + ! Number of completed start/stop cycles for the named timer. + ! + ! Called from: (currently no live callers; part of the public API.) + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find(name) + ! + if (idx == 0) then + n = 0 + return + endif + ! + n = timers(idx)%n_calls + ! + end function timer_count + ! + !-----------------------------------------------------------------------------------------------------! + ! + real(8) function timer_total_wall() result(total) + ! + ! Sum of accumulated wall time across all registered timers. + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + integer :: i + ! + total = 0.0_8 + ! + do i = 1, n_timers + total = total + timers(i)%accumulated + enddo + ! + end function timer_total_wall + ! + !-----------------------------------------------------------------------------------------------------! + ! + integer function timer_num_registered() result(n) + ! + ! Number of timers currently registered. Used by the rendering + ! routines in sfincs_log to iterate over every timer without + ! touching module-private state. + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + n = n_timers + ! + end function timer_num_registered + ! + !-----------------------------------------------------------------------------------------------------! + ! + function timer_name_by_index(i) result(name) + ! + ! Return the stored name of the i-th registered timer, or an empty + ! string for out-of-range i. Indices run 1 .. timer_num_registered(). + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + integer, intent(in) :: i + character(len=name_len) :: name + ! + if (i < 1 .or. i > n_timers) then + name = '' + return + endif + ! + name = timers(i)%name + ! + end function timer_name_by_index + ! + !-----------------------------------------------------------------------------------------------------! + ! + real(8) function timer_elapsed_by_index(i) result(elapsed) + ! + ! Accumulated wall time of the i-th registered timer. Returns 0 for + ! out-of-range i. Does NOT include a running-interval contribution + ! (use timer_elapsed(name) if you need that — the rendering code + ! runs after the simulation loop has stopped all timers). + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + integer, intent(in) :: i + ! + if (i < 1 .or. i > n_timers) then + elapsed = 0.0_8 + return + endif + ! + elapsed = timers(i)%accumulated + ! + end function timer_elapsed_by_index + ! + !-----------------------------------------------------------------------------------------------------! + ! + integer function timer_count_by_index(i) result(n) + ! + ! Number of completed start/stop cycles of the i-th registered + ! timer. Returns 0 for out-of-range i. + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + integer, intent(in) :: i + ! + if (i < 1 .or. i > n_timers) then + n = 0 + return + endif + ! + n = timers(i)%n_calls + ! + end function timer_count_by_index + ! +end module sfincs_timers diff --git a/source/src/sfincs_urban_drainage.f90 b/source/src/sfincs_urban_drainage.f90 new file mode 100644 index 000000000..fd4550d3f --- /dev/null +++ b/source/src/sfincs_urban_drainage.f90 @@ -0,0 +1,998 @@ +module sfincs_urban_drainage + ! + ! Simple urban-drainage sink/source model for SFINCS. + ! + ! Each zone is a polygon in the horizontal plane and has one of two + ! types: + ! + ! piped_drainage — cells inside the polygon drain to a single + ! outfall cell through a conceptual buried pipe + ! network. Flow is bidirectional: during high + ! water at the outfall (tide / surge), water can + ! push back into the zone cells unless a check + ! valve is configured. The per-zone net flux is + ! added as a point source/sink at the outfall. + ! + ! injection_well — water is pumped out of the zone cells (evenly + ! split across the cells in the polygon) and + ! disappears from the model underground. There is + ! no outfall and no backflow. Pumping stops when + ! the cumulative injected volume reaches the + ! well's maximum capacity. + ! + ! Common mechanics (both types): + ! + ! dt-capped per-cell drain: q = min(ramp * qmax(nm), h_cell * A(nm) / dt) + ! ramp = min(h_cell / h_threshold, 1) if h_threshold > 0, else 1 + ! h_cell = zs(nm) - (subgrid ? subgrid_z_zmin(nm) : zb(nm)) + ! + ! Piped drainage specifics: + ! + ! dzs = zs(nm) - zs(outfall) + ! if dzs > 0: drain as above (positive q, water leaves cell) + ! if dzs < 0: backflow q = -backflow_coef(nm)*sqrt(-dzs), capped at + ! -qmax(nm); suppressed entirely by check_valve + ! Per-cell qmax from the design precipitation rate: + ! qmax(nm) = design_precip_mm_hr * 1e-3 / 3600 * cell_area(nm) + ! Alternatively the user may supply max_outfall_rate [m3/s] for the + ! whole zone (exclusive with design_precip per zone); design_precip + ! is then derived as + ! design_precip_mm_hr = max_outfall_rate / zone_area * 1000 * 3600 + ! which distributes the capacity proportionally to cell area. + ! Per-cell design-head (bed_elev is subgrid_z_zmin in subgrid mode, + ! zb otherwise): + ! dh_design(nm) = max(bed_elev(nm) - bed_elev(outfall), dh_design_min) + ! backflow_coef(nm) = qmax(nm) / sqrt(dh_design(nm)) + ! + ! Injection well specifics: + ! + ! Per-cell qmax is area-weighted, so the sum across zone cells is + ! exactly injection_rate and refinement-level changes inside a + ! zone don't shift the per-cell flux relative to cell area: + ! qmax(nm) = injection_rate * cell_area(nm) / zone_area + ! The zone holds a running cumulative_injection(iz) = sum(qd*dt) + ! across cells and time steps. Once cumulative_injection(iz) + ! reaches urb_zone_maximum_capacity(iz), pumping is skipped for + ! that zone (flow drops to zero). + ! + ! Subroutines: + ! + ! initialize_urban_drainage() + ! Top-level driver. Calls read_urban_drainage, loads polygons, + ! marks cells per zone (last zone wins on overlap), snaps outfall + ! coords to the nearest active cell (piped_drainage only), + ! precomputes per-cell qmax and backflow_coef. Called from + ! sfincs_lib (once at init time). + ! + ! read_urban_drainage(filename, ierr) + ! Parses the *.urb TOML file into the per-zone arrays. Called + ! from initialize_urban_drainage (this module). + ! + ! update_urban_drainage(t, dt) + ! Per-time-step entry: accumulates signed discharges into qsrc + ! and adds the zone contribution at the outfall cell (for + ! piped_drainage zones). Called from update_continuity + ! (sfincs_continuity). + ! + ! write_urban_drainage_log_summary() + ! Prints a one-block-per-zone summary to the log. Called from + ! initialize_urban_drainage (this module). + ! + use sfincs_log + use sfincs_error + use sfincs_polygons + use sfincs_timers + ! + implicit none + ! + private + ! + public :: initialize_urban_drainage + public :: update_urban_drainage + ! + ! Zone type identifiers. Kept public so ncoutput can branch on type + ! when writing per-zone output variables. + ! + integer, parameter, public :: urb_type_piped_drainage = 1 + integer, parameter, public :: urb_type_injection_well = 2 + ! + ! Per-zone runtime state. Sized nr_urban_drainage_zones. + ! + integer, public :: nr_urban_drainage_zones = 0 + ! + character(len=64), dimension(:), allocatable, public :: urb_zone_name + character(len=64), dimension(:), allocatable, public :: urb_zone_type ! original TOML type string (for logging) + character(len=256), dimension(:), allocatable :: urb_zone_polygon_file + integer, dimension(:), allocatable, public :: urb_zone_type_id ! one of urb_type_* + ! + real*4, dimension(:), allocatable, public :: urb_zone_outfall_x ! m (piped_drainage) + real*4, dimension(:), allocatable, public :: urb_zone_outfall_y ! m (piped_drainage) + real*4, dimension(:), allocatable, public :: urb_zone_design_precip ! mm/hr (piped_drainage; either direct or derived from max_outfall_rate) + real*4, dimension(:), allocatable, public :: urb_zone_max_outfall_rate ! m3/s (piped_drainage; 0.0 if input was design_precip) + real*4, dimension(:), allocatable, public :: urb_zone_injection_rate ! m3/s (injection_well) + real*4, dimension(:), allocatable, public :: urb_zone_maximum_capacity ! m3 (injection_well) + real*4, dimension(:), allocatable, public :: urb_zone_h_threshold ! m ponding threshold (both types) + real*4, dimension(:), allocatable, public :: urb_zone_dh_design_min ! m floor on design head (piped_drainage) + logical, dimension(:), allocatable, public :: urb_zone_include_outfall ! (piped_drainage) + logical, dimension(:), allocatable, public :: urb_zone_check_valve ! (piped_drainage) + ! + integer, dimension(:), allocatable, public :: urban_drainage_outfall_index ! cell index, 0 if none + real*4, dimension(:), allocatable, public :: urban_drainage_q_total ! m3/s per zone, per step (total discharge leaving zone cells) + real*4, dimension(:), allocatable, public :: urb_zone_cumulative_injection ! m3 accumulated per zone (injection_well) + real*4, dimension(:), allocatable, public :: urb_zone_area ! m2, sum of cell areas in zone + integer, dimension(:), allocatable, public :: urb_zone_n_cells ! number of cells in zone + real*4, dimension(:), allocatable, public :: urb_zone_qmax_total ! m3/s, sum of per-cell qmax + ! + ! Per-cell runtime state. Sized np. + ! + integer, dimension(:), allocatable, public :: urban_drainage_zone_indices ! 0 if not in any zone + real*4, dimension(:), allocatable, public :: urban_drainage_qmax ! m3/s cap per cell + real*4, dimension(:), allocatable, public :: urban_drainage_backflow_coef ! qmax / sqrt(dh_design), piped_drainage only + real*4, dimension(:), allocatable, public :: urban_drainage_cumulative_volume ! m3 accumulated per cell + ! +contains + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine initialize_urban_drainage() + ! + ! Top-level initializer for urban drainage. Parses *.urb TOML file, + ! loads polygons, stamps cells per zone (last-wins on overlap), snaps + ! outfall coords (piped_drainage zones only) to the nearest active + ! cell, and precomputes per-cell qmax and backflow coefficients. + ! + ! Sets sfincs_data::urban_drainage = .true. when at least one zone is + ! loaded and has at least one participating cell. Otherwise leaves it + ! .false. and returns early. + ! + ! Called from: sfincs_lib (once, at init time, after + ! initialize_src_structures). + ! + use sfincs_data + use quadtree + ! + implicit none + ! + integer :: ierr, ipoly, iz, nm, io + integer :: n_cells_in_zones, n_outfalls, nmq + real*4 :: area_nm, dzb, dh_min + type(t_polygon), allocatable :: polygons(:) + logical, allocatable :: inside(:) + character(len=256) :: last_file + integer :: ip + ! + urban_drainage = .false. + ! + if (urbfile(1:4) == 'none') return + ! + call write_log('Info : reading urban drainage file ...', 0) + ! + call read_urban_drainage(trim(urbfile), ierr) + ! + if (ierr /= 0) then + call stop_sfincs('Error ! Failed to read urban drainage TOML file.', -1) + return + endif + ! + if (nr_urban_drainage_zones <= 0) then + call write_log('Info : urban drainage file contains no zones; feature disabled', 0) + return + endif + ! + ! Allocate per-zone snapped outfall index and per-step accumulators. + ! + allocate(urban_drainage_outfall_index(nr_urban_drainage_zones)) + allocate(urban_drainage_q_total(nr_urban_drainage_zones)) + allocate(urb_zone_cumulative_injection(nr_urban_drainage_zones)) + allocate(urb_zone_area(nr_urban_drainage_zones)) + allocate(urb_zone_n_cells(nr_urban_drainage_zones)) + allocate(urb_zone_qmax_total(nr_urban_drainage_zones)) + urban_drainage_outfall_index = 0 + urban_drainage_q_total = 0.0 + urb_zone_cumulative_injection = 0.0 + urb_zone_area = 0.0 + urb_zone_n_cells = 0 + urb_zone_qmax_total = 0.0 + ! + ! Allocate per-cell state. + ! + allocate(urban_drainage_zone_indices(np)) + allocate(urban_drainage_qmax(np)) + allocate(urban_drainage_backflow_coef(np)) + allocate(urban_drainage_cumulative_volume(np)) + urban_drainage_zone_indices = 0 + urban_drainage_qmax = 0.0 + urban_drainage_backflow_coef = 0.0 + urban_drainage_cumulative_volume = 0.0 + ! + ! Stamp cells per zone. Polygons are cached per unique file so that + ! multiple zones sharing a polygon file only trigger one file read. + ! Within a file each polygon name is matched against urb_zone_name. + ! + allocate(inside(np)) + last_file = '' + ! + do iz = 1, nr_urban_drainage_zones + ! + if (trim(urb_zone_polygon_file(iz)) == '') then + write(logstr,'(a,a,a)')' Error ! Urban drainage zone "', trim(urb_zone_name(iz)), & + '" has no polygon_file' + call stop_sfincs(trim(logstr), -1) + endif + ! + if (trim(urb_zone_polygon_file(iz)) /= trim(last_file)) then + if (allocated(polygons)) then + do ip = 1, size(polygons) + if (allocated(polygons(ip)%x)) deallocate(polygons(ip)%x) + if (allocated(polygons(ip)%y)) deallocate(polygons(ip)%y) + enddo + deallocate(polygons) + endif + call read_tek_polygons(trim(urb_zone_polygon_file(iz)), polygons, ierr) + if (ierr /= 0) then + write(logstr,'(a,a)')' Error ! Failed to read urban drainage polygon file ', & + trim(urb_zone_polygon_file(iz)) + call stop_sfincs(trim(logstr), -1) + endif + last_file = urb_zone_polygon_file(iz) + endif + ! + ! Find a polygon in this file whose name matches this zone's name. + ! + ipoly = 0 + do ip = 1, size(polygons) + if (trim(polygons(ip)%name) == trim(urb_zone_name(iz))) then + ipoly = ip + exit + endif + enddo + ! + if (ipoly == 0) then + write(logstr,'(a,a,a,a)')' Error ! No polygon named "', trim(urb_zone_name(iz)), & + '" found in file ', trim(urb_zone_polygon_file(iz)) + call stop_sfincs(trim(logstr), -1) + endif + ! + ! Test all active cell centers against this polygon. + ! + inside = .false. + call points_in_polygon_omp(z_xz, z_yz, np, polygons(ipoly), inside) + ! + ! Last-zone-wins: overwrite zone_indices wherever inside is true. + ! + do nm = 1, np + if (inside(nm)) urban_drainage_zone_indices(nm) = iz + enddo + ! + enddo + ! + if (allocated(polygons)) then + do ip = 1, size(polygons) + if (allocated(polygons(ip)%x)) deallocate(polygons(ip)%x) + if (allocated(polygons(ip)%y)) deallocate(polygons(ip)%y) + enddo + deallocate(polygons) + endif + deallocate(inside) + ! + ! Snap outfall coordinates to nearest active cell (piped_drainage only). + ! + n_outfalls = 0 + ! + do iz = 1, nr_urban_drainage_zones + ! + if (urb_zone_type_id(iz) /= urb_type_piped_drainage) cycle + if (.not. urb_zone_include_outfall(iz)) cycle + ! + nmq = find_quadtree_cell(urb_zone_outfall_x(iz), urb_zone_outfall_y(iz)) + if (nmq > 0) urban_drainage_outfall_index(iz) = index_sfincs_in_quadtree(nmq) + ! + if (urban_drainage_outfall_index(iz) <= 0) then + write(logstr,'(a,a,a)')' Warning : outfall for zone "', trim(urb_zone_name(iz)), & + '" could not be snapped to an active cell; zone contributions will be discarded' + call write_log(logstr, 0) + else + n_outfalls = n_outfalls + 1 + endif + ! + enddo + ! + ! Precompute per-cell qmax and backflow coef. Two passes: first + ! accumulate per-zone area and cell count, then derive design_precip + ! where needed and compute per-cell qmax. + ! + ! Pass 1: accumulate area and cell count per zone. + ! + n_cells_in_zones = 0 + ! + do nm = 1, np + ! + iz = urban_drainage_zone_indices(nm) + if (iz == 0) cycle + ! + if (crsgeo) then + area_nm = cell_area_m2(nm) + else + area_nm = cell_area(z_flags_iref(nm)) + endif + ! + urb_zone_area(iz) = urb_zone_area(iz) + area_nm + urb_zone_n_cells(iz) = urb_zone_n_cells(iz) + 1 + n_cells_in_zones = n_cells_in_zones + 1 + ! + enddo + ! + ! Derive design_precip for piped_drainage zones that were given + ! max_outfall_rate. Error out on injection_well zones with zero cells. + ! + do iz = 1, nr_urban_drainage_zones + ! + if (urb_zone_type_id(iz) == urb_type_piped_drainage) then + ! + if (urb_zone_max_outfall_rate(iz) > 0.0) then + ! + if (urb_zone_area(iz) <= 0.0) then + write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(iz)), & + '" has max_outfall_rate set but zero participating cells; cannot derive design_precip' + call stop_sfincs(trim(logstr), -1) + endif + ! + urb_zone_design_precip(iz) = urb_zone_max_outfall_rate(iz) / urb_zone_area(iz) * 1000.0 * 3600.0 + ! + endif + ! + elseif (urb_zone_type_id(iz) == urb_type_injection_well) then + ! + if (urb_zone_n_cells(iz) <= 0) then + write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(iz)), & + '" is an injection_well with zero participating cells' + call stop_sfincs(trim(logstr), -1) + endif + ! + endif + ! + enddo + ! + ! Pass 2: compute per-cell qmax and (piped only) backflow coefficient. + ! + do nm = 1, np + ! + iz = urban_drainage_zone_indices(nm) + if (iz == 0) cycle + ! + if (crsgeo) then + area_nm = cell_area_m2(nm) + else + area_nm = cell_area(z_flags_iref(nm)) + endif + ! + if (urb_zone_type_id(iz) == urb_type_piped_drainage) then + ! + ! mm/hr -> m/s then m3/s + ! + urban_drainage_qmax(nm) = urb_zone_design_precip(iz) * 1.0e-3 / 3600.0 * area_nm + ! + io = urban_drainage_outfall_index(iz) + ! + if (io > 0) then + dh_min = urb_zone_dh_design_min(iz) + if (subgrid) then + dzb = max(subgrid_z_zmin(nm) - subgrid_z_zmin(io), dh_min) + else + dzb = max(zb(nm) - zb(io), dh_min) + endif + urban_drainage_backflow_coef(nm) = urban_drainage_qmax(nm) / sqrt(dzb) + endif + ! + elseif (urb_zone_type_id(iz) == urb_type_injection_well) then + ! + ! Split pump capacity across the zone by cell area so the sum + ! over zone cells equals injection_rate exactly. + ! + urban_drainage_qmax(nm) = urb_zone_injection_rate(iz) * area_nm / urb_zone_area(iz) + ! + endif + ! + urb_zone_qmax_total(iz) = urb_zone_qmax_total(iz) + urban_drainage_qmax(nm) + ! + enddo + ! + write(logstr,'(a,i0,a,i0,a,i0,a)')' Info : urban drainage: ', nr_urban_drainage_zones, & + ' zone(s), ', n_cells_in_zones, ' cell(s) assigned, ', n_outfalls, ' outfall(s)' + call write_log(logstr, 0) + ! + if (n_cells_in_zones > 0) urban_drainage = .true. + ! + call write_urban_drainage_log_summary() + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine update_urban_drainage(t, dt) + ! + ! Per-time-step entry: accumulate signed discharges into qsrc for + ! cells inside drainage zones, add the zone contribution at each + ! piped_drainage outfall cell, and accumulate the per-zone + ! cumulative injection volume for injection_well zones. + ! + ! Sign convention: qd > 0 means water leaves the cell (drains to + ! outfall or underground). qsrc(nm) -= qd subtracts that flux from + ! the cell; for piped_drainage zones the same amount is added back + ! at the outfall cell. injection_well zones don't return water to + ! the model. + ! + ! Called from: update_continuity (sfincs_continuity), once per time + ! step, after update_src_structures. + ! + use sfincs_data + ! + implicit none + ! + real*8, intent(in) :: t + real*4, intent(in) :: dt + ! + integer :: nm, iz, io, type_id + real*4 :: dzs, qd, area_nm, h_cell, ramp + ! + if (nr_urban_drainage_zones <= 0) return + ! + call timer_start('urban drainage') + ! + !$acc kernels present(urban_drainage_q_total) + urban_drainage_q_total = 0.0 + !$acc end kernels + ! + !$acc parallel loop present( qsrc, zs, zb, subgrid_z_zmin,z_volume, cell_area, cell_area_m2, z_flags_iref, & + !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, & + !$acc urban_drainage_qmax, urban_drainage_backflow_coef, & + !$acc urban_drainage_q_total, urban_drainage_cumulative_volume, & + !$acc urb_zone_type_id, urb_zone_maximum_capacity, urb_zone_cumulative_injection, & + !$acc urb_zone_h_threshold, urb_zone_check_valve ) & + !$acc reduction(+:urban_drainage_q_total) + !$omp parallel do default(shared) & + !$omp private(nm, iz, io, type_id, dzs, qd, area_nm, h_cell, ramp) & + !$omp reduction(+:urban_drainage_q_total) schedule(static) + do nm = 1, np + ! + iz = urban_drainage_zone_indices(nm) + if (iz == 0) cycle + ! + type_id = urb_zone_type_id(iz) + ! + if (type_id == urb_type_injection_well) then + ! + ! Skip entirely once the well has reached maximum capacity. + ! Small overshoot of one dt is acceptable; we do not scale + ! per-cell flux to hit the cap exactly. + ! + if (urb_zone_cumulative_injection(iz) >= urb_zone_maximum_capacity(iz)) cycle + ! + if (subgrid) then + h_cell = zs(nm) - subgrid_z_zmin(nm) + else + h_cell = zs(nm) - zb(nm) + endif + ! + if (h_cell <= 0.0) cycle + ! + if (urb_zone_h_threshold(iz) > 0.0) then + ramp = min(h_cell / urb_zone_h_threshold(iz), 1.0) + else + ramp = 1.0 + endif + ! + if (crsgeo) then + area_nm = cell_area_m2(nm) + else + area_nm = cell_area(z_flags_iref(nm)) + endif + ! + if (subgrid) then + qd = min(ramp * urban_drainage_qmax(nm), z_volume(nm) / dt) + else + qd = min(ramp * urban_drainage_qmax(nm), h_cell * area_nm / dt) + endif + ! + else + ! + ! piped_drainage + ! + io = urban_drainage_outfall_index(iz) + if (io <= 0) cycle + ! + dzs = zs(nm) - zs(io) + ! + if (dzs > 0.0) then + ! + if (subgrid) then + h_cell = zs(nm) - subgrid_z_zmin(nm) + else + h_cell = zs(nm) - zb(nm) + endif + if (h_cell <= 0.0) cycle + ! + if (urb_zone_h_threshold(iz) > 0.0) then + ramp = min(h_cell / urb_zone_h_threshold(iz), 1.0) + else + ramp = 1.0 + endif + ! + if (crsgeo) then + area_nm = cell_area_m2(nm) + else + area_nm = cell_area(z_flags_iref(nm)) + endif + ! + if (subgrid) then + qd = min(ramp * urban_drainage_qmax(nm), z_volume(nm) / dt) + else + qd = min(ramp * urban_drainage_qmax(nm), h_cell * area_nm / dt) + endif + ! + else + ! + if (urb_zone_check_valve(iz)) cycle + ! + qd = -urban_drainage_backflow_coef(nm) * sqrt(-dzs) + if (qd < -urban_drainage_qmax(nm)) qd = -urban_drainage_qmax(nm) + ! + endif + ! + endif + ! + ! qsrc(nm) is unique per iteration (loop is over nm), no race. + ! The zone accumulator urban_drainage_q_total(iz) is summed via + ! the reduction(+) clause on the parent directive, so each + ! thread / gang gets a private copy that is combined at loop end. + ! + qsrc(nm) = qsrc(nm) - qd + ! + urban_drainage_q_total(iz) = urban_drainage_q_total(iz) + qd + ! + urban_drainage_cumulative_volume(nm) = urban_drainage_cumulative_volume(nm) + qd * dt + ! + enddo + !$omp end parallel do + ! + ! Second pass: for piped_drainage zones, deposit the per-zone flux + ! at the outfall cell; for injection_well zones, accumulate the + ! cumulative injected volume. + ! + !$acc parallel loop present( qsrc, urban_drainage_outfall_index, urban_drainage_q_total, & + !$acc urb_zone_type_id, urb_zone_cumulative_injection ) + do iz = 1, nr_urban_drainage_zones + ! + if (urb_zone_type_id(iz) == urb_type_piped_drainage) then + ! + io = urban_drainage_outfall_index(iz) + if (io <= 0) cycle + ! + !$acc atomic update + qsrc(io) = qsrc(io) + urban_drainage_q_total(iz) + ! + else + ! + ! injection_well + ! + urb_zone_cumulative_injection(iz) = urb_zone_cumulative_injection(iz) + urban_drainage_q_total(iz) * dt + ! + endif + ! + enddo + ! + call timer_stop('urban drainage') + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_urban_drainage_log_summary() + ! + ! Emit a one-block-per-zone description of every parsed urban + ! drainage zone to the log file. Intended for operator review at + ! init time. + ! + ! Called from: initialize_urban_drainage (this module), once after + ! cells have been stamped and per-zone totals have been + ! accumulated. + ! + implicit none + ! + integer :: iz + ! + if (nr_urban_drainage_zones <= 0) return + ! + call write_log('------------------------------------------', 0) + call write_log('Urban drainage zones', 0) + call write_log('------------------------------------------', 0) + ! + write(logstr,'(a,i0,a)')'Added ', nr_urban_drainage_zones, ' urban drainage zone(s)' + call write_log(logstr, 0) + call write_log('', 0) + ! + do iz = 1, nr_urban_drainage_zones + ! + write(logstr,'(a,i0,a)')'Zone ', iz, ':' + call write_log(logstr, 0) + ! + write(logstr,'(a,a)') ' name: ', trim(urb_zone_name(iz)) + call write_log(logstr, 0) + ! + write(logstr,'(a,a)') ' type: ', trim(urb_zone_type(iz)) + call write_log(logstr, 0) + ! + write(logstr,'(a,a)') ' polygon_file: ', trim(urb_zone_polygon_file(iz)) + call write_log(logstr, 0) + ! + write(logstr,'(a,i0)') ' cells_assigned: ', urb_zone_n_cells(iz) + call write_log(logstr, 0) + ! + write(logstr,'(a,a,a)') ' area: ', trim(fmt_real(urb_zone_area(iz), 1)), ' (m2)' + call write_log(logstr, 0) + ! + if (urb_zone_type_id(iz) == urb_type_piped_drainage) then + ! + if (urb_zone_max_outfall_rate(iz) > 0.0) then + write(logstr,'(a,a,a)') ' max_outfall_rate: ', trim(fmt_real(urb_zone_max_outfall_rate(iz), 4)), ' (m3/s)' + call write_log(logstr, 0) + write(logstr,'(a,a,a)') ' design_precip: ', trim(fmt_real(urb_zone_design_precip(iz), 2)), & + ' (mm/hr, derived from max_outfall_rate)' + call write_log(logstr, 0) + else + write(logstr,'(a,a,a)') ' design_precip: ', trim(fmt_real(urb_zone_design_precip(iz), 2)), ' (mm/hr)' + call write_log(logstr, 0) + endif + ! + write(logstr,'(a,a,a)') ' qmax_total: ', trim(fmt_real(urb_zone_qmax_total(iz), 4)), ' (m3/s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,a,a)') ' h_threshold: ', trim(fmt_real(urb_zone_h_threshold(iz), 3)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,a,a)') ' dh_design_min: ', trim(fmt_real(urb_zone_dh_design_min(iz), 3)), ' (m)' + call write_log(logstr, 0) + ! + if (urb_zone_include_outfall(iz)) then + write(logstr,'(a,a,a,a,a)') ' outfall: [', trim(fmt_real(urb_zone_outfall_x(iz), 3)), ', ', & + trim(fmt_real(urb_zone_outfall_y(iz), 3)), ']' + call write_log(logstr, 0) + ! + if (urban_drainage_outfall_index(iz) > 0) then + write(logstr,'(a,i0)') ' outfall_index: ', urban_drainage_outfall_index(iz) + call write_log(logstr, 0) + else + call write_log(' outfall_index: (no active cell snapped)', 0) + endif + else + call write_log(' outfall: (disabled)', 0) + endif + ! + if (urb_zone_check_valve(iz)) then + call write_log(' check_valve: true', 0) + else + call write_log(' check_valve: false', 0) + endif + ! + elseif (urb_zone_type_id(iz) == urb_type_injection_well) then + ! + write(logstr,'(a,a,a)') ' injection_rate: ', trim(fmt_real(urb_zone_injection_rate(iz), 4)), ' (m3/s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,a,a)') ' maximum_capacity: ', trim(fmt_real(urb_zone_maximum_capacity(iz), 1)), ' (m3)' + call write_log(logstr, 0) + ! + write(logstr,'(a,a,a)') ' qmax_total: ', trim(fmt_real(urb_zone_qmax_total(iz), 4)), ' (m3/s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,a,a)') ' h_threshold: ', trim(fmt_real(urb_zone_h_threshold(iz), 3)), ' (m)' + call write_log(logstr, 0) + ! + endif + ! + call write_log('', 0) + ! + enddo + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine read_urban_drainage(filename, ierr) + ! + ! Parse the *.urb TOML file into the per-zone arrays. + ! + ! Schema: + ! + ! [[urban_drainage_zone]] + ! name = "area 1" ! required, string (matches polygon name) + ! type = "piped_drainage" ! required, one of: "piped_drainage", "injection_well" + ! polygon_file = "zones.tek" ! required + ! + ! # piped_drainage keys: + ! outfall = [950.0, 150.0] ! required if include_outfall = true, [x, y] pair + ! design_precip = 20.0 ! required if max_outfall_rate absent, mm/hr + ! max_outfall_rate = 6.0 ! alternative to design_precip, m3/s total zone capacity + ! ! exactly one of {design_precip, max_outfall_rate} must be given + ! dh_design_min = 0.1 ! optional, m (default 0.1) + ! include_outfall = true ! optional (default true) + ! check_valve = true ! optional (default false) + ! + ! # injection_well keys: + ! injection_rate = 0.5 ! required, m3/s total zone pump rate + ! maximum_capacity = 1000.0 ! required, m3 well total storage capacity + ! + ! # common: + ! h_threshold = 0.0 ! optional, m (default 0.0) + ! + ! Called from: initialize_urban_drainage (this module). + ! + use tomlf + ! + implicit none + ! + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + ! + type(toml_table), allocatable :: top + type(toml_error), allocatable :: err + type(toml_array), pointer :: arr_zones + type(toml_table), pointer :: tbl_zone + character(len=:), allocatable :: name_str, type_str, poly_str + integer :: nz, i, stat + real(kind=8) :: r8_tmp + logical :: l_tmp, found + ! + ierr = 0 + ! + call toml_load(top, filename, error=err) + if (allocated(err)) then + write(logstr,'(a,a,a,a)')' Error ! Failed to parse TOML file ', trim(filename), ': ', & + trim(err%message) + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + if (.not. allocated(top)) then + write(logstr,'(a,a)')' Error ! Could not load TOML file ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + nullify(arr_zones) + call get_value(top, 'urban_drainage_zone', arr_zones, requested=.false., stat=stat) + ! + if (.not. associated(arr_zones)) then + nr_urban_drainage_zones = 0 + return + endif + ! + if (.not. is_array_of_tables(arr_zones)) then + write(logstr,'(a,a)')' Error ! Key "urban_drainage_zone" must be an array of tables in ', & + trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + nz = len(arr_zones) + nr_urban_drainage_zones = nz + ! + if (nz == 0) return + ! + allocate(urb_zone_name(nz)) + allocate(urb_zone_type(nz)) + allocate(urb_zone_type_id(nz)) + allocate(urb_zone_polygon_file(nz)) + allocate(urb_zone_outfall_x(nz)) + allocate(urb_zone_outfall_y(nz)) + allocate(urb_zone_design_precip(nz)) + allocate(urb_zone_max_outfall_rate(nz)) + allocate(urb_zone_injection_rate(nz)) + allocate(urb_zone_maximum_capacity(nz)) + allocate(urb_zone_h_threshold(nz)) + allocate(urb_zone_dh_design_min(nz)) + allocate(urb_zone_include_outfall(nz)) + allocate(urb_zone_check_valve(nz)) + ! + urb_zone_name = '' + urb_zone_type = '' + urb_zone_type_id = 0 + urb_zone_polygon_file = '' + urb_zone_outfall_x = 0.0 + urb_zone_outfall_y = 0.0 + urb_zone_design_precip = 0.0 + urb_zone_max_outfall_rate = 0.0 + urb_zone_injection_rate = 0.0 + urb_zone_maximum_capacity = 0.0 + urb_zone_h_threshold = 0.0 + urb_zone_dh_design_min = 0.1 + urb_zone_include_outfall = .true. + urb_zone_check_valve = .false. + ! + do i = 1, nz + ! + nullify(tbl_zone) + call get_value(arr_zones, i, tbl_zone, stat=stat) + if (.not. associated(tbl_zone)) then + write(logstr,'(a,i0,a)')' Error ! urban_drainage_zone entry ', i, ' is not a table' + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + if (allocated(name_str)) deallocate(name_str) + call get_value(tbl_zone, 'name', name_str, stat=stat) + if (.not. allocated(name_str)) then + write(logstr,'(a,i0)')' Error ! Missing required "name" in urban_drainage_zone entry ', i + call write_log(logstr, 1) + ierr = 1 + return + endif + urb_zone_name(i) = name_str + ! + ! type is now required and must resolve to a known type id. + ! + if (allocated(type_str)) deallocate(type_str) + call get_value(tbl_zone, 'type', type_str, stat=stat) + if (.not. allocated(type_str)) then + write(logstr,'(a,a,a)')' Error ! Missing required "type" in urban_drainage_zone "', & + trim(urb_zone_name(i)), '" (expected "piped_drainage" or "injection_well")' + call write_log(logstr, 1) + ierr = 1 + return + endif + urb_zone_type(i) = type_str + ! + select case (trim(type_str)) + case ('piped_drainage') + urb_zone_type_id(i) = urb_type_piped_drainage + case ('injection_well') + urb_zone_type_id(i) = urb_type_injection_well + case default + write(logstr,'(a,a,a,a,a)')' Error ! Unknown type "', trim(type_str), & + '" in urban_drainage_zone "', trim(urb_zone_name(i)), & + '" (expected "piped_drainage" or "injection_well")' + call write_log(logstr, 1) + ierr = 1 + return + end select + ! + if (allocated(poly_str)) deallocate(poly_str) + call get_value(tbl_zone, 'polygon_file', poly_str, stat=stat) + if (.not. allocated(poly_str)) then + write(logstr,'(a,a,a)')' Error ! Missing required "polygon_file" in urban_drainage_zone "', & + trim(urb_zone_name(i)), '"' + call write_log(logstr, 1) + ierr = 1 + return + endif + urb_zone_polygon_file(i) = poly_str + ! + ! h_threshold is common to both types. + ! + call get_value(tbl_zone, 'h_threshold', r8_tmp, stat=stat) + if (stat == 0) urb_zone_h_threshold(i) = real(r8_tmp, 4) + ! + ! Type-specific fields. + ! + if (urb_zone_type_id(i) == urb_type_piped_drainage) then + ! + block + type(toml_array), pointer :: arr_outfall + integer :: n_out, stat_arr + ! + nullify(arr_outfall) + call get_value(tbl_zone, 'outfall', arr_outfall, requested=.false., stat=stat_arr) + ! + if (associated(arr_outfall)) then + ! + n_out = len(arr_outfall) + ! + if (n_out /= 2) then + write(logstr,'(a,a,a,i0,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(i)), & + '" key "outfall" must have exactly 2 elements (got ', n_out, ')' + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + call get_value(arr_outfall, 1, r8_tmp, stat=stat_arr) + urb_zone_outfall_x(i) = real(r8_tmp, 4) + ! + call get_value(arr_outfall, 2, r8_tmp, stat=stat_arr) + urb_zone_outfall_y(i) = real(r8_tmp, 4) + ! + endif + ! + end block + ! + ! Exactly one of design_precip / max_outfall_rate must be given. + ! has_key distinguishes "absent" from "present but 0.0". + ! + block + logical :: has_precip, has_rate + has_precip = tbl_zone%has_key('design_precip') + has_rate = tbl_zone%has_key('max_outfall_rate') + if (has_precip .and. has_rate) then + write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(i)), & + '" has both "design_precip" and "max_outfall_rate"; specify only one' + call write_log(logstr, 1) + ierr = 1 + return + endif + if (.not. has_precip .and. .not. has_rate) then + write(logstr,'(a,a,a)')' Error ! piped_drainage zone "', trim(urb_zone_name(i)), & + '" needs "design_precip" (mm/hr) or "max_outfall_rate" (m3/s)' + call write_log(logstr, 1) + ierr = 1 + return + endif + if (has_precip) then + call get_value(tbl_zone, 'design_precip', r8_tmp, stat=stat) + urb_zone_design_precip(i) = real(r8_tmp, 4) + else + call get_value(tbl_zone, 'max_outfall_rate', r8_tmp, stat=stat) + urb_zone_max_outfall_rate(i) = real(r8_tmp, 4) + endif + end block + ! + call get_value(tbl_zone, 'dh_design_min', r8_tmp, stat=stat) + if (stat == 0) urb_zone_dh_design_min(i) = real(r8_tmp, 4) + if (urb_zone_dh_design_min(i) <= 0.0) urb_zone_dh_design_min(i) = 0.1 + ! + call get_value(tbl_zone, 'include_outfall', l_tmp, stat=stat) + if (stat == 0) urb_zone_include_outfall(i) = l_tmp + ! + call get_value(tbl_zone, 'check_valve', l_tmp, stat=stat) + if (stat == 0) urb_zone_check_valve(i) = l_tmp + ! + ! Minimal sanity check on outfall: if include_outfall is true, + ! outfall coords should be specified (warn only; snap will + ! catch bad values). + ! + if (urb_zone_include_outfall(i)) then + found = (urb_zone_outfall_x(i) /= 0.0 .or. urb_zone_outfall_y(i) /= 0.0) + if (.not. found) then + write(logstr,'(a,a,a)')' Warning : piped_drainage zone "', trim(urb_zone_name(i)), & + '" has include_outfall = true but outfall = [0.0, 0.0]' + call write_log(logstr, 0) + endif + endif + ! + elseif (urb_zone_type_id(i) == urb_type_injection_well) then + ! + if (.not. tbl_zone%has_key('injection_rate')) then + write(logstr,'(a,a,a)')' Error ! injection_well zone "', trim(urb_zone_name(i)), & + '" needs "injection_rate" (m3/s)' + call write_log(logstr, 1) + ierr = 1 + return + endif + call get_value(tbl_zone, 'injection_rate', r8_tmp, stat=stat) + urb_zone_injection_rate(i) = real(r8_tmp, 4) + ! + if (.not. tbl_zone%has_key('maximum_capacity')) then + write(logstr,'(a,a,a)')' Error ! injection_well zone "', trim(urb_zone_name(i)), & + '" needs "maximum_capacity" (m3)' + call write_log(logstr, 1) + ierr = 1 + return + endif + call get_value(tbl_zone, 'maximum_capacity', r8_tmp, stat=stat) + urb_zone_maximum_capacity(i) = real(r8_tmp, 4) + ! + ! injection_well has no outfall or check valve. + ! + urb_zone_include_outfall(i) = .false. + urb_zone_check_valve(i) = .false. + ! + endif + ! + enddo + ! + end subroutine + ! +end module sfincs_urban_drainage diff --git a/source/src/sfincs_wavemaker.f90 b/source/src/sfincs_wavemaker.f90 index 9aa83b0c7..726a8e7ed 100644 --- a/source/src/sfincs_wavemaker.f90 +++ b/source/src/sfincs_wavemaker.f90 @@ -1397,12 +1397,13 @@ subroutine initialize_wavemakers() end subroutine - subroutine update_wavemaker_fluxes(t, dt, tloop) + subroutine update_wavemaker_fluxes(t, dt) ! ! Update fluxes qx and qy at wave maker points ! use sfincs_data use sfincs_snapwave + use sfincs_timers ! implicit none ! @@ -1414,13 +1415,7 @@ subroutine update_wavemaker_fluxes(t, dt, tloop) real*4 :: wave_steepness, betas, zinc, zig, dwvm, ztot, hm0_inc real*4 :: ui, ub, dzuv, facint, zsuv, depthuv, uvm0 ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! - call system_clock(count0, count_rate, count_max) + call timer_start('wavemaker') ! ! Factors for double-exponential filtering ! @@ -1755,9 +1750,8 @@ subroutine update_wavemaker_fluxes(t, dt, tloop) enddo !$acc end parallel ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + call timer_stop('wavemaker') ! end subroutine - + end module diff --git a/source/src/snapwave/snapwave_solver.f90 b/source/src/snapwave/snapwave_solver.f90 index d5ac4d7a4..9b207fc22 100644 --- a/source/src/snapwave/snapwave_solver.f90 +++ b/source/src/snapwave/snapwave_solver.f90 @@ -1623,7 +1623,7 @@ end subroutine hpsort_eps_epw subroutine timer(t) real*4,intent(out) :: t - integer*4 :: count,count_rate,count_max + integer*8 :: count,count_rate,count_max call system_clock (count,count_rate, count_max) t = real(count) / count_rate end subroutine timer diff --git a/source/src/utils/sfincs_polygons.f90 b/source/src/utils/sfincs_polygons.f90 new file mode 100644 index 000000000..a0fcae5ac --- /dev/null +++ b/source/src/utils/sfincs_polygons.f90 @@ -0,0 +1,233 @@ +module sfincs_polygons + ! + ! Minimal polygon helper module for SFINCS. + ! + ! Provides: + ! t_polygon Derived type: one named polygon with vertex arrays. + ! read_tek_polygons Read a Delft3D "tek" polyline/polygon file + ! (name line + "nrows ncols" + rows of x y) and + ! return an array of t_polygon, each closed so + ! that the last vertex equals the first. Called + ! from initialize_urban_drainage (sfincs_urban_drainage). + ! point_in_polygon Scalar ray-casting test for a single point. + ! Called from points_in_polygon_omp. + ! points_in_polygon_omp OMP-parallel sweep of a point array against one + ! polygon, writing a logical mask. Called from + ! initialize_urban_drainage (sfincs_urban_drainage). + ! + use sfincs_log + use sfincs_error + ! + implicit none + ! + private + public :: t_polygon, read_tek_polygons, point_in_polygon, points_in_polygon_omp + ! + type :: t_polygon + character(len=64) :: name = '' + integer :: n = 0 + real*4, dimension(:), allocatable :: x + real*4, dimension(:), allocatable :: y + end type t_polygon + ! +contains + ! + subroutine read_tek_polygons(filename, polygons, ierr) + ! + ! Read a Delft3D "tek" polyline file into an array of t_polygon. + ! + ! File format (one or more blocks): + ! + ! + ! + ! ... + ! + ! + ! The file is swept twice: first to count blocks, then to read them. + ! Each polygon is auto-closed: if the last vertex is not equal to the + ! first, a copy of the first vertex is appended so downstream + ! point-in-polygon tests can treat the last-to-first edge uniformly. + ! + ! Called from: initialize_urban_drainage (sfincs_urban_drainage). + ! + implicit none + ! + character(len=*), intent(in) :: filename + type(t_polygon), allocatable, intent(out) :: polygons(:) + integer, intent(out) :: ierr + ! + integer :: unit, stat, npoly, nrows, ncols, irow, ipoly + character(len=256) :: name_line + real*4 :: dummy + logical :: ok + ! + ierr = 0 + ! + ok = check_file_exists(filename, 'Urban drainage polygon file', .true.) + ! + ! First pass: count polygons. + ! + unit = 501 + open(unit, file=trim(filename), status='old', action='read', iostat=stat) + if (stat /= 0) then + write(logstr,'(a,a)')' Error ! Could not open polygon file ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + npoly = 0 + do + read(unit, '(a)', iostat=stat) name_line + if (stat /= 0) exit + if (len_trim(name_line) == 0) cycle + read(unit, *, iostat=stat) nrows, ncols + if (stat /= 0) exit + npoly = npoly + 1 + do irow = 1, nrows + read(unit, *, iostat=stat) dummy + if (stat /= 0) exit + enddo + enddo + rewind(unit) + ! + if (npoly == 0) then + close(unit) + allocate(polygons(0)) + return + endif + ! + allocate(polygons(npoly)) + ! + ! Second pass: read each polygon. + ! + do ipoly = 1, npoly + ! + read(unit, '(a)', iostat=stat) name_line + if (stat /= 0) exit + do while (len_trim(name_line) == 0) + read(unit, '(a)', iostat=stat) name_line + if (stat /= 0) exit + enddo + ! + read(unit, *, iostat=stat) nrows, ncols + if (stat /= 0) then + write(logstr,'(a,i0,a,a)')' Error ! Missing shape line for polygon ', ipoly, & + ' in ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + close(unit) + return + endif + ! + ! Reserve one extra slot so we can auto-close the ring if needed. + ! + allocate(polygons(ipoly)%x(nrows + 1)) + allocate(polygons(ipoly)%y(nrows + 1)) + polygons(ipoly)%name = trim(adjustl(name_line)) + ! + do irow = 1, nrows + read(unit, *, iostat=stat) polygons(ipoly)%x(irow), polygons(ipoly)%y(irow) + if (stat /= 0) then + write(logstr,'(a,i0,a,i0,a,a)')' Error ! Failed reading vertex ', irow, & + ' of polygon ', ipoly, ' in ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + close(unit) + return + endif + enddo + ! + ! Close the ring if the user omitted it. + ! + if (polygons(ipoly)%x(nrows) /= polygons(ipoly)%x(1) .or. & + polygons(ipoly)%y(nrows) /= polygons(ipoly)%y(1)) then + polygons(ipoly)%x(nrows + 1) = polygons(ipoly)%x(1) + polygons(ipoly)%y(nrows + 1) = polygons(ipoly)%y(1) + polygons(ipoly)%n = nrows + 1 + else + polygons(ipoly)%n = nrows + endif + ! + enddo + ! + close(unit) + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + pure function point_in_polygon(xp, yp, xv, yv, nv) result(inside) + ! + ! Classic even-odd ray-casting point-in-polygon test. + ! + ! Returns .true. if (xp, yp) lies inside the closed polygon defined by + ! the first nv vertices of (xv, yv). The polygon is assumed closed by + ! the caller (last vertex == first vertex). + ! + ! Called from: points_in_polygon_omp (this module). + ! + implicit none + ! + real*4, intent(in) :: xp, yp + integer, intent(in) :: nv + real*4, intent(in) :: xv(nv), yv(nv) + logical :: inside + ! + integer :: i, j + ! + inside = .false. + j = nv - 1 + if (j < 1) j = nv + do i = 1, nv + if (((yv(i) > yp) .neqv. (yv(j) > yp)) .and. & + (xp < (xv(j) - xv(i)) * (yp - yv(i)) / (yv(j) - yv(i) + tiny(1.0)) + xv(i))) then + inside = .not. inside + endif + j = i + enddo + ! + end function + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine points_in_polygon_omp(xp, yp, np_pts, poly, inside) + ! + ! OMP-parallel sweep of an (xp, yp) point array against a single polygon. + ! inside(:) must be allocated by the caller with size np_pts. Points + ! already flagged .true. on entry are preserved (so the caller can + ! accumulate hits across multiple polygons if desired); this routine + ! only flips .false. to .true.. + ! + ! Called from: initialize_urban_drainage (sfincs_urban_drainage). + ! + implicit none + ! + integer, intent(in) :: np_pts + real*4, intent(in) :: xp(np_pts), yp(np_pts) + type(t_polygon), intent(in) :: poly + logical, intent(inout) :: inside(np_pts) + ! + integer :: i + real*4 :: xmin, xmax, ymin, ymax + ! + if (poly%n < 3) return + ! + xmin = minval(poly%x(1:poly%n)) + xmax = maxval(poly%x(1:poly%n)) + ymin = minval(poly%y(1:poly%n)) + ymax = maxval(poly%y(1:poly%n)) + ! + !$omp parallel do default(shared) private(i) schedule(static) + do i = 1, np_pts + if (inside(i)) cycle + if (xp(i) < xmin .or. xp(i) > xmax .or. yp(i) < ymin .or. yp(i) > ymax) cycle + if (point_in_polygon(xp(i), yp(i), poly%x, poly%y, poly%n)) then + inside(i) = .true. + endif + enddo + !$omp end parallel do + ! + end subroutine + ! +end module sfincs_polygons diff --git a/source/third_party_open/netcdf/netcdf-fortran-4.6.1/netcdff_c.vcxproj b/source/third_party_open/netcdf/netcdf-fortran-4.6.1/netcdff_c.vcxproj index bb14a4db0..86c16c6f7 100644 --- a/source/third_party_open/netcdf/netcdf-fortran-4.6.1/netcdff_c.vcxproj +++ b/source/third_party_open/netcdf/netcdf-fortran-4.6.1/netcdff_c.vcxproj @@ -25,12 +25,12 @@ StaticLibrary MultiByte - v143 + Intel C++ Compiler 2026 StaticLibrary MultiByte - v143 + Intel C++ Compiler 2026