diff --git a/.gitignore b/.gitignore index 22752d026..04acf563a 100644 --- a/.gitignore +++ b/.gitignore @@ -65,3 +65,12 @@ 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 +/source/build_nvfortran_gpu_h7.sh +/source/build_nvfortran_gpu.sh +/source/Singularityfile-gpu.def +/source/Dockerfile.xpu +/source/Dockerfile.gpu.test +/source/Dockerfile.gpu.update01 +/source/Dockerfile.gpu +/source/Dockerfile.gpu.25.5.ccall +/docs/_build diff --git a/docs/conf.py b/docs/conf.py index 35390d8f3..5dcd94ef8 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -63,7 +63,7 @@ def setup(app): # General information about the project. project = u'SFINCS' -copyright = u'2018-2025, Deltares' +copyright = u'2018-2026, Deltares' author = u'Tim Leijnse' # The version info for the project you're documenting, acts as replacement for @@ -71,9 +71,9 @@ def setup(app): # built documents. # # The short X.Y version. -version = '2.3.0_mt_Faber' +version = '2.4.0_Galibier' # The full version, including alpha/beta/rc tags. -release = '2.3.0_mt_Faber' +release = '2.4.0_Galibier' # The language for content autogenerated by Sphinx. Refer to documentation # for a list of supported languages. diff --git a/docs/developments.rst b/docs/developments.rst index e2bfe7ea8..f4ffa678d 100644 --- a/docs/developments.rst +++ b/docs/developments.rst @@ -6,14 +6,14 @@ SFINCS has continuely being developed since 2017, and many great features have b Development status ----- -See here a schematic overview of the SFINCS development status at November 2025, at the time of the v2.3.0 mt. Faber release. -Indicated are new functionality for SFINCS itself (core), and model setup/post-processing using HydroMT-SFINCS (Python). +See here a table overview of the SFINCS development status at June 2026, at the time of the v2.4.0 Galibier 2026.01 release. +Indicated are SFINCS itself (model) and model setup/post-processing using HydroMT-SFINCS (Python), green indicates existing General Available (GA) functionality. -.. figure:: ./figures/Overview_status_SFINCS-2025.02.drawio.png +.. figure:: ./figures/SFINCS_development_status_Galibier_2026_01_release.png :width: 600px :align: center - Overview of SFINCS development status 2025.02 Release + Overview of SFINCS development status 2026.01 Release Known issues ----- @@ -24,11 +24,67 @@ Known issues/warnings of the current SFINCS main version and last release are li * The BMI implementation in SFINCS is up to date with XMI (BMI + extensions - Hughes et al. 2022), to be used with 'xmipy' (https://github.com/Deltares/xmipy) and related functions (https://deltares.github.io/xmipy/xmipy.html), which is however not up to date with the latests CSDMS standard BMI implementation 2.0. * The combination of netspwfile with large difference in reference time between the spiderweb and the SFINCS simulation itself, might not run correctly in the Docker version. Use the ascii spwfile input or the Windows build executable which work correctly. * Docker GPU version of Deltares latest is not fully functional, and therefore removed from the repo. If you'd want to use the GPU version of SFINCS, get in touch to set up a collaboration. -* Issue in SFINCS v2.3.0 mt Faber Release regarding Curve Number infiltration if storecumprcp = 0 (default), then infiltration is not processed correctly and can result to unrealistic results! Simple solution for now: put storecumprcp = 1 when using this infiltration option. This issue is already fixed in SFINCS main, and therefore also in the next official release! +* Issue in SFINCS v2.3.0 mt Faber Release regarding Curve Number infiltration if storecumprcp = 0 (default), then infiltration is not processed correctly and can result to unrealistic results! Simple solution for now: put storecumprcp = 1 when using this infiltration option. This issue is fixed in the 2026.01 Galibier Release! Releases Changelog ----- +Official open source version 2026.01: v2.4.0 Galibier release release +^^^^^ + +The first official 2026 release of SFINCS, the v2.4.0 Galibier release, 'Generating Accurate Large-scale Inundation: Better Insights for Emergency Response', is now available! + +This contains open access to the source code from Github: https://github.com/Deltares/SFINCS/releases/tag/v2.4.0_Galibier_release. + +As pre-compiled Windows executable: + +https://download.deltares.nl/en/sfincs/ + +As Docker container: + +docker pull deltares/sfincs-cpu:sfincs-v2.4.0-Galibier-Release + +Changes: + +The code consists of all functionality of the 2025.02 'v2.3.0 mt. Faber' release, with the following main changes/additions: + +* Added option for timestep analysis (sfincs.inp: timestep_analysis = 1). Flag to write timestep limiter variables average_required_timestep and percentage_limiting_timestep to the sfincs_map.nc file and screen to analyse what cells are limiting the global timestep. +* Quadtree netcdf output sfincs_map.nc files can now directly be loaded and visuallised in QGIS. +* Added input variable 'huvmin', minimum depth for calculating velocity (uv = q / max(hu, huvmin)), used for output and advection. +* Added input variable 'snapwave_waveforces_factor' which you can set to 0 to turn off wave forces and thus incident wave setup. +* Made sfincs_his.nc file variables related to waves consistent with other variable (e.g. point_hm0), breaking change for post-processing scripts. Thanks to EgemenAnder for the commits! +* Renaming of wavemaker related input variables (e.g. wavemaker_wvmfile), contains legacy variables for backward compatibility. +* Added multiple validation tests in the renewed testbed report of the new quality control testbed version 2.0. + +* New Python setup tools HydroMT-SFINCS release > recommended to use this new version (v2.0.0) instead of the last release! + +Bugfixes: + +* Fixed bug with Curve Number infiltration if storecumprcp = 0 (default). +* Fixed bug with wavemakers, with waves forced from the north. +* Fixed bug in old binary sbgfile for regular grid (legacy code). +* Fixed bug in neumann boundary for sfincs (msk=6) for specific cases. +* Fixed bug in SnapWave IG source term implementation, with thanks to Yasmine Elmessary. + +Advanced user options - currently as alpha/beta functionality: + +* NOTE - please contact Deltares-SFINCS group in case you want to use any of this functionality. + +* Improvements of the integrated SnapWave solver for wave breaking, and resulting wave-induced setup, on steeper coasts. +* Added vegetation effects in the integrated SnapWave solver. +* Added option of forcing incident wave energy at wavemaker. +* Added hyper-fast, but scandalous, bathtub option. +* Improved GPU immplementation + +See here a schematic overview of the SFINCS development status at June 2026, at the time of the v2.4.0 Galibier 2026.01 release. +Indicated are new functionality for SFINCS itself (core), and model setup/post-processing using HydroMT-SFINCS (Python). + +.. figure:: ./figures/Overview_status_SFINCS-2026.01.drawio.png + :width: 600px + :align: center + + Overview of SFINCS development status 2026.01 Release + Official open source version 2025.02: v2.3.0 mt. Faber release ^^^^^ diff --git a/docs/figures/.$Overview_status_SFINCS.drawio.bkp b/docs/figures/.$Overview_status_SFINCS.drawio.bkp index a25e5719b..bac0e02ca 100644 --- a/docs/figures/.$Overview_status_SFINCS.drawio.bkp +++ b/docs/figures/.$Overview_status_SFINCS.drawio.bkp @@ -1,43 +1,249 @@ - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - + - + - + - + - + - + - + - + - + - + - + - + @@ -45,25 +251,25 @@ - + - + - + - + - + - + - + @@ -73,7 +279,7 @@ - + @@ -82,7 +288,7 @@ - + @@ -92,7 +298,7 @@ - + @@ -101,7 +307,7 @@ - + @@ -111,25 +317,25 @@ - + - + - + - + - + - + - + @@ -138,7 +344,7 @@ - + @@ -148,85 +354,85 @@ - + - + - + - + - + - + - + - + - + - - + + - + - + - + - + - + - + - + - + - - + + - + - + - + - + - + - + diff --git a/docs/figures/Overview_status_SFINCS-2026.01.drawio.png b/docs/figures/Overview_status_SFINCS-2026.01.drawio.png new file mode 100644 index 000000000..74262c813 Binary files /dev/null and b/docs/figures/Overview_status_SFINCS-2026.01.drawio.png differ diff --git a/docs/figures/Overview_status_SFINCS.drawio b/docs/figures/Overview_status_SFINCS.drawio index 43dcf3c69..141f8d75a 100644 --- a/docs/figures/Overview_status_SFINCS.drawio +++ b/docs/figures/Overview_status_SFINCS.drawio @@ -1,4 +1,210 @@ - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/docs/figures/SFINCS_development_status_Galibier_2026_01_release.png b/docs/figures/SFINCS_development_status_Galibier_2026_01_release.png new file mode 100644 index 000000000..31259f08d Binary files /dev/null and b/docs/figures/SFINCS_development_status_Galibier_2026_01_release.png differ diff --git a/docs/index.rst b/docs/index.rst index 8002b8252..5b740dcb0 100644 --- a/docs/index.rst +++ b/docs/index.rst @@ -36,7 +36,7 @@ For more, see “Support Packages” or contact software@deltares.nl **Scientific Foundation and model adoptation:** SFINCS has been widely validated and applied in numerous scientific studies and practical applications worldwide. -The model has been adopted by both the scientific community, where the main SFINCS publications have reached 150+ citations and are listed below for reference. +The model has been adopted by both the scientific community, where the main SFINCS publications have reached 200+ citations and are listed below for reference. SFINCS has also been adopted by practitioners for flood risk assessment, emergency planning, and climate adaptation strategies, with 1000+ downloads of the SFINCS executable and counting... Key publications: diff --git a/source/build_scripts/build_docker_cpu_local.sh b/source/build_scripts/build_docker_cpu_local.sh index fa21fb3b2..5e27276df 100644 --- a/source/build_scripts/build_docker_cpu_local.sh +++ b/source/build_scripts/build_docker_cpu_local.sh @@ -1,4 +1,4 @@ cd /mnt/c/users/leijnse/repos/SFINCS/source -docker build -f ./build_scripts/Dockerfile . -t leynse/sfincs-cpu > build.log 2>&1 +docker build -f ./build_scripts/Dockerfile_cpu_local . -t leynse/sfincs-cpu > build.log 2>&1 docker push leynse/sfincs-cpu diff --git a/source/sfincs/x64/Release/LICENSING CONDITIONS DELTARES FREEWARE EXECUTABLE.txt b/source/sfincs/x64/Release/LICENSING CONDITIONS DELTARES FREEWARE EXECUTABLE.txt index 7998c4532..fe1428c51 100644 --- a/source/sfincs/x64/Release/LICENSING CONDITIONS DELTARES FREEWARE EXECUTABLE.txt +++ b/source/sfincs/x64/Release/LICENSING CONDITIONS DELTARES FREEWARE EXECUTABLE.txt @@ -135,7 +135,7 @@ The SFINCS software is distributed by Deltares as SFINCS Software. SFINCS is als Typical applications of SFINCS include flood forecasting and evaluating the impact of extreme events on flooding. Typical areas of use for SFINCS are coastal areas where compound flood processes play a role, as described in the Deltares Software Documentation. For more information see: https://www.deltares.nl/en/software/SFINCS/ -SFINCS Version 2.3.0 - November 2025 +SFINCS Version 2.4.0 - June 2026 B. Specification of Operational System diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 34bf8f520..36e826f67 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -30,13 +30,16 @@ - + + - - + + + + @@ -45,36 +48,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + - - - + + + + - - + + - - + - - - - + + @@ -93,8 +139,7 @@ - - + @@ -104,8 +149,10 @@ + - + + @@ -116,7 +163,8 @@ - + + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index 891652f08..2711d1a2b 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -15,25 +15,63 @@ 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/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_date.f90 \ + sfincs_read.f90 \ sfincs_spiderweb.f90 \ sfincs_data.f90 \ - ../third_party_open/Delft3D/astro.f90 \ + ../third_party_open/Delft3D/astro.f90 \ ../third_party_open/utils/geometry.f90 \ - sfincs_error.f90 \ + sfincs_error.f90 \ sfincs_quadtree.f90 \ + sfincs_ncinput.F90 \ + sfincs_vegetation.f90 \ snapwave/interp.F90 \ snapwave/snapwave_data.f90 \ - snapwave/snapwave_ncinput.F90 \ - snapwave/snapwave_infragravity.f90 \ + snapwave/snapwave_ncinput.F90 \ + snapwave/snapwave_ncoutput.F90 \ + snapwave/snapwave_infragravity.f90 \ snapwave/snapwave_boundaries.f90 \ snapwave/snapwave_date.f90 \ snapwave/snapwave_domain.f90 \ snapwave/snapwave_windsource.f90 \ + snapwave/snapwave_RFtable.f90 \ snapwave/snapwave_solver.f90 \ sfincs_input.f90 \ - sfincs_ncinput.F90 \ sfincs_initial_conditions.f90 \ sfincs_boundaries.f90 \ sfincs_continuity.f90 \ @@ -50,7 +88,7 @@ libsfincs_la_SOURCES = \ sfincs_snapwave.f90 \ ../third_party_open/utils/deg2utm.f90 \ sfincs_meteo.f90 \ - ../third_party_open/bicgstab/bicgstab_solver_ilu.f90 \ + ../third_party_open/bicgstab/bicgstab_solver_ilu.f90 \ sfincs_nonhydrostatic.f90 \ sfincs_ncoutput.F90 \ sfincs_output.f90 \ diff --git a/source/src/sfincs_boundaries.f90 b/source/src/sfincs_boundaries.f90 index 13a49477c..34d8d64c5 100644 --- a/source/src/sfincs_boundaries.f90 +++ b/source/src/sfincs_boundaries.f90 @@ -200,8 +200,6 @@ subroutine read_boundary_data() ! iok = 0 ! - zs_bnd(ib, itb) = 0.0 - ! endif ! enddo @@ -209,7 +207,7 @@ subroutine read_boundary_data() ! if (iok == 0) then ! - write(logstr,'(a)')'Warning! Very low, very high or NaN values found in boundary conditions file ! These have now been replaced with zeros. Please check !' + write(logstr,'(a)')'Warning! Very low, very high or NaN values found in boundary conditions file ! Please check !' call write_log(logstr, 1) ! endif diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 6e9e23a8a..c5ada99dd 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -106,7 +106,7 @@ module sfincs_data real*4 factor_pres real*4 factor_prcp real*4 factor_spw_size - real*4 waveforces_factor + real*4 waveforces_ratio ! integer mmax integer nmax @@ -165,6 +165,8 @@ module sfincs_data character*256 :: z0lfile character*256 :: qtrfile character*256 :: volfile + character*256 :: veggiefile + character*256 :: veggietype_toml ! TOML lookup table companion to veggiefile ! character*256 :: trefstr_iso8601 character*41 :: treftimefews @@ -193,6 +195,8 @@ module sfincs_data logical :: subgrid logical :: manning2d ! spatially-varying roughness logical :: coriolis + logical :: vegetation + logical :: snapwave_vegetation logical :: store_cumulative_precipitation logical :: store_maximum_waterlevel logical :: store_maximum_waterdepth @@ -207,6 +211,7 @@ module sfincs_data logical :: store_zvolume logical :: store_storagevolume logical :: store_meteo + logical :: store_vegetation logical :: store_wind logical :: store_wind_max logical :: store_wave_forces @@ -420,6 +425,17 @@ module sfincs_data ! real*4, dimension(:), allocatable :: uvmean ! + ! Vegetation + ! + integer :: vegetation_vertical_segments ! nr of vegetation sections in vertical + real*4, dimension(:,:), allocatable :: vegetation_stems_cd + real*4, dimension(:,:), allocatable :: vegetation_stems_height + real*4, dimension(:,:), allocatable :: vegetation_stems_diameter + real*4, dimension(:,:), allocatable :: vegetation_stems_density + integer, dimension(:), allocatable :: vegetation_type_index ! per-cell integer type id from NetCDF + ! Wave forces limiter determined in sfincs_snapwave + real*4 :: fwmaxfac + ! !!! Wave makers ! character*256 :: wavemaker_wvmfile ! polylines diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index dd50ffd27..2d3a7262f 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -2,7 +2,7 @@ module sfincs_discharges use sfincs_log use sfincs_error - + ! contains ! subroutine read_discharges() @@ -47,7 +47,9 @@ subroutine read_discharges() 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 @@ -100,6 +102,7 @@ subroutine read_discharges() do n = 1, nsrc read(500,*)xsrc(n), ysrc(n) enddo + ! close(500) ! ! Read discharge time series @@ -111,14 +114,22 @@ subroutine read_discharges() 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) + close(502) + ! + endif + ! + if (nsrc > 0) then + ! + ! Check times at once for either srcfile or netsrcdisfile ! if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then ! @@ -141,12 +152,8 @@ subroutine read_discharges() ! endif ! - endif - ! - endif - ! - if (nsrc > 0) then - ! + endif + ! ! Determine m and n indices of sources ! do isrc = 1, nsrc @@ -277,15 +284,20 @@ subroutine read_discharges() ! 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)) + ! Get coords of source and sink points, and compute distance between them. + ! Only do this when both points were found inside the active grid (nmindsrc > 0); + ! if either point is outside, skip to avoid an index-0 array access. ! - drainage_distance(idrn) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + if (nmindsrc(nsrc + idrn * 2 - 1) > 0 .and. nmindsrc(nsrc + idrn * 2) > 0) then + ! + xsnk_tmp = z_xz(nmindsrc(nsrc + idrn * 2 - 1)) + ysnk_tmp = z_yz(nmindsrc(nsrc + idrn * 2 - 1)) + xsrc_tmp = z_xz(nmindsrc(nsrc + idrn * 2)) + ysrc_tmp = z_yz(nmindsrc(nsrc + idrn * 2)) + ! + drainage_distance(idrn) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + ! + endif ! enddo ! @@ -347,7 +359,9 @@ subroutine update_discharges(t, dt, tloop) enddo itsrclast = itsrc - 1 exit + ! endif + ! enddo ! !$acc update device(qtsrc) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 65bd1015e..d754dee73 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -10,6 +10,7 @@ subroutine initialize_domain() use sfincs_data use quadtree use sfincs_infiltration + use sfincs_vegetation use sfincs_timestep_analysis ! implicit none @@ -28,6 +29,8 @@ subroutine initialize_domain() ! call initialize_storage_volume() ! + call initialize_vegetation() + ! call initialize_hydro() ! if (timestep_analysis) then diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index bce4af73f..147004080 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -947,15 +947,20 @@ subroutine update_infiltration_map(dt, tloop) ! ! Infiltrating here ! - ! Count how long this is already going + ! Count how long this is already going. + ! If rain_T1 was positive (recovery phase), reset it to 0 for this storm onset + ! and do NOT apply the decrement yet — otherwise the first time step of a new + ! storm would start with rain_T1 = -dt, underestimating infiltration capacity. ! if (rain_T1(nm) > 0.0) then ! rain_T1(nm) = 0.0 ! + else + ! + rain_T1(nm) = rain_T1(nm) - dt ! negative amount of how long it is infiltrating + ! endif - ! - rain_T1(nm) = rain_T1(nm) - dt ! negative amount of how long it is infiltrating ! ! Compute estimate of infiltration ! Note that qinffield = horton_fc ! diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index efbad2e9a..40dc39105 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -10,6 +10,7 @@ subroutine read_sfincs_input() use sfincs_date use sfincs_log use sfincs_error + use sfincs_read ! implicit none ! @@ -203,6 +204,7 @@ subroutine read_sfincs_input() call read_logical_input(500, 'bathtub', bathtub, .false.) call read_real_input(500, 'bathtub_fachs', bathtub_fac_hs, 0.2) call read_real_input(500, 'bathtub_dt', bathtub_dt, -999.0) + call read_logical_input(500,'vegetation',vegetation,.false.) ! ! Domain ! @@ -219,6 +221,8 @@ subroutine read_sfincs_input() call read_char_input(500,'manningfile',manningfile,'none') call read_char_input(500,'drnfile',drnfile,'none') call read_char_input(500,'volfile',volfile,'none') + call read_char_input(500,'vegetationfile',veggiefile,'none') + call read_char_input(500,'vegetationtype_toml',veggietype_toml,'none') ! companion TOML lookup table; if set, veggiefile holds only vegetation_type integers ! ! Forcing ! @@ -299,8 +303,9 @@ subroutine read_sfincs_input() 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) + call read_int_input(500,'snapwave_wind',iwind,0) + call read_logical_input(500,'snapwave_vegetation',snapwave_vegetation,.false.) + call read_real_input(500,'snapwave_waveforces_ratio',waveforces_ratio,1.0) ! ! Wind drag ! @@ -485,6 +490,14 @@ subroutine read_sfincs_input() endif endif ! + store_vegetation = .false. + if (vegetation .or. snapwave_vegetation) then + ! + store_vegetation = .true. + ! vegetation can be used in SnapWave and/or SFINCS calculations + ! + endif + ! store_twet = .false. if (storetwet==1) then store_twet = .true. @@ -734,303 +747,4 @@ subroutine read_sfincs_input() 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.) - ! - read(fileid,'(a)',iostat = stat)line - ! - if (stat==-1) exit - ! - call read_line(line, keystr, valstr) - ! - if (trim(keystr)==trim(keyword)) then - ! - read(valstr,*)value - ! - exit - ! - 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 - ! - 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 - ! - read(valstr,*)(value(m), m = 1, nr) - ! - exit - ! - 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 - ! - 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 - ! - read(valstr,*)value - ! - exit - ! - endif - ! - enddo - ! - 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.) - ! - read(fileid,'(a)',iostat = stat)line - ! - if (stat==-1) exit - ! - call read_line(line, keystr, valstr) - ! - if (trim(keystr)==trim(keyword)) then - ! - value = valstr - ! - exit - ! - 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 - ! - 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 - ! - 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 - ! - exit - ! - 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. - ! - jn = index(line, '\r') - ! - if (jn > 0) then - ! - ! New line character detected (probably sfincs.inp with windows line endings, running in linux) - ! - 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 - ! - jn = index(valstr, '#') - ! - if (jn > 0) then - ! - valstr = trim(valstr(1 : jn - 1)) - ! - endif - ! - 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 - ! - ! 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) - ! - 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 - else - OUTSTR(IPOS:IPOS)=c - IPOS=IPOS+1 - endif - endif - enddo - ! - ILEN=len_trim(OUTSTR(:IPOS)) ! trim trailing spaces - return - ! - end subroutine notabs - - -end module +end module \ No newline at end of file diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index a8728f394..e643e37a7 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -94,8 +94,8 @@ function sfincs_initialize() result(ierr) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - build_revision = "$Rev: v2.3.3 mt. Faber+" - build_date = "$Date: 2025-05-27" + build_revision = "$Rev: v2.4.0 Galibier Release" + build_date = "$Date: 2025-06-11" ! call write_log('', 1) call write_log('------------ Welcome to SFINCS ------------', 1) diff --git a/source/src/sfincs_meteo.f90 b/source/src/sfincs_meteo.f90 index b71e504eb..7e40d2df5 100644 --- a/source/src/sfincs_meteo.f90 +++ b/source/src/sfincs_meteo.f90 @@ -629,6 +629,10 @@ subroutine update_spiderweb_data() ind1(4) = idstspw + 1 if (ind1(3) > spw_nrows) cycle dj1 = (dstspw - dradspw * idstspw) / dradspw + ! When dstspw < dradspw (point within first radial bin), idstspw is clamped to 1 + ! but the raw dj1 formula yields a negative value. Clamp to 0 so bilinear weights + ! remain in [0,1] and do not produce unphysical negative contributions. + dj1 = max(dj1, 0.0) phispw = 0.5*pi - atan2(dye, dxe) ! Geographic phispw = modulo(phispw, 2 * pi) ! diff --git a/source/src/sfincs_momentum.f90 b/source/src/sfincs_momentum.f90 index 4e19f72fa..66f9a2192 100644 --- a/source/src/sfincs_momentum.f90 +++ b/source/src/sfincs_momentum.f90 @@ -23,7 +23,7 @@ subroutine compute_fluxes(dt, tloop) integer :: nmu integer :: n integer :: m - + ! integer :: idir integer :: iref integer :: itype @@ -597,9 +597,13 @@ subroutine compute_fluxes(dt, tloop) ! facmax = 0.25*sqrt(g)*rhow*gammax**2 ! fmax = facmax*hu*sqrt(hu)/tp/rhow (we already divided by rhow in sfincs_snapwave) ! - fwmax = 0.8 * hwet * sqrt(hwet) / 15 + ! old: fwmax = 0.8 * hwet * sqrt(hwet) / 15 + ! fix for lab cases: fwmax = 999 + ! + fwmax = fwmaxfac * hwet * sqrt(hwet) + ! Note, fwmaxfac is determined in sfincs_snapwave every 'update_wave_field' call ! - frc = frc + phi * sign(min(abs(fwuv(ip)), fwmax), fwuv(ip)) + frc = frc + phi * sign(min(abs(fwuv(ip)), fwmax), fwuv(ip)) ! endif ! diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index fa49e9b46..3c9686d4e 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -251,6 +251,46 @@ subroutine read_netcdf_storage_volume() ! end subroutine + subroutine read_netcdf_quadtree_get_dimension(ncfile, varname, var) + ! For instance: vegetationfile, nsec, vegetation_vertical_segments + ! + use netcdf + use sfincs_data + use quadtree + ! + implicit none + ! + integer :: nm, ip, nrcells, status + ! + character*256 :: ncfile + character*256 :: varname + ! + integer, intent(inout) :: var ! variable that we are mapping to + ! + real*4, dimension(:), allocatable :: vartmp + ! + ! Open netcdf file + ! + NF90(nf90_open(trim(ncfile), NF90_CLOBBER, net_file_generic%ncid)) + ! + ! Get dimensions id's: nr points + ! + NF90(nf90_inq_dimid(net_file_generic%ncid, varname, net_file_generic%np_dimid)) + ! + ! Get dimensions sizes + ! + status = nf90_inquire_dimension(net_file_generic%ncid, net_file_generic%np_dimid, len = var) + ! + ! Stop SFINCS if wanted variable was not found + if (status /= nf90_noerr) then + write(logstr,'(a,a,a,a,a)')'Error : netcdf input file ',trim(ncfile),' does not contain needed variable: ',trim(varname),' !' + call stop_sfincs(trim(logstr), 1) + endif + ! + NF90(nf90_close(net_file_generic%ncid)) + ! + end subroutine + subroutine read_netcdf_quadtree_to_sfincs(ncfile, varname, var) ! For instance: storage_volume.nc, vol, storage_volume ! @@ -379,11 +419,155 @@ subroutine read_netcdf_quadtree_to_sfincs_real8(ncfile, varname, var) ! enddo ! - NF90(nf90_close(net_file_generic%ncid)) - ! - end subroutine - - + NF90(nf90_close(net_file_generic%ncid)) + ! + end subroutine + + + subroutine read_netcdf_quadtree_integer(ncfile, varname, var) + ! Read a 1D integer variable from a quadtree NetCDF file and map to SFINCS active cells + ! + use netcdf + use sfincs_data + use quadtree + ! + implicit none + ! + integer :: nm, ip, nrcells, status + ! + character*256 :: ncfile + character*256 :: varname + ! + integer, dimension(np), intent(inout) :: var + ! + integer, dimension(:), allocatable :: vartmp + ! + NF90(nf90_open(trim(ncfile), NF90_CLOBBER, net_file_generic%ncid)) + ! + NF90(nf90_inq_dimid(net_file_generic%ncid, "mesh2d_nFaces", net_file_generic%np_dimid)) + ! + NF90(nf90_inquire_dimension(net_file_generic%ncid, net_file_generic%np_dimid, len = nrcells)) + ! + if (nrcells /= quadtree_nr_points) then + write(logstr,*)'Error : netcdf input file ',trim(ncfile),' contains: ',nrcells, & + ' input points, while expected is: ',quadtree_nr_points,' as in sfincs.nc quadtree grid' + call stop_sfincs(trim(logstr), 1) + endif + ! + status = nf90_inq_varid(net_file_generic%ncid, varname, net_file_generic%gen_varid) + ! + if (status /= nf90_noerr) then + write(logstr,'(a,a,a,a,a)')'Error : netcdf input file ',trim(ncfile), & + ' does not contain needed variable: ',trim(varname),' !' + call stop_sfincs(trim(logstr), 1) + endif + ! + allocate(vartmp(nrcells)) + ! + NF90(nf90_get_var(net_file_generic%ncid, net_file_generic%gen_varid, vartmp(:))) + ! + do ip = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(ip) + if (nm > 0) var(nm) = vartmp(ip) + enddo + ! + deallocate(vartmp) + ! + NF90(nf90_close(net_file_generic%ncid)) + ! + end subroutine + + + subroutine read_netcdf_flag_meanings(ncfile, varname, flag_values, flag_meanings, nflags) + ! Read CF convention flag_values (integer array) and flag_meanings (space-separated string) + ! attributes from a NetCDF variable and return them as separate arrays. + ! + use netcdf + use sfincs_error + use sfincs_log + ! + implicit none + ! + character*256, intent(in) :: ncfile + character*256, intent(in) :: varname + integer, allocatable, intent(out) :: flag_values(:) + character(len=64), allocatable, intent(out) :: flag_meanings(:) + integer, intent(out) :: nflags + ! + integer :: ncid, varid, status, att_len + character(len=4096) :: meanings_str + integer :: i, istart, itype + ! + ! Open file in read-only mode + ! + status = nf90_open(trim(ncfile), NF90_NOWRITE, ncid) + if (status /= nf90_noerr) then + write(logstr,'(a,a,a)')'Error : cannot open NetCDF file ', trim(ncfile), ' !' + call stop_sfincs(trim(logstr), 1) + endif + ! + status = nf90_inq_varid(ncid, trim(varname), varid) + if (status /= nf90_noerr) then + write(logstr,'(a,a,a,a,a)')'Error : NetCDF file ',trim(ncfile), & + ' does not contain variable: ',trim(varname),' !' + call stop_sfincs(trim(logstr), 1) + endif + ! + ! flag_values: CF attribute giving the integer id for each type; its length is nflags + ! + status = nf90_inquire_attribute(ncid, varid, 'flag_values', len=nflags) + if (status /= nf90_noerr) then + write(logstr,'(a,a,a)')'Error : variable ',trim(varname), & + ' in vegetation NetCDF has no flag_values attribute !' + call stop_sfincs(trim(logstr), 1) + endif + ! + allocate(flag_values(nflags)) + status = nf90_get_att(ncid, varid, 'flag_values', flag_values) + if (status /= nf90_noerr) then + write(logstr,'(a,a,a)')'Error : cannot read flag_values attribute from variable ', & + trim(varname), ' !' + call stop_sfincs(trim(logstr), 1) + endif + ! + ! flag_meanings: CF attribute with space-separated type names + ! + status = nf90_inquire_attribute(ncid, varid, 'flag_meanings', len=att_len) + if (status /= nf90_noerr) then + write(logstr,'(a,a,a)')'Error : variable ',trim(varname), & + ' in vegetation NetCDF has no flag_meanings attribute !' + call stop_sfincs(trim(logstr), 1) + endif + ! + meanings_str = ' ' + status = nf90_get_att(ncid, varid, 'flag_meanings', meanings_str) + if (status /= nf90_noerr) then + write(logstr,'(a,a,a)')'Error : cannot read flag_meanings attribute from variable ', & + trim(varname), ' !' + call stop_sfincs(trim(logstr), 1) + endif + ! + status = nf90_close(ncid) + ! + ! Split space-separated flag_meanings string into individual name strings + ! + allocate(flag_meanings(nflags)) + flag_meanings = ' ' + itype = 0 + istart = 1 + do i = 1, len_trim(meanings_str) + 1 + if (i > len_trim(meanings_str) .or. meanings_str(i:i) == ' ') then + if (i > istart) then + itype = itype + 1 + if (itype <= nflags) flag_meanings(itype) = meanings_str(istart:i-1) + endif + istart = i + 1 + endif + enddo + ! + end subroutine + + subroutine read_netcdf_amuv_data() ! ! Output is made exactly the same as original read_amuv_dimensions & read_amuv_file subroutines but then with data given by netcdf file diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index e3a1895e1..2618849df 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -26,15 +26,19 @@ module sfincs_ncoutput integer :: manning_varid integer :: pnonh_varid integer :: subgridslope_varid + ! Vegetation + integer :: nsec_dimid + integer :: veg_cd_varid, veg_ah_varid, veg_bstems_varid, veg_Nstems_varid ! - integer :: mesh2d_varid - integer :: mesh2d_node_x_varid, mesh2d_node_y_varid - integer :: mesh2d_face_nodes_varid - integer :: nmesh2d_node_dimid - integer :: nmesh2d_face_dimid - integer :: max_nmesh2d_face_nodes_dimid - ! - end type + integer :: mesh2d_varid + integer :: mesh2d_node_x_varid, mesh2d_node_y_varid + integer :: mesh2d_face_x_varid, mesh2d_face_y_varid + integer :: mesh2d_face_nodes_varid + integer :: nmesh2d_node_dimid + integer :: nmesh2d_face_dimid + integer :: max_nmesh2d_face_nodes_dimid + ! + end type ! type his_type ! @@ -101,7 +105,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_def_dim(map_file%ncid, 'runtime', 1, map_file%runtime_dimid)) ! total_runtime, average_dt ! ! Some metadata attributes - NF90(nf90_put_att(map_file%ncid,nf90_global, "Conventions", "Conventions = 'CF-1.6, SGRID-0.3")) + NF90(nf90_put_att(map_file%ncid,nf90_global, "Conventions", "CF-1.8 UGRID-1.0 Deltares-0.10")) NF90(nf90_put_att(map_file%ncid,nf90_global, "Build-Revision-Date-Netcdf-library", trim(nf90_inq_libvers()))) ! version of netcdf library NF90(nf90_put_att(map_file%ncid,nf90_global, "Producer", "SFINCS model: Super-Fast INundation of CoastS")) NF90(nf90_put_att(map_file%ncid,nf90_global, "Build-Revision", trim(build_revision))) @@ -173,10 +177,10 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%corner_y_varid, 'grid', 'sfincsgrid')) ! 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_put_att(map_file%ncid, map_file%crs_varid, 'epsg_code', 'EPSG:' // trim(epsg_code) )) !--> add epsg_code like FEWS wants + NF90(nf90_put_att(map_file%ncid, map_file%crs_varid, 'epsg', epsg)) + NF90(nf90_put_att(map_file%ncid, map_file%crs_varid, 'epsg_code', 'EPSG:' // trim(epsg_code) )) !--> add epsg_code like FEWS wants ! - NF90(nf90_def_var(map_file%ncid, 'sfincsgrid', NF90_INT, map_file%grid_varid)) ! For neat grid clarification + NF90(nf90_def_var(map_file%ncid, 'sfincsgrid', NF90_INT, map_file%grid_varid)) ! For neat grid clarification NF90(nf90_put_att(map_file%ncid, map_file%grid_varid, 'cf_role', 'grid_topology')) NF90(nf90_put_att(map_file%ncid, map_file%grid_varid, 'topology_dimension', 2)) NF90(nf90_put_att(map_file%ncid, map_file%grid_varid, 'node_dimensions', 'n m')) !or n m? @@ -189,7 +193,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'units', '-')) NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'standard_name', 'land_binary_mask')) ! land_binary_mask but with added boundary=2 - NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'long_name', 'msk_active_cells')) + NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'long_name', 'Active cells mask')) NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'description', 'inactive=0, active=1, normal_boundary=2, outflow_boundary=3')) NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'coordinates', 'x y')) NF90(nf90_def_var_deflate(map_file%ncid, map_file%msk_varid, 1, 1, nc_deflate_level)) ! deflate @@ -230,7 +234,7 @@ subroutine ncoutput_regular_map_init() 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')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'Bed level above reference level')) NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'coordinates', 'x y')) else NF90(nf90_def_var(map_file%ncid, 'zb', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid/), map_file%zb_varid)) ! bed level in cell centre @@ -238,7 +242,7 @@ subroutine ncoutput_regular_map_init() 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')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'Bed level above reference level')) NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'coordinates', 'x y')) endif ! @@ -283,7 +287,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'standard_name', 'sea_surface_height_above_reference_level')) - NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'long_name', 'water_level')) + NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'long_name', 'Water level above reference level')) NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'coordinates', 'x y')) ! if (subgrid .eqv. .false. .or. store_hsubgrid .eqv. .true.) then @@ -291,8 +295,8 @@ subroutine ncoutput_regular_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%h_varid, 1, 1, nc_deflate_level)) ! deflate NF90(nf90_put_att(map_file%ncid, map_file%h_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'units', 'm')) - NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'standard_name', 'depth')) - NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'long_name', 'water_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'standard_name', 'water_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'long_name', 'Water depth')) NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'coordinates', 'x y')) endif ! @@ -305,7 +309,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%u_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'standard_name', 'eastward_sea_water_velocity')) ! not truly eastward when rotated, eastward_sea_water_velocity - NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'long_name', 'flow_velocity_x_direction')) + NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'long_name', 'Flow velocity x-component')) NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'coordinates', 'x y')) ! NF90(nf90_def_var(map_file%ncid, 'v', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%v_varid)) ! time-varying u map @@ -313,7 +317,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%v_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'standard_name', 'northward_sea_water_velocity')) ! not truly eastward when rotated, eastward_sea_water_velocity - NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'long_name', 'flow_velocity_y_direction')) + NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'long_name', 'Flow velocity y-component')) NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'coordinates', 'x y')) endif ! @@ -328,7 +332,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'units', 'm3')) NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'standard_name', 'subgrid_volume_in_cell')) - NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'long_name', 'subgrid_volume_in_cell')) + NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'long_name', 'Subgrid volume in cell')) NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'coordinates', 'x y')) ! endif @@ -340,7 +344,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'units', 'm3')) NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'standard_name', 'storage_volume_in_cell')) - NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'long_name', 'storage_volume_in_cell')) + NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'long_name', 'Storage volume in cell')) NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'coordinates', 'x y')) ! endif @@ -395,8 +399,8 @@ subroutine ncoutput_regular_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%zsmax_varid, 1, 1, nc_deflate_level)) ! deflate NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'units', 'm')) - NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'standard_name', 'maximum of sea_surface_height_above_reference_level')) - NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'long_name', 'maximum_water_level')) + NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'standard_name', 'maximum_sea_surface_height_above_reference_level')) + NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'long_name', 'Maximum water level')) NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'coordinates', 'x y')) endif ! @@ -406,7 +410,7 @@ subroutine ncoutput_regular_map_init() 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, '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 @@ -416,8 +420,8 @@ subroutine ncoutput_regular_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%tmax_varid, 1, 1, nc_deflate_level)) ! deflate NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'units', 'seconds')) - NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'standard_name', 'duration cell is considered wet')) - NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'long_name', 'duration_wet_cell')) + NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'standard_name', 'duration_wet_cell')) + NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'long_name', 'Duration cell is considered wet')) NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'cell_methods', 'time: sum')) NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'coordinates', 'x y')) endif @@ -427,8 +431,8 @@ subroutine ncoutput_regular_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%t_zsmax_varid, 1, 1, nc_deflate_level)) ! deflate NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'units', 'seconds since ' // trim(trefstr_iso8601) )) ! time stamp following ISO 8601 - NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'standard_name', 'time of max water level')) - NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'long_name', 'time when zsmax occurs')) + NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'standard_name', 'time_of_max_water_level')) + NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'long_name', 'Moment when zsmax occurs')) NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'cell_methods', 'time: max')) NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'coordinates', 'x y')) endif @@ -440,7 +444,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'standard_name', 'sea_floor_depth_below_sea_surface')) - NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'long_name', 'maximum_water_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'long_name', 'Maximum water depth')) NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'cell_methods', 'time: maximum')) NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'coordinates', 'x y')) endif @@ -452,7 +456,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'standard_name', 'maximum_flow_velocity')) ! no standard name available - NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'long_name', 'maximum_flow_velocity')) + NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'long_name', 'Maximum flow velocity')) NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'cell_methods', 'time: maximum')) NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'coordinates', 'x y')) endif @@ -476,7 +480,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'units', 's')) NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'standard_name', 'average_required_timestep')) - NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'long_name', 'average_required_timestep')) + NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'long_name', 'Average required time step')) NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'cell_methods', 'time: average')) NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'coordinates', 'x y')) ! @@ -486,7 +490,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'units', '%')) NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'standard_name', 'percentage_limiting_timestep')) - NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'long_name', 'percentage_cell_was_limiting_timestep')) + NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'long_name', 'Fraction of timesteps cell was limiting')) NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'cell_methods', 'time: maximum')) NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'coordinates', 'x y')) ! @@ -497,7 +501,8 @@ subroutine ncoutput_regular_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%cuminf_varid, 1, 1, nc_deflate_level)) ! deflate 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, 'standard_name', 'cumulative_infiltration_depth')) + 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, 'coordinates', 'x y')) endif @@ -511,7 +516,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'standard_name', 'eastward_wind')) - NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'long_name', 'wind_speed_u')) + NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'long_name', 'Wind speed u-component')) NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'coordinates', 'x y')) ! NF90(nf90_def_var(map_file%ncid, 'wind_v', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%wind_v_varid)) ! cumulative precipitation map @@ -519,7 +524,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'standard_name', 'northward_wind')) - NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'long_name', 'wind_speed_v')) + NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'long_name', 'Wind speed v-component')) NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'coordinates', 'x y')) ! if (meteo3d .and. store_wind_max) then @@ -527,7 +532,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%windmax_varid, 1, 1, nc_deflate_level)) ! deflate NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'units', 'm s-1')) - NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'long_name', 'maximum_wind_speed')) + NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'long_name', 'Maximum wind speed')) NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'cell_methods', 'time: sum')) NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'coordinates', 'x y')) endif @@ -541,7 +546,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'units', 'N m-2')) NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'standard_name', 'surface_air_pressure')) - NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'long_name', 'surface_air_pressure')) + NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'long_name', 'Surface air pressure')) NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'coordinates', 'x y')) ! endif @@ -567,7 +572,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'units', '-')) NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'standard_name', 'snapwavemask')) - NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'long_name', 'snapwave_msk_active_cells')) + NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'long_name', 'SnapWave active cells mask')) NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'description', 'inactive=0, active=1, wave_boundary=2, neumann_boundary=3')) NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'coordinates', 'x y')) ! @@ -594,7 +599,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'standard_name', 'wave_force_x')) - NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'long_name', 'Wave force in x-direction')) + NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'long_name', 'Wave force x-component')) NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'coordinates', 'x y')) ! NF90(nf90_def_var(map_file%ncid, 'fwy', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%fwy_varid)) @@ -602,7 +607,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'standard_name', 'wave_force_y')) - NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'long_name', 'Wave force in y-direction')) + NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'long_name', 'Wave force y-component')) NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'coordinates', 'x y')) ! NF90(nf90_def_var(map_file%ncid, 'tp', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%tp_varid)) @@ -626,7 +631,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'units', '-')) NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'standard_name', 'directionally_averaged_local_bed_slope')) - NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'long_name', 'directionally averaged local bed slope')) + NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'long_name', 'Mean local bed slope')) NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'coordinates', 'x y')) ! NF90(nf90_def_var(map_file%ncid, 'snapwavedepth', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%snapwavedepth_varid)) @@ -659,7 +664,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'units', '-')) NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'standard_name', 'tsunami_arrival_time')) - NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'long_name', 'tsunami_arrival_time')) + NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'long_name', 'Tsunami arrival time')) NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'coordinates', 'x y')) NF90(nf90_def_var_deflate(map_file%ncid, map_file%tsunami_arrival_time_varid, 1, 1, nc_deflate_level)) ! deflate ! @@ -671,7 +676,7 @@ subroutine ncoutput_regular_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%pnonh_varid, 1, 1, nc_deflate_level)) ! deflate NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'units', 'N m-2')) - NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'long_name', 'non_hydrostatic_pressure')) + NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'long_name', 'Non-hydrostatic pressure')) NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'coordinates', 'x y')) ! endif @@ -680,11 +685,11 @@ subroutine ncoutput_regular_map_init() ! NF90(nf90_def_var(map_file%ncid, 'total_runtime', NF90_FLOAT, (/map_file%runtime_dimid/),map_file%total_runtime_varid)) NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'units', 's')) - NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'long_name', 'total_model_runtime_in_seconds')) + NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'long_name', 'Total model runtime (s)')) ! NF90(nf90_def_var(map_file%ncid, 'average_dt', NF90_FLOAT, (/map_file%runtime_dimid/), map_file%average_dt_varid)) NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'units', 's')) - NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'long_name', 'model_average_timestep_in_seconds')) + NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'long_name', 'Average model time step (s)')) ! NF90(nf90_def_var(map_file%ncid, 'status', NF90_FLOAT, (/map_file%runtime_dimid/), map_file%status_varid)) NF90(nf90_put_att(map_file%ncid, map_file%status_varid, 'units', '-')) @@ -869,7 +874,7 @@ subroutine ncoutput_quadtree_map_init() ! implicit none ! - integer :: nm, nmq, nmu1, num1, n, m, nn, ntmx, n_nodes, n_faces, iref + integer :: nm, nmq, nmu1, num1, n, m, nn, ntmx, n_nodes, n_faces, iref, isec real*4 :: dxx, dyy ! real, dimension(:), allocatable :: nodes_x @@ -877,6 +882,7 @@ subroutine ncoutput_quadtree_map_init() integer*4, dimension(:,:), allocatable :: face_nodes real*4, dimension(:), allocatable :: vtmp integer*4, dimension(:), allocatable :: vtmpi + real*4, dimension(:,:), allocatable :: vtmp2d ! ! Very lazy for now ! @@ -943,11 +949,15 @@ subroutine ncoutput_quadtree_map_init() ! Time ! NF90(nf90_def_dim(map_file%ncid, 'time', NF90_UNLIMITED, map_file%time_dimid)) ! time - ntmx = max(ceiling((t1out - t0out)/dtmaxout), 1) + ntmx = max(ceiling((t1out - t0out)/dtmaxout), 1) NF90(nf90_def_dim(map_file%ncid, 'timemax', ntmx, map_file%timemax_dimid)) ! time - NF90(nf90_def_dim(map_file%ncid, 'runtime', 1, map_file%runtime_dimid)) ! total_runtime, average_dt + NF90(nf90_def_dim(map_file%ncid, 'runtime', 1, map_file%runtime_dimid)) ! total_runtime, average_dt ! - ! Some metadata attributes + if (store_vegetation) then + NF90(nf90_def_dim(map_file%ncid, 'nsec', vegetation_vertical_segments, map_file%nsec_dimid)) ! number of vegetation vertical sections + endif + ! + ! Some metadata attributes ! NF90(nf90_put_att(map_file%ncid,nf90_global, "Conventions", "Conventions = 'CF-1.8 UGRID-1.0 Deltares-0.10'")) NF90(nf90_put_att(map_file%ncid,nf90_global, "Build-Revision-Date-Netcdf-library", trim(nf90_inq_libvers()))) ! version of netcdf library @@ -970,6 +980,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_varid, 'long_name', 'Topology data of 2D network')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_varid, 'topology_dimension', 2)) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_varid, 'node_coordinates', 'mesh2d_node_x mesh2d_node_y')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_varid, 'face_coordinates', 'mesh2d_face_x mesh2d_face_y')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_varid, 'node_dimension', 'nmesh2d_node')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_varid, 'max_face_nodes_dimension', 'max_nmesh2d_face_nodes')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_varid, 'face_node_connectivity', 'mesh2d_face_nodes')) @@ -979,19 +990,21 @@ subroutine ncoutput_quadtree_map_init() ! NF90(nf90_def_var(map_file%ncid, 'mesh2d_node_x', NF90_FLOAT, (/map_file%nmesh2d_node_dimid/), map_file%mesh2d_node_x_varid)) ! location of zb, zs etc. in cell centre NF90(nf90_def_var_deflate(map_file%ncid, map_file%mesh2d_node_x_varid, 1, 1, nc_deflate_level)) - NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'units', 'degrees')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'units', 'degrees_east')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'standard_name', 'longitude')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'long_name', 'longitude')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'mesh', 'mesh2d')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'location', 'node')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'grid_mapping', 'crs')) ! NF90(nf90_def_var(map_file%ncid, 'mesh2d_node_y', NF90_FLOAT, (/map_file%nmesh2d_node_dimid/), map_file%mesh2d_node_y_varid)) ! location of zb, zs etc. in cell centre NF90(nf90_def_var_deflate(map_file%ncid, map_file%mesh2d_node_y_varid, 1, 1, nc_deflate_level)) - NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'units', 'degrees')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'units', 'degrees_north')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'standard_name', 'latitude')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'long_name', 'latitude')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'mesh', 'mesh2d')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'location', 'node')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'grid_mapping', 'crs')) ! else ! @@ -1002,6 +1015,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'long_name', 'x-coordinate of mesh nodes')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'mesh', 'mesh2d')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'location', 'node')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_x_varid, 'grid_mapping', 'crs')) ! NF90(nf90_def_var(map_file%ncid, 'mesh2d_node_y', NF90_DOUBLE, (/map_file%nmesh2d_node_dimid/), map_file%mesh2d_node_y_varid)) ! location of zb, zs etc. in cell centre NF90(nf90_def_var_deflate(map_file%ncid, map_file%mesh2d_node_y_varid, 1, 1, nc_deflate_level)) @@ -1010,6 +1024,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'long_name', 'y-coordinate of mesh nodes')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'mesh', 'mesh2d')) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'location', 'node')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_node_y_varid, 'grid_mapping', 'crs')) ! endif ! @@ -1022,15 +1037,59 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_nodes_varid, 'start_index', 1)) NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_nodes_varid, '_FillValue', -999)) ! - 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', '-')) + ! Face centroid coordinates (x and y at face centers) + ! + if (crsgeo) then + ! + NF90(nf90_def_var(map_file%ncid, 'mesh2d_face_x', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%mesh2d_face_x_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%mesh2d_face_x_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'units', 'degrees_east')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'standard_name', 'longitude')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'long_name', 'Characteristic longitude of mesh face')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'location', 'face')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'grid_mapping', 'crs')) + ! + NF90(nf90_def_var(map_file%ncid, 'mesh2d_face_y', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%mesh2d_face_y_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%mesh2d_face_y_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'units', 'degrees_north')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'standard_name', 'latitude')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'long_name', 'Characteristic latitude of mesh face')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'location', 'face')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'grid_mapping', 'crs')) + ! + else + ! + NF90(nf90_def_var(map_file%ncid, 'mesh2d_face_x', NF90_DOUBLE, (/map_file%nmesh2d_face_dimid/), map_file%mesh2d_face_x_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%mesh2d_face_x_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'standard_name', 'projection_x_coordinate')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'long_name', 'Characteristic x-coordinate of mesh face')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'location', 'face')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_x_varid, 'grid_mapping', 'crs')) + ! + NF90(nf90_def_var(map_file%ncid, 'mesh2d_face_y', NF90_DOUBLE, (/map_file%nmesh2d_face_dimid/), map_file%mesh2d_face_y_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%mesh2d_face_y_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'standard_name', 'projection_y_coordinate')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'long_name', 'Characteristic y-coordinate of mesh face')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'location', 'face')) + NF90(nf90_put_att(map_file%ncid, map_file%mesh2d_face_y_varid, 'grid_mapping', 'crs')) + ! + endif ! + NF90(nf90_def_var(map_file%ncid, 'crs', NF90_INT, map_file%crs_varid)) ! For EPSG code + NF90(nf90_put_att(map_file%ncid, map_file%crs_varid, 'epsg', epsg)) + NF90(nf90_put_att(map_file%ncid, map_file%crs_varid, 'epsg_code', 'EPSG:' // trim(epsg_code) )) !--> add epsg_code like FEWS wants NF90(nf90_def_var(map_file%ncid, 'zb', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%zb_varid)) ! bed level in cell centre NF90(nf90_def_var_deflate(map_file%ncid, map_file%zb_varid, 1, 1, nc_deflate_level)) NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'standard_name', 'altitude')) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'bed_level_above_reference_level')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'Bed level above reference level')) ! if (.not. subgrid) then ! @@ -1064,9 +1123,41 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'units', '-')) NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'standard_name', 'mask')) NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'long_name', 'msk_active_cells')) - NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'description', 'inactive=0, active=1, normal_boundary=2, outflow_boundary=3, wavemaker=4')) + NF90(nf90_put_att(map_file%ncid, map_file%msk_varid, 'description', 'inactive=0, active=1, normal_boundary=2, outflow_boundary=3, wavemaker=4')) + ! + if (store_vegetation) then + ! + NF90(nf90_def_var(map_file%ncid, 'vegetation_stems_cd', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%nsec_dimid/), map_file%veg_cd_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%veg_cd_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%veg_cd_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%veg_cd_varid, 'units', '-')) + NF90(nf90_put_att(map_file%ncid, map_file%veg_cd_varid, 'standard_name', 'vegetation_stems_cd')) + NF90(nf90_put_att(map_file%ncid, map_file%veg_cd_varid, 'long_name', 'Bulk drag coefficient per vegetation section')) + ! + NF90(nf90_def_var(map_file%ncid, 'vegetation_stems_height', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%nsec_dimid/), map_file%veg_ah_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%veg_ah_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%veg_ah_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%veg_ah_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%veg_ah_varid, 'standard_name', 'vegetation_stems_height')) + NF90(nf90_put_att(map_file%ncid, map_file%veg_ah_varid, 'long_name', 'Vegetation section thickness')) + ! + NF90(nf90_def_var(map_file%ncid, 'vegetation_stems_diameter', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%nsec_dimid/), map_file%veg_bstems_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%veg_bstems_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%veg_bstems_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%veg_bstems_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%veg_bstems_varid, 'standard_name', 'vegetation_stems_diameter')) + NF90(nf90_put_att(map_file%ncid, map_file%veg_bstems_varid, 'long_name', 'Diameter of individual vegetation stems per section')) + ! + NF90(nf90_def_var(map_file%ncid, 'vegetation_stems_density', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%nsec_dimid/), map_file%veg_Nstems_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%veg_Nstems_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%veg_Nstems_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%veg_Nstems_varid, 'units', 'm-2')) + NF90(nf90_put_att(map_file%ncid, map_file%veg_Nstems_varid, 'standard_name', 'vegetation_stems_density')) + NF90(nf90_put_att(map_file%ncid, map_file%veg_Nstems_varid, 'long_name', 'Number of stems per unit horizontal area per section')) + ! + endif ! - ! Time variables + ! Time variables ! trefstr_iso8601 = date_to_iso8601(trefstr) ! @@ -1082,7 +1173,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'standard_name', 'sea_surface_height_above_reference_level')) - NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'long_name', 'water_level')) + NF90(nf90_put_att(map_file%ncid, map_file%zs_varid, 'long_name', 'Water level above reference level')) ! if (subgrid .eqv. .false. .or. store_hsubgrid .eqv. .true.) then NF90(nf90_def_var(map_file%ncid, 'h', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%h_varid)) ! time-varying water level map @@ -1090,7 +1181,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%h_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'standard_name', 'water_depth')) - NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'long_name', 'water_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%h_varid, 'long_name', 'Water depth')) endif ! if (store_velocity) then @@ -1100,14 +1191,14 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%u_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'standard_name', 'sea_water_x_velocity')) ! not truly eastward when rotated, eastward_sea_water_velocity - NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'long_name', 'flow_velocity_x_direction_in_cell_edge')) + NF90(nf90_put_att(map_file%ncid, map_file%u_varid, 'long_name', 'Flow velocity x-component')) ! NF90(nf90_def_var(map_file%ncid, 'v', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%v_varid)) ! time-varying u map NF90(nf90_def_var_deflate(map_file%ncid, map_file%v_varid, 1, 1, nc_deflate_level)) NF90(nf90_put_att(map_file%ncid, map_file%v_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'standard_name', 'sea_water_y_velocity')) ! not truly eastward when rotated, eastward_sea_water_velocity - NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'long_name', 'flow_velocity_y_direction_in_cell_edge')) + NF90(nf90_put_att(map_file%ncid, map_file%v_varid, 'long_name', 'Flow velocity y-component')) ! endif ! @@ -1122,7 +1213,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'units', 'm3')) NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'standard_name', 'subgrid_volume_in_cell')) - NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'long_name', 'subgrid_volume_in_cell')) + NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'long_name', 'Subgrid volume in cell')) NF90(nf90_put_att(map_file%ncid, map_file%zvolume_varid, 'coordinates', 'x y')) ! endif @@ -1134,7 +1225,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'units', 'm3')) NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'standard_name', 'storage_volume_in_cell')) - NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'long_name', 'storage_volume_in_cell')) + NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'long_name', 'Storage volume in cell')) NF90(nf90_put_att(map_file%ncid, map_file%storagevolume_varid, 'coordinates', 'x y')) ! endif @@ -1157,7 +1248,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'standard_name', 'maximum of sea_surface_height_above_reference_level')) - NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'long_name', 'maximum_water_level')) + NF90(nf90_put_att(map_file%ncid, map_file%zsmax_varid, 'long_name', 'Maximum water level')) endif ! if (store_twet) then @@ -1165,8 +1256,8 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%tmax_varid, 1, 1, nc_deflate_level)) NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'units', 'seconds')) - NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'standard_name', 'duration cell is considered wet')) - NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'long_name', 'duration_wet_cell')) + NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'standard_name', 'duration_wet_cell')) + NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'long_name', 'Duration cell was considered wet')) NF90(nf90_put_att(map_file%ncid, map_file%tmax_varid, 'cell_methods', 'time: sum')) endif ! @@ -1175,8 +1266,8 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%t_zsmax_varid, 1, 1, nc_deflate_level)) NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'units', 'seconds since ' // trim(trefstr_iso8601) )) ! time stamp following ISO 8601 - NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'standard_name', 'time of max water level')) - NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'long_name', 'time when zsmax occurs')) + NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'standard_name', 'time_of_max_water_level')) + NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'long_name', 'Moment when zsmax occurs')) NF90(nf90_put_att(map_file%ncid, map_file%t_zsmax_varid, 'cell_methods', 'time: max')) endif ! @@ -1187,7 +1278,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'standard_name', 'sea_floor_depth_below_sea_surface')) - NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'long_name', 'maximum_water_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'long_name', 'Maximum water depth')) NF90(nf90_put_att(map_file%ncid, map_file%hmax_varid, 'cell_methods', 'time: maximum')) endif endif @@ -1198,7 +1289,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'standard_name', 'maximum_flow_velocity')) ! no standard name available - NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'long_name', 'maximum_flow_velocity')) + NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'long_name', 'Maximum flow velocity')) NF90(nf90_put_att(map_file%ncid, map_file%vmax_varid, 'cell_methods', 'time: maximum')) endif ! @@ -1222,7 +1313,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%cumprcp_varid, 1, 1, nc_deflate_level)) 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, 'long_name', 'Cumulative precipitation depth')) NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'cell_methods', 'time: sum')) ! ! Cumulative infiltration @@ -1231,7 +1322,7 @@ subroutine ncoutput_quadtree_map_init() 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, '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, 'long_name', 'Cumulative infiltration depth')) NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'cell_methods', 'time: sum')) ! endif @@ -1245,14 +1336,14 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'standard_name', 'eastward_wind')) ! not truly eastward when rotated, eastward_sea_water_velocity - NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'long_name', 'wind_speed_u')) + NF90(nf90_put_att(map_file%ncid, map_file%wind_u_varid, 'long_name', 'Wind speed u-component')) ! NF90(nf90_def_var(map_file%ncid, 'wind_v', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%wind_v_varid)) ! time-varying wind_u map NF90(nf90_def_var_deflate(map_file%ncid, map_file%wind_v_varid, 1, 1, nc_deflate_level)) NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'units', 'm s-1')) NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'standard_name', 'northward_wind')) ! not truly eastward when rotated, eastward_sea_water_velocity - NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'long_name', 'wind_speed_v')) + NF90(nf90_put_att(map_file%ncid, map_file%wind_v_varid, 'long_name', 'Wind speed v-component')) ! if (store_wind_max) then ! @@ -1262,7 +1353,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%windmax_varid, 1, 1, nc_deflate_level)) NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'units', 'm s-1')) - NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'long_name', 'maximum_wind_speed')) + NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'long_name', 'Maximum wind speed')) NF90(nf90_put_att(map_file%ncid, map_file%windmax_varid, 'cell_methods', 'time: maximum')) endif ! @@ -1275,7 +1366,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'units', 'N m-2')) NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'standard_name', 'surface_air_pressure')) - NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'long_name', 'surface_air_pressure')) + NF90(nf90_put_att(map_file%ncid, map_file%patm_varid, 'long_name', 'Surface air pressure')) ! endif ! @@ -1288,7 +1379,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, '_FillValue', -999)) NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'units', '-')) NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'standard_name', 'snapwavemask')) - NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'long_name', 'snapwave_msk_active_cells')) + NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'long_name', 'SnapWave active cells mask')) NF90(nf90_put_att(map_file%ncid, map_file%snapwavemsk_varid, 'description', 'inactive=0, active=1, wave_boundary=2, neumann_boundary=3')) ! NF90(nf90_def_var(map_file%ncid, 'hm0', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%hm0_varid)) @@ -1312,14 +1403,14 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'standard_name', 'wave_force_x')) - NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'long_name', 'Wave force in x-direction')) + NF90(nf90_put_att(map_file%ncid, map_file%fwx_varid, 'long_name', 'Wave force x-component')) ! NF90(nf90_def_var(map_file%ncid, 'fwy', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%fwy_varid)) NF90(nf90_def_var_deflate(map_file%ncid, map_file%fwy_varid, 1, 1, nc_deflate_level)) NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'units', 'm')) NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'standard_name', 'wave_force_y')) - NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'long_name', 'Wave force in y-direction')) + NF90(nf90_put_att(map_file%ncid, map_file%fwy_varid, 'long_name', 'Wave force y-component')) ! NF90(nf90_def_var(map_file%ncid, 'tp', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%tp_varid)) NF90(nf90_def_var_deflate(map_file%ncid, map_file%tp_varid, 1, 1, nc_deflate_level)) @@ -1339,7 +1430,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'units', '-')) NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'standard_name', 'directionally_averaged_local_bed_slope')) - NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'long_name', 'directionally averaged local bed slope')) + NF90(nf90_put_att(map_file%ncid, map_file%beta_varid, 'long_name', 'Mean local bed slope')) ! NF90(nf90_def_var(map_file%ncid, 'snapwavedepth', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%snapwavedepth_varid)) NF90(nf90_put_att(map_file%ncid, map_file%snapwavedepth_varid, '_FillValue', FILL_VALUE)) @@ -1355,7 +1446,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%wavdir_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%wavdir_varid, 'units', 'degrees')) NF90(nf90_put_att(map_file%ncid, map_file%wavdir_varid, 'standard_name', 'mean_wave_direction')) - NF90(nf90_put_att(map_file%ncid, map_file%wavdir_varid, 'long_name', 'Mean wave direction')) + NF90(nf90_put_att(map_file%ncid, map_file%wavdir_varid, 'long_name', 'Mean wave angle (deg)')) ! !NF90(nf90_def_var(map_file%ncid, 'dirspr', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%dirspr_varid)) !NF90(nf90_put_att(map_file%ncid, map_file%dirspr_varid, '_FillValue', FILL_VALUE)) @@ -1385,7 +1476,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'units', '-')) NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'standard_name', 'tsunami_arrival_time')) - NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'long_name', 'tsunami_arrival_time')) + NF90(nf90_put_att(map_file%ncid, map_file%tsunami_arrival_time_varid, 'long_name', 'Tsunami arrival time')) NF90(nf90_def_var_deflate(map_file%ncid, map_file%tsunami_arrival_time_varid, 1, 1, nc_deflate_level)) ! deflate ! endif @@ -1423,20 +1514,20 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_def_var_deflate(map_file%ncid, map_file%pnonh_varid, 1, 1, nc_deflate_level)) ! deflate NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'units', 'N m-2')) - NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'standard_name', 'non_hydrostatic_pressure')) - NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'long_name', 'non_hydrostatic_pressure')) + NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'standard_name', 'non_hydrostatic_pressure')) + NF90(nf90_put_att(map_file%ncid, map_file%pnonh_varid, 'long_name', 'Non-hydrostatic pressure')) ! endif ! if (timestep_analysis) then ! ! Average time step (written once at end of simulation, no time dimension) - NF90(nf90_def_var(map_file%ncid, 'average_required_timestep', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%average_required_timestep_varid)) + NF90(nf90_def_var(map_file%ncid, 'Average required time step', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%average_required_timestep_varid)) NF90(nf90_def_var_deflate(map_file%ncid, map_file%average_required_timestep_varid, 1, 1, nc_deflate_level)) ! deflate NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'units', 's')) - NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'standard_name', 'average_required_timestep')) - NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'long_name', 'average_required_timestep')) + NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'standard_name', 'Average required time step')) + NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'long_name', 'Average required time step')) !NF90(nf90_put_att(map_file%ncid, map_file%average_required_timestep_varid, 'cell_methods', 'time: average')) ! ! Times limiting (written once at end of simulation, no time dimension) @@ -1445,7 +1536,7 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'units', '%')) NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'standard_name', 'percentage_limiting_timestep')) - NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'long_name', 'percentage_cell_was_limiting_timestep')) + NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'long_name', 'Fraction of steps cell was limiting')) !NF90(nf90_put_att(map_file%ncid, map_file%percentage_limiting_varid, 'cell_methods', 'time: maximum')) ! endif @@ -1454,11 +1545,11 @@ subroutine ncoutput_quadtree_map_init() ! NF90(nf90_def_var(map_file%ncid, 'total_runtime', NF90_FLOAT, (/map_file%runtime_dimid/),map_file%total_runtime_varid)) NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'units', 's')) - NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'long_name', 'total_model_runtime_in_seconds')) + NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'long_name', 'Total model runtime (s)')) ! NF90(nf90_def_var(map_file%ncid, 'average_dt', NF90_FLOAT, (/map_file%runtime_dimid/), map_file%average_dt_varid)) NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'units', 's')) - NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'long_name', 'model_average_timestep_in_seconds')) + NF90(nf90_put_att(map_file%ncid, map_file%total_runtime_varid, 'long_name', 'Average model time step (s)')) ! NF90(nf90_def_var(map_file%ncid, 'status', NF90_FLOAT, (/map_file%runtime_dimid/), map_file%status_varid)) NF90(nf90_put_att(map_file%ncid, map_file%status_varid, 'units', '-')) @@ -1473,6 +1564,20 @@ subroutine ncoutput_quadtree_map_init() ! NF90(nf90_put_var(map_file%ncid, map_file%mesh2d_face_nodes_varid, face_nodes)) ! + ! Compute and write face centroids (average of node coordinates) + ! + vtmp = FILL_VALUE + do nmq = 1, n_faces + vtmp(nmq) = sum(nodes_x(face_nodes(:,nmq))) / 4.0 + enddo + NF90(nf90_put_var(map_file%ncid, map_file%mesh2d_face_x_varid, vtmp)) ! write face centroid x + ! + vtmp = FILL_VALUE + do nmq = 1, n_faces + vtmp(nmq) = sum(nodes_y(face_nodes(:,nmq))) / 4.0 + enddo + NF90(nf90_put_var(map_file%ncid, map_file%mesh2d_face_y_varid, vtmp)) ! write face centroid y + ! ! ! now for cell edges ! NF90(nf90_put_var(map_file%ncid, map_file%face_x_varid, xz(2:nmax+1-1, 2:mmax+1-1), (/1, 1/))) ! write xz of edges ! ! @@ -1599,13 +1704,67 @@ subroutine ncoutput_quadtree_map_init() ! endif ! + ! Write vegetation fields (static, written once at init) + ! + if (store_vegetation) then + ! + allocate(vtmp2d(n_faces, vegetation_vertical_segments)) + ! + vtmp2d = FILL_VALUE + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm > 0) then + do isec = 1, vegetation_vertical_segments + vtmp2d(nmq, isec) = vegetation_stems_cd(nm, isec) + enddo + endif + enddo + NF90(nf90_put_var(map_file%ncid, map_file%veg_cd_varid, vtmp2d)) + ! + vtmp2d = FILL_VALUE + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm > 0) then + do isec = 1, vegetation_vertical_segments + vtmp2d(nmq, isec) = vegetation_stems_height(nm, isec) + enddo + endif + enddo + NF90(nf90_put_var(map_file%ncid, map_file%veg_ah_varid, vtmp2d)) + ! + vtmp2d = FILL_VALUE + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm > 0) then + do isec = 1, vegetation_vertical_segments + vtmp2d(nmq, isec) = vegetation_stems_diameter(nm, isec) + enddo + endif + enddo + NF90(nf90_put_var(map_file%ncid, map_file%veg_bstems_varid, vtmp2d)) + ! + vtmp2d = FILL_VALUE + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm > 0) then + do isec = 1, vegetation_vertical_segments + vtmp2d(nmq, isec) = vegetation_stems_density(nm, isec) + enddo + endif + enddo + NF90(nf90_put_var(map_file%ncid, map_file%veg_Nstems_varid, vtmp2d)) + ! + deallocate(vtmp2d) + ! + endif + ! ! write away intermediate data ! NF90(nf90_sync(map_file%ncid)) !write away intermediate data ! end subroutine - - + + subroutine ncoutput_his_init() ! ! 1. Initialise dimensions/variables/attributes @@ -1684,7 +1843,8 @@ subroutine ncoutput_his_init() !NF90(nf90_put_att(his_file%ncid, his_file%station_id_varid, 'units', '-')) !not wanted in fews ! NF90(nf90_def_var(his_file%ncid, 'station_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%points_dimid/), his_file%station_name_varid)) - !NF90(nf90_put_att(his_file%ncid, his_file%station_name_varid, 'units', '-')) !not wanted in fews + !NF90(nf90_put_att(his_file%ncid, his_file%station_name_varid, 'units', '-')) !not wanted in fews + NF90(nf90_put_att(his_file%ncid, his_file%station_name_varid, 'cf_role', 'timeseries_id')) ! if (nrcrosssections>0) then NF90(nf90_def_var(his_file%ncid, 'crosssection_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%crosssections_dimid/), his_file%crosssection_name_varid)) @@ -1725,14 +1885,14 @@ subroutine ncoutput_his_init() !NF90(nf90_put_att(his_file%ncid, his_file%point_y_varid, 'grid', 'sfincsgrid')) !keep this? ! NF90(nf90_def_var(his_file%ncid, 'crs', NF90_INT, his_file%crs_varid)) ! For EPSG code - NF90(nf90_put_att(his_file%ncid, his_file%crs_varid, 'EPSG', '-')) - NF90(nf90_put_att(his_file%ncid, his_file%crs_varid, 'epsg_code', 'EPSG:' // trim(epsg_code) )) !--> add epsg_code like FEWS wants + NF90(nf90_put_att(his_file%ncid, his_file%crs_varid, 'epsg', epsg)) + NF90(nf90_put_att(his_file%ncid, his_file%crs_varid, 'epsg_code', 'EPSG:' // trim(epsg_code) )) !--> add epsg_code like FEWS wants ! NF90(nf90_def_var(his_file%ncid, 'point_zb', NF90_FLOAT, (/his_file%points_dimid/), his_file%zb_varid)) ! bed level in cell centre, for points NF90(nf90_put_att(his_file%ncid, his_file%zb_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%zb_varid, 'units', 'm')) NF90(nf90_put_att(his_file%ncid, his_file%zb_varid, 'standard_name', 'altitude')) - NF90(nf90_put_att(his_file%ncid, his_file%zb_varid, 'long_name', 'bed_level_above_reference_level')) + NF90(nf90_put_att(his_file%ncid, his_file%zb_varid, 'long_name', 'Bed level above reference level')) NF90(nf90_put_att(his_file%ncid, his_file%zb_varid, 'coordinates', 'station_id station_name point_x point_y')) ! if (nrstructures>0) then @@ -1787,7 +1947,7 @@ subroutine ncoutput_his_init() NF90(nf90_put_att(his_file%ncid, his_file%zs_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%zs_varid, 'units', 'm')) NF90(nf90_put_att(his_file%ncid, his_file%zs_varid, 'standard_name', 'sea_surface_height_above_reference_level')) - NF90(nf90_put_att(his_file%ncid, his_file%zs_varid, 'long_name', 'water_level')) + NF90(nf90_put_att(his_file%ncid, his_file%zs_varid, 'long_name', 'Water level above reference level')) NF90(nf90_put_att(his_file%ncid, his_file%zs_varid, 'coordinates', 'station_id station_name point_x point_y')) ! if (subgrid .eqv. .false. .or. store_hsubgrid .eqv. .true.) then @@ -1795,7 +1955,7 @@ subroutine ncoutput_his_init() NF90(nf90_put_att(his_file%ncid, his_file%h_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%h_varid, 'units', 'm')) NF90(nf90_put_att(his_file%ncid, his_file%h_varid, 'standard_name', 'depth')) - NF90(nf90_put_att(his_file%ncid, his_file%h_varid, 'long_name', 'water_depth')) + NF90(nf90_put_att(his_file%ncid, his_file%h_varid, 'long_name', 'Water depth')) NF90(nf90_put_att(his_file%ncid, his_file%h_varid, 'coordinates', 'station_id station_name point_x point_y')) endif ! @@ -2006,7 +2166,7 @@ subroutine ncoutput_his_init() NF90(nf90_def_var(his_file%ncid, 'point_patm', NF90_FLOAT, (/his_file%points_dimid, his_file%time_dimid/), his_file%patm_varid)) ! time-varying patm point NF90(nf90_put_att(his_file%ncid, his_file%patm_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%patm_varid, 'units', 'Pa')) - NF90(nf90_put_att(his_file%ncid, his_file%patm_varid, 'long_name', 'surface_air_pressure')) + NF90(nf90_put_att(his_file%ncid, his_file%patm_varid, 'long_name', 'Surface air pressure')) NF90(nf90_put_att(his_file%ncid, his_file%patm_varid, 'coordinates', 'station_id station_name point_x point_y')) ! endif @@ -2066,11 +2226,11 @@ subroutine ncoutput_his_init() ! Add for final output: NF90(nf90_def_var(his_file%ncid, 'total_runtime', NF90_FLOAT, (/his_file%runtime_dimid/), his_file%total_runtime_varid)) NF90(nf90_put_att(his_file%ncid, his_file%total_runtime_varid, 'units', 's')) - NF90(nf90_put_att(his_file%ncid, his_file%total_runtime_varid, 'long_name', 'total_model_runtime_in_seconds')) + NF90(nf90_put_att(his_file%ncid, his_file%total_runtime_varid, 'long_name', 'Total model runtime (s)')) ! NF90(nf90_def_var(his_file%ncid, 'average_dt', NF90_FLOAT, (/his_file%runtime_dimid/), his_file%average_dt_varid)) NF90(nf90_put_att(his_file%ncid, his_file%average_dt_varid, 'units', 's')) - NF90(nf90_put_att(his_file%ncid, his_file%average_dt_varid, 'long_name', 'model_average_timestep_in_seconds')) + NF90(nf90_put_att(his_file%ncid, his_file%average_dt_varid, 'long_name', 'Average model time step (s)')) ! NF90(nf90_def_var(his_file%ncid, 'status', NF90_FLOAT, (/his_file%runtime_dimid/), his_file%status_varid)) NF90(nf90_put_att(his_file%ncid, his_file%status_varid, 'units', '-')) @@ -3913,8 +4073,8 @@ subroutine ncoutput_add_params(ncid, varid) use sfincs_data ! ! 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, & - igwaves_opt, alpha_ig, gamma_ig, shinc2ig, alphaigfac, baldock_ratio_ig, ig_opt, herbers_opt, tpig_opt, eeinc2ig, tinc2ig, & + use snapwave_data, only: gamma, gammax, alpha, hmin, fw0, fw0_ig, dt, tol, dtheta, crit, nr_sweeps, baldock_exponent, baldock_ratio, & + igwaves_opt, alpha_ig, gamma_ig, gamma_fac_br, shinc2ig, alphaigfac, baldock_ratio_ig, ig_opt, herbers_opt, tpig_opt, eeinc2ig, tinc2ig, & snapwave_jonswapfile, snapwave_encfile, snapwave_bndfile, snapwave_bhsfile, snapwave_btpfile, snapwave_bwdfile, snapwave_bdsfile, upwfile, gridfile ! @@ -3974,7 +4134,7 @@ subroutine ncoutput_add_params(ncid, varid) NF90(nf90_put_att(ncid, varid, 'baro',baro)) NF90(nf90_put_att(ncid, varid, 'utmzone',utmzone)) NF90(nf90_put_att(ncid, varid, 'epsg',epsg)) - NF90(nf90_put_att(ncid, varid, 'epsg_code',epsg_code)) + NF90(nf90_put_att(ncid, varid, 'epsg_code',epsg_code)) NF90(nf90_put_att(ncid, varid, 'advlim',advlim)) NF90(nf90_put_att(ncid, varid, 'uvlim',uvlim)) NF90(nf90_put_att(ncid, varid, 'uvmax',uvmax)) @@ -4115,16 +4275,17 @@ subroutine ncoutput_add_params(ncid, varid) NF90(nf90_put_att(ncid, varid, 'snapwave_dtheta',dtheta)) NF90(nf90_put_att(ncid, varid, 'snapwave_crit',crit)) NF90(nf90_put_att(ncid, varid, 'snapwave_nrsweeps',nr_sweeps)) - NF90(nf90_put_att(ncid, varid, 'snapwave_baldock_opt',baldock_opt)) + NF90(nf90_put_att(ncid, varid, 'snapwave_baldock_exponent',baldock_exponent)) NF90(nf90_put_att(ncid, varid, 'snapwave_baldock_ratio',baldock_ratio)) - NF90(nf90_put_att(ncid, varid, 'snapwave_waveforces_factor',waveforces_factor)) + NF90(nf90_put_att(ncid, varid, 'snapwave_waveforces_ratio',waveforces_ratio)) ! ! SnapWave IG ! NF90(nf90_put_att(ncid, varid, 'snapwave_igwaves',igwaves_opt)) NF90(nf90_put_att(ncid, varid, 'snapwave_alpha_ig',alpha_ig)) - NF90(nf90_put_att(ncid, varid, 'snapwave_gammaig',gamma_ig)) - NF90(nf90_put_att(ncid, varid, 'snapwave_shinc2ig',shinc2ig)) + NF90(nf90_put_att(ncid, varid, 'snapwave_gammaig',gamma_ig)) + NF90(nf90_put_att(ncid, varid, 'snapwave_gamma_fac_br',gamma_fac_br)) + NF90(nf90_put_att(ncid, varid, 'snapwave_shinc2ig',shinc2ig)) NF90(nf90_put_att(ncid, varid, 'snapwave_alphaigfac',alphaigfac)) NF90(nf90_put_att(ncid, varid, 'snapwave_baldock_ratio_ig',baldock_ratio_ig)) NF90(nf90_put_att(ncid, varid, 'snapwave_ig_opt',ig_opt)) diff --git a/source/src/sfincs_quadtree.F90 b/source/src/sfincs_quadtree.F90 index 72a5397a9..697f5f750 100644 --- a/source/src/sfincs_quadtree.F90 +++ b/source/src/sfincs_quadtree.F90 @@ -47,6 +47,7 @@ module quadtree integer*1, dimension(:), allocatable :: quadtree_snapwave_mask integer*1, dimension(:), allocatable :: quadtree_nonh_mask ! + ! type net_type_qtr integer :: ncid integer :: np_dimid @@ -301,7 +302,7 @@ subroutine quadtree_read_file_netcdf(qtrfile, snapwave, nonhydrostatic) logical, intent(in) :: snapwave, nonhydrostatic ! integer*1 :: iversion - integer :: np, ip, iepsg, status + integer :: np, nm, ip, iepsg, status ! write(logstr,'(a,a)')'Info : reading QuadTree netCDF file ', trim(qtrfile) call write_log(logstr, 0) @@ -343,7 +344,7 @@ subroutine quadtree_read_file_netcdf(qtrfile, snapwave, nonhydrostatic) NF90(nf90_inq_varid(net_file_qtr%ncid, 'snapwave_mask', net_file_qtr%snapwave_mask_varid)) ! allocate(quadtree_snapwave_mask(np)) - ! + ! endif ! ! Allocate variables @@ -391,7 +392,9 @@ subroutine quadtree_read_file_netcdf(qtrfile, snapwave, nonhydrostatic) NF90(nf90_get_var(net_file_qtr%ncid, net_file_qtr%mask_varid, quadtree_mask(:))) ! if (snapwave) then + ! NF90(nf90_get_var(net_file_qtr%ncid, net_file_qtr%snapwave_mask_varid, quadtree_snapwave_mask(:))) + ! endif ! ! Nonhydrostatic mask diff --git a/source/src/sfincs_read.f90 b/source/src/sfincs_read.f90 new file mode 100644 index 000000000..553c82fac --- /dev/null +++ b/source/src/sfincs_read.f90 @@ -0,0 +1,303 @@ +module sfincs_read + +contains + + 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.) + ! + read(fileid,'(a)',iostat = stat)line + ! + if (stat==-1) exit + ! + call read_line(line, keystr, valstr) + ! + if (trim(keystr)==trim(keyword)) then + ! + read(valstr,*)value + ! + exit + ! + 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 + ! + 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 + ! + read(valstr,*)(value(m), m = 1, nr) + ! + exit + ! + 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 + ! + 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 + ! + read(valstr,*)value + ! + exit + ! + endif + ! + enddo + ! + 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.) + ! + read(fileid,'(a)',iostat = stat)line + ! + if (stat==-1) exit + ! + call read_line(line, keystr, valstr) + ! + if (trim(keystr)==trim(keyword)) then + ! + value = valstr + ! + exit + ! + 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 + ! + 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 + ! + 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 + ! + exit + ! + 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. + ! + jn = index(line, '\r') + ! + if (jn > 0) then + ! + ! New line character detected (probably sfincs.inp with windows line endings, running in linux) + ! + 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 + ! + jn = index(valstr, '#') + ! + if (jn > 0) then + ! + valstr = trim(valstr(1 : jn - 1)) + ! + endif + ! + 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 + ! + ! 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) + ! + 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 + else + OUTSTR(IPOS:IPOS)=c + IPOS=IPOS+1 + endif + endif + enddo + ! + ILEN=len_trim(OUTSTR(:IPOS)) ! trim trailing spaces + return + ! + end subroutine notabs + + +end module diff --git a/source/src/sfincs_snapwave.f90 b/source/src/sfincs_snapwave.f90 index 81d5015e0..5810c62df 100644 --- a/source/src/sfincs_snapwave.f90 +++ b/source/src/sfincs_snapwave.f90 @@ -37,6 +37,7 @@ module sfincs_snapwave real*4 :: snapwave_hsmean real*4 :: snapwave_tpmean real*4 :: snapwave_tpigmean + real*4 :: snapwave_fwmaxfac ! contains ! @@ -50,8 +51,8 @@ subroutine couple_snapwave(crsgeo) ! logical :: crsgeo ! - build_revision = '$Rev: svn 197-branch:SnapWave_IG' - build_date = '$Date: 2025-04-14' + build_revision = '$Rev: git SFINCS_SnapWave:main' + build_date = '$Date: 2026-06-10' ! call write_log('', 1) call write_log('----------- Welcome to SnapWave ---------', 1) @@ -498,13 +499,13 @@ subroutine update_wave_field(t, tloop) ! ! U point ! - fwuv(ip) = waveforces_factor * (0.5 * (cosrot * fwx0(nm) + sinrot * fwy0(nm)) + 0.5 * ( cosrot * fwx0(nmu) + sinrot * fwy0(nmu))) / rhow - ! waveforces_factor = 1.0 by default, but can be set to 0 to avoid double counting incident setup if wavemaker_hinc true + fwuv(ip) = waveforces_ratio * (0.5 * (cosrot * fwx0(nm) + sinrot * fwy0(nm)) + 0.5 * ( cosrot * fwx0(nmu) + sinrot * fwy0(nmu))) / rhow + ! waveforces_ratio = 1.0 by default, but can be set to 0 to avoid double counting incident setup if wavemaker_hinc true else ! ! V point ! - fwuv(ip) = waveforces_factor * (0.5 * (-sinrot * fwx0(nm) + cosrot * fwy0(nm)) + 0.5 * (-sinrot * fwx0(nmu) + cosrot * fwy0(nmu))) / rhow + fwuv(ip) = waveforces_ratio * (0.5 * (-sinrot * fwx0(nm) + cosrot * fwy0(nm)) + 0.5 * (-sinrot * fwx0(nmu) + cosrot * fwy0(nmu))) / rhow ! endif ! @@ -512,6 +513,9 @@ subroutine update_wave_field(t, tloop) ! !$acc update device(fwuv) ! + ! Set wave forces fwmaxfac factor + fwmaxfac = snapwave_fwmaxfac + ! call system_clock(count1, count_rate, count_max) tloop = tloop + 1.0*(count1 - count0)/count_rate ! @@ -554,11 +558,16 @@ subroutine compute_snapwave(t) snapwave_beta = beta snapwave_srcig = srcig snapwave_alphaig = alphaig - ! + ! ! Convert wave force to correct unit [Dw/C] as expected by SFINCS, assumed to be piecewise (seems to work) snapwave_Fx = Fx * rho * depth snapwave_Fy = Fy * rho * depth ! + ! Pre-alculate wave forces limiter factor + snapwave_fwmaxfac = 0.25 * sqrt(g) * rho * gammax**2 / tpmean_bwv + ! + ! FIXME - should we limit snapwave_fwmaxfac to a certain range? + ! ! Loop over points and set Tp, cg, direction, spreading to 0 where H and/or H_ig are zero ! TL: needed because e.g. Tp is set to Tpini initially, so shows values even if cell remains dry with H=0 do k = 1, no_nodes @@ -583,17 +592,8 @@ subroutine compute_snapwave(t) if (igwaves) then ! snapwave_tpigmean = tpmean_bwv_ig - ! - if (snapwave_tpigmean < 10.0) then - ! These warnings should not occur here - write(logstr,*)'DEBUG SFINCS_SnapWave - incoming tp for IG wave at wavemaker might be unrealistically small! value: ',snapwave_tpigmean - call write_log(logstr, 0) - elseif (snapwave_tpigmean > 250.0) then - write(logstr,*)'DEBUG SFINCS_SnapWave - incoming tp for IG wave at wavemaker might be unrealistically large! value: ',snapwave_tpigmean - call write_log(logstr, 0) - endif + ! endif - ! TL: NOTE - in first timestep run of SnapWave tp = 0, therefore excluded that case from the check ! end subroutine @@ -604,6 +604,7 @@ subroutine read_snapwave_input() ! Reads snapwave data from sfincs.inp ! use snapwave_data + use sfincs_read ! implicit none ! @@ -611,49 +612,51 @@ subroutine read_snapwave_input() ! ! Input section ! - call read_real_input(500, 'snapwave_gamma', gamma, 0.7) - call read_real_input(500, 'snapwave_gammax', gammax, 2.0) ! MvO - Changed default gammax from 0.6 to 2.0 - call read_real_input(500, 'snapwave_alpha', alpha, 1.0) - call read_real_input(500, 'snapwave_hmin', hmin, 0.1) - call read_real_input(500, 'snapwave_fw', fw0, 0.01) - call read_real_input(500, 'snapwave_fwig', fw0_ig, 0.015) - call read_real_input(500, 'snapwave_dt', dt, 36000.0) - call read_real_input(500, 'snapwave_tol', tol, 1000.0) - call read_real_input(500, 'snapwave_dtheta', dtheta, 10.0) - call read_real_input(500, 'snapwave_crit', crit, 0.001) !TL: Old default was 0.01 - call read_int_input(500, 'snapwave_nrsweeps', nr_sweeps, 4) - call read_int_input(500, 'snapwave_niter', niter, 10) - call read_int_input(500, 'snapwave_baldock_opt', baldock_opt, 1) - call read_real_input(500, 'snapwave_baldock_ratio', baldock_ratio, 0.2) - call read_real_input(500, 'rgh_lev_land', rghlevland, 0.0) - call read_real_input(500, 'snapwave_fw_ratio', fwratio, 1.0) - call read_real_input(500, 'snapwave_fwig_ratio', fwigratio, 1.0) - call read_real_input(500, 'snapwave_Tpini', Tpini, 1.0) - call read_int_input (500, 'snapwave_mwind', mwind, 2) - call read_real_input(500, 'snapwave_sigmin', sigmin, 8.0 * atan(1.0) / 25.0) - call read_real_input(500, 'snapwave_sigmax', sigmax, 8.0 * atan(1.0) / 1.0) - call read_int_input (500, 'snapwave_jadcgdx', jadcgdx, 1) - call read_real_input(500, 'snapwave_c_dispT', c_dispT, 1.0) - call read_real_input(500, 'snapwave_sector', sector, 180.0) - ! - ! Settings related to IG waves - ! - call read_int_input(500, 'snapwave_igwaves', igwaves_opt, 1) ! Compute IG waves (1=default), or not (0) - call read_real_input(500, 'snapwave_alpha_ig', alpha_ig, 1.0) ! TODO choose whether snapwave_alphaig or snapwave_gamma_ig - call read_real_input(500, 'snapwave_gammaig', gamma_ig, 0.2) ! Wave breaking parameter for IG waves, default=0.2 - call read_real_input(500, 'snapwave_shinc2ig', shinc2ig, 1.0) ! Ratio of how much of the calculated IG wave source term, is subtracted from the incident wave energy (0-1, 1=default=all energy as sink) - call read_real_input(500, 'snapwave_alphaigfac', alphaigfac, 1.0) ! Multiplication factor for IG shoaling source/sink term - call read_real_input(500, 'snapwave_baldock_ratio_ig', baldock_ratio_ig, 0.2) ! ! option controlling from what depth wave breaking should take place for IG waves, default baldock_ratio_ig=0.2 - call read_int_input(500, 'snapwave_ig_opt', ig_opt, 1) ! option of IG wave settings (1 = default = conservative shoaling based dSxx as in Leijnse et al. 2024) - call read_int_input(500, 'snapwave_iterative_srcig', iterative_srcig_opt, 0) ! Option whether to calculate IG source/sink term in iterative lower (better, but potentially slower, 1), or effectively based on previous timestep (faster, potential mismatch, =0=default) - ! - ! IG boundary conditions options - ! - call read_int_input(500, 'snapwave_use_herbers', herbers_opt, 1) ! Choice whether you want IG Hm0&Tp be calculated by herbers (=1, default), or want to specify user defined values (0> then snapwave_eeinc2ig & snapwave_Tinc2ig are used) - call read_int_input(500, 'snapwave_tpig_opt', tpig_opt, 1) ! IG wave period option based on Herbers calculated spectrum, only used if snapwave_use_herbers = 1. Options are: 1=Tm01 (default), 2=Tpsmooth, 3=Tp, 4=Tm-1,0 - call read_real_input(500, 'snapwave_jonswapgamma',jonswapgam, 3.3) ! JONSWAP gamma value for determination offshore spectrum and IG wave conditions using Herbers, default=3.3, only used if snapwave_use_herbers = 1 - call read_real_input(500, 'snapwave_eeinc2ig', eeinc2ig, 0.01) ! Only used if snapwave_use_herbers = 0 - call read_real_input(500, 'snapwave_Tinc2ig', Tinc2ig, 7.0) ! Only used if snapwave_use_herbers = 0 + call read_real_input(500,'snapwave_gamma',gamma,0.7) + call read_real_input(500,'snapwave_gammax',gammax,999.0) + call read_real_input(500,'snapwave_alpha',alpha,1.0) + call read_real_input(500,'snapwave_hmin',hmin,0.1) + call read_real_input(500,'snapwave_fw',fw0,0.01) + call read_real_input(500,'snapwave_fwig',fw0_ig,0.015) + call read_real_input(500,'snapwave_dt',dt,36000.0) + call read_real_input(500,'snapwave_tol',tol,1000.0) + call read_real_input(500,'snapwave_dtheta',dtheta,10.0) + call read_real_input(500,'snapwave_crit',crit,0.001) + call read_int_input(500,'snapwave_nrsweeps',nr_sweeps,4) + call read_int_input(500,'snapwave_niter',niter, 10) !TL: Old default was 40 + !call read_int_input(500,'snapwave_baldock_opt',baldock_opt,1) + call read_real_input(500,'snapwave_baldock_ratio',baldock_ratio,0.2) + call read_int_input(500,'snapwave_baldock_exponent',baldock_exponent,2) ! Exponent for multiplying the Baldock dissipation with a factor 'f = (Hloc / Hmax)**iexp' to enhance breaking when H > Hmax, with iexp = 0 (means unused), 1 or 2 (default). Generally, only active for steep coastlines, where Baldock dissipation can be too low in the surf zone. + call read_real_input(500,'rgh_lev_land',rghlevland,0.0) + call read_real_input(500,'snapwave_fw_ratio',fwratio,1.0) + call read_real_input(500,'snapwave_fwig_ratio',fwigratio,1.0) + call read_real_input(500,'snapwave_Tpini',Tpini,1.0) + call read_int_input (500,'snapwave_mwind',mwind,2) + call read_real_input(500,'snapwave_sigmin',sigmin,8.0 * atan(1.0) / 25.0) + call read_real_input(500,'snapwave_sigmax',sigmax,8.0 * atan(1.0) / 1.0) + call read_int_input (500,'snapwave_jadcgdx',jadcgdx,1) + call read_real_input(500,'snapwave_c_dispT',c_dispT,1.0) + call read_real_input(500,'snapwave_sector',sector,180.0) + call read_real_input(500,'snapwave_relax_factor_DoverA',relax_factor_DoverA,0.25) ! underrelaxation factor for DoverA (set to 1.0 to disable) + call read_real_input(500,'snapwave_relax_factor_DoverE',relax_factor_DoverE,0.25) ! underrelaxation factor for DoverE (set to 1.0 to disable) + ! + ! Settings related to IG waves: + call read_int_input(500,'snapwave_igwaves',igwaves_opt,1) + call read_real_input(500,'snapwave_alpha_ig',alpha_ig,1.0) !TODO choose whether snapwave_alphaig or snapwave_gamma_ig + call read_real_input(500,'snapwave_gammaig', gamma_ig, 0.7) ! Wave breaking parameter for IG waves, default=0.7 + call read_real_input(500,'snapwave_gamma_fac_br',gamma_fac_br,0.45) ! factor times gamma that is used to determine the maximum incident wave breaking point in the surf zone using local incident wave height over water depth ratio, among others used to set the IG source term to 0 shallower than this point + call read_real_input(500,'snapwave_shinc2ig',shinc2ig,1.0) ! Ratio of how much of the calculated IG wave source term, is subtracted from the incident wave energy (0-1, 1=default=all energy as sink) + call read_real_input(500,'snapwave_alphaigfac',alphaigfac,1.0) ! Multiplication factor for IG shoaling source/sink term + call read_real_input(500,'snapwave_baldock_ratio_ig',baldock_ratio_ig,0.2) + call read_int_input(500,'snapwave_ig_opt',ig_opt,1) + call read_int_input(500,'snapwave_iterative_srcig',iterative_srcig_opt,0) ! Option whether to calculate IG source/sink term in iterative lower (better, but potentially slower, 1=default), or effectively based on previous timestep (faster, potential mismatch, =0) + ! + ! IG boundary conditions options: + call read_int_input(500,'snapwave_use_herbers',herbers_opt,1) ! Choice whether you want IG Hm0&Tp be calculated by herbers (=1, default), or want to specify user defined values (0> then snapwave_eeinc2ig & snapwave_Tinc2ig are used) + call read_int_input(500,'snapwave_tpig_opt',tpig_opt,1) ! IG wave period option based on Herbers calculated spectrum, only used if snapwave_use_herbers = 1. Options are: 1=Tm01 (default), 2=Tpsmooth, 3=Tp, 4=Tm-1,0 + call read_real_input(500,'snapwave_jonswapgamma',jonswapgam,3.3) ! JONSWAP gamma value for determination offshore spectrum and IG wave conditions using Herbers, default=3.3, only used if snapwave_use_herbers = 1 + call read_real_input(500,'snapwave_eeinc2ig',eeinc2ig,0.01) ! Only used if snapwave_use_herbers = 0 + call read_real_input(500,'snapwave_Tinc2ig',Tinc2ig,7.0) ! Only used if snapwave_use_herbers = 0 ! ! Wind ! @@ -661,7 +664,7 @@ subroutine read_snapwave_input() ! ! Vegetation input ! - call read_int_input(500, 'vegetation', vegetation_opt, 0) + call read_int_input(500, 'snapwave_vegetation', vegetation_opt, 0) ! ! Input files ! @@ -677,6 +680,7 @@ subroutine read_snapwave_input() call read_char_input(500, 'snapwave_depfile', depfile, 'none') call read_char_input(500, 'snapwave_ncfile', gridfile, 'snapwave_net.nc') call read_char_input(500, 'netsnapwavefile', netsnapwavefile, 'none') + call read_logical_input(500,'storesnapwavegrid',storesnapwavegrid,.false.) call read_char_input(500, 'tref', trefstr, '20000101 000000') ! Read again > needed in sfincs_ncinput.F90 ! close(500) @@ -729,304 +733,7 @@ subroutine read_snapwave_input() restart = .true. coupled_to_sfincs = .true. ! - 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.) - ! - read(fileid,'(a)',iostat = stat)line - ! - if (stat==-1) exit - ! - call read_line(line, keystr, valstr) - ! - if (trim(keystr)==trim(keyword)) then - ! - read(valstr,*)value - ! - exit - ! - 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 - ! - 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 - ! - read(valstr,*)(value(m), m = 1, nr) - ! - exit - ! - 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 - ! - 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 - ! - read(valstr,*)value - ! - exit - ! - endif - ! - enddo - ! - 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.) - ! - read(fileid,'(a)',iostat = stat)line - ! - if (stat==-1) exit - ! - call read_line(line, keystr, valstr) - ! - if (trim(keystr)==trim(keyword)) then - ! - value = valstr - ! - exit - ! - endif - ! - enddo - ! - end subroutine + end subroutine read_snapwave_input - 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 - ! - 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 - ! - 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 - ! - exit - ! - 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. - ! - jn = index(line, '\r') - ! - if (jn > 0) then - ! - ! New line character detected (probably sfincs.inp with windows line endings, running in linux) - ! - 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 - ! - jn = index(valstr, '#') - ! - if (jn > 0) then - ! - valstr = trim(valstr(1 : jn - 1)) - ! - endif - ! - 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 - ! - ! 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) - ! - 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 - else - OUTSTR(IPOS:IPOS)=c - IPOS=IPOS+1 - endif - endif - enddo - ! - ILEN=len_trim(OUTSTR(:IPOS)) ! trim trailing spaces - return - ! - end subroutine notabs end module diff --git a/source/src/sfincs_spiderweb.f90 b/source/src/sfincs_spiderweb.f90 index 2c0abb618..7e9e6818b 100644 --- a/source/src/sfincs_spiderweb.f90 +++ b/source/src/sfincs_spiderweb.f90 @@ -1,6 +1,7 @@ module sfincs_spiderweb use sfincs_log + use sfincs_read contains @@ -404,61 +405,6 @@ subroutine read_amuv_dimensions(filename,nt,nrows,ncols,x_llcorner,y_llcorner,dx ! 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 - ! - value = default - rewind(fileid) - do while(.true.) - read(fileid,'(a)',iostat = stat)line - if (stat<0) exit - j=index(line,'=') - keystr = trim(line(1:j-1)) - if (trim(keystr)==trim(keyword)) then - valstr = trim(line(j+1:256)) - read(valstr,*)value - exit - 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 - ! - value = default - rewind(fileid) - do while(.true.) - read(fileid,'(a)',iostat = stat)line - if (stat<0) exit - j=index(line,'=') - keystr = trim(line(1:j-1)) - if (trim(keystr)==trim(keyword)) then - valstr = trim(line(j+1:256)) - read(valstr,*)value - exit - endif - enddo - ! - end subroutine subroutine compute_time_in_seconds(line,trefstr,dtsec) diff --git a/source/src/sfincs_vegetation.f90 b/source/src/sfincs_vegetation.f90 new file mode 100644 index 000000000..06e93f33c --- /dev/null +++ b/source/src/sfincs_vegetation.f90 @@ -0,0 +1,374 @@ +module sfincs_vegetation + + use sfincs_log + use sfincs_error + +contains + + subroutine initialize_vegetation() + ! + use sfincs_data + use sfincs_ncinput + ! + implicit none + ! + integer :: nm, flag_idx, type_idx + integer :: max_layers, nflags + ! + logical :: ok + ! + character*256 :: varname + ! + integer, allocatable :: flag_values(:) + character(len=64), allocatable :: flag_meanings(:) + integer, allocatable :: type_to_lookup(:) ! maps flag integer -> lookup row index + real*4, allocatable :: veg_cd_lookup(:,:) + real*4, allocatable :: veg_ah_lookup(:,:) + real*4, allocatable :: veg_bstems_lookup(:,:) + real*4, allocatable :: veg_nstems_lookup(:,:) + ! + if (store_vegetation) then + ! + if (use_quadtree .eqv. .false.) then + call stop_sfincs('Error ! Netcdf vegetation input format can only be specified for quadtree mesh model !', 1) + endif + ! + write(logstr,'(a,a)')'Info : reading vegetation file ',trim(veggiefile) + call write_log(logstr, 0) + ! + ok = check_file_exists(veggiefile, 'Vegetation file', .true.) + ! + if (trim(veggietype_toml) == 'none') then + ! + ! Old path: all four parameter arrays stored directly in the NetCDF per grid cell + ! + varname = 'nsec' + call read_netcdf_quadtree_get_dimension(veggiefile, varname, vegetation_vertical_segments) + ! + if (vegetation_vertical_segments > 64) then + call stop_sfincs('Error ! vegetation_vertical_segments exceeds 64, check vegetationfile !', 1) + endif + ! + allocate(vegetation_stems_cd(np, vegetation_vertical_segments)) + allocate(vegetation_stems_height(np, vegetation_vertical_segments)) + allocate(vegetation_stems_diameter(np, vegetation_vertical_segments)) + allocate(vegetation_stems_density(np, vegetation_vertical_segments)) + ! + vegetation_stems_cd = 0.0 + vegetation_stems_height = 0.0 + vegetation_stems_diameter = 0.0 + vegetation_stems_density = 0.0 + ! + varname = 'snapwave_veg_Cd' + call read_netcdf_quadtree_to_sfincs(veggiefile, varname, vegetation_stems_cd) + ! + varname = 'snapwave_veg_ah' + call read_netcdf_quadtree_to_sfincs(veggiefile, varname, vegetation_stems_height) + ! + varname = 'snapwave_veg_bstems' + call read_netcdf_quadtree_to_sfincs(veggiefile, varname, vegetation_stems_diameter) + ! + varname = 'snapwave_veg_Nstems' + call read_netcdf_quadtree_to_sfincs(veggiefile, varname, vegetation_stems_density) + ! + else + ! + ! New path: veggiefile holds only integer vegetation_type per cell (CF flag conventions) + ! veggietype_toml holds the parameter lookup table keyed by type name + ! + ok = check_file_exists(veggietype_toml, 'Vegetation TOML file', .true.) + ! + write(logstr,'(a,a)')'Info : reading vegetation TOML file ',trim(veggietype_toml) + call write_log(logstr, 0) + ! + ! Read CF flag attributes: flag_values=[0,1,2,...] and flag_meanings=["none","seagrass",...] + ! + varname = 'vegetation_type' + call read_netcdf_flag_meanings(veggiefile, varname, & + flag_values, flag_meanings, nflags) + ! + write(logstr,'(a,i0,a)')'Info : found ',nflags,' vegetation type(s) in NetCDF flag attributes' + call write_log(logstr, 0) + ! + ! Read integer vegetation_type per active cell + ! + allocate(vegetation_type_index(np)) + vegetation_type_index = 0 + call read_netcdf_quadtree_integer(veggiefile, varname, vegetation_type_index) + ! + ! Parse TOML lookup table: fills veg_*_lookup(nflags, max_layers), zero-padded + ! + call read_vegetation_toml(flag_meanings, nflags, & + veg_cd_lookup, veg_ah_lookup, veg_bstems_lookup, veg_nstems_lookup, max_layers) + ! + vegetation_vertical_segments = max_layers + ! + allocate(vegetation_stems_cd(np, vegetation_vertical_segments)) + allocate(vegetation_stems_height(np, vegetation_vertical_segments)) + allocate(vegetation_stems_diameter(np, vegetation_vertical_segments)) + allocate(vegetation_stems_density(np, vegetation_vertical_segments)) + ! + vegetation_stems_cd = 0.0 + vegetation_stems_height = 0.0 + vegetation_stems_diameter = 0.0 + vegetation_stems_density = 0.0 + ! + ! Build a direct map from flag integer value to lookup row to avoid per-cell linear search + ! + allocate(type_to_lookup(0:maxval(flag_values))) + type_to_lookup = -1 + do flag_idx = 1, nflags + type_to_lookup(flag_values(flag_idx)) = flag_idx + enddo + ! + ! Expand lookup table to per-cell arrays + ! + ! FIXME - parallellisation possible? + ! + do nm = 1, np + type_idx = vegetation_type_index(nm) + if (type_idx == 0) cycle ! type 0 = no vegetation + ! + if (type_idx < 0 .or. type_idx > maxval(flag_values)) then + write(logstr,'(a,i0,a)')'Error : vegetation_type ', type_idx, & + ' in NetCDF is outside the range of flag_values !' + call stop_sfincs(trim(logstr), 1) + endif + ! + flag_idx = type_to_lookup(type_idx) + ! + if (flag_idx < 1) then + write(logstr,'(a,i0,a)')'Error : vegetation_type ', type_idx, & + ' found in NetCDF but has no entry in the vegetation TOML file !' + call stop_sfincs(trim(logstr), 1) + endif + ! + vegetation_stems_cd(nm,:) = veg_cd_lookup(flag_idx,:) + vegetation_stems_height(nm,:) = veg_ah_lookup(flag_idx,:) + vegetation_stems_diameter(nm,:) = veg_bstems_lookup(flag_idx,:) + vegetation_stems_density(nm,:) = veg_nstems_lookup(flag_idx,:) + ! + enddo + ! + deallocate(vegetation_type_index) + deallocate(flag_values, flag_meanings, type_to_lookup) + deallocate(veg_cd_lookup, veg_ah_lookup, veg_bstems_lookup, veg_nstems_lookup) + ! + endif + ! + endif + ! + end subroutine + + + subroutine read_vegetation_toml(flag_meanings, nflags, & + veg_cd_lookup, veg_ah_lookup, veg_bstems_lookup, veg_nstems_lookup, max_layers) + ! Parse the TOML vegetation lookup table and return parameter arrays (nflags x max_layers). + ! Shorter types are zero-padded to max_layers so the output is rectangular. + ! + use tomlf + use sfincs_data + ! + implicit none + ! + integer, intent(in) :: nflags + character(len=64), intent(in) :: flag_meanings(nflags) + real*4, allocatable, intent(out) :: veg_cd_lookup(:,:) + real*4, allocatable, intent(out) :: veg_ah_lookup(:,:) + real*4, allocatable, intent(out) :: veg_bstems_lookup(:,:) + real*4, allocatable, intent(out) :: veg_nstems_lookup(:,:) + integer, intent(out) :: max_layers + ! + integer, parameter :: max_layers_limit = 64 + ! + type(toml_table), allocatable :: table + type(toml_error), allocatable :: parse_error + type(toml_table), pointer :: veg_table, type_table + type(toml_array), pointer :: cd_arr, ah_arr, bstems_arr, nstems_arr + ! + real*4, allocatable :: tmp_cd(:,:), tmp_ah(:,:), tmp_bstems(:,:), tmp_nstems(:,:) + integer, allocatable :: nlayers_per_type(:) + ! + integer :: it, il, nlayers, stat + real(kind=8) :: rval + character(len=64) :: typename + ! + allocate(tmp_cd(nflags, max_layers_limit)) + allocate(tmp_ah(nflags, max_layers_limit)) + allocate(tmp_bstems(nflags, max_layers_limit)) + allocate(tmp_nstems(nflags, max_layers_limit)) + allocate(nlayers_per_type(nflags)) + ! + tmp_cd = 0.0 + tmp_ah = 0.0 + tmp_bstems = 0.0 + tmp_nstems = 0.0 + ! + nlayers_per_type = 0 + ! + call toml_load(table, trim(veggietype_toml), error=parse_error) + ! + if (allocated(parse_error)) then + ! + write(logstr,'(a,a,a,a)')'Error : failed to parse vegetation TOML file ', & + trim(veggietype_toml), ': ', trim(parse_error%message) + ! + call stop_sfincs(trim(logstr), 1) + ! + endif + ! + if (.not. allocated(table)) then + ! + call stop_sfincs('Error : vegetation TOML file is empty or could not be read !', 1) + ! + endif + ! + ! Expect a [vegetation_type] table at the root level + ! + nullify(veg_table) + call get_value(table, 'vegetation_type', veg_table, stat=stat) + ! + if (.not. associated(veg_table)) then + call stop_sfincs('Error : vegetation TOML file missing [vegetation_type] section !', 1) + endif + ! + ! Loop over all names from CF flag_meanings and read their parameter arrays + ! + do it = 1, nflags + ! + typename = trim(flag_meanings(it)) + ! + ! Skip the no-vegetation entry; its cells are handled by the zero initialisation above + ! + if (trim(typename) == 'none' .or. trim(typename) == '') cycle + ! + nullify(type_table) + call get_value(veg_table, trim(typename), type_table, stat=stat) + ! + if (.not. associated(type_table)) then + write(logstr,'(a,a,a)')'Warning : vegetation type "',trim(typename), & + '" listed in NetCDF flag_meanings but absent from TOML - treated as no vegetation' + call write_log(logstr, 0) + cycle + endif + ! + ! --- vegetation_stems_cd --- + ! + nullify(cd_arr) + call get_value(type_table, 'vegetation_stems_cd', cd_arr, stat=stat) + ! + if (.not. associated(cd_arr)) then + write(logstr,'(a,a,a)')'Error : vegetation type "',trim(typename), & + '" in TOML is missing vegetation_stems_cd array !' + call stop_sfincs(trim(logstr), 1) + endif + ! + nlayers = len(cd_arr) + ! + if (nlayers > max_layers_limit) then + write(logstr,'(a,a,a,i0,a,i0,a)')'Error : vegetation type "',trim(typename), & + '" has ',nlayers,' layers which exceeds the limit of ',max_layers_limit,' !' + call stop_sfincs(trim(logstr), 1) + endif + ! + nlayers_per_type(it) = nlayers + ! + do il = 1, nlayers + call get_value(cd_arr, il, rval, stat=stat) + tmp_cd(it, il) = real(rval, kind=4) + enddo + ! + ! --- vegetation_stems_height --- + ! + nullify(ah_arr) + call get_value(type_table, 'vegetation_stems_height', ah_arr, stat=stat) + ! + if (.not. associated(ah_arr)) then + write(logstr,'(a,a,a)')'Error : vegetation type "',trim(typename), & + '" in TOML is missing vegetation_stems_height array !' + call stop_sfincs(trim(logstr), 1) + endif + ! + if (len(ah_arr) /= nlayers) then + write(logstr,'(a,a,a)')'Error : vegetation type "',trim(typename), & + '" in TOML has inconsistent array lengths across parameters !' + call stop_sfincs(trim(logstr), 1) + endif + ! + do il = 1, nlayers + call get_value(ah_arr, il, rval, stat=stat) + tmp_ah(it, il) = real(rval, kind=4) + enddo + ! + ! --- vegetation_stems_diameter --- + ! + nullify(bstems_arr) + call get_value(type_table, 'vegetation_stems_diameter', bstems_arr, stat=stat) + ! + if (.not. associated(bstems_arr)) then + write(logstr,'(a,a,a)')'Error : vegetation type "',trim(typename), & + '" in TOML is missing vegetation_stems_diameter array !' + call stop_sfincs(trim(logstr), 1) + endif + ! + if (len(bstems_arr) /= nlayers) then + write(logstr,'(a,a,a)')'Error : vegetation type "',trim(typename), & + '" in TOML has inconsistent array lengths across parameters !' + call stop_sfincs(trim(logstr), 1) + endif + ! + do il = 1, nlayers + call get_value(bstems_arr, il, rval, stat=stat) + tmp_bstems(it, il) = real(rval, kind=4) + enddo + ! + ! --- vegetation_stems_density --- + ! + nullify(nstems_arr) + call get_value(type_table, 'vegetation_stems_density', nstems_arr, stat=stat) + ! + if (.not. associated(nstems_arr)) then + write(logstr,'(a,a,a)')'Error : vegetation type "',trim(typename), & + '" in TOML is missing vegetation_stems_density array !' + call stop_sfincs(trim(logstr), 1) + endif + ! + if (len(nstems_arr) /= nlayers) then + write(logstr,'(a,a,a)')'Error : vegetation type "',trim(typename), & + '" in TOML has inconsistent array lengths across parameters !' + call stop_sfincs(trim(logstr), 1) + endif + ! + do il = 1, nlayers + call get_value(nstems_arr, il, rval, stat=stat) + tmp_nstems(it, il) = real(rval, kind=4) + enddo + ! + write(logstr,'(a,a,a,i0,a)')'Info : vegetation type "',trim(typename), & + '" loaded with ',nlayers,' vertical layer(s)' + call write_log(logstr, 0) + ! + enddo + ! + max_layers = maxval(nlayers_per_type) + ! + if (max_layers == 0) then + call stop_sfincs('Error : no valid vegetation types found in TOML file !', 1) + endif + ! + allocate(veg_cd_lookup(nflags, max_layers)) + allocate(veg_ah_lookup(nflags, max_layers)) + allocate(veg_bstems_lookup(nflags, max_layers)) + allocate(veg_nstems_lookup(nflags, max_layers)) + ! + veg_cd_lookup = tmp_cd(:, 1:max_layers) + veg_ah_lookup = tmp_ah(:, 1:max_layers) + veg_bstems_lookup = tmp_bstems(:, 1:max_layers) + veg_nstems_lookup = tmp_nstems(:, 1:max_layers) + ! + deallocate(tmp_cd, tmp_ah, tmp_bstems, tmp_nstems, nlayers_per_type) + ! + end subroutine + + +end module diff --git a/source/src/sfincs_wavemaker.f90 b/source/src/sfincs_wavemaker.f90 index 27835340e..9aa83b0c7 100644 --- a/source/src/sfincs_wavemaker.f90 +++ b/source/src/sfincs_wavemaker.f90 @@ -51,7 +51,7 @@ subroutine initialize_wavemakers() real*4, dimension(:), allocatable :: wavemaker_xfp real*4, dimension(:), allocatable :: wavemaker_yfp ! - logical :: iok, ok + logical :: iok, ok, refinement_warning ! integer ib1, ib2, ib, ic, nmb, nrwvm ! @@ -759,6 +759,8 @@ subroutine initialize_wavemakers() write(logstr,*)'Setting wave makers ...' call write_log(logstr, 0) ! + refinement_warning = .false. ! set to true if we find a wavemaker point that has refinemed neighbor + ! do ip = 1, np ! if (kcs(ip)==4) then @@ -798,6 +800,8 @@ subroutine initialize_wavemakers() iz = uv_index_z_nmu(nmu) ! if (kcs(iz) == 1) then + ! + refinement_warning = .true. ! iwm = iwm + 1 ! @@ -807,6 +811,8 @@ subroutine initialize_wavemakers() wavemaker_idir(iwm) = 1 wavemaker_angfac(iwm) = max(cos(phi(ip) - 0.0), 0.0) ! + wavemaker_nmu(nok) = iwm + ! endif ! endif @@ -842,6 +848,8 @@ subroutine initialize_wavemakers() iz = uv_index_z_nmu(nmu) ! if (kcs(iz) == 1) then + ! + refinement_warning = .true. ! iwm = iwm + 1 ! @@ -851,6 +859,8 @@ subroutine initialize_wavemakers() wavemaker_idir(iwm) = 1 wavemaker_angfac(iwm) = max(sin(phi(ip) - 0.0), 0.0) ! + wavemaker_num(nok) = iwm + ! endif ! endif @@ -888,6 +898,8 @@ subroutine initialize_wavemakers() iz = uv_index_z_nm(nmu) ! if (kcs(iz) == 1) then + ! + refinement_warning = .true. ! iwm = iwm + 1 ! @@ -897,6 +909,8 @@ subroutine initialize_wavemakers() wavemaker_idir(iwm) = -1 wavemaker_angfac(iwm) = max(cos(pi - phi(ip)), 0.0) ! + wavemaker_nmd(nok) = iwm + ! endif ! endif @@ -932,6 +946,8 @@ subroutine initialize_wavemakers() iz = uv_index_z_nmu(nmu) ! if (kcs(iz) == 1) then + ! + refinement_warning = .true. ! iwm = iwm + 1 ! @@ -941,6 +957,8 @@ subroutine initialize_wavemakers() wavemaker_idir(iwm) = 1 wavemaker_angfac(iwm) = max(sin(phi(ip) - 0.0), 0.0) ! + wavemaker_num(nok) = iwm + ! endif ! endif @@ -978,6 +996,8 @@ subroutine initialize_wavemakers() iz = uv_index_z_nm(nmu) ! if (kcs(iz) == 1) then + ! + refinement_warning = .true. ! iwm = iwm + 1 ! @@ -987,6 +1007,8 @@ subroutine initialize_wavemakers() wavemaker_idir(iwm) = -1 wavemaker_angfac(iwm) = max(cos(pi - phi(ip)), 0.0) ! + wavemaker_nmd(nok) = iwm + ! endif ! endif @@ -1007,7 +1029,7 @@ subroutine initialize_wavemakers() wavemaker_index_nmi(iwm) = iz wavemaker_index_nmb(iwm) = ip wavemaker_idir(iwm) = -1 - wavemaker_angfac(iwm) = max(sin(pi - phi(ip)), 0.0) + wavemaker_angfac(iwm) = max(-sin(phi(ip)), 0.0) ! wavemaker_ndm(nok) = iwm ! @@ -1022,6 +1044,8 @@ subroutine initialize_wavemakers() iz = uv_index_z_nm(nmu) ! if (kcs(iz) == 1) then + ! + refinement_warning = .true. ! iwm = iwm + 1 ! @@ -1029,7 +1053,9 @@ subroutine initialize_wavemakers() wavemaker_index_nmi(iwm) = iz wavemaker_index_nmb(iwm) = ip wavemaker_idir(iwm) = -1 - wavemaker_angfac(iwm) = max(sin(pi - phi(ip)), 0.0) + wavemaker_angfac(iwm) = max(-sin(phi(ip)), 0.0) + ! + wavemaker_ndm(nok) = iwm ! endif ! @@ -1067,6 +1093,8 @@ subroutine initialize_wavemakers() iz = uv_index_z_nmu(nmu) ! if (kcs(iz) == 1) then + ! + refinement_warning = .true. ! iwm = iwm + 1 ! @@ -1076,6 +1104,8 @@ subroutine initialize_wavemakers() wavemaker_idir(iwm) = 1 wavemaker_angfac(iwm) = max(cos(phi(ip) - 0.0), 0.0) ! + wavemaker_nmu(nok) = iwm + ! endif ! endif @@ -1096,7 +1126,7 @@ subroutine initialize_wavemakers() wavemaker_index_nmi(iwm) = iz wavemaker_index_nmb(iwm) = ip wavemaker_idir(iwm) = -1 - wavemaker_angfac(iwm) = max(sin(pi - phi(ip)), 0.0) + wavemaker_angfac(iwm) = max(-sin(phi(ip)), 0.0) ! wavemaker_ndm(nok) = iwm ! @@ -1111,6 +1141,8 @@ subroutine initialize_wavemakers() iz = uv_index_z_nm(nmu) ! if (kcs(iz) == 1) then + ! + refinement_warning = .true. ! iwm = iwm + 1 ! @@ -1118,7 +1150,9 @@ subroutine initialize_wavemakers() wavemaker_index_nmi(iwm) = iz wavemaker_index_nmb(iwm) = ip wavemaker_idir(iwm) = -1 - wavemaker_angfac(iwm) = max(sin(pi - phi(ip)), 0.0) + wavemaker_angfac(iwm) = max(-sin(phi(ip)), 0.0) + ! + wavemaker_ndm(nok) = iwm ! endif ! @@ -1128,6 +1162,15 @@ subroutine initialize_wavemakers() endif enddo ! + ! Give warning if we found a wavemaker point that has refined neighbor + ! + if (refinement_warning) then + ! + write(logstr,'(a)')' WARNING! Found wavemaker point along quadtree refinement boundary, this is not recommended! The simulation will continue.' + call write_log(logstr, 1) + ! + endif + ! ! Set flags for kcuv points ! do iwm = 1, wavemaker_nr_uv_points @@ -1440,10 +1483,6 @@ subroutine update_wavemaker_fluxes(t, dt, tloop) tp_inc = 10.0 ! Later make it possible to also specify Tp_inc in time series forcing, but for now just add a fixed value (that is not used) ! else - ! - ! Use mean peak period from SnapWave boundary conditions - ! - tp_ig = snapwave_tpigmean ! TL: Now calculated in SnapWave, different options for using a period based on Herbers spectrum (snapwave_tpig_opt, if snapwave_use_herbers=1, or user defined snapwave_Tinc2ig ratio (if snapwave_use_herbers = 0) ! ! We may want to use Herbers for computation of IG waves in SnapWave, but we want to have control over peak IG period at wave makers. ! @@ -1468,13 +1507,28 @@ subroutine update_wavemaker_fluxes(t, dt, tloop) ! ! ! tp_ig = snapwave_tpmean * max(1.86 * betas**-0.43 * wave_steepness**0.07, 5.0) ! ! + else + ! + ! Use mean peak period from SnapWave boundary conditions + ! + tp_ig = snapwave_tpigmean ! TL: Now calculated in SnapWave, different options for using a period based on Herbers spectrum (snapwave_tpig_opt, if snapwave_use_herbers=1, or user defined snapwave_Tinc2ig ratio (if snapwave_use_herbers = 0) + ! + if (tp_ig < 10.0) then + ! These warnings should not occur here + write(logstr,*)'DEBUG SFINCS_SnapWave - incoming tp for IG wave at wavemaker might be unrealistically small! value: ',tp_ig + call write_log(logstr, 0) + elseif (tp_ig > 250.0) then + write(logstr,*)'DEBUG SFINCS_SnapWave - incoming tp for IG wave at wavemaker might be unrealistically large! value: ',tp_ig + call write_log(logstr, 0) + endif + ! endif ! tp_inc = max(snapwave_tpmean, wavemaker_tpmin) ! tp_ig = max(tp_ig, wavemaker_tpmin) ! - endif + endif ! ! Now determine zwav_ig and zwav_inc based on spectrum or monochromatic signal. ! Time series of zwav_ig and zwav_inc will be used to modulate water level at wave maker points. @@ -1564,7 +1618,7 @@ subroutine update_wavemaker_fluxes(t, dt, tloop) ! endif ! - ! UV fluxes at wave makers - No OMP acceleration here? + ! UV fluxes at wave makers ! ! Push time-interpolated forcing values to GPU before parallel region ! @@ -1622,6 +1676,11 @@ subroutine update_wavemaker_fluxes(t, dt, tloop) ! zsnmb = zs0nmb + min(zinc + zig, wavemaker_gammax * dwvm) ! total water level in wave maker (i.e. mean water level plus wave) ! + if (( zinc + zig) > wavemaker_gammax * dwvm) then + write(*,*)'WARNING! Incident wave height at wave maker exceeds maximum allowed value based on local water depth! Value: ', zinc + zig, ' Max allowed: ', wavemaker_gammax * dwvm + endif + + ! endif ! if (subgrid) then diff --git a/source/src/snapwave/snapwave_RFtable.f90 b/source/src/snapwave/snapwave_RFtable.f90 new file mode 100644 index 000000000..7ae97eea4 --- /dev/null +++ b/source/src/snapwave/snapwave_RFtable.f90 @@ -0,0 +1,3990 @@ +module snapwave_RFtable + + implicit none + + contains + + subroutine load_RFtable(RFveg) + + implicit none + ! + real*4, dimension(:,:,:), allocatable, intent(out) :: RFveg + real*8, dimension(:), allocatable :: RFvegtmp + ! + allocate(RFveg(11,18,20)) + ! + ! load Ad's RF-table (update for depth averaged velocities?) - XBeach: + !include 'RFveg.inc' + ! + ! Instead, include as hardcoded table that does not need to be compiled anymore: + RFvegtmp = (/ & + 22.47180000000000 , & + 0.22370000000000 , & + -0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 6.26960000000000 , & + 0.40090000000000 , & + -0.00030000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 6.13660000000000 , & + 0.40960000000000 , & + -0.00110000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 5.93530000000000 , & + 0.42340000000000 , & + -0.00240000000000 , & + 0.00060000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 5.67800000000000 , & + 0.44260000000000 , & + -0.00420000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.82390000000000 , & + 0.59330000000000 , & + -0.00020000000000 , & + 0.00300000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.81430000000000 , & + 0.59540000000000 , & + -0.00080000000000 , & + 0.00600000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.79860000000000 , & + 0.59870000000000 , & + -0.00170000000000 , & + 0.00910000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.77700000000000 , & + 0.60340000000000 , & + -0.00300000000000 , & + 0.01230000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.74970000000000 , & + 0.60930000000000 , & + -0.00460000000000 , & + 0.01560000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.71710000000000 , & + 0.61660000000000 , & + -0.00660000000000 , & + 0.01910000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.67920000000000 , & + 0.62540000000000 , & + -0.00890000000000 , & + 0.02270000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.63520000000000 , & + 0.63580000000000 , & + -0.01150000000000 , & + 0.02650000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 2.58340000000000 , & + 0.64860000000000 , & + -0.01440000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.03050000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.68990000000000 , & + 0.74360000000000 , & + -0.00020000000000 , & + 0.00720000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.68850000000000 , & + 0.74420000000000 , & + -0.00060000000000 , & + 0.01440000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.68610000000000 , & + 0.74530000000000 , & + -0.00140000000000 , & + 0.02160000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.68270000000000 , & + 0.74680000000000 , & + -0.00240000000000 , & + 0.02880000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.67830000000000 , & + 0.74870000000000 , & + -0.00380000000000 , & + 0.03600000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.67290000000000 , & + 0.75120000000000 , & + -0.00540000000000 , & + 0.04320000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.66640000000000 , & + 0.75410000000000 , & + -0.00730000000000 , & + 0.05030000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.65870000000000 , & + 0.75760000000000 , & + -0.00960000000000 , & + 0.05740000000000 , & + 0.00070000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.64960000000000 , & + 0.76180000000000 , & + -0.01210000000000 , & + 0.06450000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.63910000000000 , & + 0.76660000000000 , & + -0.01480000000000 , & + 0.07160000000000 , & + 0.00120000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.62690000000000 , & + 0.77240000000000 , & + -0.01790000000000 , & + 0.07850000000000 , & + 0.00160000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.61250000000000 , & + 0.77930000000000 , & + -0.02110000000000 , & + 0.08530000000000 , & + 0.00210000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.59500000000000 , & + 0.78780000000000 , & + -0.02460000000000 , & + 0.09180000000000 , & + 0.00270000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.09180000000000 , & + 0.00270000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.09180000000000 , & + 0.00270000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.09180000000000 , & + 0.00270000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.09180000000000 , & + 0.00270000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.09180000000000 , & + 0.00270000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.20840000000000 , & + 0.83200000000000 , & + -0.00010000000000 , & + 0.00990000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.20780000000000 , & + 0.83230000000000 , & + -0.00050000000000 , & + 0.01980000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.20690000000000 , & + 0.83300000000000 , & + -0.00120000000000 , & + 0.02960000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.20560000000000 , & + 0.83380000000000 , & + -0.00220000000000 , & + 0.03940000000000 , & + 0.00060000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.20390000000000 , & + 0.83500000000000 , & + -0.00340000000000 , & + 0.04910000000000 , & + 0.00100000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.20180000000000 , & + 0.83650000000000 , & + -0.00490000000000 , & + 0.05880000000000 , & + 0.00140000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.19930000000000 , & + 0.83830000000000 , & + -0.00660000000000 , & + 0.06830000000000 , & + 0.00200000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.19620000000000 , & + 0.84040000000000 , & + -0.00860000000000 , & + 0.07780000000000 , & + 0.00260000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.19260000000000 , & + 0.84290000000000 , & + -0.01090000000000 , & + 0.08700000000000 , & + 0.00330000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.18840000000000 , & + 0.84590000000000 , & + -0.01340000000000 , & + 0.09620000000000 , & + 0.00420000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.18360000000000 , & + 0.84940000000000 , & + -0.01620000000000 , & + 0.10510000000000 , & + 0.00520000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.17790000000000 , & + 0.85350000000000 , & + -0.01920000000000 , & + 0.11370000000000 , & + 0.00640000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.17120000000000 , & + 0.85840000000000 , & + -0.02240000000000 , & + 0.12210000000000 , & + 0.00770000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.16330000000000 , & + 0.86420000000000 , & + -0.02590000000000 , & + 0.13000000000000 , & + 0.00920000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.15370000000000 , & + 0.87140000000000 , & + -0.02960000000000 , & + 0.13740000000000 , & + 0.01100000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 1.14090000000000 , & + 0.88110000000000 , & + -0.03350000000000 , & + 0.14380000000000 , & + 0.01320000000000 , & + 0.00070000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.14380000000000 , & + 0.01320000000000 , & + 0.00070000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.14380000000000 , & + 0.01320000000000 , & + 0.00070000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.94900000000000 , & + 0.88270000000000 , & + -0.00010000000000 , & + 0.01140000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.94860000000000 , & + 0.88310000000000 , & + -0.00050000000000 , & + 0.02280000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.94790000000000 , & + 0.88380000000000 , & + -0.00110000000000 , & + 0.03420000000000 , & + 0.00080000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.94690000000000 , & + 0.88480000000000 , & + -0.00200000000000 , & + 0.04550000000000 , & + 0.00150000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.94550000000000 , & + 0.88600000000000 , & + -0.00320000000000 , & + 0.05670000000000 , & + 0.00230000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.94390000000000 , & + 0.88750000000000 , & + -0.00460000000000 , & + 0.06770000000000 , & + 0.00330000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.94190000000000 , & + 0.88940000000000 , & + -0.00620000000000 , & + 0.07860000000000 , & + 0.00450000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.93960000000000 , & + 0.89160000000000 , & + -0.00810000000000 , & + 0.08920000000000 , & + 0.00590000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.93690000000000 , & + 0.89410000000000 , & + -0.01020000000000 , & + 0.09970000000000 , & + 0.00750000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.93380000000000 , & + 0.89710000000000 , & + -0.01260000000000 , & + 0.10990000000000 , & + 0.00930000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.93030000000000 , & + 0.90050000000000 , & + -0.01520000000000 , & + 0.11980000000000 , & + 0.01130000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.92630000000000 , & + 0.90450000000000 , & + -0.01810000000000 , & + 0.12930000000000 , & + 0.01350000000000 , & + 0.00070000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.92160000000000 , & + 0.90900000000000 , & + -0.02120000000000 , & + 0.13850000000000 , & + 0.01590000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.91630000000000 , & + 0.91430000000000 , & + -0.02450000000000 , & + 0.14710000000000 , & + 0.01850000000000 , & + 0.00120000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.91010000000000 , & + 0.92050000000000 , & + -0.02800000000000 , & + 0.15520000000000 , & + 0.02140000000000 , & + 0.00160000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.90260000000000 , & + 0.92810000000000 , & + -0.03170000000000 , & + 0.16240000000000 , & + 0.02470000000000 , & + 0.00210000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.16240000000000 , & + 0.02470000000000 , & + 0.00210000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.16240000000000 , & + 0.02470000000000 , & + 0.00210000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.78580000000000 , & + 0.91390000000000 , & + -0.00010000000000 , & + 0.01240000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.78530000000000 , & + 0.91440000000000 , & + -0.00050000000000 , & + 0.02470000000000 , & + 0.00070000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.78450000000000 , & + 0.91530000000000 , & + -0.00110000000000 , & + 0.03700000000000 , & + 0.00150000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.78350000000000 , & + 0.91650000000000 , & + -0.00200000000000 , & + 0.04910000000000 , & + 0.00260000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.78210000000000 , & + 0.91810000000000 , & + -0.00310000000000 , & + 0.06110000000000 , & + 0.00410000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.78040000000000 , & + 0.92010000000000 , & + -0.00440000000000 , & + 0.07290000000000 , & + 0.00590000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.77840000000000 , & + 0.92250000000000 , & + -0.00600000000000 , & + 0.08440000000000 , & + 0.00790000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.77610000000000 , & + 0.92520000000000 , & + -0.00780000000000 , & + 0.09570000000000 , & + 0.01030000000000 , & + 0.00060000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.77350000000000 , & + 0.92840000000000 , & + -0.00990000000000 , & + 0.10660000000000 , & + 0.01290000000000 , & + 0.00080000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.77050000000000 , & + 0.93190000000000 , & + -0.01220000000000 , & + 0.11720000000000 , & + 0.01580000000000 , & + 0.00120000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.76720000000000 , & + 0.93600000000000 , & + -0.01470000000000 , & + 0.12740000000000 , & + 0.01900000000000 , & + 0.00160000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.76350000000000 , & + 0.94060000000000 , & + -0.01740000000000 , & + 0.13720000000000 , & + 0.02230000000000 , & + 0.00200000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.75930000000000 , & + 0.94570000000000 , & + -0.02040000000000 , & + 0.14640000000000 , & + 0.02600000000000 , & + 0.00260000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.75460000000000 , & + 0.95160000000000 , & + -0.02360000000000 , & + 0.15510000000000 , & + 0.02980000000000 , & + 0.00340000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.74930000000000 , & + 0.95830000000000 , & + -0.02700000000000 , & + 0.16310000000000 , & + 0.03390000000000 , & + 0.00430000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.74320000000000 , & + 0.96620000000000 , & + -0.03050000000000 , & + 0.17020000000000 , & + 0.03820000000000 , & + 0.00540000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.73570000000000 , & + 0.97600000000000 , & + -0.03430000000000 , & + 0.17600000000000 , & + 0.04280000000000 , & + 0.00680000000000 , & + 0.00080000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.17600000000000 , & + 0.04280000000000 , & + 0.00680000000000 , & + 0.00080000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.67260000000000 , & + 0.93420000000000 , & + -0.00010000000000 , & + 0.01300000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.67210000000000 , & + 0.93490000000000 , & + -0.00050000000000 , & + 0.02590000000000 , & + 0.00100000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.67120000000000 , & + 0.93610000000000 , & + -0.00110000000000 , & + 0.03870000000000 , & + 0.00230000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.67000000000000 , & + 0.93780000000000 , & + -0.00190000000000 , & + 0.05140000000000 , & + 0.00410000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.66850000000000 , & + 0.93990000000000 , & + -0.00300000000000 , & + 0.06380000000000 , & + 0.00630000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.66660000000000 , & + 0.94250000000000 , & + -0.00430000000000 , & + 0.07590000000000 , & + 0.00890000000000 , & + 0.00060000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.66450000000000 , & + 0.94560000000000 , & + -0.00590000000000 , & + 0.08770000000000 , & + 0.01190000000000 , & + 0.00100000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.66200000000000 , & + 0.94910000000000 , & + -0.00760000000000 , & + 0.09910000000000 , & + 0.01530000000000 , & + 0.00140000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.65930000000000 , & + 0.95310000000000 , & + -0.00960000000000 , & + 0.11010000000000 , & + 0.01910000000000 , & + 0.00200000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.65620000000000 , & + 0.95750000000000 , & + -0.01190000000000 , & + 0.12070000000000 , & + 0.02310000000000 , & + 0.00270000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.65280000000000 , & + 0.96250000000000 , & + -0.01430000000000 , & + 0.13080000000000 , & + 0.02740000000000 , & + 0.00350000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.64910000000000 , & + 0.96800000000000 , & + -0.01700000000000 , & + 0.14030000000000 , & + 0.03190000000000 , & + 0.00450000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.64510000000000 , & + 0.97410000000000 , & + -0.01990000000000 , & + 0.14930000000000 , & + 0.03660000000000 , & + 0.00570000000000 , & + 0.00060000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.64060000000000 , & + 0.98090000000000 , & + -0.02300000000000 , & + 0.15760000000000 , & + 0.04150000000000 , & + 0.00700000000000 , & + 0.00080000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.63560000000000 , & + 0.98850000000000 , & + -0.02620000000000 , & + 0.16510000000000 , & + 0.04660000000000 , & + 0.00860000000000 , & + 0.00110000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.63000000000000 , & + 0.99740000000000 , & + -0.02970000000000 , & + 0.17160000000000 , & + 0.05180000000000 , & + 0.01050000000000 , & + 0.00160000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.62330000000000 , & + 1.00810000000000 , & + -0.03340000000000 , & + 0.17670000000000 , & + 0.05710000000000 , & + 0.01270000000000 , & + 0.00220000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.17670000000000 , & + 0.05710000000000 , & + 0.01270000000000 , & + 0.00220000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.58910000000000 , & + 0.94810000000000 , & + -0.00010000000000 , & + 0.01340000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.58850000000000 , & + 0.94910000000000 , & + -0.00050000000000 , & + 0.02670000000000 , & + 0.00150000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.58750000000000 , & + 0.95070000000000 , & + -0.00110000000000 , & + 0.03990000000000 , & + 0.00320000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.58610000000000 , & + 0.95290000000000 , & + -0.00190000000000 , & + 0.05280000000000 , & + 0.00570000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.58440000000000 , & + 0.95560000000000 , & + -0.00300000000000 , & + 0.06540000000000 , & + 0.00870000000000 , & + 0.00070000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.58240000000000 , & + 0.95900000000000 , & + -0.00420000000000 , & + 0.07760000000000 , & + 0.01230000000000 , & + 0.00120000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.58010000000000 , & + 0.96280000000000 , & + -0.00580000000000 , & + 0.08940000000000 , & + 0.01630000000000 , & + 0.00190000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.57740000000000 , & + 0.96720000000000 , & + -0.00750000000000 , & + 0.10070000000000 , & + 0.02070000000000 , & + 0.00270000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.57450000000000 , & + 0.97210000000000 , & + -0.00950000000000 , & + 0.11150000000000 , & + 0.02550000000000 , & + 0.00380000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.57130000000000 , & + 0.97760000000000 , & + -0.01170000000000 , & + 0.12180000000000 , & + 0.03060000000000 , & + 0.00500000000000 , & + 0.00060000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.56790000000000 , & + 0.98350000000000 , & + -0.01410000000000 , & + 0.13150000000000 , & + 0.03580000000000 , & + 0.00640000000000 , & + 0.00080000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.56410000000000 , & + 0.99010000000000 , & + -0.01670000000000 , & + 0.14050000000000 , & + 0.04130000000000 , & + 0.00810000000000 , & + 0.00110000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.56010000000000 , & + 0.99720000000000 , & + -0.01950000000000 , & + 0.14900000000000 , & + 0.04690000000000 , & + 0.01000000000000 , & + 0.00160000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.55570000000000 , & + 1.00510000000000 , & + -0.02250000000000 , & + 0.15660000000000 , & + 0.05260000000000 , & + 0.01210000000000 , & + 0.00210000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.55090000000000 , & + 1.01390000000000 , & + -0.02570000000000 , & + 0.16350000000000 , & + 0.05830000000000 , & + 0.01440000000000 , & + 0.00270000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.54550000000000 , & + 1.02390000000000 , & + -0.02910000000000 , & + 0.16920000000000 , & + 0.06400000000000 , & + 0.01710000000000 , & + 0.00360000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.16920000000000 , & + 0.06400000000000 , & + 0.01710000000000 , & + 0.00360000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.16920000000000 , & + 0.06400000000000 , & + 0.01710000000000 , & + 0.00360000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.52460000000000 , & + 0.95820000000000 , & + -0.00010000000000 , & + 0.01370000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.52390000000000 , & + 0.95940000000000 , & + -0.00050000000000 , & + 0.02730000000000 , & + 0.00190000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.52280000000000 , & + 0.96140000000000 , & + -0.00110000000000 , & + 0.04060000000000 , & + 0.00430000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.52130000000000 , & + 0.96410000000000 , & + -0.00190000000000 , & + 0.05360000000000 , & + 0.00740000000000 , & + 0.00070000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.51950000000000 , & + 0.96760000000000 , & + -0.00290000000000 , & + 0.06620000000000 , & + 0.01130000000000 , & + 0.00130000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.51730000000000 , & + 0.97170000000000 , & + -0.00420000000000 , & + 0.07830000000000 , & + 0.01580000000000 , & + 0.00210000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.51480000000000 , & + 0.97650000000000 , & + -0.00570000000000 , & + 0.08990000000000 , & + 0.02080000000000 , & + 0.00320000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.51200000000000 , & + 0.98180000000000 , & + -0.00740000000000 , & + 0.10090000000000 , & + 0.02620000000000 , & + 0.00460000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.50890000000000 , & + 0.98770000000000 , & + -0.00940000000000 , & + 0.11130000000000 , & + 0.03180000000000 , & + 0.00620000000000 , & + 0.00090000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.50560000000000 , & + 0.99410000000000 , & + -0.01150000000000 , & + 0.12120000000000 , & + 0.03770000000000 , & + 0.00810000000000 , & + 0.00130000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.50210000000000 , & + 1.00110000000000 , & + -0.01390000000000 , & + 0.13030000000000 , & + 0.04380000000000 , & + 0.01020000000000 , & + 0.00180000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.49830000000000 , & + 1.00870000000000 , & + -0.01640000000000 , & + 0.13880000000000 , & + 0.04990000000000 , & + 0.01260000000000 , & + 0.00240000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.49430000000000 , & + 1.01690000000000 , & + -0.01920000000000 , & + 0.14660000000000 , & + 0.05610000000000 , & + 0.01520000000000 , & + 0.00320000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.49000000000000 , & + 1.02590000000000 , & + -0.02210000000000 , & + 0.15360000000000 , & + 0.06230000000000 , & + 0.01810000000000 , & + 0.00410000000000 , & + 0.00070000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.48530000000000 , & + 1.03590000000000 , & + -0.02530000000000 , & + 0.15970000000000 , & + 0.06830000000000 , & + 0.02120000000000 , & + 0.00520000000000 , & + 0.00110000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.48000000000000 , & + 1.04720000000000 , & + -0.02860000000000 , & + 0.16460000000000 , & + 0.07420000000000 , & + 0.02460000000000 , & + 0.00660000000000 , & + 0.00150000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.16460000000000 , & + 0.07420000000000 , & + 0.02460000000000 , & + 0.00660000000000 , & + 0.00150000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.16460000000000 , & + 0.07420000000000 , & + 0.02460000000000 , & + 0.00660000000000 , & + 0.00150000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.47320000000000 , & + 0.96560000000000 , & + -0.00010000000000 , & + 0.01390000000000 , & + 0.00060000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.47250000000000 , & + 0.96710000000000 , & + -0.00050000000000 , & + 0.02770000000000 , & + 0.00250000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.47130000000000 , & + 0.96960000000000 , & + -0.00100000000000 , & + 0.04110000000000 , & + 0.00540000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.46960000000000 , & + 0.97300000000000 , & + -0.00190000000000 , & + 0.05410000000000 , & + 0.00930000000000 , & + 0.00110000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.46760000000000 , & + 0.97720000000000 , & + -0.00290000000000 , & + 0.06650000000000 , & + 0.01400000000000 , & + 0.00200000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.46530000000000 , & + 0.98210000000000 , & + -0.00420000000000 , & + 0.07840000000000 , & + 0.01940000000000 , & + 0.00330000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.46260000000000 , & + 0.98770000000000 , & + -0.00560000000000 , & + 0.08960000000000 , & + 0.02520000000000 , & + 0.00490000000000 , & + 0.00070000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.45970000000000 , & + 0.99400000000000 , & + -0.00730000000000 , & + 0.10020000000000 , & + 0.03140000000000 , & + 0.00690000000000 , & + 0.00120000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.45660000000000 , & + 1.00080000000000 , & + -0.00930000000000 , & + 0.11020000000000 , & + 0.03780000000000 , & + 0.00910000000000 , & + 0.00170000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.45320000000000 , & + 1.00830000000000 , & + -0.01140000000000 , & + 0.11940000000000 , & + 0.04430000000000 , & + 0.01170000000000 , & + 0.00240000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.44960000000000 , & + 1.01630000000000 , & + -0.01370000000000 , & + 0.12800000000000 , & + 0.05090000000000 , & + 0.01450000000000 , & + 0.00330000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.44590000000000 , & + 1.02490000000000 , & + -0.01620000000000 , & + 0.13590000000000 , & + 0.05750000000000 , & + 0.01760000000000 , & + 0.00430000000000 , & + 0.00090000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.44190000000000 , & + 1.03420000000000 , & + -0.01890000000000 , & + 0.14300000000000 , & + 0.06390000000000 , & + 0.02100000000000 , & + 0.00560000000000 , & + 0.00120000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.43760000000000 , & + 1.04430000000000 , & + -0.02180000000000 , & + 0.14930000000000 , & + 0.07020000000000 , & + 0.02460000000000 , & + 0.00700000000000 , & + 0.00170000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.43300000000000 , & + 1.05540000000000 , & + -0.02490000000000 , & + 0.15460000000000 , & + 0.07630000000000 , & + 0.02830000000000 , & + 0.00870000000000 , & + 0.00220000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.42780000000000 , & + 1.06820000000000 , & + -0.02820000000000 , & + 0.15860000000000 , & + 0.08200000000000 , & + 0.03240000000000 , & + 0.01070000000000 , & + 0.00300000000000 , & + 0.00070000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.15860000000000 , & + 0.08200000000000 , & + 0.03240000000000 , & + 0.01070000000000 , & + 0.00300000000000 , & + 0.00070000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.15860000000000 , & + 0.08200000000000 , & + 0.03240000000000 , & + 0.01070000000000 , & + 0.00300000000000 , & + 0.00070000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.43130000000000 , & + 0.97130000000000 , & + -0.00010000000000 , & + 0.01410000000000 , & + 0.00080000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.43040000000000 , & + 0.97320000000000 , & + -0.00050000000000 , & + 0.02790000000000 , & + 0.00300000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.42910000000000 , & + 0.97610000000000 , & + -0.00100000000000 , & + 0.04140000000000 , & + 0.00660000000000 , & + 0.00070000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.42740000000000 , & + 0.98020000000000 , & + -0.00180000000000 , & + 0.05420000000000 , & + 0.01130000000000 , & + 0.00160000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.42520000000000 , & + 0.98510000000000 , & + -0.00290000000000 , & + 0.06650000000000 , & + 0.01680000000000 , & + 0.00300000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.42270000000000 , & + 0.99090000000000 , & + -0.00410000000000 , & + 0.07800000000000 , & + 0.02290000000000 , & + 0.00470000000000 , & + 0.00080000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.42000000000000 , & + 0.99740000000000 , & + -0.00560000000000 , & + 0.08880000000000 , & + 0.02940000000000 , & + 0.00700000000000 , & + 0.00130000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.41700000000000 , & + 1.00450000000000 , & + -0.00730000000000 , & + 0.09890000000000 , & + 0.03620000000000 , & + 0.00950000000000 , & + 0.00200000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.41380000000000 , & + 1.01230000000000 , & + -0.00920000000000 , & + 0.10830000000000 , & + 0.04310000000000 , & + 0.01250000000000 , & + 0.00290000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.41040000000000 , & + 1.02070000000000 , & + -0.01130000000000 , & + 0.11700000000000 , & + 0.05010000000000 , & + 0.01570000000000 , & + 0.00400000000000 , & + 0.00090000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.40680000000000 , & + 1.02970000000000 , & + -0.01360000000000 , & + 0.12500000000000 , & + 0.05700000000000 , & + 0.01930000000000 , & + 0.00530000000000 , & + 0.00120000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.40300000000000 , & + 1.03930000000000 , & + -0.01600000000000 , & + 0.13230000000000 , & + 0.06370000000000 , & + 0.02300000000000 , & + 0.00680000000000 , & + 0.00170000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.39910000000000 , & + 1.04970000000000 , & + -0.01870000000000 , & + 0.13880000000000 , & + 0.07020000000000 , & + 0.02700000000000 , & + 0.00860000000000 , & + 0.00230000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.39480000000000 , & + 1.06090000000000 , & + -0.02160000000000 , & + 0.14440000000000 , & + 0.07650000000000 , & + 0.03110000000000 , & + 0.01050000000000 , & + 0.00310000000000 , & + 0.00080000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.39030000000000 , & + 1.07320000000000 , & + -0.02460000000000 , & + 0.14890000000000 , & + 0.08240000000000 , & + 0.03540000000000 , & + 0.01280000000000 , & + 0.00400000000000 , & + 0.00110000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.14890000000000 , & + 0.08240000000000 , & + 0.03540000000000 , & + 0.01280000000000 , & + 0.00400000000000 , & + 0.00110000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.14890000000000 , & + 0.08240000000000 , & + 0.03540000000000 , & + 0.01280000000000 , & + 0.00400000000000 , & + 0.00110000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.14890000000000 , & + 0.08240000000000 , & + 0.03540000000000 , & + 0.01280000000000 , & + 0.00400000000000 , & + 0.00110000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.39630000000000 , & + 0.97580000000000 , & + -0.00010000000000 , & + 0.01420000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.39540000000000 , & + 0.97800000000000 , & + -0.00050000000000 , & + 0.02810000000000 , & + 0.00360000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.39400000000000 , & + 0.98150000000000 , & + -0.00100000000000 , & + 0.04150000000000 , & + 0.00780000000000 , & + 0.00100000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.39210000000000 , & + 0.98620000000000 , & + -0.00180000000000 , & + 0.05410000000000 , & + 0.01320000000000 , & + 0.00230000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.38980000000000 , & + 0.99190000000000 , & + -0.00290000000000 , & + 0.06600000000000 , & + 0.01950000000000 , & + 0.00410000000000 , & + 0.00070000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.38720000000000 , & + 0.99850000000000 , & + -0.00410000000000 , & + 0.07720000000000 , & + 0.02620000000000 , & + 0.00640000000000 , & + 0.00130000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.38440000000000 , & + 1.00580000000000 , & + -0.00560000000000 , & + 0.08750000000000 , & + 0.03330000000000 , & + 0.00930000000000 , & + 0.00210000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.38140000000000 , & + 1.01390000000000 , & + -0.00720000000000 , & + 0.09710000000000 , & + 0.04050000000000 , & + 0.01250000000000 , & + 0.00320000000000 , & + 0.00070000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.37810000000000 , & + 1.02260000000000 , & + -0.00910000000000 , & + 0.10600000000000 , & + 0.04780000000000 , & + 0.01610000000000 , & + 0.00450000000000 , & + 0.00110000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.37470000000000 , & + 1.03190000000000 , & + -0.01120000000000 , & + 0.11410000000000 , & + 0.05490000000000 , & + 0.02000000000000 , & + 0.00600000000000 , & + 0.00150000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.37110000000000 , & + 1.04180000000000 , & + -0.01340000000000 , & + 0.12160000000000 , & + 0.06190000000000 , & + 0.02410000000000 , & + 0.00780000000000 , & + 0.00220000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.36740000000000 , & + 1.05240000000000 , & + -0.01590000000000 , & + 0.12820000000000 , & + 0.06870000000000 , & + 0.02840000000000 , & + 0.00980000000000 , & + 0.00290000000000 , & + 0.00080000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.36350000000000 , & + 1.06380000000000 , & + -0.01850000000000 , & + 0.13410000000000 , & + 0.07510000000000 , & + 0.03280000000000 , & + 0.01210000000000 , & + 0.00390000000000 , & + 0.00110000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.35930000000000 , & + 1.07610000000000 , & + -0.02130000000000 , & + 0.13910000000000 , & + 0.08110000000000 , & + 0.03730000000000 , & + 0.01460000000000 , & + 0.00500000000000 , & + 0.00150000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.35480000000000 , & + 1.08970000000000 , & + -0.02430000000000 , & + 0.14290000000000 , & + 0.08660000000000 , & + 0.04190000000000 , & + 0.01740000000000 , & + 0.00640000000000 , & + 0.00210000000000 , & + 0.00060000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.14290000000000 , & + 0.08660000000000 , & + 0.04190000000000 , & + 0.01740000000000 , & + 0.00640000000000 , & + 0.00210000000000 , & + 0.00060000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.14290000000000 , & + 0.08660000000000 , & + 0.04190000000000 , & + 0.01740000000000 , & + 0.00640000000000 , & + 0.00210000000000 , & + 0.00060000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.14290000000000 , & + 0.08660000000000 , & + 0.04190000000000 , & + 0.01740000000000 , & + 0.00640000000000 , & + 0.00210000000000 , & + 0.00060000000000 , & + 0.00020000000000 , & + 0.36660000000000 , & + 0.97940000000000 , & + -0.00010000000000 , & + 0.01430000000000 , & + 0.00110000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.36570000000000 , & + 0.98190000000000 , & + -0.00050000000000 , & + 0.02820000000000 , & + 0.00430000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.36410000000000 , & + 0.98600000000000 , & + -0.00100000000000 , & + 0.04140000000000 , & + 0.00910000000000 , & + 0.00140000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.36220000000000 , & + 0.99140000000000 , & + -0.00180000000000 , & + 0.05380000000000 , & + 0.01520000000000 , & + 0.00310000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.35980000000000 , & + 0.99780000000000 , & + -0.00280000000000 , & + 0.06540000000000 , & + 0.02200000000000 , & + 0.00540000000000 , & + 0.00110000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.35720000000000 , & + 1.00520000000000 , & + -0.00410000000000 , & + 0.07610000000000 , & + 0.02930000000000 , & + 0.00830000000000 , & + 0.00200000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.35430000000000 , & + 1.01340000000000 , & + -0.00550000000000 , & + 0.08600000000000 , & + 0.03680000000000 , & + 0.01180000000000 , & + 0.00310000000000 , & + 0.00070000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.35120000000000 , & + 1.02230000000000 , & + -0.00720000000000 , & + 0.09510000000000 , & + 0.04430000000000 , & + 0.01560000000000 , & + 0.00460000000000 , & + 0.00120000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.34790000000000 , & + 1.03190000000000 , & + -0.00900000000000 , & + 0.10340000000000 , & + 0.05170000000000 , & + 0.01980000000000 , & + 0.00630000000000 , & + 0.00180000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.34450000000000 , & + 1.04210000000000 , & + -0.01110000000000 , & + 0.11100000000000 , & + 0.05890000000000 , & + 0.02420000000000 , & + 0.00840000000000 , & + 0.00250000000000 , & + 0.00070000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.34100000000000 , & + 1.05290000000000 , & + -0.01330000000000 , & + 0.11790000000000 , & + 0.06580000000000 , & + 0.02880000000000 , & + 0.01060000000000 , & + 0.00340000000000 , & + 0.00100000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.33730000000000 , & + 1.06440000000000 , & + -0.01580000000000 , & + 0.12400000000000 , & + 0.07240000000000 , & + 0.03350000000000 , & + 0.01310000000000 , & + 0.00450000000000 , & + 0.00140000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.33340000000000 , & + 1.07680000000000 , & + -0.01840000000000 , & + 0.12930000000000 , & + 0.07860000000000 , & + 0.03820000000000 , & + 0.01590000000000 , & + 0.00590000000000 , & + 0.00190000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.32930000000000 , & + 1.09020000000000 , & + -0.02110000000000 , & + 0.13370000000000 , & + 0.08430000000000 , & + 0.04300000000000 , & + 0.01890000000000 , & + 0.00740000000000 , & + 0.00260000000000 , & + 0.00080000000000 , & + 0.00020000000000 , & + 0.32490000000000 , & + 1.10510000000000 , & + -0.02410000000000 , & + 0.13680000000000 , & + 0.08930000000000 , & + 0.04770000000000 , & + 0.02220000000000 , & + 0.00920000000000 , & + 0.00350000000000 , & + 0.00120000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.13680000000000 , & + 0.08930000000000 , & + 0.04770000000000 , & + 0.02220000000000 , & + 0.00920000000000 , & + 0.00350000000000 , & + 0.00120000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.13680000000000 , & + 0.08930000000000 , & + 0.04770000000000 , & + 0.02220000000000 , & + 0.00920000000000 , & + 0.00350000000000 , & + 0.00120000000000 , & + 0.00040000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.13680000000000 , & + 0.08930000000000 , & + 0.04770000000000 , & + 0.02220000000000 , & + 0.00920000000000 , & + 0.00350000000000 , & + 0.00120000000000 , & + 0.00040000000000 , & + 0.34120000000000 , & + 0.98230000000000 , & + -0.00010000000000 , & + 0.01430000000000 , & + 0.00130000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.34010000000000 , & + 0.98520000000000 , & + -0.00050000000000 , & + 0.02820000000000 , & + 0.00490000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.33850000000000 , & + 0.98990000000000 , & + -0.00100000000000 , & + 0.04130000000000 , & + 0.01040000000000 , & + 0.00190000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.33650000000000 , & + 0.99590000000000 , & + -0.00180000000000 , & + 0.05340000000000 , & + 0.01710000000000 , & + 0.00400000000000 , & + 0.00080000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.33410000000000 , & + 1.00310000000000 , & + -0.00280000000000 , & + 0.06460000000000 , & + 0.02440000000000 , & + 0.00680000000000 , & + 0.00160000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.33140000000000 , & + 1.01130000000000 , & + -0.00410000000000 , & + 0.07480000000000 , & + 0.03210000000000 , & + 0.01030000000000 , & + 0.00280000000000 , & + 0.00070000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.32840000000000 , & + 1.02030000000000 , & + -0.00550000000000 , & + 0.08420000000000 , & + 0.03980000000000 , & + 0.01430000000000 , & + 0.00440000000000 , & + 0.00120000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.32530000000000 , & + 1.03000000000000 , & + -0.00710000000000 , & + 0.09280000000000 , & + 0.04750000000000 , & + 0.01870000000000 , & + 0.00630000000000 , & + 0.00180000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.32210000000000 , & + 1.04040000000000 , & + -0.00900000000000 , & + 0.10060000000000 , & + 0.05490000000000 , & + 0.02340000000000 , & + 0.00850000000000 , & + 0.00270000000000 , & + 0.00080000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.31870000000000 , & + 1.05150000000000 , & + -0.01100000000000 , & + 0.10780000000000 , & + 0.06200000000000 , & + 0.02820000000000 , & + 0.01100000000000 , & + 0.00380000000000 , & + 0.00120000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.31520000000000 , & + 1.06320000000000 , & + -0.01320000000000 , & + 0.11410000000000 , & + 0.06880000000000 , & + 0.03320000000000 , & + 0.01370000000000 , & + 0.00500000000000 , & + 0.00170000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.31150000000000 , & + 1.07560000000000 , & + -0.01560000000000 , & + 0.11980000000000 , & + 0.07520000000000 , & + 0.03810000000000 , & + 0.01670000000000 , & + 0.00650000000000 , & + 0.00230000000000 , & + 0.00070000000000 , & + 0.00020000000000 , & + 0.30770000000000 , & + 1.08890000000000 , & + -0.01820000000000 , & + 0.12460000000000 , & + 0.08110000000000 , & + 0.04310000000000 , & + 0.01990000000000 , & + 0.00820000000000 , & + 0.00310000000000 , & + 0.00100000000000 , & + 0.00030000000000 , & + 0.30370000000000 , & + 1.10340000000000 , & + -0.02100000000000 , & + 0.12840000000000 , & + 0.08630000000000 , & + 0.04800000000000 , & + 0.02330000000000 , & + 0.01020000000000 , & + 0.00410000000000 , & + 0.00150000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.12840000000000 , & + 0.08630000000000 , & + 0.04800000000000 , & + 0.02330000000000 , & + 0.01020000000000 , & + 0.00410000000000 , & + 0.00150000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.12840000000000 , & + 0.08630000000000 , & + 0.04800000000000 , & + 0.02330000000000 , & + 0.01020000000000 , & + 0.00410000000000 , & + 0.00150000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.12840000000000 , & + 0.08630000000000 , & + 0.04800000000000 , & + 0.02330000000000 , & + 0.01020000000000 , & + 0.00410000000000 , & + 0.00150000000000 , & + 0.00050000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.12840000000000 , & + 0.08630000000000 , & + 0.04800000000000 , & + 0.02330000000000 , & + 0.01020000000000 , & + 0.00410000000000 , & + 0.00150000000000 , & + 0.00050000000000 , & + 0.31900000000000 , & + 0.98470000000000 , & + -0.00010000000000 , & + 0.01440000000000 , & + 0.00150000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.31800000000000 , & + 0.98810000000000 , & + -0.00050000000000 , & + 0.02820000000000 , & + 0.00560000000000 , & + 0.00080000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.31630000000000 , & + 0.99330000000000 , & + -0.00100000000000 , & + 0.04100000000000 , & + 0.01170000000000 , & + 0.00240000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.31420000000000 , & + 1.00000000000000 , & + -0.00180000000000 , & + 0.05280000000000 , & + 0.01890000000000 , & + 0.00500000000000 , & + 0.00110000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.31170000000000 , & + 1.00790000000000 , & + -0.00280000000000 , & + 0.06360000000000 , & + 0.02660000000000 , & + 0.00840000000000 , & + 0.00220000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.30890000000000 , & + 1.01690000000000 , & + -0.00400000000000 , & + 0.07340000000000 , & + 0.03450000000000 , & + 0.01240000000000 , & + 0.00380000000000 , & + 0.00100000000000 , & + 0.00020000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.30600000000000 , & + 1.02660000000000 , & + -0.00550000000000 , & + 0.08230000000000 , & + 0.04240000000000 , & + 0.01690000000000 , & + 0.00580000000000 , & + 0.00170000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.30290000000000 , & + 1.03720000000000 , & + -0.00710000000000 , & + 0.09040000000000 , & + 0.05010000000000 , & + 0.02180000000000 , & + 0.00810000000000 , & + 0.00270000000000 , & + 0.00080000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.29970000000000 , & + 1.04830000000000 , & + -0.00890000000000 , & + 0.09780000000000 , & + 0.05740000000000 , & + 0.02680000000000 , & + 0.01080000000000 , & + 0.00390000000000 , & + 0.00120000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.29630000000000 , & + 1.06020000000000 , & + -0.01090000000000 , & + 0.10450000000000 , & + 0.06440000000000 , & + 0.03200000000000 , & + 0.01370000000000 , & + 0.00530000000000 , & + 0.00180000000000 , & + 0.00060000000000 , & + 0.00020000000000 , & + 0.29280000000000 , & + 1.07280000000000 , & + -0.01320000000000 , & + 0.11040000000000 , & + 0.07100000000000 , & + 0.03720000000000 , & + 0.01690000000000 , & + 0.00690000000000 , & + 0.00250000000000 , & + 0.00090000000000 , & + 0.00030000000000 , & + 0.28930000000000 , & + 1.08610000000000 , & + -0.01550000000000 , & + 0.11560000000000 , & + 0.07700000000000 , & + 0.04230000000000 , & + 0.02030000000000 , & + 0.00870000000000 , & + 0.00340000000000 , & + 0.00120000000000 , & + 0.00040000000000 , & + 0.28550000000000 , & + 1.10040000000000 , & + -0.01810000000000 , & + 0.11990000000000 , & + 0.08250000000000 , & + 0.04740000000000 , & + 0.02380000000000 , & + 0.01080000000000 , & + 0.00450000000000 , & + 0.00170000000000 , & + 0.00060000000000 , & + 0.28150000000000 , & + 1.11590000000000 , & + -0.02080000000000 , & + 0.12320000000000 , & + 0.08730000000000 , & + 0.05220000000000 , & + 0.02750000000000 , & + 0.01320000000000 , & + 0.00590000000000 , & + 0.00240000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.12320000000000 , & + 0.08730000000000 , & + 0.05220000000000 , & + 0.02750000000000 , & + 0.01320000000000 , & + 0.00590000000000 , & + 0.00240000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.12320000000000 , & + 0.08730000000000 , & + 0.05220000000000 , & + 0.02750000000000 , & + 0.01320000000000 , & + 0.00590000000000 , & + 0.00240000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.12320000000000 , & + 0.08730000000000 , & + 0.05220000000000 , & + 0.02750000000000 , & + 0.01320000000000 , & + 0.00590000000000 , & + 0.00240000000000 , & + 0.00090000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.12320000000000 , & + 0.08730000000000 , & + 0.05220000000000 , & + 0.02750000000000 , & + 0.01320000000000 , & + 0.00590000000000 , & + 0.00240000000000 , & + 0.00090000000000 , & + 0.29970000000000 , & + 0.98670000000000 , & + -0.00010000000000 , & + 0.01440000000000 , & + 0.00170000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.29850000000000 , & + 0.99050000000000 , & + -0.00050000000000 , & + 0.02810000000000 , & + 0.00630000000000 , & + 0.00100000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.29680000000000 , & + 0.99630000000000 , & + -0.00100000000000 , & + 0.04070000000000 , & + 0.01290000000000 , & + 0.00300000000000 , & + 0.00060000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.29460000000000 , & + 1.00370000000000 , & + -0.00180000000000 , & + 0.05220000000000 , & + 0.02050000000000 , & + 0.00610000000000 , & + 0.00150000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.29210000000000 , & + 1.01240000000000 , & + -0.00280000000000 , & + 0.06250000000000 , & + 0.02860000000000 , & + 0.01000000000000 , & + 0.00300000000000 , & + 0.00080000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.28930000000000 , & + 1.02200000000000 , & + -0.00400000000000 , & + 0.07190000000000 , & + 0.03670000000000 , & + 0.01450000000000 , & + 0.00490000000000 , & + 0.00150000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.28640000000000 , & + 1.03250000000000 , & + -0.00540000000000 , & + 0.08040000000000 , & + 0.04460000000000 , & + 0.01950000000000 , & + 0.00730000000000 , & + 0.00250000000000 , & + 0.00080000000000 , & + 0.00020000000000 , & + 0.00010000000000 , & + 0.28330000000000 , & + 1.04380000000000 , & + -0.00710000000000 , & + 0.08810000000000 , & + 0.05210000000000 , & + 0.02470000000000 , & + 0.01010000000000 , & + 0.00370000000000 , & + 0.00120000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.28010000000000 , & + 1.05580000000000 , & + -0.00890000000000 , & + 0.09500000000000 , & + 0.05930000000000 , & + 0.03010000000000 , & + 0.01320000000000 , & + 0.00520000000000 , & + 0.00190000000000 , & + 0.00060000000000 , & + 0.00020000000000 , & + 0.27670000000000 , & + 1.06840000000000 , & + -0.01090000000000 , & + 0.10130000000000 , & + 0.06610000000000 , & + 0.03540000000000 , & + 0.01660000000000 , & + 0.00700000000000 , & + 0.00270000000000 , & + 0.00090000000000 , & + 0.00030000000000 , & + 0.27330000000000 , & + 1.08180000000000 , & + -0.01310000000000 , & + 0.10680000000000 , & + 0.07240000000000 , & + 0.04080000000000 , & + 0.02010000000000 , & + 0.00900000000000 , & + 0.00370000000000 , & + 0.00140000000000 , & + 0.00050000000000 , & + 0.26980000000000 , & + 1.09600000000000 , & + -0.01540000000000 , & + 0.11150000000000 , & + 0.07810000000000 , & + 0.04600000000000 , & + 0.02380000000000 , & + 0.01120000000000 , & + 0.00490000000000 , & + 0.00190000000000 , & + 0.00070000000000 , & + 0.26610000000000 , & + 1.11120000000000 , & + -0.01800000000000 , & + 0.11540000000000 , & + 0.08330000000000 , & + 0.05100000000000 , & + 0.02760000000000 , & + 0.01370000000000 , & + 0.00630000000000 , & + 0.00270000000000 , & + 0.00110000000000 , & + 0.26220000000000 , & + 1.12780000000000 , & + -0.02060000000000 , & + 0.11810000000000 , & + 0.08750000000000 , & + 0.05560000000000 , & + 0.03150000000000 , & + 0.01640000000000 , & + 0.00790000000000 , & + 0.00360000000000 , & + 0.00150000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.11810000000000 , & + 0.08750000000000 , & + 0.05560000000000 , & + 0.03150000000000 , & + 0.01640000000000 , & + 0.00790000000000 , & + 0.00360000000000 , & + 0.00150000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.11810000000000 , & + 0.08750000000000 , & + 0.05560000000000 , & + 0.03150000000000 , & + 0.01640000000000 , & + 0.00790000000000 , & + 0.00360000000000 , & + 0.00150000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.11810000000000 , & + 0.08750000000000 , & + 0.05560000000000 , & + 0.03150000000000 , & + 0.01640000000000 , & + 0.00790000000000 , & + 0.00360000000000 , & + 0.00150000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.11810000000000 , & + 0.08750000000000 , & + 0.05560000000000 , & + 0.03150000000000 , & + 0.01640000000000 , & + 0.00790000000000 , & + 0.00360000000000 , & + 0.00150000000000 , & + 0.28250000000000 , & + 0.98850000000000 , & + -0.00010000000000 , & + 0.01440000000000 , & + 0.00190000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.28130000000000 , & + 0.99270000000000 , & + -0.00050000000000 , & + 0.02800000000000 , & + 0.00700000000000 , & + 0.00130000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.27950000000000 , & + 0.99910000000000 , & + -0.00100000000000 , & + 0.04030000000000 , & + 0.01410000000000 , & + 0.00370000000000 , & + 0.00080000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.27730000000000 , & + 1.00710000000000 , & + -0.00180000000000 , & + 0.05140000000000 , & + 0.02210000000000 , & + 0.00720000000000 , & + 0.00200000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.27470000000000 , & + 1.01650000000000 , & + -0.00280000000000 , & + 0.06130000000000 , & + 0.03030000000000 , & + 0.01160000000000 , & + 0.00380000000000 , & + 0.00110000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.27200000000000 , & + 1.02680000000000 , & + -0.00400000000000 , & + 0.07030000000000 , & + 0.03840000000000 , & + 0.01660000000000 , & + 0.00620000000000 , & + 0.00210000000000 , & + 0.00060000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.26900000000000 , & + 1.03800000000000 , & + -0.00540000000000 , & + 0.07840000000000 , & + 0.04630000000000 , & + 0.02190000000000 , & + 0.00900000000000 , & + 0.00330000000000 , & + 0.00110000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.26590000000000 , & + 1.05000000000000 , & + -0.00700000000000 , & + 0.08570000000000 , & + 0.05380000000000 , & + 0.02740000000000 , & + 0.01220000000000 , & + 0.00490000000000 , & + 0.00180000000000 , & + 0.00060000000000 , & + 0.00020000000000 , & + 0.26280000000000 , & + 1.06270000000000 , & + -0.00880000000000 , & + 0.09220000000000 , & + 0.06080000000000 , & + 0.03300000000000 , & + 0.01570000000000 , & + 0.00670000000000 , & + 0.00270000000000 , & + 0.00100000000000 , & + 0.00030000000000 , & + 0.25950000000000 , & + 1.07620000000000 , & + -0.01080000000000 , & + 0.09810000000000 , & + 0.06730000000000 , & + 0.03850000000000 , & + 0.01940000000000 , & + 0.00880000000000 , & + 0.00370000000000 , & + 0.00150000000000 , & + 0.00050000000000 , & + 0.25610000000000 , & + 1.09040000000000 , & + -0.01300000000000 , & + 0.10320000000000 , & + 0.07330000000000 , & + 0.04390000000000 , & + 0.02320000000000 , & + 0.01120000000000 , & + 0.00500000000000 , & + 0.00210000000000 , & + 0.00080000000000 , & + 0.25260000000000 , & + 1.10540000000000 , & + -0.01530000000000 , & + 0.10760000000000 , & + 0.07870000000000 , & + 0.04910000000000 , & + 0.02720000000000 , & + 0.01380000000000 , & + 0.00650000000000 , & + 0.00280000000000 , & + 0.00120000000000 , & + 0.24900000000000 , & + 1.12150000000000 , & + -0.01780000000000 , & + 0.11100000000000 , & + 0.08340000000000 , & + 0.05390000000000 , & + 0.03120000000000 , & + 0.01660000000000 , & + 0.00820000000000 , & + 0.00380000000000 , & + 0.00170000000000 , & + 0.24520000000000 , & + 1.13910000000000 , & + -0.02050000000000 , & + 0.11320000000000 , & + 0.08710000000000 , & + 0.05830000000000 , & + 0.03520000000000 , & + 0.01960000000000 , & + 0.01020000000000 , & + 0.00500000000000 , & + 0.00230000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.11320000000000 , & + 0.08710000000000 , & + 0.05830000000000 , & + 0.03520000000000 , & + 0.01960000000000 , & + 0.01020000000000 , & + 0.00500000000000 , & + 0.00230000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.11320000000000 , & + 0.08710000000000 , & + 0.05830000000000 , & + 0.03520000000000 , & + 0.01960000000000 , & + 0.01020000000000 , & + 0.00500000000000 , & + 0.00230000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.11320000000000 , & + 0.08710000000000 , & + 0.05830000000000 , & + 0.03520000000000 , & + 0.01960000000000 , & + 0.01020000000000 , & + 0.00500000000000 , & + 0.00230000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.11320000000000 , & + 0.08710000000000 , & + 0.05830000000000 , & + 0.03520000000000 , & + 0.01960000000000 , & + 0.01020000000000 , & + 0.00500000000000 , & + 0.00230000000000 , & + 0.26720000000000 , & + 0.99000000000000 , & + -0.00010000000000 , & + 0.01440000000000 , & + 0.00210000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.26600000000000 , & + 0.99470000000000 , & + -0.00050000000000 , & + 0.02790000000000 , & + 0.00770000000000 , & + 0.00160000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.26410000000000 , & + 1.00160000000000 , & + -0.00100000000000 , & + 0.03990000000000 , & + 0.01520000000000 , & + 0.00440000000000 , & + 0.00110000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.26190000000000 , & + 1.01030000000000 , & + -0.00180000000000 , & + 0.05060000000000 , & + 0.02350000000000 , & + 0.00840000000000 , & + 0.00260000000000 , & + 0.00070000000000 , & + 0.00020000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.25930000000000 , & + 1.02030000000000 , & + -0.00280000000000 , & + 0.06010000000000 , & + 0.03180000000000 , & + 0.01320000000000 , & + 0.00480000000000 , & + 0.00160000000000 , & + 0.00050000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.25650000000000 , & + 1.03130000000000 , & + -0.00400000000000 , & + 0.06870000000000 , & + 0.03990000000000 , & + 0.01860000000000 , & + 0.00750000000000 , & + 0.00280000000000 , & + 0.00090000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.25360000000000 , & + 1.04320000000000 , & + -0.00540000000000 , & + 0.07640000000000 , & + 0.04770000000000 , & + 0.02420000000000 , & + 0.01070000000000 , & + 0.00430000000000 , & + 0.00160000000000 , & + 0.00050000000000 , & + 0.00020000000000 , & + 0.25050000000000 , & + 1.05590000000000 , & + -0.00700000000000 , & + 0.08330000000000 , & + 0.05500000000000 , & + 0.02990000000000 , & + 0.01430000000000 , & + 0.00620000000000 , & + 0.00250000000000 , & + 0.00090000000000 , & + 0.00030000000000 , & + 0.24740000000000 , & + 1.06940000000000 , & + -0.00880000000000 , & + 0.08950000000000 , & + 0.06170000000000 , & + 0.03560000000000 , & + 0.01810000000000 , & + 0.00840000000000 , & + 0.00360000000000 , & + 0.00140000000000 , & + 0.00050000000000 , & + 0.24420000000000 , & + 1.08350000000000 , & + -0.01080000000000 , & + 0.09500000000000 , & + 0.06800000000000 , & + 0.04120000000000 , & + 0.02210000000000 , & + 0.01080000000000 , & + 0.00490000000000 , & + 0.00210000000000 , & + 0.00080000000000 , & + 0.24080000000000 , & + 1.09850000000000 , & + -0.01290000000000 , & + 0.09980000000000 , & + 0.07360000000000 , & + 0.04650000000000 , & + 0.02620000000000 , & + 0.01350000000000 , & + 0.00650000000000 , & + 0.00290000000000 , & + 0.00120000000000 , & + 0.23740000000000 , & + 1.11430000000000 , & + -0.01520000000000 , & + 0.10380000000000 , & + 0.07870000000000 , & + 0.05160000000000 , & + 0.03030000000000 , & + 0.01640000000000 , & + 0.00830000000000 , & + 0.00390000000000 , & + 0.00180000000000 , & + 0.23390000000000 , & + 1.13130000000000 , & + -0.01770000000000 , & + 0.10690000000000 , & + 0.08300000000000 , & + 0.05630000000000 , & + 0.03440000000000 , & + 0.01940000000000 , & + 0.01030000000000 , & + 0.00510000000000 , & + 0.00240000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10690000000000 , & + 0.08300000000000 , & + 0.05630000000000 , & + 0.03440000000000 , & + 0.01940000000000 , & + 0.01030000000000 , & + 0.00510000000000 , & + 0.00240000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10690000000000 , & + 0.08300000000000 , & + 0.05630000000000 , & + 0.03440000000000 , & + 0.01940000000000 , & + 0.01030000000000 , & + 0.00510000000000 , & + 0.00240000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10690000000000 , & + 0.08300000000000 , & + 0.05630000000000 , & + 0.03440000000000 , & + 0.01940000000000 , & + 0.01030000000000 , & + 0.00510000000000 , & + 0.00240000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10690000000000 , & + 0.08300000000000 , & + 0.05630000000000 , & + 0.03440000000000 , & + 0.01940000000000 , & + 0.01030000000000 , & + 0.00510000000000 , & + 0.00240000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10690000000000 , & + 0.08300000000000 , & + 0.05630000000000 , & + 0.03440000000000 , & + 0.01940000000000 , & + 0.01030000000000 , & + 0.00510000000000 , & + 0.00240000000000 , & + 0.25350000000000 , & + 0.99130000000000 , & + -0.00010000000000 , & + 0.01440000000000 , & + 0.00240000000000 , & + 0.00030000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.25220000000000 , & + 0.99640000000000 , & + -0.00050000000000 , & + 0.02770000000000 , & + 0.00840000000000 , & + 0.00190000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.25030000000000 , & + 1.00400000000000 , & + -0.00100000000000 , & + 0.03940000000000 , & + 0.01630000000000 , & + 0.00510000000000 , & + 0.00140000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.24800000000000 , & + 1.01320000000000 , & + -0.00180000000000 , & + 0.04980000000000 , & + 0.02470000000000 , & + 0.00960000000000 , & + 0.00320000000000 , & + 0.00100000000000 , & + 0.00030000000000 , & + 0.00010000000000 , & + 0.00000000000000 , & + 0.24550000000000 , & + 1.02390000000000 , & + -0.00280000000000 , & + 0.05890000000000 , & + 0.03310000000000 , & + 0.01480000000000 , & + 0.00580000000000 , & + 0.00200000000000 , & + 0.00070000000000 , & + 0.00020000000000 , & + 0.00010000000000 , & + 0.24270000000000 , & + 1.03560000000000 , & + -0.00400000000000 , & + 0.06710000000000 , & + 0.04110000000000 , & + 0.02050000000000 , & + 0.00890000000000 , & + 0.00350000000000 , & + 0.00130000000000 , & + 0.00040000000000 , & + 0.00010000000000 , & + 0.23980000000000 , & + 1.04810000000000 , & + -0.00540000000000 , & + 0.07450000000000 , & + 0.04870000000000 , & + 0.02630000000000 , & + 0.01250000000000 , & + 0.00540000000000 , & + 0.00220000000000 , & + 0.00080000000000 , & + 0.00030000000000 , & + 0.23680000000000 , & + 1.06150000000000 , & + -0.00700000000000 , & + 0.08110000000000 , & + 0.05580000000000 , & + 0.03220000000000 , & + 0.01640000000000 , & + 0.00760000000000 , & + 0.00330000000000 , & + 0.00130000000000 , & + 0.00050000000000 , & + 0.23360000000000 , & + 1.07570000000000 , & + -0.00880000000000 , & + 0.08690000000000 , & + 0.06230000000000 , & + 0.03790000000000 , & + 0.02050000000000 , & + 0.01010000000000 , & + 0.00470000000000 , & + 0.00200000000000 , & + 0.00080000000000 , & + 0.23050000000000 , & + 1.09060000000000 , & + -0.01070000000000 , & + 0.09210000000000 , & + 0.06830000000000 , & + 0.04350000000000 , & + 0.02470000000000 , & + 0.01290000000000 , & + 0.00630000000000 , & + 0.00290000000000 , & + 0.00120000000000 , & + 0.22720000000000 , & + 1.10630000000000 , & + -0.01290000000000 , & + 0.09660000000000 , & + 0.07360000000000 , & + 0.04870000000000 , & + 0.02900000000000 , & + 0.01590000000000 , & + 0.00810000000000 , & + 0.00390000000000 , & + 0.00180000000000 , & + 0.22380000000000 , & + 1.12290000000000 , & + -0.01520000000000 , & + 0.10020000000000 , & + 0.07830000000000 , & + 0.05370000000000 , & + 0.03320000000000 , & + 0.01900000000000 , & + 0.01020000000000 , & + 0.00520000000000 , & + 0.00250000000000 , & + 0.22030000000000 , & + 1.14060000000000 , & + -0.01760000000000 , & + 0.10290000000000 , & + 0.08220000000000 , & + 0.05810000000000 , & + 0.03730000000000 , & + 0.02220000000000 , & + 0.01250000000000 , & + 0.00660000000000 , & + 0.00340000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10290000000000 , & + 0.08220000000000 , & + 0.05810000000000 , & + 0.03730000000000 , & + 0.02220000000000 , & + 0.01250000000000 , & + 0.00660000000000 , & + 0.00340000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10290000000000 , & + 0.08220000000000 , & + 0.05810000000000 , & + 0.03730000000000 , & + 0.02220000000000 , & + 0.01250000000000 , & + 0.00660000000000 , & + 0.00340000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10290000000000 , & + 0.08220000000000 , & + 0.05810000000000 , & + 0.03730000000000 , & + 0.02220000000000 , & + 0.01250000000000 , & + 0.00660000000000 , & + 0.00340000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10290000000000 , & + 0.08220000000000 , & + 0.05810000000000 , & + 0.03730000000000 , & + 0.02220000000000 , & + 0.01250000000000 , & + 0.00660000000000 , & + 0.00340000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.00000000000000 , & + 0.10290000000000 , & + 0.08220000000000 , & + 0.05810000000000 , & + 0.03730000000000 , & + 0.02220000000000 , & + 0.01250000000000 , & + 0.00660000000000 , & + 0.00340000000000 & + /) + ! + RFveg = reshape(RFvegtmp ,(/11,18,20/)) + ! + !write(*,*)'RFveg= ',RFveg + ! + end subroutine load_RFtable + +end module snapwave_RFtable + \ No newline at end of file diff --git a/source/src/snapwave/snapwave_data.f90 b/source/src/snapwave/snapwave_data.f90 index 1ab955526..6d1c484fa 100644 --- a/source/src/snapwave/snapwave_data.f90 +++ b/source/src/snapwave/snapwave_data.f90 @@ -49,8 +49,8 @@ module snapwave_data real*4, dimension(:,:), allocatable :: ctheta360 ! refraction speed, per grid point and direction ! real*4, dimension(:), allocatable :: xn,yn,zn ! coordinates of nodes of unstructured grid real*4, dimension(:), allocatable :: dzdx,dzdy ! bed slopes at nodes of unstructured grid - integer, dimension(:,:), allocatable :: face_nodes ! node numbers connected to each cell - integer, dimension(:,:), allocatable :: edge_nodes ! node numbers connected to each edge + integer, dimension(:,:), allocatable :: face_nodes ! node numbers connected to each cell + integer, dimension(:,:), allocatable :: edge_nodes ! node numbers connected to each edge real*4, dimension(:), allocatable :: bndindx real*4, dimension(:), allocatable :: tau ! real*4, dimension(:,:), allocatable :: Fluxtab @@ -62,6 +62,7 @@ module snapwave_data real*4, dimension(:), allocatable :: Hmx_ig real*4, dimension(:,:), allocatable :: ee ! directional energy density real*4, dimension(:,:), allocatable :: ee_ig ! directional infragravity energy density + real*4, dimension(:), allocatable :: DoverE ! real*4, dimension(:,:), allocatable :: aa ! directional action density real*4, dimension(:), allocatable :: sig ! mean frequency @@ -172,10 +173,9 @@ module snapwave_data real*4 :: fwcutoff ! depth below which to apply space-varying fw real*4 :: alpha,gamma ! coefficients in Baldock wave breaking dissipation model real*4 :: gammax ! max wave height/water depth ratio - integer :: baldock_opt ! option of Baldock wave breaking dissipation model (opt=1 is without gamma&depth, else is including) + !integer :: baldock_opt ! option of Baldock wave breaking dissipation model (opt=1 is without gamma&depth, else is including) real*4 :: baldock_ratio ! option controlling from what depth wave breaking should take place: (Hk>baldock_ratio*Hmx(k)), default baldock_ratio=0.2 - ! TODO - TL: bring back baldock_ratio? - + integer :: baldock_exponent! Exponent for multiplying the Baldock dissipation with a factor 'f = (Hloc / Hmax)**iexp' to enhance breaking when H > Hmax, with iexp = 0 (default, means unused), 1 or 2 real*4 :: hmin ! minimum water depth character*256 :: gridfile ! name of gridfile (Delft3D .grd format) integer :: sferic ! sferical (1) or cartesian (0) grid @@ -216,6 +216,8 @@ module snapwave_data real*4 :: rghlevland ! Elevation separation as in SFINCS for simple elevation varying roughness real*4 :: fwratio ! Above 'rghlevland' elevation of zb, the friction for incident waves is multiplied with value 'fwratio' real*4 :: fwigratio ! Above 'rghlevland' elevation of zb, the friction for IG waves is multiplied with value 'fwratio' + real*4 :: relax_factor_DoverA ! underrelaxation factor for DoverA (set to 1.0 to disable) + real*4 :: relax_factor_DoverE ! underrelaxation factor for DoverE (set to 1.0 to disable) ! character*3 :: outputformat integer :: ja_save_each_iter ! logical to save output after each iteration or not @@ -259,6 +261,7 @@ module snapwave_data ! integer :: ig_opt ! option of IG wave settings (1 = default = conservative shoaling based dSxx and Baldock breaking) real*4 :: alpha_ig,gamma_ig ! coefficients in Baldock wave breaking dissipation model for IG waves + real*4 :: gamma_fac_br ! factor times gamma that is used to determine the maximum incident wave breaking point in the surf zone using local incident wave height over water depth ratio, among others used to set the IG source term to 0 shallower than this point real*4 :: shinc2ig ! Ratio of how much of the calculated IG wave source term, is subtracted from the incident wave energy (0-1, 0=default) real*4 :: alphaigfac ! Multiplication factor for IG shoaling source/sink term, default = 1.0 real*4 :: eeinc2ig ! ratio of incident wave energy as first estimate of IG wave energy at boundary @@ -282,6 +285,7 @@ module snapwave_data ! logical :: restart logical :: coupled_to_sfincs + logical :: storesnapwavegrid ! integer :: nr_quadtree_points ! diff --git a/source/src/snapwave/snapwave_domain.f90 b/source/src/snapwave/snapwave_domain.f90 index 7c1992f2f..e671408aa 100644 --- a/source/src/snapwave/snapwave_domain.f90 +++ b/source/src/snapwave/snapwave_domain.f90 @@ -8,8 +8,10 @@ subroutine initialize_snapwave_domain() ! use snapwave_data use snapwave_boundaries + use snapwave_ncoutput use interp use sfincs_error + use quadtree ! ! Local input variables ! @@ -21,6 +23,7 @@ subroutine initialize_snapwave_domain() integer*4 :: idummy character*2 :: ext logical :: generate_upw, exists + character(len=256) :: snapwave_ncfname ! real*8 :: xmn, ymn ! ! First set some constants @@ -83,17 +86,16 @@ subroutine initialize_snapwave_domain() if (face_nodes(4,k)==0) face_nodes(4,k) = -999 enddo ! - ! Done with the mesh + ! write mesh to file + if (storesnapwavegrid) then + ! + snapwave_ncfname = 'snapwavegrid.nc' + ! + call write_snapwave_mesh(snapwave_ncfname, sferic == 1) + ! + endif ! - ! keep on also if ja_vegetation==0, so array Dveg is initialized with zeroes - !if (ja_vegetation==1) then - ! call veggie_init() - !else - allocate(veg_Cd(no_nodes, no_secveg)) - allocate(veg_ah(no_nodes, no_secveg)) - allocate(veg_bstems(no_nodes, no_secveg)) - allocate(veg_Nstems(no_nodes, no_secveg)) - !endif + ! Done with the mesh ! ntheta360 = nint(360./dtheta) ntheta = nint(sector/dtheta) @@ -165,6 +167,7 @@ subroutine initialize_snapwave_domain() allocate(WsorA (ntheta,no_nodes)) allocate(SwE (no_nodes)) allocate(SwA (no_nodes)) + allocate(DoverE(no_nodes)) ! ! Spatially-uniform bottom friction coefficients ! @@ -172,10 +175,10 @@ subroutine initialize_snapwave_domain() fw_ig = fw0_ig ! do k=1,no_nodes - if (zb(k) > rghlevland) then - fw(k) = fw0 * fwratio - fw_ig(k) = fw0_ig * fwigratio - endif + if (zb(k) > rghlevland) then + fw(k) = fw0 * fwratio + fw_ig(k) = fw0_ig * fwigratio + endif enddo ! ! Initialization of reference tables @@ -206,7 +209,9 @@ subroutine initialize_snapwave_domain() WsorA = 0.0 SwE = 0.0 SwA = 0.0 - windspreadfac = 0.0 + DoverE = 0.0 + windspreadfac = 0.0 + Hmx_ig = 0.0 ! generate_upw = .true. exists = .true. @@ -303,26 +308,12 @@ subroutine initialize_snapwave_domain() if (any(msk == 3)) then ! ! We already have all msk=3 Neumann points, now find each their nearest cell 'neumannconnected' using new 'neuboundaries_light' - call neuboundaries_light(x,y,msk,no_nodes,tol,neumannconnected) - ! - if (ANY(neumannconnected > 0)) then - ! - write(logstr,*)'SnapWave: Neumann connected boundaries found ...' - call write_log(logstr, 0) - ! - do k=1,no_nodes - if (neumannconnected(k)>0) then - if (msk(k)==1) then - ! k is inner and can be neumannconnected - inner(neumannconnected(k))= .false. - msk(neumannconnected(k)) = 3 !TL: should already by 3, but left it like in SnapWave SVN - else - ! we don't allow neumannconnected links if the node is an open boundary - neumannconnected(k) = 0 - endif - endif - enddo - endif + ! + call neuboundaries_light(x, y, msk, no_nodes, neumannconnected) + ! + write(logstr,*)'SnapWave: Neumann connected boundaries found ...' + call write_log(logstr, 0) + ! else ! neumannconnected = 0 @@ -796,136 +787,62 @@ subroutine boundaries(x,y,no_nodes,xb,yb,nb,tol,bndpts,nobndpts,bndindx,bndweigh end subroutine boundaries - subroutine neuboundaries_light(x,y,msk,no_nodes,tol,neumannconnected) + + subroutine neuboundaries_light(x, y, msk, no_nodes, neumannconnected) ! - ! TL: Based on subroutine find_nearest_depth_for_boundary_points of snapwave_boundaries.f90 - ! implicit none ! integer, intent(in) :: no_nodes - real*8, dimension(no_nodes), intent(in) :: x,y + real*8, dimension(no_nodes), intent(in) :: x, y integer*1, dimension(no_nodes), intent(in) :: msk - real*4, intent(in) :: tol integer, dimension(no_nodes), intent(out) :: neumannconnected ! - real*4 :: h1, h2, fac - ! - real xgb, ygb, dst1, dst2, dst - integer k, ib1, ib2, ic, kmin - ! - ! Loop through all msk=3 cells - ! - do ic = 1, no_nodes - ! Loop through all grid points - ! - if (msk(ic)==3) then ! point ic is on the neumann boundary - ! - dst1 = tol - dst2 = tol - ib1 = 0 - ib2 = 0 - ! - do k = 1, no_nodes - ! - if (msk(k)==1) then - xgb = x(k) - ygb = y(k) - ! - dst = sqrt((x(ic) - xgb)**2 + (y(ic) - ygb)**2) - ! - if (dst 0) .and. (ib2 > 0) ) then - ! - ! Determine the index of the minimum value, if points found within 'tol' distance - ! - if (dst1 < dst2) then - kmin = ib1 - else - kmin = ib2 - endif - ! - neumannconnected(kmin)=ic - ! - !write(*,*)kmin,ic - ! - endif - ! - endif - enddo - ! - end subroutine neuboundaries_light - - -subroutine neuboundaries(x,y,no_nodes,xneu,yneu,n_neu,tol,neumannconnected) + real :: xgb, ygb, dst1, dst + integer :: k, ib1, ic ! - implicit none + ! Loop through all msk=3 cells and find their nearest msk=1 cell, save in 'neumannconnected' ! - integer, intent(in) :: no_nodes - integer, intent(in) :: n_neu - real*8, dimension(no_nodes), intent(in) :: x,y - real*8, dimension(n_neu), intent(in) :: xneu,yneu - real*4, intent(in) :: tol - integer, dimension(no_nodes), intent(out) :: neumannconnected - ! - integer :: ib,k,kmin, k2 - real*8 :: alpha, cosa,sina, distmin, x1,y1,x2,y2, xend - ! - neumannconnected=0 - do ib=1,n_neu-1 - if (xneu(ib).ne.-999.and.xneu(ib+1).ne.-999) then - alpha=atan2(yneu(ib+1)-yneu(ib),xneu(ib+1)-xneu(ib)) - cosa=cos(alpha) - sina=sin(alpha) - xend=(xneu(ib+1)-xneu(ib))*cosa+(yneu(ib+1)-yneu(ib))*sina - do k=1,no_nodes - x1= (x(k)-xneu(ib))*cosa+(y(k)-yneu(ib))*sina - y1=-(x(k)-xneu(ib))*sina+(y(k)-yneu(ib))*cosa - if (x1>=0.d0 .and. x1<=xend) then - if (abs(y1)0) then - neumannconnected(kmin)=k - write(logstr,*)kmin,k - call write_log(logstr, 0) - endif - endif - endif + do ic = 1, no_nodes + ! + ! Loop through all grid points + ! + if (msk(ic) == 3) then ! point ic is on the neumann boundary + ! + dst1 = 1.0e9 + ib1 = 0 + ! + do k = 1, no_nodes + ! + if (msk(k) == 1) then + ! + xgb = x(k) + ygb = y(k) + ! + dst = sqrt((x(ic) - xgb)**2 + (y(ic) - ygb)**2) + ! + if (dst < dst1) then + ! + ! Nearest point found + ! + dst1 = dst + ib1 = k + ! + endif + endif enddo + ! + if (ib1 > 0) then + ! + neumannconnected(ic) = ib1 + ! + endif + ! endif - enddo + ! + enddo ! -end subroutine neuboundaries + end subroutine neuboundaries_light + subroutine read_snapwave_sfincs_mesh() @@ -1125,6 +1042,9 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) ! use snapwave_data use quadtree + use sfincs_data, only: vegetation_stems_cd, vegetation_stems_height, & + vegetation_stems_diameter, vegetation_stems_density, & + vegetation_vertical_segments ! ! Local input variables ! @@ -1143,13 +1063,19 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) integer :: n integer :: nu1 integer :: nu2 + integer :: nd1 + integer :: nd2 integer :: m integer :: mu1 integer :: mu2 + integer :: md1 + integer :: md2 integer :: mnu1 integer :: nra integer*1 :: mu integer*1 :: nu + integer*1 :: md + integer*1 :: nd integer*1 :: mnu ! logical :: load_quadtree @@ -1166,7 +1092,7 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) ! 4) Loop through all points and make cells for points where msk==1. ! The node indices in the cells will point to the indices of the entire quadtree. ! In a second temporary mask array msk_tmp2, determine which nodes are actually active (being part a cell) - ! 5) Set back snapwave_mask = 2&3 values of wave boudnary and neumann cells + ! 5) Set back snapwave_mask = 2&3 values of wave boundary and neumann cells ! 6) Count actual number of active nodes and cells, and allocate arrays ! 7) Set node data and re-map indices ! @@ -1174,12 +1100,12 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) ! ! Check if qtr file has already been loaded by other model (sfincs) ! -! if (load_quadtree) then -! ! -! write(*,*)'Reading SnapWave quadtree file ', trim(gridfile), ' ...' -! call quadtree_read_file(gridfile) -! ! -! endif + ! if (load_quadtree) then + ! ! + ! write(*,*)'Reading SnapWave quadtree file ', trim(gridfile), ' ...' + ! call quadtree_read_file(gridfile) + ! ! + ! endif ! allocate(index_snapwave_in_quadtree(quadtree_nr_points)) ! Needed for mapping to sfincs ! @@ -1190,6 +1116,7 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) allocate(msk_tmp(quadtree_nr_points)) ! Make temporary mask with all quadtree points allocate(msk_tmp2(quadtree_nr_points)) ! Make second temporary mask with all quadtree points allocate(zb_tmp(quadtree_nr_points)) ! Make temporary array with bed level on all quadtree points + ! zb_tmp = -10.0 ! msk_tmp = 1 ! Without mask file, all points will be active @@ -1221,16 +1148,6 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) ! Count number of active points ! This is also the number of points in the dep file ! -! nra = 0 -! do ip = 1, quadtree_nr_points -! if (msk_tmp(ip)>0) then -! nra = nra + 1 -! endif -! enddo - ! -! allocate(zb_tmp2(nra)) ! Make (very) temporary array with bed level on all active quadtree points -! zb_tmp2 = -10.0 - ! if (depfile /= 'none') then ! write(logstr,*)'Reading SnapWave depth file ',trim(depfile),' ...' @@ -1243,19 +1160,11 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) ! ! Now loop through all quadtree points and set depth ! -! nra = 0 -! do ip = 1, quadtree_nr_points -! if (msk_tmp(ip)>0) then -! nra = nra + 1 -! zb_tmp(ip) = zb_tmp2(nra) -! endif -! enddo -! ! -! deallocate(zb_tmp2) - ! ! STEP 4 - Make faces ! - allocate(faces(4, 4*quadtree_nr_points)) ! max 4 nodes per faces, and max 4 faces per node + allocate(faces(4, 4 * quadtree_nr_points)) ! max 4 nodes per faces, and max 4 faces per node + ! + faces = 0 ! nfaces = 0 ! @@ -1415,47 +1324,6 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) endif endif ! - if (mnu1==0) then - ! Didn't find it going to the right, try via above -! if nu==0 -! ! same level above -! if nu1>0 -! if buq.mu(nu1)==0 -! ! same level above right -! if buq.mu1(nu1)>0 -! ! and it exists -! mnu=0; -! mnu1=buq.mu1(nu1); -! end -! end -! end -! elseif mu==-1 -! ! coarser above -! if nu1>0 -! if buq.mu(nu1)==0 -! ! same level above right -! if buq.mu1(nu1)>0 -! ! and it exists -! mnu=-1; -! mnu1=buq.mu1(nu1); -! end -! end -! end -! else -! ! finer above -! if nu2>0 -! if buq.mu(nu2)==0 -! ! same level above right -! if buq.mu1(nu2)>0 -! ! and it exists -! mnu=1; -! mnu1=buq.mu1(nu2); -! end -! end -! end -! end - endif - ! ! Okay, found all the neighbors! ! ! Now let's see what sort of cells we need @@ -1464,7 +1332,6 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) ! ! Type 1 - Most normal cell possible ! -! write(*,'(a,20i6)')'ip,mu,nu,mnu,mu1,nu1,mnu1',ip,mu,nu,mnu,mu1,nu1,mnu1 if (mu1>0 .and. nu1>0 .and. mnu1>0) then nfaces = nfaces + 1 faces(1, nfaces) = ip @@ -1679,14 +1546,6 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) msk_tmp2(nu1) = 1 endif ! -!% elseif (mu==-1 .and. nu==0 .and. mnu==0 .and. odd(buq.n(ip))) -!% % Type 9 -!% if mu1>0 .and. nu1>0 -!% nfaces=nfaces+1; -!% faces(1, nfaces) = ip; -!% faces(2, nfaces) = mu1; -!% faces(3, nfaces) = nu1; -!% end elseif (mu==-1 .and. nu==-1 .and. mnu==-1) then ! ! Type 10 @@ -2033,7 +1892,80 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) msk_tmp2(nu1) = 1 endif endif - endif + endif + ! + ! Add triangles around stair case boundaries + ! + ! Inactive cell top left + ! + mu = quadtree_mu(ip) + mu1 = quadtree_mu1(ip) + mu2 = quadtree_mu2(ip) + md = quadtree_md(ip) + md1 = quadtree_md1(ip) + md2 = quadtree_md2(ip) + nu = quadtree_nu(ip) + nu1 = quadtree_nu1(ip) + nu2 = quadtree_nu2(ip) + nd = quadtree_nd(ip) + nd1 = quadtree_nd1(ip) + nd2 = quadtree_nd2(ip) + ! + ! Check for inactive cell top left + ! + if (md == 0 .and. nu == 0 .and. md1 > 0 .and. nu1 > 0) then + if (msk_tmp(md1) == 2 .and. msk_tmp(nu1) == 2 .and. msk_tmp(ip) == 1 .and. quadtree_nu1(md1) == 0) then + ! + nfaces = nfaces + 1 + faces(1, nfaces) = md1 + faces(2, nfaces) = ip + faces(3, nfaces) = nu1 + ! + endif + ! + endif + ! + ! Check for inactive cell bottom left + ! + if (md == 0 .and. nd == 0 .and. md1 > 0 .and. nd1 > 0) then + if (msk_tmp(md1) == 2 .and. msk_tmp(nd1) == 2 .and. msk_tmp(ip) == 1 .and. quadtree_nd1(md1) == 0) then + ! + nfaces = nfaces + 1 + faces(1, nfaces) = md1 + faces(2, nfaces) = nd1 + faces(3, nfaces) = ip + ! + endif + ! + endif + ! + ! Check for inactive cell top right + ! + if (mu == 0 .and. nu == 0 .and. mu1 > 0 .and. nu1 > 0) then + if (msk_tmp(mu1) == 2 .and. msk_tmp(nu1) == 2 .and. msk_tmp(ip) == 1 .and. quadtree_nu1(mu1) == 0) then + ! + nfaces = nfaces + 1 + faces(1, nfaces) = ip + faces(2, nfaces) = mu1 + faces(3, nfaces) = nu1 + ! + endif + ! + endif + ! + ! Check for inactive cell bottom right + ! + if (mu == 0 .and. nd == 0 .and. mu1 > 0 .and. nd1 > 0) then + if (msk_tmp(mu1) == 2 .and. msk_tmp(nd1) == 2 .and. msk_tmp(ip) == 1 .and. quadtree_nd1(mu1) == 0) then + ! + nfaces = nfaces + 1 + faces(1, nfaces) = ip + faces(2, nfaces) = nd1 + faces(3, nfaces) = mu1 + ! + endif + ! + endif ! enddo ! @@ -2098,7 +2030,6 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) ! ! Set node values ! -! zb(nac) = zb_tmp(ip) zb(nac) = quadtree_zz(ip) x(nac) = quadtree_xz(ip) y(nac) = quadtree_yz(ip) @@ -2110,11 +2041,11 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) ! enddo ! - ! Loop through cells to re-maps the face nodes + ! STEP 8 - Loop through cells to re-maps the face nodes ! do iface = 1, no_faces do j = 1, 4 - if (faces(j, iface)>0) then + if (faces(j, iface) > 0) then ip0 = faces(j, iface) ! index in full quadtree ip1 = index_snapwave_in_quadtree(ip0) ! index in reduced quadtree face_nodes(j, iface) = ip1 ! set index to that of reduced mesh @@ -2122,6 +2053,44 @@ subroutine read_snapwave_quadtree_mesh(load_quadtree) enddo enddo ! + ! STEP 9 - if vegetation, re-map veggie input from quadtree netcdf vegetationfile + ! Set 'no_secveg' from sfincs_vegetation.f90 for use in snapwave_data + ! + no_secveg = vegetation_vertical_segments + ! + allocate(veg_Cd(no_nodes, no_secveg)) + allocate(veg_ah(no_nodes, no_secveg)) + allocate(veg_bstems(no_nodes, no_secveg)) + allocate(veg_Nstems(no_nodes, no_secveg)) + ! + veg_Cd = 0.0 + veg_ah = 0.0 + veg_bstems = 0.0 + veg_Nstems = 0.0 + ! + if (vegetation) then + ! copy from the quadtree snapwave_veg + nac = 0 + ! + do ip = 1, quadtree_nr_points + ! + if (msk_tmp2(ip)>0) then + ! + nac = nac + 1 + ! + ! Set node values for all points in the vertical + do iq = 1, no_secveg + veg_Cd(nac,iq) = vegetation_stems_cd(ip,iq) + veg_ah(nac,iq) = vegetation_stems_height(ip,iq) + veg_bstems(nac,iq) = vegetation_stems_diameter(ip,iq) + veg_Nstems(nac,iq) = vegetation_stems_density(ip,iq) + enddo + ! + endif + enddo + ! + endif + ! end subroutine end module diff --git a/source/src/snapwave/snapwave_infragravity.f90 b/source/src/snapwave/snapwave_infragravity.f90 index 178f32843..741ce4515 100644 --- a/source/src/snapwave/snapwave_infragravity.f90 +++ b/source/src/snapwave/snapwave_infragravity.f90 @@ -43,22 +43,26 @@ subroutine determine_ig_bc(x_bwv, y_bwv, hsinc, tpinc, ds, jonswapgam, depth, Ti scoeff = (2/ds**2) - 1 ! ! Call function that calculates Hig0 following Herbers, as also implemented in XBeach and secordspec2 in Matlab - ! Loosely based on 3 step calculation in waveparams.F90 of XBeach (build_jonswap, build_etdir, build_boundw), here all in 1 subroutine calculate_herbers - ! - if (depth < 5.0) then - ! - write(logstr,*)'ERROR SnapWave - depth at boundary input point ',x_bwv, y_bwv,' dropped below 5 m: ',depth - call write_log(logstr, 1) - ! - write(logstr,*)'This might lead to large values of Hm0ig as bc, especially when directional spreading is low! Please specify input in deeper water. ' - call write_log(logstr, 1) - ! - write(logstr,*)'Depth set back to 5 meters for stability, simulation will continue.' - call write_log(logstr, 1) - ! - depth = 5.0 - ! - endif + ! Loosely based on 3 step calculation in waveparams.F90 of XBeach (build_jonswap, build_etdir, build_boundw), here all in 1 subroutine compute_herbers + ! + if (hsinc / depth > 0.5) then + ! + write(logstr, *)'ERROR SnapWave - Hs over depth at boundary input point ', x_bwv, ',', y_bwv,' is larger then 0.5: ', hsinc / depth + call write_log(logstr, 0) + write(logstr, *)'This may lead to large values of Hm0ig as bc, especially when directional spreading is low! Please specify input in deeper water.' + call write_log(logstr, 0) + write(logstr,*)'Depth set back to 2.0 * hsinc meters for stability, simulation will continue.' + call write_log(logstr, 0) + ! + depth = 2.0 * hsinc + ! + elseif (depth > 200.0) then + ! + ! Limit depth to 200 m. Larger depth can result in NaNs. @Tim, why? + ! + depth = 200.0 + ! + endif ! call compute_herbers(hsig, Tm01, Tm10, Tp, Tpsmooth, hsinc, tpinc, scoeff, jonswapgam, depth, correctHm0) ![out,out,out,out,out, in,in,in,in,in,in] ! @@ -69,9 +73,7 @@ subroutine determine_ig_bc(x_bwv, y_bwv, hsinc, tpinc, ds, jonswapgam, depth, Ti call write_log(logstr, 1) hsig = max(hsig, 0.0) ! - endif - ! - if (hsig > 3.0) then + elseif (hsig > 3.0) then ! write(logstr,*)'DEBUG SnapWave - computed hm0ig at boundary exceeds 3 meter: ',hsig, ' - please check whether this might be realistic!' call write_log(logstr, 1) diff --git a/source/src/snapwave/snapwave_ncoutput.F90 b/source/src/snapwave/snapwave_ncoutput.F90 new file mode 100644 index 000000000..bd2710fb0 --- /dev/null +++ b/source/src/snapwave/snapwave_ncoutput.F90 @@ -0,0 +1,140 @@ +#define NF90(nf90call) call handle_err(nf90call,__FILE__,__LINE__) +module snapwave_ncoutput + ! + use sfincs_log + use netcdf + ! + implicit none + ! + contains + ! + subroutine write_snapwave_mesh(fname, crsgeo) + ! + use snapwave_data + ! + implicit none + ! + character(len=256), intent(in) :: fname + logical, intent(in) :: crsgeo + ! + integer :: ncid + integer :: nmesh2d_node_dimid, nmesh2d_face_dimid, max_nmesh2d_face_nodes_dimid + integer :: mesh2d_varid + integer :: mesh2d_node_x_varid, mesh2d_node_y_varid, crs_varid + integer :: mesh2d_face_nodes_varid + integer :: zb_varid + ! + integer, parameter :: nc_deflate_level = 2 + real*4, parameter :: FILL_VALUE = -99999.0 + ! + ! dimensions + NF90(nf90_create(trim(fname), ior(NF90_CLOBBER, NF90_NETCDF4), ncid)) + NF90(nf90_def_dim(ncid, 'nmesh2d_node', no_nodes, nmesh2d_node_dimid)) + NF90(nf90_def_dim(ncid, 'nmesh2d_face', no_faces, nmesh2d_face_dimid)) + NF90(nf90_def_dim(ncid, 'max_nmesh2d_face_nodes', 4, max_nmesh2d_face_nodes_dimid)) + ! + ! global attributes + NF90(nf90_put_att(ncid,nf90_global, "Conventions", "Conventions = 'CF-1.8 UGRID-1.0 Deltares-0.10'")) + NF90(nf90_put_att(ncid,nf90_global, "Build-Revision-Date-Netcdf-library", trim(nf90_inq_libvers()))) + NF90(nf90_put_att(ncid,nf90_global, "Producer", "SFINCS model: Super-Fast INundation of CoastS")) + NF90(nf90_put_att(ncid,nf90_global, "Build-Revision", trim(build_revision))) + NF90(nf90_put_att(ncid,nf90_global, "Build-Date", trim(build_date))) + NF90(nf90_put_att(ncid,nf90_global, "title", "Snapwave grid")) + ! + ! mesh topology + NF90(nf90_def_var(ncid, 'mesh2d', NF90_INT, mesh2d_varid)) + NF90(nf90_put_att(ncid, mesh2d_varid, 'cf_role', 'mesh_topology')) + NF90(nf90_put_att(ncid, mesh2d_varid, 'long_name', 'Topology data of 2D network')) + NF90(nf90_put_att(ncid, mesh2d_varid, 'topology_dimension', 2)) + NF90(nf90_put_att(ncid, mesh2d_varid, 'node_coordinates', 'mesh2d_node_x mesh2d_node_y')) + NF90(nf90_put_att(ncid, mesh2d_varid, 'node_dimension', 'nmesh2d_node')) + NF90(nf90_put_att(ncid, mesh2d_varid, 'max_face_nodes_dimension', 'max_nmesh2d_face_nodes')) + NF90(nf90_put_att(ncid, mesh2d_varid, 'face_node_connectivity', 'mesh2d_face_nodes')) + NF90(nf90_put_att(ncid, mesh2d_varid, 'face_dimension', 'nmesh2d_face')) + ! + if (crsgeo) then + ! + NF90(nf90_def_var(ncid, 'mesh2d_node_x', NF90_FLOAT, (/nmesh2d_node_dimid/), mesh2d_node_x_varid)) ! location of zb, zs etc. in cell centre + NF90(nf90_def_var_deflate(ncid, mesh2d_node_x_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'units', 'degrees')) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'standard_name', 'longitude')) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'long_name', 'longitude')) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'location', 'node')) + ! + NF90(nf90_def_var(ncid, 'mesh2d_node_y', NF90_FLOAT, (/nmesh2d_node_dimid/), mesh2d_node_y_varid)) ! location of zb, zs etc. in cell centre + NF90(nf90_def_var_deflate(ncid, mesh2d_node_y_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'units', 'degrees')) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'standard_name', 'latitude')) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'long_name', 'latitude')) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'location', 'node')) + ! + else + ! + NF90(nf90_def_var(ncid, 'mesh2d_node_x', NF90_DOUBLE, (/nmesh2d_node_dimid/), mesh2d_node_x_varid)) ! location of zb, zs etc. in cell centre + NF90(nf90_def_var_deflate(ncid, mesh2d_node_x_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'units', 'm')) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'standard_name', 'projection_x_coordinate')) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'long_name', 'x-coordinate of mesh nodes')) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(ncid, mesh2d_node_x_varid, 'location', 'node')) + ! + NF90(nf90_def_var(ncid, 'mesh2d_node_y', NF90_DOUBLE, (/nmesh2d_node_dimid/), mesh2d_node_y_varid)) ! location of zb, zs etc. in cell centre + NF90(nf90_def_var_deflate(ncid, mesh2d_node_y_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'units', 'm')) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'standard_name', 'projection_y_coordinate')) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'long_name', 'y-coordinate of mesh nodes')) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(ncid, mesh2d_node_y_varid, 'location', 'node')) + ! + endif + ! + NF90(nf90_def_var(ncid, 'mesh2d_face_nodes', NF90_INT, (/max_nmesh2d_face_nodes_dimid, nmesh2d_face_dimid/), mesh2d_face_nodes_varid)) ! location of zb, zs etc. in cell centre + NF90(nf90_def_var_deflate(ncid, mesh2d_face_nodes_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(ncid, mesh2d_face_nodes_varid, 'cf_role', 'face_node_connectivity')) + NF90(nf90_put_att(ncid, mesh2d_face_nodes_varid, 'mesh', 'mesh2d')) + NF90(nf90_put_att(ncid, mesh2d_face_nodes_varid, 'location', 'face')) + NF90(nf90_put_att(ncid, mesh2d_face_nodes_varid, 'long_name', 'Mapping from every face to its corner nodes (counterclockwise)')) + NF90(nf90_put_att(ncid, mesh2d_face_nodes_varid, 'start_index', 1)) + NF90(nf90_put_att(ncid, mesh2d_face_nodes_varid, '_FillValue', -999)) + ! + NF90(nf90_def_var(ncid, 'crs', NF90_INT, crs_varid)) ! For EPSG code + NF90(nf90_put_att(ncid, crs_varid, 'EPSG', '-')) + ! + NF90(nf90_def_var(ncid, 'mesh2d_node_z', NF90_FLOAT, (/nmesh2d_node_dimid/), zb_varid)) ! bed level in cell centre + NF90(nf90_def_var_deflate(ncid, zb_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(ncid, zb_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(ncid, zb_varid, 'units', 'm')) + NF90(nf90_put_att(ncid, zb_varid, 'standard_name', 'altitude')) + NF90(nf90_put_att(ncid, zb_varid, 'long_name', 'bed_level_above_reference_level')) + ! + NF90(nf90_enddef(ncid)) + ! + ! put variables + NF90(nf90_put_var(ncid, mesh2d_node_x_varid, x)) ! write node x + NF90(nf90_put_var(ncid, mesh2d_node_y_varid, y)) ! write node y + NF90(nf90_put_var(ncid, mesh2d_face_nodes_varid, face_nodes)) + NF90(nf90_put_var(ncid, zb_varid, zb)) + + ! close file + NF90(nf90_close(ncid)) + + end subroutine write_snapwave_mesh + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine handle_err(status,file,line) + ! + integer, intent ( in) :: status + character(*), intent(in) :: file + integer, intent ( in) :: line + integer :: status2 + + if(status /= nf90_noerr) then + ! !UNIT=6 for stdout and UNIT=0 for stderr. + write(0,'("NETCDF ERROR: ",a,i6,":",a)') file,line,trim(nf90_strerror(status)) + end if + end subroutine handle_err + ! + end module \ No newline at end of file diff --git a/source/src/snapwave/snapwave_solver.f90 b/source/src/snapwave/snapwave_solver.f90 index 53cc31d77..d5ac4d7a4 100644 --- a/source/src/snapwave/snapwave_solver.f90 +++ b/source/src/snapwave/snapwave_solver.f90 @@ -1,9 +1,10 @@ -module snapwave_solver +module snapwave_solver - use sfincs_log + use sfincs_log - implicit none - contains + implicit none + +contains subroutine compute_wave_field() ! @@ -13,10 +14,7 @@ subroutine compute_wave_field() ! !real*8, intent(in) :: time > TL: not used in this implementation ! - real*4 :: tpb - ! real*4, parameter :: waveps = 1e-5 - !real*4, dimension(:), allocatable :: sig real*4, dimension(:), allocatable :: sigm_ig real*4, dimension(:), allocatable :: expon ! @@ -27,7 +25,7 @@ subroutine compute_wave_field() allocate(sigm_ig(no_nodes)) ! g = 9.81 - pi = 4.*atan(1.) + pi = 4 * atan(1.0) ! call timer(t0) ! @@ -35,85 +33,120 @@ subroutine compute_wave_field() ! ! Set energies to 0.0; note that boundary values have been set in update_boundaries ! + !$omp parallel do schedule(static) do k = 1, no_nodes if (inner(k)) then - ee(:,k) = waveps + ee(:, k) = waveps endif enddo + !$omp end parallel do ! ee_ig = waveps ! - restart=1 !TODO TL: CHECK > we need this turned on right now for IG... - ! endif ! ! Initialize wave period ! + !$omp parallel do schedule(static) do k = 1, no_nodes + ! if (inner(k)) then + ! Tp(k) = Tpini + ! endif - if (neumannconnected(k)>0) then - Tp(neumannconnected(k))=Tpini + ! + if (neumannconnected(k) > 0) then + ! + Tp(neumannconnected(k)) = Tpini + ! endif + ! enddo + !$omp end parallel do ! ! Compute celerities and refraction speed ! - Tp = max(tpmean_bwv,Tpini) ! to check voor windgroei - sig = 2.0*pi/Tp + Tp = max(tpmean_bwv, Tpini) ! to check voor windgroei + sig = 2.0 * pi / Tp Tp_ig = tpmean_bwv_ig! TL: now determined in snapwave_boundaries.f90 instead of Tinc2ig*Tp - sigm_ig = 2.0*pi/Tp_ig !TODO - TL: Question do we want Tp_ig now as contant, or also spatially varying like Tp ? - ! - expon = -(sig*sqrt(depth/g))**(2.5) - kwav = sig**2/g*(1.0-exp(expon))**(-0.4) - C = sig/kwav - nwav = 0.5+kwav*depth/sinh(min(2*kwav*depth,50.0)) - Cg = nwav*C + sigm_ig = 2.0 * pi / Tp_ig !TODO - TL: Question do we want Tp_ig now as contant, or also spatially varying like Tp ? + expon = - (sig * sqrt(depth / g))**2.5 + kwav = sig**2 / g * (1.0 - exp(expon))**-0.4 + C = sig / kwav + nwav = 0.5 + kwav * depth / sinh(min(2 * kwav * depth, 50.0)) + Cg = nwav * C ! if (igwaves) then + ! cg_ig = Cg - expon = -(sigm_ig*sqrt(depth/g))**(2.5) - kwav_ig = sig**2/g*(1.0-exp(expon))**(-0.4) + expon = -(sigm_ig * sqrt(depth / g))**2.5 + kwav_ig = sigm_ig**2 / g * (1.0 - exp(expon))**-0.4 + ! else + ! cg_ig = 0.0 kwav_ig = 0.0 + ! endif ! + ! Set Hmx and sinh(kh) for regular waves, and Hmx_ig for IG waves. Note that we use the same gamma for regular and IG waves, but this can be easily changed if needed. + ! + !$omp parallel do schedule(static) do k = 1, no_nodes - sinhkh(k) = sinh(min(kwav(k)*depth(k), 50.0)) - Hmx(k) = gamma*depth(k) + ! + sinhkh(k) = sinh(min(kwav(k) * depth(k), 50.0)) + !Hmx(k) = 0.88 / kwav(k) * tanh(gamma * kwav(k) * depth(k) / 0.88) + Hmx(k) = gamma * depth(k) + ! + if (igwaves) then + ! + ! Why is this different from Hmx for regular waves where we use gamma * h? + ! + Hmx_ig(k) = 0.88 / kwav_ig(k) * tanh(gamma_ig * kwav_ig(k) * depth(k) / 0.88) ! Note - uses gamma_ig + !Hmx_ig(k) = gamma_ig * depth(k) + ! + endif + ! enddo - if (igwaves) then - do k = 1, no_nodes - Hmx_ig(k) = 0.88/kwav_ig(k)*tanh(gamma_ig*kwav_ig(k)*depth(k)/0.88) ! Note - uses gamma_ig - enddo - else - Hmx_ig = 0.0 - endif + !$omp end parallel do ! do itheta = 1, ntheta - ctheta(itheta,:) = sig/sinh(min(2.0*kwav*depth, 50.0))*(dhdx*sin(theta(itheta)) - dhdy*cos(theta(itheta))) + ! + ctheta(itheta,:) = sig / sinh(min(2 * kwav * depth, 50.0)) * (dhdx * sin(theta(itheta)) - dhdy * cos(theta(itheta))) + ! enddo ! if (igwaves) then + ! do itheta = 1, ntheta - ctheta_ig(itheta,:) = sigm_ig/sinh(min(2.0*kwav_ig*depth, 50.0))*(dhdx*sin(theta(itheta)) - dhdy*cos(theta(itheta))) + ctheta_ig(itheta,:) = sigm_ig / sinh(min(2 * kwav_ig * depth, 50.0)) * (dhdx * sin(theta(itheta)) - dhdy * cos(theta(itheta))) enddo + ! else + ! ctheta_ig = 0.0 + ! endif ! ! Limit unrealistic refraction speed to 1/2 pi per wave period ! + !$omp parallel do schedule(static) do k = 1, no_nodes - ctheta(:,k) = sign(1.0, ctheta(:,k))*min(abs(ctheta(:, k)), sig(k)/4) + ! + ctheta(:,k) = sign(1.0, ctheta(:,k)) * min(abs(ctheta(:, k)), sig(k) / 4) + ! enddo + !$omp end parallel do ! if (igwaves) then - do k=1, no_nodes - ctheta_ig(:,k) = sign(1.0, ctheta_ig(:,k))*min(abs(ctheta_ig(:, k)), sigm_ig(k)/4.0) - enddo + !$omp parallel do schedule(static) + do k=1, no_nodes + ! + ctheta_ig(:,k) = sign(1.0, ctheta_ig(:,k)) * min(abs(ctheta_ig(:, k)), sigm_ig(k) / 4) + ! + enddo + !$omp end parallel do endif ! ! Solve the directional wave energy balance on an unstructured grid @@ -121,49 +154,51 @@ subroutine compute_wave_field() call timer(t2) ! call solve_energy_balance2Dstat (x,y,dhdx, dhdy, no_nodes,inner, & - w, ds, prev, & - neumannconnected, & + w, ds, prev, & + neumannconnected, & theta,ntheta,thetamean, & - depth,kwav,cg,ctheta,fw, & + depth,kwav,cg,ctheta,fw, & Tp,Tp_ig,dt,rho,alpha,gamma, gammax, & - wind, & - H,Dw,F,Df,thetam,sinhkh,& + wind, & + H,Dw,F,Df,thetam,sinhkh, & Hmx, ee, windspreadfac, u10, niter, crit, & - hmin, baldock_ratio, baldock_ratio_ig, & - aa, sig, jadcgdx, sigmin, sigmax,& + hmin, baldock_ratio, baldock_ratio_ig, baldock_exponent, & + aa, sig, jadcgdx, sigmin, sigmax, & + DoverE, relax_factor_DoverE, relax_factor_DoverA, & c_dispT, WsorE, WsorA, SwE, SwA, Tpini, & - igwaves,kwav_ig, cg_ig,H_ig,ctheta_ig,Hmx_ig, ee_ig,fw_ig, & + igwaves, kwav_ig, cg_ig,H_ig,ctheta_ig,Hmx_ig, ee_ig,fw_ig, & beta, srcig, alphaig, Dw_ig, Df_ig, & vegetation, no_secveg, veg_ah, veg_bstems, veg_Nstems, veg_Cd, Dveg, & - zb, nwav, ig_opt, alpha_ig, gamma_ig, eeinc2ig, Tinc2ig, alphaigfac, shinc2ig, iterative_srcig) + zb, nwav, ig_opt, alpha_ig, gamma_ig, gamma_fac_br, eeinc2ig, Tinc2ig, alphaigfac, shinc2ig, iterative_srcig) ! call timer(t3) ! - Fx = F*cos(thetam) - Fy = F*sin(thetam) + Fx = F * cos(thetam) + Fy = F * sin(thetam) ! end subroutine + subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & - w, ds, prev, & - neumannconnected, & + w, ds, prev, & + neumannconnected, & theta,ntheta,thetamean, & - depth,kwav,cg,ctheta,fw, & + depth,kwav,cg,ctheta,fw, & Tp,T_ig,dt,rho,alfa,gamma, gammax, & - wind, & - H,Dw,F,Df,thetam,sinhkh,& + wind, & + H,Dw,F,Df,thetam,sinhkh, & Hmx, ee, windspreadfac, u10, niter, crit, & - hmin, baldock_ratio, baldock_ratio_ig, & - aa, sig, jadcgdx, sigmin, sigmax,& + hmin, baldock_ratio, baldock_ratio_ig, baldock_exponent, & + aa, sig, jadcgdx, sigmin, sigmax, & + DoverE, relax_factor_DoverE, relax_factor_DoverA, & c_dispT, WsorE, WsorA, SwE, SwA, Tpini, & igwaves,kwav_ig, cg_ig,H_ig,ctheta_ig,Hmx_ig, ee_ig,fw_ig, & betamean, srcig, alphaig, Dw_ig, Df_ig, & vegetation, no_secveg, veg_ah, veg_bstems, veg_Nstems, veg_Cd, Dveg, & - zb, nwav, ig_opt, alfa_ig, gamma_ig, eeinc2ig, Tinc2ig, alphaigfac, shinc2ig, iterative_srcig) + zb, nwav, ig_opt, alfa_ig, gamma_ig, gamma_fac_br, eeinc2ig, Tinc2ig, alphaigfac, shinc2ig, iterative_srcig) ! use snapwave_windsource - !use snapwave_ncoutput ! TL: removed, we don't use this in SF+SW ! implicit none ! @@ -203,7 +238,7 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & real*4, intent(in) :: alfa,gamma, gammax ! coefficients in Baldock wave breaking dissipation real*4, intent(in) :: baldock_ratio ! option controlling from what depth wave breaking should take place: (Hk>baldock_ratio*Hmx(k)), default baldock_ratio=0.2 real*4, intent(in) :: baldock_ratio_ig ! option controlling from what depth wave breaking should take place for IG waves: (Hk_ig>baldock_ratio_ig*Hmx_ig(k)), default baldock_ratio_ig=0.2 - real*4, dimension(no_nodes), intent(inout) :: H ! wave height - TODO - TL - CHECK > inout needed to have updated 'H' for determining srcig + real*4, dimension(no_nodes), intent(out) :: H ! wave height real*4, dimension(no_nodes), intent(out) :: H_ig ! wave height real*4, dimension(no_nodes), intent(out) :: Dw ! wave breaking dissipation real*4, dimension(no_nodes), intent(out) :: Dw_ig ! wave breaking dissipation IG @@ -219,7 +254,9 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & real*4, dimension(no_nodes), intent(in) :: u10 ! wind speed and direction integer, intent(in) :: niter ! max number of iterations real*4, intent(in) :: crit ! relative accuracy for stopping criterion - integer :: ig_opt ! option of IG wave settings (1 = default = conservative shoaling based dSxx as in Leijnse et al. 2024) + integer, intent(in) :: ig_opt ! option of IG wave settings (1 = default = conservative shoaling based dSxx as in Leijnse et al. 2024) + real*4, intent(in) :: relax_factor_DoverA ! underrelaxation factor for DoverA (set to 1.0 to disable) + real*4, intent(in) :: relax_factor_DoverE ! underrelaxation factor for DoverE (set to 1.0 to disable) ! ! wind source vars ! @@ -227,6 +264,7 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & real*4, intent(in) :: sigmin, sigmax, c_dispT real*4, dimension(ntheta, no_nodes), intent(in) :: windspreadfac !< [-] distribution array for wind input real*4, dimension(ntheta,no_nodes), intent(inout) :: aa + real*4, dimension(no_nodes), intent(inout) :: DoverE real*4, dimension(ntheta,no_nodes), intent(out) :: WsorE, WsorA real*4, dimension(no_nodes), intent(out) :: SwE, SwA real*4, dimension(no_nodes), intent(inout) :: sig @@ -236,23 +274,30 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & ! logical, intent(in) :: vegetation ! logical yes/no real*4, dimension(no_nodes), intent(out) :: Dveg ! dissipation by vegetation: N.B. spatial field! - integer, intent(in) :: no_secveg + integer, intent(in) :: no_secveg ! number of sections in the vertical real*4, dimension(no_nodes,no_secveg), intent(in) :: veg_ah ! Height of vertical sections used in vegetation schematization [m wrt zb_ini (zb0)] real*4, dimension(no_nodes,no_secveg), intent(in) :: veg_bstems ! Width/diameter of individual vegetation stems [m] real*4, dimension(no_nodes,no_secveg), intent(in) :: veg_Nstems ! Number of vegetation stems per unit horizontal area [m-2] real*4, dimension(no_nodes,no_secveg), intent(in) :: veg_Cd ! Bulk drag coefficient [-] real*4 :: Dvegk ! dissipation by vegetation: N.B. scalar value! + real*4, dimension(no_nodes) :: Fvw ! vegetation wave drag force + real*4, dimension(no_nodes,50) :: unl ! non-linear wave orbital velocity time series, in 50 points per wave length + real*4, dimension(no_nodes,50) :: etaw0 ! non-linear sea surface time series, in 50 points per wave length ! ! ! Local variables and arrays ! integer, dimension(:), allocatable :: ok ! mask for fully iterated points - real*4 :: eemax,dtheta ! maximum wave energy density, directional resolution + integer, dimension(:), allocatable :: ok_ig ! mask for fully iterated IG points + real*4 :: dtheta ! directional resolution + real*4 :: eemax ! maximum wave energy density + real*4 :: eemax_ig ! maximum IG wave energy density real*4 :: uorbi integer :: sweep,iter ! sweep number, number of iterations integer :: k,k1,k2,count,kn,itheta ! counters (k is grid index) integer, dimension(:,:), allocatable :: indx ! index for grid sorted per sweep direction real*4, dimension(:,:), allocatable :: eeold ! wave energy density, energy density previous iteration + real*4, dimension(:,:), allocatable :: eeold_ig ! IG wave energy density, energy density previous iteration real*4, dimension(:), allocatable :: Eold ! mean wave energy, previous iteration real*4, dimension(:,:), allocatable :: srcig_local ! Energy source/sink term because of IG wave energy transfer from incident waves real*4, dimension(:,:), allocatable :: beta_local ! Local bed slope based on bed level per direction @@ -264,20 +309,18 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & real*4, dimension(:), allocatable :: A,B,C,R ! coefficients in the tridiagonal matrix solved per point real*4, dimension(:), allocatable :: B_aa,R_aa,aaprev ! coefficients in the tridiagonal matrix solved per point real*4, dimension(:), allocatable :: A_ig,B_ig,C_ig,R_ig ! coefficients in the tridiagonal matrix solved per point - real*4, dimension(:), allocatable :: DoverE ! ratio of mean wave dissipation over mean wave energy real*4, dimension(:), allocatable :: DoverA ! ratio of mean wave dissipation over mean wave energy real*4, dimension(:), allocatable :: DoverE_ig ! ratio of mean wave dissipation over mean wave energy real*4, dimension(:), allocatable :: E ! mean wave energy real*4, dimension(:), allocatable :: E_ig ! mean wave energy real*4, dimension(:), allocatable :: diff ! maximum difference of wave energy relative to previous iteration + real*4, dimension(:), allocatable :: diff_ig ! maximum difference of IG wave energy relative to previous iteration real*4, dimension(:), allocatable :: ra ! coordinate in sweep direction - !real*4, dimension(:), allocatable :: sig real*4, dimension(:), allocatable :: sigm_ig integer, dimension(4) :: shift - real*4 :: pi = 4.*atan(1.0) - real*4 :: g=9.81 + real*4 :: pi = 4.0 * atan(1.0) + real*4 :: g = 9.81 real*4 :: hmin ! minimum water depth! TL: make user changeable also here according to 'snapwave_hmin' in sfincs.inp - real*4 :: fac=1.0 ! underrelaxation factor for DoverA real*4 :: oneoverdt real*4 :: oneover2dtheta real*4 :: rhog8 @@ -286,32 +329,37 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & real*4 :: Ek real*4 :: Hk real*4 :: percok + real*4 :: percok_ig ! percentage of converged IG points real*4 :: error + real*4 :: error_ig ! relative maximum IG wave error real*4 :: Dfk_ig real*4 :: Dwk_ig real*4 :: Ek_ig real*4 :: Hk_ig real*4 :: alfa_ig,gamma_ig ! coefficients in Baldock wave breaking dissipation model for IG waves + real*4 :: gamma_fac_br ! factor times gamma that is used to determine the maximum incident wave breaking point in the surf zone using local incident wave height over water depth ratio, among others used to set the IG source term to 0 shallower than this point real*4 :: eeinc2ig ! ratio of incident wave energy as first estimate of IG wave energy at boundary real*4 :: Tinc2ig ! ratio compared to period Tinc to estimate Tig real*4 :: alphaigfac ! Multiplication factor for IG shoaling source/sink term, default = 1.0 real*4 :: shinc2ig ! Ratio of how much of the calculated IG wave source term, is subtracted from the incident wave energy (0-1, 0=default) integer, save :: callno=1 + integer, intent(in) :: baldock_exponent ! Exponent for multiplying the Baldock dissipation with a factor 'f = (Hloc / Hmax)**iexp' to enhance breaking when H > Hmax, with iexp = 0 (default, means unused), 1 or 2 ! - real*4, dimension(ntheta) :: sinth,costh ! distribution of wave angles and offshore wave energy density + real*4, dimension(ntheta) :: sinth, costh ! distribution of wave angles and offshore wave energy density ! - !local wind source vars + ! Local wind source vars ! real*4 :: Ak real*4 :: DwT real*4 :: DwAk - real*4 :: ndissip ! - real*4 :: depthlimfac=1.0 + real*4 :: ndissip + real*4 :: depthlimfac real*4 :: waveps=0.0001 ! ! Allocate local arrays ! - waveps = 0.0001 + waveps = 0.0001 + ! allocate(ok(no_nodes)); ok=0 allocate(indx(no_nodes,4)); indx=0 allocate(eeold(ntheta,no_nodes)); eeold=0.0 @@ -322,7 +370,6 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & allocate(B(ntheta)); B=0.0 allocate(C(ntheta)); C=0.0 allocate(R(ntheta)); R=0.0 - allocate(DoverE(no_nodes)); DoverE=0.0 allocate(E(no_nodes)); E=waveps allocate(Eold(no_nodes)); Eold=0.0 ! @@ -335,11 +382,13 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & allocate(cgprev_ig(ntheta)); cgprev_ig=0.0 allocate(DoverE_ig(no_nodes)); DoverE_ig=0.0 allocate(E_ig(no_nodes)); E_ig=waveps - !allocate(T_ig(no_nodes)); T_ig=0.0 allocate(sigm_ig(no_nodes)); sigm_ig=0.0 - allocate(depthprev(ntheta,no_nodes)); depthprev=0.0 - allocate(beta_local(ntheta,no_nodes)); beta_local=0.0 + allocate(depthprev(ntheta,no_nodes)); depthprev=0.0 + allocate(beta_local(ntheta,no_nodes)); beta_local=0.0 allocate(alphaig_local(ntheta,no_nodes)); alphaig_local=0.0 + allocate(eeold_ig(ntheta,no_nodes)); eeold_ig=0.0 + allocate(diff_ig(no_nodes)); diff_ig=0.0 + allocate(ok_ig(no_nodes)); ok_ig=0 endif ! if (wind) then @@ -358,55 +407,99 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & costh(itheta) = cos(theta(itheta)) enddo ! - df = 0.0 - dw = 0.0 + Df = 0.0 + Dw = 0.0 + Dveg = 0.0 F = 0.0 ! - ok = 0 - indx = 0 - eemax = maxval(ee) - dtheta = theta(2) - theta(1) - if (dtheta<0.) dtheta = dtheta + 2.*pi + ok = 0 + indx = 0 + eemax = maxval(ee) + if (igwaves) then + ok_ig = 0 + eemax_ig = maxval(ee_ig) + endif + dtheta = theta(2) - theta(1) + ! + if (dtheta < 0.0) dtheta = dtheta + 2*pi + ! if (wind) then - sig = 2*pi/Tpini + ! + sig = 2 * pi / Tpini + ! else - sig = 2*pi/Tp + ! + sig = 2 * pi / Tp + ! endif - oneoverdt = 1.0/dt - oneover2dtheta = 1.0/2.0/dtheta - rhog8 = 0.125*rho*g + ! + oneoverdt = 1.0 / dt + oneover2dtheta = 1.0 / 2.0 / dtheta + rhog8 = 0.125 * rho * g thetam = 0.0 !H = 0.0 ! TODO - TL: CHeck > needed for restart for IG > set to 0 now in snapwave_domain.f90 Dveg = 0.0 + Fvw = 0.0 + unl = 0.0 + etaw0 = 0.0 ! if (igwaves) then - !T_ig = Tinc2ig*Tp - sigm_ig = 2*pi/T_ig + ! + sigm_ig = 2 * pi / T_ig DoverE_ig = 0.0 + ! endif ! if (wind) then - DoverA = 0.0 + ! + DoverA = 0.0 ndissip = 3.0 WsorE = 0.0 WsorA = 0.0 - Ak = waveps/sigmax + Ak = waveps / sigmax + ! + ! Re-initialise Tp at inner / neumann-connected cells only; + ! boundary cells must keep their prescribed Tp (set by + ! update_boundaries) so the wind iteration starts from the + ! correct boundary forcing. + ! + do k = 1, no_nodes + ! + if (inner(k)) Tp(k) = Tpini + if (neumannconnected(k) > 0) Tp(neumannconnected(k)) = Tpini + ! + enddo + ! + do k = 1, no_nodes + ! + sig(k) = 2 * pi / Tp(k) + sig(k) = min(max(sig(k), sigmin), sigmax) + ! + if (.not. inner(k)) then + aa(:, k) = max(ee(:, k), waveps) / sig(k) + endif + ! + call compute_celerities(depth(k), sig(k), sinth, costh, ntheta, gamma, dhdx(k), dhdy(k), sinhkh(k), Hmx(k), kwav(k), cg(k), ctheta(:,k)) + ! + enddo + ! endif ! - ! Sort coordinates in sweep directions + ! Sort coordinates in sweep directions (can we not do this already in snapwave_domain?) + ! + shift = [0, 1, -1, 2] ! - shift = [0,1,-1,2] do sweep = 1, 4 ! - ra = x*cos(thetamean + 0.5*pi*shift(sweep)) + y*sin(thetamean + 0.5*pi*shift(sweep)) + ra = x * cos(thetamean + 0.5 * pi * shift(sweep)) + y * sin(thetamean + 0.5 * pi * shift(sweep)) call hpsort_eps_epw(no_nodes, ra , indx(:, sweep), 1.0e-6) ! enddo - ! - ! Set inner to false for all points at grid edge or adjacent to dry point ! - do k=1,no_nodes - ! + ! Set inner to false for all points at grid edge + ! + do k = 1, no_nodes + ! do itheta = 1, ntheta ! k1 = prev(1, itheta, k) @@ -418,148 +511,116 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & ! inner(k) = .false. ! - elseif ((k1==1 .and. k2==1)) then ! TL: for now still needed for a working IG solver - inner(k)=.false. - exit - !elseif (depth(k1) < hmin .or. depth(k2) < hmin .or. (k1 == 1 .and. k2 == 1)) then + elseif (k1==1 .and. k2==1) then ! TL: for now still needed for a working IG solver ! - ! Do not change inner here! It should be static! In a next update of the wave fields, these points may be wet. - ! - !inner(k) = .false. - ! - !exit + inner(k) = .false. + exit ! endif + ! enddo enddo ! + ! Start iteration ! - ! 0-a) Set boundary and initial conditions - ! - do k = 1, no_nodes + do iter = 1, niter * 4 + ! + sweep = mod(iter, 4) !TODO - TL: problem that we don't have option for sweep = 1 anymore? + ! + if (sweep == 0) then + sweep = 4 + endif + ! + !write(*,*)'iter:', iter, 'sweep:', sweep ! - ! Boundary condition at sea side (uniform) + ! At start of each sweep, compute E, H, E_ig and H_ig, and aa ! - if (.not.inner(k)) then + !$omp parallel do private(kn) schedule(static) + do k = 1, no_nodes + ! + if (ok(k) == 1) cycle ! - ee(:,k)=max(ee(:,k),waveps) - E(k) = sum(ee(:, k))*dtheta - H(k) = sqrt(8*E(k)/rho/g) - thetam(k) = atan2(sum(ee(:, k)*sin(theta)), sum(ee(:, k)*cos(theta))) + ee(:, k) = max(ee(:, k), waveps) ! - !ee_ig(:, k) = eeinc2ig*ee(:,k) !TODO TL: determined in snapwave_boundaries.f90 + E(k) = sum(ee(:, k)) * dtheta + H(k) = sqrt(8 * E(k) / rho / g) ! - if (igwaves) then - E_ig(k) = sum(ee_ig(:, k))*dtheta - H_ig(k) = sqrt(8*E_ig(k)/rho/g) + if (igwaves) then + ! + E_ig(k) = sum(ee_ig(:, k)) * dtheta + H_ig(k) = sqrt(8 * E_ig(k) / rho / g) + ! endif - ! - if (wind) then - sig(k) = 2*pi/Tp(k) - !aa(:,k) = max(aa(:,k),waveps/sig(k)) - aa(:,k) = max(ee(:,k),waveps)/sig(k) - Ak = E(k)/sig(k) + ! + ! Set Neumann boundaries + ! + if (neumannconnected(k) /= 0) then + ! + ! Do we really need all of these? Hmx? + ! + kn = neumannconnected(k) ! Index of internal point + ! + sinhkh(k) = sinhkh(kn) + kwav(k) = kwav(kn) + Hmx(k) = Hmx(kn) + ee(:, k) = ee(:, kn) + ee_ig(:, k) = ee_ig(:, kn) + ctheta(:, k) = ctheta(:, kn) + cg(k) = cg(kn) + ! + if (wind) then + ! + sig(k) = sig(kn) + Tp(k) = 2 * pi / sig(kn) + WsorE(:, k) = WsorE(:, kn) + WsorA(:, k) = WsorA(:, kn) + aa(:, k) = aa(:, kn) + ! + endif + ! + Df(k) = Df(kn) + Dw(k) = Dw(kn) + ! endif ! - endif - enddo - ! - ! 0-b) Determine IG source/sink term - ! - if (igwaves) then - ! - ! As defined in Leijnse, van Ormondt, van Dongeren, Aerts & Muis et al. 2024 - ! - ! Actual determining of source term: - ! - call determine_infragravity_source_sink_term(inner, no_nodes, ntheta, w, ds, prev, cg_ig, nwav, depth, zb, H, ee, ee_ig, eeprev, eeprev_ig, cgprev, ig_opt, alphaigfac, alphaig_local, beta_local, srcig_local) - ! - ! inout: alphaig_local, srcig_local - eeprev, eeprev_ig, cgprev, beta_local - ! in: the rest - ! - ! NOTE - This is based on the energy in the precious SnapWave timestep 'ee' and 'ee_ig', and waveheight 'H', which should therefore be made available. + enddo + !$omp end parallel do ! - endif - ! - ! 0-c) Set initial condition at inner cells - ! - do k = 1, no_nodes - ! - if (inner(k)) then + if (sweep == 1) then ! - if (wind) then - ee(:,k) = waveps - sig(k) = 2*pi/Tpini - aa(:,k) = ee(:,k)/sig(k) - else - ee(:,k) = waveps - endif + eeold = ee ! - ! Make sure DoverE is filled based on previous ee - Ek = sum(ee(:, k))*dtheta - Hk = min(sqrt(Ek/rhog8), gamma*depth(k)) - Ek = rhog8*Hk**2 - if (.not. wind) then - uorbi = 0.5*sig(k)*Hk/sinhkh(k) - Dfk = 0.28*rho*fw(k)*uorbi**3 - call baldock(rho, g, alfa, gamma, depth(k), Hk, Tp(k), 1, Dwk, Hmx(k)) - DoverE(k) = (Dwk + Dfk)/max(Ek, 1.0e-6) + if (igwaves) then + ! + eeold_ig = ee_ig + ! endif ! - if (wind) then - call compute_celerities(depth(k), sig(k), sinth, costh, ntheta, gamma, dhdx(k), dhdy(k), sinhkh(k), Hmx(k), kwav(k), cg(k), ctheta(:,k)) - uorbi = 0.5*sig(k)*Hk/sinhkh(k) - Dfk = 0.28*rho*fw(k)*uorbi**3 - call baldock(rho, g, alfa, gamma, depth(k), Hk, 2.0*pi/sig(k), 1, Dwk, Hmx(k)) - DoverE(k) = (Dwk + Dfk)/max(Ek, 1.0e-6) - ! - ! initial conditions are not equal to bc conditions - DwT = - c_dispT/(1.0 -ndissip)*(2.*pi)/sig(k)**2*cg(k)*kwav(k) * DoverE(k) - DwAk = 0.5/pi * (E(k)*DwT+2.0*pi*Ak*DoverE(k) ) - DoverA(k) = DwAk/max(Ak,1e-6) - endif + !$omp parallel do schedule(static) + do k = 1, no_nodes + ! + Eold(k) = sum(eeold(:, k)) + ! + enddo + !$omp end parallel do ! endif ! - enddo - ! - ! Start iteration - ! - do iter=1,niter - ! - sweep = mod(iter, 4) !TODO - TL: problem that we don't have option for sweep = 1 anymore? - ! - if (sweep==0) then - sweep = 4 - endif + ! Update IG source and sink terms ! - if (sweep==1) then - eeold = ee - do k = 1, no_nodes - Eold(k) = sum(eeold(:, k)) - enddo + if (igwaves) then ! - if (igwaves) then - ! - if (iterative_srcig) then - ! Update H(k) based on updated ee(:,k), as used in IG source term to determine alphaig - ! - do k = 1, no_nodes - ! - if (inner(k)) then - ! - H(k) = sqrt(8*sum(ee(:, k))*dtheta/rho/g) - ! - endif - enddo - ! - ! Actual determining of source term - every first sweep of iteration - ! - call determine_infragravity_source_sink_term(inner, no_nodes, ntheta, w, ds, prev, cg_ig, nwav, depth, zb, H, ee, ee_ig, eeprev, eeprev_ig, cgprev, ig_opt, alphaigfac, alphaig_local, beta_local, srcig_local) - ! - endif + ! Do this in each first sweep, or (in case of iterative_srcig) in every sweep + ! + if (sweep == 1 .or. iterative_srcig) then ! - endif + ! Determining of IG source term as defined in Leijnse et al. 2024 + ! + call determine_infragravity_source_sink_term(inner, no_nodes, ntheta, w, ds, prev, dtheta, cg_ig, nwav, depth, zb, H, & + ee, ee_ig, ig_opt, alphaigfac, & + alphaig_local, beta_local, srcig_local, gamma, gamma_fac_br) + ! + endif ! endif ! @@ -567,278 +628,306 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & ! do count = 1, no_nodes ! - k=indx(count, sweep) + k = indx(count, sweep) ! - if (inner(k)) then - if (depth(k)>1.1*hmin) then - ! - if (ok(k) == 0) then - ! - ! Only perform computations on wet inner points that are not yet converged (ok) - ! - do itheta = 1, ntheta - ! - k1 = prev(1, itheta, k) - k2 = prev(2, itheta, k) - ! - eeprev(itheta) = w(1, itheta, k)*ee(itheta, k1) + w(2, itheta, k)*ee(itheta, k2) - cgprev(itheta) = w(1, itheta, k)*cg(k1) + w(2, itheta, k)*cg(k2) - ! - if (igwaves) then - eeprev_ig(itheta) = w(1, itheta, k)*ee_ig(itheta, k1) + w(2, itheta, k)*ee_ig(itheta, k2) - cgprev_ig(itheta) = w(1, itheta, k)*cg_ig(k1) + w(2, itheta, k)*cg_ig(k2) - endif - ! - if (wind) then - aaprev(itheta) = w(1, itheta, k)*aa(itheta, k1) + w(2, itheta, k)*aa(itheta, k2) - endif - ! - enddo - ! - Ek = sum(eeprev)*dtheta ! to check - ! - depthlimfac = max(1.0, (sqrt(Ek/rhog8)/(gammax*depth(k)))**2.0) - Hk = min(sqrt(Ek/rhog8), gamma*depth(k)) - Ek = Ek/depthlimfac - ! - if (wind) then - ! - Ak = sum(aaprev)*dtheta - ! - Ak = Ak/depthlimfac - ee(:,k) = ee(:,k) / depthlimfac - aa(:,k) = aa(:,k) / depthlimfac - sig(k) = Ek/Ak - sig(k) = max(sig(k),sigmin) - sig(k) = min(sig(k),sigmax) - Ak = Ek/sig(k) ! to avoid small T in windinput - if (wind) then - aaprev=min(aaprev,eeprev/sigmin) - aaprev=max(aaprev,eeprev/sigmax) - endif - ! - call compute_celerities(depth(k), sig(k), sinth, costh, ntheta, gamma, dhdx(k), dhdy(k), sinhkh(k), Hmx(k), kwav(k), cg(k), ctheta(:,k)) - endif - ! - ! Fill DoverE - uorbi = 0.5*sig(k)*Hk/sinhkh(k) - Dfk = 0.28*rho*fw(k)*uorbi**3 - !if (Hk>0.) then ! - if (Hk>baldock_ratio*Hmx(k)) then - call baldock(rho, g, alfa, gamma, depth(k), Hk, 2*pi/sig(k) , 1, Dwk, Hmx(k)) - else - Dwk = 0. - endif - ! - if (vegetation) then - call vegatt(sig(k), no_nodes, kwav(k), no_secveg, veg_ah(k,:), veg_bstems(k,:), veg_Nstems(k,:), veg_Cd(k,:), depth(k), rho, g, Hk, Dvegk) - else - Dvegk = 0. - endif - ! - DoverE(k) = (Dwk + Dfk + Dvegk)/max(Ek, 1.0e-6) - ! - if (wind) then - ! - if (iter==1) then - call windinput(u10(k), rho, g, depth(k), ntheta, windspreadfac(:,k), Ek, Ak, cg(k), eeprev, aaprev, ds(:,k), WsorE(:,k), WsorA(:,k), jadcgdx) - else - call windinput(u10(k), rho, g, depth(k), ntheta, windspreadfac(:,k), Ek, Ak, cg(k), ee(:,k), aa(:,k), ds(:,k), WsorE(:,k), WsorA(:,k), jadcgdx) - endif - ! - DwT = - c_dispT/(1.0 -ndissip)*(2.0*pi)/sig(k)**2*cg(k)*kwav(k) * DoverE(k) - DwAk = 1/2.0/pi * (E(k)*DwT+2.0*pi*Ak*DoverE(k) ) - ! - if (iter==1) then - DoverA(k) = DwAk/max(Ak,1e-6) - else - DoverA(k) = (1.0-fac)*DoverA(k)+fac*DwAk/max(Ak,1.e-6) - endif - ! - call compute_celerities(depth(k), sig(k), sinth, costh, ntheta, gamma, dhdx(k), dhdy(k), sinhkh(k), Hmx(k), kwav(k), cg(k), ctheta(:,k)) - ! - endif - ! - do itheta = 1, ntheta - ! - R(itheta) = oneoverdt*ee(itheta, k) + cgprev(itheta)*eeprev(itheta)/ds(itheta, k) - srcig_local(itheta, k) * shinc2ig - ! - enddo - ! - do itheta = 2, ntheta - 1 - ! - A(itheta) = -ctheta(itheta - 1, k)*oneover2dtheta - B(itheta) = oneoverdt + cg(k)/ds(itheta,k) + DoverE(k) - C(itheta) = ctheta(itheta + 1, k)*oneover2dtheta - ! - enddo - ! - A(1) = -ctheta(ntheta, k)*oneover2dtheta - B(1) = oneoverdt + cg(k)/ds(1,k) + DoverE(k) - C(1) = ctheta(2, k)*oneover2dtheta - ! - A(ntheta) = -ctheta(ntheta - 1, k)*oneover2dtheta - B(ntheta) = oneoverdt + cg(k)/ds(ntheta,k) + DoverE(k) - C(ntheta) = ctheta(1, k)*oneover2dtheta - ! - ! Solve tridiagonal system per point - ! - if (wind) then - do itheta = 2, ntheta - 1 - B_aa(itheta) = oneoverdt + cg(k)/ds(itheta,k) + DoverA(k) - R_aa(itheta) = (oneoverdt)*aa(itheta, k) + cgprev(itheta)*aaprev(itheta)/ds(itheta, k) - enddo - ! - if (ctheta(1,k)<0) then - B_aa(1) = oneoverdt - ctheta(1, k)/dtheta + cg(k)/ds(1, k) + DoverA(k) - R_aa(1) = (oneoverdt)*aa(1, k) + cgprev(1)*aaprev(1)/ds(1, k) - else - B_aa(1) = oneoverdt + cg(k)/ds(1, k) + DoverA(k) - R_aa(1) = (oneoverdt)*aa(1, k) + cgprev(1)*aaprev(1)/ds(1, k) - endif - ! - if (ctheta(ntheta, k)>0) then - B_aa(ntheta) = oneoverdt + ctheta(ntheta, k)/dtheta + cg(k)/ds(ntheta, k) + DoverA(k) - R_aa(ntheta) = (oneoverdt )*aa(ntheta,k) + cgprev(ntheta)*aaprev(ntheta)/ds(ntheta, k) - else - B_aa(ntheta) = oneoverdt + cg(k)/ds(ntheta, k) + DoverA(k) - R_aa(ntheta) = (oneoverdt)*aa(ntheta,k) + cgprev(ntheta)*aaprev(ntheta)/ds(ntheta, k) - endif - R(:) = R(:) + WsorE(:,k) - R_aa(:) = R_aa(:) + WsorA(:,k) - ! - call solve_tridiag(A, B, C, R, ee(:,k), ntheta) - call solve_tridiag(A,B_aa,C,R_aa,aa(:,k),ntheta) - ee(:, k) = max(ee(:, k), waveps) - aa(:,k) = max(aa(:,k),waveps/sigmax) - aa(:,k) = max(aa(:,k),waveps/sig(k)) - ! - Ek = sum(ee(:, k))*dtheta - Ak = sum(aa(:,k))*dtheta - ! - depthlimfac = max(1.0, (sqrt(Ek/rhog8)/(gammax*depth(k)))**2.0) - Hk = sqrt(Ek/rhog8/depthlimfac) - Ek = Ek/depthlimfac - Ak = Ak/depthlimfac - ee(:,k) = ee(:,k)/depthlimfac - aa(:,k) = aa(:,k)/depthlimfac - ! - sig(k) = Ek/Ak - sig(k) = max(sig(k),sigmin) - sig(k) = min(sig(k),sigmax) - call compute_celerities(depth(k), sig(k), sinth, costh, ntheta, gamma, dhdx(k), dhdy(k), sinhkh(k), Hmx(k), kwav(k), cg(k), ctheta(:,k)) - if (sig(k)<0.1) then - a=1 - endif - else - ! - ! Solve tridiagonal system per point - ! - call solve_tridiag(A, B, C, R, ee(:,k), ntheta) - ee(:, k) = max(ee(:, k),waveps) - ! - endif !wind - ! - ! IG - ! - if (igwaves) then - Ek_ig = sum(eeprev_ig)*dtheta - !Hk_ig = sqrt(Ek_ig/rhog8) !org trunk - Hk_ig = min(sqrt(Ek_ig/rhog8), gamma_ig*depth(k)) !TL: Question - why not this one? - Ek_ig = rhog8*Hk_ig**2 - ! - ! Bottom friction Henderson and Bowen (2002) - D = 0.015*rhow*(9.81/depth(k))**1.5*(Hk/sqrt(8.0))*Hk_ig**2/8 - ! - Dfk_ig = fw_ig(k)*0.0361*(9.81/depth(k))**1.5*Hk*Ek_ig - ! - ! Dissipation of infragravity waves - ! - if (Hk_ig>baldock_ratio_ig*Hmx_ig(k)) then - call baldock(rho, g, alfa_ig, gamma_ig, depth(k), Hk_ig, T_ig(k), 1, Dwk_ig, Hmx_ig(k)) - else - Dwk_ig = 0. - endif - ! - DoverE_ig(k) = (Dwk_ig + Dfk_ig)/max(Ek_ig, 1.0e-6) ! org trunk - !DoverE_ig(k) = (1.0 - fac)*DoverE_ig(k) + fac*(Dwk_ig + Dfk_ig)/max(Ek_ig, 1.0e-6) ! TODO - TL CHECK - why not with relaxation anymore? - ! - do itheta = 1, ntheta - ! - R_ig(itheta) = oneoverdt*ee_ig(itheta, k) + cgprev_ig(itheta)*eeprev_ig(itheta)/ds(itheta, k) + srcig_local(itheta, k) !TL: new version - ! - enddo - ! - do itheta = 2, ntheta - 1 - ! - A_ig(itheta) = -ctheta_ig(itheta - 1, k)*oneover2dtheta - B_ig(itheta) = oneoverdt + cg_ig(k)/ds(itheta,k) + DoverE_ig(k) - C_ig(itheta) = ctheta_ig(itheta + 1, k)*oneover2dtheta - ! - enddo - ! - if (ctheta_ig(1,k)<0) then - A_ig(1) = 0.0 - B_ig(1) = oneoverdt - ctheta_ig(1, k)/dtheta + cg_ig(k)/ds(1, k) + DoverE_ig(k) - C_ig(1) = ctheta_ig(2, k)/dtheta - else - A_ig(1)=0.0 - B_ig(1)=1.0/dt + cg_ig(k)/ds(1, k) + DoverE_ig(k) - C_ig(1)=0.0 - endif - ! - if (ctheta_ig(ntheta, k)>0) then - A_ig(ntheta) = -ctheta_ig(ntheta - 1, k)/dtheta - B_ig(ntheta) = oneoverdt + ctheta_ig(ntheta, k)/dtheta + cg_ig(k)/ds(ntheta, k) + DoverE_ig(k) - C_ig(ntheta) = 0.0 - else - A_ig(ntheta) = 0.0 - B_ig(ntheta) = oneoverdt + cg_ig(k)/ds(ntheta, k) + DoverE_ig(k) - C_ig(ntheta) = 0.0 - endif - ! - ! Solve tridiagonal system per point - ! - call solve_tridiag(A_ig, B_ig, C_ig, R_ig, ee_ig(:,k), ntheta) - ee_ig(:, k) = max(ee_ig(:, k), 0.0) - ! - else - ! - ee_ig(:, k) = 0.0 - ! - endif - ! - endif - ! - else - ! - ee(:, k) = 0.0 - if (wind) then - aa(:,k) = 0.0 - endif - ee_ig(:, k) = 0.0 - ! - endif + ! Skip non-inner (boundary) nodes + ! + if (.not. inner(k)) cycle + ! + ! For nodes below minimum depth: zero out energy and skip + ! + if (depth(k) <= hmin) then + ! + ee(:, k) = 0.0 + if (wind) aa(:, k) = 0.0 + ee_ig(:, k) = 0.0 + cycle ! endif ! - if (neumannconnected(k)/=0) then - kn = neumannconnected(k) - sinhkh(kn) = sinhkh(k) - kwav(kn) = kwav(k) - Hmx(kn) = Hmx(k) - ee(:, kn) = ee(:, k) - ee_ig(:, kn) = ee_ig(:, k) ! TL: Added Neumann option for IG - ctheta(:, kn) = ctheta(:, k) - cg(kn) = cg(k) + ! Skip nodes that have already converged + ! + if (ok(k) == 1) cycle + ! + ! Retrieve integrated quantities computed in the start-of-sweep pre-loop + ! + Ek = E(k) + Hk = H(k) + ! + if (igwaves) then + ! + Ek_ig = E_ig(k) + Hk_ig = H_ig(k) + ! + endif + ! + ! --- Step 1: Upwind energy, group velocity (and action for wind) ------------ + ! + do itheta = 1, ntheta + ! + k1 = prev(1, itheta, k) + k2 = prev(2, itheta, k) + ! + eeprev(itheta) = w(1, itheta, k) * ee(itheta, k1) + w(2, itheta, k) * ee(itheta, k2) + cgprev(itheta) = w(1, itheta, k) * cg(k1) + w(2, itheta, k) * cg(k2) + ! + if (igwaves) then + eeprev_ig(itheta) = w(1, itheta, k) * ee_ig(itheta, k1) + w(2, itheta, k) * ee_ig(itheta, k2) + cgprev_ig(itheta) = w(1, itheta, k) * cg_ig(k1) + w(2, itheta, k) * cg_ig(k2) + endif + ! if (wind) then - sig(kn) = sig(k) - Tp(kn) = 2.0*pi/sig(k) - WsorE(:,kn) = WsorE(:,k) - WsorA(:,kn) = WsorA(:,k) - aa(:,kn) = aa(:,k) + aaprev(itheta) = w(1, itheta, k) * aa(itheta, k1) + w(2, itheta, k) * aa(itheta, k2) + aaprev(itheta) = min(aaprev(itheta), eeprev(itheta) / sigmin) + aaprev(itheta) = max(aaprev(itheta), eeprev(itheta) / sigmax) + endif + ! + enddo + ! + ! --- Step 2: Pre-solve sig and celerities from upwind Ek/Ak (wind only) ---- + ! + ! The upwind Ek/Ak provides the best pre-solve estimate of local sig, so that + ! both the ee and aa matrices are assembled with a consistent cg(k). + ! Post-solve, sig is updated from the solved Ek/Ak in Step 6. + ! + if (wind) then + ! + Ek = sum(eeprev) * dtheta + Ak = sum(aaprev) * dtheta + sig(k) = max(min(Ek / Ak, sigmax), sigmin) + Ak = Ek / sig(k) + aaprev = min(aaprev, eeprev / sigmin) + aaprev = max(aaprev, eeprev / sigmax) + call compute_celerities(depth(k), sig(k), sinth, costh, ntheta, gamma, & + dhdx(k), dhdy(k), sinhkh(k), Hmx(k), kwav(k), cg(k), ctheta(:, k)) + ! + endif + ! + ! --- Step 3: Source and sink terms ------------------------------------------ + ! + ! Bottom friction + ! + uorbi = 0.5 * sig(k) * Hk / sinhkh(k) + Dfk = 0.28 * rho * fw(k) * uorbi**3 + ! + ! Wave breaking (Baldock) + ! First check if wave breaking could occur based on Baldock criterion (Hk > baldock_ratio * Hmx(k)) + ! + if (Hk > baldock_ratio * Hmx(k)) then + ! + call baldock(rho, g, alfa, gamma, depth(k), Hk, 2 * pi / sig(k), baldock_exponent, Dwk, Hmx(k)) + ! + else + ! + ! No wave breaking according to Baldock criterion + ! + Dwk = 0.0 + ! + endif + ! + ! Vegetation + ! + if (vegetation) then + ! + call vegatt(sig(k), no_nodes, kwav(k), no_secveg, veg_ah(k, :), veg_bstems(k, :), & + veg_Nstems(k, :), veg_Cd(k, :), depth(k), rho, g, Hk, Dvegk) + ! + else + ! + Dvegk = 0.0 + ! + endif + ! + ! Energy dissipation ratio (with under-relaxation) + ! + DoverE(k) = (1.0 - relax_factor_DoverE) * DoverE(k) & + + relax_factor_DoverE * (Dwk + Dfk + Dvegk) / max(Ek, 1.0e-6) + ! + Df(k) = Dfk + Dw(k) = Dwk + Dveg(k) = Dvegk + ! + ! Wind source terms and action dissipation ratio DoverA (wind only) + ! + if (wind) then + ! + if (iter == 1) then + call windinput(u10(k), rho, g, depth(k), ntheta, windspreadfac(:, k), Ek, Ak, cg(k), & + eeprev, aaprev, ds(:, k), WsorE(:, k), WsorA(:, k), jadcgdx) + else + call windinput(u10(k), rho, g, depth(k), ntheta, windspreadfac(:, k), Ek, Ak, cg(k), & + ee(:, k), aa(:, k), ds(:, k), WsorE(:, k), WsorA(:, k), jadcgdx) + endif + ! + DwT = -c_dispT / (1.0 - ndissip) * (2.0 * pi) / sig(k)**2 * cg(k) * kwav(k) * DoverE(k) + DwAk = 1.0 / (2.0 * pi) * (E(k) * DwT + 2.0 * pi * Ak * DoverE(k)) + ! + if (iter == 1) then + DoverA(k) = DwAk / max(Ak, 1.0e-6) + else + DoverA(k) = (1.0 - relax_factor_DoverA) * DoverA(k) & + + relax_factor_DoverA * DwAk / max(Ak, 1.0e-6) + endif + ! + endif + ! + ! --- Step 4: Assemble and solve energy balance (ee) ------------------------- + ! + do itheta = 1, ntheta + ! + R(itheta) = oneoverdt * ee(itheta, k) + cgprev(itheta) * eeprev(itheta) / ds(itheta, k) & + - srcig_local(itheta, k) * shinc2ig + ! + enddo + ! + do itheta = 2, ntheta - 1 + ! + A(itheta) = -ctheta(itheta - 1, k) * oneover2dtheta + B(itheta) = oneoverdt + cg(k) / ds(itheta, k) + DoverE(k) + C(itheta) = ctheta(itheta + 1, k) * oneover2dtheta + ! + enddo + ! + A(1) = - ctheta(ntheta, k) * oneover2dtheta + B(1) = oneoverdt + cg(k) / ds(1, k) + DoverE(k) + C(1) = ctheta(2, k) * oneover2dtheta + ! + A(ntheta) = -ctheta(ntheta - 1, k) * oneover2dtheta + B(ntheta) = oneoverdt + cg(k) / ds(ntheta, k) + DoverE(k) + C(ntheta) = ctheta(1, k) * oneover2dtheta + ! + if (wind) R(:) = R(:) + WsorE(:, k) + ! + call solve_tridiag(A, B, C, R, ee(:, k), ntheta) + ee(:, k) = max(ee(:, k), waveps) + ! + ! --- Step 5: Assemble and solve action balance (aa, wind only) --------------- + ! + ! A and C are the same as for ee (refraction terms don't change). + ! Only B_aa differs: DoverA instead of DoverE, plus upwind BC for ctheta endpoints. + ! + if (wind) then + ! + do itheta = 2, ntheta - 1 + B_aa(itheta) = oneoverdt + cg(k) / ds(itheta, k) + DoverA(k) + R_aa(itheta) = oneoverdt * aa(itheta, k) + cgprev(itheta) * aaprev(itheta) / ds(itheta, k) + enddo + ! + if (ctheta(1, k) < 0.0) then + B_aa(1) = oneoverdt - ctheta(1, k) / dtheta + cg(k) / ds(1, k) + DoverA(k) + else + B_aa(1) = oneoverdt + cg(k) / ds(1, k) + DoverA(k) + endif + ! + R_aa(1) = oneoverdt * aa(1, k) + cgprev(1) * aaprev(1) / ds(1, k) + ! + if (ctheta(ntheta, k) > 0.0) then + B_aa(ntheta) = oneoverdt + ctheta(ntheta, k) / dtheta + cg(k) / ds(ntheta, k) + DoverA(k) + else + B_aa(ntheta) = oneoverdt + cg(k) / ds(ntheta, k) + DoverA(k) + endif + ! + R_aa(ntheta) = oneoverdt * aa(ntheta, k) + cgprev(ntheta) * aaprev(ntheta) / ds(ntheta, k) + R_aa(:) = R_aa(:) + WsorA(:, k) + ! + call solve_tridiag(A, B_aa, C, R_aa, aa(:, k), ntheta) + ! + aa(:, k) = max(aa(:, k), waveps / sigmax) + aa(:, k) = max(aa(:, k), waveps / sig(k)) + ! + endif + ! + ! --- Step 6: Depth-limit energy (and action), update sig and celerities ----- + ! + Ek = sum(ee(:, k)) * dtheta + depthlimfac = max(1.0, (sqrt(Ek / rhog8) / (gammax * depth(k)))**2) + ee(:, k) = ee(:, k) / depthlimfac + ! +! if (wind) then +! ! +! Ek = Ek / depthlimfac +! Ak = sum(aa(:, k)) * dtheta +! Ak = Ak / depthlimfac +! aa(:, k) = aa(:, k) / depthlimfac +! sig(k) = max(min(Ek / Ak, sigmax), sigmin) +! ! +! call compute_celerities(depth(k), sig(k), sinth, costh, ntheta, gamma, & +! dhdx(k), dhdy(k), sinhkh(k), Hmx(k), kwav(k), cg(k), ctheta(:, k)) +! ! +! endif + ! + ! --- Step 7: IG wave balance (optional) ------------------------------------- + ! + if (igwaves) then + ! + ! Update incident Hk from post-solve ee (needed for IG bottom friction) + ! + Hk = sqrt(8.0 * sum(ee(:, k)) * dtheta / rho / g) + Dfk_ig = fw_ig(k) * 0.0361 * (9.81 / depth(k))**1.5 * Hk * Ek_ig + ! + ! IG wave breaking (Baldock) + ! + if (Hk_ig > baldock_ratio_ig * Hmx_ig(k)) then + call baldock(rho, g, alfa_ig, gamma_ig, depth(k), Hk_ig, T_ig(k), baldock_exponent, Dwk_ig, Hmx_ig(k)) + else + Dwk_ig = 0.0 + endif + ! + Df_ig(k) = Dfk_ig + Dw_ig(k) = Dwk_ig + ! + ! Not using underrelaxation for IG dissipation for now, but we could add this if needed (relax_factor_DoverE_ig) + DoverE_ig(k) = (Dwk_ig + Dfk_ig) / max(Ek_ig, 1.0e-6) + ! + ! + ! IG RHS + ! + do itheta = 1, ntheta + R_ig(itheta) = oneoverdt * ee_ig(itheta, k) & + + cgprev_ig(itheta) * eeprev_ig(itheta) / ds(itheta, k) & + + srcig_local(itheta, k) + enddo + ! + ! IG matrix with directional boundary conditions + ! + do itheta = 2, ntheta - 1 + A_ig(itheta) = -ctheta_ig(itheta - 1, k) * oneover2dtheta + B_ig(itheta) = oneoverdt + cg_ig(k) / ds(itheta, k) + DoverE_ig(k) + C_ig(itheta) = ctheta_ig(itheta + 1, k) * oneover2dtheta + enddo + ! + if (ctheta_ig(1, k) < 0.0) then + A_ig(1) = 0.0 + B_ig(1) = oneoverdt - ctheta_ig(1, k) / dtheta + cg_ig(k) / ds(1, k) + DoverE_ig(k) + C_ig(1) = ctheta_ig(2, k) / dtheta + else + A_ig(1) = 0.0 + B_ig(1) = oneoverdt + cg_ig(k) / ds(1, k) + DoverE_ig(k) + C_ig(1) = 0.0 + endif + ! + if (ctheta_ig(ntheta, k) > 0.0) then + A_ig(ntheta) = -ctheta_ig(ntheta - 1, k) / dtheta + B_ig(ntheta) = oneoverdt + ctheta_ig(ntheta, k) / dtheta + cg_ig(k) / ds(ntheta, k) + DoverE_ig(k) + C_ig(ntheta) = 0.0 + else + A_ig(ntheta) = 0.0 + B_ig(ntheta) = oneoverdt + cg_ig(k) / ds(ntheta, k) + DoverE_ig(k) + C_ig(ntheta) = 0.0 endif - Df(kn) = Df(k) - Dw(kn) = Dw(k) + ! + call solve_tridiag(A_ig, B_ig, C_ig, R_ig, ee_ig(:, k), ntheta) + ee_ig(:, k) = max(ee_ig(:, k), 0.0) + ! + ! Depth-limit IG energy + ! + depthlimfac = max(1.0, (sqrt(sum(ee_ig(:, k)) * dtheta / rhog8) / (gammax * depth(k)))**2) + ee_ig(:, k) = ee_ig(:, k) / depthlimfac + ! + else + ! + ee_ig(:, k) = 0.0 + ! endif ! enddo @@ -847,108 +936,186 @@ subroutine solve_energy_balance2Dstat(x,y,dhdx, dhdy, no_nodes,inner, & ! ! Check convergence after all 4 sweeps ! + !$omp parallel do private(dee) schedule(static) do k = 1, no_nodes ! dee = ee(:, k) - eeold(:, k) diff(k) = maxval(abs(dee)) ! - if (diff(k)/eemax 0 .and. Hloc > Hmax) then + ! + ! Add extra dissipation when Hloc exceeds Hmax. + ! This is needed at very steep coast lines, where Baldock dissipation cannot always keep up with + ! the wave height increase due to shoaling. The extra dissipation is added by multiplying + ! the Baldock dissipation with a factor f, which is larger than 1 when Hloc > Hmax. + ! + f = (Hloc / Hmax)**iexp + ! + else + ! + f = 1.0 + ! endif ! + Dw = 0.28 * alfa * rho * g / T * exp( - (Hmax / Hloc)**2) * (Hmax**2 + Hloc**2) * f + ! + ! Other options for wave breaking dissipation (not used, but left here for reference) + ! + ! Dw = 0.28 * alfa * rho * g / T * exp( - (Hmax / Hloc)**2) * (Hmax**3 + Hloc**3) / gamma / depth + ! end subroutine baldock - subroutine determine_infragravity_source_sink_term(inner, no_nodes, ntheta, w, ds, prev, cg_ig, nwav, depth, zb, H, ee, ee_ig, eeprev, eeprev_ig, cgprev, ig_opt, alphaigfac, alphaig_local, beta_local, srcig_local) + + subroutine determine_infragravity_source_sink_term(inner, no_nodes, ntheta, w, ds, prev, dtheta, cg_ig, nwav, depth, zb, H, ee, ee_ig, ig_opt, alphaigfac, alphaig_local, beta_local, srcig_local, gamma, gamma_fac_br) + ! + ! Determining of IG source term as defined in Leijnse et al. 2024 + ! + ! inout: alphaig_local, srcig_local, beta_local + ! in: the rest + ! + ! NOTE - This is based on the energy in the previous SnapWave timestep 'ee' and 'ee_ig', and waveheight 'H', which should therefore be made available. ! implicit none ! ! Incoming variables + ! logical, dimension(no_nodes), intent(in) :: inner ! mask of inner grid points (not on boundary) integer, intent(in) :: no_nodes,ntheta ! number of grid points, number of directions real*4, dimension(2,ntheta,no_nodes),intent(in) :: w ! weights of upwind grid points, 2 per grid point and per wave direction @@ -1037,73 +1233,129 @@ subroutine determine_infragravity_source_sink_term(inner, no_nodes, ntheta, w, d real*4, dimension(ntheta,no_nodes), intent(in) :: ee_ig ! energy density infragravity waves integer, intent(in) :: ig_opt ! option of IG wave settings (1 = default = conservative shoaling based dSxx and Baldock breaking) real*4, intent(in) :: alphaigfac ! Multiplication factor for IG shoaling source/sink term, default = 1.0 + real*4, intent(in) :: dtheta ! directional resolution + real*4, intent(in) :: gamma ! coefficients in Baldock wave breaking dissipation + real*4, intent(in) :: gamma_fac_br ! factor times gamma that is used to determine the maximum incident wave breaking point in the surf zone using local incident wave height over water depth ratio, among others used to set the IG source term to 0 shallower than this point ! ! Inout variables + ! real*4, dimension(:,:), intent(inout) :: alphaig_local ! Local infragravity wave shoaling parameter alpha real*4, dimension(:,:), intent(inout) :: srcig_local ! Energy source/sink term because of IG wave shoaling - real*4, dimension(:), intent(inout) :: eeprev, cgprev ! energy density and group velocity at upwind intersection point - real*4, dimension(:), intent(inout) :: eeprev_ig ! energy density at upwind intersection point - real*4, dimension(ntheta,no_nodes), intent(inout):: beta_local ! Local bed slope based on bed level per direction + real*4, dimension(ntheta,no_nodes), intent(inout):: beta_local ! Local bed slope based on bed level per direction ! ! Internal variables + ! integer :: itheta ! directional counter - integer :: k ! counters (k is grid index) + integer :: k ! counters (k is grid index) integer :: k1,k2 ! upwind counters (k is grid index) - real*4 :: gam ! local gamma (Hinc / depth ratio) - real*4, dimension(ntheta,no_nodes) :: depthprev ! water depth at upwind intersection point - real*4, dimension(ntheta,no_nodes) :: Sxx ! Radiation Stress - real*4, dimension(:), allocatable :: Sxxprev ! radiation stress at upwind intersection point - real*4, dimension(:), allocatable :: Hprev ! Incident wave height at upwind intersection point + real*4 :: gam ! local gamma (Hinc / depth ratio) + real*4, dimension(ntheta,no_nodes) :: depthprev ! water depth at upwind intersection point + real*4, dimension(no_nodes) :: Sxx ! radiation Stress + real*4, dimension(ntheta) :: Sxxprev ! radiation stress at upwind point + real*4, dimension(ntheta) :: Hprev ! wave height at upwind point + real*4, dimension(ntheta) :: cgprev ! group velocity at upwind point + real*4, dimension(ntheta) :: Eprev ! Mean incident wave energy at upwind intersection point + real*4, dimension(ntheta) :: Eprev_ig ! Mean infragravity wave energy at upwind intersection point + real*4, dimension(no_nodes) :: E_local ! mean wave energy waves - just local + real*4, dimension(no_nodes) :: E_ig_local ! mean wave energy infragravity waves - just local real*4 :: dSxx ! difference in Radiation stress - real*4 :: Sxx_cons ! conservative estimate of radiation stress using conservative shoaling - ! - ! Allocate internal variables - allocate(Sxxprev(ntheta)) - allocate(Hprev(ntheta)) + real*4 :: Sxx_cons ! conservative estimate of radiation stress using conservative shoaling + real*4 :: transition_factor ! Transition factor for letting srcig go to zero smoothly, around gamma*gamma_fac_br + real*4 :: transition_factor_width_1 ! Width factor of generalized (Fermi–Dirac style) transfer function with adjustable midpoint and width + real*4 :: transition_factor_width_2 ! Width factor of generalized (Fermi–Dirac style) transfer function with adjustable midpoint and width + real*4 :: gamma_fac_br_transition ! Transitioned version of gamma_fac_br, so that for steep slopes it remains 1.0 + real*4 :: beta_limit_1 ! Cut-off beta_local for end of validity alphaig formulation of Leijnse et al. 2024 + real*4 :: beta_limit_2 ! Beta_local limit for transition function + ! + ! Set internal variables ! Sxx = 0.0 + Hprev = 0.0 + Eprev = 0.0 + Eprev_ig = 0.0 + ! + E_local = 0.0 + E_ig_local = 0.0 ! + ! Used is generalized (Fermi–Dirac style) transfer function with adjustable midpoint and width + ! + transition_factor_width_1 = 0.005 + transition_factor_width_2 = 0.002 + beta_limit_1 = 0.07 + !beta_limit_2 = beta_limit_1 - 0.01 + beta_limit_2 = beta_limit_1 - 0.02 + ! + ! Pre-compute Sxx for all nodes + ! + !$omp parallel do schedule(static) do k = 1, no_nodes ! - if (inner(k)) then + if (inner(k)) then !TODO: check whether should be on only 'inner' or not + ! + ! Update E (not saved from previous timestep) ! - ! Compute exchange source term inc to ig waves - per direction + E_local(k) = sum(ee(:,k)) * dtheta + ! + ! Update E_ig (not saved from previous timestep) + ! + E_ig_local(k) = sum(ee_ig(:, k)) * dtheta + ! + endif + ! + Sxx(k) = ((2.0 * max(0.0, min(1.0, nwav(k)))) - 0.5) * E_local(k) + ! + enddo + !$omp end parallel do + ! + ! Main loop: compute IG source/sink term per node. + ! All writes target the column (itheta, k), so the loop is data-independent across k. + ! Per-k scratch arrays (cgprev, Eprev, Eprev_ig, Sxxprev, Hprev) are + ! listed as private so each thread gets its own copy on the stack. + ! + !$omp parallel do & + !$omp& private(itheta, k1, k2, gam, dSxx, Sxx_cons, & + !$omp& cgprev, Eprev, Eprev_ig, Sxxprev, Hprev) & + !$omp& schedule(static) + do k = 1, no_nodes + ! + if (inner(k)) then + ! + ! Compute exchange source term inc to ig waves - per direction ! do itheta = 1, ntheta ! k1 = prev(1, itheta, k) k2 = prev(2, itheta, k) ! - if (k1>0 .and. k2>0) then ! IMPORTANT - for some reason (k1*k2)>0 is not reliable always, resulting in directions being uncorrectly skipped!!! + if (k1 > 0 .and. k2 > 0) then ! IMPORTANT - for some reason (k1*k2)>0 is not reliable always, resulting in directions being uncorrectly skipped!!! ! ! First calculate upwind direction dependent variables - depthprev(itheta,k) = w(1, itheta, k)*depth(k1) + w(2, itheta, k)*depth(k2) - ! - beta_local(itheta,k) = max((w(1, itheta, k)*(zb(k) - zb(k1)) + w(2, itheta, k)*(zb(k) - zb(k2)))/ds(itheta, k), 0.0) + ! + depthprev(itheta,k) = w(1, itheta, k) * depth(k1) + w(2, itheta, k) * depth(k2) + ! + beta_local(itheta,k) = max((w(1, itheta, k) * (zb(k) - zb(k1)) + w(2, itheta, k) * (zb(k) - zb(k2))) / ds(itheta, k), 0.0) ! ! Notes: ! - use actual bed level now for slope, because depth changes because of wave setup/tide/surge ! - in zb, depth is negative > therefore zb(k) minus zb(k1) ! - beta=0 means a horizontal or decreasing slope > need alphaig=0 then in IG src/sink term ! - !betan_local(itheta,k) = (beta/sigm_ig)*sqrt(9.81/max(depth(k), hmin)) ! TL: in case in the future we would need the normalised bed slope again + !betan_local(itheta,k) = (beta/sigm_ig)*sqrt(9.81/max(depth(k), hmin)) ! TL: in case in the future we would need the normalised bed slope again + ! + cgprev(itheta) = w(1, itheta, k) * cg_ig(k1) + w(2, itheta, k) * cg_ig(k2) ! - ! TL - Note: cg_ig = cg - cgprev(itheta) = w(1, itheta, k)*cg_ig(k1) + w(2, itheta, k)*cg_ig(k2) - ! - Sxx(itheta,k1) = ((2.0 * max(0.0,min(1.0,nwav(k1)))) - 0.5) * ee(itheta, k1) ! limit so value of nwav is between 0 and 1 - Sxx(itheta,k2) = ((2.0 * max(0.0,min(1.0,nwav(k2)))) - 0.5) * ee(itheta, k2) ! limit so value of nwav is between 0 and 1 + ! Sxx is pre-computed for all nodes before this parallel loop ! - Sxxprev(itheta) = w(1, itheta, k)*Sxx(itheta,k1) + w(2, itheta, k)*Sxx(itheta,k2) + Sxxprev(itheta) = w(1, itheta, k) * Sxx(k1) + w(2, itheta, k) * Sxx(k2) ! - eeprev(itheta) = w(1, itheta, k)*ee(itheta, k1) + w(2, itheta, k)*ee(itheta, k2) - eeprev_ig(itheta) = w(1, itheta, k)*ee_ig(itheta, k1) + w(2, itheta, k)*ee_ig(itheta, k2) + Eprev(itheta) = w(1, itheta, k) * E_local(k1) + w(2, itheta, k) * E_local(k2) + Eprev_ig(itheta) = w(1, itheta, k) * E_ig_local(k1) + w(2, itheta, k) * E_ig_local(k2) + ! + Hprev(itheta) = w(1, itheta, k) * H(k1) + w(2, itheta, k) * H(k2) ! - Hprev(itheta) = w(1, itheta, k)*H(k1) + w(2, itheta, k)*H(k2) - ! ! Determine relative waterdepth 'gam' ! - gam = max(0.5*(Hprev(itheta)/depthprev(itheta,k) + H(k)/depth(k)), 0.0) ! mean gamma over current and upwind point + gam = max(0.5 * (Hprev(itheta) / depthprev(itheta,k) + H(k) / depth(k)), 0.0) ! mean gamma over current and upwind point ! ! Determine dSxx and IG source/sink term 'srcig' ! @@ -1111,36 +1363,53 @@ subroutine determine_infragravity_source_sink_term(inner, no_nodes, ntheta, w, d ! ! Calculate shoaling parameter alpha_ig following Leijnse et al. (2024) ! - call estimate_shoaling_parameter_alphaig(beta_local(itheta,k), gam, alphaig_local(itheta,k)) ! [input, input, output] + call estimate_shoaling_parameter_alphaig(beta_local(itheta, k), gam, alphaig_local(itheta, k)) ! [input, input, output] ! ! Now calculate source term component ! ! Newest dSxx/dx based method, using estimate of Sxx(k) using conservative shoaling - if (Sxxprev(itheta)<=0.0) then - ! - srcig_local(itheta, k) = 0.0 !Avoid big jumps in dSxx that can happen if a upwind point is a boundary point with Hinc=0 - ! - else - ! - if (ig_opt == 1) then ! Option using conservative shoaling for dSxx/dx - ! - ! Calculate Sxx based on conservative shoaling of upwind point's energy: - ! Sxx_cons = E(i-1) * Cg(i-1) / Cg * (2 * n(i) - 0.5) - Sxx_cons = eeprev(itheta) * cgprev(itheta) / cg_ig(k) * ((2.0 * max(0.0,min(1.0,nwav(k)))) - 0.5) - ! Note - limit so value of nwav is between 0 and 1, and Sxx therefore doesn't become NaN for nwav=Infinite - ! - dSxx = Sxx_cons - Sxxprev(itheta) - ! - elseif (ig_opt == 2) then ! Option taking actual difference for dSxx/dx - ! - dSxx = Sxx(itheta,k) - Sxxprev(itheta) - ! - endif ! - dSxx = max(dSxx, 0.0) - ! - srcig_local(itheta, k) = alphaigfac * alphaig_local(itheta,k) * sqrt(eeprev_ig(itheta)) * cgprev(itheta) / depthprev(itheta,k) * dSxx / ds(itheta, k) - ! + if (Sxxprev(itheta) <= 0.0) then + ! + srcig_local(itheta, k) = 0.0 !Avoid big jumps in dSxx that can happen if a upwind point is a boundary point with Hinc=0 + ! + else + ! + if (ig_opt == 1) then ! Option using conservative shoaling for dSxx/dx + ! + ! Calculate Sxx based on conservative shoaling of upwind point's energy: + ! Sxx_cons = E(i-1) * Cg(i-1) / Cg * (2 * n(i) - 0.5) + ! + Sxx_cons = Eprev(itheta) * cgprev(itheta) / cg_ig(k) * ((2.0 * max(0.0, min(1.0, nwav(k)))) - 0.5) + ! + ! Note - limit so value of nwav is between 0 and 1, and Sxx therefore doesn't become NaN for nwav=Infinite + ! + dSxx = Sxx_cons - Sxxprev(itheta) + ! + elseif (ig_opt == 2) then ! Option taking actual difference for dSxx/dx + ! + dSxx = Sxx(k) - Sxxprev(itheta) + ! + endif + ! + dSxx = max(dSxx, 0.0) + ! + ! Base on E_prev_ig instead of eeprev_ig(itheta) > no bins but total energy + ! NOTE - already here multiplied with ee(itheta,k), for direct inclusion in 'R'-term + srcig_local(itheta, k) = alphaigfac * alphaig_local(itheta,k) * sqrt(Eprev_ig(itheta)) * cgprev(itheta) / depthprev(itheta,k) * dSxx / ds(itheta, k) /max(E_local(k), 1.0e-6) * ee(itheta,k) + ! + ! Limit srcig to 0 after waves start (significantly) breaking, as defined here as gam=Hrms,inc / h > (gamma_fac_br * gamma) + ! Ergo, it is assumed that after this point IG waves are free, and no bound wave forcing is happening anymore, so srcig should be 0 from here on + ! + ! Let srcig transition to 0 more smoothly using fac_transition that reduced from 1 to 0 around gamma_fac_br * snapwave_gamma + ! But, only for beta_local < 0.07, so adjust based on beta_local so that transition_factor = 1.0 for Beta_local = 0.07 + ! + gamma_fac_br_transition = gamma_fac_br + ((1-gamma_fac_br) / (1 + exp(- (beta_local(itheta,k) - beta_limit_2) / transition_factor_width_2))) + ! + transition_factor = 1.0 - (1.0 / (1.0 + exp(- (gam - (gamma_fac_br_transition * gamma)) / transition_factor_width_1))) + ! + srcig_local(itheta, k) = transition_factor * srcig_local(itheta, k) + ! endif ! else ! TL: option to add future parameterisations here for e.g. coral reef type coasts @@ -1153,15 +1422,17 @@ subroutine determine_infragravity_source_sink_term(inner, no_nodes, ntheta, w, d ! endif ! - enddo + enddo ! endif ! - enddo - ! + enddo + !$omp end parallel do + ! end subroutine determine_infragravity_source_sink_term subroutine estimate_shoaling_parameter_alphaig(beta, gam, alphaig) + ! real*4, intent(in) :: beta real*4, intent(in) :: gam real*4, intent(out) :: alphaig @@ -1171,6 +1442,7 @@ subroutine estimate_shoaling_parameter_alphaig(beta, gam, alphaig) ! Estimate shoaling parameter alphaig - as in Leijnse et al. (2024) ! ! Determine constants + ! beta1 = 0.016993 beta2 = 0.5 beta3 = 17.7104 @@ -1352,8 +1624,8 @@ end subroutine hpsort_eps_epw subroutine timer(t) real*4,intent(out) :: t integer*4 :: count,count_rate,count_max - call system_clock (count,count_rate,count_max) - t = real(count)/count_rate + call system_clock (count,count_rate, count_max) + t = real(count) / count_rate end subroutine timer subroutine vegatt(sigm, no_nodes, kwav, no_secveg, veg_ah, veg_bstems, veg_Nstems, veg_Cd, depth, rho, g, H, Dveg) @@ -1364,7 +1636,7 @@ subroutine vegatt(sigm, no_nodes, kwav, no_secveg, veg_ah, veg_bstems, veg_Nstem ! declare variables real*4, intent(in) :: sigm ! wave frequency (per cell) integer, intent(in) :: no_nodes ! number of unstructured grid nodes - integer, intent(in) :: no_secveg + integer, intent(in) :: no_secveg ! number of sections in the vertical real*4, dimension(no_secveg), intent(in) :: veg_ah ! Height of vertical sections used in vegetation schematization [m wrt zb_ini (zb0)] (per cell) real*4, dimension(no_secveg), intent(in) :: veg_bstems ! Width/diameter of individual vegetation stems [m] (per cell) real*4, dimension(no_secveg), intent(in) :: veg_Nstems ! Number of vegetation stems per unit horizontal area [m-2] (per cell) @@ -1377,7 +1649,7 @@ subroutine vegatt(sigm, no_nodes, kwav, no_secveg, veg_ah, veg_bstems, veg_Nstem integer :: m real*4, intent(in) :: kwav ! wave number (per cell) real*4, intent(out) :: Dveg ! dissipation by vegetation (per cell) - + ! Set dissipation in vegetation to zero everywhere for a start Dveg = 0.d0 @@ -1389,16 +1661,19 @@ subroutine vegatt(sigm, no_nodes, kwav, no_secveg, veg_ah, veg_bstems, veg_Nstem if (no_secveg > 0) then ! only in case vegetation is present do m=1,no_secveg ! for each vertical vegetation section if (veg_Cd(m) < 0.d0) then ! If Cd is not user specified: call subroutine of M. Bendoni (see below) - write(logstr,*)'Cd is not user specified: using subroutine bulkdragcoeff to compute Cd' - call write_log(logstr, 0) ! - call bulkdragcoeff(veg_ah(m),m,Cdterm,no_nodes,no_secveg,depth,H,kwav,veg_bstems(m),sigm) ! bulkdragcoeff(ahveg(k,m)+zb0(k)-zb(k),m,k,Cdterm) <- no bed level change implemented in Snapwave - !write(*,*)'Cd is not user specified: putting default value of 0.7' - !veg_Cd(k,m) = 0.7 + !call bulkdragcoeff(veg_ah(m),m,Cdterm,no_nodes,no_secveg,depth,H,kwav,veg_bstems(m),sigm) ! bulkdragcoeff(ahveg(k,m)+zb0(k)-zb(k),m,k,Cdterm) <- no bed level change implemented in Snapwave + !write(logstr,*)'Cd is not user specified: using m. bendoni bulkdragcoefficient to compute cd: ',cdterm + !veg_Cd(m) = Cdterm + ! + write(logstr,*)'SnapWave ERROR - Cd is not specified for layer: ',m + call write_log(logstr, 0) + ! + ! endif enddo endif - + ! ! Attenuation by vegetation is computed in wave action balance (swvegatt) and the momentum balance (momeqveg); ! 1) Short wave dissipation by vegetation @@ -1412,9 +1687,9 @@ end subroutine vegatt subroutine swvegatt(sigm, no_nodes, kwav, no_secveg, veg_ah, veg_bstems, veg_Nstems, veg_Cd, depth, rho, g, H, Dveg)! Short wave dissipation by vegetation !use snapwave_data !use snapwave_domain - + ! implicit none - + ! ! declare variables integer, intent(in) :: no_nodes ! number of unstructured grid nodes integer, intent(in) :: no_secveg @@ -1427,20 +1702,20 @@ subroutine swvegatt(sigm, no_nodes, kwav, no_secveg, veg_ah, veg_bstems, veg_Nst real*4, intent(in) :: rho real*4, intent(in) :: g real*4, intent(in) :: H ! wave height - + ! ! local variables real*4 :: pi ! 3.14159 integer :: k,m ! indices of actual x,y point - + ! real*4 :: aht,hterm,htermold,Dvgt,ahtold real*4 :: Dvg,kmr!,kwav real*4, intent(in) :: kwav!,k - + ! real*4, intent(out) :: Dveg - + ! pi = 4.d0*atan(1.d0) kmr = min(max(kwav, 0.01d0), 100.d0) - + ! ! Set dissipation in vegetation to zero everywhere for a start Dvg = 0.d0 Dvgt = 0.d0 @@ -1448,24 +1723,24 @@ subroutine swvegatt(sigm, no_nodes, kwav, no_secveg, veg_ah, veg_bstems, veg_Nst ahtold = 0.d0 if (no_secveg>0) then ! only if vegetation is present do m=1,no_secveg - + ! ! Determine height of vegetation section (restricted to current bed level) !aht = veg(ind)%ah(m)+ahtold !+s%zb0(k,j)-s%zb(k,j)!(max(veg(ind)%zv(m)+s%zb0(k,j),s%zb(k,j))) aht = veg_ah(m)+ahtold - + ! ! restrict vegetation height to local water depth aht = min(aht, depth) - + ! ! compute hterm based on ah hterm = (sinh(kmr*aht)**3+3*sinh(kmr*aht))/(3.d0*kmr*cosh(kmr* depth)**3) ! - + ! ! compute dissipation based on aht and correct for lower elevated dissipation layers (following Suzuki et al. 2012) Dvgt = 0.5d0/sqrt(pi)*rho*veg_Cd(m)*veg_bstems(m)*veg_Nstems(m)*(0.5d0*kmr*g/sigm)**3*(hterm-htermold)*H**3 - + ! ! save hterm to htermold to correct possibly in next vegetation section htermold = hterm ahtold = aht - + ! ! add dissipation current vegetation section Dvg = Dvg + Dvgt enddo @@ -1473,27 +1748,29 @@ subroutine swvegatt(sigm, no_nodes, kwav, no_secveg, veg_ah, veg_bstems, veg_Nst Dveg = Dvg end subroutine swvegatt - subroutine bulkdragcoeff(ahh, m, Cdterm, no_nodes, no_secveg, depth, H, kwav, veg_bstems, sigm)!(ahh,m,i,Cdterm) + subroutine bulkdragcoeff(ahh, m, Cdterm, no_nodes, no_secveg, depth, H, kwav, veg_bstems, sigm) !(ahh,m,i,Cdterm) + ! ! Michele Bendoni: subroutine to calculate bulk drag coefficient for short wave ! energy dissipation based on the Keulegan-Carpenter number (adapted from XBeach) ! Ozeren et al. (2013) or Mendez and Losada (2004) - ! + ! implicit none - ! + ! real*4, intent(out) :: Cdterm real*4, intent(in) :: ahh ! [m] plant (total) height integer, intent(in) :: m - integer, intent(in) :: no_nodes ! number of unstructured grid nodes - integer, intent(in) :: no_secveg - real*4, intent(in) :: depth ! bed level, water depth - real*4, intent(in) :: H ! wave height + integer, intent(in) :: no_nodes ! number of unstructured grid nodes + integer, intent(in) :: no_secveg + real*4, intent(in) :: depth ! bed level, water depth + real*4, intent(in) :: H ! wave height real*4, intent(in) :: kwav ! wave number - real*4, intent(in) :: veg_bstems ! Width/diameter of individual vegetation stems [m] - real*4, intent(in) :: sigm ! [rad/s] mean frequency - ! + real*4, intent(in) :: veg_bstems ! Width/diameter of individual vegetation stems [m] + real*4, intent(in) :: sigm ! [rad/s] mean frequency + ! ! Local variables + ! real*4 :: pi ! 3.14159 - real*4 :: alfav ! [-] ratio between plant height and water depth + real*4 :: alfav ! [-] ratio between plant height and water depth real*4 :: um ! [m/s] typical velocity acting on the plant real*4 :: Tp ! [s] reference wave period real*4 :: KC ! [-] Keulegan-Carpenter number @@ -1501,12 +1778,14 @@ subroutine bulkdragcoeff(ahh, m, Cdterm, no_nodes, no_secveg, depth, H, kwav, ve integer :: myflag ! 1 => Ozeren et al. (2013); 2 => Mendez and Losada (2004) ! myflag = 2 - pi = 4.d0*atan(1.d0) + pi = 4.d0*atan(1.d0) ! ! Representative wave period + ! Tp = 2*pi/sigm ! ! Coefficient alfa + ! if (ahh>=depth) then alfav = 1.d0 else @@ -1521,6 +1800,7 @@ subroutine bulkdragcoeff(ahh, m, Cdterm, no_nodes, no_secveg, depth, H, kwav, ve KC = um*Tp/veg_bstems ! ! Bulk drag coefficient + ! if (myflag == 1) then ! ! Approach from Ozeren et al. (2013), eq? @@ -1530,19 +1810,196 @@ subroutine bulkdragcoeff(ahh, m, Cdterm, no_nodes, no_secveg, depth, H, kwav, ve else Cdterm = 0.036d0+50.d0/(10.d0**0.926d0) endif + ! elseif (myflag == 2) then ! ! Approach from Mendez and Losada (2004), eq. 40 ! Only applicable for Laminaria Hyperborea (kelp)??? ! Q = KC/(alfav**0.76d0) + ! if (Q>=7) then Cdterm = exp(-0.0138*Q)/(Q**0.3d0) else Cdterm = exp(-0.0138*7)/(7**0.3d0) endif + ! endif ! end subroutine bulkdragcoeff + +subroutine momeqveg(no_nodes, no_secveg, veg_ah, veg_bstems, veg_Nstems, veg_Cd, depth, rho, H, Trep, unl, Fvw) + ! INput: no_nodes, no_secveg, veg_ah(k,:), veg_bstems(k,:), veg_Nstems(k,:), veg_Cd(k,:), depth(k), rho, H(k), Tp(k), unl(k,:), Fvw(k) + ! + implicit none + ! + ! Inputs + integer, intent(in) :: no_nodes, no_secveg + real*4, intent(in) :: depth ,rho, H, Trep + real*4, dimension(no_secveg), intent(in) :: veg_ah, veg_bstems, veg_Nstems, veg_Cd + real*4, dimension(50), intent(in) :: unl + ! + ! Output + real*4, intent(out) :: Fvw + ! + ! Local variables + integer :: m, t + real*4 :: dt, hvegeff, Fvgnlt, integral + real*4 :: Cd, b, N + ! + ! Initialize output force + ! + Fvw = 0.0 + ! + ! Time step within wave period + ! + dt = Trep / 50.0 + ! + ! Loop over vertical vegetation sections + do m = 1 , no_secveg + ! Effective submerged height of vegetation section + hvegeff = min(veg_ah(m), depth) + ! Read vegetation parameters + Cd = veg_Cd(m) + b = veg_bstems(m) + N = veg_Nstems(m) + ! Integrate vegetation drag over wave period using unl + integral = 0.0 + do t = 1, 50 !50=PPWL + integral = integral + (0.5 * Cd * b * N * hvegeff * unl(t) * abs(unl(t) ) ) * dt + enddo + ! Convert to force per unit mass and sum + Fvgnlt = -integral / depth / Trep !> units match with F(k) m/s2 + + Fvw = Fvw + Fvgnlt + enddo + ! +end subroutine momeqveg +subroutine swvegnonlin(no_nodes, kwav, depth, H, g, Trep, unl, etaw0) + use snapwave_RFtable + ! + implicit none + ! + integer, intent(in) :: no_nodes + real*4, dimension(no_nodes), intent(in) :: kwav + real*4, dimension(no_nodes), intent(in) :: depth + real*4, dimension(no_nodes), intent(in) :: H + real*4, intent(in) :: g + real*4, dimension(no_nodes), intent(in) :: Trep + real*4, dimension(no_nodes, 50),intent(out) :: unl + real*4, dimension(no_nodes, 50),intent(out) :: etaw0 + + real*4, dimension(:), save , allocatable :: h0, t0 + integer, save :: nh , nt ! save as it only needs to be done at first call + real*4, save :: dh , dt + real*4, dimension(50 ,8), save :: cs , sn ! MvdL: what is this fixed dimension 8 and 50? + + real*4, dimension(8) :: urf0 + real*4, dimension(50) :: urf2 , urf + real*4, dimension(50, 8) :: urf1 + + real*4, dimension(no_nodes) :: kmr , Urs , phi , w1 , w2 + real*4 :: p ,q , f0 , f1 , f2 , f3 + + integer :: k, irf, ih0, it0, jrf, ih1, it1 + ! + real*4 :: pi = 4.*atan(1.0) + + real*4, dimension(:,:,:), allocatable :: RFveg + ! + allocate(RFveg(11,18,20)) + ! + ! Based on Deltares' XBeach SurfBeat' subroutine: swvegnonlin + ! Subroutine to compute a net drag force due to wave skewness. Based on (matlab based) roller model with veggies by Ad. + ! + ! Background: + ! The drag force (Fveg) is a function of u*abs(u), which is zero for linear waves. For non-linear, skewed waves the + ! depth-averaged velocity integrated over the wave period is zero. However, due to the sharp peaks and flat troughs + ! the integral of u*abs(u) is non-zero, and can significantly reduce wave setup, or even lead to set-down (e.g. Dean & Bender,2006). + ! + ! Here we use a method based on Rienecker & Fenton (1981), similar to the method used for onshore sediment transport due to wave asymmetry/ + ! skewness (see also morphevolution.F90 + Van Thiel de Vries Phd thesis par 6.2.3). + ! + ! load Ad's RF-table (update for depth averaged velocities?) + call load_RFtable(RFveg) + ! + ! Initialize/Prepare for interpolation of RF-value from RFveg-table + if (.not. allocated(h0)) then + allocate(h0(no_nodes)) + allocate(t0(no_nodes)) + dh = 0.03 + dt = 1.25 + nh = floor(0.54/ dh) + nt = floor(25 / dt ) + !construct velocity profile based on cosine/sine functions / Fourier components + do irf =1 ,8 + do jrf =1 ,50 + cs ( jrf , irf ) = cos (( jrf * 2 * pi / 50) * irf ) + sn ( jrf , irf ) = sin (( jrf * 2 * pi / 50) * irf ) + enddo + enddo + endif + ! + h0 = min(nh * dh, max(dh, min(H, depth) / depth) ) + t0 = min(nt * dt, max(dt, Trep * sqrt (g / depth) ) ) + ! + ! Initialize + urf0 = 0 + urf1 = 0 + urf2 = 0 + urf = 0 + w1 = 0 + w2 = 0 + phi = 0 + Urs = 0 + kmr = 0 + ! + ! Now compute weight factors (w1,w2) for relative contribution of cosine and sine functions (for w1 = 1: only cosines -> + ! fully skewed Stokes wave, for w2 = 1: only sines -> fully asymmetric wave) based on Ruessink. + kmr = min(max(kwav, 0.01), 100.0) + Urs = H / (kmr * kmr * (depth **3) ) + + ! Compute phase and weight factors + phi = pi /2 * (1 - tanh (0.815/(Urs **0.672) ) ) + w1 = 1 - phi /( pi /2) + w2 = 1 - w1 + ! + ! Interpolate RieneckerFenton velocity from RFveg table from Ad + ! in ftab-dimension, only read 4:11 and sum later + do k =1, no_nodes + ! + ih0 = floor( h0(k) / dh) + it0 = floor( t0(k) / dt) + ih1 = min(ih0 + 1, nh) + it1 = min(it0 + 1, nt) + p = ( h0(k) - ih0 * dh) / dh + q = ( t0(k) - it0 * dt) / dt + f0 = (1 - p) * (1 - q) + f1 = p * (1 - q) + f2 = q * (1 - p) + f3 = p * q + ! + ! Compute velocity amplitude per component + do irf = 1, 8 + urf0(irf) = f0 * RFveg(irf + 3, ih0, it0) + f1 * RFveg(irf + 3, ih1, it0) + f2 * RFveg(irf+3, ih0, it1) + f3 * RFveg(irf + 3, ih1, it1) + enddo + ! fill velocity amplitude matrix urf1([50 time points, 8 components]) + do irf = 1, 8 + urf1(:, irf) = urf0(irf) + enddo + ! + ! Compute velocity profile matrix per component + urf1 = urf1 * (w1(k) * cs + w2(k) * sn ) + ! + ! Add velocity components + urf2 = sum(urf1, 2) + ! + ! Scale the results to get velocity profile over wave period + unl(k,:) = urf2 * sqrt(g * depth(k) ) + etaw0(k,:) = unl(k,:)*sqrt(max(depth(k),0.d0)/g) + enddo + ! +end subroutine swvegnonlin + end module snapwave_solver 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..295bf77cd --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf.f90 @@ -0,0 +1,64 @@ +! 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_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..e6020a302 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/all.f90 @@ -0,0 +1,28 @@ +! 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_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..70bea9a3f --- /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), allocatable :: dummy + + call self%get_string(dummy) + if (allocated(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..a88a636fe --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/path.f90 @@ -0,0 +1,808 @@ +! 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(1)%key = key1 + path%path(2)%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(1)%key = key1 + path%path(2)%key = key2 + path%path(3)%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(1)%key = key1 + path%path(2)%key = key2 + path%path(3)%key = key3 + path%path(4)%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..befab1da4 --- /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 = achar(92, kind=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..873fe0c2c --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 @@ -0,0 +1,1583 @@ +! 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 = achar(92, kind=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" + character(*, tfc), parameter :: valid_escape = "betnfr" // achar(92, kind=tfc) // """" + 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("""", achar(92, kind=tfc)); 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("""", achar(92, kind=tfc)); 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..b031aaa65 --- /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), allocatable :: 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_string(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), allocatable :: 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_string(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..1e5803294 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 @@ -0,0 +1,364 @@ +! 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 + 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 + +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), allocatable, intent(out) :: val + + if (allocated(self%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(str) + class(generic_value), intent(in) :: val + character(:, tfc), allocatable :: str + + select type(val) + type is(string_value) + if (allocated(val%raw)) str = 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..18b550ce7 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/utils.f90 @@ -0,0 +1,261 @@ +! 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 + character(1, tfc), parameter :: bs = achar(92, kind=tfc) + + 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(bs); escaped = escaped // bs // bs + case('"'); escaped = escaped // bs // '"' + case(TOML_NEWLINE) + if (preserve_newline) then + escaped = escaped // raw(i:i) + else + escaped = escaped // bs // 'n' + end if + case(TOML_FORMFEED); escaped = escaped // bs // 'f' + case(TOML_CARRIAGE_RETURN); escaped = escaped // bs // 'r' + case(TOML_TABULATOR); escaped = escaped // bs // 't' + case(TOML_BACKSPACE); escaped = escaped // bs // '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