diff --git a/.gitignore b/.gitignore index 22752d026..028a42412 100644 --- a/.gitignore +++ b/.gitignore @@ -65,3 +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.update01 +/source/Dockerfile.gpu.test +/source/Dockerfile.gpu.25.5.ccall +/source/Dockerfile.gpu diff --git a/docs/index.rst b/docs/index.rst index 8002b8252..93bec05aa 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 34bf8f520..1815f49e4 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -29,6 +29,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -60,8 +97,11 @@ + + + @@ -118,6 +158,8 @@ + + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index 891652f08..342fa81b0 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -15,7 +15,43 @@ lib_LTLIBRARIES = libsfincs.la #all sources for sfincs that go into the library (all but the program) libsfincs_la_SOURCES = \ + ../third_party_open/utils/toml-f/src/tomlf/constants.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/version.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de/token.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/utils/io.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/datetime.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/error.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/utils.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/type/value.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/terminal.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de/abc.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de/context.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/list.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/map.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/node.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/type/array.f90 \ + ../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 \ + ../third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/merge.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/path.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build.f90 \ + ../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_spiderweb.f90 \ sfincs_data.f90 \ @@ -39,6 +75,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 13a49477c..578210a43 100644 --- a/source/src/sfincs_boundaries.f90 +++ b/source/src/sfincs_boundaries.f90 @@ -1125,26 +1125,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 ! @@ -1158,7 +1153,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) @@ -1169,11 +1164,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 935be5983..d9fb88851 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 @@ -204,6 +199,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 @@ -217,6 +213,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 @@ -256,20 +258,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 @@ -399,6 +387,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 @@ -578,6 +576,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 ! @@ -772,22 +771,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 !!! @@ -955,7 +958,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 ! @@ -1013,6 +1022,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) @@ -1111,10 +1121,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 dd50ffd27..7efce042a 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -1,648 +1,412 @@ module sfincs_discharges - + ! + ! 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. + ! + ! 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. + ! + ! 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_log use sfincs_error - -contains ! - subroutine read_discharges() + implicit none ! - ! Reads discharge files + ! 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). ! - use sfincs_data - use sfincs_ncinput - use quadtree + ! Public so downstream output modules (sfincs_output, sfincs_ncoutput) + ! and the openacc bookkeeping module can reference them. ! - implicit none + ! Input file paths (sfincs.inp keywords 'srcfile' / 'disfile' / + ! 'netsrcdisfile'); 'none' when the corresponding input is not supplied. ! - real*4, dimension(:), allocatable :: xsnk - real*4, dimension(:), allocatable :: ysnk + character(len=256), public :: srcfile + character(len=256), public :: disfile + character(len=256), public :: netsrcdisfile ! - real*4 dummy, xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp + ! Number of river discharge points resolved from the input files. ! - integer isrc, itsrc, idrn, nm, m, n, stat, j, iref, nmq, npars + integer, public :: nr_discharge_points ! - logical :: ok + ! Name length (matches src_struc_name_len from sfincs_src_structures). ! - character(len=256) :: drainage_line, message + integer, parameter, public :: src_name_len = 128 ! - ! Read discharge points + ! Per-river-source names ! - nsrc = 0 - ndrn = 0 - ntsrc = 0 - itsrclast = 1 + character(len=src_name_len), dimension(:), allocatable, public :: src_name ! (nr_discharge_points) user-supplied or auto-generated names for river point sources ! - 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 + ! Runtime state ! - 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 + 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 ! - nsrcdrn = nsrc + 2 * ndrn +contains ! - if (nsrcdrn > 0) then - allocate(nmindsrc(nsrcdrn)) - allocate(qtsrc(nsrcdrn)) - nmindsrc = 0 - qtsrc = 0.0 - endif + !-----------------------------------------------------------------------------------------------------! ! - if (srcfile(1:4) /= 'none') then + subroutine initialize_discharges() ! - ! Actually read src and dis files + ! 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. ! - allocate(xsrc(nsrc)) - allocate(ysrc(nsrc)) + ! Called from: sfincs_lib (once, at init time). ! - do n = 1, nsrc - read(500,*)xsrc(n), ysrc(n) - enddo - 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 - 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) + 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 + ! + discharges = .false. + nr_discharge_points = 0 + ntsrc = 0 + itsrclast = 1 ! - 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) + 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.) ! - tsrc(ntsrc) = t1 + 1.0 + read(500, *, iostat=stat) dummy + if (stat < 0) exit + nr_discharge_points = nr_discharge_points + 1 ! - endif + enddo ! - endif - ! - endif - ! - if (nsrc > 0) then - ! - ! Determine m and n indices of sources - ! - do isrc = 1, nsrc + rewind(500) ! - ! Find cell in quadtree first + elseif (netsrcdisfile(1:4) /= 'none') then ! FEWS-compatible NetCDF discharge time series ! - nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) + ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) ! - if (nmq > 0) then + call read_netcdf_discharge_data(netsrcdisfile, nr_discharge_points) ! also sets ntsrc, xsrc, ysrc, qsrc_ts, tsrc (in sfincs_data) + ! + ! 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 ! - nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) + allocate(src_name(nr_discharge_points)) + ! + src_name = ' ' + ! + do n = 1, nr_discharge_points + ! + write(src_name(n), '(a,i4.4)') 'discharge_', n + ! + enddo ! endif - ! - enddo - ! - ! Don't need coordinates anymore, and xsrc and ysrc may be used for drainage points as well + ! + 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 ! - deallocate(xsrc) - deallocate(ysrc) + if (nr_discharge_points <= 0) return ! - endif - ! - ! And now the drainage points - ! - if (ndrn>0) then + discharges = .true. ! - 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(nmindsrc(nr_discharge_points)) + allocate(qtsrc(nr_discharge_points)) ! - allocate(drainage_type(ndrn)) - allocate(drainage_params(ndrn, 6)) - allocate(drainage_status(ndrn)) - allocate(drainage_distance(ndrn)) - allocate(drainage_fraction_open(ndrn)) + nmindsrc = 0 + qtsrc = 0.0 ! - 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) + ! Read src/dis contents for the srcfile case ! - do idrn = 1, ndrn - ! - read(501, '(a)') drainage_line - ! - ! First find out what type of drainage structure it is (integer 5th item in line) + if (srcfile(1:4) /= 'none') then ! - read(drainage_line,*,iostat=stat)xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp, drainage_type(idrn) + allocate(xsrc(nr_discharge_points)) + allocate(ysrc(nr_discharge_points)) + allocate(src_name(nr_discharge_points)) ! - npars = 0 ! Default (if npars stays 0, throw error) + src_name = ' ' ! - if (drainage_type(idrn) == 1 .or. drainage_type(idrn) == 2 .or. drainage_type(idrn) == 3) then + do n = 1, nr_discharge_points ! - ! Pump, culvert or check valve (1 parameter) + read(500, '(a)') line + line_trim = adjustl(line) ! - npars = 1 + ! Count whitespace-separated tokens on the line. ! - elseif (drainage_type(idrn) == 4 .or. drainage_type(idrn) == 5) then + call count_tokens(line_trim, ntok) ! - ! Controlled gate (6 parameters : width, sill elevation, manning, zmin, zmax, closing time) - ! - npars = 6 + 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 + ! + close(500) + ! + ! Read discharge time series + ! + ok = check_file_exists(disfile, 'River discharge timeseries dis file', .true.) + ! + open(502, file=trim(disfile)) ! - if (npars == 0) then + do while (.true.) ! - write(logstr,'(a,i0,a)')'Drainage type ', drainage_type(idrn), ' not recognized !' - call stop_sfincs(logstr, -1) + read(502, *, iostat=stat) dummy + if (stat < 0) exit + ntsrc = ntsrc + 1 ! - endif + enddo ! - if (npars == 1) then - ! - ! Pump, culvert or check valve + rewind(502) + allocate(tsrc(ntsrc)) + allocate(qsrc_ts(nr_discharge_points, ntsrc)) + ! + do itsrc = 1, ntsrc ! - read(drainage_line,*,iostat=stat)xsnk(idrn), ysnk(idrn), xsrc(idrn), ysrc(idrn), drainage_type(idrn), drainage_params(idrn,1) + read(502, *) tsrc(itsrc), (qsrc_ts(isrc, itsrc), isrc = 1, nr_discharge_points) ! - elseif (npars == 6) then + enddo + ! + close(502) + ! + if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then ! - ! Controlled gate, needs 6 parameters + write(logstr,'(a)') 'Warning! Times in discharge file do not cover entire simulation period !' + call write_log(logstr, 1) ! - 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) + 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 ! - if (stat /= 0) then + endif + ! + ! Map river sources to grid cells + ! + do isrc = 1, nr_discharge_points + ! + nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) + ! + if (nmq > 0) then ! - write(logstr,'(a,i0,a,i0,a)')'Drainage type ', drainage_type(idrn), ' requires ', npars, ' parameters !' - call stop_sfincs(logstr, -1) + nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) ! endif ! enddo ! - close(501) + deallocate(xsrc) + deallocate(ysrc) ! - ! Determine nm indices of source and sinks + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine update_discharges(t, dt) ! - do idrn = 1, ndrn - ! - ! Determine index of sink first - ! - j = nsrc + idrn*2 - 1 - ! - nmq = find_quadtree_cell(xsnk(idrn), ysnk(idrn)) + ! 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 ! - if (nmq > 0) then + if (tsrc(itsrc) > t) then ! - nmindsrc(j) = index_sfincs_in_quadtree(nmq) + it_prev = itsrc - 1 + it_next = itsrc + itsrclast = it_prev + exit ! endif ! - ! And now the index of the source - ! - j = nsrc + idrn * 2 + enddo + ! + ! 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. + ! + 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)) + ! + ! 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 ! - nmq = find_quadtree_cell(xsrc(idrn), ysrc(idrn)) + qtsrc(isrc) = qsrc_ts(isrc, it_prev) + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt + nm = nmindsrc(isrc) ! - if (nmq > 0) then + if (nm > 0) then ! - nmindsrc(j) = index_sfincs_in_quadtree(nmq) + !$acc atomic update + !$omp atomic + qsrc(nm) = qsrc(nm) + qtsrc(isrc) ! endif ! - ! Get coords of source and sink points, and compute distance between them - ! This is needed for controlled gates (type 4) - ! - 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)) - ! - drainage_distance(idrn) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) - ! enddo + !$omp end parallel do + !$acc end parallel loop ! - deallocate(xsrc) - deallocate(ysrc) - deallocate(xsnk) - deallocate(ysnk) + call timer_stop('discharges') ! - ! 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 - 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 - exit - endif - enddo + subroutine count_tokens(line, ntok) ! - !$acc update device(qtsrc) + ! Count the number of whitespace-separated tokens in a string. + ! Whitespace = spaces and tabs. Empty string returns 0. ! - endif - ! - if (ndrn > 0) then + ! Called from: initialize_discharges (this module) to disambiguate the + ! 2-column vs 3-column srcfile layout. ! - !$acc serial, present( z_volume, zs, zb, nmindsrc, qtsrc, drainage_type, drainage_params ) - do idrn = 1, ndrn - ! - jin = nsrc + idrn * 2 - 1 - jout = nsrc + idrn * 2 + 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 65bd1015e..a2a88f52d 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -24,8 +24,6 @@ subroutine initialize_domain() ! call initialize_roughness() ! - call initialize_infiltration() ! see: sfincs_infiltration.f90 - ! call initialize_storage_volume() ! call initialize_hydro() @@ -1740,24 +1738,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() ! @@ -2199,12 +2261,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 bce4af73f..b3b4d21b7 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 @@ -1007,10 +1008,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 @@ -1021,14 +1018,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 efbad2e9a..45d5469e8 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -1,1036 +1,1056 @@ module sfincs_input - -contains - - subroutine read_sfincs_input() - ! - ! Reads sfincs.inp ! - use sfincs_data - use sfincs_date - use sfincs_log - use sfincs_error + ! 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) + private + public :: read_sfincs_input + public :: get_keyword, get_keyword_real_array ! - 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) + 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 ! - 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) - ! - ! 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') - ! - ! 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_real_input(500,'snapwave_waveforces_factor',waveforces_factor,1.0) - ! - ! Wind drag +contains ! - 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 + subroutine read_sfincs_input() ! - else + ! 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) + ! + ! Coupled SnapWave solver parameters + ! + call get_keyword(500, 'snapwave_wind', snapwavewind, .false.) ! feed wind into SnapWave (implies storing wind speed/direction) + call get_keyword(500, 'snapwave_waveforces_factor', waveforces_factor, 1.0) ! multiplier on SnapWave wave forces + ! + ! 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 ! - ! Use defaults + close(500) ! - 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) + ! Done with reading input ! - 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 - ! - dxy = min(dx, dy) - dxinv = 1.0/dx - dyinv = 1.0/dy - ! - manning2d = .false. - imanning2d = 0 - if (manningfile/='none') then - manning2d = .true. - imanning2d = 1 - endif - ! - ! CRS and Coriolis parameter - ! - fcorio = 0.0 - ! - if (igeo == 0) then + ! Now do some post-processing and consistency checks on the inputs, and emit ! - ! Projected (default with coriolis, unless latitude is 0.0) + ! Limit progress reporter to (0, 100]% ! - crsgeo = .false. - fcorio = 2 * 7.2921e-05 * sin(latitude * pi / 180) + percdoneval = max(min(percdoneval, 100), 0) ! - if (latitude < 0.01 .and. latitude > -0.01) then + if (epsg == 0) then + ! + call write_log('Warning : no EPSG code defined', 0) ! - ! No Coriolis force - ! - coriolis = .false. - ! endif ! - else + ! If tref not provided, assume tref = tstart. ! - ! 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 (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_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) + ! Compute simulation time span in seconds, relative to tref. ! - else + call time_difference(trefstr, tstartstr, dtsec) + t0 = dtsec * 1.0 + call time_difference(trefstr, tstopstr, dtsec) + t1 = dtsec * 1.0 + tspinup = t0 + tspinup ! - subgrid = .false. - isubgrid = 0 - call write_log('Info : running SFINCS with regular bathymetry', 0) + g = 9.81 + pi = 3.14159 + gn2 = 9.81 * 0.02 * 0.02 ! only used in subgrid mode ! - 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) + qinf = qinf / (3600 * 1000) ! mm/hr -> m/s ! - elseif (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .true.) then + rotation = rotation * pi / 180 + cosrot = cos(rotation) + sinrot = sin(rotation) ! - 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 + area = dx * dy + dxy = min(dx, dy) + dxinv = 1.0 / dx + dyinv = 1.0 / dy + ! + manning2d = .false. + if (manningfile /= 'none') manning2d = .true. ! - wavemaker = .true. - iwavemaker = 1 + ! CRS and Coriolis parameter ! - call write_log('Info : turning on process: Dynamic waves', 0) + fcorio = 0.0 ! - if (wmsigstr(1:3) == 'mon') then - ! - ! Monochromatic - ! - wavemaker_spectrum = .false. + 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 - ! - 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 (crsgeo) then + call write_log('Info : input grid interpreted as geographic coordinates', 0) else - write(logstr,*)'Warning : advection scheme ', trim(advstr), ' not recognized! Using default upw1 instead!' - call write_log(logstr, 1) + call write_log('Info : input grid interpreted as projected coordinates', 0) endif ! - endif - ! - if (nonhydrostatic) then + 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 (nh_tstop > 0.0) then + if (dtmaxout <= 0.0) then ! - ! tstopnonh is provided so set it with respect to model reference time + ! Are there more to be added here? ! - nh_tstop = t0 + nh_tstop + 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 ! - ! tstopnonh is not provided so set it to tstop time + 999.0 s + subgrid = .false. ! - nh_tstop = t1 + 999.0 - ! - endif + endif ! - endif - ! - if (bathtub) 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. ! - call write_log('Info : turning on process: Bathtub flooding', 0) + if (.not. subgrid) store_zvolume = .false. ! - ! Set time step + thetasmoothing = .false. + if (theta < 0.9999) thetasmoothing = .true. ! use 0.9999 instead of 1.0 for numerical robustness ! - if (bathtub_dt < 0.0) then + wavemaker = .false. + wavemaker_spectrum = .true. + ! + if (wavemaker_wvmfile(1:4) /= 'none') then ! - ! Time step for simulation not defined so use same as map output + wavemaker = .true. ! - bathtub_dt = dtmapout + if (wmsigstr(1:3) == 'mon') then + ! + wavemaker_spectrum = .false. + ! + call write_log('Info : use monochromatic wave spectrum for wave makers', 0) + ! + endif ! endif ! - dthisout = bathtub_dt + 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 ! - ! Turn off some processes not needed for bathtub flooding + if (advection) then + ! + ! Default scheme is 1st-order upwind; 'original' keeps the legacy form. + ! + advection_scheme = 1 + ! + 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 + ! + endif ! - nsrc = 0 - ndrn = 0 + if (nonhydrostatic) then + ! + if (nh_tstop > 0.0) then + nh_tstop = t0 + nh_tstop + else + nh_tstop = t1 + 999.0 + endif + ! + endif ! - meteo3d = .false. - wind = .false. - store_meteo = .false. - store_wind = .false. - store_wind_max = .false. - precip = .false. - patmos = .false. - if (snapwave) then - bathtub_snapwave = .true. + 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 - snapwave = .false. - infiltration = .false. - store_velocity = .false. - store_maximum_velocity = .false. ! - endif - ! - ! normbnd = sqrt(dzdsbnd) / manningbnd - ! end subroutine - - - - subroutine read_real_input(fileid,keyword,value,default) - ! - character(*), intent(in) :: keyword - character(len=256) :: keystr - character(len=256) :: valstr - character(len=256) :: line - integer, intent(in) :: fileid - real*4, intent(out) :: value - real*4, intent(in) :: default - integer j,stat,ilen - ! - value = default ! - rewind(fileid) + !-----------------------------------------------------------------------------------------------------! ! - do while(.true.) + subroutine get_keyword_real(fileid, keyword, value, default, legacy) ! - read(fileid,'(a)',iostat = stat)line + ! 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. ! - if (stat==-1) exit + ! Called from: read_sfincs_input (this module). ! - call read_line(line, keystr, valstr) + implicit none ! - if (trim(keystr)==trim(keyword)) then - ! - read(valstr,*)value + 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 + ! + 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 ! - exit + 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 ! - enddo - ! - end subroutine - - subroutine read_real_array_input(fileid,keyword,value,default,nr) - ! - character(*), intent(in) :: keyword - character(len=256) :: keystr - character(len=256) :: valstr - character(len=256) :: line - integer, intent(in) :: fileid - integer, intent(in) :: nr - real*4, dimension(:), intent(out), allocatable :: value - real*4, intent(in) :: default - integer j,stat, m,ilen - ! - allocate(value(nr)) - ! - value = default + value = default + ! + end subroutine ! - rewind(fileid) + !-----------------------------------------------------------------------------------------------------! ! - do while(.true.) + subroutine get_keyword_int(fileid, keyword, value, default, legacy) ! - read(fileid,'(a)',iostat = stat)line + ! Read one integer keyword. See get_keyword_real for the semantics. ! - if (stat==-1) exit + ! Called from: read_sfincs_input (this module). ! - call read_line(line, keystr, valstr) + implicit none ! - if (trim(keystr)==trim(keyword)) then - ! - read(valstr,*)(value(m), m = 1, nr) + 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 ! - exit + 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 ! - enddo - ! - end subroutine - - - subroutine read_int_input(fileid,keyword,value,default) - ! - character(*), intent(in) :: keyword - character(len=256) :: keystr - character(len=256) :: valstr - character(len=256) :: line - integer, intent(in) :: fileid - integer, intent(out) :: value - integer, intent(in) :: default - integer j,stat,ilen - ! - value = default + value = default + ! + end subroutine ! - rewind(fileid) + !-----------------------------------------------------------------------------------------------------! ! - do while(.true.) + subroutine get_keyword_char(fileid, keyword, value, default, legacy) ! - read(fileid,'(a)',iostat = stat)line + ! Read one character-string keyword. See get_keyword_real for the + ! semantics. The entire right-hand side (after trailing comments + ! are stripped) becomes `value`. ! - if (stat==-1) exit + ! Called from: read_sfincs_input (this module). ! - call read_line(line, keystr, valstr) + implicit none ! - if (trim(keystr)==trim(keyword)) then - ! - read(valstr,*)value + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + character(*), intent(out) :: value + character(*), 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 = valstr + return + endif + ! + if (present(legacy)) then ! - exit + 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 ! - enddo - ! + value = default + ! end subroutine - - - subroutine read_char_input(fileid,keyword,value,default) ! - character(*), intent(in) :: keyword - character(len=256) :: keystr0 - character(len=256) :: keystr - character(len=256) :: valstr - character(len=256) :: line - integer, intent(in) :: fileid - character(*), intent(in) :: default - character(*), intent(out) :: value - integer j,stat,ilen,jn + !-----------------------------------------------------------------------------------------------------! ! - value = default - ! - rewind(fileid) - ! - do while(.true.) + subroutine get_keyword_logical(fileid, keyword, value, default, legacy) ! - read(fileid,'(a)',iostat = stat)line + ! 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. ! - if (stat==-1) exit + ! Called from: read_sfincs_input (this module). ! - call read_line(line, keystr, valstr) + implicit none ! - if (trim(keystr)==trim(keyword)) then - ! - value = valstr + 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 ! - exit + 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 ! - enddo - ! - end subroutine - - - subroutine read_logical_input(fileid,keyword,value,default) - ! - character(*), intent(in) :: keyword - character(len=256) :: keystr0 - character(len=256) :: keystr - character(len=256) :: valstr - character(len=256) :: line - integer, intent(in) :: fileid - logical, intent(in) :: default - logical, intent(out) :: value - integer j,stat,ilen - ! - value = default + value = default + ! + end subroutine ! - rewind(fileid) + !-----------------------------------------------------------------------------------------------------! ! - do while(.true.) + subroutine get_keyword_real_array(fileid, keyword, value, default, nr, legacy) ! - read(fileid,'(a)',iostat = stat)line + ! 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. ! - if (stat==-1) exit + ! Called from: read_sfincs_input (this module). ! - call read_line(line, keystr, valstr) + implicit none ! - if (trim(keystr)==trim(keyword)) then - ! - if (valstr(1:1) == '1' .or. valstr(1:1) == 'y' .or. valstr(1:1) == 'Y' .or. valstr(1:1) == 't' .or. valstr(1:1) == 'T') then - value = .true. - else - value = .false. - endif + 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 ! - exit + 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 ! - enddo - ! - end subroutine - - subroutine read_line(line0, keystr, valstr) - ! - ! Reads line from input file, returns keyword and value strings - ! - character(*), intent(in) :: line0 - character(len=256) :: line - character(*), intent(out) :: keystr - character(*), intent(out) :: valstr - integer j, ilen, jn - ! - keystr = '' - valstr = '' - ! - ! Change tabs into spaces. - ! - call notabs(line0, line, ilen) - ! - ! Look for line ending character. Remove it if it exists. + value = default + ! + end subroutine ! - jn = index(line, '\r') + !-----------------------------------------------------------------------------------------------------! ! - if (jn > 0) then + subroutine find_value(fileid, keyword, valstr, found) ! - ! New line character detected (probably sfincs.inp with windows line endings, running in linux) + ! 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. ! - line = line(1 : jn - 1) - ! - endif - ! - ! Remove leading and trailing spaces. - ! - line = trim(line) - ! - if (line(1:1) == '#' .or. line(1:1) == '!' .or. line(1:1) == '@') return - ! - ! Find "=" - ! - j = index(line, '=') - ! - if (j == 0) return - ! - keystr = trim(line(1:j-1)) - ! - valstr = trim(line(j+1:)) - ! - ! Remove comments + ! 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 ! - jn = index(valstr, '#') + !-----------------------------------------------------------------------------------------------------! ! - if (jn > 0) then + 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 ! - valstr = trim(valstr(1 : jn - 1)) - ! - endif + 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 ! - valstr = adjustl(trim(valstr)) + !-----------------------------------------------------------------------------------------------------! ! - end subroutine - - - subroutine notabs(INSTR,OUTSTR,ILEN) - ! @(#) convert tabs in input to spaces in output while maintaining columns, assuming a tab is set every 8 characters + 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 ! - ! USES: - ! It is often useful to expand tabs in input files to simplify further processing such as tokenizing an input line. - ! Some FORTRAN compilers hate tabs in input files; some printers; some editors will have problems with tabs - ! AUTHOR: - ! John S. Urban + !-----------------------------------------------------------------------------------------------------! ! - ! SEE ALSO: - ! GNU/Unix commands expand(1) and unexpand(1) + 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 ! - use ISO_FORTRAN_ENV, only : ERROR_UNIT ! get unit for standard error. if not supported yet, define ERROR_UNIT for your system (typically 0) - character(len=*),intent(in) :: INSTR ! input line to scan for tab characters - character(len=*),intent(out) :: OUTSTR ! tab-expanded version of INSTR produced - integer,intent(out) :: ILEN ! column position of last character put into output string - - integer,parameter :: TABSIZE=8 ! assume a tab stop is set every 8th column - character(len=1) :: c ! character read from stdin - integer :: ipos ! position in OUTSTR to put next character of INSTR - integer :: lenin ! length of input string trimmed of trailing spaces - integer :: lenout ! number of characters output string can hold - integer :: i10 ! counter that advances thru input string INSTR one character at a time - ! - IPOS=1 ! where to put next character in output string OUTSTR - lenin=len(INSTR) ! length of character variable INSTR - lenin=len_trim(INSTR(1:lenin)) ! length of INSTR trimmed of trailing spaces - lenout=len(OUTSTR) ! number of characters output string OUTSTR can hold - OUTSTR=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters + !-----------------------------------------------------------------------------------------------------! ! - do i10=1,lenin ! look through input string one character at a time - c=INSTR(i10:i10) - if(ichar(c) == 9)then ! test if character is a tab (ADE (ASCII Decimal Equivalent) of tab character is 9) - IPOS = IPOS + (TABSIZE - (mod(IPOS-1,TABSIZE))) - else ! c is anything else other than a tab insert it in output string - if(IPOS > lenout)then - write(ERROR_UNIT,*)"*notabs* output string overflow" - exit + 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 - OUTSTR(IPOS:IPOS)=c - IPOS=IPOS+1 + ! + if (ipos > lenout) then + write(error_unit, *) '*notabs* output string overflow' + exit + else + outstr(ipos:ipos) = c + ipos = ipos + 1 + endif + ! endif - endif - enddo - ! - ILEN=len_trim(OUTSTR(:IPOS)) ! trim trailing spaces - return + ! + enddo + ! + ilen = len_trim(outstr(:ipos)) + ! + end subroutine ! - end subroutine notabs - - end module diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index ca3441bf4..9b4449d0e 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.3.2 mt. Faber+branch:318" - build_date = "$Date: 2025-04-13" + build_revision = "$Rev: v2.3.2 Mount Faber + branch-redo-infiltration + urban_drainage + discharges + timers + screendump" + build_date = "$Date: 2026-04-19" ! - 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 b71e504eb..0d99d11f6 100644 --- a/source/src/sfincs_meteo.f90 +++ b/source/src/sfincs_meteo.f90 @@ -1226,19 +1226,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 @@ -1248,7 +1243,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 ! @@ -1261,7 +1256,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 @@ -1337,40 +1332,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 @@ -1415,13 +1408,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 @@ -1520,12 +1534,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 @@ -1541,25 +1554,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 ! @@ -1601,9 +1609,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 4e19f72fa..4f713056f 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 ! @@ -734,6 +729,7 @@ subroutine compute_fluxes(dt, tloop) ! timestep_analysis_required_timestep(ip) = min_dt_ip ! + endif ! else @@ -774,10 +770,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 fa49e9b46..7591b8d63 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 e3a1895e1..ccba6dbeb 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 @@ -41,14 +42,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 @@ -214,12 +218,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 @@ -370,14 +378,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 ! @@ -403,14 +422,24 @@ 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')) - NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'cell_methods', 'time: sum')) + 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')) + NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'cell_methods', 'time: sum')) 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 @@ -825,9 +854,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 ! @@ -843,13 +872,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 @@ -1025,12 +1070,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', '-')) ! - 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 ! @@ -1229,10 +1291,21 @@ 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')) + 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 ! @@ -1407,12 +1480,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 @@ -1484,22 +1561,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 @@ -1577,7 +1662,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 @@ -1585,20 +1670,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 away intermediate data ! NF90(nf90_sync(map_file%ncid)) !write away intermediate data @@ -1612,13 +1714,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 @@ -1626,9 +1731,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 ! - 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 + 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. 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 ! @@ -1648,11 +1757,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 (nrstructures>0) then + 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 (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 ! @@ -1692,9 +1809,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 @@ -1857,9 +1986,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 ! @@ -2043,15 +2192,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 ! @@ -2091,7 +2274,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 ! @@ -2198,20 +2436,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 ! @@ -2361,13 +2603,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 @@ -2648,8 +2907,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 ! @@ -2999,14 +3284,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 @@ -3032,7 +3320,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 @@ -3058,7 +3345,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 @@ -3111,10 +3397,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 ! @@ -3199,9 +3487,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 ! @@ -3296,19 +3582,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 @@ -3330,9 +3629,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 ! @@ -3454,7 +3754,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 ! @@ -3527,11 +3850,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 @@ -3655,9 +3979,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 @@ -3733,13 +4080,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 ! @@ -3751,9 +4099,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)) ! @@ -3891,14 +4239,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)) ! @@ -3911,6 +4263,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_opt, baldock_ratio, & @@ -4046,13 +4400,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)) ! @@ -4070,20 +4429,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 857260203..b1c936e91 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,14 +32,29 @@ 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_status, src_struc_fraction_open, src_struc_t_state, & + !$acc src_struc_interruptible, & + !$acc src_struc_rule_open, src_struc_rule_close, & + !$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 structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & !$acc tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & - !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & + !$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, netprcp, prcp, qext, & !$acc dxminv, dxrinv, dyrinv, dxm2inv, dxr2inv, dyr2inv, dxrinvc, dyrinvc, dxm, dxrm, dyrm, cell_area_m2, cell_area, & !$acc gn2uv, fcorio2d, storage_volume, nuvisc, & !$acc cuv_index_uv, cuv_index_uv1, cuv_index_uv2, & @@ -36,7 +62,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 ! @@ -51,14 +83,29 @@ 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_status, src_struc_fraction_open, src_struc_t_state, & + !$acc src_struc_interruptible, & + !$acc src_struc_rule_open, src_struc_rule_close, & + !$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 structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & !$acc tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & - !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & + !$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, & @@ -66,8 +113,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 f130bdd29..e1a8a8c3d 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 ! @@ -246,7 +243,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 ! @@ -260,12 +257,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 ! @@ -273,17 +269,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 ! @@ -294,7 +289,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 ! @@ -575,6 +570,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 ! @@ -588,7 +585,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 @@ -602,6 +603,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 ! @@ -653,10 +656,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 81d5015e0..a0178a5a2 100644 --- a/source/src/sfincs_snapwave.f90 +++ b/source/src/sfincs_snapwave.f90 @@ -285,35 +285,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)) @@ -512,8 +511,12 @@ subroutine update_wave_field(t, tloop) ! !$acc update device(fwuv) ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + call timer_stop('SnapWave') + ! + 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) ! end subroutine diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 new file mode 100644 index 000000000..be37ba366 --- /dev/null +++ b/source/src/sfincs_src_structures.f90 @@ -0,0 +1,2602 @@ +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 statuses from the initial zs. + ! Called from sfincs_lib at init time. + ! + ! update_src_structures(t, dt) + ! Advances the open/close state machine for rule-driven structures, + ! 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, 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 + ! + ! Derived type for the TOML-based src structure input. + ! + ! Gate open/close triggers are described by small boolean expressions + ! in strings (e.g. "(z1<0.5 | z2-z1>0.05) & z2<1.5"). Those strings + ! live here as raw characters on the derived type; the parser runs + ! during marshalling and emits 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 + ! + ! Gate control rule expressions (raw strings; parsed by marshal). + ! Either or both may be unallocated, meaning "no trigger for this action". + ! + character(len=:), allocatable :: rule_open + character(len=:), allocatable :: rule_close + ! + ! interruptible - when .true., an in-progress opening transition can be + ! reversed by the close rule mid-ramp (and a closing transition by the + ! open rule). When .false. (default), a transition always runs to + ! completion before the opposite rule is re-checked. + ! + logical :: interruptible + ! + 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 + integer*1, dimension(:), allocatable, public :: src_struc_status + 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) + ! + ! Gate transition timer (simulation time at which current status was entered). + ! Only meaningful for structure_gate; ignored for other types. + ! + real*4, dimension(:), allocatable, public :: src_struc_t_state + ! + ! Interruptible-transition flag. 1 = an opening/closing ramp can be reversed + ! mid-way by the opposite rule; 0 = the ramp runs to completion before rules + ! are re-checked. Only meaningful for rule-driven structures. + ! + integer*1, dimension(:), allocatable, public :: src_struc_interruptible + ! + ! 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 + ! + ! Per-structure rule ids into the registry owned by sfincs_rule_expression. + ! A rule_id of 0 means "no rule; never fires". + ! + ! src_struc_rule_open_src / src_struc_rule_close_src hold the raw source strings + ! (for log emission only); these do not need to travel to GPU. + ! + integer, dimension(:), allocatable, public :: src_struc_rule_open ! (nr_src_structures) rule_id for open action, 0 = no rule + integer, dimension(:), allocatable, public :: src_struc_rule_close ! (nr_src_structures) rule_id for close action, 0 = no rule + ! + integer, parameter :: src_struc_rule_src_len = 256 + character(len=src_struc_rule_src_len), dimension(:), allocatable, public :: src_struc_rule_open_src + character(len=src_struc_rule_src_len), dimension(:), allocatable, public :: src_struc_rule_close_src + ! +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, ierr_parse + 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-status seeding locals + ! + integer :: nm_o1, nm_o2 + real :: zs_o1, zs_o2 + logical :: open_fires, close_fires + 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_status(nr_src_structures)) + allocate(src_struc_fraction_open(nr_src_structures)) + allocate(src_struc_t_state(nr_src_structures)) + allocate(src_struc_interruptible(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)) + allocate(src_struc_rule_open(nr_src_structures)) + allocate(src_struc_rule_close(nr_src_structures)) + allocate(src_struc_rule_open_src(nr_src_structures)) + allocate(src_struc_rule_close_src(nr_src_structures)) + ! + src_struc_rule_open = 0 + src_struc_rule_close = 0 + src_struc_rule_open_src = ' ' + src_struc_rule_close_src = ' ' + ! + 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 bypass the state machine and use this as a no-op multiplier in the common-tail scaling + src_struc_status = 1 ! 0=closed, 1=open, 2=opening, 3=closing; default open (see above). Rule-driven structures overwrite this in the init-time seeding below. + src_struc_t_state = 0.0 + src_struc_interruptible = 0 ! default: transitions run to completion (not reversible mid-ramp) + 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 + ! + ! Copy scalar / coord / string / parameter fields from src_structures(:) + ! into the flat arrays, and parse rule source strings via add_rule. + ! + 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_status is runtime-only (not on the TOML type); leave it at + ! the default of 0 (closed) set above. + ! + 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 + ! + if (src_structures(i)%interruptible) then + src_struc_interruptible(i) = 1 + else + src_struc_interruptible(i) = 0 + endif + 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 + ! + ! Parse rule expressions. Missing / empty strings leave the + ! rule_id at 0, which the evaluator interprets as "never fires". + ! Stash the source string for the init-time log summary. + ! + if (allocated(src_structures(i)%rule_open)) then + ! + call add_rule(src_structures(i)%rule_open, & + src_struc_rule_open(i), ierr_parse, errmsg) + ! + if (ierr_parse /= 0) then + ! + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & + '" rules_open parse failed: ', trim(errmsg) + call write_log(logstr, 1) + call stop_sfincs(trim(logstr), -1) + ! + endif + ! + src_struc_rule_open_src(i) = src_structures(i)%rule_open + ! + endif + ! + if (allocated(src_structures(i)%rule_close)) then + ! + call add_rule(src_structures(i)%rule_close, & + src_struc_rule_close(i), ierr_parse, errmsg) + ! + if (ierr_parse /= 0) then + ! + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & + '" rules_close parse failed: ', trim(errmsg) + call write_log(logstr, 1) + call stop_sfincs(trim(logstr), -1) + ! + endif + ! + src_struc_rule_close_src(i) = src_structures(i)%rule_close + ! + 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-status seeding so the per-gate init status + ! lines trail the structure block they annotate. + ! + call write_src_structures_log_summary() + ! + ! Initial-status 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. For structures with no rule expressions the defaults + ! assigned above (status=1=open, fraction_open=1.0) already encode "no-op": + ! the state machine is skipped at runtime and the common-tail scaling by + ! fraction_open is a 1.0 multiply. + ! + ! Status encoding: 0=closed, 1=open, 2=opening, 3=closing. + ! + do istruc = 1, nr_src_structures + ! + ! Skip structures without rules - keep the "always open" defaults. + ! + if (src_struc_rule_open(istruc) <= 0 .and. src_struc_rule_close(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 + ! + open_fires = evaluate_rule(src_struc_rule_open(istruc), zs_o1, zs_o2) + close_fires = evaluate_rule(src_struc_rule_close(istruc), zs_o1, zs_o2) + ! + if (open_fires .and. .not. close_fires) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + status_str = 'open' + ! + elseif (.not. open_fires .and. close_fires) then + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + elseif (open_fires .and. close_fires) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + status_str = 'open' + write(logstr,'(a,a,a,a)')'Warning ! structure ', trim(src_struc_name(istruc)), & + ': both open and close rules fire at init; keeping structure open' + call write_log(logstr, 0) + ! + else + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + endif + ! + ! Transition timer is only consulted after a transition triggers; + ! seed with t0 so the first rule-driven transition has a sane baseline. + ! + src_struc_t_state(istruc) = t0 + ! + write(logstr,'(a,a,a,a)')'structure ', trim(src_struc_name(istruc)), & + ' initialised status=', 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 + real*4 :: qq, elapsed, zs_o1, zs_o2 + real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha + real*4 :: dh, a_eff + real*4 :: h_up, h_dn, qq_sign + logical :: open_fires, close_fires + ! + 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_status, src_struc_fraction_open, & + !$acc src_struc_t_state, src_struc_interruptible, & + !$acc src_struc_rule_open, src_struc_rule_close, & + !$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, elapsed, & + !$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 open_fires, close_fires, & + !$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, elapsed, & + !$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 open_fires, close_fires, & + !$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 + ! + ! Open/close rule state machine (any structure type, any status). + ! + ! Only runs if the user provided at least one of rules_open / + ! rules_close. Structures without rules stay at the init-time + ! defaults (status=1=open, fraction_open=1.0), which turns the + ! common-tail scaling below into a no-op. + ! + ! Status codes: 0=closed, 1=open, 2=opening, 3=closing. + ! Transient states 2 and 3 advance purely on elapsed time so the + ! state machine cannot thrash; rule evaluation happens in the + ! terminal states 0 and 1 only. Obs points feed the rule inputs + ! and default to the src pair in the marshal. + ! + if (src_struc_rule_open(istruc) > 0 .or. src_struc_rule_close(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 + ! + select case (int(src_struc_status(istruc))) + ! + case (0) + ! + ! closed - look for an open trigger + ! + open_fires = evaluate_rule(src_struc_rule_open(istruc), zs_o1, zs_o2) + ! + if (open_fires) then + ! + src_struc_status(istruc) = 2 + src_struc_t_state(istruc) = real(t, 4) + ! + endif + ! + case (1) + ! + ! open - look for a close trigger + ! + close_fires = evaluate_rule(src_struc_rule_close(istruc), zs_o1, zs_o2) + ! + if (close_fires) then + ! + src_struc_status(istruc) = 3 + src_struc_t_state(istruc) = real(t, 4) + ! + endif + ! + case (2) + ! + ! opening - advance on elapsed time. If interruptible and + ! the close rule fires, reverse into closing, resuming the + ! ramp from the current fraction_open so there is no jump. + ! + close_fires = .false. + ! + if (src_struc_interruptible(istruc) == 1 .and. src_struc_rule_close(istruc) > 0) then + ! + close_fires = evaluate_rule(src_struc_rule_close(istruc), zs_o1, zs_o2) + ! + endif + ! + if (close_fires) then + ! + ! Re-seed t_state so closing continues from the current + ! fraction f: in closing, f = 1 - elapsed/closing_duration, + ! so elapsed = (1 - f) * closing_duration. + ! + if (src_struc_closing_duration(istruc) > 0.0) then + ! + src_struc_t_state(istruc) = real(t, 4) - & + (1.0 - src_struc_fraction_open(istruc)) * src_struc_closing_duration(istruc) + ! + else + ! + src_struc_t_state(istruc) = real(t, 4) + ! + endif + ! + src_struc_status(istruc) = 3 + ! + else + ! + elapsed = real(t, 4) - src_struc_t_state(istruc) + ! + if (src_struc_opening_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_opening_duration(istruc)) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + ! + else + ! + src_struc_fraction_open(istruc) = elapsed / src_struc_opening_duration(istruc) + ! + endif + ! + endif + ! + case (3) + ! + ! closing - advance on elapsed time. If interruptible and + ! the open rule fires, reverse into opening, resuming the + ! ramp from the current fraction_open so there is no jump. + ! + open_fires = .false. + ! + if (src_struc_interruptible(istruc) == 1 .and. src_struc_rule_open(istruc) > 0) then + ! + open_fires = evaluate_rule(src_struc_rule_open(istruc), zs_o1, zs_o2) + ! + endif + ! + if (open_fires) then + ! + ! Re-seed t_state so opening continues from the current + ! fraction f: in opening, f = elapsed/opening_duration, + ! so elapsed = f * opening_duration. + ! + if (src_struc_opening_duration(istruc) > 0.0) then + ! + src_struc_t_state(istruc) = real(t, 4) - & + src_struc_fraction_open(istruc) * src_struc_opening_duration(istruc) + ! + else + ! + src_struc_t_state(istruc) = real(t, 4) + ! + endif + ! + src_struc_status(istruc) = 2 + ! + else + ! + elapsed = real(t, 4) - src_struc_t_state(istruc) + ! + if (src_struc_closing_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_closing_duration(istruc)) then + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + ! + else + ! + src_struc_fraction_open(istruc) = 1.0 - elapsed / src_struc_closing_duration(istruc) + ! + endif + ! + endif + ! + end select + ! + 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 (-) + ! rules_open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr + ! rules_close = "z2>2.0" ! optional trigger expr + ! interruptible = true ! optional, default false: + ! ! allow an in-progress opening/closing ramp to be + ! ! reversed mid-way by the opposite rule (resumes + ! ! from the current fraction; no jump). + ! + ! 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 + character(len=:), allocatable :: name_str, type_str, rule_str, dir_str, type_str_lc + integer :: n_struct, i, 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 rules_open / rules_close string expressions. Absent keys + ! leave the rule strings unallocated on the derived type; marshal + ! treats that as "no trigger". + ! + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_struct, 'rules_open', rule_str, stat=stat) + if (allocated(rule_str)) structures(i)%rule_open = rule_str + ! + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_struct, 'rules_close', rule_str, stat=stat) + if (allocated(rule_str)) structures(i)%rule_close = rule_str + ! + ! Optional: allow an in-progress transition to be reversed mid-ramp by + ! the opposite rule. Default false (transitions run to completion). + ! + call get_value(tbl_struct, 'interruptible', structures(i)%interruptible, .false., stat=stat) + ! + 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 + ! + !-----------------------------------------------------------------------------------------------------! + ! + 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 + character(len=32) :: type_str, dir_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_open(i) > 0) then + ! + if (len_trim(src_struc_rule_open_src(i)) > 0) then + ! + write(logstr,'(a22,1x,a,a,a)') ' rules_open :', '"', trim(src_struc_rule_open_src(i)), '"' + ! + else + ! + write(logstr,'(a22,1x,a)') ' rules_open :', '(set)' + ! + endif + ! + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_rule_close(i) > 0) then + ! + if (len_trim(src_struc_rule_close_src(i)) > 0) then + ! + write(logstr,'(a22,1x,a,a,a)') ' rules_close :', '"', trim(src_struc_rule_close_src(i)), '"' + ! + else + ! + write(logstr,'(a22,1x,a)') ' rules_close :', '(set)' + ! + endif + ! + call write_log(logstr, 0) + ! + endif + ! + ! Interruptible flag, only meaningful (and only printed) for rule-driven + ! structures. + ! + if (src_struc_rule_open(i) > 0 .or. src_struc_rule_close(i) > 0) then + ! + if (src_struc_interruptible(i) == 1) then + ! + write(logstr,'(a22,1x,a)') ' interruptible :', 'true' + ! + else + ! + write(logstr,'(a22,1x,a)') ' interruptible :', 'false' + ! + endif + ! + call write_log(logstr, 0) + ! + 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_open(i) > 0 .or. src_struc_rule_close(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,a,a)') 'rules_open = "', trim(rule_open_str), '"' + write(u_out,'(a,a,a)') 'rules_close = "', 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 4595f0096..65ffc3c86 100644 --- a/source/src/sfincs_wavemaker.f90 +++ b/source/src/sfincs_wavemaker.f90 @@ -1343,12 +1343,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 ! @@ -1360,17 +1361,11 @@ 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 - ! real*4, dimension(:), allocatable :: wavemaker_forcing_hm0_ig_t real*4, dimension(:), allocatable :: wavemaker_forcing_tp_ig_t - real*4, dimension(:), allocatable :: wavemaker_forcing_setup_t + real*4, dimension(:), allocatable :: wavemaker_forcing_setup_t ! - call system_clock(count0, count_rate, count_max) + call timer_start('wavemaker') ! ! Factors for double-exponential filtering ! @@ -1687,9 +1682,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 53cc31d77..d310014a8 100644 --- a/source/src/snapwave/snapwave_solver.f90 +++ b/source/src/snapwave/snapwave_solver.f90 @@ -1351,7 +1351,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/utils/toml-f/LICENSE-Apache b/source/third_party_open/utils/toml-f/LICENSE-Apache new file mode 100644 index 000000000..d64569567 --- /dev/null +++ b/source/third_party_open/utils/toml-f/LICENSE-Apache @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/source/third_party_open/utils/toml-f/LICENSE-MIT b/source/third_party_open/utils/toml-f/LICENSE-MIT new file mode 100644 index 000000000..9131f1306 --- /dev/null +++ b/source/third_party_open/utils/toml-f/LICENSE-MIT @@ -0,0 +1,7 @@ +Copyright 2019-2021 Sebastian Ehlert + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/source/third_party_open/utils/toml-f/src/tomlf.f90 b/source/third_party_open/utils/toml-f/src/tomlf.f90 new file mode 100644 index 000000000..305422c75 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf.f90 @@ -0,0 +1,65 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Public API for TOML Fortran +!> +!> This module provides the main entry point to the TOML Fortran library. +!> It re-exports all public types and procedures needed for parsing, manipulating, +!> and serializing TOML documents. +!> +!> ## Parsing TOML +!> +!> Use [[toml_load]] to load a TOML document from a file or unit, or [[toml_loads]] +!> to parse a TOML string directly: +!> +!>```fortran +!> type(toml_table), allocatable :: table +!> call toml_load(table, "config.toml") +!>``` +!> +!> ## Accessing Values +!> +!> Use [[get_value]] to retrieve values from tables and arrays, and [[set_value]] +!> to modify or create new values: +!> +!>```fortran +!> character(len=:), allocatable :: name +!> call get_value(table, "name", name) +!>``` +!> +!> ## Serialization +!> +!> Use [[toml_dump]] to write a table to a file or [[toml_dumps]] to serialize +!> to a string: +!> +!>```fortran +!> character(len=:), allocatable :: output +!> call toml_dumps(table, output) +!>``` +module tomlf + use tomlf_build, only : get_value, set_value, toml_path + use tomlf_datetime, only : toml_datetime, to_string + use tomlf_de, only : toml_parse, toml_load, toml_loads, & + & toml_context, toml_parser_config, toml_level + use tomlf_error, only : toml_error, toml_stat + use tomlf_ser, only : toml_serializer, toml_serialize, toml_dump, toml_dumps + use tomlf_terminal, only : toml_terminal + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_key, toml_value, & + & is_array_of_tables, new_table, add_table, add_array, add_keyval, len + use tomlf_utils_sort, only : sort + use tomlf_version, only : tomlf_version_string, tomlf_version_compact, & + & get_tomlf_version + implicit none + public + +end module tomlf diff --git a/source/third_party_open/utils/toml-f/src/tomlf/all.f90 b/source/third_party_open/utils/toml-f/src/tomlf/all.f90 new file mode 100644 index 000000000..867c32f05 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/all.f90 @@ -0,0 +1,29 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Complete reexport of the public API of TOML-Fortran +module tomlf_all + use tomlf_build + use tomlf_constants + use tomlf_datetime + use tomlf_de + use tomlf_error + use tomlf_ser + use tomlf_structure + use tomlf_type + use tomlf_utils + use tomlf_version + implicit none + public + +end module tomlf_all diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build.f90 new file mode 100644 index 000000000..e90b72ba9 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build.f90 @@ -0,0 +1,31 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build a TOML data structures +!> +!> The build module defines a high level interface to work with TOML data structures +!> and construct them in a convenient way. +module tomlf_build + use tomlf_build_array, only : get_value, set_value + use tomlf_build_keyval, only : get_value, set_value + use tomlf_build_merge, only : merge_table, merge_array, merge_policy, toml_merge_config + use tomlf_build_path, only : get_value, set_value, toml_path + use tomlf_build_table, only : get_value, set_value + implicit none + private + + public :: get_value, set_value + public :: merge_table, merge_array, merge_policy, toml_merge_config + public :: toml_path + +end module tomlf_build diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 new file mode 100644 index 000000000..e1151aec7 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 @@ -0,0 +1,1323 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build TOML arrays. +!> +!> This build module defines a high level interface to work with TOML arrays +!> and construct them in a convenient way. +!> +!> The access to the array elements happens by position in the array, the indexing +!> is one based, following the language convention of Fortran. All functions +!> will only allow access of elements within the bounds of the array, specifying +!> indices out-of-bounds should be save, as it only sets the status of operation. +!> The getter functions allow access to other tables and arrays as well as +!> convenient wrappers to retrieve value data +!> +!> The setter functions are somewhat weaker compared to the setter functions +!> available for TOML tables. To limit the potential havoc this routines can +!> cause they can only access the array within its bounds. Setting a value to +!> another value will overwrite it, while setting a value to a table or an array +!> will fail, for safety reasons. +!> +!> To (re)build an array appending to it is the best choice, tables and arrays +!> should always be create by using the corresponding `add_table` and `add_array` +!> function. While this can become cumbersome for values, the setter routines +!> allow out-of-bound access to for the next element in an array and will indeed +!> just append a new value to it. +module tomlf_build_array + use tomlf_build_keyval, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, & + & cast_to_table, cast_to_array, cast_to_keyval, initialized, len + implicit none + private + + public :: get_value, set_value + + + !> Setter functions to manipulate TOML arrays + interface set_value + module procedure :: set_elem_value_string + module procedure :: set_elem_value_float_sp + module procedure :: set_elem_value_float_dp + module procedure :: set_elem_value_int_i1 + module procedure :: set_elem_value_int_i2 + module procedure :: set_elem_value_int_i4 + module procedure :: set_elem_value_int_i8 + module procedure :: set_elem_value_bool + module procedure :: set_elem_value_datetime + module procedure :: set_array_value_float_sp + module procedure :: set_array_value_float_dp + module procedure :: set_array_value_int_i1 + module procedure :: set_array_value_int_i2 + module procedure :: set_array_value_int_i4 + module procedure :: set_array_value_int_i8 + module procedure :: set_array_value_bool + module procedure :: set_array_value_datetime + end interface set_value + + + !> Getter functions to manipulate TOML arrays + interface get_value + module procedure :: get_elem_table + module procedure :: get_elem_array + module procedure :: get_elem_keyval + module procedure :: get_elem_value_string + module procedure :: get_elem_value_float_sp + module procedure :: get_elem_value_float_dp + module procedure :: get_elem_value_int_i1 + module procedure :: get_elem_value_int_i2 + module procedure :: get_elem_value_int_i4 + module procedure :: get_elem_value_int_i8 + module procedure :: get_elem_value_bool + module procedure :: get_elem_value_datetime + module procedure :: get_array_value_float_sp + module procedure :: get_array_value_float_dp + module procedure :: get_array_value_int_i1 + module procedure :: get_array_value_int_i2 + module procedure :: get_array_value_int_i4 + module procedure :: get_array_value_int_i8 + module procedure :: get_array_value_bool + module procedure :: get_array_value_datetime + end interface get_value + + +contains + + +subroutine get_elem_table(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_table + + +subroutine get_elem_array(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_array(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_array + + +subroutine get_elem_keyval(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_keyval(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_keyval + + +!> Retrieve TOML value as deferred-length character +subroutine get_elem_value_string(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_string + + +!> Retrieve TOML value as single precision floating point number +subroutine get_elem_value_float_sp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_sp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_float_sp + + +!> Retrieve TOML value as double precision floating point number +subroutine get_elem_value_float_dp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_dp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_float_dp + + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i1(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i1 + + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i2(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i2 + + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i4(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i4 + + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i8(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i8 + + +!> Retrieve TOML value as boolean +subroutine get_elem_value_bool(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + logical, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_elem_value_datetime(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + type(toml_datetime), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine set_elem_value_string(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_string + + +!> Retrieve TOML value as single precision floating point number +subroutine set_elem_value_float_sp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_float_sp + + +!> Retrieve TOML value as double precision floating point number +subroutine set_elem_value_float_dp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_float_dp + + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i1(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i1 + + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i2(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i2 + + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i4(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i4 + + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i8(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i8 + + +!> Retrieve TOML value as boolean value +subroutine set_elem_value_bool(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_bool + + +!> Retrieve TOML value as datetime value +subroutine set_elem_value_datetime(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_datetime + + +!> Retrieve TOML value as single precision floating point number +subroutine get_array_value_float_sp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_sp), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_float_sp + + +!> Retrieve TOML value as double precision floating point number +subroutine get_array_value_float_dp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_dp), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_float_dp + + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i1(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i1), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i1 + + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i2(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i2), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i2 + + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i4(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i4), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i4 + + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i8(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i8), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i8 + + +!> Retrieve TOML value as boolean +subroutine get_array_value_bool(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + logical, allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_array_value_datetime(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + type(toml_datetime), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_datetime + + +!> Retrieve TOML value as single precision floating point number +subroutine set_array_value_float_sp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_sp), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_float_sp + + +!> Retrieve TOML value as double precision floating point number +subroutine set_array_value_float_dp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_dp), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_float_dp + + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i1(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i1), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i1 + + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i2(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i2), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i2 + + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i4(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i4), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i4 + + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i8(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i8), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i8 + + +!> Retrieve TOML value as boolean value +subroutine set_array_value_bool(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Boolean value + logical, intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_bool + + +!> Retrieve TOML value as datetime value +subroutine set_array_value_datetime(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Datetime value + type(toml_datetime), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_datetime + + +end module tomlf_build_array diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 new file mode 100644 index 000000000..165df7e35 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 @@ -0,0 +1,589 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build a TOML values +!> +!> The build module defines an interface to work with TOML values instead +!> of accessing the raw value directly. Both setter and getter routines defined +!> here are rarely needed in any user context, but serve as a basic building +!> block to define uniform access methods for TOML tables and arrays. +module tomlf_build_keyval + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp, TOML_NEWLINE + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, len + use tomlf_utils, only : toml_escape_string, to_string + implicit none + private + + public :: get_value, set_value + + + !> Setter functions to manipulate TOML values + interface set_value + module procedure :: set_value_float_sp + module procedure :: set_value_float_dp + module procedure :: set_value_integer_i1 + module procedure :: set_value_integer_i2 + module procedure :: set_value_integer_i4 + module procedure :: set_value_integer_i8 + module procedure :: set_value_bool + module procedure :: set_value_datetime + module procedure :: set_value_string + end interface set_value + + + !> Getter functions to manipulate TOML values + interface get_value + module procedure :: get_value_float_sp + module procedure :: get_value_float_dp + module procedure :: get_value_integer_i1 + module procedure :: get_value_integer_i2 + module procedure :: get_value_integer_i4 + module procedure :: get_value_integer_i8 + module procedure :: get_value_bool + module procedure :: get_value_datetime + module procedure :: get_value_string + end interface get_value + + + !> Length for the static character variables + integer, parameter :: buffersize = 128 + + +contains + + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_value_float_sp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Real value + real(tf_sp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + real(tfr), pointer :: dummy + integer(tfi), pointer :: idummy + + call self%get(dummy) + if (associated(dummy)) then + val = real(dummy, tf_sp) + info = toml_stat%success + else + call self%get(idummy) + if (associated(idummy)) then + val = real(idummy, tf_sp) + if (nint(val, tfi) == idummy) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_float_sp + + +!> Retrieve TOML value as double precision float +subroutine get_value_float_dp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Real value + real(tf_dp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + real(tfr), pointer :: dummy + integer(tfi), pointer :: idummy + + call self%get(dummy) + if (associated(dummy)) then + val = real(dummy, tf_dp) + info = toml_stat%success + else + call self%get(idummy) + if (associated(idummy)) then + val = real(idummy, tf_dp) + if (nint(val, tfi) == idummy) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_float_dp + + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_value_integer_i1(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i1) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i1 + + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_value_integer_i2(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i2) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i2 + + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_value_integer_i4(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i4) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i4 + + +!> Retrieve TOML value as eight byte integer +subroutine get_value_integer_i8(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i8) + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i8 + + +!> Retrieve TOML value as logical +subroutine get_value_bool(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Boolean value + logical, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + logical, pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_value_datetime(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + type(toml_datetime), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine get_value_string(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + character(:, tfc), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_string + + +!> Set TOML value to single precision float +subroutine set_value_float_sp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(real(val, tfr)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_float_sp + + +!> Set TOML value to double precision float +subroutine set_value_float_dp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(real(val, tfr)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_float_dp + + +!> Set TOML value to one byte integer +subroutine set_value_integer_i1(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i1 + + +!> Set TOML value to two byte integer +subroutine set_value_integer_i2(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i2 + + +!> Set TOML value to four byte integer +subroutine set_value_integer_i4(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i4 + + +!> Set TOML value to eight byte integer +subroutine set_value_integer_i8(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i8 + + +!> Set TOML value to logical +subroutine set_value_bool(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_bool + + +!> Set TOML value to datetime +subroutine set_value_datetime(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_datetime + + +!> Set TOML value to deferred-length character +subroutine set_value_string(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_string + + +end module tomlf_build_keyval diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 new file mode 100644 index 000000000..8c86fe53b --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 @@ -0,0 +1,1474 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build TOML tables +!> +!> The build module defines a high level interface to work with TOML tables +!> and construct them in a convenient way. +!> +!> The getter functions allow to both retrieve and set values, to easily +!> support default values when reading from a TOML data structure. +!> Using the getter function with a default value specified will request +!> the respective setter function to add it to the table if it was not +!> found in the first place. +!> +!> This allows to build a TOML table using only the getter functions, which +!> represents the finally read values for the applications. +!> +!> Note that neither setter nor getter functions can overwrite existing +!> TOML values for safety reasons, request the deletion on the respective +!> key from the TOML table and than set it. The deletion of a subtable or +!> array will recursively destroy the contained data nodes. +module tomlf_build_table + use tomlf_build_keyval, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, & + & toml_key, cast_to_table, cast_to_array, cast_to_keyval, initialized, & + & len + implicit none + private + + public :: get_value, set_value + + + !> Setter functions to manipulate TOML tables + interface set_value + module procedure :: set_child_value_float_sp + module procedure :: set_child_value_float_dp + module procedure :: set_child_value_integer_i1 + module procedure :: set_child_value_integer_i2 + module procedure :: set_child_value_integer_i4 + module procedure :: set_child_value_integer_i8 + module procedure :: set_child_value_bool + module procedure :: set_child_value_datetime + module procedure :: set_child_value_string + module procedure :: set_key_value_float_sp + module procedure :: set_key_value_float_dp + module procedure :: set_key_value_integer_i1 + module procedure :: set_key_value_integer_i2 + module procedure :: set_key_value_integer_i4 + module procedure :: set_key_value_integer_i8 + module procedure :: set_key_value_bool + module procedure :: set_key_value_datetime + module procedure :: set_key_value_string + end interface set_value + + + !> Getter functions to manipulate TOML tables + interface get_value + module procedure :: get_child_table + module procedure :: get_child_array + module procedure :: get_child_keyval + module procedure :: get_child_value_float_sp + module procedure :: get_child_value_float_dp + module procedure :: get_child_value_integer_i1 + module procedure :: get_child_value_integer_i2 + module procedure :: get_child_value_integer_i4 + module procedure :: get_child_value_integer_i8 + module procedure :: get_child_value_bool + module procedure :: get_child_value_datetime + module procedure :: get_child_value_string + module procedure :: get_key_table + module procedure :: get_key_array + module procedure :: get_key_keyval + module procedure :: get_key_value_float_sp + module procedure :: get_key_value_float_dp + module procedure :: get_key_value_integer_i1 + module procedure :: get_key_value_integer_i2 + module procedure :: get_key_value_integer_i4 + module procedure :: get_key_value_integer_i8 + module procedure :: get_key_value_bool + module procedure :: get_key_value_datetime + module procedure :: get_key_value_string + end interface get_value + + +contains + + +subroutine get_key_table(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_table + + +subroutine get_key_array(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_array + + +subroutine get_key_keyval(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_keyval + + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_key_value_float_sp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_float_sp + + +!> Retrieve TOML value as double precision float +subroutine get_key_value_float_dp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_float_dp + + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_key_value_integer_i1(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i1 + + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_key_value_integer_i2(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i2 + + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_key_value_integer_i4(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i4 + + +!> Retrieve TOML value as eight byte integer +subroutine get_key_value_integer_i8(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i8 + + +!> Retrieve TOML value as logical +subroutine get_key_value_bool(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_key_value_datetime(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine get_key_value_string(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_string + + +!> Set TOML value to single precision float +subroutine set_key_value_float_sp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_float_sp + + +!> Set TOML value to double precision float +subroutine set_key_value_float_dp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_float_dp + + +!> Set TOML value to one byte integer +subroutine set_key_value_integer_i1(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i1 + + +!> Set TOML value to two byte integer +subroutine set_key_value_integer_i2(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i2 + + +!> Set TOML value to four byte integer +subroutine set_key_value_integer_i4(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i4 + + +!> Set TOML value to eight byte integer +subroutine set_key_value_integer_i8(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i8 + + +!> Set TOML value to logical +subroutine set_key_value_bool(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_bool + + +!> Set TOML value to datetime +subroutine set_key_value_datetime(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_datetime + + +!> Set TOML value to deferred-length character +subroutine set_key_value_string(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_string + + +subroutine get_child_table(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_table(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_table + + +subroutine get_child_array(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_array(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_array(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_array + + +subroutine get_child_keyval(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_keyval(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_keyval(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_keyval + + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_child_value_float_sp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_float_sp + + +!> Retrieve TOML value as double precision float +subroutine get_child_value_float_dp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_float_dp + + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_child_value_integer_i1(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i1 + + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_child_value_integer_i2(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i2 + + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_child_value_integer_i4(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i4 + + +!> Retrieve TOML value as eight byte integer +subroutine get_child_value_integer_i8(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i8 + + +!> Retrieve TOML value as logical +subroutine get_child_value_bool(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_child_value_datetime(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine get_child_value_string(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_string + + +!> Set TOML value to single precision float +subroutine set_child_value_float_sp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_float_sp + + +!> Set TOML value to double precision float +subroutine set_child_value_float_dp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_float_dp + + +!> Set TOML value to one byte integer +subroutine set_child_value_integer_i1(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i1 + + +!> Set TOML value to two byte integer +subroutine set_child_value_integer_i2(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i2 + + +!> Set TOML value to four byte integer +subroutine set_child_value_integer_i4(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i4 + + +!> Set TOML value to eight byte integer +subroutine set_child_value_integer_i8(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i8 + + +!> Set TOML value to logical +subroutine set_child_value_bool(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_bool + + +!> Set TOML value to datetime +subroutine set_child_value_datetime(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_datetime + + +!> Set TOML value to deferred-length character +subroutine set_child_value_string(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_string + + +end module tomlf_build_table diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/merge.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/merge.f90 new file mode 100644 index 000000000..be8b63fd7 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/merge.f90 @@ -0,0 +1,214 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Merge TOML data structures, the merge policy can be adjusted. +!> +!> Note that the context information cannot be preserved. +module tomlf_build_merge + use tomlf_constants, only : tfc + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_value, & + & toml_key, cast_to_keyval, len + implicit none + private + + public :: merge_table, merge_array, merge_policy, toml_merge_config + + + !> Possible merge policies + type :: enum_policy + + !> Overwrite existing values + integer :: overwrite = 1 + + !> Preserve existing values + integer :: preserve = 2 + + !> Append to existing values + integer :: append = 3 + end type enum_policy + + !> Actual enumerator for merging data structures + type(enum_policy), parameter :: merge_policy = enum_policy() + + + !> Configuration for merging data structures + type :: toml_merge_config + + !> Policy for merging tables + integer :: table = merge_policy%append + + !> Policy for merging arrays + integer :: array = merge_policy%preserve + + !> Policy for merging values + integer :: keyval = merge_policy%preserve + end type toml_merge_config + + !> Constructor for merge configuration + interface toml_merge_config + module procedure :: new_merge_config + end interface toml_merge_config + + +contains + + +!> Create a new merge configuration +pure function new_merge_config(table, array, keyval) result(config) + + !> Policy for merging tables + character(*), intent(in), optional :: table + + !> Policy for merging arrays + character(*), intent(in), optional :: array + + !> Policy for merging values + character(*), intent(in), optional :: keyval + + !> Merge policy + type(toml_merge_config) :: config + + if (present(table)) call set_enum(config%table, table) + if (present(array)) call set_enum(config%array, array) + if (present(keyval)) call set_enum(config%keyval, keyval) + +contains + + pure subroutine set_enum(enum, str) + character(*), intent(in) :: str + integer, intent(inout) :: enum + + select case(str) + case("append") + enum = merge_policy%append + case("overwrite") + enum = merge_policy%overwrite + case("preserve") + enum = merge_policy%preserve + end select + end subroutine set_enum + +end function new_merge_config + + +!> Merge TOML tables by appending their values +recursive subroutine merge_table(lhs, rhs, config) + + !> Instance of table to merge into + class(toml_table), intent(inout) :: lhs + + !> Instance of table to be merged + class(toml_table), intent(inout) :: rhs + + !> Merge policy + type(toml_merge_config), intent(in), optional :: config + + type(toml_merge_config) :: policy + type(toml_key), allocatable :: list(:) + class(toml_value), pointer :: ptr1, ptr2 + class(toml_keyval), pointer :: kv + class(toml_value), allocatable :: tmp + logical :: has_key + integer :: i, n, stat + + policy = toml_merge_config() + if (present(config)) policy = config + + call rhs%get_keys(list) + n = size(list, 1) + + do i = 1, n + if (allocated(tmp)) deallocate(tmp) + call rhs%get(list(i)%key, ptr1) + has_key = lhs%has_key(list(i)%key) + select type(ptr1) + class is(toml_keyval) + if (has_key .and. policy%keyval == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + kv => cast_to_keyval(tmp) + kv%origin_value = 0 + kv%origin = 0 + call lhs%push_back(tmp, stat) + end if + + class is(toml_array) + if (has_key .and. policy%array == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (has_key .and. policy%array == merge_policy%append) then + call lhs%get(list(i)%key, ptr2) + select type(ptr2) + class is(toml_array) + call merge_array(ptr2, ptr1) + end select + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + tmp%origin = 0 + call lhs%push_back(tmp, stat) + end if + + class is(toml_table) + if (has_key .and. policy%table == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (has_key .and. policy%table == merge_policy%append) then + call lhs%get(list(i)%key, ptr2) + select type(ptr2) + class is(toml_table) + call merge_table(ptr2, ptr1, policy) + end select + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + tmp%origin = 0 + call lhs%push_back(tmp, stat) + end if + end select + end do + +end subroutine merge_table + + +!> Append values from one TOML array to another +recursive subroutine merge_array(lhs, rhs) + + !> Instance of array to merge into + class(toml_array), intent(inout) :: lhs + + !> Instance of array to be merged + class(toml_array), intent(inout) :: rhs + + class(toml_value), pointer :: ptr + class(toml_value), allocatable :: tmp + integer :: n, i, stat + + n = len(rhs) + + do i = 1, n + call rhs%get(i, ptr) + if (allocated(tmp)) deallocate(tmp) + allocate(tmp, source=ptr) + call lhs%push_back(tmp, stat) + end do + +end subroutine merge_array + + +end module tomlf_build_merge diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/path.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/path.f90 new file mode 100644 index 000000000..b9a9ee693 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/path.f90 @@ -0,0 +1,802 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Support for retrieving and setting values using a key path. +module tomlf_build_path + use tomlf_build_table, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_key + implicit none + private + + public :: toml_path, get_value, set_value + + + !> Setter functions to manipulate TOML tables + interface set_value + module procedure :: set_path_value_float_sp + module procedure :: set_path_value_float_dp + module procedure :: set_path_value_integer_i1 + module procedure :: set_path_value_integer_i2 + module procedure :: set_path_value_integer_i4 + module procedure :: set_path_value_integer_i8 + module procedure :: set_path_value_bool + module procedure :: set_path_value_datetime + module procedure :: set_path_value_string + end interface set_value + + + !> Getter functions to manipulate TOML tables + interface get_value + module procedure :: get_path_table + module procedure :: get_path_array + module procedure :: get_path_keyval + module procedure :: get_path_value_float_sp + module procedure :: get_path_value_float_dp + module procedure :: get_path_value_integer_i1 + module procedure :: get_path_value_integer_i2 + module procedure :: get_path_value_integer_i4 + module procedure :: get_path_value_integer_i8 + module procedure :: get_path_value_bool + module procedure :: get_path_value_datetime + module procedure :: get_path_value_string + end interface get_value + + + !> Wrapper for storing key paths + type :: toml_path + !> Path components + type(toml_key), allocatable :: path(:) + end type toml_path + + + !> Convenience constructors for building key paths from strings instead of keys + interface toml_path + module procedure :: new_path2 + module procedure :: new_path3 + module procedure :: new_path4 + end interface toml_path + + +contains + + +!> Create a new path with two components +pure function new_path2(key1, key2) result(path) + + !> First key to retrieve + character(*), intent(in) :: key1 + + !> Second key to retrieve + character(*), intent(in) :: key2 + + !> New path + type(toml_path) :: path + + allocate(path%path(2)) + path%path(:) = [toml_key(key1), toml_key(key2)] +end function new_path2 + + +!> Create a new path with three components +pure function new_path3(key1, key2, key3) result(path) + + !> First key to retrieve + character(*, tfc), intent(in) :: key1 + + !> Second key to retrieve + character(*, tfc), intent(in) :: key2 + + !> Third key to retrieve + character(*, tfc), intent(in) :: key3 + + !> New path + type(toml_path) :: path + + allocate(path%path(3)) + path%path(:) = [toml_key(key1), toml_key(key2), toml_key(key3)] +end function new_path3 + + +!> Create a new path with three components +pure function new_path4(key1, key2, key3, key4) result(path) + + !> First key to retrieve + character(*, tfc), intent(in) :: key1 + + !> Second key to retrieve + character(*, tfc), intent(in) :: key2 + + !> Third key to retrieve + character(*, tfc), intent(in) :: key3 + + !> Forth key to retrieve + character(*, tfc), intent(in) :: key4 + + !> New path + type(toml_path) :: path + + allocate(path%path(4)) + path%path(:) = [toml_key(key1), toml_key(key2), toml_key(key3), toml_key(key4)] +end function new_path4 + + +subroutine get_path_table(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout), target :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_table + + +subroutine get_path_array(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_array + + +subroutine get_path_keyval(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_keyval + + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_path_value_float_sp(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_float_sp + + +!> Retrieve TOML value as double precision float +subroutine get_path_value_float_dp(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_float_dp + + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_path_value_integer_i1(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i1 + + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_path_value_integer_i2(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i2 + + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_path_value_integer_i4(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i4 + + +!> Retrieve TOML value as eight byte integer +subroutine get_path_value_integer_i8(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i8 + + +!> Retrieve TOML value as logical +subroutine get_path_value_bool(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_path_value_datetime(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine get_path_value_string(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_string + + +!> Set TOML value to single precision float +subroutine set_path_value_float_sp(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_float_sp + + +!> Set TOML value to double precision float +subroutine set_path_value_float_dp(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_float_dp + + +!> Set TOML value to one byte integer +subroutine set_path_value_integer_i1(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i1 + + +!> Set TOML value to two byte integer +subroutine set_path_value_integer_i2(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i2 + + +!> Set TOML value to four byte integer +subroutine set_path_value_integer_i4(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i4 + + +!> Set TOML value to eight byte integer +subroutine set_path_value_integer_i8(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i8 + + +!> Set TOML value to logical +subroutine set_path_value_bool(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_bool + + +!> Set TOML value to datetime +subroutine set_path_value_datetime(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_datetime + + +!> Set TOML value to deferred-length character +subroutine set_path_value_string(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_string + + +subroutine walk_path(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout), target :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + type(toml_table), pointer :: current, next + + nullify(ptr) + if (.not.allocated(path%path)) then + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = table%origin + return + end if + + current => table + do it = 1, size(path%path) - 1 + call get_value(current, path%path(it)%key, next, requested, stat, origin) + if (.not.associated(next)) then + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = current%origin + return + end if + current => next + end do + ptr => current +end subroutine walk_path + + +end module tomlf_build_path diff --git a/source/third_party_open/utils/toml-f/src/tomlf/constants.f90 b/source/third_party_open/utils/toml-f/src/tomlf/constants.f90 new file mode 100644 index 000000000..a85e557ab --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/constants.f90 @@ -0,0 +1,145 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +module tomlf_constants + use, intrinsic :: iso_fortran_env, only : output_unit + implicit none + private + + !> Single precision real numbers + integer, public, parameter :: tf_sp = selected_real_kind(6) + + !> Double precision real numbers + integer, public, parameter :: tf_dp = selected_real_kind(15) + + !> Char length for integers + integer, public, parameter :: tf_i1 = selected_int_kind(2) + + !> Short length for integers + integer, public, parameter :: tf_i2 = selected_int_kind(4) + + !> Length of default integers + integer, public, parameter :: tf_i4 = selected_int_kind(9) + + !> Long length for integers + integer, public, parameter :: tf_i8 = selected_int_kind(18) + + + !> Default character kind + integer, public, parameter :: tfc = selected_char_kind('DEFAULT') + + !> Default float precision, IEEE 754 binary64 values expected + integer, public, parameter :: tfr = tf_dp + + !> Default integer precision, 64 bit (signed long) range expected + integer, public, parameter :: tfi = tf_i8 + + !> Default output channel + integer, public, parameter :: tfout = output_unit + + + !> Possible escape characters in TOML + type :: enum_escape + + !> Backslash is used to escape other characters + character(kind=tfc, len=1) :: backslash = tfc_'\' + + !> Double quotes signal strings with escape characters enabled + character(kind=tfc, len=1) :: dquote = tfc_'"' + + !> Single quotes signal strings without escape characters enabled + character(kind=tfc, len=1) :: squote = tfc_'''' + + !> Newline character + character(kind=tfc, len=1) :: newline = achar(10, kind=tfc) + + !> Formfeed character is allowed in strings + character(kind=tfc, len=1) :: formfeed = achar(12, kind=tfc) + + !> Carriage return is allowed as part of the newline and in strings + character(kind=tfc, len=1) :: carriage_return = achar(13, kind=tfc) + + !> Backspace is allowed in strings + character(kind=tfc, len=1) :: bspace = achar(8, kind=tfc) + + !> Tabulators are allowed as whitespace and in strings + character(kind=tfc, len=1) :: tabulator = achar(9, kind=tfc) + + end type enum_escape + + !> Actual enumerator with TOML escape characters + type(enum_escape), public, parameter :: toml_escape = enum_escape() + + + !> Possible kinds of TOML values in key-value pairs + type :: enum_type + + !> Invalid type + integer :: invalid = 100 + + !> String type + integer :: string = 101 + + !> Boolean type + integer :: boolean = 102 + + !> Integer type + integer :: int = 103 + + !> Float type + integer :: float = 104 + + !> Datetime type + integer :: datetime = 105 + + end type enum_type + + !> Actual enumerator with TOML value types + type(enum_type), public, parameter :: toml_type = enum_type() + + + !> Single quotes denote literal strings + character(kind=tfc, len=*), public, parameter :: TOML_SQUOTE = "'" + !> Double quotes denote strings (with escape character possible) + character(kind=tfc, len=*), public, parameter :: TOML_DQUOTE = '"' + character(kind=tfc, len=*), public, parameter :: TOML_NEWLINE = new_line('a') ! \n + character(kind=tfc, len=*), public, parameter :: TOML_TABULATOR = achar(9) ! \t + character(kind=tfc, len=*), public, parameter :: TOML_FORMFEED = achar(12) ! \f + character(kind=tfc, len=*), public, parameter :: TOML_CARRIAGE_RETURN = achar(13) ! \r + character(kind=tfc, len=*), public, parameter :: TOML_BACKSPACE = achar(8) ! \b + character(kind=tfc, len=*), public, parameter :: TOML_ESC = achar(27) ! \e + character(kind=tfc, len=*), public, parameter :: TOML_LOWERCASE = & + & 'abcdefghijklmnopqrstuvwxyz' + character(kind=tfc, len=*), public, parameter :: TOML_UPPERCASE = & + & 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(kind=tfc, len=*), public, parameter :: TOML_LETTERS = & + & TOML_LOWERCASE//TOML_UPPERCASE + !> Whitespace in TOML are blanks and tabs. + character(kind=tfc, len=*), public, parameter :: TOML_WHITESPACE = & + & ' '//toml_escape%tabulator + character(kind=tfc, len=*), public, parameter :: TOML_DIGITS = '0123456789' + character(kind=tfc, len=*), public, parameter :: TOML_BINDIGITS = & + & '01' + character(kind=tfc, len=*), public, parameter :: TOML_OCTDIGITS = & + & '01234567' + character(kind=tfc, len=*), public, parameter :: TOML_HEXDIGITS = & + & '0123456789ABCDEFabcdef' + character(kind=tfc, len=*), public, parameter :: TOML_TIMESTAMP = & + & TOML_DIGITS//'.:+-T Zz' + !> Allowed characters in TOML bare keys. + character(kind=tfc, len=*), public, parameter :: TOML_BAREKEY = & + & TOML_LETTERS//TOML_DIGITS//'_-' + character(kind=tfc, len=*), public, parameter :: TOML_LITERALS = & + & TOML_LETTERS//TOML_DIGITS//'_-+.' + +end module tomlf_constants diff --git a/source/third_party_open/utils/toml-f/src/tomlf/datetime.f90 b/source/third_party_open/utils/toml-f/src/tomlf/datetime.f90 new file mode 100644 index 000000000..b8b8c9b73 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/datetime.f90 @@ -0,0 +1,352 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML datetime value representation +!> +!> This module provides the [[toml_datetime]] type for representing TOML +!> datetime values. TOML supports four datetime formats: +!> +!> - Offset date-time: `1979-05-27T07:32:00Z` +!> - Local date-time: `1979-05-27T07:32:00` +!> - Local date: `1979-05-27` +!> - Local time: `07:32:00` +!> +!> The [[toml_datetime]] type combines [[toml_date]] and [[toml_time]] +!> components to represent any of these formats. +module tomlf_datetime + use tomlf_constants, only : tfc + implicit none + private + + public :: toml_datetime, toml_time, toml_date, to_string, has_date, has_time + public :: operator(==) + + + !> TOML time value (HH:MM:SS.sssssZ...) + type :: toml_time + integer :: hour = -1 + integer :: minute = -1 + integer :: second = -1 + integer :: msec = -1 + character(len=:), allocatable :: zone + end type + + interface toml_time + module procedure :: new_toml_time + end interface toml_time + + + !> TOML date value (YYYY-MM-DD) + type :: toml_date + integer :: year = -1 + integer :: month = -1 + integer :: day = -1 + end type + + + !> TOML datatime value type + type :: toml_datetime + type(toml_date) :: date + type(toml_time) :: time + end type + + + !> Create a new TOML datetime value + interface toml_datetime + module procedure :: new_datetime + module procedure :: new_datetime_from_string + end interface toml_datetime + + + interface operator(==) + module procedure :: compare_datetime + end interface operator(==) + + + interface to_string + module procedure :: to_string_datetime + end interface to_string + + +contains + + +pure function new_datetime(year, month, day, hour, minute, second, msecond, zone) & + & result(datetime) + integer, intent(in), optional :: year + integer, intent(in), optional :: month + integer, intent(in), optional :: day + integer, intent(in), optional :: hour + integer, intent(in), optional :: minute + integer, intent(in), optional :: second + integer, intent(in), optional :: msecond + character(len=*), intent(in), optional :: zone + type(toml_datetime) :: datetime + + if (present(year) .and. present(month) .and. present(day)) then + datetime%date%year = year + datetime%date%month = month + datetime%date%day = day + end if + + if (present(hour) .and. present(minute) .and. present(second)) then + datetime%time%hour = hour + datetime%time%minute = minute + datetime%time%second = second + if (present(msecond)) then + datetime%time%msec = msecond + end if + if (present(zone)) then + datetime%time%zone = zone + end if + end if +end function new_datetime + + +pure function new_datetime_from_string(string) result(datetime) + character(len=*), intent(in) :: string + type(toml_datetime) :: datetime + + type(toml_date) :: date + type(toml_time) :: time + + integer :: it, tmp, first + character(*, tfc), parameter :: num = "0123456789" + integer, allocatable :: msec(:) + logical :: has_seconds + + first = 0 + + if (all([string(first+5:first+5), string(first+8:first+8)] == "-")) then + date%year = 0 + do it = first + 1, first + 4 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%year = date%year * 10 + tmp + end do + + date%month = 0 + do it = first + 6, first + 7 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%month = date%month * 10 + tmp + end do + + date%day = 0 + do it = first + 9, first + 10 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%day = date%day * 10 + tmp + end do + + first = first + 11 + datetime%date = date + end if + + if (first >= len(string)) return + ! Check for time: HH:MM format (colon at position 3) + if (string(first+3:first+3) == ":") then + time%hour = 0 + do it = first + 1, first + 2 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%hour = time%hour * 10 + tmp + end do + + time%minute = 0 + do it = first + 4, first + 5 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%minute = time%minute * 10 + tmp + end do + + ! Check for optional seconds (TOML 1.1) + has_seconds = first + 6 <= len(string) .and. string(first+6:first+6) == ":" + if (has_seconds) then + time%second = 0 + do it = first + 7, first + 8 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%second = time%second * 10 + tmp + end do + first = first + 8 + else + ! No seconds - keep time%second as default (-1) + first = first + 5 + end if + + if (first < len(string)) then + if (string(first+1:first+1) == ".") then + msec = [integer::] + do it = first + 2, len(string) + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + msec = [msec, tmp] + end do + first = it - 1 + + msec = [msec, 0, 0, 0, 0, 0, 0] + time%msec = sum(msec(1:6) * [100000, 10000, 1000, 100, 10, 1]) + end if + end if + + if (first < len(string)) then + time%zone = "" + do it = first + 1, len(string) + time%zone = time%zone // string(it:it) + end do + if (time%zone == "z") time%zone = "Z" + end if + datetime%time = time + end if + +end function new_datetime_from_string + + +pure function to_string_datetime(datetime) result(str) + type(toml_datetime), intent(in) :: datetime + character(kind=tfc, len=:), allocatable :: str + + str = "" + if (has_date(datetime)) then + str = str // to_string_date(datetime%date) + end if + + if (has_time(datetime)) then + if (has_date(datetime)) then + str = str // ' ' + end if + str = str // to_string_time(datetime%time) + end if +end function to_string_datetime + +pure function to_string_date(date) result(str) + type(toml_date), intent(in) :: date + character(:, tfc), allocatable :: str + + allocate(character(10, tfc) :: str) + write(str, '(i4.4,"-",i2.2,"-",i2.2)') & + & date%year, date%month, date%day +end function to_string_date + +pure function to_string_time(time) result(str) + type(toml_time), intent(in) :: time + character(:, tfc), allocatable :: str + + integer :: msec, width + character(1), parameter :: places(6) = ["1", "2", "3", "4", "5", "6"] + + ! Handle optional seconds (TOML 1.1) + if (time%second < 0) then + ! No seconds - output HH:MM format + allocate(character(5, tfc) :: str) + write(str, '(i2.2,":",i2.2)') & + & time%hour, time%minute + else if (time%msec < 0) then + allocate(character(8, tfc) :: str) + write(str, '(i2.2,":",i2.2,":",i2.2)') & + & time%hour, time%minute, time%second + else + width = 6 + msec = time%msec + do while(mod(msec, 10) == 0 .and. width > 3) + width = width - 1 + msec = msec / 10 + end do + allocate(character(9 + width, tfc) :: str) + write(str, '(i2.2,":",i2.2,":",i2.2,".",i'//places(width)//'.'//places(width)//')') & + & time%hour, time%minute, time%second, msec + end if + if (allocated(time%zone)) str = str // trim(time%zone) +end function to_string_time + + +pure function has_date(datetime) + class(toml_datetime), intent(in) :: datetime + logical :: has_date + has_date = (datetime%date%year >= 0) .and. & + & (datetime%date%month >= 0) .and. & + & (datetime%date%day >= 0) +end function has_date + +pure function has_time(datetime) + class(toml_datetime), intent(in) :: datetime + logical :: has_time + has_time = (datetime%time%hour >= 0) .and. & + & (datetime%time%minute >= 0) +end function has_time + + +!> Constructor for toml_time type, necessary due to PGI bug in NVHPC 20.7 and 20.9 +elemental function new_toml_time(hour, minute, second, msec, zone) & + & result(self) + integer, intent(in), optional :: hour + integer, intent(in), optional :: minute + integer, intent(in), optional :: second + integer, intent(in), optional :: msec + character(len=*), intent(in), optional :: zone + type(toml_time) :: self + if (present(hour)) self%hour = hour + if (present(minute)) self%minute = minute + if (present(second)) self%second = second + if (present(msec)) self%msec = msec + if (present(zone)) self%zone = zone +end function new_toml_time + + +pure function compare_datetime(lhs, rhs) result(match) + type(toml_datetime), intent(in) :: lhs + type(toml_datetime), intent(in) :: rhs + logical :: match + + match = (has_date(lhs) .eqv. has_date(rhs)) & + & .and. (has_time(lhs) .eqv. has_time(rhs)) + if (has_date(lhs) .and. has_date(rhs)) then + match = match .and. compare_date(lhs%date, rhs%date) + end if + + if (has_time(lhs) .and. has_time(rhs)) then + match = match .and. compare_time(lhs%time, rhs%time) + end if +end function compare_datetime + + +pure function compare_date(lhs, rhs) result(match) + type(toml_date), intent(in) :: lhs + type(toml_date), intent(in) :: rhs + logical :: match + + match = lhs%year == rhs%year .and. lhs%month == rhs%month .and. lhs%day == rhs%day +end function compare_date + + +pure function compare_time(lhs, rhs) result(match) + type(toml_time), intent(in) :: lhs + type(toml_time), intent(in) :: rhs + logical :: match + + integer :: lms, rms + + lms = max(lhs%msec, 0) + rms = max(rhs%msec, 0) + + match = lhs%hour == rhs%hour .and. lhs%minute == rhs%minute .and. lhs%second == rhs%second & + & .and. lms == rms .and. allocated(lhs%zone) .eqv. allocated(rhs%zone) + + if (allocated(lhs%zone) .and. allocated(rhs%zone)) then + match = match .and. lhs%zone == rhs%zone + end if +end function compare_time + + +end module tomlf_datetime diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de.f90 new file mode 100644 index 000000000..1b96021e6 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de.f90 @@ -0,0 +1,161 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML deserialization module +!> +!> This module provides interfaces for loading and parsing TOML documents +!> from various sources (files, strings, and I/O units). +!> +!> The primary interfaces are: +!> +!> - [[toml_load]]: Load TOML from a file path or connected unit +!> - [[toml_loads]]: Parse TOML from a string +!> +!> All parsing functions return an allocatable [[toml_table]] that contains +!> the parsed document. If parsing fails, the table will not be allocated +!> and error information is provided via the optional error argument. +module tomlf_de + use tomlf_constants, only : tfc, TOML_NEWLINE + use tomlf_de_context, only : toml_context + use tomlf_de_lexer, only : toml_lexer, new_lexer_from_string, new_lexer_from_unit, & + & new_lexer_from_file + use tomlf_de_parser, only : parse, toml_parser_config + use tomlf_diagnostic, only : toml_level + use tomlf_error, only : toml_error + use tomlf_type, only : toml_table + implicit none + private + + public :: toml_parse + public :: toml_load, toml_loads + public :: toml_context, toml_parser_config, toml_level + + + !> Parse a TOML document. + !> + !> This interface is deprecated in favor of [[toml_load]] and [[toml_loads]] + interface toml_parse + module procedure :: toml_parse_unit + module procedure :: toml_parse_string + end interface toml_parse + + !> Load a TOML data structure from the provided source + interface toml_load + module procedure :: toml_load_file + module procedure :: toml_load_unit + end interface toml_load + + !> Load a TOML data structure from a string + interface toml_loads + module procedure :: toml_load_string + end interface toml_loads + + +contains + + +!> Parse a TOML input from a given IO unit. +!> +!> @note This procedure is deprectated +subroutine toml_parse_unit(table, unit, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> Unit to read from + integer, intent(in) :: unit + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + call toml_load(table, unit, error=error) +end subroutine toml_parse_unit + +!> Wrapper to parse a TOML string. +!> +!> @note This procedure is deprectated +subroutine toml_parse_string(table, string, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> String containing TOML document + character(len=*), intent(in), target :: string + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + call toml_loads(table, string, error=error) +end subroutine toml_parse_string + +!> Load TOML data structure from file +subroutine toml_load_file(table, filename, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + character(*, tfc), intent(in) :: filename + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + type(toml_error), allocatable :: error_ + + call new_lexer_from_file(lexer, filename, error_) + if (.not.allocated(error_)) then + call parse(lexer, table, config, context, error) + else + if (present(error)) call move_alloc(error_, error) + end if +end subroutine toml_load_file + +!> Load TOML data structure from unit +subroutine toml_load_unit(table, io, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> Unit to read from + integer, intent(in) :: io + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + type(toml_error), allocatable :: error_ + + call new_lexer_from_unit(lexer, io, error_) + if (.not.allocated(error_)) then + call parse(lexer, table, config, context, error) + else + if (present(error)) call move_alloc(error_, error) + end if +end subroutine toml_load_unit + +!> Load TOML data structure from string +subroutine toml_load_string(table, string, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> String containing TOML document + character(*, tfc), intent(in) :: string + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + + call new_lexer_from_string(lexer, string) + call parse(lexer, table, config, context, error) +end subroutine toml_load_string + +end module tomlf_de diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/abc.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/abc.f90 new file mode 100644 index 000000000..3b2b1a73a --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/abc.f90 @@ -0,0 +1,126 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Defines the abstract base class which is implemented by the TOML lexer. +module tomlf_de_abc + use tomlf_constants, only : tfc, tfi, tfr + use tomlf_datetime, only : toml_datetime + use tomlf_de_token, only : toml_token + implicit none + private + + public :: abstract_lexer + + + !> Abstract base class for TOML lexers. + type, abstract :: abstract_lexer + contains + !> Obtain the next token + procedure(next), deferred :: next + !> Extract a token + generic :: extract => & + & extract_string, extract_integer, extract_float, extract_bool, extract_datetime + !> Extract a string from a token + procedure(extract_string), deferred :: extract_string + !> Extract an integer from a token + procedure(extract_integer), deferred :: extract_integer + !> Extract a float from a token + procedure(extract_float), deferred :: extract_float + !> Extract a boolean from a token + procedure(extract_bool), deferred :: extract_bool + !> Extract a timestamp from a token + procedure(extract_datetime), deferred :: extract_datetime + !> Get information about the source + procedure(get_info), deferred :: get_info + end type abstract_lexer + + + abstract interface + !> Advance the lexer to the next token. + subroutine next(lexer, token) + import :: abstract_lexer, toml_token + !> Instance of the lexer + class(abstract_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + end subroutine next + + !> Extract string value of token, works for keypath, string, multiline string, literal, + !> and mulitline literal tokens. + subroutine extract_string(lexer, token, string) + import :: abstract_lexer, toml_token, tfc + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract string value from + type(toml_token), intent(in) :: token + !> String value of token + character(:, tfc), allocatable, intent(out) :: string + end subroutine extract_string + + !> Extract integer value of token + subroutine extract_integer(lexer, token, val) + import :: abstract_lexer, toml_token, tfi + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract integer value from + type(toml_token), intent(in) :: token + !> Integer value of token + integer(tfi), intent(out) :: val + end subroutine extract_integer + + !> Extract floating point value of token + subroutine extract_float(lexer, token, val) + import :: abstract_lexer, toml_token, tfr + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract floating point value from + type(toml_token), intent(in) :: token + !> Floating point value of token + real(tfr), intent(out) :: val + end subroutine extract_float + + !> Extract boolean value of token + subroutine extract_bool(lexer, token, val) + import :: abstract_lexer, toml_token + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract boolean value from + type(toml_token), intent(in) :: token + !> Boolean value of token + logical, intent(out) :: val + end subroutine extract_bool + + !> Extract datetime value of token + subroutine extract_datetime(lexer, token, val) + import :: abstract_lexer, toml_token, toml_datetime + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract datetime value from + type(toml_token), intent(in) :: token + !> Datetime value of token + type(toml_datetime), intent(out) :: val + end subroutine extract_datetime + + !> Extract information about the source + subroutine get_info(lexer, meta, output) + import :: abstract_lexer, tfc + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Query about the source + character(*, tfc), intent(in) :: meta + !> Metadata about the source + character(:, tfc), allocatable, intent(out) :: output + end subroutine get_info + end interface + +end module tomlf_de_abc diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/context.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/context.f90 new file mode 100644 index 000000000..59b904f1b --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/context.f90 @@ -0,0 +1,154 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides a container to store tokens for later use +module tomlf_de_context + use tomlf_constants, only : tfc + use tomlf_de_token, only : toml_token, resize + use tomlf_diagnostic, only : toml_diagnostic, toml_label, render, toml_level + use tomlf_terminal, only : toml_terminal + implicit none + private + + public :: toml_context + + !> Container storing tokens + type :: toml_context + !> Filename of the input + character(:, tfc), allocatable :: filename + !> Actual source + character(:, tfc), allocatable :: source + !> Stack of stored tokens + type(toml_token), allocatable :: token(:) + !> Last stored token + integer :: top = 0 + contains + !> Push a new token to the stack + procedure :: push_back + !> Create a report + generic :: report => report1, report2 + !> Create a report with a single label + procedure :: report1 + !> Create a report with a two labels + procedure :: report2 + end type toml_context + +contains + +!> Push a new token to the stack +subroutine push_back(self, token) + !> Instance of the token storage + class(toml_context), intent(inout) :: self + !> New token to be added + type(toml_token), intent(in) :: token + + if (.not.allocated(self%token)) call resize(self%token) + if (self%top >= size(self%token)) call resize(self%token) + + self%top = self%top + 1 + self%token(self%top) = token +end subroutine push_back + +!> Create a report with a single label +pure function report1(self, message, origin, label, level, color) result(string) + !> Instance of the token storage + class(toml_context), intent(in) :: self + !> Message for the report + character(*, tfc), intent(in) :: message + !> Position to report at + integer, intent(in) :: origin + !> String for the label + character(*, tfc), intent(in), optional :: label + !> Highlight level + integer, intent(in), optional :: level + !> Color terminal + type(toml_terminal), intent(in), optional :: color + !> Final rendered report + character(:, tfc), allocatable :: string + + type(toml_diagnostic) :: diagnostic + type(toml_label), allocatable :: labels(:) + integer :: level_ + + level_ = toml_level%error + if (present(level)) level_ = level + + if (origin > 0 .and. origin <= self%top) then + allocate(labels(1)) + labels(1) = toml_label(level_, & + & self%token(origin)%first, self%token(origin)%last, label, .true.) + end if + + diagnostic = toml_diagnostic( & + & level_, & + & message, & + & self%filename, & + & labels) + + if (.not.present(color)) then + string = render(diagnostic, self%source, toml_terminal(.false.)) + else + string = render(diagnostic, self%source, color) + end if +end function report1 + +!> Create a report with two labels +pure function report2(self, message, origin1, origin2, label1, label2, level1, level2, color) & + & result(string) + !> Instance of the token storage + class(toml_context), intent(in) :: self + !> Message for the report + character(*, tfc), intent(in) :: message + !> Position to report at + integer, intent(in) :: origin1, origin2 + !> String for the label + character(*, tfc), intent(in), optional :: label1, label2 + !> Highlight level + integer, intent(in), optional :: level1, level2 + !> Color terminal + type(toml_terminal), intent(in), optional :: color + !> Final rendered report + character(:, tfc), allocatable :: string + + type(toml_diagnostic) :: diagnostic + type(toml_label), allocatable :: labels(:) + integer :: level1_, level2_ + + level1_ = toml_level%error + if (present(level1)) level1_ = level1 + level2_ = toml_level%info + if (present(level2)) level2_ = level2 + + if (origin1 > 0 .and. origin1 <= self%top & + & .and. origin2 > 0 .and. origin2 <= self%top) then + allocate(labels(2)) + labels(1) = toml_label(level1_, & + & self%token(origin1)%first, self%token(origin1)%last, label1, .true.) + labels(2) = toml_label(level2_, & + & self%token(origin2)%first, self%token(origin2)%last, label2, .false.) + end if + + diagnostic = toml_diagnostic( & + & level1_, & + & message, & + & self%filename, & + & labels) + + if (.not.present(color)) then + string = render(diagnostic, self%source, toml_terminal(.false.)) + else + string = render(diagnostic, self%source, color) + end if +end function report2 + +end module tomlf_de_context diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 new file mode 100644 index 000000000..6710b5f6e --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 @@ -0,0 +1,1582 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides tokenization for TOML documents. +!> +!> The lexer provides a way to turn a stream of characters into tokens which +!> are further processed by the parser and turned into actual TOML data structures. +!> In the current structure no knowledge about the character stream is required +!> in the parser to generate the data structures. +!> +!> The validity of all tokens can be guaranteed by the lexer, however syntax errors +!> and semantic errors are not detected until the parser is run. Identification of +!> invalid tokens and recovery of the tokenization is done on a best effort basis. +!> +!> To avoid overflows in the parser due to deeply nested but unclosed groups, the +!> lexer will always tokenize a complete group to verify it is closed properly. +!> Unclosed groups will lead to the first token of the group getting invalidated, +!> to allow reporting in the parsing phase. +module tomlf_de_lexer + use tomlf_constants, only : tfc, tfi, tfr, TOML_BACKSPACE, TOML_TABULATOR, TOML_NEWLINE, & + & TOML_CARRIAGE_RETURN, TOML_FORMFEED, TOML_ESC + use tomlf_datetime, only : toml_datetime, toml_date, toml_time + use tomlf_de_abc, only : abstract_lexer + use tomlf_de_context, only : toml_context + use tomlf_de_token, only : toml_token, stringify, token_kind, resize + use tomlf_error, only : toml_error, toml_stat, make_error + use tomlf_utils, only : read_whole_file, read_whole_line + implicit none + private + + public :: toml_lexer, new_lexer_from_file, new_lexer_from_unit, new_lexer_from_string + public :: toml_token, stringify, token_kind + + + !> Possible characters encountered in a lexeme + type :: enum_char + character(1, tfc) :: space = tfc_" " + character(1, tfc) :: hash = tfc_"#" + character(1, tfc) :: squote = tfc_"'" + character(3, tfc) :: squote3 = repeat(tfc_"'", 3) + character(1, tfc) :: dquote = tfc_"""" + character(3, tfc) :: dquote3 = repeat(tfc_"""", 3) + character(1, tfc) :: backslash = tfc_"\" + character(1, tfc) :: dot = tfc_"." + character(1, tfc) :: comma = tfc_"," + character(1, tfc) :: equal = tfc_"=" + character(1, tfc) :: lbrace = tfc_"{" + character(1, tfc) :: rbrace = tfc_"}" + character(1, tfc) :: lbracket = tfc_"[" + character(1, tfc) :: rbracket = tfc_"]" + character(1, tfc) :: newline = achar(10, kind=tfc) + character(1, tfc) :: formfeed = achar(12, kind=tfc) + character(1, tfc) :: carriage_return = achar(13, kind=tfc) + character(1, tfc) :: bspace = achar(8, kind=tfc) + character(1, tfc) :: tab = achar(9, kind=tfc) + character(1, tfc) :: plus = tfc_"+" + character(1, tfc) :: minus = tfc_"-" + character(12, tfc) :: literal = tfc_"0123456789-_" + end type enum_char + + !> Actual enumerator for possible characters + type(enum_char), parameter :: char_kind = enum_char() + + !> Set of characters marking a terminated lexeme, mainly used for values and to + !> obtain boundaries of invalid tokens. + character(*, tfc), parameter :: terminated = & + & char_kind%space//char_kind%tab//char_kind%newline//char_kind%carriage_return//& + & char_kind%hash//char_kind%rbrace//char_kind%rbracket//char_kind%comma//& + & char_kind%equal + + !> Scopes to identify the state of the lexer. + type :: enum_scope + !> Table scopes allow keypaths, in this scenario only bare keys, strings and + !> literals are allowed, furthermore dots become special characters to separate + !> the keypaths. + integer :: table = 1 + !> Terminates a table scope and opens a value scope. Here usual values, like integer, + !> floats or strings are allowed. + integer :: equal = 2 + !> Opens an array scope, similar to the value scope for allowed characters but with + !> simplified closing rules to allow handling of values and inline tables in arrays. + integer :: array = 3 + end type enum_scope + + !> Actual enumerator for auxiliary scopes + type(enum_scope), parameter :: lexer_scope = enum_scope() + + !> Item identifying the scope and the corresponding token index + type :: stack_item + !> Current scope of the item, can only be removed with matching scope + integer :: scope + !> Token index in the buffer of the lexer, used for invalidation of unclosed groups + integer :: token + end type stack_item + + !> Reallocate the stack of scopes + interface resize + module procedure :: resize_scope + end interface + + + !> Tokenizer for TOML documents. + type, extends(abstract_lexer) :: toml_lexer + !> Name of the source file, used for error reporting + character(len=:), allocatable :: filename + !> Current internal position in the source chunk + integer :: pos = 0 + !> Current source chunk, for convenience stored as character array rather than string + character(:, tfc), allocatable :: chunk + !> Last scope of the lexer + integer :: top = 0 + !> Stack of scopes, used to identify the current state of the lexer + type(stack_item), allocatable :: stack(:) + !> Index in the buffer queue + integer :: buffer = 0 + !> Douple-ended queue for buffering tokens + type(toml_context) :: context + contains + !> Obtain the next token + procedure :: next + !> Extract a string from a token + procedure :: extract_string + !> Extract an integer from a token + procedure :: extract_integer + !> Extract a float from a token + procedure :: extract_float + !> Extract a boolean from a token + procedure :: extract_bool + !> Extract a timestamp from a token + procedure :: extract_datetime + !> Get information about source + procedure :: get_info + end type toml_lexer + +contains + +!> Create a new instance of a lexer by reading from a file +subroutine new_lexer_from_file(lexer, filename, error) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> Name of the file to read from + character(len=*), intent(in) :: filename + !> Error code + type(toml_error), allocatable, intent(out) :: error + + integer :: stat + + lexer%pos = 0 + lexer%filename = filename + call resize(lexer%stack) + call read_whole_file(filename, lexer%chunk, stat) + + if (stat /= 0) then + call make_error(error, "Could not open file '"//filename//"'") + end if +end subroutine new_lexer_from_file + +!> Create a new instance of a lexer by reading from a unit. +!> +!> Currently, only sequential access units can be processed by this constructor. +subroutine new_lexer_from_unit(lexer, io, error) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> Unit to read from + integer, intent(in) :: io + !> Error code + type(toml_error), allocatable, intent(out) :: error + + character(:, tfc), allocatable :: source, line + integer, parameter :: bufsize = 512 + character(bufsize, tfc) :: filename, mode + integer :: stat + + inquire(unit=io, access=mode, name=filename) + select case(trim(mode)) + case default + stat = 1 + + case("sequential", "SEQUENTIAL") + allocate(character(0) :: source) + do + call read_whole_line(io, line, stat) + if (stat > 0) exit + source = source // line // TOML_NEWLINE + if (stat < 0) then + if (is_iostat_end(stat)) stat = 0 + exit + end if + end do + call new_lexer_from_string(lexer, source) + end select + if (len_trim(filename) > 0) lexer%filename = trim(filename) + + if (stat /= 0) then + call make_error(error, "Failed to read from unit") + end if +end subroutine new_lexer_from_unit + +!> Create a new instance of a lexer by reading from a string. +subroutine new_lexer_from_string(lexer, string) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> String to read from + character(*, tfc), intent(in) :: string + + integer :: length + + length = len(string) + lexer%pos = 0 + lexer%buffer = 0 + allocate(character(length) :: lexer%chunk) + lexer%chunk(:length) = string + call resize(lexer%stack) +end subroutine new_lexer_from_string + + +!> Advance the lexer to the next token. +subroutine next(lexer, token) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + if (lexer%buffer >= lexer%context%top) then + call fill_buffer(lexer) + end if + + lexer%buffer = lexer%buffer + 1 + token = lexer%context%token(lexer%buffer) +end subroutine next + +!> Fill the buffer with tokens, this routine will attempt to create as many tokens as +!> necessary to determine whether all opened groups are closed properly. +!> +!> The state of the buffer can be changed while this routine is running, therefore +!> accessing the buffer concurrently is not allowed. +subroutine fill_buffer(lexer) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + type(toml_token) :: token + integer :: stack_top, it + + lexer%buffer = 0 + lexer%context%top = 0 + stack_top = lexer%top + + ! Tokenization will cover always a complete scope + do while(lexer%top >= stack_top .and. token%kind /= token_kind%eof) + call next_token(lexer, token) + call lexer%context%push_back(token) + end do + + ! Flag all incomplete inline table and array scopes for the parser + if (lexer%top > stack_top) then + do it = lexer%top, stack_top + 1, -1 + select case(lexer%stack(it)%scope) + case(lexer_scope%table, lexer_scope%array) + lexer%context%token(lexer%stack(it)%token)%kind = token_kind%unclosed + end select + end do + end if +end subroutine fill_buffer + +!> Actually generate the next token, unbuffered version +subroutine next_token(lexer, token) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + + ! Consume current token + lexer%pos = lexer%pos + token%last - token%first + 1 + prev = lexer%pos + pos = lexer%pos + + ! If lexer is exhausted, return EOF as early as possible + if (pos > len(lexer%chunk)) then + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%eof, prev, pos) + return + end if + + select case(peek(lexer, pos)) + case(char_kind%hash) + do while(all(peek(lexer, pos+1) /= [char_kind%carriage_return, char_kind%newline]) & + & .and. pos <= len(lexer%chunk)) + pos = pos + 1 + end do + token = toml_token(token_kind%comment, prev, pos) + + case(char_kind%space, char_kind%tab) + do while(any(match(lexer, pos+1, [char_kind%space, char_kind%tab])) & + & .and. pos <= len(lexer%chunk)) + pos = pos + 1 + end do + token = toml_token(token_kind%whitespace, prev, pos) + + case(char_kind%newline) + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%newline, prev, pos) + + case(char_kind%carriage_return) + if (match(lexer, pos+1, char_kind%newline)) then + pos = pos + 1 + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%newline, prev, pos) + else + token = toml_token(token_kind%invalid, prev, pos) + end if + + case(char_kind%dot) + if (view_scope(lexer) == lexer_scope%table) then + token = toml_token(token_kind%dot, prev, pos) + else + token = toml_token(token_kind%invalid, prev, pos) + end if + + case(char_kind%comma) + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%comma, prev, pos) + + case(char_kind%equal) + token = toml_token(token_kind%equal, prev, pos) + call push_back(lexer, lexer_scope%equal, lexer%context%top + 1) + + case(char_kind%lbrace) + token = toml_token(token_kind%lbrace, prev, pos) + call push_back(lexer, lexer_scope%table, lexer%context%top + 1) + + case(char_kind%rbrace) + call pop(lexer, lexer_scope%equal) + call pop(lexer, lexer_scope%table) + token = toml_token(token_kind%rbrace, prev, pos) + + case(char_kind%lbracket) + token = toml_token(token_kind%lbracket, prev, pos) + if (any(view_scope(lexer) == [lexer_scope%equal, lexer_scope%array])) then + call push_back(lexer, lexer_scope%array, lexer%context%top + 1) + end if + + case(char_kind%rbracket) + call pop(lexer, lexer_scope%array) + token = toml_token(token_kind%rbracket, prev, pos) + + case(char_kind%squote) + call next_sstring(lexer, token) + + case(char_kind%dquote) + call next_dstring(lexer, token) + + case default + if (view_scope(lexer) == lexer_scope%table) then + call next_keypath(lexer, token) + else + call next_literal(lexer, token) + end if + + end select +end subroutine next_token + +!> Process next literal string token, can produce normal literals and multiline literals +subroutine next_sstring(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(1, tfc) :: ch + integer :: prev, pos, it + logical :: valid + + prev = lexer%pos + pos = lexer%pos + + if (all(match(lexer, [pos+1, pos+2], char_kind%squote))) then + pos = pos + 3 + + pos = strstr(lexer%chunk(pos:), char_kind%squote3) + pos - 1 + if (pos < prev + 3) then + token = toml_token(token_kind%invalid, prev, len(lexer%chunk)) + return + end if + + do it = 1, 2 + if (match(lexer, pos+3, char_kind%squote)) pos = pos + 1 + end do + + valid = .true. + do it = prev + 3, pos - 1 + ch = peek(lexer, it) + valid = valid .and. valid_string(ch) + end do + + token = toml_token(merge(token_kind%mliteral, token_kind%invalid, valid), prev, pos+2) + return + end if + + valid = .true. + + do while(pos < len(lexer%chunk)) + pos = pos + 1 + ch = peek(lexer, pos) + valid = valid .and. valid_string(ch) + if (ch == char_kind%squote) exit + if (ch == char_kind%newline) then + pos = pos - 1 + valid = .false. + exit + end if + end do + + valid = valid .and. peek(lexer, pos) == char_kind%squote .and. pos /= prev + token = toml_token(merge(token_kind%literal, token_kind%invalid, valid), prev, pos) +end subroutine next_sstring + +!> Process next string token, can produce normal string and multiline string tokens +subroutine next_dstring(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(1, tfc) :: ch + character(*, tfc), parameter :: hexnum = "0123456789ABCDEF", valid_escape = "betnfr\""" + integer :: prev, pos, expect, it, hex + logical :: escape, valid, space + + prev = lexer%pos + pos = lexer%pos + hex = 0 + + if (all(match(lexer, [pos+1, pos+2], char_kind%dquote))) then + pos = pos + 3 + + do + it = strstr(lexer%chunk(pos:), char_kind%dquote3) + pos = it + pos - 1 + if (pos < prev + 3 .or. it == 0) then + token = toml_token(token_kind%invalid, prev, len(lexer%chunk)) + return + end if + + if (match(lexer, pos-1, char_kind%backslash)) then + pos = pos + 1 + cycle + end if + + do it = 1, 2 + if (match(lexer, pos+3, char_kind%dquote)) pos = pos + 1 + end do + exit + end do + + valid = .true. + escape = .false. + space = .false. + expect = 0 + + do it = prev + 3, pos - 1 + ch = peek(lexer, it) + if (escape) then + space = verify(ch, char_kind%space//char_kind%tab//& + & char_kind%carriage_return//char_kind%newline) == 0 + end if + if (space) then + escape = .false. + if (ch == char_kind%newline) then + if (expect > 0) expect = expect - 1 + space = .false. + cycle + end if + if (verify(ch, char_kind%space//char_kind%tab) == 0 .and. expect == 0) cycle + if (ch == char_kind%carriage_return) then + expect = 1 + cycle + end if + valid = .false. + space = .false. + expect = 0 + cycle + end if + valid = valid .and. valid_string(ch) + if (escape) then + escape = .false. + space = .false. + if (verify(ch, valid_escape) == 0) cycle + if (ch == "x") then + expect = 2 + hex = it + 1 + cycle + end if + if (ch == "u") then + expect = 4 + hex = pos + 1 + cycle + end if + if (ch == "U") then + expect = 8 + hex = pos + 1 + cycle + end if + valid = .false. + cycle + end if + if (expect > 0) then + expect = expect - 1 + valid = valid .and. verify(ch, hexnum) == 0 + if (expect == 0) valid = valid .and. verify_ucs(lexer%chunk(hex:pos)) + cycle + end if + escape = ch == char_kind%backslash + end do + + ! Check for any unfinished escape sequences + valid = valid .and. expect == 0 .and. .not.(escape.or.space) + + token = toml_token(merge(token_kind%mstring, token_kind%invalid, valid), prev, pos+2) + return + end if + + valid = .true. + escape = .false. + expect = 0 + + do while(pos < len(lexer%chunk)) + pos = pos + 1 + ch = peek(lexer, pos) + valid = valid .and. valid_string(ch) + if (escape) then + escape = .false. + if (verify(ch, valid_escape) == 0) cycle + if (ch == "x") then + expect = 2 + hex = it + 1 + cycle + end if + if (ch == "u") then + expect = 4 + hex = pos + 1 + cycle + end if + if (ch == "U") then + expect = 8 + hex = pos + 1 + cycle + end if + valid = .false. + cycle + end if + if (expect > 0) then + expect = expect - 1 + valid = valid .and. verify(ch, hexnum) == 0 + if (expect == 0) valid = valid .and. verify_ucs(lexer%chunk(hex:pos)) + cycle + end if + escape = ch == char_kind%backslash + if (ch == char_kind%dquote) exit + if (ch == char_kind%newline) then + pos = pos - 1 + valid = .false. + exit + end if + end do + + valid = valid .and. peek(lexer, pos) == char_kind%dquote .and. pos /= prev + token = toml_token(merge(token_kind%string, token_kind%invalid, valid), prev, pos) +end subroutine next_dstring + +!> Validate characters in string, non-printable characters are invalid in this context +pure function valid_string(ch) result(valid) + character(1, tfc), intent(in) :: ch + logical :: valid + + character(1, tfc), parameter :: x00 = achar(int(z"00")), x08 = achar(int(z"08")), & + & x0b = achar(int(z"0b")), x1f = achar(int(z"1f")), x7f = achar(int(z"7f")) + + valid = & + & .not.(x00 <= ch .and. ch <= x08) .and. & + & .not.(x0b <= ch .and. ch <= x1f) .and. & + & ch /= x7f +end function + +!> Process next bare key token, produces keypath tokens. +subroutine next_keypath(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + logical :: valid + integer :: prev, pos + character(1, tfc) :: ch + + prev = lexer%pos + pos = lexer%pos + ch = peek(lexer, pos) + + valid = (tfc_"A" <= ch .and. ch <= tfc_"Z") & + & .or. (tfc_"a" <= ch .and. ch <= tfc_"z") & + & .or. (verify(ch, char_kind%literal) == 0) + do while(verify(peek(lexer, pos+1), terminated//char_kind%dot) > 0) + pos = pos + 1 + ch = peek(lexer, pos) + + if (tfc_"A" <= ch .and. ch <= tfc_"Z") cycle + if (tfc_"a" <= ch .and. ch <= tfc_"z") cycle + if (verify(ch, char_kind%literal) == 0) cycle + + valid = .false. + cycle + end do + + token = toml_token(merge(token_kind%keypath, token_kind%invalid, valid), prev, pos) +end subroutine next_keypath + +!> Identify literal values, produces integer, float, boolean, and datetime tokens. +subroutine next_literal(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + integer, parameter :: offset(*) = [0, 1, 2, 3, 4, 5] + character(1, tfc), parameter :: & + & true(4) = ["t", "r", "u", "e"], false(5) = ["f", "a", "l", "s", "e"] + + prev = lexer%pos + pos = lexer%pos + + select case(peek(lexer, pos)) + case("t") + if (match_all(lexer, pos+offset(:4), true) .and. & + & verify(peek(lexer, pos+4), terminated) == 0) then + token = toml_token(token_kind%bool, prev, pos+3) + return + end if + + case("f") + if (match_all(lexer, pos+offset(:5), false) .and. & + & verify(peek(lexer, pos+5), terminated) == 0) then + token = toml_token(token_kind%bool, prev, pos+4) + return + end if + + case default + call next_datetime(lexer, token) + if (token%kind == token_kind%datetime) return + + call next_integer(lexer, token) + if (token%kind == token_kind%int) return + + call next_float(lexer, token) + if (token%kind == token_kind%float) return + + end select + + ! If the current token is invalid, advance to the next terminator + do while(verify(peek(lexer, pos+1), terminated) > 0) + pos = pos + 1 + end do + token = toml_token(token_kind%invalid, prev, pos) +end subroutine next_literal + +!> Process integer tokens and binary, octal, and hexadecimal literals. +subroutine next_integer(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(*, tfc), parameter :: toml_base(4) = [& + & "0123456789abcdefABCDEF", & + & "0123456789000000000000", & + & "0123456700000000000000", & + & "0100000000000000000000"] + integer, parameter :: b10 = 2, b16 = 1, b8 = 3, b2 = 4 + + character(1, tfc) :: ch + integer :: prev, pos, base + logical :: underscore, okay + + prev = lexer%pos + pos = lexer%pos + okay = .true. + underscore = .true. + base = b10 + + if (any(match(lexer, pos, ["+", "-"]))) then + pos = pos + 1 + end if + + if (match(lexer, pos, "0")) then + select case(peek(lexer, pos+1)) + case("x") + okay = pos == prev + base = b16 + pos = pos + 2 + case("o") + okay = pos == prev + base = b8 + pos = pos + 2 + case("b") + okay = pos == prev + base = b2 + pos = pos + 2 + case(char_kind%space, char_kind%tab, char_kind%newline, char_kind%carriage_return, & + & char_kind%hash, char_kind%rbrace, char_kind%rbracket, char_kind%comma) + token = toml_token(token_kind%int, prev, pos) + return + case default + do while(verify(peek(lexer, pos), terminated) > 0) + pos = pos + 1 + end do + token = toml_token(token_kind%invalid, prev, pos-1) + return + end select + end if + + + do while(pos <= len(lexer%chunk)) + ch = peek(lexer, pos) + if (ch == "_") then + if (underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (verify(ch, toml_base(base)) == 0) then + pos = pos + 1 + underscore = .false. + cycle + end if + + okay = okay .and. verify(ch, terminated) == 0 + exit + end do + + okay = .not.underscore .and. okay + token = toml_token(merge(token_kind%int, token_kind%invalid, okay), prev, pos-1) +end subroutine next_integer + +!> Process float tokens. +subroutine next_float(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + logical :: plus_minus, underscore, point, expo, okay, zero, first + character(1, tfc) :: ch + integer, parameter :: offset(*) = [0, 1, 2] + character(1, tfc), parameter :: nan(3) = ["n", "a", "n"], inf(3) = ["i", "n", "f"] + + prev = lexer%pos + pos = lexer%pos + point = .false. + expo = .false. + zero = .false. + first = .true. + underscore = .true. + plus_minus = any(match(lexer, pos, ["+", "-"])) + if (plus_minus) pos = pos + 1 + + if (match_all(lexer, pos+offset, nan) .and. & + & verify(peek(lexer, pos+3), terminated) == 0) then + token = toml_token(token_kind%float, prev, pos+2) + return + end if + + if (match_all(lexer, pos+offset, inf) .and. & + & verify(peek(lexer, pos+3), terminated) == 0) then + token = toml_token(token_kind%float, prev, pos+2) + return + end if + + do while(pos <= len(lexer%chunk)) + ch = peek(lexer, pos) + if (ch == "_") then + if (underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (ch == ".") then + if (point .or. expo .or. underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = .false. + underscore = .true. + point = .true. + pos = pos + 1 + cycle + end if + + if (ch == "e" .or. ch == "E") then + if (expo .or. underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = .false. + underscore = .true. + expo = .true. + pos = pos + 1 + cycle + end if + + if (ch == "+" .or. ch == "-") then + if (.not.any(match(lexer, pos-1, ["e", "E"]))) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (verify(ch, "0123456789") == 0) then + if (zero) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = first .and. ch == "0" + first = .false. + pos = pos + 1 + underscore = .false. + cycle + end if + + exit + end do + + okay = .not.underscore .and. (expo .or. point) + token = toml_token(merge(token_kind%float, token_kind%invalid, okay), prev, pos-1) +end subroutine next_float + +!> Find the next datetime expression +subroutine next_datetime(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + logical :: has_date, has_time, has_millisec, has_local, okay, has_seconds + integer :: prev, pos, it, time_len + integer, parameter :: offset(*) = [(it, it = 0, 10)], & + & offset_date = 10, offset_time = 8, offset_time_no_sec = 5, offset_local = 6 + character(*, tfc), parameter :: num = "0123456789" + + prev = lexer%pos + pos = lexer%pos + + has_date = valid_date(peek(lexer, pos+offset(:offset_date))) + if (has_date) then + if (verify(peek(lexer, pos+offset_date), "Tt ") == 0 & + & .and. pos + offset_date < len(lexer%chunk) & + & .and. verify(peek(lexer, pos+offset_date+1), num) == 0) then + pos = pos + offset_date + 1 + end if + end if + + ! Try to validate time - first with 8 characters (HH:MM:SS), then 5 (HH:MM) + call valid_time(peek(lexer, pos+offset(:offset_time)), has_time, has_seconds) + if (has_time) then + if (has_seconds) then + time_len = offset_time + else + time_len = offset_time_no_sec + end if + pos = pos + time_len - 1 + if (match(lexer, pos+1, char_kind%dot)) then + it = 1 + do while(verify(peek(lexer, pos+it+1), num) == 0) + it = it + 1 + end do + has_millisec = it > 1 + if (.not.has_millisec) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + + pos = pos + it + end if + + has_local = valid_local(peek(lexer, pos+offset(:offset_local)+1)) + if (has_local) then + if (.not.has_date) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + pos = pos + offset_local + else if (verify(peek(lexer, pos+1), "zZ") == 0) then + pos = pos + 1 + end if + end if + + if (.not.(has_time.or.has_date)) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + + if (.not.has_time.and.has_date) pos = pos + offset_date - 1 + okay = verify(peek(lexer, pos+1), terminated) == 0 .and. pos <= len(lexer%chunk) + token = toml_token(merge(token_kind%datetime, token_kind%invalid, okay), prev, pos) +end subroutine next_datetime + +!> Validate a string as date +pure function valid_date(string) result(valid) + !> Input string, 10 characters + character(1, tfc), intent(in) :: string(:) + !> Valid date + logical :: valid + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: year, month, day, mday + logical :: leap + + valid = .false. + if (any(string([5, 8]) /= "-")) return + + year = 0 + do it = 1, 4 + val = scan(num, string(it)) - 1 + if (val < 0) return + year = year * 10 + val + end do + + month = 0 + do it = 6, 7 + val = scan(num, string(it)) - 1 + if (val < 0) return + month = month * 10 + val + end do + + day = 0 + do it = 9, 10 + val = scan(num, string(it)) - 1 + if (val < 0) return + day = day * 10 + val + end do + + mday = 0 + select case(month) + case(1, 3, 5, 7, 8, 10, 12) + mday = 31 + case(2) + leap = mod(year, 4) == 0 .and. (mod(year, 100) /= 0 .or. mod(year, 400) == 0) + mday = merge(29, 28, leap) + case(4, 6, 9, 11) + mday = 30 + end select + valid = day >= 1 .and. day <= mday +end function valid_date + + +!> Validate a string as time (HH:MM or HH:MM:SS) +subroutine valid_time(string, valid, has_seconds) + !> Input string, 5 characters (HH:MM) or 8 characters (HH:MM:SS) + character(1, tfc), intent(in) :: string(:) + !> Valid time + logical, intent(out) :: valid + !> Whether the time has seconds + logical, intent(out) :: has_seconds + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: hour, minute, second + + valid = .false. + has_seconds = .false. + if (string(3) /= ":") return + + hour = 0 + do it = 1, 2 + val = scan(num, string(it)) - 1 + if (val < 0) return + hour = hour * 10 + val + end do + + minute = 0 + do it = 4, 5 + val = scan(num, string(it)) - 1 + if (val < 0) return + minute = minute * 10 + val + end do + + ! Check for seconds (optional in TOML 1.1) + if (size(string) >= 8 .and. string(6) == ":") then + second = 0 + do it = 7, 8 + val = scan(num, string(it)) - 1 + if (val < 0) return + second = second * 10 + val + end do + if (second < 0 .or. second >= 60) return + has_seconds = .true. + end if + + valid = minute >= 0 .and. minute < 60 & + & .and. hour >= 0 .and. hour < 24 +end subroutine valid_time + + +!> Validate a string as timezone +function valid_local(string) result(valid) + !> Input string, 6 characters + character(1, tfc), intent(in) :: string(:) + !> Valid timezone + logical :: valid + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: hour, minute + + valid = .false. + if (string(4) /= ":" .or. all(string(1) /= ["+", "-"])) return + + hour = 0 + do it = 2, 3 + val = scan(num, string(it)) - 1 + if (val < 0) return + hour = hour * 10 + val + end do + + minute = 0 + do it = 5, 6 + val = scan(num, string(it)) - 1 + if (val < 0) return + minute = minute * 10 + val + end do + + valid = minute >= 0 .and. minute < 60 & + & .and. hour >= 0 .and. hour < 24 +end function valid_local + + +!> Show current character +elemental function peek(lexer, pos) result(ch) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos + !> Character found + character(1, tfc) :: ch + + if (pos <= len(lexer%chunk)) then + ch = lexer%chunk(pos:pos) + else + ch = char_kind%space + end if +end function peek + +!> Compare a character +elemental function match(lexer, pos, kind) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos + !> Character to compare against + character(1, tfc), intent(in) :: kind + !> Characters match + logical :: match + + match = peek(lexer, pos) == kind +end function match + +!> Compare a set of characters +pure function match_all(lexer, pos, kind) result(match) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos(:) + !> Character to compare against + character(1, tfc), intent(in) :: kind(:) + !> Characters match + logical :: match + + match = all(peek(lexer, pos) == kind) +end function match_all + +pure function strstr(string, pattern) result(res) + character(*, tfc), intent(in) :: string + character(*, tfc), intent(in) :: pattern + integer :: lps_array(len(pattern)) + integer :: res, s_i, p_i, length_string, length_pattern + res = 0 + length_string = len(string) + length_pattern = len(pattern) + + if (length_pattern > 0 .and. length_pattern <= length_string) then + lps_array = compute_lps(pattern) + + s_i = 1 + p_i = 1 + do while(s_i <= length_string) + if (string(s_i:s_i) == pattern(p_i:p_i)) then + if (p_i == length_pattern) then + res = s_i - length_pattern + 1 + exit + end if + s_i = s_i + 1 + p_i = p_i + 1 + else if (p_i > 1) then + p_i = lps_array(p_i - 1) + 1 + else + s_i = s_i + 1 + end if + end do + end if + +contains + + pure function compute_lps(string) result(lps_array) + character(*, tfc), intent(in) :: string + integer :: lps_array(len(string)) + integer :: i, j, length_string + + length_string = len(string) + + if (length_string > 0) then + lps_array(1) = 0 + + i = 2 + j = 1 + do while (i <= length_string) + if (string(j:j) == string(i:i)) then + lps_array(i) = j + i = i + 1 + j = j + 1 + else if (j > 1) then + j = lps_array(j - 1) + 1 + else + lps_array(i) = 0 + i = i + 1 + end if + end do + end if + + end function compute_lps + +end function strstr + +!> Extract string value of token, works for keypath, string, multiline string, literal, +!> and mulitline literal tokens. +subroutine extract_string(lexer, token, string) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract string value from + type(toml_token), intent(in) :: token + !> String value of token + character(len=:), allocatable, intent(out) :: string + + integer :: it, length + logical :: escape, leading_newline + character(1, tfc) :: ch + + length = token%last - token%first + 1 + + select case(token%kind) + case(token_kind%string) + string = "" + escape = .false. + it = token%first + 1 + do while(it <= token%last - 1) + ch = peek(lexer, it) + if (escape) then + escape = .false. + select case(ch) + case("""", "\"); string = string // ch + case("b"); string = string // TOML_BACKSPACE + case("e"); string = string // TOML_ESC + case("t"); string = string // TOML_TABULATOR + case("n"); string = string // TOML_NEWLINE + case("r"); string = string // TOML_CARRIAGE_RETURN + case("f"); string = string // TOML_FORMFEED + case("x"); string = string // convert_ucs(lexer%chunk(it+1:it+2)); it = it + 3 + case("u"); string = string // convert_ucs(lexer%chunk(it+1:it+4)); it = it + 5 + case("U"); string = string // convert_ucs(lexer%chunk(it+1:it+8)); it = it + 9 + end select + else + escape = ch == char_kind%backslash + if (.not.escape) string = string // ch + end if + it = it + 1 + end do + case(token_kind%mstring) + leading_newline = peek(lexer, token%first+3) == char_kind%newline + string = "" + escape = .false. + it = token%first + merge(4, 3, leading_newline) + do while(it <= token%last - 3) + ch = peek(lexer, it) + if (escape) then + escape = .false. + select case(ch) + case("""", "\"); string = string // ch + case("b"); string = string // TOML_BACKSPACE + case("e"); string = string // TOML_ESC + case("t"); string = string // TOML_TABULATOR + case("n"); string = string // TOML_NEWLINE + case("r"); string = string // TOML_CARRIAGE_RETURN + case("f"); string = string // TOML_FORMFEED + case("x"); string = string // convert_ucs(lexer%chunk(it+1:it+2)); it = it + 3 + case("u"); string = string // convert_ucs(lexer%chunk(it+1:it+4)); it = it + 5 + case("U"); string = string // convert_ucs(lexer%chunk(it+1:it+8)); it = it + 9 + case(char_kind%space, char_kind%tab, char_kind%carriage_return) + escape = .true. + case(char_kind%newline) + continue + end select + else + escape = ch == char_kind%backslash + if (.not.escape) string = string // ch + end if + it = it + 1 + end do + case(token_kind%literal) + allocate(character(length - 2)::string) + string = lexer%chunk(token%first+1:token%last-1) + case(token_kind%mliteral) + leading_newline = peek(lexer, token%first+3) == char_kind%newline + allocate(character(length - merge(7, 6, leading_newline))::string) + string = lexer%chunk(token%first+merge(4, 3, leading_newline):token%last-3) + case(token_kind%keypath) + allocate(character(length)::string) + string = lexer%chunk(token%first:token%last) + end select + +end subroutine extract_string + +!> Extract integer value of token +subroutine extract_integer(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract integer value from + type(toml_token), intent(in) :: token + !> Integer value of token + integer(tfi), intent(out) :: val + + integer :: first, base, it, tmp + logical :: minus + character(1, tfc) :: ch + character(*, tfc), parameter :: num = "0123456789abcdef" + + if (token%kind /= token_kind%int) return + + val = 0 + base = 10 + first = token%first + + if (any(peek(lexer, first) == ["+", "-"])) first = first + 1 + + if (peek(lexer, first) == "0") then + select case(peek(lexer, first + 1)) + case("x") + first = first + 2 + base = 16 + case("o") + first = first + 2 + base = 8 + case("b") + first = first + 2 + base = 2 + case default + return + end select + end if + + minus = match(lexer, token%first, char_kind%minus) + + do it = first, token%last + ch = peek(lexer, it) + if ("A" <= ch .and. ch <= "Z") ch = achar(iachar(ch) - iachar("A") + iachar("a")) + tmp = scan(num(:abs(base)), ch) - 1 + if (tmp < 0) cycle + val = val * base + merge(-tmp, tmp, minus) + end do +end subroutine extract_integer + +!> Extract floating point value of token +subroutine extract_float(lexer, token, val) + ! Not useable since unsupported with GFortran on some platforms (MacOS/ppc) + ! use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quite_nan, & + ! & ieee_positive_inf, ieee_negative_inf + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract floating point value from + type(toml_token), intent(in) :: token + !> Floating point value of token + real(tfr), intent(out) :: val + + integer :: first, it, ic + character(len=token%last - token%first + 1) :: buffer + character(1, tfc) :: ch + + if (token%kind /= token_kind%float) return + + first = token%first + + if (any(peek(lexer, first) == ["+", "-"])) first = first + 1 + + if (match(lexer, first, "n")) then + ! val = ieee_value(val, ieee_quite_nan) + buffer = "NaN" + read(buffer, *, iostat=ic) val + return + end if + + if (match(lexer, first, "i")) then + ! val = ieee_value(val, ieee_positive_inf) + buffer = "Inf" + read(buffer, *, iostat=ic) val + if (match(lexer, token%first, char_kind%minus)) val = -val + return + end if + +! ival = 0 +! idot = 0 +! +! do it = first, token%last +! ch = peek(lexer, it) +! if (any(ch == [".", "e", "E"])) exit +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! ival = ival * base + tmp +! end do +! first = it +! +! if (ch == ".") then +! idot = 0 +! do it = first, token%last +! ch = peek(lexer, it) +! if (any(ch == ["e", "E"])) exit +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! idot = idot + 1 +! ival = ival * base + tmp +! end do +! first = it +! end if +! +! expo = 0 +! if (any(ch == ["e", "E"])) then +! first = first + 1 +! do it = first, token%last +! ch = peek(lexer, it) +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! expo = expo * base + tmp +! end do +! if (match(lexer, first, char_kind%minus)) expo = -expo +! end if +! expo = expo - idot +! val = ival * 10.0_tfr ** expo ! FIXME +! +! if (match(lexer, token%first, char_kind%minus)) val = -val + + ic = 0 + do it = token%first, token%last + ch = peek(lexer, it) + if (ch == "_") cycle + ic = ic + 1 + buffer(ic:ic) = ch + end do + + read(buffer(:ic), *, iostat=it) val +end subroutine extract_float + +!> Extract boolean value of token +subroutine extract_bool(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract boolean value from + type(toml_token), intent(in) :: token + !> Boolean value of token + logical, intent(out) :: val + + if (token%kind /= token_kind%bool) return + + val = peek(lexer, token%first) == "t" +end subroutine extract_bool + +!> Extract datetime value of token +subroutine extract_datetime(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract datetime value from + type(toml_token), intent(in) :: token + !> Datetime value of token + type(toml_datetime), intent(out) :: val + + if (token%kind /= token_kind%datetime) return + + val = toml_datetime(lexer%chunk(token%first:token%last)) +end subroutine extract_datetime + + +!> Push a new scope onto the lexer stack and record the token +pure subroutine push_back(lexer, scope, token) + type(toml_lexer), intent(inout) :: lexer + integer, intent(in) :: scope + integer, intent(in) :: token + + lexer%top = lexer%top + 1 + if (lexer%top > size(lexer%stack)) call resize(lexer%stack) + lexer%stack(lexer%top) = stack_item(scope, token) +end subroutine push_back + +!> Pop a scope from the lexer stack in case the topmost scope matches the requested scope +subroutine pop(lexer, scope) + type(toml_lexer), intent(inout) :: lexer + integer, intent(in) :: scope + + if (lexer%top > 0) then + if (lexer%stack(lexer%top)%scope == scope) lexer%top = lexer%top - 1 + end if +end subroutine pop + +!> Peek at the topmost scope on the lexer stack +pure function view_scope(lexer) result(scope) + type(toml_lexer), intent(in) :: lexer + integer :: scope + + if (lexer%top > 0) then + scope = lexer%stack(lexer%top)%scope + else + scope = lexer_scope%table + end if +end function view_scope + + +!> Reallocate list of scopes +pure subroutine resize_scope(var, n) + !> Instance of the array to be resized + type(stack_item), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(stack_item), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 8 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate(tmp) + end if + +end subroutine resize_scope + + +!> Extract information about the source +subroutine get_info(lexer, meta, output) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Query about the source + character(*, tfc), intent(in) :: meta + !> Metadata about the source + character(:, tfc), allocatable, intent(out) :: output + + select case(meta) + case("source") + output = lexer%chunk // TOML_NEWLINE + case("filename") + if (allocated(lexer%filename)) output = lexer%filename + end select +end subroutine get_info + + +function hex_to_int(hex) result(val) + character(*, tfc), intent(in) :: hex + integer(tfi) :: val + integer :: i + character(1, tfc) :: ch + character(*, tfc), parameter :: hex_digits = "0123456789abcdef" + + val = 0_tfi + do i = 1, len(hex) + ch = hex(i:i) + if ("A" <= ch .and. ch <= "Z") ch = achar(iachar(ch) - iachar("A") + iachar("a")) + val = val * 16 + max(index(hex_digits, ch) - 1, 0) + end do +end function hex_to_int + + +function verify_ucs(escape) result(valid) + character(*, tfc), intent(in) :: escape + logical :: valid + integer(tfi) :: code + + code = hex_to_int(escape) + + valid = code > 0 .and. code < int(z"7FFFFFFF", tfi) & + & .and. (code < int(z"d800", tfi) .or. code > int(z"dfff", tfi)) & + & .and. (code < int(z"fffe", tfi) .or. code > int(z"ffff", tfi)) +end function verify_ucs + + +function convert_ucs(escape) result(str) + character(*, tfc), intent(in) :: escape + character(:, tfc), allocatable :: str + integer(tfi) :: code + + code = hex_to_int(escape) + + select case(code) + case(int(z"00000000", tfi):int(z"0000007f", tfi)) + str = achar(code, kind=tfc) + case(int(z"00000080", tfi):int(z"000007ff", tfi)) + str = & + achar(ior(int(z"c0", tfi), ishft(code, -6)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00000800", tfi):int(z"0000ffff", tfi)) + str = & + achar(ior(int(z"e0", tfi), ishft(code, -12)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00010000", tfi):int(z"001fffff", tfi)) + str = & + achar(ior(int(z"f0", tfi), ishft(code, -18)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00200000", tfi):int(z"03ffffff", tfi)) + str = & + achar(ior(int(z"f8", tfi), ishft(code, -24)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -18), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"04000000", tfi):int(z"7fffffff", tfi)) + str = & + achar(ior(int(z"fc", tfi), ishft(code, -30)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -24), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -18), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + end select +end function convert_ucs + + +end module tomlf_de_lexer diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/parser.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/parser.f90 new file mode 100644 index 000000000..564ab8423 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/parser.f90 @@ -0,0 +1,862 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a parser for transforming a token stream to TOML datastructures. +module tomlf_de_parser + use tomlf_constants, only : tfc, tfr, tfi, TOML_NEWLINE + use tomlf_datetime, only : toml_datetime + use tomlf_de_context, only : toml_context + use tomlf_de_abc, only : toml_lexer => abstract_lexer + use tomlf_de_token, only : toml_token, token_kind, stringify + use tomlf_diagnostic, only : render, toml_diagnostic, toml_label, toml_level + use tomlf_terminal, only : toml_terminal + use tomlf_error, only : toml_error, toml_stat + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_value, toml_key, & + & add_table, add_array, add_keyval, cast_to_table, cast_to_array, len + implicit none + private + + public :: toml_parser, toml_parser_config, parse + + + !> Configuration of the TOML parser + type :: toml_parser_config + !> Use colorful output for diagnostics + type(toml_terminal) :: color = toml_terminal() + !> Record all tokens + integer :: context_detail = 0 + end type toml_parser_config + + interface toml_parser_config + module procedure :: new_parser_config + end interface toml_parser_config + + !> TOML parser + type :: toml_parser + !> Current token + type(toml_token) :: token + !> Table containing the document root + type(toml_table), allocatable :: root + !> Pointer to the currently processed table + type(toml_table), pointer :: current + !> Diagnostic produced while parsing + type(toml_diagnostic), allocatable :: diagnostic + !> Context for producing diagnostics + type(toml_context) :: context + !> Configuration of the parser + type(toml_parser_config) :: config + end type toml_parser + +contains + +!> Create a new instance of the TOML parser +subroutine new_parser(parser, config) + !> Instance of the parser + type(toml_parser), intent(out), target :: parser + !> Configuration of the parser + type(toml_parser_config), intent(in), optional :: config + + parser%token = toml_token(token_kind%newline, 0, 0) + parser%root = toml_table() + parser%current => parser%root + parser%config = toml_parser_config() + if (present(config)) parser%config = config +end subroutine new_parser + +!> Create new configuration for the TOML parser +pure function new_parser_config(color, context_detail) result(config) + !> Configuration of the parser + type(toml_parser_config) :: config + !> Color support for diagnostics + logical, intent(in), optional :: color + !> Record all tokens + integer, intent(in), optional :: context_detail + + if (present(color)) config%color = toml_terminal(color) + if (present(context_detail)) config%context_detail = context_detail +end function new_parser_config + +!> Parse TOML document and return root table +subroutine parse(lexer, table, config, context, error) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> TOML data structure + type(toml_table), allocatable, intent(out) :: table + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handler + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_parser) :: parser + + call new_parser(parser, config) + call parse_root(parser, lexer) + + if (present(error) .and. allocated(parser%diagnostic)) then + call make_error(error, parser%diagnostic, lexer, parser%config%color) + end if + if (allocated(parser%diagnostic)) return + + call move_alloc(parser%root, table) + + if (present(context)) then + context = parser%context + call lexer%get_info("filename", context%filename) + call lexer%get_info("source", context%source) + end if +end subroutine parse + +!> Parse the root table +subroutine parse_root(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + do while(.not.allocated(parser%diagnostic) .and. parser%token%kind /= token_kind%eof) + select case(parser%token%kind) + case(token_kind%newline, token_kind%whitespace, token_kind%comment) + call next_token(parser, lexer) + + case(token_kind%keypath, token_kind%string, token_kind%literal) + call parse_keyval(parser, lexer, parser%current) + + case(token_kind%lbracket) + call parse_table_header(parser, lexer) + + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax", & + & "unexpected "//stringify(parser%token)) + end select + end do +end subroutine parse_root + + +!> Parse a table or array of tables header +subroutine parse_table_header(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + type(toml_array), pointer :: array + type(toml_table), pointer :: table + class(toml_value), pointer :: ptr + type(toml_key) :: key + logical :: array_of_tables + + integer, parameter :: initial_size = 8 + integer :: top + type(toml_key), allocatable :: stack(:) + type(toml_token), allocatable :: leading_whitespace, trailing_whitespace + + + call consume(parser, lexer, token_kind%lbracket) + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) then + leading_whitespace = parser%token + call next_token(parser, lexer) + end if + + array_of_tables = parser%token%kind == token_kind%lbracket + + if (array_of_tables) then + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) then + call next_token(parser, lexer) + end if + end if + + call fill_stack(lexer, parser, top, stack) + if (allocated(parser%diagnostic)) return + + key = stack(top) + top = top - 1 + + call walk_stack(parser, top, stack) + + if (array_of_tables) then + call parser%current%get(key%key, ptr) + if (associated(ptr)) then + array => cast_to_array(ptr) + if (.not.associated(array)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + if (array%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(array%origin), & + & "Array of tables cannot extend inline array", & + & "extended here", & + & "defined as inline") + return + end if + else + call add_array(parser%current, key, array) + array%inline = .false. + end if + call add_table(array, table) + else + call parser%current%get(key%key, ptr) + if (associated(ptr)) then + table => cast_to_table(ptr) + if (associated(table)) then + if (.not.table%implicit) nullify(table) + end if + + if (.not.associated(table)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + else + call add_table(parser%current, key, table) + end if + end if + + parser%current => table + + call consume(parser, lexer, token_kind%rbracket) + if (allocated(parser%diagnostic)) return + + if (array_of_tables) then + if (parser%token%kind == token_kind%whitespace) then + trailing_whitespace = parser%token + call next_token(parser, lexer) + end if + call consume(parser, lexer, token_kind%rbracket) + if (allocated(parser%diagnostic)) return + end if + + if (array_of_tables .and. allocated(leading_whitespace)) then + call syntax_error(parser%diagnostic, lexer, leading_whitespace, & + & "Malformatted array of table header encountered", & + & "whitespace not allowed in header") + return + end if + + if (array_of_tables .and. allocated(trailing_whitespace)) then + call syntax_error(parser%diagnostic, lexer, trailing_whitespace, & + & "Malformatted array of table header encountered", & + & "whitespace not allowed in header") + return + end if + + do while(parser%token%kind == token_kind%whitespace) + call next_token(parser, lexer) + end do + + if (parser%token%kind == token_kind%comment) then + call next_token(parser, lexer) + end if + + if (all(parser%token%kind /= [token_kind%newline, token_kind%eof])) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Unexpected "//stringify(parser%token)//" after table header", & + & "expected newline") + end if + +contains + + !> Fill the stack with tokens + subroutine fill_stack(lexer, parser, top, stack) + class(toml_lexer), intent(inout) :: lexer + type(toml_parser), intent(inout) :: parser + !> Depth of the table key stack + integer, intent(out) :: top + !> Stack of all keys in the table header + type(toml_key), allocatable, intent(out) :: stack(:) + + top = 0 + allocate(stack(initial_size)) + + do + if (top >= size(stack)) then + call resize(stack) + end if + + if (all(parser%token%kind /= [token_kind%string, token_kind%literal, & + & token_kind%keypath])) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Missing key for table header", & + & "unexpected "//stringify(parser%token)) + return + end if + + top = top + 1 + call extract_key(parser, lexer, stack(top)) + + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + & call next_token(parser, lexer) + + if (parser%token%kind == token_kind%rbracket) exit + + call consume(parser, lexer, token_kind%dot) + if (allocated(parser%diagnostic)) return + if (parser%token%kind == token_kind%whitespace) & + & call next_token(parser, lexer) + end do + + if (top <= 0) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Empty table header", & + & "expected table header") + end if + + end subroutine fill_stack + + !> Walk the key stack to fetch the correct table, create implicit tables as necessary + subroutine walk_stack(parser, top, stack) + type(toml_parser), intent(inout), target :: parser + !> Depth of the table key stack + integer, intent(in) :: top + !> Stack of all keys in the table header + type(toml_key), intent(in), target :: stack(:) + + type(toml_table), pointer :: table, tmp_tbl + type(toml_array), pointer :: array + type(toml_key), pointer :: key + class(toml_value), pointer :: ptr + integer :: it + + table => parser%root + + do it = 1, top + key => stack(it) + + if (.not.table%has_key(key%key)) then + call add_table(table, key, tmp_tbl) + if (associated(tmp_tbl)) then + tmp_tbl%implicit = .true. + end if + end if + call table%get(key%key, ptr) + + table => cast_to_table(ptr) + if (.not.associated(table)) then + array => cast_to_array(ptr) + if (associated(array)) then + call array%get(len(array), ptr) + table => cast_to_table(ptr) + end if + if (.not.associated(table)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + end if + + if (table%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(table%origin), & + & "Inline table '"//key%key//"' cannot be used as a key", & + & "inline table cannot be extended", & + & "defined as inline first") + end if + end do + + parser%current => table + end subroutine walk_stack + + !> Change size of the stack + subroutine resize(stack, n) + !> Stack of keys to be resized + type(toml_key), allocatable, intent(inout) :: stack(:) + !> New size of the stack + integer, intent(in), optional :: n + + type(toml_key), allocatable :: tmp(:) + integer :: m + + if (present(n)) then + m = n + else + if (allocated(stack)) then + m = size(stack) + m = m + m/2 + 1 + else + m = initial_size + end if + end if + + if (allocated(stack)) then + call move_alloc(stack, tmp) + allocate(stack(m)) + + m = min(size(tmp), m) + stack(:m) = tmp(:m) + + deallocate(tmp) + else + allocate(stack(m)) + end if + end subroutine resize + +end subroutine parse_table_header + +!> Parse key value pairs in a table body +recursive subroutine parse_keyval(parser, lexer, table) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current table + type(toml_table), intent(inout) :: table + + class(toml_value), pointer :: ptr + type(toml_keyval), pointer :: vptr + type(toml_array), pointer :: aptr + type(toml_table), pointer :: tptr + type(toml_key) :: key + + call extract_key(parser, lexer, key) + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (parser%token%kind == token_kind%dot) then + call get_table(table, key, tptr) + if (tptr%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(tptr%origin), & + & "Cannot add keys to inline tables", & + & "inline table cannot be extended", & + & "defined as inline first") + return + end if + + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (any(parser%token%kind == [token_kind%keypath, token_kind%string, & + & token_kind%literal])) then + call parse_keyval(parser, lexer, tptr) + else + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax", & + & "expected key") + end if + return + end if + + call consume(parser, lexer, token_kind%equal) + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + call table%get(key%key, ptr) + if (associated(ptr)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + + select case(parser%token%kind) + case default + call add_keyval(table, key, vptr) + call parse_value(parser, lexer, vptr) + + case(token_kind%nil) + call next_token(parser, lexer) + + case(token_kind%lbracket) + call add_array(table, key, aptr) + call parse_inline_array(parser, lexer, aptr) + + case(token_kind%lbrace) + call add_table(table, key, tptr) + call parse_inline_table(parser, lexer, tptr) + + end select + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (parser%token%kind == token_kind%comment) & + call next_token(parser, lexer) +end subroutine parse_keyval + +recursive subroutine parse_inline_array(parser, lexer, array) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current array + type(toml_array), intent(inout) :: array + + type(toml_keyval), pointer :: vptr + type(toml_array), pointer :: aptr + type(toml_table), pointer :: tptr + integer, parameter :: skip_tokens(*) = & + [token_kind%whitespace, token_kind%comment, token_kind%newline] + + array%inline = .true. + call consume(parser, lexer, token_kind%lbracket) + + inline_array: do while(.not.allocated(parser%diagnostic)) + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + select case(parser%token%kind) + case(token_kind%rbracket) + exit inline_array + + case default + call add_keyval(array, vptr) + call parse_value(parser, lexer, vptr) + + case(token_kind%nil) + call next_token(parser, lexer) + + case(token_kind%lbracket) + call add_array(array, aptr) + call parse_inline_array(parser, lexer, aptr) + + case(token_kind%lbrace) + call add_table(array, tptr) + call parse_inline_table(parser, lexer, tptr) + + end select + if (allocated(parser%diagnostic)) exit inline_array + + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + if (parser%token%kind == token_kind%comma) then + call next_token(parser, lexer) + cycle inline_array + end if + exit inline_array + end do inline_array + if (allocated(parser%diagnostic)) return + + call consume(parser, lexer, token_kind%rbracket) +end subroutine parse_inline_array + +recursive subroutine parse_inline_table(parser, lexer, table) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current table + type(toml_table), intent(inout) :: table + + integer, parameter :: skip_tokens(*) = & + [token_kind%whitespace, token_kind%comment, token_kind%newline] + + table%inline = .true. + call consume(parser, lexer, token_kind%lbrace) + + inline_table: do while(.not.allocated(parser%diagnostic)) + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + select case(parser%token%kind) + case(token_kind%rbrace) + exit inline_table + + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid character in inline table", & + & "unexpected "//stringify(parser%token)) + + case(token_kind%keypath, token_kind%string, token_kind%literal) + call parse_keyval(parser, lexer, table) + + end select + if (allocated(parser%diagnostic)) exit inline_table + + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + if (parser%token%kind == token_kind%comma) then + call next_token(parser, lexer) + cycle inline_table + end if + exit inline_table + end do inline_table + if (allocated(parser%diagnostic)) return + + call consume(parser, lexer, token_kind%rbrace) +end subroutine parse_inline_table + +subroutine parse_value(parser, lexer, kval) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current key value pair + type(toml_keyval), intent(inout) :: kval + + select case(parser%token%kind) + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid expression for value", & + & "unexpected "//stringify(parser%token)) + + case(token_kind%unclosed) + ! Handle runaway expressions separately + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Inline expression contains unclosed or runaway group", & + & "unclosed inline expression") + + case(token_kind%string, token_kind%mstring, token_kind%literal, token_kind%mliteral, & + & token_kind%int, token_kind%float, token_kind%bool, token_kind%datetime) + call extract_value(parser, lexer, kval) + + call next_token(parser, lexer) + end select +end subroutine parse_value + +!> Check whether the current token is the expected one and advance the lexer +subroutine consume(parser, lexer, kind) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Expected token kind + integer, intent(in) :: kind + + if (parser%token%kind /= kind) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax in this context", & + & "expected "//stringify(toml_token(kind))) + return + end if + + call next_token(parser, lexer) +end subroutine consume + +!> Create diagnostic for invalid syntax +subroutine syntax_error(diagnostic, lexer, token, message, label) + !> Diagnostic for the syntax error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token that caused the error + type(toml_token), intent(in) :: token + !> Message for the error + character(len=*), intent(in) :: message + !> Label for the token + character(len=*), intent(in) :: label + + character(:, tfc), allocatable :: filename + + call lexer%get_info("filename", filename) + + allocate(diagnostic) + diagnostic = toml_diagnostic( & + & toml_level%error, & + & message, & + & filename, & + & [toml_label(toml_level%error, token%first, token%last, label, .true.)]) +end subroutine syntax_error + +!> Create diagnostic for incorrect semantics +subroutine semantic_error(diagnostic, lexer, token1, token2, message, label1, label2) + !> Diagnostic for the duplicate key error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token identifying the duplicate key + type(toml_token), intent(in) :: token1 + !> Token identifying the original key + type(toml_token), intent(in) :: token2 + !> Message for the error + character(len=*), intent(in) :: message + !> Label for the first token + character(len=*), intent(in) :: label1 + !> Label for the second token + character(len=*), intent(in) :: label2 + + character(:, tfc), allocatable :: filename + + call lexer%get_info("filename", filename) + + allocate(diagnostic) + diagnostic = toml_diagnostic( & + & toml_level%error, & + & message, & + & filename, & + & [toml_label(toml_level%error, token1%first, token1%last, label1, .true.), & + & toml_label(toml_level%info, token2%first, token2%last, label2, .false.)]) +end subroutine semantic_error + +!> Create a diagnostic for a duplicate key entry +subroutine duplicate_key_error(diagnostic, lexer, token1, token2, message) + !> Diagnostic for the duplicate key error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token identifying the duplicate key + type(toml_token), intent(in) :: token1 + !> Token identifying the original key + type(toml_token), intent(in) :: token2 + !> Message for the error + character(len=*), intent(in) :: message + + call semantic_error(diagnostic, lexer, token1, token2, & + & message, "key already used", "first defined here") +end subroutine duplicate_key_error + +!> Create an error from a diagnostic +subroutine make_error(error, diagnostic, lexer, color) + !> Error to be created + type(toml_error), allocatable, intent(out) :: error + !> Diagnostic to be used + type(toml_diagnostic), intent(in) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(in) :: lexer + !> Use colorful error messages + type(toml_terminal), intent(in) :: color + + character(len=:), allocatable :: str + + allocate(error) + call lexer%get_info("source", str) + error%message = render(diagnostic, str, color) + error%stat = toml_stat%fatal +end subroutine make_error + +!> Wrapper around the lexer to retrieve the next token. +!> Allows to record the tokens for keys and values in the parser context +subroutine next_token(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + call lexer%next(parser%token) + + select case(parser%token%kind) + case(token_kind%keypath, token_kind%string, token_kind%literal, token_kind%int, & + & token_kind%float, token_kind%bool, token_kind%datetime) + call parser%context%push_back(parser%token) + case(token_kind%newline, token_kind%dot, token_kind%comma, token_kind%equal, & + & token_kind%lbrace, token_kind%rbrace, token_kind%lbracket, token_kind%rbracket) + if (parser%config%context_detail > 0) & + call parser%context%push_back(parser%token) + case default + if (parser%config%context_detail > 1) & + call parser%context%push_back(parser%token) + end select +end subroutine next_token + +!> Extract key from token +subroutine extract_key(parser, lexer, key) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Key to be extracted + type(toml_key), intent(out) :: key + + call lexer%extract(parser%token, key%key) + key%origin = parser%context%top + if (scan(key%key, TOML_NEWLINE) > 0) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid character in key", & + & "key cannot contain newline") + return + end if +end subroutine extract_key + +!> Extract value from token +subroutine extract_value(parser, lexer, kval) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Value to be extracted + type(toml_keyval), intent(inout) :: kval + + character(:, tfc), allocatable :: sval + real(tfr) :: rval + integer(tfi) :: ival + logical :: bval + type(toml_datetime) :: dval + + kval%origin_value = parser%context%top + + select case(parser%token%kind) + case(token_kind%string, token_kind%literal, token_kind%mstring, token_kind%mliteral) + call lexer%extract_string(parser%token, sval) + call kval%set(sval) + + case(token_kind%int) + call lexer%extract_integer(parser%token, ival) + call kval%set(ival) + + case(token_kind%float) + call lexer%extract_float(parser%token, rval) + call kval%set(rval) + + case(token_kind%bool) + call lexer%extract_bool(parser%token, bval) + call kval%set(bval) + + case(token_kind%datetime) + call lexer%extract_datetime(parser%token, dval) + call kval%set(dval) + end select +end subroutine extract_value + +!> Try to retrieve TOML table with key or create it +subroutine get_table(table, key, ptr, stat) + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + !> Key for the new table + type(toml_key), intent(in) :: key + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), pointer :: tmp + + nullify(ptr) + call table%get(key%key, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) stat = merge(toml_stat%success, toml_stat%fatal, associated(ptr)) + else + call add_table(table, key, ptr, stat) + end if +end subroutine get_table + +end module tomlf_de_parser diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/token.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/token.f90 new file mode 100644 index 000000000..34d12a509 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/token.f90 @@ -0,0 +1,163 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides a definition for a token +module tomlf_de_token + implicit none + private + + public :: toml_token, stringify, token_kind, resize + + + !> Possible token kinds + type :: enum_token + !> Invalid token found + integer :: invalid = -1 + !> End of file + integer :: eof = -2 + !> Unclosed group from inline table or array + integer :: unclosed = -3 + !> Whitespace (space, tab) + integer :: whitespace = 0 + !> Newline character (\r\n, \n) + integer :: newline = 1 + !> Comments (#) + integer :: comment = 2 + !> Separator in table path (.) + integer :: dot = 3 + !> Separator in inline arrays and inline tables (,) + integer :: comma = 4 + !> Separator in key-value pairs (=) + integer :: equal = 5 + !> Beginning of an inline table ({) + integer :: lbrace = 6 + !> End of an inline table (}) + integer :: rbrace = 7 + !> Beginning of an inline array or table header ([) + integer :: lbracket = 8 + !> End of an inline array or table header (]) + integer :: rbracket = 9 + !> String literal + integer :: string = 10 + !> String literal + integer :: mstring = 11 + !> String literal + integer :: literal = 12 + !> String literal + integer :: mliteral = 13 + !> String literal + integer :: keypath = 14 + !> Floating point value + integer :: float = 15 + !> Integer value + integer :: int = 16 + !> Boolean value + integer :: bool = 17 + !> Datetime value + integer :: datetime = 18 + !> Absence of value + integer :: nil = 19 + end type enum_token + + !> Actual enumerator for token kinds + type(enum_token), parameter :: token_kind = enum_token() + + !> Token containing + type :: toml_token + !> Kind of token + integer :: kind = token_kind%newline + !> Starting position of the token in character stream + integer :: first = 0 + !> Last position of the token in character stream + integer :: last = 0 + !> Identifier for the chunk index in case of buffered reading + integer :: chunk = 0 + end type toml_token + + !> Reallocate a list of tokens + interface resize + module procedure :: resize_token + end interface + +contains + +!> Reallocate list of tokens +pure subroutine resize_token(var, n) + !> Instance of the array to be resized + type(toml_token), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(toml_token), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 8 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate(tmp) + end if + +end subroutine resize_token + +!> Represent a token as string +pure function stringify(token) result(str) + !> Token to represent as string + type(toml_token), intent(in) :: token + !> String representation of token + character(len=:), allocatable :: str + + select case(token%kind) + case default; str = "unknown" + case(token_kind%invalid); str = "invalid sequence" + case(token_kind%eof); str = "end of file" + case(token_kind%unclosed); str = "unclosed group" + case(token_kind%whitespace); str = "whitespace" + case(token_kind%comment); str = "comment" + case(token_kind%newline); str = "newline" + case(token_kind%dot); str = "dot" + case(token_kind%comma); str = "comma" + case(token_kind%equal); str = "equal" + case(token_kind%lbrace); str = "opening brace" + case(token_kind%rbrace); str = "closing brace" + case(token_kind%lbracket); str = "opening bracket" + case(token_kind%rbracket); str = "closing bracket" + case(token_kind%string); str = "string" + case(token_kind%mstring); str = "multiline string" + case(token_kind%literal); str = "literal" + case(token_kind%mliteral); str = "multiline-literal" + case(token_kind%keypath); str = "keypath" + case(token_kind%int); str = "integer" + case(token_kind%float); str = "float" + case(token_kind%bool); str = "bool" + case(token_kind%datetime); str = "datetime" + case(token_kind%nil); str = "nil" + end select +end function stringify + +end module tomlf_de_token diff --git a/source/third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 b/source/third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 new file mode 100644 index 000000000..5d9ca0ae6 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 @@ -0,0 +1,461 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Diagnostic message support for TOML Fortran +module tomlf_diagnostic + use tomlf_terminal, only : toml_terminal, ansi_code, operator(//), operator(+) + implicit none + private + + public :: render + public :: toml_diagnostic, toml_label + + + interface render + module procedure render_diagnostic + module procedure render_text + module procedure render_text_with_label + module procedure render_text_with_labels + end interface render + + + !> Enumerator for diagnostic levels + type :: level_enum + integer :: error = 0 + integer :: warning = 1 + integer :: help = 2 + integer :: note = 3 + integer :: info = 4 + end type level_enum + + !> Actual enumerator values + type(level_enum), parameter, public :: toml_level = level_enum() + + + type toml_label + !> Level of message + integer :: level + !> Primary message + logical :: primary + !> First and last character of message + integer :: first, last + !> Message text + character(len=:), allocatable :: text + !> Identifier of context + character(len=:), allocatable :: source + end type toml_label + + interface toml_label + module procedure new_label + end interface toml_label + + + !> Definition of diagnostic message + type :: toml_diagnostic + !> Level of message + integer :: level + !> Primary message + character(len=:), allocatable :: message + !> Context of the diagnostic source + character(len=:), allocatable :: source + !> Messages associated with this diagnostic + type(toml_label), allocatable :: label(:) + end type toml_diagnostic + + interface toml_diagnostic + module procedure new_diagnostic + end interface toml_diagnostic + + + type :: line_token + integer :: first, last + end type line_token + + character(len=*), parameter :: nl = new_line('a') + + +contains + + +pure function new_label(level, first, last, text, primary) result(new) + integer, intent(in) :: level + integer, intent(in) :: first, last + character(len=*), intent(in), optional :: text + logical, intent(in), optional :: primary + type(toml_label) :: new + + if (present(text)) new%text = text + new%level = level + new%first = first + new%last = last + if (present(primary)) then + new%primary = primary + else + new%primary = .false. + end if +end function new_label + + +!> Create new diagnostic message +pure function new_diagnostic(level, message, source, label) result(new) + !> Level of message + integer, intent(in) :: level + !> Primary message + character(len=*), intent(in), optional :: message + !> Context of the diagnostic source + character(len=*), intent(in), optional :: source + !> Messages associated with this diagnostic + type(toml_label), intent(in), optional :: label(:) + type(toml_diagnostic) :: new + + new%level = level + if (present(message)) new%message = message + if (present(source)) new%source = source + if (present(label)) new%label = label +end function new_diagnostic + + +pure function line_tokens(input) result(token) + character(len=*), intent(in) :: input + type(line_token), allocatable :: token(:) + + integer :: first, last + + first = 1 + last = 1 + allocate(token(0)) + do while (first <= len(input)) + if (input(last:last) /= nl) then + last = last + 1 + cycle + end if + + token = [token, line_token(first, last-1)] + first = last + 1 + last = first + end do +end function line_tokens + +recursive pure function render_diagnostic(diag, input, color) result(string) + character(len=*), intent(in) :: input + type(toml_diagnostic), intent(in) :: diag + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + render_message(diag%level, diag%message, color) + + if (allocated(diag%label)) then + string = string // nl // & + render_text_with_labels(input, diag%label, color, source=diag%source) + end if +end function render_diagnostic + +pure function render_message(level, message, color) result(string) + integer, intent(in) :: level + character(len=*), intent(in), optional :: message + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + if (present(message)) then + string = & + level_name(level, color) // color%bold // ": " // message // color%reset + else + string = & + level_name(level, color) + end if +end function render_message + +pure function level_name(level, color) result(string) + integer, intent(in) :: level + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + select case(level) + case(toml_level%error) + string = color%bold + color%red // "error" // color%reset + case(toml_level%warning) + string = color%bold + color%yellow // "warning" // color%reset + case(toml_level%help) + string = color%bold + color%cyan // "help" // color%reset + case(toml_level%note) + string = color%bold + color%blue // "note" // color%reset + case(toml_level%info) + string = color%bold + color%magenta // "info" // color%reset + case default + string = color%bold + color%blue // "unknown" // color%reset + end select +end function level_name + +pure function render_source(source, offset, color) result(string) + character(len=*), intent(in) :: source + integer, intent(in) :: offset + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + & repeat(" ", offset) // (color%bold + color%blue) // "-->" // color%reset // " " // source +end function render_source + +function render_text(input, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, offset + type(line_token), allocatable :: token(:) + + allocate(token(0)) ! avoid compiler warning + token = line_tokens(input) + offset = integer_width(size(token)) + + if (present(source)) then + string = render_source(source, offset, color) // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + else + string = & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + end if + + do it = 1, size(token) + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), to_string(it, offset), color) + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text + +function render_text_with_label(input, label, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_label), intent(in) :: label + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, offset, first, last, line, shift + type(line_token), allocatable :: token(:) + + allocate(token(0)) ! avoid compiler warning + token = line_tokens(input) + line = count(token%first < label%first) + shift = token(line)%first - 1 + first = max(1, line - 1) + last = min(size(token), line + 1) + offset = integer_width(last) + + if (present(source)) then + string = render_source(source, offset, color) // ":" // & + & to_string(line) // ":" // & + & to_string(label%first) + if (label%first /= label%last) then + string = string // "-" // to_string(label%last) + end if + end if + string = string // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + + do it = first, last + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), & + & to_string(it, offset), color) + if (it == line) then + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset // & + & render_label(label, shift, color) + end if + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text_with_label + +pure function render_text_with_labels(input, label, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_label), intent(in) :: label(:) + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, il, offset, first, last, line(size(label)), shift(size(label)) + type(line_token), allocatable :: token(:) + logical, allocatable :: display(:) + + allocate(token(0)) ! avoid compiler warning + allocate(character(len=0) :: string) ! Allocate to avoid referencing an unallocated variable + token = line_tokens(input) + line(:) = [(count(token%first <= label(it)%first), it = 1, size(label))] + shift(:) = token(line)%first - 1 + first = max(1, minval(line)) + last = min(size(token), maxval(line)) + offset = integer_width(last) + + it = 1 ! Without a primary we use the first label + do il = 1, size(label) + if (label(il)%primary) then + it = il + exit + end if + end do + + if (present(source)) then + string = render_source(source, offset, color) // ":" // & + & to_string(line(it)) // ":" // & + & to_string(label(it)%first-shift(it)) + if (label(it)%first /= label(it)%last) then + string = string // "-" // to_string(label(it)%last-shift(it)) + end if + end if + string = string // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + + allocate(display(first:last), source=.false.) + do il = 1, size(label) + ! display(max(first, line(il) - 1):min(last, line(il) + 1)) = .true. + display(line(il)) = .true. + end do + + do it = first, last + if (.not.display(it)) then + if (display(it-1) .and. count(display(it:)) > 0) then + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // ":" // color%reset + end if + cycle + end if + + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), & + & to_string(it, offset), color) + if (any(it == line)) then + do il = 1, size(label) + if (line(il) /= it) cycle + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset // & + & render_label(label(il), shift(il), color) + end do + end if + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text_with_labels + +pure function render_label(label, shift, color) result(string) + type(toml_label), intent(in) :: label + integer, intent(in) :: shift + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + integer :: width + character :: marker + type(ansi_code) :: this_color + + marker = merge("^", "-", label%primary) + width = label%last - label%first + 1 + this_color = level_color(label%level, color) + + string = & + & repeat(" ", label%first - shift) // this_color // repeat(marker, width) // color%reset + if (allocated(label%text)) then + string = string // & + & " " // this_color // label%text // color%reset + end if + +end function render_label + +pure function level_color(level, color) result(this_color) + integer, intent(in) :: level + type(toml_terminal), intent(in) :: color + type(ansi_code) :: this_color + + select case(level) + case(toml_level%error) + this_color = color%bold + color%red + case(toml_level%warning) + this_color = color%bold + color%yellow + case(toml_level%help) + this_color = color%bold + color%cyan + case(toml_level%info) + this_color = color%bold + color%magenta + case default + this_color = color%bold + color%blue + end select +end function level_color + +pure function render_line(input, line, color) result(string) + character(len=*), intent(in) :: input + character(len=*), intent(in) :: line + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + & line // " " // (color%bold + color%blue) // "|" // color%reset // " " // input +end function render_line + +pure function integer_width(input) result(width) + integer, intent(in) :: input + integer :: width + + integer :: val + + val = input + width = 0 + do while (val /= 0) + val = val / 10 + width = width + 1 + end do + +end function integer_width + +!> Represent an integer as character sequence. +pure function to_string(val, width) result(string) + integer, intent(in) :: val + integer, intent(in), optional :: width + character(len=:), allocatable :: string + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer :: n + character(len=1), parameter :: numbers(0:9) = & + ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] + + if (val == 0) then + string = numbers(0) + return + end if + + n = abs(val) + buffer = "" + + pos = buffer_len + 1 + do while (n > 0) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10)) + n = n/10 + end do + if (val < 0) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + if (present(width)) then + string = repeat(" ", max(width-(buffer_len+1-pos), 0)) // buffer(pos:) + else + string = buffer(pos:) + end if +end function to_string + + +end module tomlf_diagnostic diff --git a/source/third_party_open/utils/toml-f/src/tomlf/error.f90 b/source/third_party_open/utils/toml-f/src/tomlf/error.f90 new file mode 100644 index 000000000..7fde4344e --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/error.f90 @@ -0,0 +1,114 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Error handling for TOML Fortran +!> +!> This module provides the [[toml_error]] type for error reporting and +!> the [[toml_stat]] enumerator for status codes returned by various +!> TOML Fortran procedures. +!> +!> ## Error Handling +!> +!> Most parsing and access functions accept an optional `error` argument +!> of type [[toml_error]]. If an error occurs, this will be allocated +!> and contain a descriptive message: +!> +!>```fortran +!> type(toml_error), allocatable :: error +!> call toml_load(table, "config.toml", error=error) +!> if (allocated(error)) print '(a)', error%message +!>``` +!> +!> ## Status Codes +!> +!> The [[toml_stat]] enumerator provides named constants for common +!> error conditions like `toml_stat%duplicate_key` or `toml_stat%type_mismatch`. +module tomlf_error + use tomlf_constants, only : tfc, TOML_NEWLINE + implicit none + private + + public :: toml_stat, toml_error, make_error + + + !> Possible TOML Fortran status codes + type :: enum_stat + + !> Successful run + integer :: success = 0 + + !> Internal error: + !> + !> General undefined error state, usually caused by algorithmic errors. + integer :: fatal = -1 + + !> Duplicate key encountered + integer :: duplicate_key = -2 + + !> Incorrect type when reading a value + integer :: type_mismatch = -3 + + !> Conversion error when downcasting a value + integer :: conversion_error = -4 + + !> Key not present in table + integer :: missing_key = -5 + + end type enum_stat + + !> Actual enumerator for return states + !> + !> | Name | Description | + !> |------|-------------| + !> | `success` | Operation completed successfully | + !> | `fatal` | Internal error or undefined error state | + !> | `duplicate_key` | Duplicate key encountered in table | + !> | `type_mismatch` | Incorrect type when reading a value | + !> | `conversion_error` | Error when converting or downcasting a value | + !> | `missing_key` | Requested key not present in table | + type(enum_stat), parameter :: toml_stat = enum_stat() + + + !> Error message produced by TOML-Fortran + type :: toml_error + + !> Error code + integer :: stat = toml_stat%fatal + + !> Payload of the error + character(kind=tfc, len=:), allocatable :: message + + end type toml_error + + +contains + +!> Create new error message +subroutine make_error(error, message, stat) + !> Error report + type(toml_error), allocatable, intent(out) :: error + !> Message for the error + character(*, tfc), intent(in) :: message + !> Status code + integer, intent(in), optional :: stat + + allocate(error) + error%message = message + if (present(stat)) then + error%stat = stat + else + error%stat = toml_stat%fatal + end if +end subroutine make_error + +end module tomlf_error diff --git a/source/third_party_open/utils/toml-f/src/tomlf/ser.f90 b/source/third_party_open/utils/toml-f/src/tomlf/ser.f90 new file mode 100644 index 000000000..0dcf37140 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/ser.f90 @@ -0,0 +1,545 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML serialization module +!> +!> This module provides interfaces for serializing TOML data structures +!> back to TOML format. The primary interfaces are: +!> +!> - [[toml_dump]]: Write a TOML table to a file or I/O unit +!> - [[toml_dumps]]: Serialize a TOML table to a string +!> - [[toml_serialize]]: Low-level serialization using the visitor pattern +!> +!> The [[toml_serializer]] type implements the visitor pattern and can be +!> used directly for custom serialization workflows. +module tomlf_ser + use tomlf_constants, only : tfc, tfi, tfr, tfout, toml_type + use tomlf_datetime, only : toml_datetime, to_string + use tomlf_error, only : toml_error, toml_stat, make_error + use tomlf_type, only : toml_value, toml_visitor, toml_key, toml_table, & + & toml_array, toml_keyval, is_array_of_tables, len + use tomlf_utils, only : to_string, toml_escape_string + implicit none + private + + public :: toml_serializer, new_serializer, new + public :: toml_dump, toml_dumps, toml_serialize + + + interface toml_dumps + module procedure :: toml_dump_to_string + end interface toml_dumps + + interface toml_dump + module procedure :: toml_dump_to_file + module procedure :: toml_dump_to_unit + end interface toml_dump + + + !> Configuration for JSON serializer + type :: toml_ser_config + + !> Indentation + character(len=:), allocatable :: indent + + end type toml_ser_config + + + !> TOML serializer to produduce a TOML document from a datastructure + type, extends(toml_visitor) :: toml_serializer + private + + !> Output string + character(:), allocatable :: output + + !> Configuration for serializer + type(toml_ser_config) :: config = toml_ser_config() + + !> Special mode for printing array of tables + logical, private :: array_of_tables = .false. + + !> Special mode for printing inline arrays + logical, private :: inline_array = .false. + + !> Top of the key stack + integer, private :: top = 0 + + !> Key stack to create table headers + type(toml_key), allocatable, private :: stack(:) + + contains + + !> Visit a TOML value + procedure :: visit + + end type toml_serializer + + + !> Create standard constructor + interface toml_serializer + module procedure :: new_serializer_func + end interface toml_serializer + + + !> Overloaded constructor for TOML serializers + interface new + module procedure :: new_serializer + end interface + + + !> Initial size of the key path stack + integer, parameter :: initial_size = 8 + + +contains + + +!> Serialize a JSON value to a string and return it. +!> +!> In case of an error this function will invoke an error stop. +function toml_serialize(val, config) result(string) + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + !> Serialized JSON value + character(len=:), allocatable :: string + + type(toml_error), allocatable :: error + + call toml_dumps(val, string, error, config=config) + if (allocated(error)) then + print '(a)', "Error: " // error%message + error stop 1 + end if +end function toml_serialize + + +!> Create a string representing the JSON value +subroutine toml_dump_to_string(val, string, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Formatted unit to write to + character(:), allocatable, intent(out) :: string + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + type(toml_serializer) :: ser + + ser = toml_serializer(config=config) + call val%accept(ser) + string = ser%output +end subroutine toml_dump_to_string + + +!> Write string representation of JSON value to a connected formatted unit +subroutine toml_dump_to_unit(val, io, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Formatted unit to write to + integer, intent(in) :: io + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + character(len=:), allocatable :: string + character(512) :: msg + integer :: stat + + call toml_dumps(val, string, error, config=config) + if (allocated(error)) return + write(io, '(a)', iostat=stat, iomsg=msg) string + if (stat /= 0) then + call make_error(error, trim(msg)) + return + end if +end subroutine toml_dump_to_unit + + +!> Write string representation of JSON value to a file +subroutine toml_dump_to_file(val, filename, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> File name to write to + character(*), intent(in) :: filename + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + integer :: io + integer :: stat + character(512) :: msg + + open(file=filename, newunit=io, iostat=stat, iomsg=msg) + if (stat /= 0) then + call make_error(error, trim(msg)) + return + end if + call toml_dump(val, io, error, config=config) + close(unit=io, iostat=stat, iomsg=msg) + if (.not.allocated(error) .and. stat /= 0) then + call make_error(error, trim(msg)) + end if +end subroutine toml_dump_to_file + + +!> Constructor to create new serializer instance +subroutine new_serializer(self, config) + + !> Instance of the TOML serializer + type(toml_serializer), intent(out) :: self + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + self%output = "" + if (present(config)) self%config = config +end subroutine new_serializer + + +!> Default constructor for TOML serializer +function new_serializer_func(config) result(self) + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + !> Instance of the TOML serializer + type(toml_serializer) :: self + + call new_serializer(self, config) +end function new_serializer_func + + +!> Visit a TOML value +recursive subroutine visit(self, val) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: self + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + select type(val) + class is(toml_keyval) + call visit_keyval(self, val) + class is(toml_array) + call visit_array(self, val) + class is(toml_table) + call visit_table(self, val) + end select + +end subroutine visit + + +!> Visit a TOML key-value pair +subroutine visit_keyval(visitor, keyval) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML value to visit + type(toml_keyval), intent(inout) :: keyval + + character(kind=tfc, len=:), allocatable :: key, str + type(toml_datetime), pointer :: dval + character(:, tfc), pointer :: sval + integer(tfi), pointer :: ival + real(tfr), pointer :: rval + logical, pointer :: lval + + call keyval%get_key(key) + + select case(keyval%get_type()) + case(toml_type%string) + call keyval%get(sval) + call toml_escape_string(sval, str) + case(toml_type%int) + call keyval%get(ival) + str = to_string(ival) + case(toml_type%float) + call keyval%get(rval) + str = to_string(rval) + case(toml_type%boolean) + call keyval%get(lval) + if (lval) then + str = "true" + else + str = "false" + end if + case(toml_type%datetime) + call keyval%get(dval) + str = to_string(dval) + end select + + if (visitor%inline_array) then + visitor%output = visitor%output // " " + end if + visitor%output = visitor%output // key // " = " // str + if (.not.visitor%inline_array) then + visitor%output = visitor%output // new_line('a') + end if + +end subroutine visit_keyval + + +!> Visit a TOML array +recursive subroutine visit_array(visitor, array) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML value to visit + type(toml_array), intent(inout) :: array + + class(toml_value), pointer :: ptr + character(kind=tfc, len=:), allocatable :: key, str + type(toml_datetime), pointer :: dval + character(:, tfc), pointer :: sval + integer(tfi), pointer :: ival + real(tfr), pointer :: rval + logical, pointer :: lval + integer :: i, n + + if (visitor%inline_array) visitor%output = visitor%output // " [" + n = len(array) + do i = 1, n + call array%get(i, ptr) + select type(ptr) + class is(toml_keyval) + + select case(ptr%get_type()) + case(toml_type%string) + call ptr%get(sval) + call toml_escape_string(sval, str) + case(toml_type%int) + call ptr%get(ival) + str = to_string(ival) + case(toml_type%float) + call ptr%get(rval) + str = to_string(rval) + case(toml_type%boolean) + call ptr%get(lval) + if (lval) then + str = "true" + else + str = "false" + end if + case(toml_type%datetime) + call ptr%get(dval) + str = to_string(dval) + end select + + visitor%output = visitor%output // " " // str + if (i /= n) visitor%output = visitor%output // "," + class is(toml_array) + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + class is(toml_table) + if (visitor%inline_array) then + visitor%output = visitor%output // " {" + call ptr%accept(visitor) + visitor%output = visitor%output // " }" + if (i /= n) visitor%output = visitor%output // "," + else + visitor%array_of_tables = .true. + if (size(visitor%stack, 1) <= visitor%top) call resize(visitor%stack) + visitor%top = visitor%top + 1 + call array%get_key(key) + visitor%stack(visitor%top)%key = key + call ptr%accept(visitor) + deallocate(visitor%stack(visitor%top)%key) + visitor%top = visitor%top - 1 + end if + end select + end do + if (visitor%inline_array) visitor%output = visitor%output // " ]" + +end subroutine visit_array + + +!> Visit a TOML table +recursive subroutine visit_table(visitor, table) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML table to visit + type(toml_table), intent(inout) :: table + + class(toml_value), pointer :: ptr + type(toml_key), allocatable :: list(:) + logical, allocatable :: defer(:) + character(kind=tfc, len=:), allocatable :: key + integer :: i, n + + call table%get_keys(list) + + n = size(list, 1) + allocate(defer(n)) + + if (.not.allocated(visitor%stack)) then + call resize(visitor%stack) + else + if (.not.(visitor%inline_array .or. table%implicit)) then + visitor%output = visitor%output // "[" + if (visitor%array_of_tables) visitor%output = visitor%output // "[" + do i = 1, visitor%top-1 + visitor%output = visitor%output // visitor%stack(i)%key // "." + end do + visitor%output = visitor%output // visitor%stack(visitor%top)%key + visitor%output = visitor%output // "]" + if (visitor%array_of_tables) visitor%output = visitor%output // "]" + visitor%output = visitor%output // new_line('a') + visitor%array_of_tables = .false. + end if + end if + + do i = 1, n + defer(i) = .false. + call table%get(list(i)%key, ptr) + select type(ptr) + class is(toml_keyval) + call ptr%accept(visitor) + if (visitor%inline_array) then + if (i /= n) visitor%output = visitor%output // "," + end if + class is(toml_array) + if (visitor%inline_array) then + call ptr%get_key(key) + visitor%output = visitor%output // " " // key // " =" + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + else + if (is_array_of_tables(ptr)) then + ! Array of tables open a new section + ! -> cannot serialize them before all key-value pairs are done + defer(i) = .true. + else + visitor%inline_array = .true. + call ptr%get_key(key) + visitor%output = visitor%output // key // " =" + call ptr%accept(visitor) + visitor%inline_array = .false. + visitor%output = visitor%output // new_line('a') + end if + end if + class is(toml_table) + ! Subtables open a new section + ! -> cannot serialize them before all key-value pairs are done + defer(i) = .true. + end select + end do + + do i = 1, n + if (defer(i)) then + call table%get(list(i)%key, ptr) + select type(ptr) + class is(toml_keyval) + call ptr%accept(visitor) + if (visitor%inline_array) then + if (i /= n) visitor%output = visitor%output // "," + end if + class is(toml_array) + if (visitor%inline_array) then + call ptr%get_key(key) + visitor%output = visitor%output // " " // key // " =" + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + else + if (is_array_of_tables(ptr)) then + call ptr%accept(visitor) + else + visitor%inline_array = .true. + call ptr%get_key(key) + visitor%output = visitor%output // key // " =" + call ptr%accept(visitor) + visitor%inline_array = .false. + visitor%output = visitor%output // new_line('a') + end if + end if + class is(toml_table) + if (size(visitor%stack, 1) <= visitor%top) call resize(visitor%stack) + visitor%top = visitor%top + 1 + call ptr%get_key(key) + visitor%stack(visitor%top)%key = key + call ptr%accept(visitor) + deallocate(visitor%stack(visitor%top)%key) + visitor%top = visitor%top - 1 + end select + end if + end do + + if (.not.visitor%inline_array .and. visitor%top == 0) then + deallocate(visitor%stack) + end if + +end subroutine visit_table + + +!> Change size of the stack +subroutine resize(stack, n) + + !> Stack of keys to be resized + type(toml_key), allocatable, intent(inout) :: stack(:) + + !> New size of the stack + integer, intent(in), optional :: n + + type(toml_key), allocatable :: tmp(:) + integer :: m + + if (present(n)) then + m = n + else + if (allocated(stack)) then + m = size(stack) + m = m + m/2 + 1 + else + m = initial_size + end if + end if + + if (allocated(stack)) then + call move_alloc(stack, tmp) + allocate(stack(m)) + + m = min(size(tmp), m) + stack(:m) = tmp(:m) + + deallocate(tmp) + else + allocate(stack(m)) + end if + +end subroutine resize + + +end module tomlf_ser diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure.f90 new file mode 100644 index 000000000..54e286288 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure.f90 @@ -0,0 +1,75 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstraction layer for the actual storage of the data structure. +!> +!> The structure implementations provide the actual storage for TOML values, with +!> a generic enough interface to make the definition of the TOML data structures +!> independent of the actual algorithm used for storing the TOML values. +!> +!> Every data structure defined here should strive to only use allocatable +!> data types and limit the use of pointer attributes as they interfer with +!> the automatic memory management of Fortran. A well defined data structure +!> in allocatables allows deep-copying of TOML values by assignment, data structures +!> requiring pointer attributes have to define an assignment(=) interface to +!> allow deep-copying of TOML values. +module tomlf_structure + use tomlf_structure_list, only : toml_list_structure + use tomlf_structure_map, only : toml_map_structure + use tomlf_structure_array_list, only : toml_array_list, new_array_list + use tomlf_structure_ordered_map, only : toml_ordered_map, new_ordered_map + implicit none + private + + public :: toml_list_structure, toml_map_structure + public :: new_list_structure, new_map_structure + + +contains + + +!> Constructor for the ordered storage data structure +subroutine new_list_structure(self) + + !> Instance of the structure + class(toml_list_structure), allocatable, intent(out) :: self + + block + type(toml_array_list), allocatable :: list + + allocate(list) + call new_array_list(list) + call move_alloc(list, self) + end block + +end subroutine new_list_structure + + +!> Constructor for the storage data structure +subroutine new_map_structure(self) + + !> Instance of the structure + class(toml_map_structure), allocatable, intent(out) :: self + + block + type(toml_ordered_map), allocatable :: map + + allocate(map) + call new_ordered_map(map) + call move_alloc(map, self) + end block + +end subroutine new_map_structure + + +end module tomlf_structure diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 new file mode 100644 index 000000000..670a86c2a --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 @@ -0,0 +1,209 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_array_list + use tomlf_constants, only : tfc + use tomlf_structure_list, only : toml_list_structure + use tomlf_structure_node, only : toml_node, resize + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_array_list, new_array_list + + + !> Stores TOML values in a list of pointers + type, extends(toml_list_structure) :: toml_array_list + + !> Current number of stored TOML values + integer :: n = 0 + + !> List of TOML values + type(toml_node), allocatable :: lst(:) + + contains + + !> Get number of TOML values in the structure + procedure :: get_len + + !> Get TOML value at a given index + procedure :: get + + !> Push back a TOML value to the structure + procedure :: push_back + + !> Remove the first element from the structure + procedure :: shift + + !> Remove the last element from the structure + procedure :: pop + + !> Destroy the data structure + procedure :: destroy + + end type toml_array_list + + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + + +contains + + +!> Constructor for the storage data structure +subroutine new_array_list(self, n) + + !> Instance of the structure + type(toml_array_list), intent(out) :: self + + !> Initial storage capacity + integer, intent(in), optional :: n + + self%n = 0 + if (present(n)) then + allocate(self%lst(min(1, n))) + else + allocate(self%lst(initial_size)) + end if + +end subroutine new_array_list + + +!> Get number of TOML values in the structure +pure function get_len(self) result(length) + + !> Instance of the structure + class(toml_array_list), intent(in), target :: self + + !> Current length of the ordered structure + integer :: length + + length = self%n + +end function get_len + + +!> Get TOML value at a given index +subroutine get(self, idx, ptr) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> Position in the ordered structure + integer, intent(in) :: idx + + !> Pointer to the stored value at given index + class(toml_value), pointer, intent(out) :: ptr + + nullify(ptr) + + if (idx > 0 .and. idx <= self%n) then + if (allocated(self%lst(idx)%val)) then + ptr => self%lst(idx)%val + end if + end if + +end subroutine get + + +!> Push back a TOML value to the structure +subroutine push_back(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + integer :: m + + if (.not.allocated(self%lst)) then + call resize(self%lst, initial_size) + end if + + m = size(self%lst) + if (self%n >= m) then + call resize(self%lst, m + m/2 + 1) + end if + + self%n = self%n + 1 + call move_alloc(val, self%lst(self%n)%val) + +end subroutine push_back + + +!> Remove the first element from the data structure +subroutine shift(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + integer :: i + + if (self%n > 0) then + call move_alloc(self%lst(1)%val, val) + do i = 2, self%n + call move_alloc(self%lst(i)%val, self%lst(i-1)%val) + end do + self%n = self%n - 1 + end if + +end subroutine shift + + +!> Remove the last element from the data structure +subroutine pop(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + if (self%n > 0) then + call move_alloc(self%lst(self%n)%val, val) + self%n = self%n - 1 + end if + +end subroutine pop + + +!> Deconstructor for data structure +subroutine destroy(self) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + integer :: i + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + call self%lst(i)%val%destroy + end if + end do + + deallocate(self%lst) + self%n = 0 + +end subroutine destroy + + +end module tomlf_structure_array_list diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/list.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/list.f90 new file mode 100644 index 000000000..c01f54c56 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/list.f90 @@ -0,0 +1,141 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstract base class definitions for data structures to store TOML values +module tomlf_structure_list + use tomlf_constants, only : tfc + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_list_structure + + + !> Ordered data structure, allows iterations + type, abstract :: toml_list_structure + contains + + !> Get number of TOML values in the structure + procedure(get_len), deferred :: get_len + + !> Push back a TOML value to the structure + procedure(push_back), deferred :: push_back + + !> Remove the first element from the structure + procedure(shift), deferred :: shift + + !> Remove the last element from the structure + procedure(pop), deferred :: pop + + !> Get TOML value at a given index + procedure(get), deferred :: get + + !> Destroy the data structure + procedure(destroy), deferred :: destroy + + end type toml_list_structure + + + abstract interface + !> Get number of TOML values in the structure + pure function get_len(self) result(length) + import :: toml_list_structure + + !> Instance of the structure + class(toml_list_structure), intent(in), target :: self + + !> Current length of the ordered structure + integer :: length + end function get_len + + + !> Get TOML value at a given index + subroutine get(self, idx, ptr) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> Position in the ordered structure + integer, intent(in) :: idx + + !> Pointer to the stored value at given index + class(toml_value), pointer, intent(out) :: ptr + end subroutine get + + + !> Push back a TOML value to the structure + subroutine push_back(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + end subroutine push_back + + + !> Remove the first element from the data structure + subroutine shift(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + end subroutine shift + + + !> Remove the last element from the data structure + subroutine pop(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + end subroutine pop + + + !> Delete TOML value at a given key + subroutine delete(self, key) + import :: toml_list_structure, toml_value, tfc + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + end subroutine delete + + + !> Deconstructor for data structure + subroutine destroy(self) + import :: toml_list_structure + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + end subroutine destroy + + end interface + + +end module tomlf_structure_list diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/map.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/map.f90 new file mode 100644 index 000000000..e1f4437eb --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/map.f90 @@ -0,0 +1,132 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstract base class definitions for data structures to store TOML values +module tomlf_structure_map + use tomlf_constants, only : tfc + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_map_structure + + + !> Abstract data structure + type, abstract :: toml_map_structure + contains + + !> Get TOML value at a given key + procedure(get), deferred :: get + + !> Push back a TOML value to the structure + procedure(push_back), deferred :: push_back + + !> Get list of all keys in the structure + procedure(get_keys), deferred :: get_keys + + !> Remove TOML value at a given key and return it + procedure(pop), deferred :: pop + + !> Delete TOML value at a given key + procedure(delete), deferred :: delete + + !> Destroy the data structure + procedure(destroy), deferred :: destroy + + end type toml_map_structure + + + abstract interface + !> Get TOML value at a given key + subroutine get(self, key, ptr) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the stored value at given key + class(toml_value), pointer, intent(out) :: ptr + end subroutine get + + + !> Push back a TOML value to the structure + subroutine push_back(self, val) + import :: toml_map_structure, toml_value + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + end subroutine push_back + + + !> Get list of all keys in the structure + subroutine get_keys(self, list) + import :: toml_map_structure, toml_key + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + end subroutine get_keys + + + !> Remove TOML value at a given key and return it + subroutine pop(self, key, val) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value + class(toml_value), allocatable, intent(out) :: val + + end subroutine pop + + + !> Delete TOML value at a given key + subroutine delete(self, key) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + end subroutine delete + + + !> Deconstructor for data structure + subroutine destroy(self) + import :: toml_map_structure + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + end subroutine destroy + + end interface + + +end module tomlf_structure_map diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/node.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/node.f90 new file mode 100644 index 000000000..e2d8ac38b --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/node.f90 @@ -0,0 +1,79 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_node + use tomlf_type_value, only : toml_value + implicit none + private + + public :: toml_node, resize + + + !> Wrapped TOML value to generate pointer list + type :: toml_node + + !> TOML value payload + class(toml_value), allocatable :: val + + end type toml_node + + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + + +contains + + +!> Change size of the TOML value list +subroutine resize(list, n) + + !> Array of TOML values to be resized + type(toml_node), allocatable, intent(inout), target :: list(:) + + !> New size of the list + integer, intent(in) :: n + + type(toml_node), allocatable, target :: tmp(:) + integer :: i + + + if (allocated(list)) then + call move_alloc(list, tmp) + allocate(list(n)) + + do i = 1, min(size(tmp), n) + if (allocated(tmp(i)%val)) then + call move_alloc(tmp(i)%val, list(i)%val) + end if + end do + + do i = n+1, size(tmp) + if (allocated(tmp(i)%val)) then + call tmp(i)%val%destroy + deallocate(tmp(i)%val) + end if + end do + + deallocate(tmp) + else + allocate(list(n)) + end if + +end subroutine resize + +end module tomlf_structure_node diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 new file mode 100644 index 000000000..a2234a607 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 @@ -0,0 +1,240 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_ordered_map + use tomlf_constants, only : tfc + use tomlf_structure_map, only : toml_map_structure + use tomlf_structure_node, only : toml_node, resize + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_ordered_map, new_ordered_map + + + !> Stores TOML values in a list of pointers + type, extends(toml_map_structure) :: toml_ordered_map + + !> Current number of stored TOML values + integer :: n = 0 + + !> List of TOML values + type(toml_node), allocatable :: lst(:) + + contains + + !> Get TOML value at a given key + procedure :: get + + !> Push back a TOML value to the structure + procedure :: push_back + + !> Remove TOML value at a given key and return it + procedure :: pop + + !> Get list of all keys in the structure + procedure :: get_keys + + !> Delete TOML value at a given key + procedure :: delete + + !> Destroy the data structure + procedure :: destroy + + end type toml_ordered_map + + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + + +contains + + +!> Constructor for the storage data structure +subroutine new_ordered_map(self, n) + + !> Instance of the structure + type(toml_ordered_map), intent(out) :: self + + !> Initial storage capacity + integer, intent(in), optional :: n + + self%n = 0 + if (present(n)) then + allocate(self%lst(min(1, n))) + else + allocate(self%lst(initial_size)) + end if + +end subroutine new_ordered_map + + +!> Get TOML value at a given key +subroutine get(self, key, ptr) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the stored value at given key + class(toml_value), pointer, intent(out) :: ptr + + integer :: i + + nullify(ptr) + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (self%lst(i)%val%match_key(key)) then + ptr => self%lst(i)%val + exit + end if + end if + end do + +end subroutine get + + +!> Push back a TOML value to the structure +subroutine push_back(self, val) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + integer :: m + + if (.not.allocated(self%lst)) then + call resize(self%lst, initial_size) + end if + + m = size(self%lst) + if (self%n >= m) then + call resize(self%lst, m + m/2 + 1) + end if + + self%n = self%n + 1 + call move_alloc(val, self%lst(self%n)%val) + +end subroutine push_back + + +!> Get list of all keys in the structure +subroutine get_keys(self, list) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + integer :: i + + allocate(list(self%n)) + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (allocated(self%lst(i)%val%key)) then + list(i)%key = self%lst(i)%val%key + list(i)%origin = self%lst(i)%val%origin + end if + end if + end do + +end subroutine get_keys + + +!> Remove TOML value at a given key and return it +subroutine pop(self, key, val) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value + class(toml_value), allocatable, intent(out) :: val + + integer :: idx, i + + idx = 0 + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (self%lst(i)%val%match_key(key)) then + idx = i + exit + end if + end if + end do + + if (idx > 0) then + call move_alloc(self%lst(idx)%val, val) + do i = idx+1, self%n + call move_alloc(self%lst(i)%val, self%lst(i-1)%val) + end do + self%n = self%n - 1 + end if + +end subroutine pop + + +!> Delete TOML value at a given key +subroutine delete(self, key) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + class(toml_value), allocatable :: val + + call self%pop(key, val) + if (allocated(val)) then + call val%destroy() + end if + +end subroutine delete + + +!> Deconstructor for data structure +subroutine destroy(self) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + integer :: i + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + call self%lst(i)%val%destroy + end if + end do + + deallocate(self%lst) + self%n = 0 + +end subroutine destroy + + +end module tomlf_structure_ordered_map diff --git a/source/third_party_open/utils/toml-f/src/tomlf/terminal.f90 b/source/third_party_open/utils/toml-f/src/tomlf/terminal.f90 new file mode 100644 index 000000000..be587a811 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/terminal.f90 @@ -0,0 +1,326 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a terminal to provide ANSI escape sequences +!> +!> ANSI escape codes for producing terminal colors. The `ansi_code` derived +!> type is used to store ANSI escape codes and can be combined with other +!> codes or applied to strings by concatenation. The default or uninitialized +!> `ansi_code` is a stub and does not produce escape sequences when applied +!> to a string. +!> +!> Available colors are +!> +!> color | foreground | background +!> -------------- | --------------------- | ------------------------ +!> black | `black` (30) | `bg_black` (40) +!> red | `red` (31) | `bg_red` (41) +!> green | `green` (32) | `bg_green` (42) +!> yellow | `yellow` (33) | `bg_yellow` (43) +!> blue | `blue` (34) | `bg_blue` (44) +!> magenta | `magenta` (35) | `bg_magenta` (45) +!> cyan | `cyan` (36) | `bg_cyan` (46) +!> white | `white` (37) | `bg_white` (47) +!> gray | `gray` (90) | `bg_gray` (100) +!> bright red | `bright_red` (91) | `bg_bright_red` (101) +!> bright green | `bright_green` (92) | `bg_bright_green` (102) +!> bright yellow | `bright_yellow` (93) | `bg_bright_yellow` (103) +!> bright blue | `bright_blue` (94) | `bg_bright_blue` (104) +!> bright magenta | `bright_magenta` (95) | `bg_bright_magenta` (105) +!> bright cyan | `bright_cyan` (96) | `bg_bright_cyan` (106) +!> bright white | `bright_white` (97) | `bg_bright_white` (107) +!> +!> Available styles are +!> +!> style | +!> ------------| --------------- +!> reset | `reset` (0) +!> bold | `bold` (1) +!> dim | `dim` (2) +!> italic | `italic` (3) +!> underline | `underline` (4) +!> blink | `blink` (5) +!> blink rapid | `blink_rapid` (6) +!> reverse | `reverse` (7) +!> hidden | `hidden` (8) +!> crossed | `crossed` (9) +module tomlf_terminal + use tomlf_utils, only : to_string + implicit none + private + + public :: toml_terminal + public :: ansi_code, escape, operator(+), operator(//) + + + !> Char length for integers + integer, parameter :: i1 = selected_int_kind(2) + + !> Container for terminal escape code + type :: ansi_code + private + !> Style descriptor + integer(i1) :: style = -1_i1 + !> Background color descriptor + integer(i1) :: bg = -1_i1 + !> Foreground color descriptor + integer(i1) :: fg = -1_i1 + end type + + interface operator(+) + module procedure :: add + end interface operator(+) + + interface operator(//) + module procedure :: concat_left + module procedure :: concat_right + end interface operator(//) + + interface escape + module procedure :: escape + end interface escape + + type(ansi_code), public, parameter :: & + reset = ansi_code(style=0_i1), & + bold = ansi_code(style=1_i1), & + dim = ansi_code(style=2_i1), & + italic = ansi_code(style=3_i1), & + underline = ansi_code(style=4_i1), & + blink = ansi_code(style=5_i1), & + blink_rapid = ansi_code(style=6_i1), & + reverse = ansi_code(style=7_i1), & + hidden = ansi_code(style=8_i1), & + crossed = ansi_code(style=9_i1) + + type(ansi_code), public, parameter :: & + black = ansi_code(fg=30_i1), & + red = ansi_code(fg=31_i1), & + green = ansi_code(fg=32_i1), & + yellow = ansi_code(fg=33_i1), & + blue = ansi_code(fg=34_i1), & + magenta = ansi_code(fg=35_i1), & + cyan = ansi_code(fg=36_i1), & + white = ansi_code(fg=37_i1), & + gray = ansi_code(fg=90_i1), & + bright_red = ansi_code(fg=91_i1), & + bright_green = ansi_code(fg=92_i1), & + bright_yellow = ansi_code(fg=93_i1), & + bright_blue = ansi_code(fg=94_i1), & + bright_magenta = ansi_code(fg=95_i1), & + bright_cyan = ansi_code(fg=96_i1), & + bright_white = ansi_code(fg=97_i1) + + type(ansi_code), public, parameter :: & + bg_black = ansi_code(bg=40_i1), & + bg_red = ansi_code(bg=41_i1), & + bg_green = ansi_code(bg=42_i1), & + bg_yellow = ansi_code(bg=43_i1), & + bg_blue = ansi_code(bg=44_i1), & + bg_magenta = ansi_code(bg=45_i1), & + bg_cyan = ansi_code(bg=46_i1), & + bg_white = ansi_code(bg=47_i1), & + bg_gray = ansi_code(bg=100_i1), & + bg_bright_red = ansi_code(bg=101_i1), & + bg_bright_green = ansi_code(bg=102_i1), & + bg_bright_yellow = ansi_code(bg=103_i1), & + bg_bright_blue = ansi_code(bg=104_i1), & + bg_bright_magenta = ansi_code(bg=105_i1), & + bg_bright_cyan = ansi_code(bg=106_i1), & + bg_bright_white = ansi_code(bg=107_i1) + + + !> Terminal wrapper to handle color escape sequences, must be initialized with + !> color support to provide colorful output. Default and uninitialized instances + !> will remain usable but provide only stubs and do not produce colorful output. + !> This behavior is useful for creating applications which can toggle color support. + type :: toml_terminal + type(ansi_code) :: & + reset = ansi_code(), & + bold = ansi_code(), & + dim = ansi_code(), & + italic = ansi_code(), & + underline = ansi_code(), & + blink = ansi_code(), & + blink_rapid = ansi_code(), & + reverse = ansi_code(), & + hidden = ansi_code(), & + crossed = ansi_code() + + type(ansi_code) :: & + black = ansi_code(), & + red = ansi_code(), & + green = ansi_code(), & + yellow = ansi_code(), & + blue = ansi_code(), & + magenta = ansi_code(), & + cyan = ansi_code(), & + white = ansi_code(), & + gray = ansi_code(), & + bright_red = ansi_code(), & + bright_green = ansi_code(), & + bright_yellow = ansi_code(), & + bright_blue = ansi_code(), & + bright_magenta = ansi_code(), & + bright_cyan = ansi_code(), & + bright_white = ansi_code() + + type(ansi_code) :: & + bg_black = ansi_code(), & + bg_red = ansi_code(), & + bg_green = ansi_code(), & + bg_yellow = ansi_code(), & + bg_blue = ansi_code(), & + bg_magenta = ansi_code(), & + bg_cyan = ansi_code(), & + bg_white = ansi_code(), & + bg_gray = ansi_code(), & + bg_bright_red = ansi_code(), & + bg_bright_green = ansi_code(), & + bg_bright_yellow = ansi_code(), & + bg_bright_blue = ansi_code(), & + bg_bright_magenta = ansi_code(), & + bg_bright_cyan = ansi_code(), & + bg_bright_white = ansi_code() + end type toml_terminal + + !> Constructor to create new terminal + interface toml_terminal + module procedure :: new_terminal + end interface toml_terminal + +contains + +!> Create new terminal +pure function new_terminal(use_color) result(new) + !> Enable color support in terminal + logical, intent(in) :: use_color + !> New terminal instance + type(toml_terminal) :: new + + if (use_color) then + new%reset = reset + new%bold = bold + new%dim = dim + new%italic = italic + new%underline = underline + new%blink = blink + new%blink_rapid = blink_rapid + new%reverse = reverse + new%hidden = hidden + new%crossed = crossed + + new%black = black + new%red = red + new%green = green + new%yellow = yellow + new%blue = blue + new%magenta = magenta + new%cyan = cyan + new%white = white + new%gray = gray + new%bright_red = bright_red + new%bright_green = bright_green + new%bright_yellow = bright_yellow + new%bright_blue = bright_blue + new%bright_magenta = bright_magenta + new%bright_cyan = bright_cyan + new%bright_white = bright_white + + new%bg_black = bg_black + new%bg_red = bg_red + new%bg_green = bg_green + new%bg_yellow = bg_yellow + new%bg_blue = bg_blue + new%bg_magenta = bg_magenta + new%bg_cyan = bg_cyan + new%bg_white = bg_white + new%bg_gray = bg_gray + new%bg_bright_red = bg_bright_red + new%bg_bright_green = bg_bright_green + new%bg_bright_yellow = bg_bright_yellow + new%bg_bright_blue = bg_bright_blue + new%bg_bright_magenta = bg_bright_magenta + new%bg_bright_cyan = bg_bright_cyan + new%bg_bright_white = bg_bright_white + end if +end function new_terminal + +!> Add two escape sequences, attributes in the right value override the left value ones. +pure function add(lval, rval) result(code) + !> First escape code + type(ansi_code), intent(in) :: lval + !> Second escape code + type(ansi_code), intent(in) :: rval + !> Combined escape code + type(ansi_code) :: code + + code%style = merge(rval%style, lval%style, rval%style >= 0) + code%fg = merge(rval%fg, lval%fg, rval%fg >= 0) + code%bg = merge(rval%bg, lval%bg, rval%bg >= 0) +end function add + + +!> Concatenate an escape code with a string and turn it into an actual escape sequence +pure function concat_left(lval, code) result(str) + !> String to add the escape code to + character(len=*), intent(in) :: lval + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Concatenated string + character(len=:), allocatable :: str + + str = lval // escape(code) +end function concat_left + +!> Concatenate an escape code with a string and turn it into an actual escape sequence +pure function concat_right(code, rval) result(str) + !> String to add the escape code to + character(len=*), intent(in) :: rval + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Concatenated string + character(len=:), allocatable :: str + + str = escape(code) // rval +end function concat_right + + +!> Transform a color code into an actual ANSI escape sequence +pure function escape(code) result(str) + !> Color code to be used + type(ansi_code), intent(in) :: code + !> ANSI escape sequence representing the color code + character(len=:), allocatable :: str + + if (anycolor(code)) then + str = achar(27) // "[0" ! Always reset the style + if (code%style > 0) str = str // ";" // to_string(code%style) + if (code%fg >= 0) str = str // ";" // to_string(code%fg) + if (code%bg >= 0) str = str // ";" // to_string(code%bg) + str = str // "m" + else + str = "" + end if +end function escape + +!> Check whether the code describes any color or is just a stub +pure function anycolor(code) + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Any color / style is active + logical :: anycolor + + anycolor = code%fg >= 0 .or. code%bg >= 0 .or. code%style >= 0 +end function anycolor + +end module tomlf_terminal diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type.f90 new file mode 100644 index 000000000..da1c10f70 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type.f90 @@ -0,0 +1,541 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Collection of the central datatypes to define TOML data structures +!> +!> All TOML data types should inherit from an abstract value allowing to generate +!> a generic interface to deal with all more specialized TOML data types, while +!> the abstract value is interesting for developing algorithms in TOML-Fortran, +!> the user of TOML-Fortran will usually only care about TOML tables and possibly +!> arrays. +!> +!> The TOML types defined here should implement the TOML data structures (mostly) +!> without taking the actual implementation of the data structures into account. +!> This is done by providing a bare minimum interface using type bound procedures +!> to minimize the interdependencies between the datatypes. +!> +!> To make the data types extendable a visitor pattern allows access to the TOML +!> data types and can be used to implement further algorithms. +module tomlf_type + use tomlf_constants, only : tfc + use tomlf_error, only : toml_stat + use tomlf_type_array, only : toml_array, new_array, new, initialized, len + use tomlf_type_keyval, only : toml_keyval, new_keyval, new + use tomlf_type_table, only : toml_table, new_table, new, initialized + use tomlf_type_value, only : toml_value, toml_visitor, toml_key + implicit none + private + + public :: toml_value, toml_visitor, toml_table, toml_array, toml_keyval + public :: toml_key + public :: new, new_table, new_array, new_keyval, initialized, len + public :: add_table, add_array, add_keyval + public :: is_array_of_tables + public :: cast_to_table, cast_to_array, cast_to_keyval + + + !> Interface to build new tables + interface add_table + module procedure :: add_table_to_table + module procedure :: add_table_to_table_key + module procedure :: add_table_to_array + end interface add_table + + + !> Interface to build new arrays + interface add_array + module procedure :: add_array_to_table + module procedure :: add_array_to_table_key + module procedure :: add_array_to_array + end interface add_array + + + !> Interface to build new key-value pairs + interface add_keyval + module procedure :: add_keyval_to_table + module procedure :: add_keyval_to_table_key + module procedure :: add_keyval_to_array + end interface add_keyval + + +contains + + +!> Create a new TOML table inside an existing table +subroutine add_table_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_table_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_table) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_table_to_table + + +!> Create a new TOML table inside an existing table +subroutine add_table_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new table + type(toml_key), intent(in) :: key + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_table(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_table_to_table_key + + +!> Create a new TOML array inside an existing table +subroutine add_array_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new array + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_array_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_array) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_array_to_table + + +!> Create a new TOML array inside an existing table +subroutine add_array_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new array + type(toml_key), intent(in) :: key + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_array(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_array_to_table_key + + +!> Create a new key-value pair inside an existing table +subroutine add_keyval_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new key-value pair + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_keyval_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_keyval) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_keyval_to_table + + +!> Create a new key-value pair inside an existing table +subroutine add_keyval_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new key-value pair + type(toml_key), intent(in) :: key + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_keyval(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_keyval_to_table_key + + +!> Create a new TOML table inside an existing array +subroutine add_table_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_table_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_table) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_table_to_array + + +!> Create a new TOML array inside an existing array +subroutine add_array_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + allocate(toml_array :: val) + call new_array_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_array) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_array_to_array + + +!> Create a new key-value pair inside an existing array +subroutine add_keyval_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_keyval_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_keyval) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_keyval_to_array + + +!> Wrapped constructor to create a new TOML table on an abstract TOML value +subroutine new_table_(self) + + !> Newly created TOML table + class(toml_value), allocatable, intent(out) :: self + + type(toml_table), allocatable :: val + + allocate(val) + call new_table(val) + call move_alloc(val, self) + +end subroutine new_table_ + + +!> Wrapped constructor to create a new TOML array on an abstract TOML value +subroutine new_array_(self) + + !> Newly created TOML array + class(toml_value), allocatable, intent(out) :: self + + type(toml_array), allocatable :: val + + allocate(val) + call new_array(val) + call move_alloc(val, self) + +end subroutine new_array_ + + +!> Wrapped constructor to create a new TOML array on an abstract TOML value +subroutine new_keyval_(self) + + !> Newly created key-value pair + class(toml_value), allocatable, intent(out) :: self + + type(toml_keyval), allocatable :: val + + allocate(val) + call new_keyval(val) + call move_alloc(val, self) + +end subroutine new_keyval_ + + +!> Determine if array contains only tables +function is_array_of_tables(array) result(only_tables) + + !> TOML value to visit + class(toml_array), intent(inout) :: array + + !> Array contains only tables + logical :: only_tables + + class(toml_value), pointer :: ptr + integer :: i, n + + + n = len(array) + only_tables = n > 0 + + do i = 1, n + call array%get(i, ptr) + select type(ptr) + type is(toml_table) + cycle + class default + only_tables = .false. + exit + end select + end do + +end function is_array_of_tables + + +!> Cast an abstract TOML value to a TOML array +function cast_to_array(ptr) result(array) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML array view, nullified if the value is not an array + type(toml_array), pointer :: array + + nullify(array) + select type(ptr) + type is(toml_array) + array => ptr + end select +end function cast_to_array + +!> Cast an abstract TOML value to a TOML table +function cast_to_table(ptr) result(table) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML table view, nullified if the value is not a table + type(toml_table), pointer :: table + + nullify(table) + select type(ptr) + type is(toml_table) + table => ptr + end select +end function cast_to_table + +!> Cast an abstract TOML value to a TOML key-value pair +function cast_to_keyval(ptr) result(kval) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML key-value view, nullified if the value is not a table + type(toml_keyval), pointer :: kval + + nullify(kval) + select type(ptr) + type is(toml_keyval) + kval => ptr + end select +end function cast_to_keyval + + +end module tomlf_type diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type/array.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type/array.f90 new file mode 100644 index 000000000..14caae285 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/array.f90 @@ -0,0 +1,225 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML array data type +!> +!> A [[toml_array]] represents a TOML array, which is an ordered sequence +!> of values. TOML arrays can contain values of any type, including nested +!> arrays and tables (arrays of tables). +!> +!> Use [[get_value]] from the build module to retrieve array elements by +!> index, or the type-bound procedures for direct access. The intrinsic +!> [[len]] function is overloaded to return the number of elements. +module tomlf_type_array + use tomlf_error, only : toml_stat + use tomlf_type_value, only : toml_value, toml_visitor + use tomlf_structure, only : toml_list_structure, new_list_structure + implicit none + private + + public :: toml_array, new_array, new, initialized, len + + + !> TOML array + type, extends(toml_value) :: toml_array + + !> Is an inline array rather than an array of tables + logical :: inline = .true. + + !> Storage unit for TOML values of this array + class(toml_list_structure), allocatable, private :: list + + contains + + !> Get the TOML value at a given index + procedure :: get + + !> Append value to array + procedure :: push_back + + !> Remove the first element from the array + procedure :: shift + + !> Remove the last element from the array + procedure :: pop + + !> Release allocation hold by TOML array + procedure :: destroy + + end type toml_array + + + !> Create standard constructor + interface toml_array + module procedure :: new_array_func + end interface toml_array + + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_array + end interface + + + !> Overload len function + interface len + module procedure :: get_len + end interface + + + !> Check whether data structure is initialized properly + interface initialized + module procedure :: array_initialized + end interface initialized + + +contains + + +!> Constructor to create a new TOML array and allocate the internal storage +subroutine new_array(self) + + !> Instance of the TOML array + type(toml_array), intent(out) :: self + + call new_list_structure(self%list) + +end subroutine new_array + + +!> Default constructor for TOML array type +function new_array_func() result(self) + + !> Instance of the TOML array + type(toml_array) :: self + + call new_array(self) + +end function new_array_func + + +!> Check whether data structure is initialized properly +pure function array_initialized(self) result(okay) + + !> Instance of the TOML array + type(toml_array), intent(in) :: self + + !> Data structure is initialized + logical :: okay + + okay = allocated(self%list) +end function array_initialized + + +!> Get number of TOML values in the array +pure function get_len(self) result(length) + + !> Instance of the TOML array + class(toml_array), intent(in) :: self + + !> Current length of the array + integer :: length + + length = self%list%get_len() + +end function get_len + + +!> Get the TOML value at the respective index +subroutine get(self, idx, ptr) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> Index to the TOML value + integer, intent(in) :: idx + + !> Pointer to the TOML value + class(toml_value), pointer, intent(out) :: ptr + + call self%list%get(idx, ptr) + +end subroutine get + + +!> Push back a TOML value to the array +subroutine push_back(self, val, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to append to array + class(toml_value), allocatable, intent(inout) :: val + + !> Status of operation + integer, intent(out) :: stat + + if (allocated(val%key)) then + stat = toml_stat%fatal + return + end if + + call self%list%push_back(val) + + stat = toml_stat%success + +end subroutine push_back + + +!> Remove the first element from the data structure +subroutine shift(self, val) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + call self%list%shift(val) + +end subroutine shift + + +!> Remove the last element from the data structure +subroutine pop(self, val) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + call self%list%pop(val) + +end subroutine pop + + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%list)) then + call self%list%destroy + deallocate(self%list) + end if + +end subroutine destroy + + +end module tomlf_type_array diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 new file mode 100644 index 000000000..06e163412 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 @@ -0,0 +1,367 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML key-value pair data type +!> +!> A [[toml_keyval]] represents a single key-value pair in a TOML document. +!> It can hold any of the TOML value types: strings, integers, floats, +!> booleans, and datetimes. +!> +!> Key-value pairs are typically accessed through their parent table using +!> [[get_value]] rather than directly manipulating this type. +module tomlf_type_keyval + use tomlf_constants, only : tfc, tfr, tfi, toml_type + use tomlf_datetime, only : toml_datetime + use tomlf_type_value, only : toml_value, toml_visitor + implicit none + private + + public :: toml_keyval, new_keyval, new + + + !> Generic TOML value + type, abstract :: generic_value + end type generic_value + + !> TOML real value + type, extends(generic_value) :: float_value + real(tfr) :: raw + end type float_value + + !> TOML integer value + type, extends(generic_value) :: integer_value + integer(tfi) :: raw + end type integer_value + + !> TOML boolean value + type, extends(generic_value) :: boolean_value + logical :: raw + end type boolean_value + + !> TOML datetime value + type, extends(generic_value) :: datetime_value + type(toml_datetime) :: raw + end type datetime_value + + !> TOML string value + type, extends(generic_value) :: string_value + character(:, tfc), allocatable :: raw + end type string_value + + + + !> TOML key-value pair + type, extends(toml_value) :: toml_keyval + + !> Actual TOML value + class(generic_value), allocatable :: val + + !> Origin of value + integer :: origin_value = 0 + + contains + + !> Get the value stored in the key-value pair + generic :: get => get_float, get_integer, get_boolean, get_datetime, get_string + procedure :: get_float + procedure :: get_integer + procedure :: get_boolean + procedure :: get_datetime + procedure :: get_string + + !> Set the value for the key-value pair + generic :: set => set_float, set_integer, set_boolean, set_datetime, set_string + procedure :: set_float + procedure :: set_integer + procedure :: set_boolean + procedure :: set_datetime + procedure :: set_string + + !> Get the type of the value stored in the key-value pair + procedure :: get_type + + !> Release allocation hold by TOML key-value pair + procedure :: destroy + + end type toml_keyval + + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_keyval + end interface + + +contains + + +!> Constructor to create a new TOML key-value pair +subroutine new_keyval(self) + + !> Instance of the TOML key-value pair + type(toml_keyval), intent(out) :: self + + associate(self => self); end associate + +end subroutine new_keyval + + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%val)) then + deallocate(self%val) + end if + +end subroutine destroy + + +!> Obtain real value from TOML key-value pair +subroutine get_float(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + real(tfr), pointer, intent(out) :: val + + val => cast_float(self%val) +end subroutine get_float + + +!> Obtain integer value from TOML key-value pair +subroutine get_integer(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + integer(tfi), pointer, intent(out) :: val + + val => cast_integer(self%val) +end subroutine get_integer + + +!> Obtain boolean value from TOML key-value pair +subroutine get_boolean(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + logical, pointer, intent(out) :: val + + val => cast_boolean(self%val) +end subroutine get_boolean + + +!> Obtain datetime value from TOML key-value pair +subroutine get_datetime(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + type(toml_datetime), pointer, intent(out) :: val + + val => cast_datetime(self%val) +end subroutine get_datetime + + +!> Obtain datetime value from TOML key-value pair +subroutine get_string(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + character(:, tfc), pointer, intent(out) :: val + + val => cast_string(self%val) +end subroutine get_string + + +!> Obtain real value from TOML key-value pair +subroutine set_float(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + real(tfr), intent(in) :: val + + type(float_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_float + + +!> Obtain integer value from TOML key-value pair +subroutine set_integer(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + integer(tfi), intent(in) :: val + + type(integer_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_integer + + +!> Obtain boolean value from TOML key-value pair +subroutine set_boolean(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + logical, intent(in) :: val + + type(boolean_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_boolean + + +!> Obtain datetime value from TOML key-value pair +subroutine set_datetime(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + type(toml_datetime), intent(in) :: val + + type(datetime_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_datetime + + +!> Obtain datetime value from TOML key-value pair +subroutine set_string(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + character(*, tfc), intent(in) :: val + + type(string_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_string + + +!> Get the type of the value stored in the key-value pair +pure function get_type(self) result(value_type) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value type + integer :: value_type + + select type(val => self%val) + class default + value_type = toml_type%invalid + type is(float_value) + value_type = toml_type%float + type is(integer_value) + value_type = toml_type%int + type is(boolean_value) + value_type = toml_type%boolean + type is(datetime_value) + value_type = toml_type%datetime + type is(string_value) + value_type = toml_type%string + end select +end function get_type + + +function cast_float(val) result(ptr) + class(generic_value), intent(in), target :: val + real(tfr), pointer :: ptr + + nullify(ptr) + select type(val) + type is(float_value) + ptr => val%raw + end select +end function cast_float + +function cast_integer(val) result(ptr) + class(generic_value), intent(in), target :: val + integer(tfi), pointer :: ptr + + nullify(ptr) + select type(val) + type is(integer_value) + ptr => val%raw + end select +end function cast_integer + +function cast_boolean(val) result(ptr) + class(generic_value), intent(in), target :: val + logical, pointer :: ptr + + nullify(ptr) + select type(val) + type is(boolean_value) + ptr => val%raw + end select +end function cast_boolean + +function cast_datetime(val) result(ptr) + class(generic_value), intent(in), target :: val + type(toml_datetime), pointer :: ptr + + nullify(ptr) + select type(val) + type is(datetime_value) + ptr => val%raw + end select +end function cast_datetime + +function cast_string(val) result(ptr) + class(generic_value), intent(in), target :: val + character(:, tfc), pointer :: ptr + + nullify(ptr) + select type(val) + type is(string_value) + ptr => val%raw + end select +end function cast_string + +end module tomlf_type_keyval diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type/table.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type/table.f90 new file mode 100644 index 000000000..fec9dbff0 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/table.f90 @@ -0,0 +1,266 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML table data type +!> +!> A [[toml_table]] represents a TOML table (also known as a hash table or +!> dictionary). Every TOML document contains at least one root table which +!> holds key-value pairs, arrays, and nested tables. +!> +!> Tables are the primary way to access parsed TOML data. Use [[get_value]] +!> from the build module to retrieve values by key, or the type-bound +!> procedures for direct access. +module tomlf_type_table + use tomlf_constants, only : tfc + use tomlf_error, only : toml_stat + use tomlf_type_value, only : toml_value, toml_visitor, toml_key + use tomlf_structure, only : toml_map_structure, new_map_structure + implicit none + private + + public :: toml_table, new_table, new, initialized + + + !> TOML table + type, extends(toml_value) :: toml_table + + !> Table was implictly created + logical :: implicit = .false. + + !> Is an inline table and is therefore non-extendable + logical :: inline = .false. + + !> Storage unit for TOML values of this table + class(toml_map_structure), allocatable, private :: map + + contains + + !> Get the TOML value associated with the respective key + procedure :: get + + !> Get list of all keys in this table + procedure :: get_keys + + !> Check if key is already present in this table instance + procedure :: has_key + + !> Append value to table (checks automatically for key) + procedure :: push_back + + !> Remove TOML value at a given key and return it + procedure :: pop + + !> Delete TOML value at a given key + procedure :: delete + + !> Release allocation hold by TOML table + procedure :: destroy + + end type toml_table + + + !> Create standard constructor + interface toml_table + module procedure :: new_table_func + end interface toml_table + + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_table + end interface + + + !> Check whether data structure is initialized properly + interface initialized + module procedure :: table_initialized + end interface initialized + + +contains + + +!> Constructor to create a new TOML table and allocate the internal storage +subroutine new_table(self) + + !> Instance of the TOML table + type(toml_table), intent(out) :: self + + call new_map_structure(self%map) + +end subroutine new_table + + +!> Default constructor for TOML table type +function new_table_func() result(self) + + !> Instance of the TOML table + type(toml_table) :: self + + call new_table(self) + +end function new_table_func + + +!> Check whether data structure is initialized properly +pure function table_initialized(self) result(okay) + + !> Instance of the TOML table + type(toml_table), intent(in) :: self + + !> Data structure is initialized + logical :: okay + + okay = allocated(self%map) +end function table_initialized + + +!> Get the TOML value associated with the respective key +subroutine get(self, key, ptr) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the TOML value + class(toml_value), pointer, intent(out) :: ptr + + call self%map%get(key, ptr) + +end subroutine get + + +!> Get list of all keys in this table +subroutine get_keys(self, list) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + call self%map%get_keys(list) + +end subroutine get_keys + + +!> Check if a key is present in the table +function has_key(self, key) result(found) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> TOML value is present in table + logical :: found + + class(toml_value), pointer :: ptr + + call self%map%get(key, ptr) + + found = associated(ptr) + +end function has_key + + +!> Push back a TOML value to the table +subroutine push_back(self, val, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> TOML value to append to table + class(toml_value), allocatable, intent(inout) :: val + + !> Status of operation + integer, intent(out) :: stat + + class(toml_value), pointer :: ptr + + if (.not.allocated(val)) then + stat = merge(self%origin, toml_stat%fatal, self%origin > 0) + return + end if + + if (.not.allocated(val%key)) then + stat = merge(val%origin, toml_stat%fatal, val%origin > 0) + return + end if + + call self%get(val%key, ptr) + if (associated(ptr)) then + stat = merge(ptr%origin, toml_stat%duplicate_key, ptr%origin > 0) + return + end if + + call self%map%push_back(val) + + stat = toml_stat%success + +end subroutine push_back + + +!> Remove TOML value at a given key and return it +subroutine pop(self, key, val) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value to return + class(toml_value), allocatable, intent(out) :: val + + call self%map%pop(key, val) + +end subroutine pop + + +!> Delete TOML value at a given key +subroutine delete(self, key) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + call self%map%delete(key) + +end subroutine delete + + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%map)) then + call self%map%destroy + deallocate(self%map) + end if + +end subroutine destroy + + +end module tomlf_type_table diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type/value.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type/value.f90 new file mode 100644 index 000000000..1eb28f8b9 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/value.f90 @@ -0,0 +1,162 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstract base types for TOML values +!> +!> This module defines the abstract [[toml_value]] base type from which all +!> concrete TOML types ([[toml_table]], [[toml_array]], [[toml_keyval]]) +!> inherit. It also provides the [[toml_visitor]] abstract type for +!> implementing the visitor pattern. +!> +!> Most users will not need to work with these types directly, but they +!> are useful for implementing custom algorithms that traverse TOML +!> data structures. +module tomlf_type_value + use tomlf_constants, only : tfc, TOML_BAREKEY + use tomlf_utils, only : toml_escape_string + implicit none + private + + public :: toml_value, toml_visitor, toml_key + + + !> Abstract base value for TOML data types + type, abstract :: toml_value + + !> Raw representation of the key to the TOML value + character(kind=tfc, len=:), allocatable :: key + + !> Original source of the value + integer :: origin = 0 + + contains + + !> Accept a visitor to transverse the data structure + procedure :: accept + + !> Get escaped key to TOML value + procedure :: get_key + + !> Compare raw key of TOML value to input key + procedure :: match_key + + !> Release allocation hold by TOML value + procedure(destroy), deferred :: destroy + + end type toml_value + + + !> Abstract visitor for TOML values + type, abstract :: toml_visitor + contains + + !> Visitor visiting a TOML value + procedure(visit), deferred :: visit + + end type toml_visitor + + + !> Thin wrapper around the deferred-size character intrinisc + type :: toml_key + + !> Raw representation of the key to the TOML value + character(kind=tfc, len=:), allocatable :: key + + !> Original source of the value + integer :: origin = 0 + + end type toml_key + + + abstract interface + !> Accept a visitor to transverse the data structure + recursive subroutine visit(self, val) + import toml_value, toml_visitor + + !> Instance of the visitor + class(toml_visitor), intent(inout) :: self + + !> Value to visit + class(toml_value), intent(inout) :: val + end subroutine visit + + !> Deconstructor to cleanup allocations (optional) + subroutine destroy(self) + import toml_value + + !> Instance of the TOML value + class(toml_value), intent(inout) :: self + + end subroutine destroy + + end interface + + +contains + + +!> Accept a visitor to transverse the data structure +recursive subroutine accept(self, visitor) + + !> Instance of the TOML value + class(toml_value), intent(inout) :: self + + !> Visitor for this value + class(toml_visitor), intent(inout) :: visitor + + call visitor%visit(self) + +end subroutine accept + + +!> Get escaped key to TOML value +subroutine get_key(self, key) + + !> TOML value instance. + class(toml_value), intent(in) :: self + + !> Contains valid TOML key on exit + character(kind=tfc, len=:), allocatable :: key + + if (allocated(self%key)) then + if (verify(self%key, TOML_BAREKEY) == 0 .and. len(self%key) > 0) then + key = self%key + else + call toml_escape_string(self%key, key) + end if + end if + +end subroutine get_key + + +!> Compare raw key of TOML value to input key +pure function match_key(self, key) result(match) + + !> TOML value instance. + class(toml_value), intent(in) :: self + + !> TOML raw key to compare to + character(kind=tfc, len=*), intent(in) :: key + + logical :: match + + if (allocated(self%key)) then + match = key == self%key + else + match = .false. + end if + +end function match_key + + +end module tomlf_type_value diff --git a/source/third_party_open/utils/toml-f/src/tomlf/utils.f90 b/source/third_party_open/utils/toml-f/src/tomlf/utils.f90 new file mode 100644 index 000000000..00648f728 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/utils.f90 @@ -0,0 +1,260 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +module tomlf_utils + use tomlf_constants + use tomlf_datetime, only : toml_datetime, toml_date, toml_time, to_string + use tomlf_utils_io, only : read_whole_file, read_whole_line + implicit none + private + + public :: toml_escape_string + public :: to_string + public :: read_whole_file, read_whole_line + + + interface to_string + module procedure :: to_string_i1 + module procedure :: to_string_i2 + module procedure :: to_string_i4 + module procedure :: to_string_i8 + module procedure :: to_string_r8 + end interface to_string + + +contains + + +!> Escape all special characters in a TOML string +subroutine toml_escape_string(raw, escaped, multiline) + + !> Raw representation of TOML string + character(kind=tfc, len=*), intent(in) :: raw + + !> Escaped view of the TOML string + character(kind=tfc, len=:), allocatable, intent(out) :: escaped + + !> Preserve newline characters + logical, intent(in), optional :: multiline + + integer :: i + logical :: preserve_newline + + preserve_newline = .false. + if (present(multiline)) preserve_newline = multiline + + escaped = '"' + do i = 1, len(raw) + select case(raw(i:i)) + case default; escaped = escaped // raw(i:i) + case('\'); escaped = escaped // '\\' + case('"'); escaped = escaped // '\"' + case(TOML_NEWLINE) + if (preserve_newline) then + escaped = escaped // raw(i:i) + else + escaped = escaped // '\n' + end if + case(TOML_FORMFEED); escaped = escaped // '\f' + case(TOML_CARRIAGE_RETURN); escaped = escaped // '\r' + case(TOML_TABULATOR); escaped = escaped // '\t' + case(TOML_BACKSPACE); escaped = escaped // '\b' + end select + end do + escaped = escaped // '"' + +end subroutine toml_escape_string + + +!> Represent an integer as character sequence. +pure function to_string_i1(val) result(string) + integer, parameter :: ik = tf_i1 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i1 + + +!> Represent an integer as character sequence. +pure function to_string_i2(val) result(string) + integer, parameter :: ik = tf_i2 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i2 + + +!> Represent an integer as character sequence. +pure function to_string_i4(val) result(string) + integer, parameter :: ik = tf_i4 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i4 + + +!> Represent an integer as character sequence. +pure function to_string_i8(val) result(string) + integer, parameter :: ik = tf_i8 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i8 + +!> Represent an real as character sequence. +pure function to_string_r8(val) result(string) + integer, parameter :: rk = tfr + !> Real value to create string from + real(rk), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + character(128, tfc) :: buffer + + if (val > huge(val)) then + string = "+inf" + else if (val < -huge(val)) then + string = "-inf" + else if (val /= val) then + string = "nan" + else + if (abs(val) >= 1.0e+100_rk) then + write(buffer, '(es24.16e3)') val + else if (abs(val) >= 1.0e+10_rk) then + write(buffer, '(es24.16e2)') val + else if (abs(val) >= 1.0e+3_rk) then + write(buffer, '(es24.16e1)') val + else + write(buffer, '(f24.16)') val + end if + string = trim(adjustl(buffer)) + end if +end function to_string_r8 + +end module tomlf_utils diff --git a/source/third_party_open/utils/toml-f/src/tomlf/utils/io.f90 b/source/third_party_open/utils/toml-f/src/tomlf/utils/io.f90 new file mode 100644 index 000000000..5580c1ac6 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/utils/io.f90 @@ -0,0 +1,90 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Utilities for handling input and output operations +module tomlf_utils_io + use tomlf_constants, only : tfc + implicit none + private + + public :: read_whole_file, read_whole_line + + +contains + +!> Read a whole file into an array of characters +subroutine read_whole_file(filename, string, stat) + !> File to read + character(*, tfc), intent(in) :: filename + !> Array of characters representing the file + character(:, tfc), allocatable, intent(out) :: string + !> Error status + integer, intent(out) :: stat + + integer :: io, length + + open(file=filename, & + & status="old", & + & access="stream", & + & position="append", & + & newunit=io, & + & iostat=stat) + if (stat == 0) then + inquire(unit=io, pos=length) + allocate(character(length-1, tfc) :: string, stat=stat) + end if + if (stat == 0) then + read(io, pos=1, iostat=stat) string(:length-1) + end if + if (stat == 0) then + close(io) + end if +end subroutine read_whole_file + +!> Read a whole line from a formatted unit into a deferred length character variable +subroutine read_whole_line(io, string, stat) + !> Formatted IO unit + integer, intent(in) :: io + !> Line to read + character(:, tfc), allocatable, intent(out) :: string + !> Status of operation + integer, intent(out) :: stat + + integer, parameter :: bufsize = 4096 + character(bufsize, tfc) :: buffer, msg + integer :: chunk + logical :: opened + + if (io /= -1) then + inquire(unit=io, opened=opened) + else + opened = .false. + end if + + if (opened) then + open(unit=io, pad="yes", iostat=stat) + else + stat = 1 + msg = "Unit is not connected" + end if + + string = "" + do while (stat == 0) + read(io, '(a)', advance='no', iostat=stat, size=chunk) buffer + if (stat > 0) exit + string = string // buffer(:chunk) + end do + if (is_iostat_eor(stat)) stat = 0 +end subroutine read_whole_line + +end module tomlf_utils_io diff --git a/source/third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 b/source/third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 new file mode 100644 index 000000000..af76ebe82 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 @@ -0,0 +1,141 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Sorting algorithms to work with hash maps +module tomlf_utils_sort + use tomlf_type_value, only : toml_key + implicit none + private + + public :: sort, compare_less + + + !> Create overloaded interface for export + interface sort + module procedure :: sort_keys + end interface + + + abstract interface + !> Define order relation between two TOML keys + pure function compare_less(lhs, rhs) result(less) + import :: toml_key + !> Left hand side TOML key in comparison + type(toml_key), intent (in) :: lhs + !> Right hand side TOML key in comparison + type(toml_key), intent (in) :: rhs + !> Comparison result + logical :: less + end function compare_less + end interface + + +contains + + + !> Entry point for sorting algorithm + pure subroutine sort_keys(list, idx, compare) + + !> List of TOML keys to be sorted + type(toml_key), intent(inout) :: list(:) + + !> Optionally, mapping from unsorted list to sorted list + integer, intent(out), optional :: idx(:) + + !> Function implementing the order relation between two TOML keys + procedure(compare_less), optional :: compare + + integer :: low, high, i + type(toml_key), allocatable :: sorted(:) + integer, allocatable :: indexarray(:) + + low = 1 + high = size(list) + + allocate(sorted, source=list) + + allocate(indexarray(high), source=[(i, i=low, high)]) + + if (present(compare)) then + call quicksort(sorted, indexarray, low, high, compare) + else + call quicksort(sorted, indexarray, low, high, compare_keys_less) + end if + + do i = low, high + list(i) = sorted(indexarray(i)) + end do + + if (present(idx)) then + idx = indexarray + end if + + end subroutine sort_keys + + + !> Actual quick sort implementation + pure recursive subroutine quicksort(list, idx, low, high, less) + type(toml_key), intent(inout) :: list(:) + integer, intent(inout) :: idx(:) + integer, intent(in) :: low, high + procedure(compare_less) :: less + + integer :: i, last + integer :: pivot + + if (low < high) then + + call swap(idx(low), idx((low + high)/2)) + last = low + do i = low + 1, high + if (less(list(idx(i)), list(idx(low)))) then + last = last + 1 + call swap(idx(last), idx(i)) + end if + end do + call swap(idx(low), idx(last)) + pivot = last + + call quicksort(list, idx, low, pivot - 1, less) + call quicksort(list, idx, pivot + 1, high, less) + end if + + end subroutine quicksort + + + !> Swap two integer values + pure subroutine swap(lhs, rhs) + integer, intent(inout) :: lhs + integer, intent(inout) :: rhs + + integer :: tmp + + tmp = lhs + lhs = rhs + rhs = tmp + + end subroutine swap + + + !> Default comparison between two TOML keys + pure function compare_keys_less(lhs, rhs) result(less) + type(toml_key), intent (in) :: lhs + type(toml_key), intent (in) :: rhs + logical :: less + + less = lhs%key < rhs%key + + end function compare_keys_less + + +end module tomlf_utils_sort diff --git a/source/third_party_open/utils/toml-f/src/tomlf/version.f90 b/source/third_party_open/utils/toml-f/src/tomlf/version.f90 new file mode 100644 index 000000000..89b36d3f0 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/version.f90 @@ -0,0 +1,74 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Version information on TOML-Fortran +module tomlf_version + implicit none + private + + public :: get_tomlf_version + public :: tomlf_version_string, tomlf_version_compact + + + !> String representation of the TOML-Fortran version + character(len=*), parameter :: tomlf_version_string = "0.5.0" + + !> Major version number of the above TOML-Fortran version + integer, parameter :: tomlf_major = 0 + + !> Minor version number of the above TOML-Fortran version + integer, parameter :: tomlf_minor = 5 + + !> Patch version number of the above TOML-Fortran version + integer, parameter :: tomlf_patch = 0 + + !> Compact numeric representation of the TOML-Fortran version + integer, parameter :: tomlf_version_compact = & + & tomlf_major*10000 + tomlf_minor*100 + tomlf_patch + + +contains + + +!> Getter function to retrieve TOML-Fortran version +subroutine get_tomlf_version(major, minor, patch, string) + + !> Major version number of the TOML-Fortran version + integer, intent(out), optional :: major + + !> Minor version number of the TOML-Fortran version + integer, intent(out), optional :: minor + + !> Patch version number of the TOML-Fortran version + integer, intent(out), optional :: patch + + !> String representation of the TOML-Fortran version + character(len=:), allocatable, intent(out), optional :: string + + if (present(major)) then + major = tomlf_major + end if + if (present(minor)) then + minor = tomlf_minor + end if + if (present(patch)) then + patch = tomlf_patch + end if + if (present(string)) then + string = tomlf_version_string + end if + +end subroutine get_tomlf_version + + +end module tomlf_version