From beb9f1ac24557e9b5da9a11d3b7068019c1fa02f Mon Sep 17 00:00:00 2001 From: Leynse Date: Wed, 4 Feb 2026 13:28:25 +0100 Subject: [PATCH 01/65] - Initial commit, working on make a generic read_netcdf_quadtree_generic function - Apply first to netcdf storage volume - Work in progress still --- source/src/sfincs_lib.f90 | 4 +- source/src/sfincs_ncinput.F90 | 107 ++++++++++++++++++++++++++++------ 2 files changed, 91 insertions(+), 20 deletions(-) diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index a08899641..8405bef7b 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -92,8 +92,8 @@ function sfincs_initialize() result(ierr) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - build_revision = "$Rev: v2.3.0 mt. Faber Release" - build_date = "$Date: 2025-11-18" + build_revision = "$Rev: v2.3.0 mt. Faber Release-branch:268" + build_date = "$Date: 2025-02-04" ! call write_log('', 1) call write_log('------------ Welcome to SFINCS ------------', 1) diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index a29e49356..dc9b9a8c0 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -59,6 +59,11 @@ module sfincs_ncinput integer :: np_dimid integer :: vol_varid end type + type net_type_generic + integer :: ncid + integer :: np_dimid + integer :: gen_varid + end type ! type(net_type_bndbzsbzi) :: net_file_bndbzsbzi type(net_type_srcdis) :: net_file_srcdis @@ -66,7 +71,8 @@ module sfincs_ncinput type(net_type_amp) :: net_file_amp type(net_type_ampr) :: net_file_ampr type(net_type_spw) :: net_file_spw - type(net_type_vol) :: net_file_vol + type(net_type_vol) :: net_file_vol + type(net_type_generic) :: net_file_generic contains @@ -227,52 +233,117 @@ subroutine read_netcdf_discharge_data() subroutine read_netcdf_storage_volume() ! - use netcdf + !use netcdf use sfincs_data use quadtree ! implicit none ! - real*8, dimension(:), allocatable :: vols - integer :: nrcells, nm, ip + !real*8, dimension(:), allocatable :: vols + integer :: precision ! character (len=256), parameter :: vol_varname = 'vol' ! - NF90(nf90_open(trim(volfile), NF90_CLOBBER, net_file_vol%ncid)) + !NF90(nf90_open(trim(volfile), NF90_CLOBBER, net_file_vol%ncid)) + !! + !! Get dimensions id's: nr points + !! + !NF90(nf90_inq_dimid(net_file_vol%ncid, "mesh2d_nFaces", net_file_vol%np_dimid)) + !! + !! Get dimensions sizes + !! + !NF90(nf90_inquire_dimension(net_file_vol%ncid, net_file_vol%np_dimid, len = nrcells)) ! nr of cells + !! + !! Check that number of values in the cell matches quadtree_nr_points + !! + !! TODO: if (nrcells /=quadtree_nr_points) GIVE ERROR and stop simulation + !! + !NF90(nf90_inq_varid(net_file_vol%ncid, vol_varname, net_file_vol%vol_varid)) + !! + !allocate(vols(nrcells)) + !! + !NF90(nf90_get_var(net_file_vol%ncid, net_file_vol%vol_varid, vols(:))) + ! + ! Call the generic function + precision = 4 + ! + call read_netcdf_quadtree_generic(trim(volfile), vol_varname, storage_volume, np, precision) !ncfile, varname, varout, size, precision) + + !! Map quadtree to sfincs --> Question: better in or out of function? + !! + !do ip = 1, quadtree_nr_points + ! ! + ! nm = index_sfincs_in_quadtree(ip) + ! ! + ! storage_volume(nm) = vols(ip) + ! ! + !enddo + ! + !NF90(nf90_close(net_file_vol%ncid)) + ! + end subroutine + + subroutine read_netcdf_quadtree_generic(ncfile, varname, var, npoints, precision) + ! For instance: storage_volume.nc, vol, storage_volume, np, 5 + ! + use netcdf + use sfincs_data + use quadtree + ! + implicit none + ! + integer :: nm, npoints, ip, nrcells, precision + ! + character*256 :: ncfile + character*256 :: varname + !character (len=256), parameter :: varname + ! + !real*precision, dimension(:), allocatable :: varout + real*4, dimension(npoints), intent(inout) :: var ! variable that we are mapping to + + if (precision .eqv. 4) then + real*4, dimension(:), allocatable :: vartmp + elseif (precision .eqv. 8) then + real*8, dimension(:), allocatable :: vartmp + else + call write_log('ERROR : precision should be 4 or 8 ...', 0) + endif + ! + ! 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_vol%ncid, "mesh2d_nFaces", net_file_vol%np_dimid)) + NF90(nf90_inq_dimid(net_file_generic%ncid, "mesh2d_nFaces", net_file_generic%np_dimid)) ! ! Get dimensions sizes ! - NF90(nf90_inquire_dimension(net_file_vol%ncid, net_file_vol%np_dimid, len = nrcells)) ! nr of cells + NF90(nf90_inquire_dimension(net_file_generic%ncid, net_file_generic%np_dimid, len = nrcells)) ! nr of cells ! ! Check that number of values in the cell matches quadtree_nr_points - ! + write(logstr,*)'Info - number of cells in file: ',nrcells, ' vs quadtree_nr_points: ',quadtree_nr_points + call write_log(logstr, 1) ! TODO: if (nrcells /=quadtree_nr_points) GIVE ERROR and stop simulation ! - NF90(nf90_inq_varid(net_file_vol%ncid, vol_varname, net_file_vol%vol_varid)) + NF90(nf90_inq_varid(net_file_generic%ncid, varname, net_file_generic%gen_varid)) ! - allocate(vols(nrcells)) + allocate(vartmp(nrcells)) ! - NF90(nf90_get_var(net_file_vol%ncid, net_file_vol%vol_varid, vols(:))) + NF90(nf90_get_var(net_file_generic%ncid, net_file_generic%gen_varid, vartmp(:))) ! - ! Map quadtree to sfincs + ! Map quadtree to sfincs > externally for now ! do ip = 1, quadtree_nr_points ! nm = index_sfincs_in_quadtree(ip) ! - storage_volume(nm) = vols(ip) + var(nm) = vartmp(ip) ! enddo - ! - NF90(nf90_close(net_file_vol%ncid)) + ! + NF90(nf90_close(net_file_generic%ncid)) ! - end subroutine - - + 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 From 68e1493dd88d527407a82074b0402b3c85d747be Mon Sep 17 00:00:00 2001 From: Leynse Date: Wed, 4 Feb 2026 15:11:22 +0100 Subject: [PATCH 02/65] - Working version for storage volume nc with fixed mapping to SFINCS (can always add a snapwave one) and with real*4 (can always make a double version as well) - In sfincs_domain.f90, 'call read_netcdf_storage_volume' is now replaced by 'call read_netcdf_quadtree_to_sfincs' - Succesfully tested for testbed run 'storage_volume_qt_sbg_thd2' --- source/src/sfincs_domain.f90 | 7 ++-- source/src/sfincs_lib.f90 | 2 +- source/src/sfincs_ncinput.F90 | 77 ++++++++--------------------------- 3 files changed, 22 insertions(+), 64 deletions(-) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index a1b532f2d..8b789fb50 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2403,6 +2403,7 @@ subroutine initialize_storage_volume() ! integer :: nchar logical :: ok + character*256 :: varname ! if (use_storage_volume) then ! @@ -2424,9 +2425,9 @@ subroutine initialize_storage_volume() ! if (volfile(nchar - 1 : nchar) == 'nc') then ! - ! Read netcdf file - ! - call read_netcdf_storage_volume() + ! Call the generic quadtree nc file reader function + varname = 'vol' + call read_netcdf_quadtree_to_sfincs(volfile, varname, storage_volume) !ncfile, varname, varout) ! else ! diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 8405bef7b..898905cc2 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -92,7 +92,7 @@ function sfincs_initialize() result(ierr) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - build_revision = "$Rev: v2.3.0 mt. Faber Release-branch:268" + build_revision = "$Rev: v2.3.1 mt. Faber" build_date = "$Date: 2025-02-04" ! call write_log('', 1) diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index dc9b9a8c0..dfe2c5198 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -239,52 +239,12 @@ subroutine read_netcdf_storage_volume() ! implicit none ! - !real*8, dimension(:), allocatable :: vols - integer :: precision - ! - character (len=256), parameter :: vol_varname = 'vol' - ! - !NF90(nf90_open(trim(volfile), NF90_CLOBBER, net_file_vol%ncid)) - !! - !! Get dimensions id's: nr points - !! - !NF90(nf90_inq_dimid(net_file_vol%ncid, "mesh2d_nFaces", net_file_vol%np_dimid)) - !! - !! Get dimensions sizes - !! - !NF90(nf90_inquire_dimension(net_file_vol%ncid, net_file_vol%np_dimid, len = nrcells)) ! nr of cells - !! - !! Check that number of values in the cell matches quadtree_nr_points - !! - !! TODO: if (nrcells /=quadtree_nr_points) GIVE ERROR and stop simulation - !! - !NF90(nf90_inq_varid(net_file_vol%ncid, vol_varname, net_file_vol%vol_varid)) - !! - !allocate(vols(nrcells)) - !! - !NF90(nf90_get_var(net_file_vol%ncid, net_file_vol%vol_varid, vols(:))) - ! - ! Call the generic function - precision = 4 - ! - call read_netcdf_quadtree_generic(trim(volfile), vol_varname, storage_volume, np, precision) !ncfile, varname, varout, size, precision) - - !! Map quadtree to sfincs --> Question: better in or out of function? - !! - !do ip = 1, quadtree_nr_points - ! ! - ! nm = index_sfincs_in_quadtree(ip) - ! ! - ! storage_volume(nm) = vols(ip) - ! ! - !enddo - ! - !NF90(nf90_close(net_file_vol%ncid)) + ! end subroutine - subroutine read_netcdf_quadtree_generic(ncfile, varname, var, npoints, precision) - ! For instance: storage_volume.nc, vol, storage_volume, np, 5 + subroutine read_netcdf_quadtree_to_sfincs(ncfile, varname, var) + ! For instance: storage_volume.nc, vol, storage_volume ! use netcdf use sfincs_data @@ -292,24 +252,17 @@ subroutine read_netcdf_quadtree_generic(ncfile, varname, var, npoints, precision ! implicit none ! - integer :: nm, npoints, ip, nrcells, precision + integer :: nm, ip, nrcells, precision ! character*256 :: ncfile character*256 :: varname - !character (len=256), parameter :: varname ! - !real*precision, dimension(:), allocatable :: varout - real*4, dimension(npoints), intent(inout) :: var ! variable that we are mapping to - - if (precision .eqv. 4) then - real*4, dimension(:), allocatable :: vartmp - elseif (precision .eqv. 8) then - real*8, dimension(:), allocatable :: vartmp - else - call write_log('ERROR : precision should be 4 or 8 ...', 0) - endif + real*4, dimension(np), 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 @@ -320,10 +273,14 @@ subroutine read_netcdf_quadtree_generic(ncfile, varname, var, npoints, precision ! NF90(nf90_inquire_dimension(net_file_generic%ncid, net_file_generic%np_dimid, len = nrcells)) ! nr of cells ! - ! Check that number of values in the cell matches quadtree_nr_points - write(logstr,*)'Info - number of cells in file: ',nrcells, ' vs quadtree_nr_points: ',quadtree_nr_points - call write_log(logstr, 1) - ! TODO: if (nrcells /=quadtree_nr_points) GIVE ERROR and stop simulation + ! Check that number of values in the cell matches quadtree_nr_points + ! (=all quadtree cells, not just the active ones) + ! + if (nrcells /=quadtree_nr_points) then + write(logstr,*)'Info - file: ',trim(ncfile),' contains ',nrcells, 'input points vs quadtree_nr_points: ',quadtree_nr_points,' in sfincs.nc quadtree grid' + call write_log(logstr, 0) + call stop_sfincs('Error ! Number of grid points in netcdf input file does not match with that in sfincs.nc quadtree grid!', 1) + endif ! NF90(nf90_inq_varid(net_file_generic%ncid, varname, net_file_generic%gen_varid)) ! @@ -331,7 +288,7 @@ subroutine read_netcdf_quadtree_generic(ncfile, varname, var, npoints, precision ! NF90(nf90_get_var(net_file_generic%ncid, net_file_generic%gen_varid, vartmp(:))) ! - ! Map quadtree to sfincs > externally for now + ! Map quadtree to sfincs variable ! do ip = 1, quadtree_nr_points ! From 245c1a14b7e3147e39967db1997c270139ff19fa Mon Sep 17 00:00:00 2001 From: Leynse Date: Wed, 4 Feb 2026 15:55:10 +0100 Subject: [PATCH 03/65] - Add error when wanted variable was not found in file and directly stop - Tested by supplying dummy stoarge volume nc file for manning, now nicely stops --- source/src/sfincs_ncinput.F90 | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index dfe2c5198..7f4ef894c 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -252,7 +252,7 @@ subroutine read_netcdf_quadtree_to_sfincs(ncfile, varname, var) ! implicit none ! - integer :: nm, ip, nrcells, precision + integer :: nm, ip, nrcells, status ! character*256 :: ncfile character*256 :: varname @@ -277,12 +277,17 @@ subroutine read_netcdf_quadtree_to_sfincs(ncfile, varname, var) ! (=all quadtree cells, not just the active ones) ! if (nrcells /=quadtree_nr_points) then - write(logstr,*)'Info - file: ',trim(ncfile),' contains ',nrcells, 'input points vs quadtree_nr_points: ',quadtree_nr_points,' in sfincs.nc quadtree grid' - call write_log(logstr, 0) - call stop_sfincs('Error ! Number of grid points in netcdf input file does not match with that in sfincs.nc quadtree grid!', 1) + 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 ! - NF90(nf90_inq_varid(net_file_generic%ncid, varname, net_file_generic%gen_varid)) + status = nf90_inq_varid(net_file_generic%ncid, varname, net_file_generic%gen_varid) + ! + ! 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 ! allocate(vartmp(nrcells)) ! From d3db40e74bf1ab2d8cf37a4abdc4ea7306fe15ee Mon Sep 17 00:00:00 2001 From: Leynse Date: Wed, 4 Feb 2026 17:07:57 +0100 Subject: [PATCH 04/65] - Add netinfiltrationfile, netinftype variables - If netinfiltrationfile exists, then netinftype should be used - Do precheck of netinfiltrationfile before reading in all data --- source/src/sfincs_data.f90 | 3 +++ source/src/sfincs_domain.f90 | 50 +++++++++++++++++++++++++++++++++--- source/src/sfincs_input.f90 | 5 +++- source/src/sfincs_lib.f90 | 2 +- 4 files changed, 54 insertions(+), 6 deletions(-) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index c778c4925..4f3b74156 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -160,6 +160,7 @@ module sfincs_data character*256 :: netampfile character*256 :: netamprfile character*256 :: netspwfile + character*256 :: netinfiltrationfile character*256 :: scsfile character*256 :: smaxfile character*256 :: sefffile @@ -186,6 +187,7 @@ module sfincs_data character*3 :: outputtype_his character*3 :: utmzone character*3 :: inftype + character*3 :: netinftype integer :: epsg character*15 :: epsg_code integer :: nc_deflate_level @@ -225,6 +227,7 @@ module sfincs_data logical :: write_time_output logical :: bziwaves logical :: infiltration + LOGICAL :: netcdf_infiltration logical :: debug logical :: radstr logical :: crsgeo diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 8b789fb50..c5a7a9db5 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2034,6 +2034,7 @@ subroutine initialize_infiltration() ! Note, infiltration methods not designed to be stacked ! infiltration = .false. + netcdf_infiltration = .false. ! ! Four options for infiltration: ! @@ -2045,6 +2046,10 @@ subroutine initialize_infiltration() ! Requires: cumprcp, cuminf, qinfmap, qinffield ! 4) Spatially-varying infiltration with CN numbers (new) ! Requires: qinfmap, qinffield, qinffield, ksfield, scs_P1, scs_F1, scs_Se and scs_rain (but not necessarily cuminf and cumprcp) + ! 5) Spatially-varying infiltration with the Green-Ampt (GA) model + ! Requires: qinfmap, qinffield, ksfield, GA_head, GA_sigma_max, GA_Lu + ! 6) Spatially-varying infiltration with the modified Horton Equation + ! Requires: qinfmap, qinffield, horton_fc, horton_f0 ! ! cumprcp and cuminf are stored in the netcdf output if store_cumulative_precipitation == .true. which is the default ! @@ -2053,11 +2058,27 @@ subroutine initialize_infiltration() ! or: ! b) inftype == 'cna' or inftype == 'cnb' ! - ! First we determine precipitation type + !!!!!!!!!!!!!!!!!!!!! + ! Initializing steps: + !!!!!!!!!!!!!!!!!!!!! + ! + ! 1) First we determine infiltration type ! if (precip) then ! - if (qinf > 0.0) then + if (netinfiltrationfile /= 'none') then + ! + ! inftype is user defined, keyword: 'netinftype' in sfincs.inp: + ! + inftype = netinftype + ! + ! inftype is either: c2d, cna, cnb, gai, hor + ! 'inftype = con' is not relevant for netcdf input + ! + infiltration = .true. + netcdf_infiltration = .true. + ! + elseif (qinf > 0.0) then ! ! Spatially-uniform constant infiltration (specified as +mm/hr) ! @@ -2102,7 +2123,7 @@ subroutine initialize_infiltration() ! endif ! - ! We need cumprcp and cuminf + ! 2) We need cumprcp and cuminf ! allocate(cumprcp(np)) cumprcp = 0.0 @@ -2110,7 +2131,7 @@ subroutine initialize_infiltration() allocate(cuminf(np)) cuminf = 0.0 ! - ! Now allocate and read spatially-varying inputs + ! 3) Now allocate and read spatially-varying inputs ! if (infiltration) then ! @@ -2119,10 +2140,31 @@ subroutine initialize_infiltration() ! endif ! + ! 4) Pre-check whether netcdf infiltration file exists - once + ! + if (netcdf_infiltration) then + ! + write(logstr,'(a)')'Info : turning on infiltration from netcdf input file' + call write_log(logstr, 0) + ! + write(logstr,'(a,a)')'Info : reading netcdf infiltration file ', trim(netinfiltrationfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(netinfiltrationfile, 'Infiltration netcdf file', .true.) + ! + write(logstr,'(a,a)')'Info : specified inftype is ', trim(inftype) + call write_log(logstr, 0) + ! + endif + ! + ! 5) Read in data per type, either from ascii or general netcdf file + ! if (inftype == 'con') then ! ! Spatially-uniform constant infiltration (specified as +mm/hr) ! + ! Note : Input directly in sfincs.inp, so no file needs to be read + ! write(logstr,'(a)')'Info : turning on spatially-uniform constant infiltration' call write_log(logstr, 0) ! diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index aba244eeb..a5b93ddb7 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -207,7 +207,10 @@ subroutine read_sfincs_input() call read_char_input(500,'netamuamvfile',netamuamvfile,'none') call read_char_input(500,'netamprfile',netamprfile,'none') call read_char_input(500,'netampfile',netampfile,'none') - call read_char_input(500,'netspwfile',netspwfile,'none') + call read_char_input(500,'netspwfile',netspwfile,'none') + ! + call read_char_input(500,'netinfiltrationfile',netinfiltrationfile,'none') + call read_char_input(500,'netinftype',netinftype,'none') ! ! Output call read_char_input(500,'obsfile',obsfile,'none') diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 898905cc2..b9f303f3a 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -92,7 +92,7 @@ function sfincs_initialize() result(ierr) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - build_revision = "$Rev: v2.3.1 mt. Faber" + build_revision = "$Rev: v2.3.1 mt. Faber+" build_date = "$Date: 2025-02-04" ! call write_log('', 1) From 435327424067c62af8f5887a46aa83315f66b351 Mon Sep 17 00:00:00 2001 From: Leynse Date: Wed, 4 Feb 2026 17:48:48 +0100 Subject: [PATCH 05/65] - Implement netcdf reader option for all infiltration options - Current implementation will check and retrieve multiple variables from the same file (e.g. cnb) individually - Added some documentation what part of the code is reading/allocating/generic needed conversions - Kept naming in netcdf files for now consistent with the equivalent netcdf files --- source/src/sfincs_domain.f90 | 314 +++++++++++++++++++++++++---------- 1 file changed, 227 insertions(+), 87 deletions(-) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index c5a7a9db5..c7c0d5547 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2020,6 +2020,7 @@ subroutine initialize_roughness() subroutine initialize_infiltration() ! use sfincs_data + use sfincs_ncinput ! implicit none ! @@ -2027,6 +2028,8 @@ subroutine initialize_infiltration() ! logical :: ok ! + character*256 :: varname + ! ! INFILTRATION ! ! Infiltration only works when rainfall is activated ! If you want infiltration without rainfall, use a precip file with 0.0s @@ -2195,17 +2198,32 @@ subroutine initialize_infiltration() write(logstr,'(a)')'Info : turning on spatially-varying constant infiltration' call write_log(logstr, 0) ! - ! Read spatially-varying infiltration (only binary, specified in +mm/hr) + allocate(qinffield(np)) ! - write(logstr,'(a,a)')'Info : reading infiltration file ', trim(qinffile) - call write_log(logstr, 0) + qinffield = 0.0 ! - ok = check_file_exists(qinffile, 'Infiltration qinf file', .true.) + ! Read spatially-varying infiltration (specified in +mm/hr) ! - allocate(qinffield(np)) - open(unit = 500, file = trim(qinffile), form = 'unformatted', access = 'stream') - read(500)qinffield - close(500) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'qinf' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, qinffield) !ncfile, varname, varout) + ! + else ! from separate qinffile - only binary: + ! + write(logstr,'(a,a)')'Info : reading infiltration file ', trim(qinffile) + call write_log(logstr, 0) + ! + ok = check_file_exists(qinffile, 'Infiltration qinf file', .true.) + ! + open(unit = 500, file = trim(qinffile), form = 'unformatted', access = 'stream') + read(500)qinffield + close(500) + ! + endif + ! + ! Generic needed conversion: ! qinffield = qinffield / 3600 / 1000 ! convert to +m/s ! @@ -2220,18 +2238,29 @@ subroutine initialize_infiltration() ! qinffield = 0.0 ! - write(logstr,'(a,a)')'Info : reading scs file ',trim(scsfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(scsfile, 'Infiltration scs file', .true.) - ! - open(unit = 500, file = trim(scsfile), form = 'unformatted', access = 'stream') - read(500)qinffield - close(500) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'scs' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, qinffield) + ! + else ! from separate scsfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading scs file ',trim(scsfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(scsfile, 'Infiltration scs file', .true.) + ! + open(unit = 500, file = trim(scsfile), form = 'unformatted', access = 'stream') + read(500)qinffield + close(500) + ! + endif ! - ! already convert qinffield from inches to m here + ! Generic needed conversion: ! qinffield = qinffield * 0.0254 ! to m + ! already convert qinffield from inches to m here ! elseif (inftype == 'cnb') then ! @@ -2243,48 +2272,83 @@ subroutine initialize_infiltration() ! Allocate Smax allocate(qinffield(np)) qinffield = 0.0 - write(logstr,'(a,a)')'Info : reading smax file ',trim(smaxfile) - call write_log(logstr, 0) ! - ok = check_file_exists(smaxfile, 'Infiltration smax file', .true.) - ! - open(unit = 500, file = trim(smaxfile), form = 'unformatted', access = 'stream') - read(500)qinffield - close(500) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'smax' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, qinffield) + ! + else ! from separate smaxfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading smax file ',trim(smaxfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(smaxfile, 'Infiltration smax file', .true.) + ! + open(unit = 500, file = trim(smaxfile), form = 'unformatted', access = 'stream') + read(500)qinffield + close(500) + ! + endif ! ! Allocate Se allocate(scs_Se(np)) scs_Se = 0.0 - write(logstr,'(a,a)')'Info : reading seff file ',trim(sefffile) - call write_log(logstr, 0) ! - ok = check_file_exists(sefffile, 'Infiltration seff file', .true.) - ! - open(unit = 501, file = trim(sefffile), form = 'unformatted', access = 'stream') - read(501)scs_Se - close(501) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'seff' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, scs_Se) + ! + else ! from separate sefffile - only binary: + ! + write(logstr,'(a,a)')'Info : reading seff file ',trim(sefffile) + call write_log(logstr, 0) + ! + ok = check_file_exists(sefffile, 'Infiltration seff file', .true.) + ! + open(unit = 501, file = trim(sefffile), form = 'unformatted', access = 'stream') + read(501)scs_Se + close(501) + ! + endif ! - ! Compute recovery ! Equation 4-36 ! Allocate Ks ! allocate(ksfield(np)) ksfield = 0.0 - write(logstr,'(a,a)')'Info : reading ks file ',trim(ksfile) - call write_log(logstr, 0) ! - ok = check_file_exists(ksfile, 'Infiltration ks file', .true.) - ! - open(unit = 502, file = trim(ksfile), form = 'unformatted', access = 'stream') - read(502)ksfield - close(502) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'ks' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, ksfield) + ! + else ! from separate ksfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading ks file ',trim(ksfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(ksfile, 'Infiltration ks file', .true.) + ! + open(unit = 502, file = trim(ksfile), form = 'unformatted', access = 'stream') + read(502)ksfield + close(502) + ! + endif ! + ! Generic needed conversion: + ! ! Compute recovery ! Equation 4-36 ! allocate(inf_kr(np)) inf_kr = sqrt(ksfield/25.4) / 75 ! Note that we assume ksfield to be in mm/hr, convert it here to inch/hr (/25.4) ! /75 is conversion to recovery rate (in days) ! - ! Allocate support variables + ! Allocate support variables: + ! allocate(scs_P1(np)) scs_P1 = 0.0 allocate(scs_F1(np)) @@ -2306,41 +2370,77 @@ subroutine initialize_infiltration() ! allocate(GA_head(np)) GA_head = 0.0 - write(logstr,'(a,a)')'Info : reading psi file ',trim(psifile) - call write_log(logstr, 0) ! - ok = check_file_exists(psifile, 'Infiltration psi file', .true.) - ! - open(unit = 500, file = trim(psifile), form = 'unformatted', access = 'stream') - read(500)GA_head - close(500) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'psi' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, GA_head) + ! + else ! from separate psifile - only binary: + ! + write(logstr,'(a,a)')'Info : reading psi file ',trim(psifile) + call write_log(logstr, 0) + ! + ok = check_file_exists(psifile, 'Infiltration psi file', .true.) + ! + open(unit = 500, file = trim(psifile), form = 'unformatted', access = 'stream') + read(500)GA_head + close(500) + ! + endif ! ! Allocate maximum soil moisture deficit ! allocate(GA_sigma_max(np)) GA_sigma_max = 0.0 - write(logstr,'(a,a)')'Info : reading sigma file ',trim(sigmafile) - call write_log(logstr, 0) ! - ok = check_file_exists(sigmafile, 'Infiltration sigma file', .true.) - ! - open(unit = 501, file = trim(sigmafile), form = 'unformatted', access = 'stream') - read(501)GA_sigma_max - close(501) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'sigma' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, GA_sigma_max) + ! + else ! from separate sigmafile - only binary: + ! + write(logstr,'(a,a)')'Info : reading sigma file ',trim(sigmafile) + call write_log(logstr, 0) + ! + ok = check_file_exists(sigmafile, 'Infiltration sigma file', .true.) + ! + open(unit = 501, file = trim(sigmafile), form = 'unformatted', access = 'stream') + read(501)GA_sigma_max + close(501) + ! + endif ! ! Allocate saturated hydraulic conductivity ! allocate(ksfield(np)) ksfield = 0.0 - write(logstr,'(a,a)')'Info : reading ks file ',trim(ksfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(ksfile, 'Infiltration ks file', .true.) ! - open(unit = 502, file = trim(ksfile), form = 'unformatted', access = 'stream') - read(502)ksfield - close(502) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'ks' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, ksfield) + ! + else ! from separate ksfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading ks file ',trim(ksfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(ksfile, 'Infiltration ks file', .true.) + ! + open(unit = 502, file = trim(ksfile), form = 'unformatted', access = 'stream') + read(502)ksfield + close(502) + ! + endif + ! + ! Generic needed conversion: + ! ! Compute recovery ! Equation 4-36 ! allocate(inf_kr(np)) @@ -2367,6 +2467,8 @@ subroutine initialize_infiltration() ! ! First time step doesnt have an estimate yet ! + ! Allocate support variables: + ! allocate(qinffield(np)) qinffield(nm) = 0.0 ! @@ -2377,48 +2479,86 @@ subroutine initialize_infiltration() call write_log('Info : turning on process infiltration (via modified Horton)', 0) ! ! Horton: final infiltration capacity (fc) - ! Note that qinffield = horton_fc + ! Note that qinffield = horton_fc (/3600/1000, see below) + ! allocate(horton_fc(np)) horton_fc = 0.0 - write(logstr,'(a,a)')'Info : reading fc file ',trim(fcfile) - call write_log(logstr, 0) ! - ok = check_file_exists(fcfile, 'Infiltration fc file', .true.) - ! - open(unit = 500, file = trim(fcfile), form = 'unformatted', access = 'stream') - read(500)horton_fc - close(500) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'fc' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, horton_fc) + ! + else ! from separate fcfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading fc file ',trim(fcfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(fcfile, 'Infiltration fc file', .true.) + ! + open(unit = 500, file = trim(fcfile), form = 'unformatted', access = 'stream') + read(500)horton_fc + close(500) + ! + endif ! ! Horton: initial infiltration capacity (f0) allocate(horton_f0(np)) horton_f0 = 0.0 - write(logstr,'(a,a)')'Info : reading f0 file ',trim(f0file) - call write_log(logstr, 0) - ! - ok = check_file_exists(f0file, 'Infiltration f0 file', .true.) - ! - open(unit = 501, file = trim(f0file), form = 'unformatted', access = 'stream') - read(501)horton_f0 - close(501) ! - ! Prescribe the current estimate (for output only; initial capacity) - qinffield = horton_f0/3600/1000 + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'f0' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, horton_f0) + ! + else ! from separate f0file - only binary: + ! + write(logstr,'(a,a)')'Info : reading f0 file ',trim(f0file) + call write_log(logstr, 0) + ! + ok = check_file_exists(f0file, 'Infiltration f0 file', .true.) + ! + open(unit = 501, file = trim(f0file), form = 'unformatted', access = 'stream') + read(501)horton_f0 + close(501) + ! + endif ! ! Empirical constant (1/hr) k => note that this is different than ks used in Curve Number and Green-Ampt allocate(horton_kd(np)) horton_kd = 0.0 - write(logstr,'(a,a)')'Info : reading kd file ',trim(kdfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(kdfile, 'Infiltration kd file', .true.) ! - open(unit = 502, file = trim(kdfile), form = 'unformatted', access = 'stream') - read(502)horton_kd - close(502) + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'kd' + call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, horton_kd) + ! + else ! from separate kdfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading kd file ',trim(kdfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(kdfile, 'Infiltration kd file', .true.) + ! + open(unit = 502, file = trim(kdfile), form = 'unformatted', access = 'stream') + read(502)horton_kd + close(502) + ! + endif ! - write(logstr,'(a,a)')'Using constant recovery rate that is based on constant factor relative to ',trim(kdfile) + write(logstr,'(a,a)')'Info : Using constant recovery rate that is based on constant factor relative to ',trim(kdfile) call write_log(logstr, 0) ! + ! Generic needed conversion: + ! + ! Prescribe the current estimate (for output only; initial capacity) + qinffield = horton_f0/3600/1000 + ! + ! Allocate support variables: + ! ! Estimate of time allocate(rain_T1(np)) rain_T1 = 0.0 From 378e27e65b86d71b8108eadeda95a8a803397280 Mon Sep 17 00:00:00 2001 From: Leynse Date: Wed, 4 Feb 2026 17:56:14 +0100 Subject: [PATCH 06/65] - Add stop_sfincs check on combination check of infiltration input type (orignal vs netcdf) vs grid type (regular vs quadtree) - Idea for now is if quadtree model, only netcdf input is support, and for regular model only the original binary files --- source/src/sfincs_domain.f90 | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index c7c0d5547..2b5bf86a5 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2159,8 +2159,28 @@ subroutine initialize_infiltration() call write_log(logstr, 0) ! endif - ! - ! 5) Read in data per type, either from ascii or general netcdf file + ! + ! 5) Check whether infiltration input type (orignal vs netcdf) are correctly matched to grid type (regular vs quadtree) + ! + if (netcdf_infiltration) then + ! + if (use_quadtree .eqv. .false.) then + ! + call stop_sfincs('Error ! Netcdf infiltration input format can only be specified for quadtree mesh model !', 1) + ! + endif + ! + else ! Original + ! + if (use_quadtree .eqv. .true.) then + ! + call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the netinfiltrationfile Netcdf format! !', 1) + ! + endif + ! + endif + ! + ! 6) Read in data per type, either from ascii or general netcdf file ! if (inftype == 'con') then ! From a2f67b4a2997b3f11a8b3f5395fc5846267cb469 Mon Sep 17 00:00:00 2001 From: Leynse Date: Wed, 4 Feb 2026 18:05:49 +0100 Subject: [PATCH 07/65] - Constant uniform infiltration is allowed for both grid types --- source/src/sfincs_domain.f90 | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 2b5bf86a5..4ecb3258d 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2162,23 +2162,26 @@ subroutine initialize_infiltration() ! ! 5) Check whether infiltration input type (orignal vs netcdf) are correctly matched to grid type (regular vs quadtree) ! - if (netcdf_infiltration) then - ! - if (use_quadtree .eqv. .false.) then - ! - call stop_sfincs('Error ! Netcdf infiltration input format can only be specified for quadtree mesh model !', 1) + if (inftype /= 'con') then !constant uniform works for both options + ! + if (netcdf_infiltration) then + ! + if (use_quadtree .eqv. .false.) then + ! + call stop_sfincs('Error ! Netcdf infiltration input format can only be specified for quadtree mesh model !', 1) + ! + endif ! + else ! Original + ! + if (use_quadtree .eqv. .true.) then + ! + call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the netinfiltrationfile Netcdf ormat! !', 1) + endif + ! endif ! - else ! Original - ! - if (use_quadtree .eqv. .true.) then - ! - call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the netinfiltrationfile Netcdf format! !', 1) - ! - endif - ! - endif + endif ! ! 6) Read in data per type, either from ascii or general netcdf file ! From c654c0057b6198b5bbb2403771acbea064a011e2 Mon Sep 17 00:00:00 2001 From: Leynse Date: Wed, 4 Feb 2026 18:10:20 +0100 Subject: [PATCH 08/65] - Edit check - still possible that precip is forced but qinf=0 --- source/src/sfincs_domain.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 4ecb3258d..ca4c8a1dd 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2162,7 +2162,7 @@ subroutine initialize_infiltration() ! ! 5) Check whether infiltration input type (orignal vs netcdf) are correctly matched to grid type (regular vs quadtree) ! - if (inftype /= 'con') then !constant uniform works for both options + if (infiltration .and. inftype /= 'con') then !constant uniform works for both options ! if (netcdf_infiltration) then ! From 36a5aa8e085c95512e15c75011edf166856eea3d Mon Sep 17 00:00:00 2001 From: Leynse Date: Thu, 12 Feb 2026 09:38:13 +0100 Subject: [PATCH 09/65] - Change names to infiltrationfile and infiltrationtype --- source/src/sfincs_data.f90 | 3 +-- source/src/sfincs_domain.f90 | 34 ++++++++++++++++------------------ source/src/sfincs_input.f90 | 4 ++-- 3 files changed, 19 insertions(+), 22 deletions(-) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 4f3b74156..c367d1b3e 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -160,7 +160,7 @@ module sfincs_data character*256 :: netampfile character*256 :: netamprfile character*256 :: netspwfile - character*256 :: netinfiltrationfile + character*256 :: infiltrationfile character*256 :: scsfile character*256 :: smaxfile character*256 :: sefffile @@ -187,7 +187,6 @@ module sfincs_data character*3 :: outputtype_his character*3 :: utmzone character*3 :: inftype - character*3 :: netinftype integer :: epsg character*15 :: epsg_code integer :: nc_deflate_level diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index ca4c8a1dd..547617bf8 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2069,11 +2069,9 @@ subroutine initialize_infiltration() ! if (precip) then ! - if (netinfiltrationfile /= 'none') then + if (infiltrationfile /= 'none') then ! - ! inftype is user defined, keyword: 'netinftype' in sfincs.inp: - ! - inftype = netinftype + ! inftype is user defined, keyword: 'inftype' in sfincs.inp: ! ! inftype is either: c2d, cna, cnb, gai, hor ! 'inftype = con' is not relevant for netcdf input @@ -2150,10 +2148,10 @@ subroutine initialize_infiltration() write(logstr,'(a)')'Info : turning on infiltration from netcdf input file' call write_log(logstr, 0) ! - write(logstr,'(a,a)')'Info : reading netcdf infiltration file ', trim(netinfiltrationfile) + write(logstr,'(a,a)')'Info : reading netcdf infiltration file ', trim(infiltrationfile) call write_log(logstr, 0) ! - ok = check_file_exists(netinfiltrationfile, 'Infiltration netcdf file', .true.) + ok = check_file_exists(infiltrationfile, 'Infiltration netcdf file', .true.) ! write(logstr,'(a,a)')'Info : specified inftype is ', trim(inftype) call write_log(logstr, 0) @@ -2176,7 +2174,7 @@ subroutine initialize_infiltration() ! if (use_quadtree .eqv. .true.) then ! - call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the netinfiltrationfile Netcdf ormat! !', 1) + call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) endif ! endif @@ -2231,7 +2229,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'qinf' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, qinffield) !ncfile, varname, varout) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) !ncfile, varname, varout) ! else ! from separate qinffile - only binary: ! @@ -2265,7 +2263,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'scs' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, qinffield) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) ! else ! from separate scsfile - only binary: ! @@ -2300,7 +2298,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'smax' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, qinffield) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) ! else ! from separate smaxfile - only binary: ! @@ -2323,7 +2321,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'seff' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, scs_Se) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, scs_Se) ! else ! from separate sefffile - only binary: ! @@ -2347,7 +2345,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'ks' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, ksfield) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, ksfield) ! else ! from separate ksfile - only binary: ! @@ -2398,7 +2396,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'psi' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, GA_head) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, GA_head) ! else ! from separate psifile - only binary: ! @@ -2422,7 +2420,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'sigma' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, GA_sigma_max) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, GA_sigma_max) ! else ! from separate sigmafile - only binary: ! @@ -2446,7 +2444,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'ks' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, ksfield) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, ksfield) ! else ! from separate ksfile - only binary: ! @@ -2511,7 +2509,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'fc' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, horton_fc) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_fc) ! else ! from separate fcfile - only binary: ! @@ -2534,7 +2532,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'f0' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, horton_f0) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_f0) ! else ! from separate f0file - only binary: ! @@ -2557,7 +2555,7 @@ subroutine initialize_infiltration() ! ! Call the generic quadtree nc file reader function varname = 'kd' - call read_netcdf_quadtree_to_sfincs(netinfiltrationfile, varname, horton_kd) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_kd) ! else ! from separate kdfile - only binary: ! diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index a5b93ddb7..31b22daa9 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -209,8 +209,8 @@ subroutine read_sfincs_input() call read_char_input(500,'netampfile',netampfile,'none') call read_char_input(500,'netspwfile',netspwfile,'none') ! - call read_char_input(500,'netinfiltrationfile',netinfiltrationfile,'none') - call read_char_input(500,'netinftype',netinftype,'none') + call read_char_input(500,'infiltrationfile',infiltrationfile,'none') + call read_char_input(500,'infiltrationtype',inftype,'none') ! ! Output call read_char_input(500,'obsfile',obsfile,'none') From 30a0cb670a8bf205b81595ff490df795c3f576fb Mon Sep 17 00:00:00 2001 From: Leynse Date: Thu, 12 Feb 2026 09:41:42 +0100 Subject: [PATCH 10/65] - Move whole subroutine 'initialize_infiltration' from sfincs_domain.f90 to sfincs_infiltration.f90 --- source/src/sfincs_domain.f90 | 583 +---------------------------- source/src/sfincs_infiltration.f90 | 583 +++++++++++++++++++++++++++++ 2 files changed, 585 insertions(+), 581 deletions(-) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 547617bf8..9dbd31219 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -9,6 +9,7 @@ subroutine initialize_domain() ! use sfincs_data use quadtree + use sfincs_infiltration ! implicit none ! @@ -22,7 +23,7 @@ subroutine initialize_domain() ! call initialize_roughness() ! - call initialize_infiltration() + call initialize_infiltration() ! see: sfincs_infiltration.f90 ! call initialize_storage_volume() ! @@ -2017,586 +2018,6 @@ subroutine initialize_roughness() end subroutine - subroutine initialize_infiltration() - ! - use sfincs_data - use sfincs_ncinput - ! - implicit none - ! - integer :: nm - ! - logical :: ok - ! - character*256 :: varname - ! - ! INFILTRATION - ! - ! Infiltration only works when rainfall is activated ! If you want infiltration without rainfall, use a precip file with 0.0s - ! - ! Note, infiltration methods not designed to be stacked - ! - infiltration = .false. - netcdf_infiltration = .false. - ! - ! Four options for infiltration: - ! - ! 1) Spatially-uniform constant infiltration - ! Requires: - - ! 2) Spatially-varying constant infiltration - ! Requires: qinfmap (does not require qinffield !) - ! 3) Spatially-varying infiltration with CN numbers (old) - ! Requires: cumprcp, cuminf, qinfmap, qinffield - ! 4) Spatially-varying infiltration with CN numbers (new) - ! Requires: qinfmap, qinffield, qinffield, ksfield, scs_P1, scs_F1, scs_Se and scs_rain (but not necessarily cuminf and cumprcp) - ! 5) Spatially-varying infiltration with the Green-Ampt (GA) model - ! Requires: qinfmap, qinffield, ksfield, GA_head, GA_sigma_max, GA_Lu - ! 6) Spatially-varying infiltration with the modified Horton Equation - ! Requires: qinfmap, qinffield, horton_fc, horton_f0 - ! - ! cumprcp and cuminf are stored in the netcdf output if store_cumulative_precipitation == .true. which is the default - ! - ! We need to keep cumprcp and cuminf in memory when: - ! a) store_cumulative_precipitation == .true. - ! or: - ! b) inftype == 'cna' or inftype == 'cnb' - ! - !!!!!!!!!!!!!!!!!!!!! - ! Initializing steps: - !!!!!!!!!!!!!!!!!!!!! - ! - ! 1) First we determine infiltration type - ! - if (precip) then - ! - if (infiltrationfile /= 'none') then - ! - ! inftype is user defined, keyword: 'inftype' in sfincs.inp: - ! - ! inftype is either: c2d, cna, cnb, gai, hor - ! 'inftype = con' is not relevant for netcdf input - ! - infiltration = .true. - netcdf_infiltration = .true. - ! - elseif (qinf > 0.0) then - ! - ! Spatially-uniform constant infiltration (specified as +mm/hr) - ! - inftype = 'con' - infiltration = .true. - ! - elseif (qinffile /= 'none') then - ! - ! Spatially-varying constant infiltration - ! - inftype = 'c2d' - infiltration = .true. - ! - elseif (scsfile /= 'none') then - ! - ! Spatially-varying infiltration with CN numbers (old) - ! - inftype = 'cna' - infiltration = .true. - ! - elseif (sefffile /= 'none') then - ! - ! Spatially-varying infiltration with CN numbers (new) - ! - inftype = 'cnb' - infiltration = .true. - ! - elseif (psifile /= 'none') then - ! - ! The Green-Ampt (GA) model for infiltration - ! - inftype = 'gai' - infiltration = .true. - ! - elseif (f0file /= 'none') then - ! - ! The Horton Equation model for infiltration - ! - inftype = 'hor' - infiltration = .true. - store_meteo = .true. - ! - endif - ! - ! 2) We need cumprcp and cuminf - ! - allocate(cumprcp(np)) - cumprcp = 0.0 - ! - allocate(cuminf(np)) - cuminf = 0.0 - ! - ! 3) Now allocate and read spatially-varying inputs - ! - if (infiltration) then - ! - allocate(qinfmap(np)) - qinfmap = 0.0 - ! - endif - ! - ! 4) Pre-check whether netcdf infiltration file exists - once - ! - if (netcdf_infiltration) then - ! - write(logstr,'(a)')'Info : turning on infiltration from netcdf input file' - call write_log(logstr, 0) - ! - write(logstr,'(a,a)')'Info : reading netcdf infiltration file ', trim(infiltrationfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(infiltrationfile, 'Infiltration netcdf file', .true.) - ! - write(logstr,'(a,a)')'Info : specified inftype is ', trim(inftype) - call write_log(logstr, 0) - ! - endif - ! - ! 5) Check whether infiltration input type (orignal vs netcdf) are correctly matched to grid type (regular vs quadtree) - ! - if (infiltration .and. inftype /= 'con') then !constant uniform works for both options - ! - if (netcdf_infiltration) then - ! - if (use_quadtree .eqv. .false.) then - ! - call stop_sfincs('Error ! Netcdf infiltration input format can only be specified for quadtree mesh model !', 1) - ! - endif - ! - else ! Original - ! - if (use_quadtree .eqv. .true.) then - ! - call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) - endif - ! - endif - ! - endif - ! - ! 6) Read in data per type, either from ascii or general netcdf file - ! - if (inftype == 'con') then - ! - ! Spatially-uniform constant infiltration (specified as +mm/hr) - ! - ! Note : Input directly in sfincs.inp, so no file needs to be read - ! - write(logstr,'(a)')'Info : turning on spatially-uniform constant infiltration' - call write_log(logstr, 0) - ! - allocate(qinffield(np)) - ! - ! Note : qinf has already been converted to m/s in sfincs_input.f90 ! - ! - do nm = 1, np - if (subgrid) then - if (subgrid_z_zmin(nm) > qinf_zmin) then - qinffield(nm) = qinf - else - qinffield(nm) = 0.0 - endif - else - if (zb(nm) > qinf_zmin) then - qinffield(nm) = qinf - else - qinffield(nm) = 0.0 - endif - endif - enddo - ! - elseif (inftype == 'c2d') then - ! - ! Spatially-varying constant infiltration - ! - write(logstr,'(a)')'Info : turning on spatially-varying constant infiltration' - call write_log(logstr, 0) - ! - allocate(qinffield(np)) - ! - qinffield = 0.0 - ! - ! Read spatially-varying infiltration (specified in +mm/hr) - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'qinf' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) !ncfile, varname, varout) - ! - else ! from separate qinffile - only binary: - ! - write(logstr,'(a,a)')'Info : reading infiltration file ', trim(qinffile) - call write_log(logstr, 0) - ! - ok = check_file_exists(qinffile, 'Infiltration qinf file', .true.) - ! - open(unit = 500, file = trim(qinffile), form = 'unformatted', access = 'stream') - read(500)qinffield - close(500) - ! - endif - ! - ! Generic needed conversion: - ! - qinffield = qinffield / 3600 / 1000 ! convert to +m/s - ! - elseif (inftype == 'cna') then - ! - ! Spatially-varying infiltration with CN numbers (old) - ! - write(logstr,'(a)')'Info : turning on infiltration (via Curve Number method - A)' - call write_log(logstr, 0) - ! - allocate(qinffield(np)) - ! - qinffield = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'scs' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) - ! - else ! from separate scsfile - only binary: - ! - write(logstr,'(a,a)')'Info : reading scs file ',trim(scsfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(scsfile, 'Infiltration scs file', .true.) - ! - open(unit = 500, file = trim(scsfile), form = 'unformatted', access = 'stream') - read(500)qinffield - close(500) - ! - endif - ! - ! Generic needed conversion: - ! - qinffield = qinffield * 0.0254 ! to m - ! already convert qinffield from inches to m here - ! - elseif (inftype == 'cnb') then - ! - ! Spatially-varying infiltration with CN numbers (new) - ! - write(logstr,'(a)')'Info : turning on infiltration (via Curve Number method - B)' - call write_log(logstr, 0) - ! - ! Allocate Smax - allocate(qinffield(np)) - qinffield = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'smax' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) - ! - else ! from separate smaxfile - only binary: - ! - write(logstr,'(a,a)')'Info : reading smax file ',trim(smaxfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(smaxfile, 'Infiltration smax file', .true.) - ! - open(unit = 500, file = trim(smaxfile), form = 'unformatted', access = 'stream') - read(500)qinffield - close(500) - ! - endif - ! - ! Allocate Se - allocate(scs_Se(np)) - scs_Se = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'seff' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, scs_Se) - ! - else ! from separate sefffile - only binary: - ! - write(logstr,'(a,a)')'Info : reading seff file ',trim(sefffile) - call write_log(logstr, 0) - ! - ok = check_file_exists(sefffile, 'Infiltration seff file', .true.) - ! - open(unit = 501, file = trim(sefffile), form = 'unformatted', access = 'stream') - read(501)scs_Se - close(501) - ! - endif - ! - ! Allocate Ks - ! - allocate(ksfield(np)) - ksfield = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'ks' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, ksfield) - ! - else ! from separate ksfile - only binary: - ! - write(logstr,'(a,a)')'Info : reading ks file ',trim(ksfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(ksfile, 'Infiltration ks file', .true.) - ! - open(unit = 502, file = trim(ksfile), form = 'unformatted', access = 'stream') - read(502)ksfield - close(502) - ! - endif - ! - ! Generic needed conversion: - ! - ! Compute recovery ! Equation 4-36 - ! - allocate(inf_kr(np)) - inf_kr = sqrt(ksfield/25.4) / 75 ! Note that we assume ksfield to be in mm/hr, convert it here to inch/hr (/25.4) - ! /75 is conversion to recovery rate (in days) - ! - ! Allocate support variables: - ! - allocate(scs_P1(np)) - scs_P1 = 0.0 - allocate(scs_F1(np)) - scs_F1 = 0.0 - allocate(rain_T1(np)) - rain_T1 = 0.0 - allocate(scs_S1(np)) - scs_S1 = 0.0 - allocate(scs_rain(np)) - scs_rain = 0 - ! - elseif (inftype == 'gai') then - ! - ! Spatially-varying infiltration with the Green-Ampt (GA) model - ! - call write_log('Info : turning on process infiltration (via Green-Ampt)', 0) - ! - ! Allocate suction head at the wetting front - ! - allocate(GA_head(np)) - GA_head = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'psi' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, GA_head) - ! - else ! from separate psifile - only binary: - ! - write(logstr,'(a,a)')'Info : reading psi file ',trim(psifile) - call write_log(logstr, 0) - ! - ok = check_file_exists(psifile, 'Infiltration psi file', .true.) - ! - open(unit = 500, file = trim(psifile), form = 'unformatted', access = 'stream') - read(500)GA_head - close(500) - ! - endif - ! - ! Allocate maximum soil moisture deficit - ! - allocate(GA_sigma_max(np)) - GA_sigma_max = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'sigma' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, GA_sigma_max) - ! - else ! from separate sigmafile - only binary: - ! - write(logstr,'(a,a)')'Info : reading sigma file ',trim(sigmafile) - call write_log(logstr, 0) - ! - ok = check_file_exists(sigmafile, 'Infiltration sigma file', .true.) - ! - open(unit = 501, file = trim(sigmafile), form = 'unformatted', access = 'stream') - read(501)GA_sigma_max - close(501) - ! - endif - ! - ! Allocate saturated hydraulic conductivity - ! - allocate(ksfield(np)) - ksfield = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'ks' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, ksfield) - ! - else ! from separate ksfile - only binary: - ! - write(logstr,'(a,a)')'Info : reading ks file ',trim(ksfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(ksfile, 'Infiltration ks file', .true.) - ! - open(unit = 502, file = trim(ksfile), form = 'unformatted', access = 'stream') - read(502)ksfield - close(502) - ! - endif - - ! - ! Generic needed conversion: - ! - ! Compute recovery ! Equation 4-36 - ! - allocate(inf_kr(np)) - inf_kr = sqrt(ksfield/25.4) / 75 ! Note that we assume ksfield to be in mm/hr, convert it here to inch/hr (/25.4) - ! /75 is conversion to recovery rate (in days) - - allocate(rain_T1(np)) ! minimum amount of time that a soil must remain in recovery - rain_T1 = 0.0 - ! - ! Allocate support variables - ! - allocate(GA_sigma(np)) ! variable for sigma_max_du - GA_sigma = GA_sigma_max - allocate(GA_F(np)) ! total infiltration - GA_F = 0.0 - allocate(GA_Lu(np)) ! depth of upper soil recovery zone - GA_Lu = 4 * sqrt(25.4) * sqrt(ksfield) ! Equation 4-33 - ! - ! Input values for green-ampt are in mm and mm/hr, but computation is in m a m/s - ! - GA_head = GA_head / 1000 ! from mm to m - GA_Lu = GA_Lu / 1000 ! from mm to m - ksfield = ksfield / 1000 / 3600 ! from mm/hr to m/s - ! - ! First time step doesnt have an estimate yet - ! - ! Allocate support variables: - ! - allocate(qinffield(np)) - qinffield(nm) = 0.0 - ! - elseif (inftype == 'hor') then - ! - ! Spatially-varying infiltration with the modified Horton Equation - ! - call write_log('Info : turning on process infiltration (via modified Horton)', 0) - ! - ! Horton: final infiltration capacity (fc) - ! Note that qinffield = horton_fc (/3600/1000, see below) - ! - allocate(horton_fc(np)) - horton_fc = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'fc' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_fc) - ! - else ! from separate fcfile - only binary: - ! - write(logstr,'(a,a)')'Info : reading fc file ',trim(fcfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(fcfile, 'Infiltration fc file', .true.) - ! - open(unit = 500, file = trim(fcfile), form = 'unformatted', access = 'stream') - read(500)horton_fc - close(500) - ! - endif - ! - ! Horton: initial infiltration capacity (f0) - allocate(horton_f0(np)) - horton_f0 = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'f0' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_f0) - ! - else ! from separate f0file - only binary: - ! - write(logstr,'(a,a)')'Info : reading f0 file ',trim(f0file) - call write_log(logstr, 0) - ! - ok = check_file_exists(f0file, 'Infiltration f0 file', .true.) - ! - open(unit = 501, file = trim(f0file), form = 'unformatted', access = 'stream') - read(501)horton_f0 - close(501) - ! - endif - ! - ! Empirical constant (1/hr) k => note that this is different than ks used in Curve Number and Green-Ampt - allocate(horton_kd(np)) - horton_kd = 0.0 - ! - if (netcdf_infiltration) then - ! - ! Call the generic quadtree nc file reader function - varname = 'kd' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_kd) - ! - else ! from separate kdfile - only binary: - ! - write(logstr,'(a,a)')'Info : reading kd file ',trim(kdfile) - call write_log(logstr, 0) - ! - ok = check_file_exists(kdfile, 'Infiltration kd file', .true.) - ! - open(unit = 502, file = trim(kdfile), form = 'unformatted', access = 'stream') - read(502)horton_kd - close(502) - ! - endif - ! - write(logstr,'(a,a)')'Info : Using constant recovery rate that is based on constant factor relative to ',trim(kdfile) - call write_log(logstr, 0) - ! - ! Generic needed conversion: - ! - ! Prescribe the current estimate (for output only; initial capacity) - qinffield = horton_f0/3600/1000 - ! - ! Allocate support variables: - ! - ! Estimate of time - allocate(rain_T1(np)) - rain_T1 = 0.0 - ! - endif - ! - else - ! - ! Overrule input - ! - store_cumulative_precipitation = .false. - ! - endif - ! - end subroutine - - subroutine initialize_storage_volume() ! use sfincs_data diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index 57a4e2f20..4dd7acc58 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -1,7 +1,590 @@ module sfincs_infiltration + use sfincs_log + use sfincs_error + contains + subroutine initialize_infiltration() + ! + use sfincs_data + use sfincs_ncinput + ! + implicit none + ! + integer :: nm + ! + logical :: ok + ! + character*256 :: varname + ! + ! INFILTRATION + ! + ! Infiltration only works when rainfall is activated ! If you want infiltration without rainfall, use a precip file with 0.0s + ! + ! Note, infiltration methods not designed to be stacked + ! + infiltration = .false. + netcdf_infiltration = .false. + ! + ! Four options for infiltration: + ! + ! 1) Spatially-uniform constant infiltration + ! Requires: - + ! 2) Spatially-varying constant infiltration + ! Requires: qinfmap (does not require qinffield !) + ! 3) Spatially-varying infiltration with CN numbers (old) + ! Requires: cumprcp, cuminf, qinfmap, qinffield + ! 4) Spatially-varying infiltration with CN numbers (new) + ! Requires: qinfmap, qinffield, qinffield, ksfield, scs_P1, scs_F1, scs_Se and scs_rain (but not necessarily cuminf and cumprcp) + ! 5) Spatially-varying infiltration with the Green-Ampt (GA) model + ! Requires: qinfmap, qinffield, ksfield, GA_head, GA_sigma_max, GA_Lu + ! 6) Spatially-varying infiltration with the modified Horton Equation + ! Requires: qinfmap, qinffield, horton_fc, horton_f0 + ! + ! cumprcp and cuminf are stored in the netcdf output if store_cumulative_precipitation == .true. which is the default + ! + ! We need to keep cumprcp and cuminf in memory when: + ! a) store_cumulative_precipitation == .true. + ! or: + ! b) inftype == 'cna' or inftype == 'cnb' + ! + !!!!!!!!!!!!!!!!!!!!! + ! Initializing steps: + !!!!!!!!!!!!!!!!!!!!! + ! + ! 1) First we determine infiltration type + ! + if (precip) then + ! + if (infiltrationfile /= 'none') then + ! + ! inftype is user defined, keyword: 'inftype' in sfincs.inp: + ! + ! inftype is either: c2d, cna, cnb, gai, hor + ! 'inftype = con' is not relevant for netcdf input + ! + infiltration = .true. + netcdf_infiltration = .true. + ! + elseif (qinf > 0.0) then + ! + ! Spatially-uniform constant infiltration (specified as +mm/hr) + ! + inftype = 'con' + infiltration = .true. + ! + elseif (qinffile /= 'none') then + ! + ! Spatially-varying constant infiltration + ! + inftype = 'c2d' + infiltration = .true. + ! + elseif (scsfile /= 'none') then + ! + ! Spatially-varying infiltration with CN numbers (old) + ! + inftype = 'cna' + infiltration = .true. + ! + elseif (sefffile /= 'none') then + ! + ! Spatially-varying infiltration with CN numbers (new) + ! + inftype = 'cnb' + infiltration = .true. + ! + elseif (psifile /= 'none') then + ! + ! The Green-Ampt (GA) model for infiltration + ! + inftype = 'gai' + infiltration = .true. + ! + elseif (f0file /= 'none') then + ! + ! The Horton Equation model for infiltration + ! + inftype = 'hor' + infiltration = .true. + store_meteo = .true. + ! + endif + ! + ! 2) We need cumprcp and cuminf + ! + allocate(cumprcp(np)) + cumprcp = 0.0 + ! + allocate(cuminf(np)) + cuminf = 0.0 + ! + ! 3) Now allocate and read spatially-varying inputs + ! + if (infiltration) then + ! + allocate(qinfmap(np)) + qinfmap = 0.0 + ! + endif + ! + ! 4) Pre-check whether netcdf infiltration file exists - once + ! + if (netcdf_infiltration) then + ! + write(logstr,'(a)')'Info : turning on infiltration from netcdf input file' + call write_log(logstr, 0) + ! + write(logstr,'(a,a)')'Info : reading netcdf infiltration file ', trim(infiltrationfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(infiltrationfile, 'Infiltration netcdf file', .true.) + ! + write(logstr,'(a,a)')'Info : specified inftype is ', trim(inftype) + call write_log(logstr, 0) + ! + endif + ! + ! 5) Check whether infiltration input type (orignal vs netcdf) are correctly matched to grid type (regular vs quadtree) + ! + if (infiltration .and. inftype /= 'con') then !constant uniform works for both options + ! + if (netcdf_infiltration) then + ! + if (use_quadtree .eqv. .false.) then + ! + call stop_sfincs('Error ! Netcdf infiltration input format can only be specified for quadtree mesh model !', 1) + ! + endif + ! + else ! Original + ! + if (use_quadtree .eqv. .true.) then + ! + call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) + endif + ! + endif + ! + endif + ! + ! 6) Read in data per type, either from ascii or general netcdf file + ! + if (inftype == 'con') then + ! + ! Spatially-uniform constant infiltration (specified as +mm/hr) + ! + ! Note : Input directly in sfincs.inp, so no file needs to be read + ! + write(logstr,'(a)')'Info : turning on spatially-uniform constant infiltration' + call write_log(logstr, 0) + ! + allocate(qinffield(np)) + ! + ! Note : qinf has already been converted to m/s in sfincs_input.f90 ! + ! + do nm = 1, np + if (subgrid) then + if (subgrid_z_zmin(nm) > qinf_zmin) then + qinffield(nm) = qinf + else + qinffield(nm) = 0.0 + endif + else + if (zb(nm) > qinf_zmin) then + qinffield(nm) = qinf + else + qinffield(nm) = 0.0 + endif + endif + enddo + ! + elseif (inftype == 'c2d') then + ! + ! Spatially-varying constant infiltration + ! + write(logstr,'(a)')'Info : turning on spatially-varying constant infiltration' + call write_log(logstr, 0) + ! + allocate(qinffield(np)) + ! + qinffield = 0.0 + ! + ! Read spatially-varying infiltration (specified in +mm/hr) + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'qinf' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) !ncfile, varname, varout) + ! + else ! from separate qinffile - only binary: + ! + write(logstr,'(a,a)')'Info : reading infiltration file ', trim(qinffile) + call write_log(logstr, 0) + ! + ok = check_file_exists(qinffile, 'Infiltration qinf file', .true.) + ! + open(unit = 500, file = trim(qinffile), form = 'unformatted', access = 'stream') + read(500)qinffield + close(500) + ! + endif + ! + ! Generic needed conversion: + ! + qinffield = qinffield / 3600 / 1000 ! convert to +m/s + ! + elseif (inftype == 'cna') then + ! + ! Spatially-varying infiltration with CN numbers (old) + ! + write(logstr,'(a)')'Info : turning on infiltration (via Curve Number method - A)' + call write_log(logstr, 0) + ! + allocate(qinffield(np)) + ! + qinffield = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'scs' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) + ! + else ! from separate scsfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading scs file ',trim(scsfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(scsfile, 'Infiltration scs file', .true.) + ! + open(unit = 500, file = trim(scsfile), form = 'unformatted', access = 'stream') + read(500)qinffield + close(500) + ! + endif + ! + ! Generic needed conversion: + ! + qinffield = qinffield * 0.0254 ! to m + ! already convert qinffield from inches to m here + ! + elseif (inftype == 'cnb') then + ! + ! Spatially-varying infiltration with CN numbers (new) + ! + write(logstr,'(a)')'Info : turning on infiltration (via Curve Number method - B)' + call write_log(logstr, 0) + ! + ! Allocate Smax + allocate(qinffield(np)) + qinffield = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'smax' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, qinffield) + ! + else ! from separate smaxfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading smax file ',trim(smaxfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(smaxfile, 'Infiltration smax file', .true.) + ! + open(unit = 500, file = trim(smaxfile), form = 'unformatted', access = 'stream') + read(500)qinffield + close(500) + ! + endif + ! + ! Allocate Se + allocate(scs_Se(np)) + scs_Se = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'seff' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, scs_Se) + ! + else ! from separate sefffile - only binary: + ! + write(logstr,'(a,a)')'Info : reading seff file ',trim(sefffile) + call write_log(logstr, 0) + ! + ok = check_file_exists(sefffile, 'Infiltration seff file', .true.) + ! + open(unit = 501, file = trim(sefffile), form = 'unformatted', access = 'stream') + read(501)scs_Se + close(501) + ! + endif + ! + ! Allocate Ks + ! + allocate(ksfield(np)) + ksfield = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'ks' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, ksfield) + ! + else ! from separate ksfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading ks file ',trim(ksfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(ksfile, 'Infiltration ks file', .true.) + ! + open(unit = 502, file = trim(ksfile), form = 'unformatted', access = 'stream') + read(502)ksfield + close(502) + ! + endif + ! + ! Generic needed conversion: + ! + ! Compute recovery ! Equation 4-36 + ! + allocate(inf_kr(np)) + inf_kr = sqrt(ksfield/25.4) / 75 ! Note that we assume ksfield to be in mm/hr, convert it here to inch/hr (/25.4) + ! /75 is conversion to recovery rate (in days) + ! + ! Allocate support variables: + ! + allocate(scs_P1(np)) + scs_P1 = 0.0 + allocate(scs_F1(np)) + scs_F1 = 0.0 + allocate(rain_T1(np)) + rain_T1 = 0.0 + allocate(scs_S1(np)) + scs_S1 = 0.0 + allocate(scs_rain(np)) + scs_rain = 0 + ! + elseif (inftype == 'gai') then + ! + ! Spatially-varying infiltration with the Green-Ampt (GA) model + ! + call write_log('Info : turning on process infiltration (via Green-Ampt)', 0) + ! + ! Allocate suction head at the wetting front + ! + allocate(GA_head(np)) + GA_head = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'psi' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, GA_head) + ! + else ! from separate psifile - only binary: + ! + write(logstr,'(a,a)')'Info : reading psi file ',trim(psifile) + call write_log(logstr, 0) + ! + ok = check_file_exists(psifile, 'Infiltration psi file', .true.) + ! + open(unit = 500, file = trim(psifile), form = 'unformatted', access = 'stream') + read(500)GA_head + close(500) + ! + endif + ! + ! Allocate maximum soil moisture deficit + ! + allocate(GA_sigma_max(np)) + GA_sigma_max = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'sigma' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, GA_sigma_max) + ! + else ! from separate sigmafile - only binary: + ! + write(logstr,'(a,a)')'Info : reading sigma file ',trim(sigmafile) + call write_log(logstr, 0) + ! + ok = check_file_exists(sigmafile, 'Infiltration sigma file', .true.) + ! + open(unit = 501, file = trim(sigmafile), form = 'unformatted', access = 'stream') + read(501)GA_sigma_max + close(501) + ! + endif + ! + ! Allocate saturated hydraulic conductivity + ! + allocate(ksfield(np)) + ksfield = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'ks' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, ksfield) + ! + else ! from separate ksfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading ks file ',trim(ksfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(ksfile, 'Infiltration ks file', .true.) + ! + open(unit = 502, file = trim(ksfile), form = 'unformatted', access = 'stream') + read(502)ksfield + close(502) + ! + endif + + ! + ! Generic needed conversion: + ! + ! Compute recovery ! Equation 4-36 + ! + allocate(inf_kr(np)) + inf_kr = sqrt(ksfield/25.4) / 75 ! Note that we assume ksfield to be in mm/hr, convert it here to inch/hr (/25.4) + ! /75 is conversion to recovery rate (in days) + + allocate(rain_T1(np)) ! minimum amount of time that a soil must remain in recovery + rain_T1 = 0.0 + ! + ! Allocate support variables + ! + allocate(GA_sigma(np)) ! variable for sigma_max_du + GA_sigma = GA_sigma_max + allocate(GA_F(np)) ! total infiltration + GA_F = 0.0 + allocate(GA_Lu(np)) ! depth of upper soil recovery zone + GA_Lu = 4 * sqrt(25.4) * sqrt(ksfield) ! Equation 4-33 + ! + ! Input values for green-ampt are in mm and mm/hr, but computation is in m a m/s + ! + GA_head = GA_head / 1000 ! from mm to m + GA_Lu = GA_Lu / 1000 ! from mm to m + ksfield = ksfield / 1000 / 3600 ! from mm/hr to m/s + ! + ! First time step doesnt have an estimate yet + ! + ! Allocate support variables: + ! + allocate(qinffield(np)) + qinffield(nm) = 0.0 + ! + elseif (inftype == 'hor') then + ! + ! Spatially-varying infiltration with the modified Horton Equation + ! + call write_log('Info : turning on process infiltration (via modified Horton)', 0) + ! + ! Horton: final infiltration capacity (fc) + ! Note that qinffield = horton_fc (/3600/1000, see below) + ! + allocate(horton_fc(np)) + horton_fc = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'fc' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_fc) + ! + else ! from separate fcfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading fc file ',trim(fcfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(fcfile, 'Infiltration fc file', .true.) + ! + open(unit = 500, file = trim(fcfile), form = 'unformatted', access = 'stream') + read(500)horton_fc + close(500) + ! + endif + ! + ! Horton: initial infiltration capacity (f0) + allocate(horton_f0(np)) + horton_f0 = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'f0' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_f0) + ! + else ! from separate f0file - only binary: + ! + write(logstr,'(a,a)')'Info : reading f0 file ',trim(f0file) + call write_log(logstr, 0) + ! + ok = check_file_exists(f0file, 'Infiltration f0 file', .true.) + ! + open(unit = 501, file = trim(f0file), form = 'unformatted', access = 'stream') + read(501)horton_f0 + close(501) + ! + endif + ! + ! Empirical constant (1/hr) k => note that this is different than ks used in Curve Number and Green-Ampt + allocate(horton_kd(np)) + horton_kd = 0.0 + ! + if (netcdf_infiltration) then + ! + ! Call the generic quadtree nc file reader function + varname = 'kd' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, horton_kd) + ! + else ! from separate kdfile - only binary: + ! + write(logstr,'(a,a)')'Info : reading kd file ',trim(kdfile) + call write_log(logstr, 0) + ! + ok = check_file_exists(kdfile, 'Infiltration kd file', .true.) + ! + open(unit = 502, file = trim(kdfile), form = 'unformatted', access = 'stream') + read(502)horton_kd + close(502) + ! + endif + ! + write(logstr,'(a,a)')'Info : Using constant recovery rate that is based on constant factor relative to ',trim(kdfile) + call write_log(logstr, 0) + ! + ! Generic needed conversion: + ! + ! Prescribe the current estimate (for output only; initial capacity) + qinffield = horton_f0/3600/1000 + ! + ! Allocate support variables: + ! + ! Estimate of time + allocate(rain_T1(np)) + rain_T1 = 0.0 + ! + endif + ! + else + ! + ! Overrule input + ! + store_cumulative_precipitation = .false. + ! + endif + ! + end subroutine + + subroutine update_infiltration_map(dt, tloop) ! ! Update infiltration rates in each grid cell From 0dc07201b981cd109e68bc79cc7229e5c76ec882 Mon Sep 17 00:00:00 2001 From: Leynse Date: Thu, 12 Feb 2026 09:52:01 +0100 Subject: [PATCH 11/65] - Add check whether specified infiltrationtype is correct --- source/src/sfincs_infiltration.f90 | 29 ++++++++++++++++++++++++----- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index 4dd7acc58..bce4af73f 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -18,6 +18,11 @@ subroutine initialize_infiltration() ! character*256 :: varname ! + character(len=3), parameter :: allowed_types(5) = & + ['c2d', 'cna', 'cnb', 'gai', 'hor'] + + logical :: inftype_exists + ! ! INFILTRATION ! ! Infiltration only works when rainfall is activated ! If you want infiltration without rainfall, use a precip file with 0.0s @@ -64,8 +69,25 @@ subroutine initialize_infiltration() ! inftype is either: c2d, cna, cnb, gai, hor ! 'inftype = con' is not relevant for netcdf input ! - infiltration = .true. - netcdf_infiltration = .true. + ! Check if specified type is correct + ! + inftype_exists = any(inftype == allowed_types) + ! + if (inftype_exists) then + ! + infiltration = .true. + netcdf_infiltration = .true. + ! + write(logstr,'(a,a)')'Info : specified infiltrationtype is ', trim(inftype) + call write_log(logstr, 0) + ! + else + ! + write(logstr,*)'Error : infiltration input type ',trim(inftype),' is not part of supported types c2d cna cnb gai hor !' + call stop_sfincs(trim(logstr), 1) + ! + end if + ! ! elseif (qinf > 0.0) then ! @@ -141,9 +163,6 @@ subroutine initialize_infiltration() ! ok = check_file_exists(infiltrationfile, 'Infiltration netcdf file', .true.) ! - write(logstr,'(a,a)')'Info : specified inftype is ', trim(inftype) - call write_log(logstr, 0) - ! endif ! ! 5) Check whether infiltration input type (orignal vs netcdf) are correctly matched to grid type (regular vs quadtree) From 2a1a97489877705606b9b1573a3779a512f4ede2 Mon Sep 17 00:00:00 2001 From: Tim Leijnse Date: Fri, 6 Mar 2026 11:13:38 +0100 Subject: [PATCH 12/65] - Added version for reading in netcdf quadtree manningfile (#271) * - Added version for reading in netcdf quadtree manningfile - For now: input argument is still manningfile, internally checked whether it is a netcdf file or binary - For now: expected variable in the netcdf file is 'manning' - For now: tested only with dummy of stoarge nc file - Full testing pending on having ncinput example * - Add non-stopping warning if a manningfile is prescribed while there is also a subgridfile, because then it will be unused! * - Bugfix in general read_netcdf_quadtree_to_sfincs routine * - Bugfix that the netcdf manningfile is actually read in * - Now define 'rghfield' in sfincs_data.f90 rather than sfincs_domain.f90, so we can use that variable for output to netcdf file * - Add 'manning' as netcdf output in case not a subgrid model, and if manningfile supplied (either binary for regular model, or as netcdf for quadtree - Tested and working for new quadtree netcdf manningfile input --- source/src/sfincs_data.f90 | 1 + source/src/sfincs_domain.f90 | 39 +++++++++++++++++--- source/src/sfincs_lib.f90 | 2 +- source/src/sfincs_ncinput.F90 | 4 ++- source/src/sfincs_ncoutput.F90 | 65 +++++++++++++++++++++++++++++++++- 5 files changed, 103 insertions(+), 8 deletions(-) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index c778c4925..ac55df396 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -373,6 +373,7 @@ module sfincs_data real*4, dimension(:), allocatable, target :: z_yz real*4, dimension(:), allocatable :: cell_area_m2 real*4, dimension(:), allocatable :: nuvisc + real*4, dimension(:), allocatable :: rghfield ! ! UV-points ! diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 8b789fb50..b5bc0a447 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -1945,16 +1945,19 @@ subroutine initialize_boundaries() subroutine initialize_roughness() ! use sfincs_data + use sfincs_ncinput ! implicit none ! - real*4, dimension(:), allocatable :: rghfield ! integer :: ip integer :: nm integer :: nmu logical :: ok ! + integer :: nchar + character*256 :: varname + ! ! FRICTION COEFFICIENTS (only for regular bathymetry, as for subgrid the Manning's n values are stored in the tables) ! if (.not. subgrid) then @@ -1963,19 +1966,35 @@ subroutine initialize_roughness() ! gn2uv = 9.81*0.02*0.02 ! - if (manningfile(1:4) /= 'none') then + if (manningfile(1:4) /= 'none') then ! ! Read spatially-varying friction + ! File is either binary or netcdf ! allocate(rghfield(np)) + ! write(logstr,'(a,a)')'Info : reading roughness file ',trim(manningfile) call write_log(logstr, 0) ! + nchar = len_trim(manningfile) + ! ok = check_file_exists(manningfile, 'Roughness file', .true.) ! - open(unit = 500, file = trim(manningfile), form = 'unformatted', access = 'stream') - read(500)rghfield - close(500) + if (manningfile(nchar - 1 : nchar) == 'nc') then + ! + ! Call the generic quadtree nc file reader function + varname = 'manning' + call read_netcdf_quadtree_to_sfincs(manningfile, varname, rghfield) !ncfile, varname, varout) + ! + else + ! + ! Read from binary file + ! + open(unit = 500, file = trim(manningfile), form = 'unformatted', access = 'stream') + read(500)rghfield + close(500) + ! + endif ! do ip = 1, npuv nm = uv_index_z_nm(ip) @@ -2012,6 +2031,16 @@ subroutine initialize_roughness() enddo ! endif + else + ! + ! Give warning if manningfile is supplied, but also a subgrid file + ! + if (manningfile(1:4) /= 'none') then + ! + call write_log('Warning : manningfile input will be ignored because SFINCS will use the friction information from sbgfile!', 1) + ! + endif + ! endif ! end subroutine diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 898905cc2..07aeb92fd 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -92,7 +92,7 @@ function sfincs_initialize() result(ierr) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - build_revision = "$Rev: v2.3.1 mt. Faber" + build_revision = "$Rev: v2.3.1 mt. Faber+branch-270" build_date = "$Date: 2025-02-04" ! call write_log('', 1) diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index 7f4ef894c..96687cd25 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -299,7 +299,9 @@ subroutine read_netcdf_quadtree_to_sfincs(ncfile, varname, var) ! nm = index_sfincs_in_quadtree(ip) ! - var(nm) = vartmp(ip) + if (nm>0) then + var(nm) = vartmp(ip) + endif ! enddo ! diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 7042a0424..3fcfbe9d6 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -23,6 +23,7 @@ module sfincs_ncoutput integer :: fwx_varid, fwy_varid, beta_varid, snapwavedepth_varid integer :: zsm_varid, tsunami_arrival_time_varid integer :: inp_varid, total_runtime_varid, average_dt_varid, status_varid + integer :: manning_varid integer :: pnonh_varid integer :: subgridslope_varid ! @@ -241,6 +242,16 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'coordinates', 'x y')) endif ! + if (.not. subgrid) then + NF90(nf90_def_var(map_file%ncid, 'manning', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid/), map_file%manning_varid)) ! bed level in cell centre + NF90(nf90_def_var_deflate(map_file%ncid, map_file%manning_varid, 1, 1, nc_deflate_level)) ! deflate + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, 'units', 's/m^1/3')) + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, 'standard_name', 'manning')) + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, 'long_name', 'manning_roughness')) + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, 'coordinates', 'x y')) + endif + ! if (subgrid .and. store_hsubgrid .and. store_hmean) then ! ! The subgrid slope (zmax - zmin) / sqrt(A) is used for making high-res flood maps @@ -769,6 +780,25 @@ subroutine ncoutput_regular_map_init() ! endif ! + ! Write Manning (only non-subgrid model) + ! + if (.not. subgrid .and. manning2d) then + ! + zsg = FILL_VALUE + ! + do nm = 1, np + ! + n = z_index_z_n(nm) + m = z_index_z_m(nm) + ! + zsg(m, n) = rghfield(nm) ! gn2uv is on uv-points, but rghfield is in center + ! + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%manning_varid, zsg, (/1, 1/))) + ! + endif + ! ! Write infiltration map ! if (infiltration) then @@ -815,7 +845,7 @@ subroutine ncoutput_quadtree_map_init() ! implicit none ! - integer :: nm, nmq, n, m, nn, ntmx, n_nodes, n_faces, iref + integer :: nm, nmq, nmu1, num1, n, m, nn, ntmx, n_nodes, n_faces, iref real*4 :: dxx, dyy ! real, dimension(:), allocatable :: nodes_x @@ -978,6 +1008,17 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'standard_name', 'altitude')) NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'bed_level_above_reference_level')) ! + if (.not. subgrid) then + ! + NF90(nf90_def_var(map_file%ncid, 'manning', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%manning_varid)) ! bed level in cell centre + NF90(nf90_def_var_deflate(map_file%ncid, map_file%manning_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, 'units', 's/m^1/3')) + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, 'standard_name', 'manning')) + NF90(nf90_put_att(map_file%ncid, map_file%manning_varid, 'long_name', 'manning_roughness')) + ! + endif + ! if (subgrid .and. store_hsubgrid .and. store_hmean) then ! ! The subgrid slope (zmax - zmin) / sqrt(A) is used for making high-res flood maps @@ -1463,6 +1504,28 @@ subroutine ncoutput_quadtree_map_init() ! endif ! + ! Write Manning (only non-subgrid model) + ! + if (.not. subgrid .and. manning2d) then + ! + vtmp = FILL_VALUE + ! + do nmq = 1, quadtree_nr_points + ! + nm = index_sfincs_in_quadtree(nmq) + ! + if (nm>0) then + ! + vtmp(nmq) = rghfield(nm) ! gn2uv is on uv-points, but rghfield is in center + ! + endif + ! + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%manning_varid, vtmp)) + ! + endif + ! ! Write infiltration map ! vtmp = FILL_VALUE From 167387b1f6b5dd83b0a70188392a975ca147b9be Mon Sep 17 00:00:00 2001 From: Leynse Date: Fri, 6 Mar 2026 15:51:13 +0100 Subject: [PATCH 13/65] - Bump date --- source/src/sfincs_lib.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index bdeb3e139..11318103e 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -93,7 +93,7 @@ function sfincs_initialize() result(ierr) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! build_revision = "$Rev: v2.3.1 mt. Faber+branch-272" - build_date = "$Date: 2025-02-04" + build_date = "$Date: 2026-03-06" ! call write_log('', 1) call write_log('------------ Welcome to SFINCS ------------', 1) From a0ed4a044a78cd8e522654237ed25ada8e423ac0 Mon Sep 17 00:00:00 2001 From: Kees Nederhoff Date: Wed, 18 Mar 2026 07:22:48 -0700 Subject: [PATCH 14/65] Progress with redoing continuity logic, adding new infiltration flavor, adding option to mimic drainage --- source/src/sfincs_continuity.f90 | 165 +++++++++++++----- source/src/sfincs_data.f90 | 21 +++ source/src/sfincs_domain.f90 | 80 ++++++++- source/src/sfincs_infiltration.f90 | 258 +++++++++++++++++++++++------ source/src/sfincs_input.f90 | 7 +- source/src/sfincs_lib.f90 | 18 +- source/src/sfincs_meteo.f90 | 38 ++--- source/src/sfincs_openacc.f90 | 10 +- 8 files changed, 457 insertions(+), 140 deletions(-) diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index 251951150..bcfc9699a 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -1,7 +1,62 @@ module sfincs_continuity contains - + + subroutine update_continuity(t, dt, tloopsrc, tloopinf, tloopcont) + ! + ! Unified continuity update: orchestrates all water balance terms + ! + ! A. Discharges, sources and sinks => computed in sfincs_discharges + ! B. Hydrodynamic fluxes (q) => already computed in sfincs_momentum + ! C. Main adjustments: + ! 1. Rainfall (+) => already computed in sfincs_meteo (prcp) + ! 2. Infiltration (-) => computed in sfincs_infiltration (qinfmap) + ! (includes: con, c2d, cna, cnb, gai, hor, bkt flavors) + ! 3. Drainage mimic (-) => simple constant rate (qdrain_rate) + ! 4. External source/sink qext (+/-) => set via BMI coupling + ! 5. Storage volume => depression storage (subgrid only) + ! + ! compute_water_levels then applies all terms to update zs/z_volume: + ! A. Discharges (+/-) => outside main loop + ! B. Hydrodynamic fluxes => div(q) * dt + ! C1. Rainfall (+) => prcp * dt + ! C2. Infiltration (-) => qinfmap * dt + ! C3. Drainage mimic (-) => qdrain_rate * dt + ! C4. External source/sink (+/-) => qext * dt + ! C5. Storage volume => absorbs excess volume + ! + use sfincs_data + use sfincs_infiltration + use sfincs_discharges + ! + implicit none + ! + real*8 :: t + real*4 :: dt + real :: tloopsrc + real :: tloopinf + real :: tloopcont + ! + ! A. Update discharges, sources and sinks + ! + call update_discharges(t, dt, tloopsrc) + ! + ! C2. Compute infiltration rates => qinfmap (all flavors including bucket) + ! + if (infiltration) then + call update_infiltration_map(dt, tloopinf) + endif + ! + ! C1, C3, C4, C5: rainfall, drainage mimic, qext, storage_volume + ! => nothing to compute, these are direct rates applied in compute_water_levels + ! + ! B + C: Update water levels (applies all terms) + ! + call compute_water_levels(t, dt, tloopcont) + ! + end subroutine + + subroutine compute_water_levels(t, dt, tloop) ! use sfincs_data @@ -75,7 +130,7 @@ subroutine compute_water_levels_regular(dt,t) ! endif ! - !$acc parallel present( kcs, zs, zb, netprcp, prcp, q, qext, zsmax, zsm, maxzsm, & + !$acc parallel present( kcs, zs, zb, prcp, q, qext, qinfmap, qdrain_rate, zsmax, zsm, maxzsm, & !$acc z_flags_iref, uv_flags_iref, & !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & @@ -85,24 +140,24 @@ subroutine compute_water_levels_regular(dt,t) ! First discharges (don't do this parallel, as it's probably not worth it) ! if (nsrcdrn > 0) then - ! + ! !$acc loop do isrc = 1, nsrcdrn - ! + ! nm = nmindsrc(isrc) - ! + ! if (crsgeo) then - ! + ! zs(nmindsrc(isrc)) = max(zs(nm) + qtsrc(isrc) * dt / cell_area_m2(nm), zb(nm)) - ! + ! else - ! + ! zs(nmindsrc(isrc)) = max(zs(nm) + qtsrc(isrc) * dt / cell_area(z_flags_iref(nm)), zb(nm)) - ! + ! endif - ! + ! enddo - ! + ! endif ! !$omp parallel & @@ -110,21 +165,31 @@ subroutine compute_water_levels_regular(dt,t) !$omp do schedule ( dynamic, 256 ) !$acc loop gang vector do nm = 1, np - ! + ! if (kcs(nm) == 1) then ! Regular point + ! + ! C1. Rainfall (+) ! if (precip) then - ! - zs(nm) = zs(nm) + netprcp(nm) * dt - ! + zs(nm) = zs(nm) + prcp(nm) * dt + endif + ! + ! C2. Infiltration (-) (includes all flavors: con, c2d, cna, cnb, gai, hor, bkt) + ! + if (infiltration) then + zs(nm) = zs(nm) - qinfmap(nm) * dt endif ! + ! C3. Drainage mimic (-) + ! + if (use_drainage_mimic) then + zs(nm) = zs(nm) - qdrain_rate(nm) * dt + endif + ! + ! C4. External source/sink (+/-) + ! if (use_qext) then - ! - ! Add external source (e.g. from XMI coupling) - ! - zs(nm) = zs(nm) + qext(nm) * dt - ! + zs(nm) = zs(nm) + qext(nm) * dt endif ! nmd = z_index_uv_md(nm) @@ -329,9 +394,9 @@ subroutine compute_water_levels_subgrid(dt,t) !$omp do schedule ( dynamic, 256 ) !$acc parallel present( kcs, zs, zs0, zb, z_volume, zsmax, zsm, maxzsm, zsderv, & !$acc subgrid_z_zmin, subgrid_z_zmax, subgrid_z_dep, subgrid_z_volmax, & - !$acc netprcp, prcp, q, qext, z_flags_iref, uv_flags_iref, & + !$acc prcp, q, qext, qinfmap, qdrain_rate, z_flags_iref, uv_flags_iref, & !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & - !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & + !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, storage_volume) !$acc loop gang vector do nm = 1, np @@ -470,32 +535,40 @@ subroutine compute_water_levels_subgrid(dt,t) ! endif ! - if (precip .or. use_qext) then - ! - dzsdt = 0.0 - ! - if (precip) then - ! - ! Add nett rainfall - ! - dzsdt = dzsdt + netprcp(nm) - ! - endif - ! - if (use_qext) then - ! - ! Add external source (e.g. from XMI coupling) - ! - dzsdt = dzsdt + qext(nm) - ! - endif - ! - ! dzsdt is still in m/s, so multiply with a * dt to get m^3 - ! - dvol = dvol + dzsdt * a * dt - ! + dzsdt = 0.0 + ! + ! C1. Rainfall (+) + ! + if (precip) then + dzsdt = dzsdt + prcp(nm) endif ! + ! C2. Infiltration (-) (includes all flavors: con, c2d, cna, cnb, gai, hor, bkt) + ! + if (infiltration) then + dzsdt = dzsdt - qinfmap(nm) + endif + ! + ! C3. Drainage mimic (-) + ! + if (use_drainage_mimic) then + dzsdt = dzsdt - qdrain_rate(nm) + endif + ! + ! C4. External source/sink (+/-) + ! + if (use_qext) then + dzsdt = dzsdt + qext(nm) + endif + ! + ! dzsdt is still in m/s, so multiply with a * dt to get m^3 + ! + if (dzsdt /= 0.0) then + dvol = dvol + dzsdt * a * dt + endif + ! + ! C5. Storage volume + ! if (use_storage_volume) then ! ! If water enters the cell through a point discharge, it will NOT end up in storage volume ! diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index b3108611f..111c4cc5c 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -170,6 +170,8 @@ module sfincs_data character*256 :: f0file character*256 :: fcfile character*256 :: kdfile + character*256 :: drainagefile + character*256 :: bucketfile character*256 :: z0lfile character*256 :: wvmfile character*256 :: qtrfile @@ -408,6 +410,20 @@ module sfincs_data ! real*4, dimension(:), allocatable :: storage_volume ! Storage volume green infra ! + ! Drainage mimic - constant removal rate representing subsurface drainage + ! + logical :: use_drainage_mimic = .false. + real*4 :: qdrain_uniform = 0.0 ! uniform drainage rate (mm/hr input, stored as m/s) + real*4, dimension(:), allocatable :: qdrain_rate ! drainage rate per cell (m/s) + ! + ! Bucket model - finite capacity reservoir with linear drainage + ! + logical :: use_bucket_model = .false. + real*4, dimension(:), allocatable :: bucket_volume ! current storage (m) + real*4, dimension(:), allocatable :: bucket_capacity ! max capacity S_max (m) + real*4, dimension(:), allocatable :: bucket_k ! drainage coefficient (1/s) + real*4, dimension(:), allocatable :: bucket_drain_rate ! net removal from surface this step (m/s) + ! ! Wind reduction for spiderweb winds ! real*4, dimension(:,:), allocatable :: z0land ! z0 values over land for spiderweb wind speed reduction @@ -924,6 +940,11 @@ subroutine finalize_parameters() if(allocated(qinffield)) deallocate(qinffield) if(allocated(ksfield)) deallocate(ksfield) if(allocated(scs_Se)) deallocate(scs_Se) + if(allocated(qdrain_rate)) deallocate(qdrain_rate) + if(allocated(bucket_volume)) deallocate(bucket_volume) + if(allocated(bucket_capacity)) deallocate(bucket_capacity) + if(allocated(bucket_k)) deallocate(bucket_k) + if(allocated(bucket_drain_rate)) deallocate(bucket_drain_rate) if(allocated(nuvisc)) deallocate(nuvisc) ! ! Boundary velocity points diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 6a1d2e229..7cfce450b 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -23,7 +23,9 @@ subroutine initialize_domain() ! call initialize_roughness() ! - call initialize_infiltration() ! see: sfincs_infiltration.f90 + call initialize_infiltration() ! see: sfincs_infiltration.f90 (includes bucket model if bucketfile specified) + ! + call initialize_drainage_mimic() ! call initialize_storage_volume() ! @@ -2047,6 +2049,82 @@ subroutine initialize_roughness() end subroutine + subroutine initialize_drainage_mimic() + ! + use sfincs_data + use sfincs_ncinput + ! + implicit none + ! + integer :: nm + integer :: nchar + logical :: ok + character*256 :: varname + ! + ! Check if drainage mimic is enabled + ! + if (qdrain_uniform > 0.0 .or. drainagefile /= 'none') then + ! + use_drainage_mimic = .true. + ! + allocate(qdrain_rate(np)) + ! + if (drainagefile /= 'none') then + ! + ! Spatially-varying drainage rate + ! + write(logstr,'(a)')'Info : turning on drainage mimic (spatially-varying)' + call write_log(logstr, 0) + ! + nchar = len_trim(drainagefile) + ok = check_file_exists(drainagefile, 'Drainage file', .true.) + ! + if (drainagefile(nchar - 1 : nchar) == 'nc') then + ! + varname = 'drainage_rate' + call read_netcdf_quadtree_to_sfincs(drainagefile, varname, qdrain_rate) + ! + ! Convert from mm/hr to m/s + ! + qdrain_rate = qdrain_rate / 3600.0 / 1000.0 + ! + else + ! + ! Read from binary file (assumed to be in mm/hr) + ! + open(unit = 500, file = trim(drainagefile), form = 'unformatted', access = 'stream') + read(500)qdrain_rate + close(500) + ! + ! Convert from mm/hr to m/s + ! + qdrain_rate = qdrain_rate / 3600.0 / 1000.0 + ! + endif + ! + else + ! + ! Uniform drainage rate (already converted to m/s in sfincs_input.f90) + ! + write(logstr,'(a,f10.4,a)')'Info : turning on drainage mimic (uniform, ', qdrain_uniform * 3600.0 * 1000.0, ' mm/hr)' + call write_log(logstr, 0) + ! + qdrain_rate = qdrain_uniform + ! + endif + ! + else + ! + ! Allocate minimal arrays for OpenACC compatibility + ! + allocate(qdrain_rate(1)) + qdrain_rate = 0.0 + ! + endif + ! + end subroutine + + subroutine initialize_storage_volume() ! use sfincs_data diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index bce4af73f..7c6496155 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -18,8 +18,8 @@ subroutine initialize_infiltration() ! character*256 :: varname ! - character(len=3), parameter :: allowed_types(5) = & - ['c2d', 'cna', 'cnb', 'gai', 'hor'] + character(len=3), parameter :: allowed_types(6) = & + ['c2d', 'cna', 'cnb', 'gai', 'hor', 'bkt'] logical :: inftype_exists ! @@ -32,20 +32,22 @@ subroutine initialize_infiltration() infiltration = .false. netcdf_infiltration = .false. ! - ! Four options for infiltration: + ! Seven infiltration flavors (inftype): ! - ! 1) Spatially-uniform constant infiltration - ! Requires: - - ! 2) Spatially-varying constant infiltration - ! Requires: qinfmap (does not require qinffield !) - ! 3) Spatially-varying infiltration with CN numbers (old) - ! Requires: cumprcp, cuminf, qinfmap, qinffield - ! 4) Spatially-varying infiltration with CN numbers (new) - ! Requires: qinfmap, qinffield, qinffield, ksfield, scs_P1, scs_F1, scs_Se and scs_rain (but not necessarily cuminf and cumprcp) - ! 5) Spatially-varying infiltration with the Green-Ampt (GA) model - ! Requires: qinfmap, qinffield, ksfield, GA_head, GA_sigma_max, GA_Lu - ! 6) Spatially-varying infiltration with the modified Horton Equation - ! Requires: qinfmap, qinffield, horton_fc, horton_f0 + ! 1) 'con' - Spatially-uniform constant infiltration + ! Requires: qinf (mm/hr in sfincs.inp) + ! 2) 'c2d' - Spatially-varying constant infiltration + ! Requires: qinffile or infiltrationfile + ! 3) 'cna' - SCS Curve Number (old, no recovery) + ! Requires: scsfile or infiltrationfile + ! 4) 'cnb' - SCS Curve Number (new, with recovery) + ! Requires: sefffile or infiltrationfile + ! 5) 'gai' - Green-Ampt infiltration + ! Requires: psifile or infiltrationfile + ! 6) 'hor' - Modified Horton equation + ! Requires: f0file or infiltrationfile + ! 7) 'bkt' - Bucket model (linear reservoir, HBV/wflow style) + ! Requires: bucketfile (netcdf with bucket_smax and bucket_k) ! ! cumprcp and cuminf are stored in the netcdf output if store_cumulative_precipitation == .true. which is the default ! @@ -83,7 +85,7 @@ subroutine initialize_infiltration() ! else ! - write(logstr,*)'Error : infiltration input type ',trim(inftype),' is not part of supported types c2d cna cnb gai hor !' + write(logstr,*)'Error : infiltration input type ',trim(inftype),' is not part of supported types c2d cna cnb gai hor bkt !' call stop_sfincs(trim(logstr), 1) ! end if @@ -124,7 +126,7 @@ subroutine initialize_infiltration() inftype = 'gai' infiltration = .true. ! - elseif (f0file /= 'none') then + elseif (f0file /= 'none') then ! ! The Horton Equation model for infiltration ! @@ -132,6 +134,13 @@ subroutine initialize_infiltration() infiltration = .true. store_meteo = .true. ! + elseif (bucketfile /= 'none') then + ! + ! Bucket model (linear reservoir) + ! + inftype = 'bkt' + infiltration = .true. + ! endif ! ! 2) We need cumprcp and cuminf @@ -498,7 +507,7 @@ subroutine initialize_infiltration() ! Allocate support variables: ! allocate(qinffield(np)) - qinffield(nm) = 0.0 + qinffield = 0.0 ! elseif (inftype == 'hor') then ! @@ -591,6 +600,14 @@ subroutine initialize_infiltration() allocate(rain_T1(np)) rain_T1 = 0.0 ! + elseif (inftype == 'bkt') then + ! + ! Bucket model (linear reservoir) - mimics hydrology models like wflow/HBV + ! + call write_log('Info : turning on process infiltration (via bucket model)', 0) + ! + call initialize_bucket_model() + ! endif ! else @@ -634,7 +651,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( nm ) !$omp do - !$acc parallel present( qinfmap, qinffield, z_volume, zs, zb, netprcp, cuminf ) + !$acc parallel present( qinfmap, qinffield, z_volume, zs, zb, cuminf ) !$acc loop independent gang vector do nm = 1, np ! @@ -656,17 +673,13 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - ! Compute nett precip - ! - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration ! cuminf(nm) = cuminf(nm) + qinfmap(nm) * dt ! - endif + endif ! enddo !$omp end do @@ -680,7 +693,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( Qq,I,nm ) !$omp do - !$acc parallel present( qinfmap, qinffield, prcp, netprcp, cumprcp, cuminf ) + !$acc parallel present( qinfmap, qinffield, prcp, cumprcp, cuminf ) !$acc loop independent gang vector do nm = 1, np ! @@ -702,10 +715,6 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - ! Compute nett precip - ! - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration @@ -726,7 +735,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( Qq,I,nm ) !$omp do - !$acc parallel present( qinfmap, prcp, netprcp, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, qinffield, inf_kr ) + !$acc parallel present( qinfmap, prcp, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, qinffield, inf_kr ) !$acc loop independent gang vector do nm = 1, np ! @@ -808,10 +817,6 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - ! Compute nett precip - ! - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration @@ -822,7 +827,7 @@ subroutine update_infiltration_map(dt, tloop) ! enddo !$omp end do - !$omp end parallel + !$omp end parallel !$acc end parallel ! elseif (inftype == 'gai') then @@ -832,7 +837,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( nm ) !$omp do - !$acc parallel present( qinfmap, prcp, netprcp, cuminf, rain_T1, & + !$acc parallel present( qinfmap, prcp, cuminf, rain_T1, & !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr ) !$acc loop independent gang vector do nm = 1, np @@ -853,8 +858,18 @@ subroutine update_infiltration_map(dt, tloop) ! ! Larger amounts of rainfall - Equation 4-27 from SWMM manual ! - qinfmap(nm) = (ksfield(nm) * (1.0 + (GA_head(np) * GA_sigma(np)) / GA_F(nm))) - qinfmap(nm) = max(min(qinfmap(nm), prcp(nm)), 0.0) ! never more than rainfall and and never negative + if (GA_F(nm) < 1.0e-10) then + ! + ! No cumulative infiltration yet (first timestep) - all rainfall infiltrates + ! + qinfmap(nm) = prcp(nm) + ! + else + ! + qinfmap(nm) = (ksfield(nm) * (1.0 + (GA_head(nm) * GA_sigma(nm)) / GA_F(nm))) + qinfmap(nm) = max(min(qinfmap(nm), prcp(nm)), 0.0) ! never more than rainfall and never negative + ! + endif ! endif ! @@ -891,11 +906,6 @@ subroutine update_infiltration_map(dt, tloop) endif endif ! - ! Compute nett precip - ! - !qinffield(nm) = qinfmap(nm) ! Really ? Why ? - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration @@ -906,7 +916,7 @@ subroutine update_infiltration_map(dt, tloop) ! enddo !$omp end do - !$omp end parallel + !$omp end parallel !$acc end parallel ! elseif (inftype == 'hor') then @@ -916,7 +926,7 @@ subroutine update_infiltration_map(dt, tloop) !$omp parallel & !$omp private ( nm, Qq, I, a, hh_local ) !$omp do - !$acc parallel present( qinfmap, prcp, netprcp, cuminf, cell_area_m2, cell_area, z_flags_iref, z_volume, zs, zb, rain_T1, & + !$acc parallel present( qinfmap, prcp, cuminf, cell_area_m2, cell_area, z_flags_iref, z_volume, zs, zb, rain_T1, & !$acc horton_kd, horton_fc, horton_f0 ) !$acc loop independent gang vector do nm = 1, np @@ -1007,10 +1017,6 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - ! Compute nett precip - ! - netprcp(nm) = netprcp(nm) - qinfmap(nm) - ! if (store_cumulative_precipitation) then ! ! Compute cumulative infiltration @@ -1021,14 +1027,164 @@ subroutine update_infiltration_map(dt, tloop) ! enddo !$omp end do - !$omp end parallel + !$omp end parallel !$acc end parallel ! + elseif (inftype == 'bkt') then + ! + ! Bucket model (linear reservoir) + ! + call compute_bucket_drainage(dt) + ! endif ! call system_clock(count1, count_rate, count_max) tloop = tloop + 1.0 * (count1 - count0) / count_rate ! - end subroutine + end subroutine + + + subroutine initialize_bucket_model() + ! + use sfincs_data + use sfincs_ncinput + ! + implicit none + ! + integer :: nchar + logical :: ok + character*256 :: varname + ! + if (bucketfile /= 'none') then + ! + use_bucket_model = .true. + ! + write(logstr,'(a)')'Info : turning on bucket model (linear reservoir)' + call write_log(logstr, 0) + ! + allocate(bucket_capacity(np)) + allocate(bucket_k(np)) + allocate(bucket_volume(np)) + allocate(bucket_drain_rate(np)) + ! + bucket_capacity = 0.0 + bucket_k = 0.0 + bucket_volume = 0.0 + bucket_drain_rate = 0.0 + ! + nchar = len_trim(bucketfile) + ok = check_file_exists(bucketfile, 'Bucket model file', .true.) + ! + if (bucketfile(nchar - 1 : nchar) == 'nc') then + ! + ! Read bucket capacity (S_max) in mm, convert to m + ! + varname = 'bucket_smax' + call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_capacity) + bucket_capacity = bucket_capacity / 1000.0 ! mm to m + ! + ! Read drainage coefficient (k) in 1/hr, convert to 1/s + ! + varname = 'bucket_k' + call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_k) + bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s + ! + else + ! + ! Read from binary files + ! + open(unit = 500, file = trim(bucketfile), form = 'unformatted', access = 'stream') + read(500)bucket_capacity + close(500) + bucket_capacity = bucket_capacity / 1000.0 ! mm to m + ! + ! For binary input, k needs a separate file - not supported yet + ! Default k = 0.1/hr + ! + bucket_k = 0.1 / 3600.0 + ! + endif + ! + write(logstr,'(a,f10.4,a)')'Info : bucket max capacity = ', maxval(bucket_capacity) * 1000.0, ' mm' + call write_log(logstr, 0) + ! + else + ! + ! Allocate minimal arrays for OpenACC compatibility + ! + allocate(bucket_capacity(1)) + allocate(bucket_k(1)) + allocate(bucket_volume(1)) + allocate(bucket_drain_rate(1)) + bucket_capacity = 0.0 + bucket_k = 0.0 + bucket_volume = 0.0 + bucket_drain_rate = 0.0 + ! + endif + ! + end subroutine + + + subroutine compute_bucket_drainage(dt) + ! + ! Bucket model: finite capacity reservoir with linear drainage (HBV/wflow style) + ! Recovery is inherent - bucket drains during dry periods via Q=k*S, restoring capacity + ! + ! Literature: Linear reservoir (Nash, 1957), HBV soil moisture bucket (Bergstrom, 1995) + ! + use sfincs_data + ! + implicit none + ! + real*4 :: dt + integer :: nm + real*4 :: exp_factor + real*4 :: drain_vol + real*4 :: available_water + real*4 :: available_cap + real*4 :: actual_inflow + ! + !$omp parallel do private(nm, exp_factor, drain_vol, available_water, available_cap, actual_inflow) + do nm = 1, np + ! + if (kcs(nm) == 1 .and. bucket_capacity(nm) > 0.0) then + ! + ! Step 1: Drain current storage (analytical linear reservoir solution) + ! S(t+dt) = S(t) * exp(-k*dt), drainage = S(t) - S(t+dt) + ! + exp_factor = exp(-bucket_k(nm) * dt) + drain_vol = bucket_volume(nm) * (1.0 - exp_factor) + bucket_volume(nm) = bucket_volume(nm) * exp_factor + ! + ! Step 2: Fill bucket from available rainfall + ! + available_water = max(prcp(nm), 0.0) * dt ! m of water available + available_cap = bucket_capacity(nm) - bucket_volume(nm) + actual_inflow = min(available_water, available_cap) + bucket_volume(nm) = bucket_volume(nm) + actual_inflow + ! + ! Step 3: Set qinfmap = what entered the bucket (removed from surface) + ! This is used by continuity as the infiltration loss term + ! + qinfmap(nm) = actual_inflow / dt + bucket_drain_rate(nm) = actual_inflow / dt + ! + if (store_cumulative_precipitation) then + cuminf(nm) = cuminf(nm) + qinfmap(nm) * dt + endif + ! + else + ! + qinfmap(nm) = 0.0 + bucket_drain_rate(nm) = 0.0 + ! + endif + ! + enddo + !$omp end parallel do + ! + end subroutine + end module diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 31b22daa9..34163b0bd 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -209,8 +209,12 @@ subroutine read_sfincs_input() call read_char_input(500,'netampfile',netampfile,'none') call read_char_input(500,'netspwfile',netspwfile,'none') ! - call read_char_input(500,'infiltrationfile',infiltrationfile,'none') + ! Infiltration and losses + call read_char_input(500,'infiltrationfile',infiltrationfile,'none') call read_char_input(500,'infiltrationtype',inftype,'none') + call read_char_input(500,'bucketfile',bucketfile,'none') ! bucket model (infiltration flavor 'bkt') + call read_real_input(500,'qdrain',qdrain_uniform,0.0) ! drainage mimic (mm/hr) + call read_char_input(500,'drainagefile',drainagefile,'none') ! spatially-varying drainage rates ! ! Output call read_char_input(500,'obsfile',obsfile,'none') @@ -313,6 +317,7 @@ subroutine read_sfincs_input() gn2 = 9.81*0.02*0.02 ! Only to be used in subgrid ! qinf = qinf/(3600*1000) + qdrain_uniform = qdrain_uniform/(3600*1000) ! Convert mm/hr to m/s ! rotation = rotation*pi/180 cosrot = cos(rotation) diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 11318103e..f40d12bf6 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -500,26 +500,12 @@ function sfincs_update(dtrange) result(ierr) ! call update_meteo_forcing(t, dt, tloopwnd2) ! - ! Update infiltration - ! - if (infiltration) then - ! - ! Compute infiltration rates - ! - call update_infiltration_map(dt, tloopinf) - ! - endif - ! endif ! ! Update boundary conditions ! call update_boundaries(t, dt, tloopbnd) ! - ! Update discharges - ! - call update_discharges(t, dt, tloopsrc) - ! if (snapwave .and. update_waves) then ! call timer(t3) @@ -570,9 +556,9 @@ function sfincs_update(dtrange) result(ierr) ! endif ! - ! Update water levels + ! Update continuity (discharges, infiltration, drainage, water levels) ! - call compute_water_levels(t, dt, tloopcont) + call update_continuity(t, dt, tloopsrc, tloopinf, tloopcont) ! ! OUTPUT ! diff --git a/source/src/sfincs_meteo.f90 b/source/src/sfincs_meteo.f90 index 733ae8467..62175caa3 100644 --- a/source/src/sfincs_meteo.f90 +++ b/source/src/sfincs_meteo.f90 @@ -1214,7 +1214,7 @@ subroutine update_meteo_forcing(t, dt, tloop) !$acc parallel, present( tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & !$acc patm, patm0, patm1, & - !$acc prcp, prcp0, prcp1, cumprcp, netprcp, & + !$acc prcp, prcp0, prcp1, cumprcp, & !$acc zs, zb, z_volume ) !$acc loop gang vector do nm = 1, np @@ -1262,7 +1262,6 @@ subroutine update_meteo_forcing(t, dt, tloop) endif endif ! - netprcp(nm) = prcp(nm) cumprcp(nm) = cumprcp(nm) + prcp(nm) * dt ! endif @@ -1282,40 +1281,38 @@ subroutine update_meteo_forcing(t, dt, tloop) !$omp parallel & !$omp private ( nm ) !$omp do - !$acc parallel, present( tauwu, tauwv, patm, prcp, netprcp, zs, zb, z_volume ) + !$acc parallel, present( tauwu, tauwv, patm, prcp, zs, zb, z_volume ) !$acc loop gang vector do nm = 1, np ! if (wind) then tauwu(nm) = tauwu(nm) * smfac tauwv(nm) = tauwv(nm) * smfac - endif + endif ! if (patmos) then patm(nm) =patm(nm) * smfac + gapres * oneminsmfac - endif + endif ! if (precip) then - ! - netprcp(nm) = netprcp(nm) * smfac - ! - ! Don't allow negative netprcp during spinup (e.g. hardfixing infiltration/evaporation on model when forcing effective rainfall) when there's no water in the cell (same as check for constant infiltration) - ! - if (netprcp(nm) < 0.0) then - ! - ! No effective infiltration if there is no water - ! + ! + prcp(nm) = prcp(nm) * smfac + ! + ! Don't allow negative precip during spinup when there's no water in the cell + ! + if (prcp(nm) < 0.0) then + ! if (subgrid) then if (z_volume(nm) <= 0.0) then - netprcp(nm) = 0.0 + prcp(nm) = 0.0 endif else if (zs(nm) <= zb(nm)) then - netprcp(nm) = 0.0 + prcp(nm) = 0.0 endif - endif - ! - endif + endif + ! + endif endif ! enddo @@ -1465,12 +1462,11 @@ subroutine update_precipitation_from_timeseries(t, dt) !$omp parallel & !$omp private ( nm ) !$omp do - !$acc parallel present( prcp, cumprcp, netprcp ) + !$acc parallel present( prcp, cumprcp ) !$acc loop gang vector do nm = 1, np ! prcp(nm) = ptmp - netprcp(nm) = ptmp ! if (store_cumulative_precipitation) then cumprcp(nm) = cumprcp(nm) + ptmp * dt diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index d751d9d04..3d2a9cdcc 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -28,14 +28,15 @@ subroutine initialize_openacc() !$acc tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & !$acc patm, patm0, patm1, patmb, nmindbnd, & - !$acc prcp, prcp0, prcp1, cumprcp, netprcp, prcp, qext, & + !$acc prcp, prcp0, prcp1, cumprcp, qext, & !$acc dxminv, dxrinv, dyrinv, dxm2inv, dxr2inv, dyr2inv, dxrinvc, dyrinvc, dxm, dxrm, dyrm, cell_area_m2, cell_area, & !$acc gn2uv, fcorio2d, storage_volume, nuvisc, & !$acc cuv_index_uv, cuv_index_uv1, cuv_index_uv2, & !$acc x73, & !$acc gnapp2, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & - !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0 ) + !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & + !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate ) ! end subroutine ! @@ -57,14 +58,15 @@ subroutine finalize_openacc() !$acc tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & !$acc patm, patm0, patm1, patmb, nmindbnd, & - !$acc prcp, prcp0, prcp1, cumprcp, netprcp, prcp, qext, & + !$acc prcp, prcp0, prcp1, cumprcp, qext, & !$acc dxminv, dxrinv, dyrinv, dxm2inv, dxr2inv, dyr2inv, dxrinvc, dxm, dxrm, dyrm, cell_area_m2, cell_area, & !$acc gn2uv, fcorio2d, storage_volume, nuvisc, & !$acc cuv_index_uv, cuv_index_uv1, cuv_index_uv2, & !$acc x73, & !$acc gnapp2, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & - !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0 ) + !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & + !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate ) ! end ! From cf6a78d124d3ffae94ef9b8576c6950189e7c7c5 Mon Sep 17 00:00:00 2001 From: Kees Nederhoff Date: Thu, 19 Mar 2026 18:07:13 -0700 Subject: [PATCH 15/65] Included more output options --- source/sfincs/sfincs.log | 40 +++++ source/sfincs/sfincs.vfproj.keesn.user | 8 + .../sfincs_lib/sfincs_lib.vfproj.keesn.user | 8 + source/src/sfincs_continuity.f90 | 4 +- source/src/sfincs_data.f90 | 4 +- source/src/sfincs_domain.f90 | 4 +- source/src/sfincs_infiltration.f90 | 22 ++- source/src/sfincs_lib.f90 | 9 +- source/src/sfincs_ncoutput.F90 | 151 ++++++++++++++---- 9 files changed, 199 insertions(+), 51 deletions(-) create mode 100644 source/sfincs/sfincs.log create mode 100644 source/sfincs/sfincs.vfproj.keesn.user create mode 100644 source/sfincs_lib/sfincs_lib.vfproj.keesn.user diff --git a/source/sfincs/sfincs.log b/source/sfincs/sfincs.log new file mode 100644 index 000000000..2b94f1aae --- /dev/null +++ b/source/sfincs/sfincs.log @@ -0,0 +1,40 @@ + +------------ Welcome to SFINCS ------------ + + @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ + @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@ + @@@ @@ @@ @@@ @@ @@ @@ @@@ + @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ + @@@ @@ @@ @@ @@@ @@ @@ @@@ + @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@ + @@@@@ @@ @@ @@ @ @@@@ @@@@@ + + .............. + ......:@@@@@@@@:...... + ..::::..@@........@@.:::::.. + ..:::::..@@..::..::..@@.::::::.. + .::::::..@@............@@.:::::::. + .::::::..@@..............@@.:::::::. + .::::::::..@@............@@..::::::::. + .:::::::::...@@.@..@@..@.@@..::::::::::. + .:::::::::...:@@@..@@..@@@:..:::::::::.. + ............@@.@@..@@..@@.@@............ + ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ + .::::::::::@@..............@@.:::::::::. + .......:.@@.....@.....@....@@.:....... + .::....@@......@.@@@.@....@@.....::. + .:::~@@.:...:.@@...@@.:.:.@@~::::. + .::~@@@@@@@@@@.....@@@@@@@@@~::. + ..:~~~~~~~:.......:~~~~~~~:.. + ...................... + .............. + +------------------------------------------ + +Build-Revision: $Rev: v2.3.1 mt. Faber+branch-redo-infiltration +Build-Date: $Date: 2026-03-19 + +------ Preparing model simulation -------- + +Reading input file ... +Error : SFINCS input file "sfincs.inp" not found! SFINCS has stopped! diff --git a/source/sfincs/sfincs.vfproj.keesn.user b/source/sfincs/sfincs.vfproj.keesn.user new file mode 100644 index 000000000..6ae2aa06f --- /dev/null +++ b/source/sfincs/sfincs.vfproj.keesn.user @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/source/sfincs_lib/sfincs_lib.vfproj.keesn.user b/source/sfincs_lib/sfincs_lib.vfproj.keesn.user new file mode 100644 index 000000000..818b85e15 --- /dev/null +++ b/source/sfincs_lib/sfincs_lib.vfproj.keesn.user @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index bcfc9699a..d50437556 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -182,7 +182,7 @@ subroutine compute_water_levels_regular(dt,t) ! ! C3. Drainage mimic (-) ! - if (use_drainage_mimic) then + if (drainage) then zs(nm) = zs(nm) - qdrain_rate(nm) * dt endif ! @@ -551,7 +551,7 @@ subroutine compute_water_levels_subgrid(dt,t) ! ! C3. Drainage mimic (-) ! - if (use_drainage_mimic) then + if (drainage) then dzsdt = dzsdt - qdrain_rate(nm) endif ! diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 111c4cc5c..2eb81c5a0 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -410,9 +410,9 @@ module sfincs_data ! real*4, dimension(:), allocatable :: storage_volume ! Storage volume green infra ! - ! Drainage mimic - constant removal rate representing subsurface drainage + ! Drainage - constant removal rate representing subsurface drainage ! - logical :: use_drainage_mimic = .false. + logical :: drainage = .false. real*4 :: qdrain_uniform = 0.0 ! uniform drainage rate (mm/hr input, stored as m/s) real*4, dimension(:), allocatable :: qdrain_rate ! drainage rate per cell (m/s) ! diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 7cfce450b..9b0383092 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2061,11 +2061,11 @@ subroutine initialize_drainage_mimic() logical :: ok character*256 :: varname ! - ! Check if drainage mimic is enabled + ! Check if drainage is enabled ! if (qdrain_uniform > 0.0 .or. drainagefile /= 'none') then ! - use_drainage_mimic = .true. + drainage = .true. ! allocate(qdrain_rate(np)) ! diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index 7c6496155..8da1855d4 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -177,22 +177,18 @@ subroutine initialize_infiltration() ! 5) Check whether infiltration input type (orignal vs netcdf) are correctly matched to grid type (regular vs quadtree) ! if (infiltration .and. inftype /= 'con') then !constant uniform works for both options - ! - if (netcdf_infiltration) then - ! - if (use_quadtree .eqv. .false.) then - ! - call stop_sfincs('Error ! Netcdf infiltration input format can only be specified for quadtree mesh model !', 1) + ! + ! Netcdf infiltration works for both regular and quadtree grids + ! (regular grids populate quadtree_nr_points and index_sfincs_in_quadtree + ! via make_quadtree_from_indices) + ! + if (.not. netcdf_infiltration) then + ! + if (use_quadtree .eqv. .true.) then ! + call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) endif ! - else ! Original - ! - if (use_quadtree .eqv. .true.) then - ! - call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) - endif - ! endif ! endif diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index f40d12bf6..39e193ec2 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -92,8 +92,8 @@ function sfincs_initialize() result(ierr) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - build_revision = "$Rev: v2.3.1 mt. Faber+branch-272" - build_date = "$Date: 2026-03-06" + build_revision = "$Rev: v2.3.1 mt. Faber+branch-redo-infiltration" + build_date = "$Date: 2026-03-19" ! call write_log('', 1) call write_log('------------ Welcome to SFINCS ------------', 1) @@ -225,6 +225,11 @@ function sfincs_initialize() result(ierr) else call write_log('Infiltration : no', 1) endif + if (drainage) then + call write_log('Drainage : yes', 1) + else + call write_log('Drainage : no', 1) + endif if (snapwave) then call write_log('SnapWave : yes', 1) else diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 3fcfbe9d6..6a9ecdf3d 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -214,12 +214,16 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'suction head at the wetting front - Green and Ampt')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'm')) elseif (inftype == 'hor') then - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'f0')) - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'initial infiltration rate - Horton')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'f0')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'initial infiltration rate - Horton')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'm')) + elseif (inftype == 'bkt') then + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'bucket_capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'maximum bucket storage capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm')) else - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'qinf')) - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'infiltration rate - constant in time')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'qinf')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'infiltration rate - constant in time')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm h-1')) endif endif @@ -370,14 +374,25 @@ subroutine ncoutput_regular_map_init() NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'coordinates', 'corner_x corner_y')) endif ! - ! Store current infiltration (only for Horton) + ! Store current infiltration capacity (only for Horton) ! if (inftype == 'hor') then - NF90(nf90_def_var(map_file%ncid, 'f', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%Seff_varid)) ! time-varying sigma - NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_def_var(map_file%ncid, 'f', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%Seff_varid)) ! time-varying f + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'units', 'mm h-1')) - NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'standard_name', 'sigma')) - NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'long_name', 'current infiltration capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'standard_name', 'f')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'long_name', 'current infiltration capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'coordinates', 'corner_x corner_y')) + endif + ! + ! Store current bucket storage (only for Bucket model) + ! + if (inftype == 'bkt') then + NF90(nf90_def_var(map_file%ncid, 'bucket_volume', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%time_dimid/), map_file%Seff_varid)) ! time-varying bucket volume + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'standard_name', 'bucket_volume')) + NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'long_name', 'current bucket storage')) NF90(nf90_put_att(map_file%ncid, map_file%Seff_varid, 'coordinates', 'corner_x corner_y')) endif ! @@ -801,9 +816,9 @@ subroutine ncoutput_regular_map_init() ! ! Write infiltration map ! - if (infiltration) then + if (infiltration .and. allocated(qinffield)) then ! - zsg = FILL_VALUE + zsg = FILL_VALUE ! do nm = 1, np ! @@ -819,13 +834,29 @@ subroutine ncoutput_regular_map_init() zsg(m, n) = qinffield(nm) ! endif - ! + ! enddo ! NF90(nf90_put_var(map_file%ncid, map_file%qinf_varid, zsg, (/1, 1/))) ! write infiltration map ! endif ! + ! Write bucket capacity map (static) + ! + if (inftype == 'bkt' .and. allocated(bucket_capacity)) then + ! + zsg = FILL_VALUE + ! + do nm = 1, np + n = z_index_z_n(nm) + m = z_index_z_m(nm) + zsg(m, n) = bucket_capacity(nm) * 1000.0 ! m to mm + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%qinf_varid, zsg, (/1, 1/))) ! write bucket capacity map + ! + endif + ! ! write away intermediate data ! NF90(nf90_sync(map_file%ncid)) !write away intermediate data @@ -1383,12 +1414,16 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'suction head at the wetting front - Green and Ampt')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'm')) elseif (inftype == 'hor') then - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'f0')) - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'initial infiltration rate - Horton')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'f0')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'initial infiltration rate - Horton')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm h-1')) + elseif (inftype == 'bkt') then + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'bucket_capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'maximum bucket storage capacity')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm')) else - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'qinf')) - NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'infiltration rate - constant in time')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'standard_name', 'qinf')) + NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'long_name', 'infiltration rate - constant in time')) NF90(nf90_put_att(map_file%ncid, map_file%qinf_varid, 'units', 'mm h-1')) endif endif @@ -1530,7 +1565,7 @@ subroutine ncoutput_quadtree_map_init() ! vtmp = FILL_VALUE ! - if (infiltration) then + if (infiltration .and. allocated(qinffield)) then ! if (inftype == 'con' .or. inftype == 'c2d') then do nmq = 1, quadtree_nr_points @@ -1538,20 +1573,37 @@ subroutine ncoutput_quadtree_map_init() if (nm>0) then vtmp(nmq) = qinffield(nm) * 3600 * 1000 endif - enddo + enddo else do nmq = 1, quadtree_nr_points nm = index_sfincs_in_quadtree(nmq) if (nm>0) then vtmp(nmq) = qinffield(nm) endif - enddo + enddo endif ! NF90(nf90_put_var(map_file%ncid, map_file%qinf_varid, vtmp)) ! write infiltration map ! endif ! + ! Write bucket capacity map (static) + ! + if (inftype == 'bkt' .and. allocated(bucket_capacity)) then + ! + vtmp = FILL_VALUE + ! + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm>0) then + vtmp(nmq) = bucket_capacity(nm) * 1000.0 ! m to mm + endif + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%qinf_varid, vtmp)) ! write bucket capacity map + ! + endif + ! ! write away intermediate data ! NF90(nf90_sync(map_file%ncid)) !write away intermediate data @@ -1810,9 +1862,29 @@ subroutine ncoutput_his_init() ! if (inftype == 'gai') then NF90(nf90_def_var(his_file%ncid, 'point_S', NF90_FLOAT, (/his_file%points_dimid, his_file%time_dimid/), his_file%S_varid)) ! time-varying S - NF90(nf90_put_att(his_file%ncid, his_file%S_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'units', 'm')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'long_name', 'maximum soil moisture deficit')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'coordinates', 'station_id station_name point_x point_y')) + endif + ! + ! More output for Horton method + ! + if (inftype == 'hor') then + NF90(nf90_def_var(his_file%ncid, 'point_S', NF90_FLOAT, (/his_file%points_dimid, his_file%time_dimid/), his_file%S_varid)) ! time-varying f + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'units', 'mm hr-1')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'long_name', 'current infiltration capacity')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'coordinates', 'station_id station_name point_x point_y')) + endif + ! + ! More output for Bucket model + ! + if (inftype == 'bkt') then + NF90(nf90_def_var(his_file%ncid, 'point_S', NF90_FLOAT, (/his_file%points_dimid, his_file%time_dimid/), his_file%S_varid)) ! time-varying bucket volume + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'units', 'm')) - NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'long_name', 'maximum soil moisture deficit')) + NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'long_name', 'current bucket storage')) NF90(nf90_put_att(his_file%ncid, his_file%S_varid, 'coordinates', 'station_id station_name point_x point_y')) endif ! @@ -1987,10 +2059,10 @@ subroutine ncoutput_his_init() if (ndrn>0) then ! NF90(nf90_def_var(his_file%ncid, 'drainage_discharge', NF90_FLOAT, (/his_file%drain_dimid, his_file%time_dimid/), his_file%drain_varid)) ! time-varying discharge through drainage structure - NF90(nf90_put_att(his_file%ncid, his_file%discharge_varid, '_FillValue', FILL_VALUE)) - NF90(nf90_put_att(his_file%ncid, his_file%discharge_varid, 'units', 'm3 s-1')) - NF90(nf90_put_att(his_file%ncid, his_file%discharge_varid, 'long_name', 'discharge through drainage structure')) - NF90(nf90_put_att(his_file%ncid, his_file%discharge_varid, 'coordinates', 'drainage_name')) + NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'units', 'm3 s-1')) + NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'long_name', 'discharge through drainage structure')) + NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'coordinates', 'drainage_name')) ! endif ! @@ -2302,13 +2374,30 @@ subroutine ncoutput_update_regular_map(t,ntmapout) ! n = z_index_z_n(nm) m = z_index_z_m(nm) - ! + ! zsg(m, n) = qinfmap(nm) ! enddo ! NF90(nf90_put_var(map_file%ncid, map_file%Seff_varid, zsg, (/1, 1, ntmapout/))) ! + elseif (inftype == 'bkt') then + ! + ! Store current bucket volume + ! + zsg = FILL_VALUE + ! + do nm = 1, np + ! + n = z_index_z_n(nm) + m = z_index_z_m(nm) + ! + zsg(m, n) = bucket_volume(nm) + ! + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%Seff_varid, zsg, (/1, 1, ntmapout/))) + ! endif ! if (store_meteo) then @@ -3047,8 +3136,12 @@ subroutine ncoutput_update_his(t,nthisout) tS_effective(iobs) = scs_Se(nm) elseif (inftype == 'gai') then tS_effective(iobs) = GA_sigma(nm) + elseif (inftype == 'hor') then + tS_effective(iobs) = qinfmap(nm)*3.6e3*1.0e3 ! current f in mm/hr + elseif (inftype == 'bkt') then + tS_effective(iobs) = bucket_volume(nm) ! current bucket storage in m endif - endif + endif ! if (store_meteo) then ! @@ -3127,9 +3220,7 @@ subroutine ncoutput_update_his(t,nthisout) ! NF90(nf90_put_var(his_file%ncid, his_file%qinf_varid, tqinf, (/1, nthisout/))) ! write qinf ! - if (inftype == 'cnb') then - NF90(nf90_put_var(his_file%ncid, his_file%S_varid, tS_effective, (/1, nthisout/))) ! write S - elseif (inftype == 'gai') then + if (inftype == 'cnb' .or. inftype == 'gai' .or. inftype == 'hor' .or. inftype == 'bkt') then NF90(nf90_put_var(his_file%ncid, his_file%S_varid, tS_effective, (/1, nthisout/))) ! write S endif ! From 3300914c1b82cb6c997132a916f707bfe890deb7 Mon Sep 17 00:00:00 2001 From: Leynse Date: Tue, 24 Mar 2026 15:18:36 +0100 Subject: [PATCH 16/65] - clean repo --- .gitignore | 8 +++++ source/Dockerfile.gpu | 31 ----------------- source/Dockerfile.gpu.25.5.ccall | 32 ------------------ source/Dockerfile.gpu.test | 15 --------- source/Dockerfile.gpu.update01 | 32 ------------------ source/Dockerfile.xpu | 21 ------------ source/Singularityfile-gpu.def | 58 -------------------------------- source/build_nvfortran_gpu.sh | 35 ------------------- source/build_nvfortran_gpu_h7.sh | 21 ------------ 9 files changed, 8 insertions(+), 245 deletions(-) delete mode 100644 source/Dockerfile.gpu delete mode 100644 source/Dockerfile.gpu.25.5.ccall delete mode 100644 source/Dockerfile.gpu.test delete mode 100644 source/Dockerfile.gpu.update01 delete mode 100644 source/Dockerfile.xpu delete mode 100644 source/Singularityfile-gpu.def delete mode 100644 source/build_nvfortran_gpu.sh delete mode 100644 source/build_nvfortran_gpu_h7.sh diff --git a/.gitignore b/.gitignore index 22752d026..6156e1289 100644 --- a/.gitignore +++ b/.gitignore @@ -65,3 +65,11 @@ 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.update01 +/source/Dockerfile.gpu.test +/source/Dockerfile.gpu.25.5.ccall +/source/Dockerfile.gpu diff --git a/source/Dockerfile.gpu b/source/Dockerfile.gpu deleted file mode 100644 index 24da778bc..000000000 --- a/source/Dockerfile.gpu +++ /dev/null @@ -1,31 +0,0 @@ -FROM nvcr.io/nvidia/nvhpc:20.11-devel-cuda_multi-ubuntu20.04 -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y dos2unix -RUN apt update && apt install -y libnetcdf-dev build-essential autoconf automake libtool pkg-config tzdata -# copy the compilers -RUN cd /opt/nvidia/hpc_sdk/Linux_x86_64/20.11/REDIST/compilers && tar -czvhf /root/nvidia-20.11.tar.gz * && cd - -COPY . /usr/src/sfincs -WORKDIR /usr/src/sfincs - -RUN find . -name \*.m4|xargs dos2unix && find . -name \*.ac|xargs dos2unix && find . -name \*.am|xargs dos2unix -RUN find . -name \*.f90|xargs dos2unix -RUN find . -name \*.F90|xargs dos2unix -RUN find . -name \*.am|xargs dos2unix -# ccall -> Generate code for all compute capabilities supported by this platform and by the selected or default CUDA Toolkit. -RUN autoreconf -vif && FCFLAGS="-acc -Minfo=accel -fast -O3 -gpu=ccall -DSIZEOF_PTRDIFF_T=8" FC=nvfortran ./configure --disable-shared --disable-openmp && make && make install - -FROM nvidia/cuda:11.2.2-runtime-ubuntu20.04 -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y libnetcdf-dev tzdata -# copy nvidia SDK (REDIST folder contains symlinks) -COPY --from=0 /root/nvidia-20.11.tar.gz . -# copy software -COPY --from=0 /usr/local /usr/local -RUN mkdir -p /opt/nvidia/compilers -RUN tar -xzf nvidia-20.11.tar.gz -C /opt/nvidia/compilers -# add the REDIST libs to the environment -ENV LD_LIBRARY_PATH=/usr/local/nvidia/lib:/usr/local/nvidia/lib64:/opt/nvidia/compilers/lib -VOLUME /data -WORKDIR /data -CMD ["sfincs"] - diff --git a/source/Dockerfile.gpu.25.5.ccall b/source/Dockerfile.gpu.25.5.ccall deleted file mode 100644 index fb8e25234..000000000 --- a/source/Dockerfile.gpu.25.5.ccall +++ /dev/null @@ -1,32 +0,0 @@ -FROM nvcr.io/nvidia/nvhpc:25.5-devel-cuda_multi-ubuntu22.04 -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y dos2unix -RUN apt update && apt install -y libnetcdf-dev build-essential autoconf automake libtool pkg-config tzdata -# copy the compilers -RUN cd /opt/nvidia/hpc_sdk/Linux_x86_64/2025/REDIST/compilers && tar -czvhf /root/nvidia-25.5.tar.gz * && cd - -COPY . /usr/src/sfincs -WORKDIR /usr/src/sfincs - -RUN find . -name \*.m4|xargs dos2unix && find . -name \*.ac|xargs dos2unix && find . -name \*.am|xargs dos2unix -RUN find . -name \*.f90|xargs dos2unix -RUN find . -name \*.F90|xargs dos2unix -RUN find . -name \*.am|xargs dos2unix -# ccall -> Generate code for all compute capabilities supported by this platform and by the selected or default CUDA Toolkit. -RUN autoreconf -vif && FCFLAGS="-acc -Minfo=accel -fast -O3 -gpu=ccall -DSIZEOF_PTRDIFF_T=8" FC=nvfortran ./configure --disable-shared --disable-openmp && make && make install -#RUN autoreconf -vif && FCFLAGS="-acc -Minfo=accel -fast -O3 -gpu=ccall" FC=nvfortran ./configure --disable-shared --disable-openmp && make && make install - -FROM nvidia/cuda:12.5.0-runtime-ubuntu22.04 -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y libnetcdf-dev tzdata -# copy nvidia SDK (REDIST folder contains symlinks) -COPY --from=0 /root/nvidia-25.5.tar.gz . -# copy software -COPY --from=0 /usr/local /usr/local -RUN mkdir -p /opt/nvidia/compilers -RUN tar -xzf nvidia-25.5.tar.gz -C /opt/nvidia/compilers -# add the REDIST libs to the environment -ENV LD_LIBRARY_PATH=/usr/local/nvidia/lib:/usr/local/nvidia/lib64:/opt/nvidia/compilers/lib -VOLUME /data -WORKDIR /data -CMD ["sfincs"] - diff --git a/source/Dockerfile.gpu.test b/source/Dockerfile.gpu.test deleted file mode 100644 index 87870c2ac..000000000 --- a/source/Dockerfile.gpu.test +++ /dev/null @@ -1,15 +0,0 @@ -FROM nvcr.io/nvidia/nvhpc:20.11-devel-cuda_multi-ubuntu20.04 -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y libnetcdf-dev build-essential autoconf automake libtool pkg-config tzdata -# copy the compilers -RUN cd /opt/nvidia/hpc_sdk/Linux_x86_64/20.11/REDIST/compilers && tar -czvhf /root/nvidia-20.11.tar.gz * && cd - -WORKDIR /usr/src/sfincs -COPY . /usr/src/sfincs -# ccall -> Generate code for all compute capabilities supported by this platform and by the selected or default CUDA Toolkit. -# create a debug version -RUN autoreconf -vif && FCFLAGS="-acc -Minfo=accel -fast -g -O0 -gpu=ccall" FC=nvfortran ./configure --disable-shared --disable-openmp && make && make install - -ENV LD_LIBRARY_PATH=/usr/local/nvidia/lib:/usr/local/nvidia/lib64:/opt/nvidia/compilers/lib -VOLUME /data -WORKDIR /data -CMD ["sfincs"] diff --git a/source/Dockerfile.gpu.update01 b/source/Dockerfile.gpu.update01 deleted file mode 100644 index bd54b6412..000000000 --- a/source/Dockerfile.gpu.update01 +++ /dev/null @@ -1,32 +0,0 @@ -FROM nvcr.io/nvidia/nvhpc:24.3-devel-cuda_multi-ubuntu22.04 -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y dos2unix -RUN apt update && apt install -y libnetcdf-dev build-essential autoconf automake libtool pkg-config tzdata -# copy the compilers -RUN cd /opt/nvidia/hpc_sdk/Linux_x86_64/2024/REDIST/compilers && tar -czvhf /root/nvidia-24.5.tar.gz * && cd - -COPY . /usr/src/sfincs -WORKDIR /usr/src/sfincs - -RUN find . -name \*.m4|xargs dos2unix && find . -name \*.ac|xargs dos2unix && find . -name \*.am|xargs dos2unix -RUN find . -name \*.f90|xargs dos2unix -RUN find . -name \*.F90|xargs dos2unix -RUN find . -name \*.am|xargs dos2unix -# ccall -> Generate code for all compute capabilities supported by this platform and by the selected or default CUDA Toolkit. -RUN autoreconf -vif && FCFLAGS="-acc -Minfo=accel -fast -O3 -gpu=ccall -DSIZEOF_PTRDIFF_T=8" FC=nvfortran ./configure --disable-shared --disable-openmp && make && make install -#RUN autoreconf -vif && FCFLAGS="-acc -Minfo=accel -fast -O3 -gpu=ccall" FC=nvfortran ./configure --disable-shared --disable-openmp && make && make install - -FROM nvidia/cuda:12.5.0-runtime-ubuntu22.04 -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y libnetcdf-dev tzdata -# copy nvidia SDK (REDIST folder contains symlinks) -COPY --from=0 /root/nvidia-24.5.tar.gz . -# copy software -COPY --from=0 /usr/local /usr/local -RUN mkdir -p /opt/nvidia/compilers -RUN tar -xzf nvidia-24.5.tar.gz -C /opt/nvidia/compilers -# add the REDIST libs to the environment -ENV LD_LIBRARY_PATH=/usr/local/nvidia/lib:/usr/local/nvidia/lib64:/opt/nvidia/compilers/lib -VOLUME /data -WORKDIR /data -CMD ["sfincs"] - diff --git a/source/Dockerfile.xpu b/source/Dockerfile.xpu deleted file mode 100644 index c311d2e67..000000000 --- a/source/Dockerfile.xpu +++ /dev/null @@ -1,21 +0,0 @@ -FROM ubuntu:latest -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y libnetcdf-dev build-essential autoconf automake libtool pkg-config tzdata -# copy the compilers -COPY aocc-compiler-4.0.0_1_amd64.deb . -RUN apt install -y ./aocc-compiler-4.0.0_1_amd64.deb -WORKDIR /usr/src/sfincs -COPY . /usr/src/sfincs -# Compile with the AMD fortran compiler -ENV PATH="/opt/AMD/aocc-compiler-4.0.0/bin:${PATH}" -RUN autoreconf -vif && FCFLAGS="-O3" FC=flang ./configure --disable-shared --disable-openmp && make && make install - -# Copy the files to empty docker container -FROM ubuntu:latest -ENV DEBIAN_FRONTEND=noninteractive -RUN apt update && apt install -y libnetcdf-dev tzdata -# copy nvidia SDK (REDIST folder contains symlinks) -COPY --from=0 /usr/local /usr/local -VOLUME /data -WORKDIR /data -CMD ["sfincs"] diff --git a/source/Singularityfile-gpu.def b/source/Singularityfile-gpu.def deleted file mode 100644 index 69ab0a258..000000000 --- a/source/Singularityfile-gpu.def +++ /dev/null @@ -1,58 +0,0 @@ -BootStrap: library -From: library://library/default/ubuntu:jammy -Stage: build - -# -# The source files of sfincs -# - -%files - . /usr/src/sfincs - -# -# Compiler flags -# -fallow-argument-mismatch needed for https://github.com/Unidata/netcdf-fortran/issues/212 -# - -%environment - FCFLAGS="-fopenmp -O3 -fallow-argument-mismatch -w" - FFLAGS="-fopenmp -O3 -fallow-argument-mismatch -w" - -# -# Installing compilers -# Compiling sfincs -# - -%post - apt clean && apt autoclean && apt -y update --fix-missing && apt -y upgrade -y && apt install -y libnetcdf-dev build-essential autoconf automake libtool pkg-config gfortran gdb m4 - -# Install software into /usr/local by default - - cd /usr/src/sfincs - export CONFIG_SHELL=/bin/bash - autoreconf -vif - ./autogen.sh - ./configure FCFLAGS="-acc -Minfo=accel -fast -O3 -gpu=ccall -DSIZEOF_PTRDIFF_T=999" FC=nvfortran --disable-shared --disable-openmp --program-suffix="_async" - - make clean - make - make install - -# Install binary in a much smaller image - -BootStrap: library -From: library://library/default/ubuntu:jammy -Stage: final - -# install binary from stage one -%files from build - /usr/local/bin/sfincs /usr/local/bin/sfincs - -%files - run-sfincs.sh /usr/local/bin/run-sfincs.sh - -%post - apt clean && apt autoclean && apt update --fix-missing && apt upgrade -y - apt install -y libnetcdf19 libgfortran5 libgomp1 - apt clean && apt autoclean - chmod +x /usr/local/bin/run-sfincs.sh diff --git a/source/build_nvfortran_gpu.sh b/source/build_nvfortran_gpu.sh deleted file mode 100644 index a38ae8a7e..000000000 --- a/source/build_nvfortran_gpu.sh +++ /dev/null @@ -1,35 +0,0 @@ -#!/bin/bash - -LOGFILE=build_$(date +%Y%m%d_%H%M%S).log -exec > >(tee "$LOGFILE") 2>&1 - -echo "Starting build at $(date)" -echo "Saving log to $LOGFILE" - -find . -name \*.m4|xargs dos2unix && find . -name \*.ac|xargs dos2unix && find . -name \*.am|xargs dos2unix -find . -name \*.f90|xargs dos2unix -find . -name \*.F90|xargs dos2unix -find . -name \*.am|xargs dos2unix -find . -name \*.sh|xargs dos2unix - -MANPATH=$MANPATH:/opt/nvidia/hpc_sdk/Linux_x86_64/24.5/compilers/man; export MANPATH -PATH=/opt/nvidia/hpc_sdk/Linux_x86_64/24.5/compilers/bin:$PATH; export PATH - -LD_LIBRARY_PATH=/usr/lib/wsl/lib:$LD_LIBRARY_PATH; export LD_LIBRARY_PATH - -apt install -y libnetcdf-dev build-essential autoconf automake libtool pkg-config tzdata -export CONFIG_SHELL=/bin/bash - -autoreconf -vif - -./autogen.sh - -./configure FCFLAGS="-acc=gpu -Minfo=accel -fast -O3 -gpu=ccall -DSIZEOF_PTRDIFF_T=999" FC=nvfortran --disable-shared --disable-openmp --prefix=/usr/local/bin/sfincs/nvfortran_gpu_ccall - -make clean - -make - -make install - -echo "Build finished at $(date)" diff --git a/source/build_nvfortran_gpu_h7.sh b/source/build_nvfortran_gpu_h7.sh deleted file mode 100644 index c50fb36a6..000000000 --- a/source/build_nvfortran_gpu_h7.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh - -module load nvidia/nvhpc/24.1 -module load netcdf - -export LDFLAGS="-L${NETCDF_C_LIBRARY}" - -find . -name \*.m4|xargs dos2unix && find . -name \*.ac|xargs dos2unix && find . -name \*.am|xargs dos2unix -find . -name \*.f90|xargs dos2unix -find . -name \*.F90|xargs dos2unix -find . -name \*.am|xargs dos2unix - -./autogen.sh - -./configure FCFLAGS="-acc -Minfo=accel -fast -O3 -gpu=ccall -DSIZEOF_PTRDIFF_T=999" FC=nvfortran --disable-shared --disable-openmp --prefix /u/${USER}/bin/sfincs_nvfortran_gpu - -make clean - -make - -make install From bb6166122ac78ca241b4cfda75eade374b7463ec Mon Sep 17 00:00:00 2001 From: Kees Nederhoff Date: Thu, 26 Mar 2026 11:18:37 -0700 Subject: [PATCH 17/65] submit progress --- source/src/sfincs_infiltration.f90 | 77 +++++++++++++++++++++--------- 1 file changed, 55 insertions(+), 22 deletions(-) diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index 8da1855d4..d6784f47e 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -182,11 +182,28 @@ subroutine initialize_infiltration() ! (regular grids populate quadtree_nr_points and index_sfincs_in_quadtree ! via make_quadtree_from_indices) ! + ! Bucket model uses bucketfile (not infiltrationfile), but supports netcdf natively + ! if (.not. netcdf_infiltration) then ! if (use_quadtree .eqv. .true.) then ! - call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) + ! Allow bucket model with netcdf bucketfile on quadtree grids + ! + if (inftype == 'bkt' .and. bucketfile /= 'none') then + ! + if (bucketfile(len_trim(bucketfile) - 1 : len_trim(bucketfile)) /= 'nc') then + ! + call stop_sfincs('Error ! Bucket model on quadtree mesh requires a netcdf bucketfile (.nc) !', 1) + ! + endif + ! + else + ! + call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) + ! + endif + ! endif ! endif @@ -1051,7 +1068,7 @@ subroutine initialize_bucket_model() logical :: ok character*256 :: varname ! - if (bucketfile /= 'none') then + if (bucketfile /= 'none' .or. netcdf_infiltration) then ! use_bucket_model = .true. ! @@ -1068,36 +1085,52 @@ subroutine initialize_bucket_model() bucket_volume = 0.0 bucket_drain_rate = 0.0 ! - nchar = len_trim(bucketfile) - ok = check_file_exists(bucketfile, 'Bucket model file', .true.) - ! - if (bucketfile(nchar - 1 : nchar) == 'nc') then + if (netcdf_infiltration) then ! - ! Read bucket capacity (S_max) in mm, convert to m + ! Read from infiltrationfile (netcdf) - works for both regular and quadtree grids ! varname = 'bucket_smax' - call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_capacity) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_capacity) bucket_capacity = bucket_capacity / 1000.0 ! mm to m ! - ! Read drainage coefficient (k) in 1/hr, convert to 1/s - ! varname = 'bucket_k' - call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_k) + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_k) bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s ! - else - ! - ! Read from binary files - ! - open(unit = 500, file = trim(bucketfile), form = 'unformatted', access = 'stream') - read(500)bucket_capacity - close(500) - bucket_capacity = bucket_capacity / 1000.0 ! mm to m + elseif (bucketfile /= 'none') then ! - ! For binary input, k needs a separate file - not supported yet - ! Default k = 0.1/hr + nchar = len_trim(bucketfile) + ok = check_file_exists(bucketfile, 'Bucket model file', .true.) ! - bucket_k = 0.1 / 3600.0 + if (bucketfile(nchar - 1 : nchar) == 'nc') then + ! + ! Read bucket capacity (S_max) in mm, convert to m + ! + varname = 'bucket_smax' + call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_capacity) + bucket_capacity = bucket_capacity / 1000.0 ! mm to m + ! + ! Read drainage coefficient (k) in 1/hr, convert to 1/s + ! + varname = 'bucket_k' + call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_k) + bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s + ! + else + ! + ! Read from binary files + ! + open(unit = 500, file = trim(bucketfile), form = 'unformatted', access = 'stream') + read(500)bucket_capacity + close(500) + bucket_capacity = bucket_capacity / 1000.0 ! mm to m + ! + ! For binary input, k needs a separate file - not supported yet + ! Default k = 0.1/hr + ! + bucket_k = 0.1 / 3600.0 + ! + endif ! endif ! From f1c425b0be40a4b8482938b055380b1185308012 Mon Sep 17 00:00:00 2001 From: Kees Nederhoff Date: Tue, 31 Mar 2026 12:10:23 -0700 Subject: [PATCH 18/65] included loss function in bucket model --- source/src/sfincs_data.f90 | 7 +- source/src/sfincs_infiltration.f90 | 106 +++++++++++++++++++++++------ source/src/sfincs_input.f90 | 1 + source/src/sfincs_openacc.f90 | 4 +- 4 files changed, 95 insertions(+), 23 deletions(-) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 2eb81c5a0..ef25bf796 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -419,10 +419,13 @@ module sfincs_data ! Bucket model - finite capacity reservoir with linear drainage ! logical :: use_bucket_model = .false. + real*4 :: bucket_loss_default = 0.0 ! uniform loss fraction from sfincs.inp (0-1) real*4, dimension(:), allocatable :: bucket_volume ! current storage (m) real*4, dimension(:), allocatable :: bucket_capacity ! max capacity S_max (m) real*4, dimension(:), allocatable :: bucket_k ! drainage coefficient (1/s) real*4, dimension(:), allocatable :: bucket_drain_rate ! net removal from surface this step (m/s) + real*4, dimension(:), allocatable :: bucket_loss ! loss fraction per cell (0-1), ET/deep percolation + real*4, dimension(:), allocatable :: bucket_runoff ! bucket drainage returned as surface runoff (m/s) ! ! Wind reduction for spiderweb winds ! @@ -945,7 +948,9 @@ subroutine finalize_parameters() if(allocated(bucket_capacity)) deallocate(bucket_capacity) if(allocated(bucket_k)) deallocate(bucket_k) if(allocated(bucket_drain_rate)) deallocate(bucket_drain_rate) - if(allocated(nuvisc)) deallocate(nuvisc) + if(allocated(bucket_loss)) deallocate(bucket_loss) + if(allocated(bucket_runoff)) deallocate(bucket_runoff) + if(allocated(nuvisc)) deallocate(nuvisc) ! ! Boundary velocity points ! diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index d6784f47e..c3716496a 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -1059,12 +1059,13 @@ subroutine update_infiltration_map(dt, tloop) subroutine initialize_bucket_model() ! + use netcdf use sfincs_data use sfincs_ncinput ! implicit none ! - integer :: nchar + integer :: nchar, status, ncid, varid logical :: ok character*256 :: varname ! @@ -1079,11 +1080,15 @@ subroutine initialize_bucket_model() allocate(bucket_k(np)) allocate(bucket_volume(np)) allocate(bucket_drain_rate(np)) + allocate(bucket_loss(np)) + allocate(bucket_runoff(np)) ! - bucket_capacity = 0.0 - bucket_k = 0.0 - bucket_volume = 0.0 + bucket_capacity = 0.0 + bucket_k = 0.0 + bucket_volume = 0.0 bucket_drain_rate = 0.0 + bucket_loss = bucket_loss_default + bucket_runoff = 0.0 ! if (netcdf_infiltration) then ! @@ -1097,6 +1102,18 @@ subroutine initialize_bucket_model() call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_k) bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s ! + ! Try reading spatially-varying loss fraction (optional, falls back to uniform) + status = nf90_open(trim(infiltrationfile), NF90_NOWRITE, ncid) + if (status == nf90_noerr) then + status = nf90_inq_varid(ncid, 'bucket_loss', varid) + nchar = nf90_close(ncid) + if (status == nf90_noerr) then + varname = 'bucket_loss' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_loss) + call write_log('Info : read spatially-varying bucket_loss from infiltrationfile', 0) + endif + endif + ! elseif (bucketfile /= 'none') then ! nchar = len_trim(bucketfile) @@ -1116,6 +1133,18 @@ subroutine initialize_bucket_model() call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_k) bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s ! + ! Try reading spatially-varying loss fraction (optional, falls back to uniform) + status = nf90_open(trim(bucketfile), NF90_NOWRITE, ncid) + if (status == nf90_noerr) then + status = nf90_inq_varid(ncid, 'bucket_loss', varid) + nchar = nf90_close(ncid) + if (status == nf90_noerr) then + varname = 'bucket_loss' + call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_loss) + call write_log('Info : read spatially-varying bucket_loss from bucketfile', 0) + endif + endif + ! else ! ! Read from binary files @@ -1136,6 +1165,8 @@ subroutine initialize_bucket_model() ! write(logstr,'(a,f10.4,a)')'Info : bucket max capacity = ', maxval(bucket_capacity) * 1000.0, ' mm' call write_log(logstr, 0) + write(logstr,'(a,f6.3)')'Info : bucket loss fraction = ', maxval(bucket_loss) + call write_log(logstr, 0) ! else ! @@ -1145,10 +1176,14 @@ subroutine initialize_bucket_model() allocate(bucket_k(1)) allocate(bucket_volume(1)) allocate(bucket_drain_rate(1)) + allocate(bucket_loss(1)) + allocate(bucket_runoff(1)) bucket_capacity = 0.0 bucket_k = 0.0 bucket_volume = 0.0 bucket_drain_rate = 0.0 + bucket_loss = 0.0 + bucket_runoff = 0.0 ! endif ! @@ -1157,8 +1192,16 @@ subroutine initialize_bucket_model() subroutine compute_bucket_drainage(dt) ! - ! Bucket model: finite capacity reservoir with linear drainage (HBV/wflow style) - ! Recovery is inherent - bucket drains during dry periods via Q=k*S, restoring capacity + ! Bucket model with loss: linear reservoir + loss fraction (HBV/wflow style) + ! + ! Steps per cell: + ! 1. P_eff = P * (1 - loss) -- fraction lost to ET/deep percolation + ! 2. Fill bucket with P_eff (up to Smax capacity) + ! 3. Drain bucket: S(t+dt) = S(t)*exp(-k*dt), drainage returned as runoff + ! 4. qinfmap = P - runoff -- net removal from surface + ! + ! In continuity: zs += prcp*dt - qinfmap*dt = bucket_runoff*dt + ! => Only bucket drainage reaches the surface water level ! ! Literature: Linear reservoir (Nash, 1957), HBV soil moisture bucket (Bergstrom, 1995) ! @@ -1170,34 +1213,55 @@ subroutine compute_bucket_drainage(dt) integer :: nm real*4 :: exp_factor real*4 :: drain_vol - real*4 :: available_water + real*4 :: P_eff real*4 :: available_cap real*4 :: actual_inflow + real*4 :: precip_rate ! - !$omp parallel do private(nm, exp_factor, drain_vol, available_water, available_cap, actual_inflow) + !$omp parallel do private(nm, exp_factor, drain_vol, P_eff, available_cap, actual_inflow, precip_rate) + !$acc parallel present( kcs, prcp, qinfmap, cuminf, bucket_volume, bucket_capacity, bucket_k, & + !$acc bucket_drain_rate, bucket_loss, bucket_runoff ) + !$acc loop independent gang vector do nm = 1, np ! - if (kcs(nm) == 1 .and. bucket_capacity(nm) > 0.0) then + if (kcs(nm) == 1 .and. bucket_k(nm) > 0.0) then + ! + ! Step 1: Compute effective precipitation (after loss) + ! + precip_rate = max(prcp(nm), 0.0) + P_eff = precip_rate * (1.0 - bucket_loss(nm)) ! m/s after loss + ! + ! Step 2: Fill bucket with effective precip (up to capacity) + ! + if (bucket_capacity(nm) > 0.0) then + available_cap = bucket_capacity(nm) - bucket_volume(nm) + actual_inflow = min(P_eff * dt, available_cap) ! m + else + ! No capacity limit (Smax = 0 means infinite) + actual_inflow = P_eff * dt ! m + endif + bucket_volume(nm) = bucket_volume(nm) + actual_inflow ! - ! Step 1: Drain current storage (analytical linear reservoir solution) + ! Step 3: Drain bucket (analytical linear reservoir) ! S(t+dt) = S(t) * exp(-k*dt), drainage = S(t) - S(t+dt) ! exp_factor = exp(-bucket_k(nm) * dt) - drain_vol = bucket_volume(nm) * (1.0 - exp_factor) + drain_vol = bucket_volume(nm) * (1.0 - exp_factor) ! m drained this step bucket_volume(nm) = bucket_volume(nm) * exp_factor ! - ! Step 2: Fill bucket from available rainfall + ! Step 4: Bucket drainage becomes runoff returned to surface ! - available_water = max(prcp(nm), 0.0) * dt ! m of water available - available_cap = bucket_capacity(nm) - bucket_volume(nm) - actual_inflow = min(available_water, available_cap) - bucket_volume(nm) = bucket_volume(nm) + actual_inflow + bucket_runoff(nm) = drain_vol / dt ! m/s + ! + ! Step 5: Set qinfmap = loss + what entered bucket - what drained back + ! In continuity: zs += prcp*dt - qinfmap*dt + ! Water balance: qinfmap = prcp*loss + actual_inflow/dt - bucket_runoff + ! When bucket has room: actual_inflow = P_eff*dt => qinfmap = prcp - bucket_runoff + ! When bucket is full: actual_inflow = 0 => qinfmap can be negative (drainage > inflow) ! - ! Step 3: Set qinfmap = what entered the bucket (removed from surface) - ! This is used by continuity as the infiltration loss term + qinfmap(nm) = precip_rate * bucket_loss(nm) + actual_inflow / dt - bucket_runoff(nm) ! - qinfmap(nm) = actual_inflow / dt - bucket_drain_rate(nm) = actual_inflow / dt + bucket_drain_rate(nm) = bucket_runoff(nm) ! if (store_cumulative_precipitation) then cuminf(nm) = cuminf(nm) + qinfmap(nm) * dt @@ -1207,10 +1271,12 @@ subroutine compute_bucket_drainage(dt) ! qinfmap(nm) = 0.0 bucket_drain_rate(nm) = 0.0 + bucket_runoff(nm) = 0.0 ! endif ! enddo + !$acc end parallel !$omp end parallel do ! end subroutine diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 34163b0bd..5f76d76b1 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -213,6 +213,7 @@ subroutine read_sfincs_input() call read_char_input(500,'infiltrationfile',infiltrationfile,'none') call read_char_input(500,'infiltrationtype',inftype,'none') call read_char_input(500,'bucketfile',bucketfile,'none') ! bucket model (infiltration flavor 'bkt') + call read_real_input(500,'bucket_loss_frac',bucket_loss_default,0.0) ! bucket loss fraction (0-1) call read_real_input(500,'qdrain',qdrain_uniform,0.0) ! drainage mimic (mm/hr) call read_char_input(500,'drainagefile',drainagefile,'none') ! spatially-varying drainage rates ! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 3d2a9cdcc..74d8a856a 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -36,7 +36,7 @@ subroutine initialize_openacc() !$acc gnapp2, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & - !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate ) + !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff ) ! end subroutine ! @@ -66,7 +66,7 @@ subroutine finalize_openacc() !$acc gnapp2, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & - !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate ) + !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff ) ! end ! From 2a07fe88bdca891e71ae728324729104031b1fbb Mon Sep 17 00:00:00 2001 From: Kees Nederhoff Date: Wed, 15 Apr 2026 05:14:14 -0700 Subject: [PATCH 19/65] ongoing progress --- docs/input.rst | 66 ++++++++++++-- docs/parameters.rst | 40 ++++++--- source/src/sfincs_continuity.f90 | 2 +- source/src/sfincs_data.f90 | 3 - source/src/sfincs_domain.f90 | 58 +++++------- source/src/sfincs_infiltration.f90 | 138 ++++++++--------------------- source/src/sfincs_input.f90 | 50 +++++++---- source/src/sfincs_ncoutput.F90 | 6 ++ 8 files changed, 187 insertions(+), 176 deletions(-) diff --git a/docs/input.rst b/docs/input.rst index 0829c475c..f1cbd3167 100644 --- a/docs/input.rst +++ b/docs/input.rst @@ -357,14 +357,37 @@ SFINCS allows the specification of the following options for accounting for infi 3. The Curve Number method: empirical rainfall-runoff model 4. The Green-Ampt method: empirical rainfall-runoff model 5. The Horton infiltration method +6. The bucket model: linear reservoir with losses -Infiltration is specified with either constant in time values in mm/hr (both uniform and spatially varying), or using more detailed parameters for the Curve Number method, The Green-Ampt method or Horton method. +Spatially uniform infiltration is still specified directly in sfincs.inp with ``qinf``. All modern spatially varying infiltration and bucket-model input should be provided through ``infiltrationfile`` together with ``infiltrationtype``. The older binary keywords (``qinffile``, ``scsfile``, ``smaxfile``, ``sefffile``, ``ksfile``, ``psifile``, ``sigmafile``, ``f0file``, ``fcfile`` and ``kdfile``) remain available for backward compatibility only and should be removed in a future cleanup. **NOTE - Infiltration in SFINCS is only turned on when any rainfall is forced'** **NOTE - Infiltration methods in SFINCS are not designed to be stacked** +NetCDF infiltration input (recommended): +%%%%% + +For all spatially varying infiltration methods the recommended interface is: + +.. code-block:: text + + infiltrationfile = sfincs.infiltration.nc + infiltrationtype = c2d | cna | cnb | gai | hor | bkt + +The required variables in ``infiltrationfile`` depend on ``infiltrationtype``: + +* ``c2d``: ``qinf`` +* ``cna``: ``scs`` +* ``cnb``: ``smax``, ``seff``, ``ks`` +* ``gai``: ``psi``, ``sigma``, ``ks`` +* ``hor``: ``f0``, ``fc``, ``kd`` +* ``bkt``: ``bucket_smax``, ``bucket_k``, ``bucket_loss`` + +The older separate binary infiltration keywords are still supported for backward compatibility only. The former separate inputs ``bucketfile`` and ``bucket_loss_frac`` have been removed; for the bucket model, all required variables must now be present in ``infiltrationfile``. + + Spatially uniform constant in time: %%%%% @@ -381,7 +404,7 @@ Specify the keyword: Spatially varying constant in time: %%%%% -For spatially varying infiltration values per cell use the qinffile option, with the same grid based input as the depfile using a binary file. +For spatially varying infiltration values per cell use ``infiltrationfile`` with ``infiltrationtype = c2d``. The ``qinffile`` option below is kept for backward compatibility only and should be removed in a future cleanup. **qinffile = sfincs.qinf** @@ -424,7 +447,7 @@ where Smax = the soil's maximum moisture storage capacity. Smax typically derive **Without recovery** -For spatially varying infiltration values per cell using the Curve Number method without recovery use the scsfile option, with the same grid based input as the depfile using a binary file. Note here that in pre-processing the wanted CN values should be converted to S values following: +For spatially varying infiltration values per cell using the Curve Number method without recovery use ``infiltrationfile`` with ``infiltrationtype = cna``. The ``scsfile`` option below is kept for backward compatibility only and should be removed in a future cleanup. Note here that in pre-processing the wanted CN values should be converted to S values following: * scsfile: maximum soil moisture storage capacity in inches .. code-block:: text @@ -456,7 +479,7 @@ This option doesn't support restart functionality. **With recovery** -Within SFINCS, the Curve number method with recovery can be used as follows. The user needs to provide the following variables. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: +Within SFINCS, the Curve number method with recovery is preferably supplied through ``infiltrationfile`` with ``infiltrationtype = cnb``. The separate binary files listed below are kept for backward compatibility only. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: * smaxfile: maximum soil moisture storage capacity in m * sefffile: soil moisture storage capacity at the start in m @@ -496,7 +519,7 @@ The basic form of the Green-Ampt equation is expressed as follows: In which t is time, K is the saturated hydraulic conductivity, delta_theta is defined as the soil capacity (the difference between the saturated and initial moisture content) and sigma is the soil suction head. -Within SFINCS, the Green-Ampt method can be used as follows. The user needs to provide the following variables. For a range of typically values see Table 1. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: +Within SFINCS, the Green-Ampt method is preferably supplied through ``infiltrationfile`` with ``infiltrationtype = gai``. The separate binary files listed below are kept for backward compatibility only. For a range of typically values see Table 1. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: * ksfile: saturated hydraulic conductivity in mm/hr * sigmafile: soil moisture deficit in [-] @@ -520,7 +543,7 @@ The basic form of the Horton equation is expressed as follows: In which f_t is the infiltration rate at time, f_c is the final, constant infiltration rate, f_0 is the initial infiltration rate, k is a decay constant and t is the time since the start of infiltration. -Within SFINCS, the Horton method can be used as follows. The user needs to provide the following variables. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: +Within SFINCS, the Horton method is preferably supplied through ``infiltrationfile`` with ``infiltrationtype = hor``. The separate binary files listed below are kept for backward compatibility only. For all variables, one needs to specify these values per cell with the same grid based input as the depfile using a binary file: * f0file: maximum (Initial) Infiltration Capacity in mm/hr * fcfile: Minimum (Asymptotic) Infiltration Rate in mm/hr @@ -531,6 +554,37 @@ The recovery of the infiltration rate during dry weather (kr) is calculated as f This option also supports restart functionality. +The bucket model: +%%%%% + +The bucket model is a linear-reservoir representation of infiltration and losses. It is configured with: + +.. code-block:: text + + infiltrationfile = sfincs.infiltration.nc + infiltrationtype = bkt + +The ``infiltrationfile`` must contain the following variables: + +* ``bucket_smax``: maximum bucket storage in mm +* ``bucket_k``: drainage coefficient in 1/hr +* ``bucket_loss``: loss fraction in the range 0-1 + +The former separate inputs ``bucketfile`` and ``bucket_loss_frac`` are no longer supported. + + +Drainage mimic: +%%%%% + +Drainage mimic is configured separately from infiltration and now only supports ``drainagefile``: + +.. code-block:: text + + drainagefile = sfincs.drainage + +This file may be a binary map or a NetCDF file containing ``drainage_rate`` in mm/hr. The former uniform ``qdrain`` keyword has been removed. + + Storage volume ^^^^^ diff --git a/docs/parameters.rst b/docs/parameters.rst index 4ad213c52..eafb65937 100644 --- a/docs/parameters.rst +++ b/docs/parameters.rst @@ -465,54 +465,68 @@ Domain :units: s/m^(1/3) :required: no in case of regular mode, ignored in case of subgrid mode :format: bin + infiltrationfile = sfincs.infiltration.nc + :description: Recommended NetCDF input for spatially varying infiltration and bucket-model losses. Use together with infiltrationtype. + :units: depends on selected infiltrationtype and variables in the NetCDF file + :required: no + :format: net + infiltrationtype = c2d | cna | cnb | gai | hor | bkt + :description: Selects which infiltration method is read from infiltrationfile. Bucket mode requires bucket_smax, bucket_k and bucket_loss in infiltrationfile. + :units: - + :required: Only when infiltrationfile is used + :format: asc + drainagefile = sfincs.drainage + :description: Spatially varying drainage mimic input in mm/hr. Can be a binary map or a NetCDF file with variable drainage_rate. This replaces the removed qdrain keyword. + :units: mm/hr + :required: no + :format: bin or net qinffile = sfincs.qinf - :description: For spatially varying constant in time infiltration values per cell use the qinffile option, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For spatially varying constant in time infiltration values per cell prefer infiltrationfile with infiltrationtype = c2d. :units: mm/hr :required: no :format: bin scsfile = sfincs.scs - :description: For spatially varying infiltration values per cell using the Curve Number method A (without recovery) use the scsfile option, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Curve Number method A (without recovery) prefer infiltrationfile with infiltrationtype = cna. :units: - :required: no :format: bin smaxfile = sfincs.smax - :description: For spatially varying infiltration values per cell using the Curve Number method B (with recovery) provide the smaxfile (as well as the sefffile and ksfile) as maximum soil moisture storage capacity in m, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Curve Number method B (with recovery) prefer infiltrationfile with infiltrationtype = cnb. The smaxfile contains the maximum soil moisture storage capacity in m. :units: m :required: no :format: bin sefffile = sfincs.seff - :description: For spatially varying infiltration values per cell using the Curve Number method B (with recovery) provide the sefffile (as well as the smaxfile and ksfile) as soil moisture storage capacity at the start in m, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Curve Number method B (with recovery) prefer infiltrationfile with infiltrationtype = cnb. The sefffile contains soil moisture storage capacity at the start in m. :units: m :required: no :format: bin ksfile = sfincs.ks - :description: For spatially varying infiltration values per cell using the Curve Number method B (with recovery) provide the ksfile (as well as the smaxfile and sefffile) as saturated hydraulic conductivity in mm/hr, with the same grid based input as the depfile using a binary file. - :description: For spatially varying infiltration values per cell using the Green & Ampt method (with recovery) provide the ksfile (as well as the sigmafile and psifile) as saturated hydraulic conductivity in mm/hr, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Curve Number method B (with recovery) and Green & Ampt infiltration prefer infiltrationfile with infiltrationtype = cnb or gai. The ksfile contains saturated hydraulic conductivity in mm/hr. :units: mm/hr :required: no :format: bin sigmafile = sfincs.sigma - :description: For spatially varying infiltration values per cell using the Green & Ampt method (with recovery) provide the sigmafile (as well as the psifile and ksfile) as suction head at the wetting front in mm, with the same grid based input as the depfile using a binary file. - :units: mm + :description: Backward compatibility only. For Green & Ampt infiltration prefer infiltrationfile with infiltrationtype = gai. The sigmafile contains soil moisture deficit in [-]. + :units: - :required: no :format: bin psifile = sfincs.psi - :description: For spatially varying infiltration values per cell using the Green & Ampt method (with recovery) provide the psifile (as well as the sigmafile and ksfile) as soil moisture deficit in [-], with the same grid based input as the depfile using a binary file. - :units: - + :description: Backward compatibility only. For Green & Ampt infiltration prefer infiltrationfile with infiltrationtype = gai. The psifile contains suction head at the wetting front in mm. + :units: mm :required: no :format: bin f0file = sfincs.f0 - :description: For spatially varying infiltration values per cell using the Horton method (with recovery) provide the f0file (as well as the fcfile and kdfile) as maximum (Initial) Infiltration Capacity in mm/hr, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Horton infiltration prefer infiltrationfile with infiltrationtype = hor. The f0file contains maximum (initial) infiltration capacity in mm/hr. :units: mm/hr :required: no :format: bin fcfile = sfincs.fc - :description: For spatially varying infiltration values per cell using the Horton method (with recovery) provide the fcfile (as well as the f0file and kdfile) as Minimum (Asymptotic) Infiltration Rate in mm/hr, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Horton infiltration prefer infiltrationfile with infiltrationtype = hor. The fcfile contains the minimum (asymptotic) infiltration rate in mm/hr. :units: mm/hr :required: no :format: bin kdfile = sfincs.kd - :description: For spatially varying infiltration values per cell using the Horton method (with recovery) provide the kdfile (as well as the f0file and fcfile) as empirical constant (hr-1) of decay, with the same grid based input as the depfile using a binary file. + :description: Backward compatibility only. For Horton infiltration prefer infiltrationfile with infiltrationtype = hor. The kdfile contains the empirical decay constant in hr-1. :units: hr-1 :required: no :format: bin diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index d50437556..ac42e2c57 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -12,7 +12,7 @@ subroutine update_continuity(t, dt, tloopsrc, tloopinf, tloopcont) ! 1. Rainfall (+) => already computed in sfincs_meteo (prcp) ! 2. Infiltration (-) => computed in sfincs_infiltration (qinfmap) ! (includes: con, c2d, cna, cnb, gai, hor, bkt flavors) - ! 3. Drainage mimic (-) => simple constant rate (qdrain_rate) + ! 3. Drainage mimic (-) => drainage rate field (qdrain_rate) ! 4. External source/sink qext (+/-) => set via BMI coupling ! 5. Storage volume => depression storage (subgrid only) ! diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index ef25bf796..a2a4d4d0f 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -171,7 +171,6 @@ module sfincs_data character*256 :: fcfile character*256 :: kdfile character*256 :: drainagefile - character*256 :: bucketfile character*256 :: z0lfile character*256 :: wvmfile character*256 :: qtrfile @@ -413,13 +412,11 @@ module sfincs_data ! Drainage - constant removal rate representing subsurface drainage ! logical :: drainage = .false. - real*4 :: qdrain_uniform = 0.0 ! uniform drainage rate (mm/hr input, stored as m/s) real*4, dimension(:), allocatable :: qdrain_rate ! drainage rate per cell (m/s) ! ! Bucket model - finite capacity reservoir with linear drainage ! logical :: use_bucket_model = .false. - real*4 :: bucket_loss_default = 0.0 ! uniform loss fraction from sfincs.inp (0-1) real*4, dimension(:), allocatable :: bucket_volume ! current storage (m) real*4, dimension(:), allocatable :: bucket_capacity ! max capacity S_max (m) real*4, dimension(:), allocatable :: bucket_k ! drainage coefficient (1/s) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 9b0383092..a2df13ae5 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -23,7 +23,7 @@ subroutine initialize_domain() ! call initialize_roughness() ! - call initialize_infiltration() ! see: sfincs_infiltration.f90 (includes bucket model if bucketfile specified) + call initialize_infiltration() ! see: sfincs_infiltration.f90 (includes bucket model if infiltrationtype='bkt') ! call initialize_drainage_mimic() ! @@ -2063,53 +2063,41 @@ subroutine initialize_drainage_mimic() ! ! Check if drainage is enabled ! - if (qdrain_uniform > 0.0 .or. drainagefile /= 'none') then + if (drainagefile /= 'none') then ! drainage = .true. ! allocate(qdrain_rate(np)) ! - if (drainagefile /= 'none') then + ! + ! Spatially-varying drainage rate + ! + write(logstr,'(a)')'Info : turning on drainage mimic (spatially-varying)' + call write_log(logstr, 0) + ! + nchar = len_trim(drainagefile) + ok = check_file_exists(drainagefile, 'Drainage file', .true.) + ! + if (drainagefile(nchar - 1 : nchar) == 'nc') then ! - ! Spatially-varying drainage rate + varname = 'drainage_rate' + call read_netcdf_quadtree_to_sfincs(drainagefile, varname, qdrain_rate) ! - write(logstr,'(a)')'Info : turning on drainage mimic (spatially-varying)' - call write_log(logstr, 0) + ! Convert from mm/hr to m/s ! - nchar = len_trim(drainagefile) - ok = check_file_exists(drainagefile, 'Drainage file', .true.) - ! - if (drainagefile(nchar - 1 : nchar) == 'nc') then - ! - varname = 'drainage_rate' - call read_netcdf_quadtree_to_sfincs(drainagefile, varname, qdrain_rate) - ! - ! Convert from mm/hr to m/s - ! - qdrain_rate = qdrain_rate / 3600.0 / 1000.0 - ! - else - ! - ! Read from binary file (assumed to be in mm/hr) - ! - open(unit = 500, file = trim(drainagefile), form = 'unformatted', access = 'stream') - read(500)qdrain_rate - close(500) - ! - ! Convert from mm/hr to m/s - ! - qdrain_rate = qdrain_rate / 3600.0 / 1000.0 - ! - endif + qdrain_rate = qdrain_rate / 3600.0 / 1000.0 ! else ! - ! Uniform drainage rate (already converted to m/s in sfincs_input.f90) + ! Read from binary file (assumed to be in mm/hr) ! - write(logstr,'(a,f10.4,a)')'Info : turning on drainage mimic (uniform, ', qdrain_uniform * 3600.0 * 1000.0, ' mm/hr)' - call write_log(logstr, 0) + open(unit = 500, file = trim(drainagefile), form = 'unformatted', access = 'stream') + read(500)qdrain_rate + close(500) + ! + ! Convert from mm/hr to m/s ! - qdrain_rate = qdrain_uniform + qdrain_rate = qdrain_rate / 3600.0 / 1000.0 ! endif ! diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index c3716496a..f020477e4 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -47,7 +47,7 @@ subroutine initialize_infiltration() ! 6) 'hor' - Modified Horton equation ! Requires: f0file or infiltrationfile ! 7) 'bkt' - Bucket model (linear reservoir, HBV/wflow style) - ! Requires: bucketfile (netcdf with bucket_smax and bucket_k) + ! Requires: infiltrationfile with bucket_smax, bucket_k and bucket_loss ! ! cumprcp and cuminf are stored in the netcdf output if store_cumulative_precipitation == .true. which is the default ! @@ -63,6 +63,12 @@ subroutine initialize_infiltration() ! 1) First we determine infiltration type ! if (precip) then + ! + if (inftype == 'bkt' .and. infiltrationfile == 'none') then + ! + call stop_sfincs('Error ! Bucket model requires infiltrationfile together with infiltrationtype = bkt !', 1) + ! + endif ! if (infiltrationfile /= 'none') then ! @@ -134,13 +140,6 @@ subroutine initialize_infiltration() infiltration = .true. store_meteo = .true. ! - elseif (bucketfile /= 'none') then - ! - ! Bucket model (linear reservoir) - ! - inftype = 'bkt' - infiltration = .true. - ! endif ! ! 2) We need cumprcp and cuminf @@ -182,27 +181,11 @@ subroutine initialize_infiltration() ! (regular grids populate quadtree_nr_points and index_sfincs_in_quadtree ! via make_quadtree_from_indices) ! - ! Bucket model uses bucketfile (not infiltrationfile), but supports netcdf natively - ! if (.not. netcdf_infiltration) then ! if (use_quadtree .eqv. .true.) then ! - ! Allow bucket model with netcdf bucketfile on quadtree grids - ! - if (inftype == 'bkt' .and. bucketfile /= 'none') then - ! - if (bucketfile(len_trim(bucketfile) - 1 : len_trim(bucketfile)) /= 'nc') then - ! - call stop_sfincs('Error ! Bucket model on quadtree mesh requires a netcdf bucketfile (.nc) !', 1) - ! - endif - ! - else - ! - call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) - ! - endif + call stop_sfincs('Error ! Infiltration input for quadtree mesh model can only be specified using the infiltrationfile Netcdf format! !', 1) ! endif ! @@ -1065,11 +1048,10 @@ subroutine initialize_bucket_model() ! implicit none ! - integer :: nchar, status, ncid, varid - logical :: ok + integer :: status, ncid, varid character*256 :: varname ! - if (bucketfile /= 'none' .or. netcdf_infiltration) then + if (netcdf_infiltration) then ! use_bucket_model = .true. ! @@ -1087,82 +1069,38 @@ subroutine initialize_bucket_model() bucket_k = 0.0 bucket_volume = 0.0 bucket_drain_rate = 0.0 - bucket_loss = bucket_loss_default + bucket_loss = 0.0 bucket_runoff = 0.0 ! - if (netcdf_infiltration) then - ! - ! Read from infiltrationfile (netcdf) - works for both regular and quadtree grids - ! - varname = 'bucket_smax' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_capacity) - bucket_capacity = bucket_capacity / 1000.0 ! mm to m - ! - varname = 'bucket_k' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_k) - bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s - ! - ! Try reading spatially-varying loss fraction (optional, falls back to uniform) - status = nf90_open(trim(infiltrationfile), NF90_NOWRITE, ncid) - if (status == nf90_noerr) then - status = nf90_inq_varid(ncid, 'bucket_loss', varid) - nchar = nf90_close(ncid) - if (status == nf90_noerr) then - varname = 'bucket_loss' - call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_loss) - call write_log('Info : read spatially-varying bucket_loss from infiltrationfile', 0) - endif - endif - ! - elseif (bucketfile /= 'none') then - ! - nchar = len_trim(bucketfile) - ok = check_file_exists(bucketfile, 'Bucket model file', .true.) - ! - if (bucketfile(nchar - 1 : nchar) == 'nc') then - ! - ! Read bucket capacity (S_max) in mm, convert to m - ! - varname = 'bucket_smax' - call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_capacity) - bucket_capacity = bucket_capacity / 1000.0 ! mm to m - ! - ! Read drainage coefficient (k) in 1/hr, convert to 1/s - ! - varname = 'bucket_k' - call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_k) - bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s - ! - ! Try reading spatially-varying loss fraction (optional, falls back to uniform) - status = nf90_open(trim(bucketfile), NF90_NOWRITE, ncid) - if (status == nf90_noerr) then - status = nf90_inq_varid(ncid, 'bucket_loss', varid) - nchar = nf90_close(ncid) - if (status == nf90_noerr) then - varname = 'bucket_loss' - call read_netcdf_quadtree_to_sfincs(bucketfile, varname, bucket_loss) - call write_log('Info : read spatially-varying bucket_loss from bucketfile', 0) - endif - endif - ! - else - ! - ! Read from binary files - ! - open(unit = 500, file = trim(bucketfile), form = 'unformatted', access = 'stream') - read(500)bucket_capacity - close(500) - bucket_capacity = bucket_capacity / 1000.0 ! mm to m - ! - ! For binary input, k needs a separate file - not supported yet - ! Default k = 0.1/hr - ! - bucket_k = 0.1 / 3600.0 - ! - endif - ! + ! + ! Read from infiltrationfile (netcdf) - works for both regular and quadtree grids + ! + varname = 'bucket_smax' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_capacity) + bucket_capacity = bucket_capacity / 1000.0 ! mm to m + ! + varname = 'bucket_k' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_k) + bucket_k = bucket_k / 3600.0 ! 1/hr to 1/s + ! + status = nf90_open(trim(infiltrationfile), NF90_NOWRITE, ncid) + if (status /= nf90_noerr) then + call stop_sfincs('Error ! Cannot open infiltrationfile for bucket model input !', 1) + endif + ! + status = nf90_inq_varid(ncid, 'bucket_loss', varid) + if (nf90_close(ncid) /= nf90_noerr) then + call stop_sfincs('Error ! Cannot close infiltrationfile after checking bucket model variables !', 1) endif ! + if (status /= nf90_noerr) then + call stop_sfincs('Error ! Bucket model requires variable bucket_loss in infiltrationfile !', 1) + endif + ! + varname = 'bucket_loss' + call read_netcdf_quadtree_to_sfincs(infiltrationfile, varname, bucket_loss) + call write_log('Info : read spatially-varying bucket_loss from infiltrationfile', 0) + ! write(logstr,'(a,f10.4,a)')'Info : bucket max capacity = ', maxval(bucket_capacity) * 1000.0, ' mm' call write_log(logstr, 0) write(logstr,'(a,f6.3)')'Info : bucket loss fraction = ', maxval(bucket_loss) diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 5f76d76b1..be4a8bc66 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -41,6 +41,7 @@ subroutine read_sfincs_input() ! character*256 wmsigstr character*256 advstr + character*256 removed_input ! ok = check_file_exists('sfincs.inp', 'SFINCS input file', .true.) ! @@ -187,20 +188,6 @@ subroutine read_sfincs_input() call read_char_input(500,'amprfile',amprfile,'none') call read_char_input(500,'z0lfile',z0lfile,'none') call read_char_input(500,'wvmfile',wvmfile,'none') - call read_char_input(500,'qinffile',qinffile,'none') - ! Curve Number files - call read_char_input(500,'scsfile',scsfile,'none') - call read_char_input(500,'smaxfile',smaxfile,'none') - call read_char_input(500,'sefffile',sefffile,'none') - ! Green and Ampt files - call read_char_input(500,'psifile',psifile,'none') ! suction head [mm] - call read_char_input(500,'sigmafile',sigmafile,'none') ! maximum moisture deficit θdmax [-] - call read_char_input(500,'ksfile',ksfile,'none') ! saturated hydraulic conductivity [mm/hr] - ! Horton file - call read_char_input(500,'f0file',f0file,'none') ! Maximum (Initial) Infiltration Capacity, F0 - call read_char_input(500,'fcfile',fcfile,'none') ! Minimum (Asymptotic) Infiltration Rate, Fc - call read_char_input(500,'kdfile',kdfile,'none') ! k = empirical constant (hr-1) of decay - call read_real_input(500,'horton_kr_kd',horton_kr_kd,10.0) ! recovery goes 10 times as SLOW as decay ! Netcdf input call read_char_input(500,'netbndbzsbzifile',netbndbzsbzifile,'none') call read_char_input(500,'netsrcdisfile',netsrcdisfile,'none') @@ -212,10 +199,38 @@ subroutine read_sfincs_input() ! Infiltration and losses call read_char_input(500,'infiltrationfile',infiltrationfile,'none') call read_char_input(500,'infiltrationtype',inftype,'none') - call read_char_input(500,'bucketfile',bucketfile,'none') ! bucket model (infiltration flavor 'bkt') - call read_real_input(500,'bucket_loss_frac',bucket_loss_default,0.0) ! bucket loss fraction (0-1) - call read_real_input(500,'qdrain',qdrain_uniform,0.0) ! drainage mimic (mm/hr) call read_char_input(500,'drainagefile',drainagefile,'none') ! spatially-varying drainage rates + call read_char_input(500,'bucketfile',removed_input,'__removed_keyword_not_present__') + if (trim(removed_input) /= '__removed_keyword_not_present__') then + write(logstr,'(a)') 'Error : keyword bucketfile has been removed. Use infiltrationfile together with infiltrationtype = bkt.' + call stop_sfincs(trim(logstr), 1) + endif + call read_char_input(500,'bucket_loss_frac',removed_input,'__removed_keyword_not_present__') + if (trim(removed_input) /= '__removed_keyword_not_present__') then + write(logstr,'(a)') 'Error : keyword bucket_loss_frac has been removed. Add bucket_loss to infiltrationfile instead.' + call stop_sfincs(trim(logstr), 1) + endif + call read_char_input(500,'qdrain',removed_input,'__removed_keyword_not_present__') + if (trim(removed_input) /= '__removed_keyword_not_present__') then + write(logstr,'(a)') 'Error : keyword qdrain has been removed. Use drainagefile for drainage mimic input.' + call stop_sfincs(trim(logstr), 1) + endif + ! + ! Legacy binary infiltration input (backward compatibility only; remove in a future cleanup) + call read_char_input(500,'qinffile',qinffile,'none') + ! Curve Number files (legacy binary support) + call read_char_input(500,'scsfile',scsfile,'none') + call read_char_input(500,'smaxfile',smaxfile,'none') + call read_char_input(500,'sefffile',sefffile,'none') + ! Green and Ampt files (legacy binary support) + call read_char_input(500,'psifile',psifile,'none') ! suction head [mm] + call read_char_input(500,'sigmafile',sigmafile,'none') ! maximum moisture deficit theta_dmax [-] + call read_char_input(500,'ksfile',ksfile,'none') ! saturated hydraulic conductivity [mm/hr] + ! Horton files (legacy binary support) + call read_char_input(500,'f0file',f0file,'none') ! Maximum (Initial) Infiltration Capacity, F0 + call read_char_input(500,'fcfile',fcfile,'none') ! Minimum (Asymptotic) Infiltration Rate, Fc + call read_char_input(500,'kdfile',kdfile,'none') ! k = empirical constant (hr-1) of decay + call read_real_input(500,'horton_kr_kd',horton_kr_kd,10.0) ! recovery goes 10 times as SLOW as decay ! ! Output call read_char_input(500,'obsfile',obsfile,'none') @@ -318,7 +333,6 @@ subroutine read_sfincs_input() gn2 = 9.81*0.02*0.02 ! Only to be used in subgrid ! qinf = qinf/(3600*1000) - qdrain_uniform = qdrain_uniform/(3600*1000) ! Convert mm/hr to m/s ! rotation = rotation*pi/180 cosrot = cos(rotation) diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 6a9ecdf3d..dc9e5cf99 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -3963,6 +3963,9 @@ subroutine ncoutput_add_params(ncid, varid) NF90(nf90_put_att(ncid, varid, 'amvfile',amvfile)) NF90(nf90_put_att(ncid, varid, 'ampfile',ampfile)) NF90(nf90_put_att(ncid, varid, 'amprfile',amprfile)) + NF90(nf90_put_att(ncid, varid, 'infiltrationfile',infiltrationfile)) + NF90(nf90_put_att(ncid, varid, 'infiltrationtype',inftype)) + NF90(nf90_put_att(ncid, varid, 'drainagefile',drainagefile)) NF90(nf90_put_att(ncid, varid, 'qinffile',qinffile)) NF90(nf90_put_att(ncid, varid, 'scsfile',scsfile)) NF90(nf90_put_att(ncid, varid, 'smaxfile',smaxfile)) @@ -3970,6 +3973,9 @@ subroutine ncoutput_add_params(ncid, varid) NF90(nf90_put_att(ncid, varid, 'ksfile',ksfile)) NF90(nf90_put_att(ncid, varid, 'psifile',psifile)) NF90(nf90_put_att(ncid, varid, 'sigmafile',sigmafile)) + NF90(nf90_put_att(ncid, varid, 'f0file',f0file)) + NF90(nf90_put_att(ncid, varid, 'fcfile',fcfile)) + NF90(nf90_put_att(ncid, varid, 'kdfile',kdfile)) NF90(nf90_put_att(ncid, varid, 'z0lfile',z0lfile)) NF90(nf90_put_att(ncid, varid, 'wvmfile',wvmfile)) ! From a7dde240f7aee6486aa6241075acdf7a169f564c Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Thu, 16 Apr 2026 12:46:24 +0200 Subject: [PATCH 20/65] Split src-point structures into new module Add sfincs_src_structures module and refactor discharge handling: introduce a cell-wise discharge accumulator qsrc (allocated in sfincs_data and domain init) that both river sources and src-point structures write into. Extract structure logic (pumps, culverts, check valves, controlled gates) from sfincs_discharges into new sfincs_src_structures with initialize/update routines; rename/clean up discharge initialization to initialize_discharges and separate river time-series storage (qsrc_ts). Update continuity and update_discharges to apply qsrc per-cell (OpenACC/OpenMP parallel loops), zero qsrc each step, and use atomic updates when accumulating. Update NetCDF input/output (sfincs_ncinput/F90, sfincs_ncoutput.F90) and runtime output (sfincs_output.f90) to handle river variables and qsrc_ts. Wire new file into project files (Makefile.am, sfincs_lib.vfproj) and initialize/update both modules from sfincs_lib. Misc: OpenACC directives and minor formatting/variable renames adjusted to match the refactor. --- source/sfincs_lib/sfincs_lib.vfproj | 1 + source/src/Makefile.am | 1 + source/src/sfincs_continuity.f90 | 61 ++- source/src/sfincs_data.f90 | 36 +- source/src/sfincs_discharges.f90 | 621 ++++----------------------- source/src/sfincs_domain.f90 | 18 +- source/src/sfincs_lib.f90 | 8 +- source/src/sfincs_ncinput.F90 | 6 +- source/src/sfincs_ncoutput.F90 | 45 +- source/src/sfincs_openacc.f90 | 4 +- source/src/sfincs_output.f90 | 17 +- source/src/sfincs_src_structures.f90 | 373 ++++++++++++++++ 12 files changed, 583 insertions(+), 608 deletions(-) create mode 100644 source/src/sfincs_src_structures.f90 diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 34bf8f520..e77d5d747 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -62,6 +62,7 @@ + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index 891652f08..c36927c0c 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -39,6 +39,7 @@ libsfincs_la_SOURCES = \ sfincs_continuity.f90 \ sfincs_crosssections.f90 \ sfincs_discharges.f90 \ + sfincs_src_structures.f90 \ sfincs_subgrid.F90 \ sfincs_timestep_analysis.f90 \ sfincs_infiltration.f90 \ diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index 592477666..b1c16e911 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -79,31 +79,26 @@ subroutine compute_water_levels_regular(dt,t) !$acc z_flags_iref, uv_flags_iref, & !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & - !$acc nmindsrc, qtsrc, & + !$acc qsrc, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num ) ! - ! First discharges (don't do this parallel, as it's probably not worth it) + ! Apply cell-wise discharges (rivers + src-point structures, accumulated + ! into qsrc by sfincs_discharges and sfincs_src_structures). ! - if (nsrcdrn > 0) then - ! - !$acc loop - do isrc = 1, nsrcdrn - ! - nm = nmindsrc(isrc) - ! + !$acc loop + do nm = 1, np + ! + if (qsrc(nm) /= 0.0) then + ! if (crsgeo) then - ! - zs(nmindsrc(isrc)) = max(zs(nm) + qtsrc(isrc) * dt / cell_area_m2(nm), zb(nm)) - ! + zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area_m2(nm), zb(nm)) else - ! - zs(nmindsrc(isrc)) = max(zs(nm) + qtsrc(isrc) * dt / cell_area(z_flags_iref(nm)), zb(nm)) - ! + zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area(z_flags_iref(nm)), zb(nm)) endif - ! - enddo - ! - endif + ! + endif + ! + enddo ! !$omp parallel & !$omp private ( nm,dvol,nmd,nmu,ndm,num,qnmd,qnmu,qndm,qnum,iwm) @@ -305,24 +300,18 @@ subroutine compute_water_levels_subgrid(dt,t) ! endif ! - ! First discharges (don't do this parallel, as it's probably not worth it) - ! NVFORTAN turns this into a sequential loop (!$acc loop seq) + ! Apply cell-wise discharges to z_volume (rivers + src-point structures, + ! accumulated into qsrc by sfincs_discharges and sfincs_src_structures). ! - if (nsrcdrn > 0) then - ! - !$acc serial present( z_volume, nmindsrc, qtsrc ) - do isrc = 1, nsrcdrn - ! - nm = nmindsrc(isrc) - ! - if ((z_volume(nm) >= 0) .or. ((qtsrc(isrc)<0.0) .and. (z_volume(nm) >= 0))) then - z_volume(nm) = z_volume(nm) + qtsrc(isrc) * dt - endif - ! - enddo - !$acc end serial - ! - endif + !$acc parallel loop present( z_volume, qsrc ) + !$omp parallel do schedule ( static ) + do nm = 1, np + if (qsrc(nm) /= 0.0 .and. z_volume(nm) >= 0) then + z_volume(nm) = z_volume(nm) + qsrc(nm) * dt + endif + enddo + !$omp end parallel do + !$acc end parallel loop ! !$omp parallel & !$omp private ( dvol,dzsdt,nmd,nmu,ndm,num,a,iuv,facint,dzvol,ind,iwm,qnmd,qnmu,qndm,qnum,dv,zs00,zs11 ) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 935be5983..4d30ec807 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -772,22 +772,36 @@ module sfincs_data !!! !!! Discharges and drainage !!! + ! Cell-wise accumulated discharge used by continuity. Size np. Zeroed + ! each step, then both sfincs_discharges and sfincs_src_structures + ! accumulate into it. + ! + real*4, dimension(:), allocatable :: qsrc ! (np) cell-wise discharge [m3/s] + ! + ! River point discharges (sfincs_discharges) + ! integer :: nsrc - integer :: ndrn - integer :: nsrcdrn integer :: ntsrc integer :: itsrclast - real*4, dimension(:), allocatable :: tsrc - real*4, dimension(:,:), allocatable :: qsrc - real*4, dimension(:), allocatable :: qtsrc - integer*4, dimension(:), allocatable :: nmindsrc + real*4, dimension(:), allocatable :: tsrc ! (ntsrc) time stamps of river discharge time series + real*4, dimension(:,:), allocatable :: qsrc_ts ! (nsrc, ntsrc) river discharge time series matrix + real*4, dimension(:), allocatable :: qtsrc ! (nsrc) interpolated discharge at current time, for his output + integer*4, dimension(:), allocatable :: nmindsrc ! (nsrc) river source cell indices + real*4, dimension(:), allocatable :: xsrc + real*4, dimension(:), allocatable :: ysrc + ! + ! Src-point structures: pumps, culverts, check valves, controlled gates + ! (sfincs_src_structures) + ! + integer :: ndrn + integer*4, dimension(:), allocatable :: nmindrn_in ! (ndrn) intake (sink) cell indices + integer*4, dimension(:), allocatable :: nmindrn_out ! (ndrn) outfall (source) cell indices + real*4, dimension(:), allocatable :: qdrain ! (ndrn) signed discharge per structure, for his output integer*1, dimension(:), allocatable :: drainage_type real*4, dimension(:,:), allocatable :: drainage_params real*4, dimension(:), allocatable :: drainage_distance integer*1, dimension(:), allocatable :: drainage_status real*4, dimension(:), allocatable :: drainage_fraction_open - real*4, dimension(:), allocatable :: xsrc - real*4, dimension(:), allocatable :: ysrc !!! !!! Structures !!! @@ -1111,10 +1125,14 @@ subroutine finalize_parameters() !!! !!! Discharges !!! - if(allocated(tsrc)) deallocate(tsrc) if(allocated(qsrc)) deallocate(qsrc) + if(allocated(tsrc)) deallocate(tsrc) + if(allocated(qsrc_ts)) deallocate(qsrc_ts) if(allocated(qtsrc)) deallocate(qtsrc) if(allocated(nmindsrc)) deallocate(nmindsrc) + if(allocated(nmindrn_in)) deallocate(nmindrn_in) + if(allocated(nmindrn_out)) deallocate(nmindrn_out) + if(allocated(qdrain)) deallocate(qdrain) !!! !!! Structures !!! diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index dd50ffd27..45f364838 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -1,13 +1,24 @@ module sfincs_discharges - + ! + ! River point discharges: nsrc (x,y) locations from srcfile with matching + ! time series qsrc_ts(:,:) from disfile, OR from a FEWS-style netCDF input + ! via netsrcdisfile. Interpolates to the current model time every step, + ! stores the interpolated value in qtsrc(nsrc) (for his output), and + ! accumulates the per-cell discharge into the global qsrc(np) array used + ! by sfincs_continuity. + ! + ! Drainage structures (pumps, check valves, culverts, controlled gates) + ! live in sfincs_src_structures. The two modules no longer share any + ! arrays -- they cooperate only by both writing into qsrc(np). + ! use sfincs_log use sfincs_error contains ! - subroutine read_discharges() + subroutine initialize_discharges() ! - ! Reads discharge files + ! Read src/dis or netsrcdis. Allocate nmindsrc(nsrc), qtsrc(nsrc). ! use sfincs_data use sfincs_ncinput @@ -15,335 +26,153 @@ subroutine read_discharges() ! implicit none ! - real*4, dimension(:), allocatable :: xsnk - real*4, dimension(:), allocatable :: ysnk - ! - real*4 dummy, xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp - ! - integer isrc, itsrc, idrn, nm, m, n, stat, j, iref, nmq, npars - ! - logical :: ok + real*4 :: dummy + integer :: isrc, itsrc, nmq, n, stat + logical :: ok ! - character(len=256) :: drainage_line, message - ! - ! Read discharge points - ! - nsrc = 0 - ndrn = 0 - ntsrc = 0 + nsrc = 0 + ntsrc = 0 itsrclast = 1 ! if (srcfile(1:4) /= 'none') then ! ok = check_file_exists(srcfile, 'Source points file', .true.) ! - write(logstr,'(a)')'Info : reading discharges' + write(logstr,'(a)') 'Info : reading discharges' call write_log(logstr, 0) ! - ok = check_file_exists(srcfile, 'River input locations src file', .true.) + ok = check_file_exists(srcfile, 'River input locations src file', .true.) ! open(500, file=trim(srcfile)) - do while(.true.) - read(500,*,iostat = stat)dummy + do while (.true.) + read(500, *, iostat=stat) dummy if (stat < 0) exit nsrc = nsrc + 1 enddo rewind(500) ! - elseif (netsrcdisfile(1:4) /= 'none') then ! FEWS compatible Netcdf discharge time-series input + elseif (netsrcdisfile(1:4) /= 'none') then ! FEWS-compatible NetCDF discharge time series ! - ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) + ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) ! - call read_netcdf_discharge_data() ! reads nsrc, ntsrc, xsrc, ysrc, qsrc, and tsrc + call read_netcdf_discharge_data() ! sets nsrc, ntsrc, xsrc, ysrc, qsrc_ts, tsrc ! if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then - ! - write(logstr,'(a)')' WARNING! Times in discharge file do not cover entire simulation period!' + write(logstr,'(a)') ' WARNING! Times in discharge file do not cover entire simulation period!' call write_log(logstr, 1) - ! - endif - ! - endif - ! - if (drnfile(1:4) /= 'none') then + endif ! - write(logstr,'(a)')'Info : reading drainage file' - call write_log(logstr, 0) - ! - ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) - ! - open(501, file=trim(drnfile)) - do while(.true.) - read(501,*,iostat = stat)dummy - if (stat < 0) exit - ndrn = ndrn + 1 - enddo - rewind(501) endif ! - nsrcdrn = nsrc + 2 * ndrn + if (nsrc <= 0) return ! - if (nsrcdrn > 0) then - allocate(nmindsrc(nsrcdrn)) - allocate(qtsrc(nsrcdrn)) - nmindsrc = 0 - qtsrc = 0.0 - endif + allocate(nmindsrc(nsrc)) + allocate(qtsrc(nsrc)) + nmindsrc = 0 + qtsrc = 0.0 + ! + ! --- Read src/dis contents for the srcfile case --------------------- ! if (srcfile(1:4) /= 'none') then - ! - ! Actually read src and dis files ! allocate(xsrc(nsrc)) allocate(ysrc(nsrc)) ! do n = 1, nsrc - read(500,*)xsrc(n), ysrc(n) + read(500, *) xsrc(n), ysrc(n) enddo close(500) ! ! Read discharge time series ! - ok = check_file_exists(disfile, 'River discharge timeseries dis file', .true.) - ! + ok = check_file_exists(disfile, 'River discharge timeseries dis file', .true.) + ! open(502, file=trim(disfile)) - do while(.true.) - read(502,*,iostat = stat)dummy + do while (.true.) + read(502, *, iostat=stat) dummy if (stat < 0) exit ntsrc = ntsrc + 1 enddo rewind(502) allocate(tsrc(ntsrc)) - allocate(qsrc(nsrc,ntsrc)) + allocate(qsrc_ts(nsrc, ntsrc)) do itsrc = 1, ntsrc - read(502,*)tsrc(itsrc), (qsrc(isrc, itsrc), isrc = 1, nsrc) + read(502, *) tsrc(itsrc), (qsrc_ts(isrc, itsrc), isrc = 1, nsrc) enddo close(502) ! if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then - ! - write(logstr,'(a)')'Warning! Times in discharge file do not cover entire simulation period !' + ! + write(logstr,'(a)') 'Warning! Times in discharge file do not cover entire simulation period !' call write_log(logstr, 1) ! if (tsrc(1) > (t0 + 1.0)) then - ! - write(logstr,'(a)')'Warning! Adjusting first time in discharge time series !' + write(logstr,'(a)') 'Warning! Adjusting first time in discharge time series !' call write_log(logstr, 1) - ! tsrc(1) = t0 - 1.0 - ! else - ! - write(logstr,'(a)')'Warning! Adjusting last time in discharge time series !' + write(logstr,'(a)') 'Warning! Adjusting last time in discharge time series !' call write_log(logstr, 1) - ! tsrc(ntsrc) = t1 + 1.0 - ! endif ! - endif + endif ! - endif - ! - if (nsrc > 0) then - ! - ! Determine m and n indices of sources - ! - do isrc = 1, nsrc - ! - ! Find cell in quadtree first - ! - nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) - ! - if (nmq > 0) then - ! - nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) - ! - endif - ! - enddo - ! - ! Don't need coordinates anymore, and xsrc and ysrc may be used for drainage points as well - ! - deallocate(xsrc) - deallocate(ysrc) - ! - endif + endif ! - ! And now the drainage points + ! --- Map river sources to grid cells -------------------------------- ! - if (ndrn>0) then - ! - write(logstr,'(a,a,a,i0,a)')' Reading ',trim(drnfile),' (', ndrn, ' drainage points found) ...' - call write_log(logstr, 0) - ! - allocate(xsrc(ndrn)) - allocate(ysrc(ndrn)) - allocate(xsnk(ndrn)) - allocate(ysnk(ndrn)) - ! - allocate(drainage_type(ndrn)) - allocate(drainage_params(ndrn, 6)) - allocate(drainage_status(ndrn)) - allocate(drainage_distance(ndrn)) - allocate(drainage_fraction_open(ndrn)) - ! - drainage_params = 0.0 - drainage_distance = 0.0 - drainage_fraction_open = 1.0 ! initially fully open (should fix this based on zmin and zmax in params) - drainage_status = 1 ! open (0=closed, 1=open, 2=closing, 3=opening) - ! - do idrn = 1, ndrn - ! - read(501, '(a)') drainage_line - ! - ! First find out what type of drainage structure it is (integer 5th item in line) - ! - read(drainage_line,*,iostat=stat)xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp, drainage_type(idrn) - ! - npars = 0 ! Default (if npars stays 0, throw error) - ! - if (drainage_type(idrn) == 1 .or. drainage_type(idrn) == 2 .or. drainage_type(idrn) == 3) then - ! - ! Pump, culvert or check valve (1 parameter) - ! - npars = 1 - ! - elseif (drainage_type(idrn) == 4 .or. drainage_type(idrn) == 5) then - ! - ! Controlled gate (6 parameters : width, sill elevation, manning, zmin, zmax, closing time) - ! - npars = 6 - ! - endif - ! - if (npars == 0) then - ! - write(logstr,'(a,i0,a)')'Drainage type ', drainage_type(idrn), ' not recognized !' - call stop_sfincs(logstr, -1) - ! - endif - ! - if (npars == 1) then - ! - ! Pump, culvert or check valve - ! - read(drainage_line,*,iostat=stat)xsnk(idrn), ysnk(idrn), xsrc(idrn), ysrc(idrn), drainage_type(idrn), drainage_params(idrn,1) - ! - elseif (npars == 6) then - ! - ! Controlled gate, needs 6 parameters - ! - read(drainage_line,*,iostat=stat)xsnk(idrn), ysnk(idrn), xsrc(idrn), ysrc(idrn), drainage_type(idrn), drainage_params(idrn,1), drainage_params(idrn,2), drainage_params(idrn,3), drainage_params(idrn,4), drainage_params(idrn,5), drainage_params(idrn,6) - ! - endif - ! - if (stat /= 0) then - ! - write(logstr,'(a,i0,a,i0,a)')'Drainage type ', drainage_type(idrn), ' requires ', npars, ' parameters !' - call stop_sfincs(logstr, -1) - ! - endif - ! - enddo + do isrc = 1, nsrc ! - close(501) + nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) + if (nmq > 0) then + nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) + endif ! - ! Determine nm indices of source and sinks - ! - do idrn = 1, ndrn - ! - ! Determine index of sink first - ! - j = nsrc + idrn*2 - 1 - ! - nmq = find_quadtree_cell(xsnk(idrn), ysnk(idrn)) - ! - if (nmq > 0) then - ! - nmindsrc(j) = index_sfincs_in_quadtree(nmq) - ! - endif - ! - ! And now the index of the source - ! - j = nsrc + idrn * 2 - ! - nmq = find_quadtree_cell(xsrc(idrn), ysrc(idrn)) - ! - if (nmq > 0) then - ! - nmindsrc(j) = index_sfincs_in_quadtree(nmq) - ! - endif - ! - ! Get coords of source and sink points, and compute distance between them - ! This is needed for controlled gates (type 4) - ! - xsnk_tmp = z_xz(nmindsrc(nsrc + idrn * 2 - 1)) - ysnk_tmp = z_yz(nmindsrc(nsrc + idrn * 2 - 1)) - xsrc_tmp = z_xz(nmindsrc(nsrc + idrn * 2)) - ysrc_tmp = z_yz(nmindsrc(nsrc + idrn * 2)) - ! - drainage_distance(idrn) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) - ! - enddo - ! - deallocate(xsrc) - deallocate(ysrc) - deallocate(xsnk) - deallocate(ysnk) - ! - ! Check if all sink/source points have found an index - if (any(nmindsrc == 0)) then - ! - write(logstr,'(a)')'Warning ! For some sink/source drainage points no matching active grid cell was found!' - call write_log(logstr, 0) - write(logstr,'(a)')'Warning ! These points will be skipped, please check your input!' - call write_log(logstr, 0) - ! - endif - ! - endif + enddo ! - end subroutine + deallocate(xsrc) + deallocate(ysrc) ! + end subroutine ! ! subroutine update_discharges(t, dt, tloop) ! - ! Update discharges + ! Zero qsrc(np); interpolate the river discharge time series to t, + ! store in qtsrc(1..nsrc), and accumulate into qsrc(nmindsrc(:)). + ! + ! update_discharges is called BEFORE update_src_structures -- that is + ! why it owns the qsrc zeroing. Both routines then additively write + ! their contributions. ! use sfincs_data ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop + real*8 :: t + real*4 :: dt + real :: tloop ! - real*8 :: t - real*4 :: dt - real*4 :: qq - real*4 :: qq0 - ! - real*4 :: dzds, frac, wdt, zsill, zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose - integer :: idir - ! - integer isrc, itsrc, idrn, jin, jout, nmin, nmout + integer :: count0, count1, count_rate, count_max + integer :: isrc, itsrc, nm ! call system_clock(count0, count_rate, count_max) ! - ! Compute instantaneous discharges from point sources + ! Zero qsrc for this step. sfincs_src_structures will add to it next. + ! + !$acc kernels present( qsrc ) + qsrc = 0.0 + !$acc end kernels ! if (nsrc > 0) then + ! do itsrc = itsrclast, ntsrc - ! Find first point in time series large than t if (tsrc(itsrc) > t) then do isrc = 1, nsrc - qtsrc(isrc) = qsrc(isrc, itsrc - 1) + (qsrc(isrc, itsrc) - qsrc(isrc, itsrc - 1)) * (t - tsrc(itsrc - 1)) / (tsrc(itsrc) - tsrc(itsrc - 1)) + qtsrc(isrc) = qsrc_ts(isrc, itsrc - 1) & + + (qsrc_ts(isrc, itsrc) - qsrc_ts(isrc, itsrc - 1)) & + * (t - tsrc(itsrc - 1)) / (tsrc(itsrc) - tsrc(itsrc - 1)) enddo itsrclast = itsrc - 1 exit @@ -352,291 +181,21 @@ subroutine update_discharges(t, dt, tloop) ! !$acc update device(qtsrc) ! - endif - ! - if (ndrn > 0) then + ! Accumulate river sources into the cell-wise qsrc. Atomic because + ! two river sources (or a river and a structure) can share a cell. ! - !$acc serial, present( z_volume, zs, zb, nmindsrc, qtsrc, drainage_type, drainage_params ) - do idrn = 1, ndrn - ! - jin = nsrc + idrn * 2 - 1 - jout = nsrc + idrn * 2 - ! - nmin = nmindsrc(jin) - nmout = nmindsrc(jout) - ! - if (nmin > 0 .and. nmout > 0) then - ! - select case(drainage_type(idrn)) - ! - case(1) - ! - ! Pump - ! - qq = drainage_params(idrn, 1) - ! - case(2) - ! - ! Culvert - ! - if (zs(nmin)>zs(nmout)) then - ! - qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) - ! - else - ! - qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) - ! - endif - ! - case(3) - ! - ! Check valve (same as culvert, but only works in one direction) - ! - if (zs(nmin) > zs(nmout)) then - ! - qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) - ! - else - ! - qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) - ! - endif - ! - ! Make sure it can only flow from intake to outfall point - ! - qq = max(qq, 0.0) - ! - case(4) - ! - ! Controlled gate. Gate opens when water level at intake point is between zmin and zmax. - ! - wdt = drainage_params(idrn, 1) ! width - zsill = drainage_params(idrn, 2) ! sill elevation - mng = drainage_params(idrn, 3) ! Manning's n - zmin = drainage_params(idrn, 4) ! min water level for open - zmax = drainage_params(idrn, 5) ! max water level for open - tcls = drainage_params(idrn, 6) ! closing time (seconds) - ! - dzds = (zs(nmout) - zs(nmin)) / drainage_distance(idrn) ! water level slope - frac = drainage_fraction_open(idrn) ! fraction open (from previous time step) - hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) ! water depth - dfrac = dt / tcls ! change in fraction open per time step - ! - qq0 = -qtsrc(jin) / (wdt * max(frac, 0.001)) ! discharge (in m2/s) from previous time step, excluding fraction open - ! - ! Get status of gate - ! - if (drainage_status(idrn) == 0) then - ! - ! Gate fully closed - ! - if (zs(nmin) > zmin .and. zs(nmin) < zmax) then - ! - ! Water level is in allowable range, so need to open the gate - ! - drainage_status(idrn) = 3 - ! - ! Lines below only work with Windows intel compiler, can be used for debugging - ! - ! Actual discharges through drainage structure can always be checked if 'storeqdrain=1' in sfincs.inp - ! - !write(logstr,'(a,i0,a,f0.1)')'INFO Gates - Opening structure ',idrn,' at t= ',t - !call write_log(logstr, 0) - ! - endif - ! - elseif (drainage_status(idrn) == 1) then - ! - ! Gate fully open - ! - if (zs(nmin) <= zmin .or. zs(nmin) >= zmax) then - ! - ! Water level is NOT in allowable range, so need to close the gate - ! - drainage_status(idrn) = 2 - ! - !write(logstr,'(a,i0,a,f0.1)')'INFO Gates - Closing structure ',idrn,' at t= ',t - !call write_log(logstr, 0) - ! - endif - ! - endif - ! - ! Update fraction open - ! - if (drainage_status(idrn) == 2) then - ! - ! Gate is closing - ! - frac = frac - dfrac - ! - if (frac < 0.0) then - ! - ! Gate is now fully closed - ! - frac = 0.0 - drainage_status(idrn) = 0 - ! - endif - ! - elseif (drainage_status(idrn) == 3) then - ! - ! Gate is opening - ! - frac = frac + dfrac - ! - if (frac > 1.0) then - ! - ! Gate is now fully open - ! - frac = 1.0 - drainage_status(idrn) = 1 - ! - endif - ! - endif - ! - drainage_fraction_open(idrn) = frac - ! - ! Use Bates et al. (2010) formulation to include inertia effects - ! - qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) - ! - ! Multiply with width and fraction open to get discharge in m3/s - ! - qq = qq * wdt * frac - ! - case(5) - ! - ! Controlled gate. Gate opens and closes at set user input times (only, and once), still using closing time. - ! - wdt = drainage_params(idrn, 1) ! width - zsill = drainage_params(idrn, 2) ! sill elevation - mng = drainage_params(idrn, 3) ! Manning's n - tclose = drainage_params(idrn, 4) ! time wrt tref for closing gate - topen = drainage_params(idrn, 5) ! time wrt tref for opening gate - tcls = drainage_params(idrn, 6) ! closing time (seconds) - ! - dzds = (zs(nmout) - zs(nmin)) / drainage_distance(idrn) ! water level slope - frac = drainage_fraction_open(idrn) ! fraction open (from previous time step) - hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) ! water depth - dfrac = dt / tcls ! change in fraction open per time step - ! - qq0 = -qtsrc(jin) / (wdt * max(frac, 0.001)) ! discharge (in m2/s) from previous time step, excluding fraction open - ! - ! Get status of gate - ! - if (drainage_status(idrn) == 0) then - ! - ! Gate fully closed - ! - if (t >= topen) then - ! - ! Time has passed 'topen', so need to open the gate - ! - drainage_status(idrn) = 3 - ! - !write(logstr,'(a,i0,a,f0.1)')'INFO Gates - Opening structure ',idrn,' at t= ',t - !call write_log(logstr, 0) - ! - endif - ! - elseif (drainage_status(idrn) == 1) then - ! - ! Gate fully open - ! - if (t >= tclose .and. t < topen) then - ! - ! Time has passed 'tclose', so need to close the gate - ! - drainage_status(idrn) = 2 - ! - !write(logstr,'(a,i0,a,f0.1)')'INFO Gates - Closing structure ',idrn,' at t= ',t - !call write_log(logstr, 0) - ! - endif - ! - endif - ! - ! Update fraction open - ! - if (drainage_status(idrn) == 2) then - ! - ! Gate is closing - ! - frac = frac - dfrac - ! - if (frac < 0.0) then - ! - ! Gate is now fully closed - ! - frac = 0.0 - drainage_status(idrn) = 0 - ! - endif - ! - elseif (drainage_status(idrn) == 3) then - ! - ! Gate is opening - ! - frac = frac + dfrac - ! - if (frac > 1.0) then - ! - ! Gate is now fully open - ! - frac = 1.0 - drainage_status(idrn) = 1 - ! - endif - ! - endif - ! - drainage_fraction_open(idrn) = frac - ! - ! Use Bates et al. (2010) formulation to include inertia effects - ! - qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) - ! - ! Multiply with width and fraction open to get discharge in m3/s - ! - qq = qq * wdt * frac - ! - end select - ! - ! Add some relaxation - ! structure_relax in seconds => gives ratio between new and old discharge (default 10s) - ! - qq = 1.0 / (structure_relax / dt) * qq + (1.0 - (1.0 / (structure_relax / dt))) * -qtsrc(jin) - ! - ! Limit discharge based on available volume in cell (regular or subgrid) - ! - if (subgrid) then - ! - if (qq > 0.0) then - qq = min(qq, max(z_volume(nmin), 0.0) / dt) - else - qq = max(qq, -max(z_volume(nmout), 0.0) / dt) - endif - ! - else - ! - if (qq > 0.0) then - qq = min(qq, max((zs(nmin) - zb(nmin)) * cell_area(z_flags_iref(nmin)), 0.0) / dt) - else - qq = max(qq, -max((zs(nmout) - zb(nmout)) * cell_area(z_flags_iref(nmout)), 0.0) / dt) - endif - ! - endif - ! - qtsrc(jin) = -qq - qtsrc(jout) = qq - ! + !$acc parallel loop present( qsrc, qtsrc, nmindsrc ) private( nm ) + !$omp parallel do private( nm ) schedule ( static ) + do isrc = 1, nsrc + nm = nmindsrc(isrc) + if (nm > 0) then + !$acc atomic update + !$omp atomic + qsrc(nm) = qsrc(nm) + qtsrc(isrc) endif - ! enddo - !$acc end serial + !$omp end parallel do + !$acc end parallel loop ! endif ! diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 65bd1015e..e47863fe8 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -2199,12 +2199,18 @@ subroutine initialize_hydro() allocate(uv0(npuv + ncuv + 1)) ! allocate(kfuv(npuv)) - ! - zs = 0.0 - q = 0.0 - q0 = 0.0 - uv = 0.0 - uv0 = 0.0 + ! + ! Cell-wise discharge accumulator (point sources + drainage structures), + ! read by sfincs_continuity. + ! + allocate(qsrc(np)) + ! + zs = 0.0 + q = 0.0 + q0 = 0.0 + uv = 0.0 + uv0 = 0.0 + qsrc = 0.0 ! kfuv = 0 ! diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index ca3441bf4..8c6b54e9a 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -11,6 +11,7 @@ module sfincs_lib use sfincs_crosssections use sfincs_runup_gauges use sfincs_discharges + use sfincs_src_structures use sfincs_meteo use sfincs_infiltration use sfincs_data @@ -165,7 +166,9 @@ function sfincs_initialize() result(ierr) ! call read_rug_file() ! Read runup gauge file ! - call read_discharges() ! Reads dis and src file + call initialize_discharges() ! Reads dis and src file (river point discharges) + ! + call initialize_src_structures() ! Reads drn file (pumps / culverts / check valves / gates) ! if (nonhydrostatic) then ! @@ -545,9 +548,10 @@ function sfincs_update(dtrange) result(ierr) ! call update_boundaries(t, dt, tloopbnd) ! - ! Update discharges + ! Update discharges (river sources) and src-point structures (pumps/gates/...) ! call update_discharges(t, dt, tloopsrc) + call update_src_structures(t, dt, tloopsrc) ! if (snapwave .and. update_waves) then ! diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index fa49e9b46..b56b13030 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -218,13 +218,13 @@ subroutine read_netcdf_discharge_data() allocate(xsrc(nsrc)) allocate(ysrc(nsrc)) allocate(tsrc(ntsrc)) - allocate(qsrc(nsrc,ntsrc)) + allocate(qsrc_ts(nsrc,ntsrc)) ! ! Read values NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%x_varid, xsrc(:)) ) NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%y_varid, ysrc(:)) ) - NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%time_varid, tsrc(:)) ) - NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%q_varid, qsrc(:,:)) ) + NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%time_varid, tsrc(:)) ) + NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%q_varid, qsrc_ts(:,:)) ) ! ! Read time attibute ! diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index e3a1895e1..951d61105 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -41,7 +41,7 @@ module sfincs_ncoutput integer :: ncid integer :: time_dimid integer :: points_dimid, pointnamelength_dimid - integer :: crosssections_dimid, structures_dimid, thindams_dimid, drain_dimid, runup_gauges_dimid + integer :: crosssections_dimid, structures_dimid, thindams_dimid, drain_dimid, runup_gauges_dimid, river_dimid integer :: runtime_dimid integer :: point_x_varid, point_y_varid, station_x_varid, station_y_varid, crs_varid, qinf_varid, S_varid integer :: station_id_varid, station_name_varid @@ -49,6 +49,7 @@ module sfincs_ncoutput integer :: structure_height_varid, structure_x_varid, structure_y_varid integer :: thindam_x_varid, thindam_y_varid integer :: drain_varid, drain_name_varid + integer :: river_varid integer :: zb_varid integer :: time_varid integer :: zs_varid, h_varid, u_varid, v_varid, prcp_varid, cumprcp_varid, discharge_varid, uvmag_varid, uvdir_varid @@ -1628,7 +1629,7 @@ subroutine ncoutput_his_init() real*4, dimension(:), allocatable :: thindam_x real*4, dimension(:), allocatable :: thindam_y ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. ndrn==0 .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains or run-up gauges; his file is not created + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. ndrn==0 .and. nsrc==0 .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources or run-up gauges; his file is not created return endif ! @@ -1648,10 +1649,14 @@ subroutine ncoutput_his_init() NF90(nf90_def_dim(his_file%ncid, 'crosssections', nrcrosssections, his_file%crosssections_dimid)) ! nr of crosssections endif ! - if (ndrn>0) then + if (ndrn>0) then NF90(nf90_def_dim(his_file%ncid, 'drainage', ndrn, his_file%drain_dimid)) ! nr of drainage structures endif ! + if (nsrc>0) then + NF90(nf90_def_dim(his_file%ncid, 'rivers', nsrc, his_file%river_dimid)) ! nr of river point sources + endif + ! if (nrstructures>0) then NF90(nf90_def_dim(his_file%ncid, 'structures', nrstructures, his_file%structures_dimid)) ! nr of structures (weir) endif @@ -2046,12 +2051,21 @@ subroutine ncoutput_his_init() if (ndrn>0) then ! NF90(nf90_def_var(his_file%ncid, 'drainage_discharge', NF90_FLOAT, (/his_file%drain_dimid, his_file%time_dimid/), his_file%drain_varid)) ! time-varying discharge through drainage structure - NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'units', 'm3 s-1')) NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'long_name', 'discharge through drainage structure')) NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'coordinates', 'drainage_name')) ! - endif + endif + ! + if (nsrc>0) then + ! + NF90(nf90_def_var(his_file%ncid, 'river_discharge', NF90_FLOAT, (/his_file%river_dimid, his_file%time_dimid/), his_file%river_varid)) ! time-varying river point discharge + NF90(nf90_put_att(his_file%ncid, his_file%river_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'units', 'm3 s-1')) + NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'long_name', 'river point discharge')) + ! + endif ! if (nr_runup_gauges > 0) then ! @@ -3032,7 +3046,6 @@ subroutine ncoutput_update_his(t,nthisout) real*4, dimension(nobs) :: tpigobs real*4, dimension(nobs) :: wavdirobs real*4, dimension(nobs) :: dirsprobs - real*4, dimension(ndrn) :: q_drain real*4, dimension(nobs) :: dwobs real*4, dimension(nobs) :: dfobs real*4, dimension(nobs) :: dwigobs @@ -3058,7 +3071,6 @@ subroutine ncoutput_update_his(t,nthisout) tpatm = FILL_VALUE twndmag = FILL_VALUE twnddir = FILL_VALUE - q_drain = FILL_VALUE dwobs = FILL_VALUE dfobs = FILL_VALUE cgobs = FILL_VALUE @@ -3297,18 +3309,19 @@ subroutine ncoutput_update_his(t,nthisout) endif ! if (ndrn>0) then + ! + !$acc update host(qdrain) + ! + NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, qdrain, (/1, nthisout/))) ! write per-structure discharge + ! + endif + ! + if (nsrc>0) then ! !$acc update host(qtsrc) - ! Get fluxes through drainage structure ! - idrn = 0 - do iobs = nsrc + 1, nsrcdrn, 2 !TL: as in sfincs_output.f90 - idrn = idrn + 1 - q_drain(idrn) = qtsrc(iobs) - enddo + NF90(nf90_put_var(his_file%ncid, his_file%river_varid, qtsrc, (/1, nthisout/))) ! write per-river-source discharge ! - NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, q_drain, (/1, nthisout/))) ! write discharge of sink point - ! endif ! if (store_velocity) then @@ -3894,7 +3907,7 @@ subroutine ncoutput_his_finalize() ! implicit none ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. ndrn==0) then ! If no observation points, cross-sections, structures 9weir or thin dam), or drains; hisfile + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. ndrn==0 .and. nsrc==0) then ! If no observation points, cross-sections, structures (weir or thin dam), drains or river sources; hisfile return endif ! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 857260203..3847cee7f 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -21,7 +21,7 @@ subroutine initialize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc nmindsrc, qtsrc, drainage_type, drainage_params, & + !$acc qsrc, qtsrc, qdrain, nmindsrc, nmindrn_in, nmindrn_out, drainage_type, drainage_params, drainage_distance, drainage_status, drainage_fraction_open, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & @@ -51,7 +51,7 @@ subroutine finalize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc nmindsrc, qtsrc, drainage_type, drainage_params, & + !$acc qsrc, qtsrc, qdrain, nmindsrc, nmindrn_in, nmindrn_out, drainage_type, drainage_params, drainage_distance, drainage_status, drainage_fraction_open, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & diff --git a/source/src/sfincs_output.f90 b/source/src/sfincs_output.f90 index f130bdd29..b4d8e5dbb 100644 --- a/source/src/sfincs_output.f90 +++ b/source/src/sfincs_output.f90 @@ -588,7 +588,11 @@ subroutine open_his_output() open(unit = 966, file = trim('qt.txt')) close(unit = 966 ,status='delete') endif - if (nsrcdrn>0) then + if (nsrc>0) then + open(unit = 969, file = trim('qriver.txt')) + close(unit = 969 ,status='delete') + endif + if (ndrn>0) then open(unit = 970, file = trim('qdrain.txt')) close(unit = 970 ,status='delete') endif @@ -653,10 +657,17 @@ subroutine write_his_output(t) ! endif ! - if (ndrn>0 .and. store_qdrain) then + if (nsrc>0) then !$acc update host(qtsrc) + open(unit = 969, file = trim('qriver.txt'), access='append') + write(969,'(f12.1,10000f9.3)')t,(qtsrc(iobs), iobs = 1, nsrc) + close(969) + endif + ! + if (ndrn>0 .and. store_qdrain) then + !$acc update host(qdrain) open(unit = 970, file = trim('qdrain.txt'), access='append') - write(970,'(f12.1,10000f9.3)')t,(qtsrc(iobs), iobs = nsrc + 1, nsrcdrn, 2) + write(970,'(f12.1,10000f9.3)')t,(qdrain(iobs), iobs = 1, ndrn) close(970) endif ! diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 new file mode 100644 index 000000000..3e3bc77a9 --- /dev/null +++ b/source/src/sfincs_src_structures.f90 @@ -0,0 +1,373 @@ +module sfincs_src_structures + ! + ! Point structures that move water between two grid cells by user-specified + ! rules rather than by momentum conservation: + ! type 1 - pump (fixed discharge) + ! type 2 - culvert (bidirectional, weir-like) + ! type 3 - check valve (unidirectional culvert) + ! type 4 - controlled gate, water-level triggered + ! type 5 - controlled gate, schedule triggered + ! + ! These used to live in sfincs_discharges.f90 alongside the river point + ! discharges read from src/dis/netsrcdis. They have been split out so that + ! each module has a single responsibility. + ! + ! Runtime handoff to the continuity module is via the cell-wise qsrc(np) + ! array (in sfincs_data): this module accumulates qq on intake (nmindrn_in) + ! and outfall (nmindrn_out) cells. Per-structure signed discharge is also + ! stored in qdrain(ndrn) for his output. + ! + ! Concurrency: qsrc updates use atomic because two structures (or a river + ! source and a structure) can land in the same cell. + ! + use sfincs_log + use sfincs_error + +contains + ! + subroutine initialize_src_structures() + ! + ! Parse drnfile and populate drainage_type/_params/_status/_distance/ + ! _fraction_open, nmindrn_in(ndrn), nmindrn_out(ndrn), and the output + ! buffer qdrain(ndrn). + ! + use sfincs_data + use quadtree + ! + implicit none + ! + real*4, dimension(:), allocatable :: xsrc_drn, ysrc_drn + real*4, dimension(:), allocatable :: xsnk, ysnk + real*4 :: dummy, xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp + integer :: idrn, nmq, stat, npars + logical :: ok + character(len=256) :: drainage_line + ! + ndrn = 0 + ! + if (drnfile(1:4) == 'none') return + ! + ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) + ! + ! Count lines + ! + open(501, file=trim(drnfile)) + do while (.true.) + read(501, *, iostat=stat) dummy + if (stat < 0) exit + ndrn = ndrn + 1 + enddo + rewind(501) + ! + if (ndrn <= 0) then + close(501) + return + endif + ! + write(logstr,'(a,a,a,i0,a)')' Reading ', trim(drnfile), ' (', ndrn, ' drainage points found) ...' + call write_log(logstr, 0) + ! + allocate(xsrc_drn(ndrn)) + allocate(ysrc_drn(ndrn)) + allocate(xsnk(ndrn)) + allocate(ysnk(ndrn)) + ! + allocate(nmindrn_in(ndrn)) + allocate(nmindrn_out(ndrn)) + allocate(qdrain(ndrn)) + allocate(drainage_type(ndrn)) + allocate(drainage_params(ndrn, 6)) + allocate(drainage_status(ndrn)) + allocate(drainage_distance(ndrn)) + allocate(drainage_fraction_open(ndrn)) + ! + nmindrn_in = 0 + nmindrn_out = 0 + qdrain = 0.0 + drainage_params = 0.0 + drainage_distance = 0.0 + drainage_fraction_open = 1.0 ! initially fully open (could be refined from zmin/zmax) + drainage_status = 1 ! 0=closed, 1=open, 2=closing, 3=opening + ! + do idrn = 1, ndrn + ! + read(501, '(a)') drainage_line + ! + ! Determine drainage type first (5th integer in the line) + ! + read(drainage_line, *, iostat=stat) xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp, drainage_type(idrn) + ! + npars = 0 + ! + if (drainage_type(idrn) == 1 .or. drainage_type(idrn) == 2 .or. drainage_type(idrn) == 3) then + npars = 1 ! pump, culvert, or check valve + elseif (drainage_type(idrn) == 4 .or. drainage_type(idrn) == 5) then + npars = 6 ! controlled gate (width, sill, manning, zmin/tclose, zmax/topen, closing time) + endif + ! + if (npars == 0) then + write(logstr,'(a,i0,a)') 'Drainage type ', drainage_type(idrn), ' not recognized !' + call stop_sfincs(logstr, -1) + endif + ! + if (npars == 1) then + read(drainage_line, *, iostat=stat) xsnk(idrn), ysnk(idrn), xsrc_drn(idrn), ysrc_drn(idrn), & + drainage_type(idrn), drainage_params(idrn, 1) + elseif (npars == 6) then + read(drainage_line, *, iostat=stat) xsnk(idrn), ysnk(idrn), xsrc_drn(idrn), ysrc_drn(idrn), & + drainage_type(idrn), drainage_params(idrn, 1), drainage_params(idrn, 2), & + drainage_params(idrn, 3), drainage_params(idrn, 4), drainage_params(idrn, 5), & + drainage_params(idrn, 6) + endif + ! + if (stat /= 0) then + write(logstr,'(a,i0,a,i0,a)') 'Drainage type ', drainage_type(idrn), ' requires ', npars, ' parameters !' + call stop_sfincs(logstr, -1) + endif + ! + enddo + ! + close(501) + ! + ! Map intake / outfall points to cell indices and compute centre-to-centre + ! distance (needed by controlled-gate types 4 and 5). + ! + do idrn = 1, ndrn + ! + nmq = find_quadtree_cell(xsnk(idrn), ysnk(idrn)) + if (nmq > 0) nmindrn_in(idrn) = index_sfincs_in_quadtree(nmq) + ! + nmq = find_quadtree_cell(xsrc_drn(idrn), ysrc_drn(idrn)) + if (nmq > 0) nmindrn_out(idrn) = index_sfincs_in_quadtree(nmq) + ! + if (nmindrn_in(idrn) > 0 .and. nmindrn_out(idrn) > 0) then + xsnk_tmp = z_xz(nmindrn_in(idrn)) + ysnk_tmp = z_yz(nmindrn_in(idrn)) + xsrc_tmp = z_xz(nmindrn_out(idrn)) + ysrc_tmp = z_yz(nmindrn_out(idrn)) + drainage_distance(idrn) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + endif + ! + enddo + ! + deallocate(xsrc_drn) + deallocate(ysrc_drn) + deallocate(xsnk) + deallocate(ysnk) + ! + if (any(nmindrn_in == 0) .or. any(nmindrn_out == 0)) then + write(logstr,'(a)') 'Warning ! For some sink/source drainage points no matching active grid cell was found!' + call write_log(logstr, 0) + write(logstr,'(a)') 'Warning ! These points will be skipped, please check your input!' + call write_log(logstr, 0) + endif + ! + end subroutine + ! + ! + subroutine update_src_structures(t, dt, tloop) + ! + ! Compute discharges through each drainage structure, accumulate them + ! into qsrc(np) (intake: -qq, outfall: +qq), and store per-structure + ! signed discharge in qdrain(ndrn) for his output. + ! + ! Called AFTER update_discharges, which zeros qsrc first. + ! + ! Atomic updates on qsrc(nm) guard against two structures (or a river + ! and a structure) writing to the same cell under parallel execution. + ! + use sfincs_data + ! + implicit none + ! + real*8 :: t + real*4 :: dt + real :: tloop + ! + integer :: count0, count1, count_rate, count_max + integer :: idrn, nmin, nmout + real*4 :: qq, qq0 + real*4 :: dzds, frac, wdt, zsill, zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose + ! + if (ndrn <= 0) return + ! + call system_clock(count0, count_rate, count_max) + ! + !$acc parallel loop present( z_volume, zs, zb, qsrc, qdrain, & + !$acc nmindrn_in, nmindrn_out, & + !$acc drainage_type, drainage_params, & + !$acc drainage_distance, drainage_status, drainage_fraction_open ) & + !$acc private( nmin, nmout, qq, qq0, dzds, frac, wdt, zsill, & + !$acc zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ) + !$omp parallel do & + !$omp private( nmin, nmout, qq, qq0, dzds, frac, wdt, zsill, & + !$omp zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ) & + !$omp schedule ( static ) + do idrn = 1, ndrn + ! + nmin = nmindrn_in(idrn) + nmout = nmindrn_out(idrn) + ! + if (nmin > 0 .and. nmout > 0) then + ! + select case(drainage_type(idrn)) + ! + case(1) + ! + ! Pump + ! + qq = drainage_params(idrn, 1) + ! + case(2) + ! + ! Culvert (bidirectional) + ! + if (zs(nmin) > zs(nmout)) then + qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) + else + qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) + endif + ! + case(3) + ! + ! Check valve (culvert, but flow only from intake to outfall) + ! + if (zs(nmin) > zs(nmout)) then + qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) + else + qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) + endif + qq = max(qq, 0.0) + ! + case(4) + ! + ! Controlled gate - opens when intake water level is between zmin and zmax. + ! + wdt = drainage_params(idrn, 1) ! width + zsill = drainage_params(idrn, 2) ! sill elevation + mng = drainage_params(idrn, 3) ! Manning's n + zmin = drainage_params(idrn, 4) ! min water level for open + zmax = drainage_params(idrn, 5) ! max water level for open + tcls = drainage_params(idrn, 6) ! closing time (s) + ! + dzds = (zs(nmout) - zs(nmin)) / drainage_distance(idrn) + frac = drainage_fraction_open(idrn) + hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) + dfrac = dt / tcls + ! + qq0 = qdrain(idrn) / (wdt * max(frac, 0.001)) ! previous discharge per unit width, ignoring fraction + ! + if (drainage_status(idrn) == 0) then + if (zs(nmin) > zmin .and. zs(nmin) < zmax) drainage_status(idrn) = 3 + elseif (drainage_status(idrn) == 1) then + if (zs(nmin) <= zmin .or. zs(nmin) >= zmax) drainage_status(idrn) = 2 + endif + ! + if (drainage_status(idrn) == 2) then + frac = frac - dfrac + if (frac < 0.0) then + frac = 0.0 + drainage_status(idrn) = 0 + endif + elseif (drainage_status(idrn) == 3) then + frac = frac + dfrac + if (frac > 1.0) then + frac = 1.0 + drainage_status(idrn) = 1 + endif + endif + ! + drainage_fraction_open(idrn) = frac + ! + qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) + qq = qq * wdt * frac + ! + case(5) + ! + ! Controlled gate - schedule triggered (one open/close window). + ! + wdt = drainage_params(idrn, 1) ! width + zsill = drainage_params(idrn, 2) ! sill elevation + mng = drainage_params(idrn, 3) ! Manning's n + tclose = drainage_params(idrn, 4) ! time wrt tref to close + topen = drainage_params(idrn, 5) ! time wrt tref to open + tcls = drainage_params(idrn, 6) ! closing time (s) + ! + dzds = (zs(nmout) - zs(nmin)) / drainage_distance(idrn) + frac = drainage_fraction_open(idrn) + hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) + dfrac = dt / tcls + ! + qq0 = qdrain(idrn) / (wdt * max(frac, 0.001)) + ! + if (drainage_status(idrn) == 0) then + if (t >= topen) drainage_status(idrn) = 3 + elseif (drainage_status(idrn) == 1) then + if (t >= tclose .and. t < topen) drainage_status(idrn) = 2 + endif + ! + if (drainage_status(idrn) == 2) then + frac = frac - dfrac + if (frac < 0.0) then + frac = 0.0 + drainage_status(idrn) = 0 + endif + elseif (drainage_status(idrn) == 3) then + frac = frac + dfrac + if (frac > 1.0) then + frac = 1.0 + drainage_status(idrn) = 1 + endif + endif + ! + drainage_fraction_open(idrn) = frac + ! + qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) + qq = qq * wdt * frac + ! + end select + ! + ! Relaxation: blend new and previous discharge to damp oscillations. + ! + qq = 1.0 / (structure_relax / dt) * qq + (1.0 - (1.0 / (structure_relax / dt))) * qdrain(idrn) + ! + ! Limit discharge by available volume in the intake / outfall cell. + ! + if (subgrid) then + if (qq > 0.0) then + qq = min(qq, max(z_volume(nmin), 0.0) / dt) + else + qq = max(qq, -max(z_volume(nmout), 0.0) / dt) + endif + else + if (qq > 0.0) then + qq = min(qq, max((zs(nmin) - zb(nmin)) * cell_area(z_flags_iref(nmin)), 0.0) / dt) + else + qq = max(qq, -max((zs(nmout) - zb(nmout)) * cell_area(z_flags_iref(nmout)), 0.0) / dt) + endif + endif + ! + qdrain(idrn) = qq + ! + ! Accumulate into cell-wise qsrc. Atomic guards against multiple + ! structures (or a river and a structure) in the same cell. + ! + !$acc atomic update + !$omp atomic + qsrc(nmin) = qsrc(nmin) - qq + !$acc atomic update + !$omp atomic + qsrc(nmout) = qsrc(nmout) + qq + ! + endif + ! + enddo + !$omp end parallel do + !$acc end parallel loop + ! + call system_clock(count1, count_rate, count_max) + tloop = tloop + 1.0 * (count1 - count0) / count_rate + ! + end subroutine + +end module From 1831c3cdec74845c44f37228b1f87cf1186fb29d Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Thu, 16 Apr 2026 13:49:46 +0200 Subject: [PATCH 21/65] Add optional river discharge output and interpolation Introduce a new logical flag store_river_discharge and wire it into input parsing (.claude added to .gitignore). Guard NetCDF history-file creation, river dimension/variable definition, and river output on this flag so river sources are only recorded when requested. Refactor river-source time interpolation in sfincs_discharges: locate the bracketing interval once, compute an interpolation weight (wt) and use it inside a single parallel loop (added it_prev, it_next, wt) to compute qtsrc per source before atomic accumulation; reduce device/data handling and improve parallel efficiency. Minor bookkeeping adjustments to variable lists for OpenACC/OpenMP loops. --- .gitignore | 3 +++ source/src/sfincs_data.f90 | 1 + source/src/sfincs_discharges.f90 | 29 +++++++++++++++++------------ source/src/sfincs_input.f90 | 1 + source/src/sfincs_ncoutput.F90 | 10 +++++----- 5 files changed, 27 insertions(+), 17 deletions(-) diff --git a/.gitignore b/.gitignore index 22752d026..bfe26a593 100644 --- a/.gitignore +++ b/.gitignore @@ -65,3 +65,6 @@ source/third_party_open/netcdf/x64 source/sfincs/sfincs.opt.yaml /source/sfincs_lib/*.yaml /source/third_party_open/netcdf/netcdf-fortran-4.6.1/Debug + +# Local Claude Code agents / settings (not shared with co-developers) +.claude/ diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 4d30ec807..a1685dd9c 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -204,6 +204,7 @@ module sfincs_data logical :: store_hsubgrid logical :: store_hmean logical :: store_qdrain + logical :: store_river_discharge logical :: store_zvolume logical :: store_storagevolume logical :: store_meteo diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index 45f364838..2e0b109bf 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -155,7 +155,8 @@ subroutine update_discharges(t, dt, tloop) real :: tloop ! integer :: count0, count1, count_rate, count_max - integer :: isrc, itsrc, nm + integer :: isrc, itsrc, nm, it_prev, it_next + real*4 :: wt ! call system_clock(count0, count_rate, count_max) ! @@ -167,26 +168,30 @@ subroutine update_discharges(t, dt, tloop) ! if (nsrc > 0) then ! + ! Locate the bracketing interval in tsrc and compute the interpolation + ! weight once. Then run a single parallel loop that both interpolates + ! qtsrc and accumulates it into qsrc. + ! + it_prev = itsrclast + it_next = itsrclast + 1 do itsrc = itsrclast, ntsrc if (tsrc(itsrc) > t) then - do isrc = 1, nsrc - qtsrc(isrc) = qsrc_ts(isrc, itsrc - 1) & - + (qsrc_ts(isrc, itsrc) - qsrc_ts(isrc, itsrc - 1)) & - * (t - tsrc(itsrc - 1)) / (tsrc(itsrc) - tsrc(itsrc - 1)) - enddo - itsrclast = itsrc - 1 + it_prev = itsrc - 1 + it_next = itsrc + itsrclast = it_prev exit endif enddo + wt = (t - tsrc(it_prev)) / (tsrc(it_next) - tsrc(it_prev)) ! - !$acc update device(qtsrc) - ! - ! Accumulate river sources into the cell-wise qsrc. Atomic because - ! two river sources (or a river and a structure) can share a cell. + ! Atomic accumulation because two river sources (or a river and a + ! structure) can share a cell. ! - !$acc parallel loop present( qsrc, qtsrc, nmindsrc ) private( nm ) + !$acc parallel loop present( qsrc, qtsrc, nmindsrc, qsrc_ts ) private( nm ) !$omp parallel do private( nm ) schedule ( static ) do isrc = 1, nsrc + qtsrc(isrc) = qsrc_ts(isrc, it_prev) & + + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt nm = nmindsrc(isrc) if (nm > 0) then !$acc atomic update diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index efbad2e9a..014d308b9 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -283,6 +283,7 @@ subroutine read_sfincs_input() call read_real_input(500,'tsunami_arrival_threshold',tsunami_arrival_threshold,0.01) call read_logical_input(500,'timestep_analysis',timestep_analysis,.false.) call read_int_input(500,'storeqdrain',storeqdrain,1) + call read_logical_input(500,'store_river_discharge',store_river_discharge,.false.) call read_int_input(500,'storezvolume',storezvolume,0) call read_int_input(500,'storestoragevolume',storestoragevolume,0) call read_int_input(500,'writeruntime',wrttimeoutput,0) diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 951d61105..eb04a3213 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -1629,7 +1629,7 @@ subroutine ncoutput_his_init() real*4, dimension(:), allocatable :: thindam_x real*4, dimension(:), allocatable :: thindam_y ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. ndrn==0 .and. nsrc==0 .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources or run-up gauges; his file is not created + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. ndrn==0 .and. .not. (nsrc>0 .and. store_river_discharge) .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources (when store_river_discharge) or run-up gauges; his file is not created return endif ! @@ -1653,7 +1653,7 @@ subroutine ncoutput_his_init() NF90(nf90_def_dim(his_file%ncid, 'drainage', ndrn, his_file%drain_dimid)) ! nr of drainage structures endif ! - if (nsrc>0) then + if (nsrc>0 .and. store_river_discharge) then NF90(nf90_def_dim(his_file%ncid, 'rivers', nsrc, his_file%river_dimid)) ! nr of river point sources endif ! @@ -2058,7 +2058,7 @@ subroutine ncoutput_his_init() ! endif ! - if (nsrc>0) then + if (nsrc>0 .and. store_river_discharge) then ! NF90(nf90_def_var(his_file%ncid, 'river_discharge', NF90_FLOAT, (/his_file%river_dimid, his_file%time_dimid/), his_file%river_varid)) ! time-varying river point discharge NF90(nf90_put_att(his_file%ncid, his_file%river_varid, '_FillValue', FILL_VALUE)) @@ -3316,7 +3316,7 @@ subroutine ncoutput_update_his(t,nthisout) ! endif ! - if (nsrc>0) then + if (nsrc>0 .and. store_river_discharge) then ! !$acc update host(qtsrc) ! @@ -3907,7 +3907,7 @@ subroutine ncoutput_his_finalize() ! implicit none ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. ndrn==0 .and. nsrc==0) then ! If no observation points, cross-sections, structures (weir or thin dam), drains or river sources; hisfile + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. ndrn==0 .and. .not. (nsrc>0 .and. store_river_discharge)) then ! If no observation points, cross-sections, structures (weir or thin dam), drains or river sources (when store_river_discharge); hisfile return endif ! From d5abd8256967b18ffa209f2873f6b272fad309b6 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Thu, 16 Apr 2026 16:57:01 +0200 Subject: [PATCH 22/65] Add toml-f and TOML src_structure parsing Add the toml-f third-party TOML parser (sources and licenses) and wire it into the build (Makefile.am and Visual Studio .vfproj). Implement TOML-based parsing for src_structure inputs in sfincs_src_structures.f90: new types, constants, read_toml_src_structures routine, validation helpers and a dispatcher in initialize_src_structures() that probes for TOML and falls back to the legacy reader. Also include minor non-functional whitespace/formatting cleanups in sfincs_discharges.f90. --- source/sfincs_lib/sfincs_lib.vfproj | 37 + source/src/Makefile.am | 35 + source/src/sfincs_discharges.f90 | 41 +- source/src/sfincs_src_structures.f90 | 958 +++++++++- .../utils/toml-f/LICENSE-Apache | 202 +++ .../third_party_open/utils/toml-f/LICENSE-MIT | 7 + .../utils/toml-f/src/tomlf.f90 | 65 + .../utils/toml-f/src/tomlf/all.f90 | 29 + .../utils/toml-f/src/tomlf/build.f90 | 31 + .../toml-f/src/tomlf/build/build_array.f90 | 1323 ++++++++++++++ .../toml-f/src/tomlf/build/build_keyval.f90 | 589 ++++++ .../toml-f/src/tomlf/build/build_table.f90 | 1474 +++++++++++++++ .../utils/toml-f/src/tomlf/build/merge.f90 | 214 +++ .../utils/toml-f/src/tomlf/build/path.f90 | 802 +++++++++ .../utils/toml-f/src/tomlf/constants.f90 | 145 ++ .../utils/toml-f/src/tomlf/datetime.f90 | 352 ++++ .../utils/toml-f/src/tomlf/de.f90 | 161 ++ .../utils/toml-f/src/tomlf/de/abc.f90 | 126 ++ .../utils/toml-f/src/tomlf/de/context.f90 | 154 ++ .../utils/toml-f/src/tomlf/de/lexer.f90 | 1582 +++++++++++++++++ .../utils/toml-f/src/tomlf/de/parser.f90 | 862 +++++++++ .../utils/toml-f/src/tomlf/de/token.f90 | 163 ++ .../utils/toml-f/src/tomlf/diagnostic.f90 | 461 +++++ .../utils/toml-f/src/tomlf/error.f90 | 114 ++ .../utils/toml-f/src/tomlf/ser.f90 | 545 ++++++ .../utils/toml-f/src/tomlf/structure.f90 | 75 + .../toml-f/src/tomlf/structure/array_list.f90 | 209 +++ .../utils/toml-f/src/tomlf/structure/list.f90 | 141 ++ .../utils/toml-f/src/tomlf/structure/map.f90 | 132 ++ .../utils/toml-f/src/tomlf/structure/node.f90 | 79 + .../src/tomlf/structure/ordered_map.f90 | 240 +++ .../utils/toml-f/src/tomlf/terminal.f90 | 326 ++++ .../utils/toml-f/src/tomlf/type.f90 | 541 ++++++ .../utils/toml-f/src/tomlf/type/array.f90 | 225 +++ .../utils/toml-f/src/tomlf/type/keyval.f90 | 367 ++++ .../utils/toml-f/src/tomlf/type/table.f90 | 266 +++ .../utils/toml-f/src/tomlf/type/value.f90 | 162 ++ .../utils/toml-f/src/tomlf/utils.f90 | 260 +++ .../utils/toml-f/src/tomlf/utils/io.f90 | 90 + .../utils/toml-f/src/tomlf/utils/sort.f90 | 141 ++ .../utils/toml-f/src/tomlf/version.f90 | 74 + 41 files changed, 13794 insertions(+), 6 deletions(-) create mode 100644 source/third_party_open/utils/toml-f/LICENSE-Apache create mode 100644 source/third_party_open/utils/toml-f/LICENSE-MIT create mode 100644 source/third_party_open/utils/toml-f/src/tomlf.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/all.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/build.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/build/merge.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/build/path.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/constants.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/datetime.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/de.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/de/abc.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/de/context.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/de/parser.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/de/token.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/error.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/ser.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/structure.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/structure/list.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/structure/map.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/structure/node.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/terminal.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/type.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/type/array.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/type/table.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/type/value.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/utils.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/utils/io.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 create mode 100644 source/third_party_open/utils/toml-f/src/tomlf/version.f90 diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index e77d5d747..884aede9a 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -29,6 +29,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index c36927c0c..a3538a58c 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -15,6 +15,41 @@ lib_LTLIBRARIES = libsfincs.la #all sources for sfincs that go into the library (all but the program) libsfincs_la_SOURCES = \ + ../third_party_open/utils/toml-f/src/tomlf/constants.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/version.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de/token.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/utils/io.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/datetime.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/error.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/utils.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/type/value.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/terminal.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de/abc.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de/context.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/list.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/map.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/node.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/structure.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/type/array.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/type/table.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/type.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/ser.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de/parser.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/de.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/merge.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build/path.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/build.f90 \ + ../third_party_open/utils/toml-f/src/tomlf/all.f90 \ + ../third_party_open/utils/toml-f/src/tomlf.f90 \ sfincs_log.f90 \ sfincs_date.f90 \ sfincs_spiderweb.f90 \ diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index 2e0b109bf..367b0060e 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -13,7 +13,7 @@ module sfincs_discharges ! use sfincs_log use sfincs_error - + ! contains ! subroutine initialize_discharges() @@ -44,11 +44,15 @@ subroutine initialize_discharges() ok = check_file_exists(srcfile, 'River input locations src file', .true.) ! open(500, file=trim(srcfile)) + ! do while (.true.) + ! read(500, *, iostat=stat) dummy if (stat < 0) exit nsrc = nsrc + 1 + ! enddo + ! rewind(500) ! elseif (netsrcdisfile(1:4) /= 'none') then ! FEWS-compatible NetCDF discharge time series @@ -58,8 +62,10 @@ subroutine initialize_discharges() call read_netcdf_discharge_data() ! sets nsrc, ntsrc, xsrc, ysrc, qsrc_ts, tsrc ! if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then + ! write(logstr,'(a)') ' WARNING! Times in discharge file do not cover entire simulation period!' call write_log(logstr, 1) + ! endif ! endif @@ -68,6 +74,7 @@ subroutine initialize_discharges() ! allocate(nmindsrc(nsrc)) allocate(qtsrc(nsrc)) + ! nmindsrc = 0 qtsrc = 0.0 ! @@ -79,8 +86,11 @@ subroutine initialize_discharges() allocate(ysrc(nsrc)) ! do n = 1, nsrc + ! read(500, *) xsrc(n), ysrc(n) + ! enddo + ! close(500) ! ! Read discharge time series @@ -88,17 +98,25 @@ subroutine initialize_discharges() ok = check_file_exists(disfile, 'River discharge timeseries dis file', .true.) ! open(502, file=trim(disfile)) + ! do while (.true.) + ! read(502, *, iostat=stat) dummy if (stat < 0) exit ntsrc = ntsrc + 1 + ! enddo + ! rewind(502) allocate(tsrc(ntsrc)) allocate(qsrc_ts(nsrc, ntsrc)) + ! do itsrc = 1, ntsrc + ! read(502, *) tsrc(itsrc), (qsrc_ts(isrc, itsrc), isrc = 1, nsrc) + ! enddo + ! close(502) ! if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then @@ -107,13 +125,17 @@ subroutine initialize_discharges() call write_log(logstr, 1) ! if (tsrc(1) > (t0 + 1.0)) then + ! write(logstr,'(a)') 'Warning! Adjusting first time in discharge time series !' call write_log(logstr, 1) tsrc(1) = t0 - 1.0 + ! else + ! write(logstr,'(a)') 'Warning! Adjusting last time in discharge time series !' call write_log(logstr, 1) tsrc(ntsrc) = t1 + 1.0 + ! endif ! endif @@ -125,8 +147,11 @@ subroutine initialize_discharges() do isrc = 1, nsrc ! nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) + ! if (nmq > 0) then + ! nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) + ! endif ! enddo @@ -174,14 +199,20 @@ subroutine update_discharges(t, dt, tloop) ! it_prev = itsrclast it_next = itsrclast + 1 + ! do itsrc = itsrclast, ntsrc + ! if (tsrc(itsrc) > t) then + ! it_prev = itsrc - 1 it_next = itsrc itsrclast = it_prev exit + ! endif + ! enddo + ! wt = (t - tsrc(it_prev)) / (tsrc(it_next) - tsrc(it_prev)) ! ! Atomic accumulation because two river sources (or a river and a @@ -190,14 +221,18 @@ subroutine update_discharges(t, dt, tloop) !$acc parallel loop present( qsrc, qtsrc, nmindsrc, qsrc_ts ) private( nm ) !$omp parallel do private( nm ) schedule ( static ) do isrc = 1, nsrc - qtsrc(isrc) = qsrc_ts(isrc, it_prev) & - + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt + ! + qtsrc(isrc) = qsrc_ts(isrc, it_prev) + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt nm = nmindsrc(isrc) + ! if (nm > 0) then + ! !$acc atomic update !$omp atomic qsrc(nm) = qsrc(nm) + qtsrc(isrc) + ! endif + ! enddo !$omp end parallel do !$acc end parallel loop diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 3e3bc77a9..ec93bf23c 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -22,14 +22,216 @@ module sfincs_src_structures ! use sfincs_log use sfincs_error + ! + private :: parse_action_kind, parse_rule_lhs, parse_comparator, parse_rule_rhs, parse_structure_type, to_lower, check_required + private :: initialize_src_structures_legacy + ! + ! ------------------------------------------------------------------ + ! Named constants for the keyword-based src structure input. + ! + ! These are scaffolding for a future TOML/YAML reader; no runtime + ! code consumes them yet. + ! ------------------------------------------------------------------ + ! + ! Structure type codes + ! + integer, parameter :: structure_pump = 1 + integer, parameter :: structure_check_valve = 2 + integer, parameter :: structure_culvert = 3 + integer, parameter :: structure_gate = 4 + ! + ! Action kind codes + ! + integer, parameter :: ACTION_OPEN = 1 + integer, parameter :: ACTION_CLOSE = 2 + ! + ! Rule left-hand-side kind codes + ! + integer, parameter :: RULE_LHS_Z1 = 1 + integer, parameter :: RULE_LHS_Z2 = 2 + ! + ! Rule comparator codes + ! + integer, parameter :: CMP_LT = 1 + integer, parameter :: CMP_LE = 2 + integer, parameter :: CMP_GT = 3 + integer, parameter :: CMP_GE = 4 + integer, parameter :: CMP_EQ = 5 + integer, parameter :: CMP_NE = 6 + ! + ! Rule right-hand-side kind codes + ! + integer, parameter :: RULE_RHS_PAR1 = 1 + integer, parameter :: RULE_RHS_PAR2 = 2 + integer, parameter :: RULE_RHS_PAR3 = 3 + integer, parameter :: RULE_RHS_CONST = 4 + ! + ! ------------------------------------------------------------------ + ! Derived types for the keyword-based src structure input. + ! + ! Scaffolding only - not yet wired into any reader or the runtime. + ! ------------------------------------------------------------------ + ! + type :: t_src_action + ! + integer :: kind ! ACTION_OPEN / ACTION_CLOSE + real :: value ! payload (e.g. target state / timing), unused for now + ! + end type t_src_action + ! + type :: t_src_rule + ! + integer :: lhs_kind ! RULE_LHS_* + integer :: comparator ! CMP_* + integer :: rhs_kind ! RULE_RHS_* + real :: rhs_value ! only used when rhs_kind == RULE_RHS_CONST + ! + end type t_src_rule + ! + type :: t_src_structure + ! + ! Identification (populated by the TOML reader). id is required, + ! name is a human-friendly label and optional. + ! + character(len=:), allocatable :: id + character(len=:), allocatable :: name + ! + ! Structure kind (one of the structure_* codes) + ! + integer :: structure_type + ! + ! Geometry - single representative point (x, y), and two paired + ! coords: src_1/src_2 (the old source/sink pair) and obs_1/obs_2. + ! + real :: x, y + real :: src_1_x, src_1_y + real :: src_2_x, src_2_y + real :: obs_1_x, obs_1_y + real :: obs_2_x, obs_2_y + ! + ! State + ! + integer :: status ! 0/1/2/3 - meaning reserved for later + ! + ! Parameters + ! + ! q - pump discharge + ! width - gate width + ! sill_elevation - gate sill elevation + ! mannings_n - gate Manning's n + ! zmin - gate min water level for open + ! zmax - gate max water level for open + ! t_close - gate closing time (seconds) + ! cd, par1, par2, par3 - generic parameters (use depends on type) + ! + real :: q + real :: width + real :: sill_elevation + real :: mannings_n + real :: zmin + real :: zmax + real :: t_close + real :: cd + real :: par1 + real :: par2 + real :: par3 + ! + ! Actions and rules + ! + type(t_src_action), allocatable :: actions(:) + type(t_src_rule), allocatable :: rules(:) + ! + end type t_src_structure + ! + ! ------------------------------------------------------------------ + ! Module-level storage for structures parsed from a TOML input file. + ! + ! Populated by the dispatcher when the drn file parses as TOML. + ! Not yet consumed by any downstream runtime code - wiring is a later + ! step. The legacy path continues to populate the flat arrays in + ! sfincs_data (drainage_type, drainage_params, etc.). + ! ------------------------------------------------------------------ + ! + type(t_src_structure), allocatable :: src_structures(:) + ! contains ! subroutine initialize_src_structures() ! - ! Parse drnfile and populate drainage_type/_params/_status/_distance/ - ! _fraction_open, nmindrn_in(ndrn), nmindrn_out(ndrn), and the output - ! buffer qdrain(ndrn). + ! Dispatcher for the src_structures / drainage input file. + ! + ! Probes the file with toml-f. If it parses as TOML, the TOML reader + ! populates the module-level src_structures(:) array. If toml-f rejects + ! it, falls back to the legacy fixed-column reader, which populates the + ! drainage_* arrays in sfincs_data. + ! + ! If a file parses as TOML but fails semantic validation (e.g. a + ! missing required field), that is treated as a hard error: we do NOT + ! fall back to the legacy reader, because the file was already + ! unambiguously TOML. + ! + use sfincs_data + use tomlf, only : toml_table, toml_error, toml_load + ! + implicit none + ! + type(toml_table), allocatable :: probe_top + type(toml_error), allocatable :: probe_err + integer :: ierr_toml + logical :: ok + ! + if (drnfile(1:4) == 'none') return + ! + ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) + ! + ! Probe: try to parse as TOML. This is a cheap check; on success we + ! discard the probe table and let read_toml_src_structures re-parse, + ! which keeps the two code paths decoupled. + ! + call toml_load(probe_top, drnfile, error=probe_err) + ! + if (.not. allocated(probe_err)) then + ! + ! TOML path + ! + if (allocated(probe_top)) deallocate(probe_top) + ! + call read_toml_src_structures(drnfile, src_structures, ierr_toml) + ! + if (ierr_toml /= 0) then + ! + ! File was valid TOML but failed semantic validation; do NOT + ! fall back to legacy. + ! + write(logstr,'(a,a,a)')' Error ! Failed to load TOML src_structures file ', trim(drnfile), ' !' + call stop_sfincs(logstr, -1) + ! + endif + ! + return + ! + else + ! + ! Legacy path + ! + deallocate(probe_err) + if (allocated(probe_top)) deallocate(probe_top) + ! + call initialize_src_structures_legacy() + ! + return + ! + endif + ! + end subroutine + ! + ! + subroutine initialize_src_structures_legacy() + ! + ! Parse drnfile in the fixed-column legacy format and populate + ! drainage_type/_params/_status/_distance/_fraction_open, + ! nmindrn_in(ndrn), nmindrn_out(ndrn), and the output buffer qdrain(ndrn). ! use sfincs_data use quadtree @@ -52,16 +254,22 @@ subroutine initialize_src_structures() ! Count lines ! open(501, file=trim(drnfile)) + ! do while (.true.) + ! read(501, *, iostat=stat) dummy if (stat < 0) exit ndrn = ndrn + 1 + ! enddo + ! rewind(501) ! if (ndrn <= 0) then + ! close(501) return + ! endif ! write(logstr,'(a,a,a,i0,a)')' Reading ', trim(drnfile), ' (', ndrn, ' drainage points found) ...' @@ -100,29 +308,41 @@ subroutine initialize_src_structures() npars = 0 ! if (drainage_type(idrn) == 1 .or. drainage_type(idrn) == 2 .or. drainage_type(idrn) == 3) then + ! npars = 1 ! pump, culvert, or check valve + ! elseif (drainage_type(idrn) == 4 .or. drainage_type(idrn) == 5) then + ! npars = 6 ! controlled gate (width, sill, manning, zmin/tclose, zmax/topen, closing time) + ! endif ! if (npars == 0) then + ! write(logstr,'(a,i0,a)') 'Drainage type ', drainage_type(idrn), ' not recognized !' call stop_sfincs(logstr, -1) + ! endif ! if (npars == 1) then + ! read(drainage_line, *, iostat=stat) xsnk(idrn), ysnk(idrn), xsrc_drn(idrn), ysrc_drn(idrn), & drainage_type(idrn), drainage_params(idrn, 1) + ! elseif (npars == 6) then + ! read(drainage_line, *, iostat=stat) xsnk(idrn), ysnk(idrn), xsrc_drn(idrn), ysrc_drn(idrn), & drainage_type(idrn), drainage_params(idrn, 1), drainage_params(idrn, 2), & drainage_params(idrn, 3), drainage_params(idrn, 4), drainage_params(idrn, 5), & drainage_params(idrn, 6) + ! endif ! if (stat /= 0) then + ! write(logstr,'(a,i0,a,i0,a)') 'Drainage type ', drainage_type(idrn), ' requires ', npars, ' parameters !' call stop_sfincs(logstr, -1) + ! endif ! enddo @@ -141,11 +361,13 @@ subroutine initialize_src_structures() if (nmq > 0) nmindrn_out(idrn) = index_sfincs_in_quadtree(nmq) ! if (nmindrn_in(idrn) > 0 .and. nmindrn_out(idrn) > 0) then + ! xsnk_tmp = z_xz(nmindrn_in(idrn)) ysnk_tmp = z_yz(nmindrn_in(idrn)) xsrc_tmp = z_xz(nmindrn_out(idrn)) ysrc_tmp = z_yz(nmindrn_out(idrn)) drainage_distance(idrn) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + ! endif ! enddo @@ -156,10 +378,12 @@ subroutine initialize_src_structures() deallocate(ysnk) ! if (any(nmindrn_in == 0) .or. any(nmindrn_out == 0)) then + ! write(logstr,'(a)') 'Warning ! For some sink/source drainage points no matching active grid cell was found!' call write_log(logstr, 0) write(logstr,'(a)') 'Warning ! These points will be skipped, please check your input!' call write_log(logstr, 0) + ! endif ! end subroutine @@ -223,9 +447,13 @@ subroutine update_src_structures(t, dt, tloop) ! Culvert (bidirectional) ! if (zs(nmin) > zs(nmout)) then + ! qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) + ! else + ! qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) + ! endif ! case(3) @@ -233,10 +461,15 @@ subroutine update_src_structures(t, dt, tloop) ! Check valve (culvert, but flow only from intake to outfall) ! if (zs(nmin) > zs(nmout)) then + ! qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) + ! else + ! qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) + ! endif + ! qq = max(qq, 0.0) ! case(4) @@ -258,23 +491,37 @@ subroutine update_src_structures(t, dt, tloop) qq0 = qdrain(idrn) / (wdt * max(frac, 0.001)) ! previous discharge per unit width, ignoring fraction ! if (drainage_status(idrn) == 0) then + ! if (zs(nmin) > zmin .and. zs(nmin) < zmax) drainage_status(idrn) = 3 + ! elseif (drainage_status(idrn) == 1) then + ! if (zs(nmin) <= zmin .or. zs(nmin) >= zmax) drainage_status(idrn) = 2 + ! endif ! if (drainage_status(idrn) == 2) then + ! frac = frac - dfrac + ! if (frac < 0.0) then + ! frac = 0.0 drainage_status(idrn) = 0 + ! endif + ! elseif (drainage_status(idrn) == 3) then + ! frac = frac + dfrac + ! if (frac > 1.0) then + ! frac = 1.0 drainage_status(idrn) = 1 + ! endif + ! endif ! drainage_fraction_open(idrn) = frac @@ -301,23 +548,37 @@ subroutine update_src_structures(t, dt, tloop) qq0 = qdrain(idrn) / (wdt * max(frac, 0.001)) ! if (drainage_status(idrn) == 0) then + ! if (t >= topen) drainage_status(idrn) = 3 + ! elseif (drainage_status(idrn) == 1) then + ! if (t >= tclose .and. t < topen) drainage_status(idrn) = 2 + ! endif ! if (drainage_status(idrn) == 2) then + ! frac = frac - dfrac + ! if (frac < 0.0) then + ! frac = 0.0 drainage_status(idrn) = 0 + ! endif + ! elseif (drainage_status(idrn) == 3) then + ! frac = frac + dfrac + ! if (frac > 1.0) then + ! frac = 1.0 drainage_status(idrn) = 1 + ! endif + ! endif ! drainage_fraction_open(idrn) = frac @@ -334,17 +595,29 @@ subroutine update_src_structures(t, dt, tloop) ! Limit discharge by available volume in the intake / outfall cell. ! if (subgrid) then + ! if (qq > 0.0) then + ! qq = min(qq, max(z_volume(nmin), 0.0) / dt) + ! else + ! qq = max(qq, -max(z_volume(nmout), 0.0) / dt) + ! endif + ! else + ! if (qq > 0.0) then + ! qq = min(qq, max((zs(nmin) - zb(nmin)) * cell_area(z_flags_iref(nmin)), 0.0) / dt) + ! else + ! qq = max(qq, -max((zs(nmout) - zb(nmout)) * cell_area(z_flags_iref(nmout)), 0.0) / dt) + ! endif + ! endif ! qdrain(idrn) = qq @@ -369,5 +642,684 @@ subroutine update_src_structures(t, dt, tloop) tloop = tloop + 1.0 * (count1 - count0) / count_rate ! end subroutine + ! + ! + subroutine read_toml_src_structures(filename, structures, ierr) + ! + ! Parse a TOML input file describing point source structures into an + ! allocatable array of t_src_structure. + ! + ! The TOML schema is an array of tables under the key "src_structure": + ! + ! [[src_structure]] + ! id = "gate_south" ! required, string + ! name = "South tide gate" ! optional, string + ! type = "gate" ! required, one of pump/check_valve/culvert/gate + ! x = ... ; y = ... ! optional single-point coord + ! src_1_x = ... ; src_1_y = ... ; src_2_x = ... ; src_2_y = ... + ! obs_1_x = ... ; obs_1_y = ... ; obs_2_x = ... ; obs_2_y = ... + ! status = 0 + ! q = ... ! pump discharge + ! width = ... ; sill_elevation = ... ; mannings_n = ... + ! zmin = ... ; zmax = ... ; t_close = ... + ! cd = ... ; par1 = ... ; par2 = ... ; par3 = ... + ! actions = [ { kind = "open", value = 10.0 }, ... ] + ! rules = [ { lhs = "z1", comparator = ">", rhs = "par1" }, ... ] + ! + ! Per-type required keys (enforced on parse): + ! pump : x, y, q + ! check_valve : src_1_x, src_1_y, src_2_x, src_2_y, par1 + ! culvert : src_1_x, src_1_y, src_2_x, src_2_y, par1 + ! gate : src_1_x, src_1_y, src_2_x, src_2_y, + ! width, sill_elevation, mannings_n, zmin, zmax, t_close + ! + ! On success, structures is allocated to the exact number of entries + ! (can be 0). On any I/O or parse failure, structures is left + ! unallocated and ierr is non-zero. + ! + ! This routine does not modify module state; it is the caller's job to + ! decide what to do with the parsed array. + ! + use tomlf + ! + implicit none + ! + character(len=*), intent(in) :: filename + type(t_src_structure), allocatable, intent(out) :: structures(:) + integer, intent(out) :: ierr + ! + type(toml_table), allocatable :: top + type(toml_error), allocatable :: err + type(toml_array), pointer :: arr_structs, arr_actions, arr_rules + type(toml_table), pointer :: tbl_struct, tbl_entry + character(len=:), allocatable :: id_str, name_str, type_str, kind_str, lhs_str, cmp_str, rhs_str + integer :: n_struct, n_act, n_rule, i, j, stat + real :: rval + ! + ierr = 0 + ! + ! Parse the file. toml_load returns an allocatable table; on failure the + ! table is not allocated and err carries the diagnostic. + ! + call toml_load(top, filename, error=err) + ! + if (allocated(err)) then + ! + write(logstr,'(a,a,a,a)')' Error ! Failed to parse TOML file ', trim(filename), ': ', trim(err%message) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + if (.not. allocated(top)) then + ! + write(logstr,'(a,a)')' Error ! Could not load TOML file ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + ! Look for the top-level array of tables "src_structure". If it is not + ! present at all, treat that as "zero entries" (empty but valid). + ! + nullify(arr_structs) + call get_value(top, 'src_structure', arr_structs, requested=.false., stat=stat) + ! + if (.not. associated(arr_structs)) then + ! + allocate(structures(0)) + return + ! + endif + ! + if (.not. is_array_of_tables(arr_structs)) then + ! + write(logstr,'(a,a)')' Error ! Key "src_structure" must be an array of tables in ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + n_struct = len(arr_structs) + allocate(structures(n_struct)) + ! + do i = 1, n_struct + ! + nullify(tbl_struct) + call get_value(arr_structs, i, tbl_struct, stat=stat) + ! + if (.not. associated(tbl_struct)) then + ! + write(logstr,'(a,i0,a)')' Error ! src_structure entry ', i, ' is not a table' + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + ! Required id string + ! + if (allocated(id_str)) deallocate(id_str) + call get_value(tbl_struct, 'id', id_str, stat=stat) + ! + if (.not. allocated(id_str)) then + ! + write(logstr,'(a,i0,a,a)')' Error ! Missing required "id" in src_structure entry ', i, & + ' of ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + ! + endif + ! + structures(i)%id = id_str + ! + ! Optional name + ! + if (allocated(name_str)) deallocate(name_str) + call get_value(tbl_struct, 'name', name_str, stat=stat) + if (allocated(name_str)) structures(i)%name = name_str + ! + ! Required type string, mapped to structure_* code + ! + if (allocated(type_str)) deallocate(type_str) + call get_value(tbl_struct, 'type', type_str, stat=stat) + ! + if (.not. allocated(type_str)) then + ! + write(logstr,'(a,i0,a,a)')' Error ! Missing required "type" in src_structure entry ', i, & + ' of ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + ! + endif + ! + call parse_structure_type(type_str, structures(i)%structure_type, ierr) + ! + if (ierr /= 0) then + ! + write(logstr,'(a,a,a,i0)')' Error ! Unknown structure type "', trim(type_str), & + '" in src_structure entry ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + ! Per-type required-field validation. Checked by key presence + ! (has_key) so that 0.0 remains a legal input value. + ! + select case (structures(i)%structure_type) + ! + case (structure_pump) + ! + call check_required(tbl_struct, [ character(len=14) :: & + 'x', 'y', 'q' ], id_str, ierr) + ! + case (structure_check_valve) + ! + call check_required(tbl_struct, [ character(len=14) :: & + 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'par1' ], id_str, ierr) + ! + case (structure_culvert) + ! + call check_required(tbl_struct, [ character(len=14) :: & + 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'par1' ], id_str, ierr) + ! + case (structure_gate) + ! + call check_required(tbl_struct, [ character(len=14) :: & + 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & + 'width', 'sill_elevation', 'mannings_n', & + 'zmin', 'zmax', 't_close' ], id_str, ierr) + ! + end select + ! + if (ierr /= 0) then + ! + call cleanup_on_error() + return + ! + endif + ! + ! Coordinates - all default to 0.0 if missing. A structure may use only + ! the single point (x, y), or only the paired coords. + ! + call get_value(tbl_struct, 'x', structures(i)%x, 0.0, stat=stat) + call get_value(tbl_struct, 'y', structures(i)%y, 0.0, stat=stat) + call get_value(tbl_struct, 'src_1_x', structures(i)%src_1_x, 0.0, stat=stat) + call get_value(tbl_struct, 'src_1_y', structures(i)%src_1_y, 0.0, stat=stat) + call get_value(tbl_struct, 'src_2_x', structures(i)%src_2_x, 0.0, stat=stat) + call get_value(tbl_struct, 'src_2_y', structures(i)%src_2_y, 0.0, stat=stat) + call get_value(tbl_struct, 'obs_1_x', structures(i)%obs_1_x, 0.0, stat=stat) + call get_value(tbl_struct, 'obs_1_y', structures(i)%obs_1_y, 0.0, stat=stat) + call get_value(tbl_struct, 'obs_2_x', structures(i)%obs_2_x, 0.0, stat=stat) + call get_value(tbl_struct, 'obs_2_y', structures(i)%obs_2_y, 0.0, stat=stat) + ! + ! State + ! + call get_value(tbl_struct, 'status', structures(i)%status, 0, stat=stat) + ! + ! Named physical parameters + ! + call get_value(tbl_struct, 'q', structures(i)%q, 0.0, stat=stat) + call get_value(tbl_struct, 'width', structures(i)%width, 0.0, stat=stat) + call get_value(tbl_struct, 'sill_elevation', structures(i)%sill_elevation, 0.0, stat=stat) + call get_value(tbl_struct, 'mannings_n', structures(i)%mannings_n, 0.0, stat=stat) + call get_value(tbl_struct, 'zmin', structures(i)%zmin, 0.0, stat=stat) + call get_value(tbl_struct, 'zmax', structures(i)%zmax, 0.0, stat=stat) + call get_value(tbl_struct, 't_close', structures(i)%t_close, 0.0, stat=stat) + ! + ! Generic parameters (kept for future use / rule rhs) + ! + call get_value(tbl_struct, 'cd', structures(i)%cd, 0.0, stat=stat) + call get_value(tbl_struct, 'par1', structures(i)%par1, 0.0, stat=stat) + call get_value(tbl_struct, 'par2', structures(i)%par2, 0.0, stat=stat) + call get_value(tbl_struct, 'par3', structures(i)%par3, 0.0, stat=stat) + ! + ! Optional actions array + ! + nullify(arr_actions) + call get_value(tbl_struct, 'actions', arr_actions, requested=.false., stat=stat) + ! + if (associated(arr_actions)) then + ! + n_act = len(arr_actions) + allocate(structures(i)%actions(n_act)) + ! + do j = 1, n_act + ! + nullify(tbl_entry) + call get_value(arr_actions, j, tbl_entry, stat=stat) + ! + if (.not. associated(tbl_entry)) then + ! + write(logstr,'(a,i0,a,i0,a)')' Error ! actions entry ', j, & + ' of src_structure ', i, ' is not a table' + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + if (allocated(kind_str)) deallocate(kind_str) + call get_value(tbl_entry, 'kind', kind_str, stat=stat) + ! + if (.not. allocated(kind_str)) then + ! + write(logstr,'(a,i0,a,i0)')' Error ! Missing "kind" in actions entry ', j, & + ' of src_structure ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + call parse_action_kind(kind_str, structures(i)%actions(j)%kind, ierr) + ! + if (ierr /= 0) then + ! + write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown action kind "', trim(kind_str), & + '" in actions entry ', j, ' of src_structure ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + rval = 0.0 + call get_value(tbl_entry, 'value', rval, stat=stat) + structures(i)%actions(j)%value = rval + ! + enddo + ! + else + ! + allocate(structures(i)%actions(0)) + ! + endif + ! + ! Optional rules array + ! + nullify(arr_rules) + call get_value(tbl_struct, 'rules', arr_rules, requested=.false., stat=stat) + ! + if (associated(arr_rules)) then + ! + n_rule = len(arr_rules) + allocate(structures(i)%rules(n_rule)) + ! + do j = 1, n_rule + ! + nullify(tbl_entry) + call get_value(arr_rules, j, tbl_entry, stat=stat) + ! + if (.not. associated(tbl_entry)) then + ! + write(logstr,'(a,i0,a,i0,a)')' Error ! rules entry ', j, & + ' of src_structure ', i, ' is not a table' + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + if (allocated(lhs_str)) deallocate(lhs_str) + if (allocated(cmp_str)) deallocate(cmp_str) + if (allocated(rhs_str)) deallocate(rhs_str) + ! + call get_value(tbl_entry, 'lhs', lhs_str, stat=stat) + call get_value(tbl_entry, 'comparator', cmp_str, stat=stat) + call get_value(tbl_entry, 'rhs', rhs_str, stat=stat) + ! + if (.not. allocated(lhs_str) .or. .not. allocated(cmp_str) .or. & + .not. allocated(rhs_str)) then + ! + write(logstr,'(a,i0,a,i0)')' Error ! rules entry ', j, & + ' needs lhs/comparator/rhs keys in src_structure ', i + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + ! + endif + ! + call parse_rule_lhs(lhs_str, structures(i)%rules(j)%lhs_kind, ierr) + ! + if (ierr /= 0) then + ! + write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown rule lhs "', trim(lhs_str), & + '" in rules entry ', j, ' of src_structure ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + call parse_comparator(cmp_str, structures(i)%rules(j)%comparator, ierr) + ! + if (ierr /= 0) then + ! + write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown comparator "', trim(cmp_str), & + '" in rules entry ', j, ' of src_structure ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + call parse_rule_rhs(rhs_str, structures(i)%rules(j)%rhs_kind, ierr) + ! + if (ierr /= 0) then + ! + write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown rule rhs "', trim(rhs_str), & + '" in rules entry ', j, ' of src_structure ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + rval = 0.0 + ! + if (structures(i)%rules(j)%rhs_kind == RULE_RHS_CONST) then + ! + call get_value(tbl_entry, 'rhs_value', rval, stat=stat) + ! + endif + ! + structures(i)%rules(j)%rhs_value = rval + ! + enddo + ! + else + ! + allocate(structures(i)%rules(0)) + ! + endif + ! + enddo + ! + contains + ! + subroutine cleanup_on_error() + ! + if (allocated(structures)) deallocate(structures) + ! + end subroutine + ! + end subroutine + ! + ! + subroutine check_required(table, keys, id_str, ierr) + ! + ! Verify that every key in "keys" is present in the TOML table. Missing + ! keys are reported to the log (naming the structure id and key) and + ! ierr is set non-zero. Presence is checked via has_key so that a legal + ! value of 0.0 is not mistaken for "missing". + ! + use tomlf + ! + implicit none + ! + type(toml_table), pointer, intent(in) :: table + character(len=*), intent(in) :: keys(:) + character(len=*), intent(in) :: id_str + integer, intent(inout) :: ierr + ! + integer :: k + ! + do k = 1, size(keys) + ! + if (.not. table%has_key(trim(keys(k)))) then + ! + write(logstr,'(a,a,a,a,a)')' Error ! src_structure "', trim(id_str), & + '" is missing required key "', trim(keys(k)), '"' + call write_log(logstr, 1) + ierr = 1 + ! + endif + ! + enddo + ! + end subroutine + ! + ! + subroutine parse_action_kind(str, code, ierr) + ! + ! Translate a TOML action "kind" string to one of the ACTION_* codes. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = 0 + s = to_lower(str) + ! + select case (s) + ! + case ('open') + ! + code = ACTION_OPEN + ! + case ('close') + ! + code = ACTION_CLOSE + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + ! + subroutine parse_structure_type(str, code, ierr) + ! + ! Translate a TOML "type" string to one of the structure_* codes. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = 0 + s = to_lower(str) + ! + select case (s) + ! + case ('pump') + ! + code = structure_pump + ! + case ('check_valve') + ! + code = structure_check_valve + ! + case ('culvert') + ! + code = structure_culvert + ! + case ('gate') + ! + code = structure_gate + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + ! + subroutine parse_rule_lhs(str, code, ierr) + ! + ! Translate a TOML rule "lhs" string to one of the RULE_LHS_* codes. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = 0 + s = to_lower(str) + ! + select case (s) + ! + case ('z1') + ! + code = RULE_LHS_Z1 + ! + case ('z2') + ! + code = RULE_LHS_Z2 + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + ! + subroutine parse_comparator(str, code, ierr) + ! + ! Translate a TOML "comparator" string to one of the CMP_* codes. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + ierr = 0 + code = 0 + ! + select case (trim(str)) + ! + case ('<') + ! + code = CMP_LT + ! + case ('<=') + ! + code = CMP_LE + ! + case ('>') + ! + code = CMP_GT + ! + case ('>=') + ! + code = CMP_GE + ! + case ('==') + ! + code = CMP_EQ + ! + case ('!=') + ! + code = CMP_NE + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + ! + subroutine parse_rule_rhs(str, code, ierr) + ! + ! Translate a TOML rule "rhs" string to one of the RULE_RHS_* codes. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = 0 + s = to_lower(str) + ! + select case (s) + ! + case ('par1') + ! + code = RULE_RHS_PAR1 + ! + case ('par2') + ! + code = RULE_RHS_PAR2 + ! + case ('par3') + ! + code = RULE_RHS_PAR3 + ! + case ('const') + ! + code = RULE_RHS_CONST + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + ! + function to_lower(str) result(lower) + ! + ! Return a lowercase copy of str (ASCII only). + ! + implicit none + ! + character(len=*), intent(in) :: str + character(len=:), allocatable :: lower + ! + integer :: k, ic + ! + lower = str + ! + do k = 1, len(lower) + ! + ic = iachar(lower(k:k)) + ! + if (ic >= iachar('A') .and. ic <= iachar('Z')) then + ! + lower(k:k) = achar(ic + 32) + ! + endif + ! + enddo + ! + end function end module diff --git a/source/third_party_open/utils/toml-f/LICENSE-Apache b/source/third_party_open/utils/toml-f/LICENSE-Apache new file mode 100644 index 000000000..d64569567 --- /dev/null +++ b/source/third_party_open/utils/toml-f/LICENSE-Apache @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/source/third_party_open/utils/toml-f/LICENSE-MIT b/source/third_party_open/utils/toml-f/LICENSE-MIT new file mode 100644 index 000000000..9131f1306 --- /dev/null +++ b/source/third_party_open/utils/toml-f/LICENSE-MIT @@ -0,0 +1,7 @@ +Copyright 2019-2021 Sebastian Ehlert + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/source/third_party_open/utils/toml-f/src/tomlf.f90 b/source/third_party_open/utils/toml-f/src/tomlf.f90 new file mode 100644 index 000000000..305422c75 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf.f90 @@ -0,0 +1,65 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Public API for TOML Fortran +!> +!> This module provides the main entry point to the TOML Fortran library. +!> It re-exports all public types and procedures needed for parsing, manipulating, +!> and serializing TOML documents. +!> +!> ## Parsing TOML +!> +!> Use [[toml_load]] to load a TOML document from a file or unit, or [[toml_loads]] +!> to parse a TOML string directly: +!> +!>```fortran +!> type(toml_table), allocatable :: table +!> call toml_load(table, "config.toml") +!>``` +!> +!> ## Accessing Values +!> +!> Use [[get_value]] to retrieve values from tables and arrays, and [[set_value]] +!> to modify or create new values: +!> +!>```fortran +!> character(len=:), allocatable :: name +!> call get_value(table, "name", name) +!>``` +!> +!> ## Serialization +!> +!> Use [[toml_dump]] to write a table to a file or [[toml_dumps]] to serialize +!> to a string: +!> +!>```fortran +!> character(len=:), allocatable :: output +!> call toml_dumps(table, output) +!>``` +module tomlf + use tomlf_build, only : get_value, set_value, toml_path + use tomlf_datetime, only : toml_datetime, to_string + use tomlf_de, only : toml_parse, toml_load, toml_loads, & + & toml_context, toml_parser_config, toml_level + use tomlf_error, only : toml_error, toml_stat + use tomlf_ser, only : toml_serializer, toml_serialize, toml_dump, toml_dumps + use tomlf_terminal, only : toml_terminal + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_key, toml_value, & + & is_array_of_tables, new_table, add_table, add_array, add_keyval, len + use tomlf_utils_sort, only : sort + use tomlf_version, only : tomlf_version_string, tomlf_version_compact, & + & get_tomlf_version + implicit none + public + +end module tomlf diff --git a/source/third_party_open/utils/toml-f/src/tomlf/all.f90 b/source/third_party_open/utils/toml-f/src/tomlf/all.f90 new file mode 100644 index 000000000..867c32f05 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/all.f90 @@ -0,0 +1,29 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Complete reexport of the public API of TOML-Fortran +module tomlf_all + use tomlf_build + use tomlf_constants + use tomlf_datetime + use tomlf_de + use tomlf_error + use tomlf_ser + use tomlf_structure + use tomlf_type + use tomlf_utils + use tomlf_version + implicit none + public + +end module tomlf_all diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build.f90 new file mode 100644 index 000000000..e90b72ba9 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build.f90 @@ -0,0 +1,31 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build a TOML data structures +!> +!> The build module defines a high level interface to work with TOML data structures +!> and construct them in a convenient way. +module tomlf_build + use tomlf_build_array, only : get_value, set_value + use tomlf_build_keyval, only : get_value, set_value + use tomlf_build_merge, only : merge_table, merge_array, merge_policy, toml_merge_config + use tomlf_build_path, only : get_value, set_value, toml_path + use tomlf_build_table, only : get_value, set_value + implicit none + private + + public :: get_value, set_value + public :: merge_table, merge_array, merge_policy, toml_merge_config + public :: toml_path + +end module tomlf_build diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 new file mode 100644 index 000000000..e1151aec7 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/build_array.f90 @@ -0,0 +1,1323 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build TOML arrays. +!> +!> This build module defines a high level interface to work with TOML arrays +!> and construct them in a convenient way. +!> +!> The access to the array elements happens by position in the array, the indexing +!> is one based, following the language convention of Fortran. All functions +!> will only allow access of elements within the bounds of the array, specifying +!> indices out-of-bounds should be save, as it only sets the status of operation. +!> The getter functions allow access to other tables and arrays as well as +!> convenient wrappers to retrieve value data +!> +!> The setter functions are somewhat weaker compared to the setter functions +!> available for TOML tables. To limit the potential havoc this routines can +!> cause they can only access the array within its bounds. Setting a value to +!> another value will overwrite it, while setting a value to a table or an array +!> will fail, for safety reasons. +!> +!> To (re)build an array appending to it is the best choice, tables and arrays +!> should always be create by using the corresponding `add_table` and `add_array` +!> function. While this can become cumbersome for values, the setter routines +!> allow out-of-bound access to for the next element in an array and will indeed +!> just append a new value to it. +module tomlf_build_array + use tomlf_build_keyval, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, & + & cast_to_table, cast_to_array, cast_to_keyval, initialized, len + implicit none + private + + public :: get_value, set_value + + + !> Setter functions to manipulate TOML arrays + interface set_value + module procedure :: set_elem_value_string + module procedure :: set_elem_value_float_sp + module procedure :: set_elem_value_float_dp + module procedure :: set_elem_value_int_i1 + module procedure :: set_elem_value_int_i2 + module procedure :: set_elem_value_int_i4 + module procedure :: set_elem_value_int_i8 + module procedure :: set_elem_value_bool + module procedure :: set_elem_value_datetime + module procedure :: set_array_value_float_sp + module procedure :: set_array_value_float_dp + module procedure :: set_array_value_int_i1 + module procedure :: set_array_value_int_i2 + module procedure :: set_array_value_int_i4 + module procedure :: set_array_value_int_i8 + module procedure :: set_array_value_bool + module procedure :: set_array_value_datetime + end interface set_value + + + !> Getter functions to manipulate TOML arrays + interface get_value + module procedure :: get_elem_table + module procedure :: get_elem_array + module procedure :: get_elem_keyval + module procedure :: get_elem_value_string + module procedure :: get_elem_value_float_sp + module procedure :: get_elem_value_float_dp + module procedure :: get_elem_value_int_i1 + module procedure :: get_elem_value_int_i2 + module procedure :: get_elem_value_int_i4 + module procedure :: get_elem_value_int_i8 + module procedure :: get_elem_value_bool + module procedure :: get_elem_value_datetime + module procedure :: get_array_value_float_sp + module procedure :: get_array_value_float_dp + module procedure :: get_array_value_int_i1 + module procedure :: get_array_value_int_i2 + module procedure :: get_array_value_int_i4 + module procedure :: get_array_value_int_i8 + module procedure :: get_array_value_bool + module procedure :: get_array_value_datetime + end interface get_value + + +contains + + +subroutine get_elem_table(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_table + + +subroutine get_elem_array(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_array(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_array + + +subroutine get_elem_keyval(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_keyval(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_keyval + + +!> Retrieve TOML value as deferred-length character +subroutine get_elem_value_string(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_string + + +!> Retrieve TOML value as single precision floating point number +subroutine get_elem_value_float_sp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_sp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_float_sp + + +!> Retrieve TOML value as double precision floating point number +subroutine get_elem_value_float_dp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_dp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_float_dp + + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i1(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i1 + + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i2(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i2 + + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i4(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i4 + + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i8(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i8 + + +!> Retrieve TOML value as boolean +subroutine get_elem_value_bool(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + logical, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_elem_value_datetime(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + type(toml_datetime), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine set_elem_value_string(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_string + + +!> Retrieve TOML value as single precision floating point number +subroutine set_elem_value_float_sp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_float_sp + + +!> Retrieve TOML value as double precision floating point number +subroutine set_elem_value_float_dp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_float_dp + + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i1(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i1 + + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i2(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i2 + + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i4(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i4 + + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i8(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i8 + + +!> Retrieve TOML value as boolean value +subroutine set_elem_value_bool(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_bool + + +!> Retrieve TOML value as datetime value +subroutine set_elem_value_datetime(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_datetime + + +!> Retrieve TOML value as single precision floating point number +subroutine get_array_value_float_sp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_sp), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_float_sp + + +!> Retrieve TOML value as double precision floating point number +subroutine get_array_value_float_dp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_dp), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_float_dp + + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i1(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i1), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i1 + + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i2(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i2), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i2 + + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i4(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i4), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i4 + + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i8(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i8), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i8 + + +!> Retrieve TOML value as boolean +subroutine get_array_value_bool(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + logical, allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_array_value_datetime(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + type(toml_datetime), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_datetime + + +!> Retrieve TOML value as single precision floating point number +subroutine set_array_value_float_sp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_sp), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_float_sp + + +!> Retrieve TOML value as double precision floating point number +subroutine set_array_value_float_dp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_dp), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_float_dp + + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i1(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i1), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i1 + + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i2(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i2), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i2 + + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i4(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i4), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i4 + + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i8(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i8), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i8 + + +!> Retrieve TOML value as boolean value +subroutine set_array_value_bool(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Boolean value + logical, intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_bool + + +!> Retrieve TOML value as datetime value +subroutine set_array_value_datetime(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Datetime value + type(toml_datetime), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_datetime + + +end module tomlf_build_array diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 new file mode 100644 index 000000000..165df7e35 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/build_keyval.f90 @@ -0,0 +1,589 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build a TOML values +!> +!> The build module defines an interface to work with TOML values instead +!> of accessing the raw value directly. Both setter and getter routines defined +!> here are rarely needed in any user context, but serve as a basic building +!> block to define uniform access methods for TOML tables and arrays. +module tomlf_build_keyval + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp, TOML_NEWLINE + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, len + use tomlf_utils, only : toml_escape_string, to_string + implicit none + private + + public :: get_value, set_value + + + !> Setter functions to manipulate TOML values + interface set_value + module procedure :: set_value_float_sp + module procedure :: set_value_float_dp + module procedure :: set_value_integer_i1 + module procedure :: set_value_integer_i2 + module procedure :: set_value_integer_i4 + module procedure :: set_value_integer_i8 + module procedure :: set_value_bool + module procedure :: set_value_datetime + module procedure :: set_value_string + end interface set_value + + + !> Getter functions to manipulate TOML values + interface get_value + module procedure :: get_value_float_sp + module procedure :: get_value_float_dp + module procedure :: get_value_integer_i1 + module procedure :: get_value_integer_i2 + module procedure :: get_value_integer_i4 + module procedure :: get_value_integer_i8 + module procedure :: get_value_bool + module procedure :: get_value_datetime + module procedure :: get_value_string + end interface get_value + + + !> Length for the static character variables + integer, parameter :: buffersize = 128 + + +contains + + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_value_float_sp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Real value + real(tf_sp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + real(tfr), pointer :: dummy + integer(tfi), pointer :: idummy + + call self%get(dummy) + if (associated(dummy)) then + val = real(dummy, tf_sp) + info = toml_stat%success + else + call self%get(idummy) + if (associated(idummy)) then + val = real(idummy, tf_sp) + if (nint(val, tfi) == idummy) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_float_sp + + +!> Retrieve TOML value as double precision float +subroutine get_value_float_dp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Real value + real(tf_dp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + real(tfr), pointer :: dummy + integer(tfi), pointer :: idummy + + call self%get(dummy) + if (associated(dummy)) then + val = real(dummy, tf_dp) + info = toml_stat%success + else + call self%get(idummy) + if (associated(idummy)) then + val = real(idummy, tf_dp) + if (nint(val, tfi) == idummy) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_float_dp + + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_value_integer_i1(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i1) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i1 + + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_value_integer_i2(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i2) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i2 + + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_value_integer_i4(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i4) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i4 + + +!> Retrieve TOML value as eight byte integer +subroutine get_value_integer_i8(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i8) + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i8 + + +!> Retrieve TOML value as logical +subroutine get_value_bool(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Boolean value + logical, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + logical, pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_value_datetime(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + type(toml_datetime), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine get_value_string(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + character(:, tfc), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_string + + +!> Set TOML value to single precision float +subroutine set_value_float_sp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(real(val, tfr)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_float_sp + + +!> Set TOML value to double precision float +subroutine set_value_float_dp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(real(val, tfr)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_float_dp + + +!> Set TOML value to one byte integer +subroutine set_value_integer_i1(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i1 + + +!> Set TOML value to two byte integer +subroutine set_value_integer_i2(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i2 + + +!> Set TOML value to four byte integer +subroutine set_value_integer_i4(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i4 + + +!> Set TOML value to eight byte integer +subroutine set_value_integer_i8(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i8 + + +!> Set TOML value to logical +subroutine set_value_bool(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_bool + + +!> Set TOML value to datetime +subroutine set_value_datetime(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_datetime + + +!> Set TOML value to deferred-length character +subroutine set_value_string(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_string + + +end module tomlf_build_keyval diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 new file mode 100644 index 000000000..8c86fe53b --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/build_table.f90 @@ -0,0 +1,1474 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build TOML tables +!> +!> The build module defines a high level interface to work with TOML tables +!> and construct them in a convenient way. +!> +!> The getter functions allow to both retrieve and set values, to easily +!> support default values when reading from a TOML data structure. +!> Using the getter function with a default value specified will request +!> the respective setter function to add it to the table if it was not +!> found in the first place. +!> +!> This allows to build a TOML table using only the getter functions, which +!> represents the finally read values for the applications. +!> +!> Note that neither setter nor getter functions can overwrite existing +!> TOML values for safety reasons, request the deletion on the respective +!> key from the TOML table and than set it. The deletion of a subtable or +!> array will recursively destroy the contained data nodes. +module tomlf_build_table + use tomlf_build_keyval, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, & + & toml_key, cast_to_table, cast_to_array, cast_to_keyval, initialized, & + & len + implicit none + private + + public :: get_value, set_value + + + !> Setter functions to manipulate TOML tables + interface set_value + module procedure :: set_child_value_float_sp + module procedure :: set_child_value_float_dp + module procedure :: set_child_value_integer_i1 + module procedure :: set_child_value_integer_i2 + module procedure :: set_child_value_integer_i4 + module procedure :: set_child_value_integer_i8 + module procedure :: set_child_value_bool + module procedure :: set_child_value_datetime + module procedure :: set_child_value_string + module procedure :: set_key_value_float_sp + module procedure :: set_key_value_float_dp + module procedure :: set_key_value_integer_i1 + module procedure :: set_key_value_integer_i2 + module procedure :: set_key_value_integer_i4 + module procedure :: set_key_value_integer_i8 + module procedure :: set_key_value_bool + module procedure :: set_key_value_datetime + module procedure :: set_key_value_string + end interface set_value + + + !> Getter functions to manipulate TOML tables + interface get_value + module procedure :: get_child_table + module procedure :: get_child_array + module procedure :: get_child_keyval + module procedure :: get_child_value_float_sp + module procedure :: get_child_value_float_dp + module procedure :: get_child_value_integer_i1 + module procedure :: get_child_value_integer_i2 + module procedure :: get_child_value_integer_i4 + module procedure :: get_child_value_integer_i8 + module procedure :: get_child_value_bool + module procedure :: get_child_value_datetime + module procedure :: get_child_value_string + module procedure :: get_key_table + module procedure :: get_key_array + module procedure :: get_key_keyval + module procedure :: get_key_value_float_sp + module procedure :: get_key_value_float_dp + module procedure :: get_key_value_integer_i1 + module procedure :: get_key_value_integer_i2 + module procedure :: get_key_value_integer_i4 + module procedure :: get_key_value_integer_i8 + module procedure :: get_key_value_bool + module procedure :: get_key_value_datetime + module procedure :: get_key_value_string + end interface get_value + + +contains + + +subroutine get_key_table(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_table + + +subroutine get_key_array(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_array + + +subroutine get_key_keyval(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_keyval + + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_key_value_float_sp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_float_sp + + +!> Retrieve TOML value as double precision float +subroutine get_key_value_float_dp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_float_dp + + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_key_value_integer_i1(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i1 + + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_key_value_integer_i2(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i2 + + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_key_value_integer_i4(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i4 + + +!> Retrieve TOML value as eight byte integer +subroutine get_key_value_integer_i8(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i8 + + +!> Retrieve TOML value as logical +subroutine get_key_value_bool(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_key_value_datetime(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine get_key_value_string(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_string + + +!> Set TOML value to single precision float +subroutine set_key_value_float_sp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_float_sp + + +!> Set TOML value to double precision float +subroutine set_key_value_float_dp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_float_dp + + +!> Set TOML value to one byte integer +subroutine set_key_value_integer_i1(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i1 + + +!> Set TOML value to two byte integer +subroutine set_key_value_integer_i2(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i2 + + +!> Set TOML value to four byte integer +subroutine set_key_value_integer_i4(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i4 + + +!> Set TOML value to eight byte integer +subroutine set_key_value_integer_i8(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i8 + + +!> Set TOML value to logical +subroutine set_key_value_bool(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_bool + + +!> Set TOML value to datetime +subroutine set_key_value_datetime(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_datetime + + +!> Set TOML value to deferred-length character +subroutine set_key_value_string(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_string + + +subroutine get_child_table(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_table(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_table + + +subroutine get_child_array(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_array(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_array(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_array + + +subroutine get_child_keyval(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_keyval(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_keyval(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_keyval + + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_child_value_float_sp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_float_sp + + +!> Retrieve TOML value as double precision float +subroutine get_child_value_float_dp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_float_dp + + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_child_value_integer_i1(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i1 + + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_child_value_integer_i2(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i2 + + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_child_value_integer_i4(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i4 + + +!> Retrieve TOML value as eight byte integer +subroutine get_child_value_integer_i8(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i8 + + +!> Retrieve TOML value as logical +subroutine get_child_value_bool(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_child_value_datetime(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine get_child_value_string(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_string + + +!> Set TOML value to single precision float +subroutine set_child_value_float_sp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_float_sp + + +!> Set TOML value to double precision float +subroutine set_child_value_float_dp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_float_dp + + +!> Set TOML value to one byte integer +subroutine set_child_value_integer_i1(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i1 + + +!> Set TOML value to two byte integer +subroutine set_child_value_integer_i2(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i2 + + +!> Set TOML value to four byte integer +subroutine set_child_value_integer_i4(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i4 + + +!> Set TOML value to eight byte integer +subroutine set_child_value_integer_i8(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i8 + + +!> Set TOML value to logical +subroutine set_child_value_bool(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_bool + + +!> Set TOML value to datetime +subroutine set_child_value_datetime(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_datetime + + +!> Set TOML value to deferred-length character +subroutine set_child_value_string(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_string + + +end module tomlf_build_table diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/merge.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/merge.f90 new file mode 100644 index 000000000..be8b63fd7 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/merge.f90 @@ -0,0 +1,214 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Merge TOML data structures, the merge policy can be adjusted. +!> +!> Note that the context information cannot be preserved. +module tomlf_build_merge + use tomlf_constants, only : tfc + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_value, & + & toml_key, cast_to_keyval, len + implicit none + private + + public :: merge_table, merge_array, merge_policy, toml_merge_config + + + !> Possible merge policies + type :: enum_policy + + !> Overwrite existing values + integer :: overwrite = 1 + + !> Preserve existing values + integer :: preserve = 2 + + !> Append to existing values + integer :: append = 3 + end type enum_policy + + !> Actual enumerator for merging data structures + type(enum_policy), parameter :: merge_policy = enum_policy() + + + !> Configuration for merging data structures + type :: toml_merge_config + + !> Policy for merging tables + integer :: table = merge_policy%append + + !> Policy for merging arrays + integer :: array = merge_policy%preserve + + !> Policy for merging values + integer :: keyval = merge_policy%preserve + end type toml_merge_config + + !> Constructor for merge configuration + interface toml_merge_config + module procedure :: new_merge_config + end interface toml_merge_config + + +contains + + +!> Create a new merge configuration +pure function new_merge_config(table, array, keyval) result(config) + + !> Policy for merging tables + character(*), intent(in), optional :: table + + !> Policy for merging arrays + character(*), intent(in), optional :: array + + !> Policy for merging values + character(*), intent(in), optional :: keyval + + !> Merge policy + type(toml_merge_config) :: config + + if (present(table)) call set_enum(config%table, table) + if (present(array)) call set_enum(config%array, array) + if (present(keyval)) call set_enum(config%keyval, keyval) + +contains + + pure subroutine set_enum(enum, str) + character(*), intent(in) :: str + integer, intent(inout) :: enum + + select case(str) + case("append") + enum = merge_policy%append + case("overwrite") + enum = merge_policy%overwrite + case("preserve") + enum = merge_policy%preserve + end select + end subroutine set_enum + +end function new_merge_config + + +!> Merge TOML tables by appending their values +recursive subroutine merge_table(lhs, rhs, config) + + !> Instance of table to merge into + class(toml_table), intent(inout) :: lhs + + !> Instance of table to be merged + class(toml_table), intent(inout) :: rhs + + !> Merge policy + type(toml_merge_config), intent(in), optional :: config + + type(toml_merge_config) :: policy + type(toml_key), allocatable :: list(:) + class(toml_value), pointer :: ptr1, ptr2 + class(toml_keyval), pointer :: kv + class(toml_value), allocatable :: tmp + logical :: has_key + integer :: i, n, stat + + policy = toml_merge_config() + if (present(config)) policy = config + + call rhs%get_keys(list) + n = size(list, 1) + + do i = 1, n + if (allocated(tmp)) deallocate(tmp) + call rhs%get(list(i)%key, ptr1) + has_key = lhs%has_key(list(i)%key) + select type(ptr1) + class is(toml_keyval) + if (has_key .and. policy%keyval == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + kv => cast_to_keyval(tmp) + kv%origin_value = 0 + kv%origin = 0 + call lhs%push_back(tmp, stat) + end if + + class is(toml_array) + if (has_key .and. policy%array == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (has_key .and. policy%array == merge_policy%append) then + call lhs%get(list(i)%key, ptr2) + select type(ptr2) + class is(toml_array) + call merge_array(ptr2, ptr1) + end select + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + tmp%origin = 0 + call lhs%push_back(tmp, stat) + end if + + class is(toml_table) + if (has_key .and. policy%table == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (has_key .and. policy%table == merge_policy%append) then + call lhs%get(list(i)%key, ptr2) + select type(ptr2) + class is(toml_table) + call merge_table(ptr2, ptr1, policy) + end select + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + tmp%origin = 0 + call lhs%push_back(tmp, stat) + end if + end select + end do + +end subroutine merge_table + + +!> Append values from one TOML array to another +recursive subroutine merge_array(lhs, rhs) + + !> Instance of array to merge into + class(toml_array), intent(inout) :: lhs + + !> Instance of array to be merged + class(toml_array), intent(inout) :: rhs + + class(toml_value), pointer :: ptr + class(toml_value), allocatable :: tmp + integer :: n, i, stat + + n = len(rhs) + + do i = 1, n + call rhs%get(i, ptr) + if (allocated(tmp)) deallocate(tmp) + allocate(tmp, source=ptr) + call lhs%push_back(tmp, stat) + end do + +end subroutine merge_array + + +end module tomlf_build_merge diff --git a/source/third_party_open/utils/toml-f/src/tomlf/build/path.f90 b/source/third_party_open/utils/toml-f/src/tomlf/build/path.f90 new file mode 100644 index 000000000..b9a9ee693 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/build/path.f90 @@ -0,0 +1,802 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Support for retrieving and setting values using a key path. +module tomlf_build_path + use tomlf_build_table, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_key + implicit none + private + + public :: toml_path, get_value, set_value + + + !> Setter functions to manipulate TOML tables + interface set_value + module procedure :: set_path_value_float_sp + module procedure :: set_path_value_float_dp + module procedure :: set_path_value_integer_i1 + module procedure :: set_path_value_integer_i2 + module procedure :: set_path_value_integer_i4 + module procedure :: set_path_value_integer_i8 + module procedure :: set_path_value_bool + module procedure :: set_path_value_datetime + module procedure :: set_path_value_string + end interface set_value + + + !> Getter functions to manipulate TOML tables + interface get_value + module procedure :: get_path_table + module procedure :: get_path_array + module procedure :: get_path_keyval + module procedure :: get_path_value_float_sp + module procedure :: get_path_value_float_dp + module procedure :: get_path_value_integer_i1 + module procedure :: get_path_value_integer_i2 + module procedure :: get_path_value_integer_i4 + module procedure :: get_path_value_integer_i8 + module procedure :: get_path_value_bool + module procedure :: get_path_value_datetime + module procedure :: get_path_value_string + end interface get_value + + + !> Wrapper for storing key paths + type :: toml_path + !> Path components + type(toml_key), allocatable :: path(:) + end type toml_path + + + !> Convenience constructors for building key paths from strings instead of keys + interface toml_path + module procedure :: new_path2 + module procedure :: new_path3 + module procedure :: new_path4 + end interface toml_path + + +contains + + +!> Create a new path with two components +pure function new_path2(key1, key2) result(path) + + !> First key to retrieve + character(*), intent(in) :: key1 + + !> Second key to retrieve + character(*), intent(in) :: key2 + + !> New path + type(toml_path) :: path + + allocate(path%path(2)) + path%path(:) = [toml_key(key1), toml_key(key2)] +end function new_path2 + + +!> Create a new path with three components +pure function new_path3(key1, key2, key3) result(path) + + !> First key to retrieve + character(*, tfc), intent(in) :: key1 + + !> Second key to retrieve + character(*, tfc), intent(in) :: key2 + + !> Third key to retrieve + character(*, tfc), intent(in) :: key3 + + !> New path + type(toml_path) :: path + + allocate(path%path(3)) + path%path(:) = [toml_key(key1), toml_key(key2), toml_key(key3)] +end function new_path3 + + +!> Create a new path with three components +pure function new_path4(key1, key2, key3, key4) result(path) + + !> First key to retrieve + character(*, tfc), intent(in) :: key1 + + !> Second key to retrieve + character(*, tfc), intent(in) :: key2 + + !> Third key to retrieve + character(*, tfc), intent(in) :: key3 + + !> Forth key to retrieve + character(*, tfc), intent(in) :: key4 + + !> New path + type(toml_path) :: path + + allocate(path%path(4)) + path%path(:) = [toml_key(key1), toml_key(key2), toml_key(key3), toml_key(key4)] +end function new_path4 + + +subroutine get_path_table(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout), target :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_table + + +subroutine get_path_array(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_array + + +subroutine get_path_keyval(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_keyval + + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_path_value_float_sp(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_float_sp + + +!> Retrieve TOML value as double precision float +subroutine get_path_value_float_dp(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_float_dp + + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_path_value_integer_i1(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i1 + + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_path_value_integer_i2(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i2 + + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_path_value_integer_i4(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i4 + + +!> Retrieve TOML value as eight byte integer +subroutine get_path_value_integer_i8(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i8 + + +!> Retrieve TOML value as logical +subroutine get_path_value_bool(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_bool + + +!> Retrieve TOML value as datetime +subroutine get_path_value_datetime(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_datetime + + +!> Retrieve TOML value as deferred-length character +subroutine get_path_value_string(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_string + + +!> Set TOML value to single precision float +subroutine set_path_value_float_sp(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_float_sp + + +!> Set TOML value to double precision float +subroutine set_path_value_float_dp(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_float_dp + + +!> Set TOML value to one byte integer +subroutine set_path_value_integer_i1(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i1 + + +!> Set TOML value to two byte integer +subroutine set_path_value_integer_i2(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i2 + + +!> Set TOML value to four byte integer +subroutine set_path_value_integer_i4(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i4 + + +!> Set TOML value to eight byte integer +subroutine set_path_value_integer_i8(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i8 + + +!> Set TOML value to logical +subroutine set_path_value_bool(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_bool + + +!> Set TOML value to datetime +subroutine set_path_value_datetime(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_datetime + + +!> Set TOML value to deferred-length character +subroutine set_path_value_string(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_string + + +subroutine walk_path(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout), target :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + type(toml_table), pointer :: current, next + + nullify(ptr) + if (.not.allocated(path%path)) then + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = table%origin + return + end if + + current => table + do it = 1, size(path%path) - 1 + call get_value(current, path%path(it)%key, next, requested, stat, origin) + if (.not.associated(next)) then + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = current%origin + return + end if + current => next + end do + ptr => current +end subroutine walk_path + + +end module tomlf_build_path diff --git a/source/third_party_open/utils/toml-f/src/tomlf/constants.f90 b/source/third_party_open/utils/toml-f/src/tomlf/constants.f90 new file mode 100644 index 000000000..a85e557ab --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/constants.f90 @@ -0,0 +1,145 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +module tomlf_constants + use, intrinsic :: iso_fortran_env, only : output_unit + implicit none + private + + !> Single precision real numbers + integer, public, parameter :: tf_sp = selected_real_kind(6) + + !> Double precision real numbers + integer, public, parameter :: tf_dp = selected_real_kind(15) + + !> Char length for integers + integer, public, parameter :: tf_i1 = selected_int_kind(2) + + !> Short length for integers + integer, public, parameter :: tf_i2 = selected_int_kind(4) + + !> Length of default integers + integer, public, parameter :: tf_i4 = selected_int_kind(9) + + !> Long length for integers + integer, public, parameter :: tf_i8 = selected_int_kind(18) + + + !> Default character kind + integer, public, parameter :: tfc = selected_char_kind('DEFAULT') + + !> Default float precision, IEEE 754 binary64 values expected + integer, public, parameter :: tfr = tf_dp + + !> Default integer precision, 64 bit (signed long) range expected + integer, public, parameter :: tfi = tf_i8 + + !> Default output channel + integer, public, parameter :: tfout = output_unit + + + !> Possible escape characters in TOML + type :: enum_escape + + !> Backslash is used to escape other characters + character(kind=tfc, len=1) :: backslash = tfc_'\' + + !> Double quotes signal strings with escape characters enabled + character(kind=tfc, len=1) :: dquote = tfc_'"' + + !> Single quotes signal strings without escape characters enabled + character(kind=tfc, len=1) :: squote = tfc_'''' + + !> Newline character + character(kind=tfc, len=1) :: newline = achar(10, kind=tfc) + + !> Formfeed character is allowed in strings + character(kind=tfc, len=1) :: formfeed = achar(12, kind=tfc) + + !> Carriage return is allowed as part of the newline and in strings + character(kind=tfc, len=1) :: carriage_return = achar(13, kind=tfc) + + !> Backspace is allowed in strings + character(kind=tfc, len=1) :: bspace = achar(8, kind=tfc) + + !> Tabulators are allowed as whitespace and in strings + character(kind=tfc, len=1) :: tabulator = achar(9, kind=tfc) + + end type enum_escape + + !> Actual enumerator with TOML escape characters + type(enum_escape), public, parameter :: toml_escape = enum_escape() + + + !> Possible kinds of TOML values in key-value pairs + type :: enum_type + + !> Invalid type + integer :: invalid = 100 + + !> String type + integer :: string = 101 + + !> Boolean type + integer :: boolean = 102 + + !> Integer type + integer :: int = 103 + + !> Float type + integer :: float = 104 + + !> Datetime type + integer :: datetime = 105 + + end type enum_type + + !> Actual enumerator with TOML value types + type(enum_type), public, parameter :: toml_type = enum_type() + + + !> Single quotes denote literal strings + character(kind=tfc, len=*), public, parameter :: TOML_SQUOTE = "'" + !> Double quotes denote strings (with escape character possible) + character(kind=tfc, len=*), public, parameter :: TOML_DQUOTE = '"' + character(kind=tfc, len=*), public, parameter :: TOML_NEWLINE = new_line('a') ! \n + character(kind=tfc, len=*), public, parameter :: TOML_TABULATOR = achar(9) ! \t + character(kind=tfc, len=*), public, parameter :: TOML_FORMFEED = achar(12) ! \f + character(kind=tfc, len=*), public, parameter :: TOML_CARRIAGE_RETURN = achar(13) ! \r + character(kind=tfc, len=*), public, parameter :: TOML_BACKSPACE = achar(8) ! \b + character(kind=tfc, len=*), public, parameter :: TOML_ESC = achar(27) ! \e + character(kind=tfc, len=*), public, parameter :: TOML_LOWERCASE = & + & 'abcdefghijklmnopqrstuvwxyz' + character(kind=tfc, len=*), public, parameter :: TOML_UPPERCASE = & + & 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(kind=tfc, len=*), public, parameter :: TOML_LETTERS = & + & TOML_LOWERCASE//TOML_UPPERCASE + !> Whitespace in TOML are blanks and tabs. + character(kind=tfc, len=*), public, parameter :: TOML_WHITESPACE = & + & ' '//toml_escape%tabulator + character(kind=tfc, len=*), public, parameter :: TOML_DIGITS = '0123456789' + character(kind=tfc, len=*), public, parameter :: TOML_BINDIGITS = & + & '01' + character(kind=tfc, len=*), public, parameter :: TOML_OCTDIGITS = & + & '01234567' + character(kind=tfc, len=*), public, parameter :: TOML_HEXDIGITS = & + & '0123456789ABCDEFabcdef' + character(kind=tfc, len=*), public, parameter :: TOML_TIMESTAMP = & + & TOML_DIGITS//'.:+-T Zz' + !> Allowed characters in TOML bare keys. + character(kind=tfc, len=*), public, parameter :: TOML_BAREKEY = & + & TOML_LETTERS//TOML_DIGITS//'_-' + character(kind=tfc, len=*), public, parameter :: TOML_LITERALS = & + & TOML_LETTERS//TOML_DIGITS//'_-+.' + +end module tomlf_constants diff --git a/source/third_party_open/utils/toml-f/src/tomlf/datetime.f90 b/source/third_party_open/utils/toml-f/src/tomlf/datetime.f90 new file mode 100644 index 000000000..b8b8c9b73 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/datetime.f90 @@ -0,0 +1,352 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML datetime value representation +!> +!> This module provides the [[toml_datetime]] type for representing TOML +!> datetime values. TOML supports four datetime formats: +!> +!> - Offset date-time: `1979-05-27T07:32:00Z` +!> - Local date-time: `1979-05-27T07:32:00` +!> - Local date: `1979-05-27` +!> - Local time: `07:32:00` +!> +!> The [[toml_datetime]] type combines [[toml_date]] and [[toml_time]] +!> components to represent any of these formats. +module tomlf_datetime + use tomlf_constants, only : tfc + implicit none + private + + public :: toml_datetime, toml_time, toml_date, to_string, has_date, has_time + public :: operator(==) + + + !> TOML time value (HH:MM:SS.sssssZ...) + type :: toml_time + integer :: hour = -1 + integer :: minute = -1 + integer :: second = -1 + integer :: msec = -1 + character(len=:), allocatable :: zone + end type + + interface toml_time + module procedure :: new_toml_time + end interface toml_time + + + !> TOML date value (YYYY-MM-DD) + type :: toml_date + integer :: year = -1 + integer :: month = -1 + integer :: day = -1 + end type + + + !> TOML datatime value type + type :: toml_datetime + type(toml_date) :: date + type(toml_time) :: time + end type + + + !> Create a new TOML datetime value + interface toml_datetime + module procedure :: new_datetime + module procedure :: new_datetime_from_string + end interface toml_datetime + + + interface operator(==) + module procedure :: compare_datetime + end interface operator(==) + + + interface to_string + module procedure :: to_string_datetime + end interface to_string + + +contains + + +pure function new_datetime(year, month, day, hour, minute, second, msecond, zone) & + & result(datetime) + integer, intent(in), optional :: year + integer, intent(in), optional :: month + integer, intent(in), optional :: day + integer, intent(in), optional :: hour + integer, intent(in), optional :: minute + integer, intent(in), optional :: second + integer, intent(in), optional :: msecond + character(len=*), intent(in), optional :: zone + type(toml_datetime) :: datetime + + if (present(year) .and. present(month) .and. present(day)) then + datetime%date%year = year + datetime%date%month = month + datetime%date%day = day + end if + + if (present(hour) .and. present(minute) .and. present(second)) then + datetime%time%hour = hour + datetime%time%minute = minute + datetime%time%second = second + if (present(msecond)) then + datetime%time%msec = msecond + end if + if (present(zone)) then + datetime%time%zone = zone + end if + end if +end function new_datetime + + +pure function new_datetime_from_string(string) result(datetime) + character(len=*), intent(in) :: string + type(toml_datetime) :: datetime + + type(toml_date) :: date + type(toml_time) :: time + + integer :: it, tmp, first + character(*, tfc), parameter :: num = "0123456789" + integer, allocatable :: msec(:) + logical :: has_seconds + + first = 0 + + if (all([string(first+5:first+5), string(first+8:first+8)] == "-")) then + date%year = 0 + do it = first + 1, first + 4 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%year = date%year * 10 + tmp + end do + + date%month = 0 + do it = first + 6, first + 7 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%month = date%month * 10 + tmp + end do + + date%day = 0 + do it = first + 9, first + 10 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%day = date%day * 10 + tmp + end do + + first = first + 11 + datetime%date = date + end if + + if (first >= len(string)) return + ! Check for time: HH:MM format (colon at position 3) + if (string(first+3:first+3) == ":") then + time%hour = 0 + do it = first + 1, first + 2 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%hour = time%hour * 10 + tmp + end do + + time%minute = 0 + do it = first + 4, first + 5 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%minute = time%minute * 10 + tmp + end do + + ! Check for optional seconds (TOML 1.1) + has_seconds = first + 6 <= len(string) .and. string(first+6:first+6) == ":" + if (has_seconds) then + time%second = 0 + do it = first + 7, first + 8 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%second = time%second * 10 + tmp + end do + first = first + 8 + else + ! No seconds - keep time%second as default (-1) + first = first + 5 + end if + + if (first < len(string)) then + if (string(first+1:first+1) == ".") then + msec = [integer::] + do it = first + 2, len(string) + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + msec = [msec, tmp] + end do + first = it - 1 + + msec = [msec, 0, 0, 0, 0, 0, 0] + time%msec = sum(msec(1:6) * [100000, 10000, 1000, 100, 10, 1]) + end if + end if + + if (first < len(string)) then + time%zone = "" + do it = first + 1, len(string) + time%zone = time%zone // string(it:it) + end do + if (time%zone == "z") time%zone = "Z" + end if + datetime%time = time + end if + +end function new_datetime_from_string + + +pure function to_string_datetime(datetime) result(str) + type(toml_datetime), intent(in) :: datetime + character(kind=tfc, len=:), allocatable :: str + + str = "" + if (has_date(datetime)) then + str = str // to_string_date(datetime%date) + end if + + if (has_time(datetime)) then + if (has_date(datetime)) then + str = str // ' ' + end if + str = str // to_string_time(datetime%time) + end if +end function to_string_datetime + +pure function to_string_date(date) result(str) + type(toml_date), intent(in) :: date + character(:, tfc), allocatable :: str + + allocate(character(10, tfc) :: str) + write(str, '(i4.4,"-",i2.2,"-",i2.2)') & + & date%year, date%month, date%day +end function to_string_date + +pure function to_string_time(time) result(str) + type(toml_time), intent(in) :: time + character(:, tfc), allocatable :: str + + integer :: msec, width + character(1), parameter :: places(6) = ["1", "2", "3", "4", "5", "6"] + + ! Handle optional seconds (TOML 1.1) + if (time%second < 0) then + ! No seconds - output HH:MM format + allocate(character(5, tfc) :: str) + write(str, '(i2.2,":",i2.2)') & + & time%hour, time%minute + else if (time%msec < 0) then + allocate(character(8, tfc) :: str) + write(str, '(i2.2,":",i2.2,":",i2.2)') & + & time%hour, time%minute, time%second + else + width = 6 + msec = time%msec + do while(mod(msec, 10) == 0 .and. width > 3) + width = width - 1 + msec = msec / 10 + end do + allocate(character(9 + width, tfc) :: str) + write(str, '(i2.2,":",i2.2,":",i2.2,".",i'//places(width)//'.'//places(width)//')') & + & time%hour, time%minute, time%second, msec + end if + if (allocated(time%zone)) str = str // trim(time%zone) +end function to_string_time + + +pure function has_date(datetime) + class(toml_datetime), intent(in) :: datetime + logical :: has_date + has_date = (datetime%date%year >= 0) .and. & + & (datetime%date%month >= 0) .and. & + & (datetime%date%day >= 0) +end function has_date + +pure function has_time(datetime) + class(toml_datetime), intent(in) :: datetime + logical :: has_time + has_time = (datetime%time%hour >= 0) .and. & + & (datetime%time%minute >= 0) +end function has_time + + +!> Constructor for toml_time type, necessary due to PGI bug in NVHPC 20.7 and 20.9 +elemental function new_toml_time(hour, minute, second, msec, zone) & + & result(self) + integer, intent(in), optional :: hour + integer, intent(in), optional :: minute + integer, intent(in), optional :: second + integer, intent(in), optional :: msec + character(len=*), intent(in), optional :: zone + type(toml_time) :: self + if (present(hour)) self%hour = hour + if (present(minute)) self%minute = minute + if (present(second)) self%second = second + if (present(msec)) self%msec = msec + if (present(zone)) self%zone = zone +end function new_toml_time + + +pure function compare_datetime(lhs, rhs) result(match) + type(toml_datetime), intent(in) :: lhs + type(toml_datetime), intent(in) :: rhs + logical :: match + + match = (has_date(lhs) .eqv. has_date(rhs)) & + & .and. (has_time(lhs) .eqv. has_time(rhs)) + if (has_date(lhs) .and. has_date(rhs)) then + match = match .and. compare_date(lhs%date, rhs%date) + end if + + if (has_time(lhs) .and. has_time(rhs)) then + match = match .and. compare_time(lhs%time, rhs%time) + end if +end function compare_datetime + + +pure function compare_date(lhs, rhs) result(match) + type(toml_date), intent(in) :: lhs + type(toml_date), intent(in) :: rhs + logical :: match + + match = lhs%year == rhs%year .and. lhs%month == rhs%month .and. lhs%day == rhs%day +end function compare_date + + +pure function compare_time(lhs, rhs) result(match) + type(toml_time), intent(in) :: lhs + type(toml_time), intent(in) :: rhs + logical :: match + + integer :: lms, rms + + lms = max(lhs%msec, 0) + rms = max(rhs%msec, 0) + + match = lhs%hour == rhs%hour .and. lhs%minute == rhs%minute .and. lhs%second == rhs%second & + & .and. lms == rms .and. allocated(lhs%zone) .eqv. allocated(rhs%zone) + + if (allocated(lhs%zone) .and. allocated(rhs%zone)) then + match = match .and. lhs%zone == rhs%zone + end if +end function compare_time + + +end module tomlf_datetime diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de.f90 new file mode 100644 index 000000000..1b96021e6 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de.f90 @@ -0,0 +1,161 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML deserialization module +!> +!> This module provides interfaces for loading and parsing TOML documents +!> from various sources (files, strings, and I/O units). +!> +!> The primary interfaces are: +!> +!> - [[toml_load]]: Load TOML from a file path or connected unit +!> - [[toml_loads]]: Parse TOML from a string +!> +!> All parsing functions return an allocatable [[toml_table]] that contains +!> the parsed document. If parsing fails, the table will not be allocated +!> and error information is provided via the optional error argument. +module tomlf_de + use tomlf_constants, only : tfc, TOML_NEWLINE + use tomlf_de_context, only : toml_context + use tomlf_de_lexer, only : toml_lexer, new_lexer_from_string, new_lexer_from_unit, & + & new_lexer_from_file + use tomlf_de_parser, only : parse, toml_parser_config + use tomlf_diagnostic, only : toml_level + use tomlf_error, only : toml_error + use tomlf_type, only : toml_table + implicit none + private + + public :: toml_parse + public :: toml_load, toml_loads + public :: toml_context, toml_parser_config, toml_level + + + !> Parse a TOML document. + !> + !> This interface is deprecated in favor of [[toml_load]] and [[toml_loads]] + interface toml_parse + module procedure :: toml_parse_unit + module procedure :: toml_parse_string + end interface toml_parse + + !> Load a TOML data structure from the provided source + interface toml_load + module procedure :: toml_load_file + module procedure :: toml_load_unit + end interface toml_load + + !> Load a TOML data structure from a string + interface toml_loads + module procedure :: toml_load_string + end interface toml_loads + + +contains + + +!> Parse a TOML input from a given IO unit. +!> +!> @note This procedure is deprectated +subroutine toml_parse_unit(table, unit, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> Unit to read from + integer, intent(in) :: unit + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + call toml_load(table, unit, error=error) +end subroutine toml_parse_unit + +!> Wrapper to parse a TOML string. +!> +!> @note This procedure is deprectated +subroutine toml_parse_string(table, string, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> String containing TOML document + character(len=*), intent(in), target :: string + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + call toml_loads(table, string, error=error) +end subroutine toml_parse_string + +!> Load TOML data structure from file +subroutine toml_load_file(table, filename, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + character(*, tfc), intent(in) :: filename + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + type(toml_error), allocatable :: error_ + + call new_lexer_from_file(lexer, filename, error_) + if (.not.allocated(error_)) then + call parse(lexer, table, config, context, error) + else + if (present(error)) call move_alloc(error_, error) + end if +end subroutine toml_load_file + +!> Load TOML data structure from unit +subroutine toml_load_unit(table, io, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> Unit to read from + integer, intent(in) :: io + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + type(toml_error), allocatable :: error_ + + call new_lexer_from_unit(lexer, io, error_) + if (.not.allocated(error_)) then + call parse(lexer, table, config, context, error) + else + if (present(error)) call move_alloc(error_, error) + end if +end subroutine toml_load_unit + +!> Load TOML data structure from string +subroutine toml_load_string(table, string, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> String containing TOML document + character(*, tfc), intent(in) :: string + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + + call new_lexer_from_string(lexer, string) + call parse(lexer, table, config, context, error) +end subroutine toml_load_string + +end module tomlf_de diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/abc.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/abc.f90 new file mode 100644 index 000000000..3b2b1a73a --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/abc.f90 @@ -0,0 +1,126 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Defines the abstract base class which is implemented by the TOML lexer. +module tomlf_de_abc + use tomlf_constants, only : tfc, tfi, tfr + use tomlf_datetime, only : toml_datetime + use tomlf_de_token, only : toml_token + implicit none + private + + public :: abstract_lexer + + + !> Abstract base class for TOML lexers. + type, abstract :: abstract_lexer + contains + !> Obtain the next token + procedure(next), deferred :: next + !> Extract a token + generic :: extract => & + & extract_string, extract_integer, extract_float, extract_bool, extract_datetime + !> Extract a string from a token + procedure(extract_string), deferred :: extract_string + !> Extract an integer from a token + procedure(extract_integer), deferred :: extract_integer + !> Extract a float from a token + procedure(extract_float), deferred :: extract_float + !> Extract a boolean from a token + procedure(extract_bool), deferred :: extract_bool + !> Extract a timestamp from a token + procedure(extract_datetime), deferred :: extract_datetime + !> Get information about the source + procedure(get_info), deferred :: get_info + end type abstract_lexer + + + abstract interface + !> Advance the lexer to the next token. + subroutine next(lexer, token) + import :: abstract_lexer, toml_token + !> Instance of the lexer + class(abstract_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + end subroutine next + + !> Extract string value of token, works for keypath, string, multiline string, literal, + !> and mulitline literal tokens. + subroutine extract_string(lexer, token, string) + import :: abstract_lexer, toml_token, tfc + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract string value from + type(toml_token), intent(in) :: token + !> String value of token + character(:, tfc), allocatable, intent(out) :: string + end subroutine extract_string + + !> Extract integer value of token + subroutine extract_integer(lexer, token, val) + import :: abstract_lexer, toml_token, tfi + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract integer value from + type(toml_token), intent(in) :: token + !> Integer value of token + integer(tfi), intent(out) :: val + end subroutine extract_integer + + !> Extract floating point value of token + subroutine extract_float(lexer, token, val) + import :: abstract_lexer, toml_token, tfr + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract floating point value from + type(toml_token), intent(in) :: token + !> Floating point value of token + real(tfr), intent(out) :: val + end subroutine extract_float + + !> Extract boolean value of token + subroutine extract_bool(lexer, token, val) + import :: abstract_lexer, toml_token + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract boolean value from + type(toml_token), intent(in) :: token + !> Boolean value of token + logical, intent(out) :: val + end subroutine extract_bool + + !> Extract datetime value of token + subroutine extract_datetime(lexer, token, val) + import :: abstract_lexer, toml_token, toml_datetime + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract datetime value from + type(toml_token), intent(in) :: token + !> Datetime value of token + type(toml_datetime), intent(out) :: val + end subroutine extract_datetime + + !> Extract information about the source + subroutine get_info(lexer, meta, output) + import :: abstract_lexer, tfc + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Query about the source + character(*, tfc), intent(in) :: meta + !> Metadata about the source + character(:, tfc), allocatable, intent(out) :: output + end subroutine get_info + end interface + +end module tomlf_de_abc diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/context.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/context.f90 new file mode 100644 index 000000000..59b904f1b --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/context.f90 @@ -0,0 +1,154 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides a container to store tokens for later use +module tomlf_de_context + use tomlf_constants, only : tfc + use tomlf_de_token, only : toml_token, resize + use tomlf_diagnostic, only : toml_diagnostic, toml_label, render, toml_level + use tomlf_terminal, only : toml_terminal + implicit none + private + + public :: toml_context + + !> Container storing tokens + type :: toml_context + !> Filename of the input + character(:, tfc), allocatable :: filename + !> Actual source + character(:, tfc), allocatable :: source + !> Stack of stored tokens + type(toml_token), allocatable :: token(:) + !> Last stored token + integer :: top = 0 + contains + !> Push a new token to the stack + procedure :: push_back + !> Create a report + generic :: report => report1, report2 + !> Create a report with a single label + procedure :: report1 + !> Create a report with a two labels + procedure :: report2 + end type toml_context + +contains + +!> Push a new token to the stack +subroutine push_back(self, token) + !> Instance of the token storage + class(toml_context), intent(inout) :: self + !> New token to be added + type(toml_token), intent(in) :: token + + if (.not.allocated(self%token)) call resize(self%token) + if (self%top >= size(self%token)) call resize(self%token) + + self%top = self%top + 1 + self%token(self%top) = token +end subroutine push_back + +!> Create a report with a single label +pure function report1(self, message, origin, label, level, color) result(string) + !> Instance of the token storage + class(toml_context), intent(in) :: self + !> Message for the report + character(*, tfc), intent(in) :: message + !> Position to report at + integer, intent(in) :: origin + !> String for the label + character(*, tfc), intent(in), optional :: label + !> Highlight level + integer, intent(in), optional :: level + !> Color terminal + type(toml_terminal), intent(in), optional :: color + !> Final rendered report + character(:, tfc), allocatable :: string + + type(toml_diagnostic) :: diagnostic + type(toml_label), allocatable :: labels(:) + integer :: level_ + + level_ = toml_level%error + if (present(level)) level_ = level + + if (origin > 0 .and. origin <= self%top) then + allocate(labels(1)) + labels(1) = toml_label(level_, & + & self%token(origin)%first, self%token(origin)%last, label, .true.) + end if + + diagnostic = toml_diagnostic( & + & level_, & + & message, & + & self%filename, & + & labels) + + if (.not.present(color)) then + string = render(diagnostic, self%source, toml_terminal(.false.)) + else + string = render(diagnostic, self%source, color) + end if +end function report1 + +!> Create a report with two labels +pure function report2(self, message, origin1, origin2, label1, label2, level1, level2, color) & + & result(string) + !> Instance of the token storage + class(toml_context), intent(in) :: self + !> Message for the report + character(*, tfc), intent(in) :: message + !> Position to report at + integer, intent(in) :: origin1, origin2 + !> String for the label + character(*, tfc), intent(in), optional :: label1, label2 + !> Highlight level + integer, intent(in), optional :: level1, level2 + !> Color terminal + type(toml_terminal), intent(in), optional :: color + !> Final rendered report + character(:, tfc), allocatable :: string + + type(toml_diagnostic) :: diagnostic + type(toml_label), allocatable :: labels(:) + integer :: level1_, level2_ + + level1_ = toml_level%error + if (present(level1)) level1_ = level1 + level2_ = toml_level%info + if (present(level2)) level2_ = level2 + + if (origin1 > 0 .and. origin1 <= self%top & + & .and. origin2 > 0 .and. origin2 <= self%top) then + allocate(labels(2)) + labels(1) = toml_label(level1_, & + & self%token(origin1)%first, self%token(origin1)%last, label1, .true.) + labels(2) = toml_label(level2_, & + & self%token(origin2)%first, self%token(origin2)%last, label2, .false.) + end if + + diagnostic = toml_diagnostic( & + & level1_, & + & message, & + & self%filename, & + & labels) + + if (.not.present(color)) then + string = render(diagnostic, self%source, toml_terminal(.false.)) + else + string = render(diagnostic, self%source, color) + end if +end function report2 + +end module tomlf_de_context diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 new file mode 100644 index 000000000..6710b5f6e --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/lexer.f90 @@ -0,0 +1,1582 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides tokenization for TOML documents. +!> +!> The lexer provides a way to turn a stream of characters into tokens which +!> are further processed by the parser and turned into actual TOML data structures. +!> In the current structure no knowledge about the character stream is required +!> in the parser to generate the data structures. +!> +!> The validity of all tokens can be guaranteed by the lexer, however syntax errors +!> and semantic errors are not detected until the parser is run. Identification of +!> invalid tokens and recovery of the tokenization is done on a best effort basis. +!> +!> To avoid overflows in the parser due to deeply nested but unclosed groups, the +!> lexer will always tokenize a complete group to verify it is closed properly. +!> Unclosed groups will lead to the first token of the group getting invalidated, +!> to allow reporting in the parsing phase. +module tomlf_de_lexer + use tomlf_constants, only : tfc, tfi, tfr, TOML_BACKSPACE, TOML_TABULATOR, TOML_NEWLINE, & + & TOML_CARRIAGE_RETURN, TOML_FORMFEED, TOML_ESC + use tomlf_datetime, only : toml_datetime, toml_date, toml_time + use tomlf_de_abc, only : abstract_lexer + use tomlf_de_context, only : toml_context + use tomlf_de_token, only : toml_token, stringify, token_kind, resize + use tomlf_error, only : toml_error, toml_stat, make_error + use tomlf_utils, only : read_whole_file, read_whole_line + implicit none + private + + public :: toml_lexer, new_lexer_from_file, new_lexer_from_unit, new_lexer_from_string + public :: toml_token, stringify, token_kind + + + !> Possible characters encountered in a lexeme + type :: enum_char + character(1, tfc) :: space = tfc_" " + character(1, tfc) :: hash = tfc_"#" + character(1, tfc) :: squote = tfc_"'" + character(3, tfc) :: squote3 = repeat(tfc_"'", 3) + character(1, tfc) :: dquote = tfc_"""" + character(3, tfc) :: dquote3 = repeat(tfc_"""", 3) + character(1, tfc) :: backslash = tfc_"\" + character(1, tfc) :: dot = tfc_"." + character(1, tfc) :: comma = tfc_"," + character(1, tfc) :: equal = tfc_"=" + character(1, tfc) :: lbrace = tfc_"{" + character(1, tfc) :: rbrace = tfc_"}" + character(1, tfc) :: lbracket = tfc_"[" + character(1, tfc) :: rbracket = tfc_"]" + character(1, tfc) :: newline = achar(10, kind=tfc) + character(1, tfc) :: formfeed = achar(12, kind=tfc) + character(1, tfc) :: carriage_return = achar(13, kind=tfc) + character(1, tfc) :: bspace = achar(8, kind=tfc) + character(1, tfc) :: tab = achar(9, kind=tfc) + character(1, tfc) :: plus = tfc_"+" + character(1, tfc) :: minus = tfc_"-" + character(12, tfc) :: literal = tfc_"0123456789-_" + end type enum_char + + !> Actual enumerator for possible characters + type(enum_char), parameter :: char_kind = enum_char() + + !> Set of characters marking a terminated lexeme, mainly used for values and to + !> obtain boundaries of invalid tokens. + character(*, tfc), parameter :: terminated = & + & char_kind%space//char_kind%tab//char_kind%newline//char_kind%carriage_return//& + & char_kind%hash//char_kind%rbrace//char_kind%rbracket//char_kind%comma//& + & char_kind%equal + + !> Scopes to identify the state of the lexer. + type :: enum_scope + !> Table scopes allow keypaths, in this scenario only bare keys, strings and + !> literals are allowed, furthermore dots become special characters to separate + !> the keypaths. + integer :: table = 1 + !> Terminates a table scope and opens a value scope. Here usual values, like integer, + !> floats or strings are allowed. + integer :: equal = 2 + !> Opens an array scope, similar to the value scope for allowed characters but with + !> simplified closing rules to allow handling of values and inline tables in arrays. + integer :: array = 3 + end type enum_scope + + !> Actual enumerator for auxiliary scopes + type(enum_scope), parameter :: lexer_scope = enum_scope() + + !> Item identifying the scope and the corresponding token index + type :: stack_item + !> Current scope of the item, can only be removed with matching scope + integer :: scope + !> Token index in the buffer of the lexer, used for invalidation of unclosed groups + integer :: token + end type stack_item + + !> Reallocate the stack of scopes + interface resize + module procedure :: resize_scope + end interface + + + !> Tokenizer for TOML documents. + type, extends(abstract_lexer) :: toml_lexer + !> Name of the source file, used for error reporting + character(len=:), allocatable :: filename + !> Current internal position in the source chunk + integer :: pos = 0 + !> Current source chunk, for convenience stored as character array rather than string + character(:, tfc), allocatable :: chunk + !> Last scope of the lexer + integer :: top = 0 + !> Stack of scopes, used to identify the current state of the lexer + type(stack_item), allocatable :: stack(:) + !> Index in the buffer queue + integer :: buffer = 0 + !> Douple-ended queue for buffering tokens + type(toml_context) :: context + contains + !> Obtain the next token + procedure :: next + !> Extract a string from a token + procedure :: extract_string + !> Extract an integer from a token + procedure :: extract_integer + !> Extract a float from a token + procedure :: extract_float + !> Extract a boolean from a token + procedure :: extract_bool + !> Extract a timestamp from a token + procedure :: extract_datetime + !> Get information about source + procedure :: get_info + end type toml_lexer + +contains + +!> Create a new instance of a lexer by reading from a file +subroutine new_lexer_from_file(lexer, filename, error) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> Name of the file to read from + character(len=*), intent(in) :: filename + !> Error code + type(toml_error), allocatable, intent(out) :: error + + integer :: stat + + lexer%pos = 0 + lexer%filename = filename + call resize(lexer%stack) + call read_whole_file(filename, lexer%chunk, stat) + + if (stat /= 0) then + call make_error(error, "Could not open file '"//filename//"'") + end if +end subroutine new_lexer_from_file + +!> Create a new instance of a lexer by reading from a unit. +!> +!> Currently, only sequential access units can be processed by this constructor. +subroutine new_lexer_from_unit(lexer, io, error) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> Unit to read from + integer, intent(in) :: io + !> Error code + type(toml_error), allocatable, intent(out) :: error + + character(:, tfc), allocatable :: source, line + integer, parameter :: bufsize = 512 + character(bufsize, tfc) :: filename, mode + integer :: stat + + inquire(unit=io, access=mode, name=filename) + select case(trim(mode)) + case default + stat = 1 + + case("sequential", "SEQUENTIAL") + allocate(character(0) :: source) + do + call read_whole_line(io, line, stat) + if (stat > 0) exit + source = source // line // TOML_NEWLINE + if (stat < 0) then + if (is_iostat_end(stat)) stat = 0 + exit + end if + end do + call new_lexer_from_string(lexer, source) + end select + if (len_trim(filename) > 0) lexer%filename = trim(filename) + + if (stat /= 0) then + call make_error(error, "Failed to read from unit") + end if +end subroutine new_lexer_from_unit + +!> Create a new instance of a lexer by reading from a string. +subroutine new_lexer_from_string(lexer, string) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> String to read from + character(*, tfc), intent(in) :: string + + integer :: length + + length = len(string) + lexer%pos = 0 + lexer%buffer = 0 + allocate(character(length) :: lexer%chunk) + lexer%chunk(:length) = string + call resize(lexer%stack) +end subroutine new_lexer_from_string + + +!> Advance the lexer to the next token. +subroutine next(lexer, token) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + if (lexer%buffer >= lexer%context%top) then + call fill_buffer(lexer) + end if + + lexer%buffer = lexer%buffer + 1 + token = lexer%context%token(lexer%buffer) +end subroutine next + +!> Fill the buffer with tokens, this routine will attempt to create as many tokens as +!> necessary to determine whether all opened groups are closed properly. +!> +!> The state of the buffer can be changed while this routine is running, therefore +!> accessing the buffer concurrently is not allowed. +subroutine fill_buffer(lexer) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + type(toml_token) :: token + integer :: stack_top, it + + lexer%buffer = 0 + lexer%context%top = 0 + stack_top = lexer%top + + ! Tokenization will cover always a complete scope + do while(lexer%top >= stack_top .and. token%kind /= token_kind%eof) + call next_token(lexer, token) + call lexer%context%push_back(token) + end do + + ! Flag all incomplete inline table and array scopes for the parser + if (lexer%top > stack_top) then + do it = lexer%top, stack_top + 1, -1 + select case(lexer%stack(it)%scope) + case(lexer_scope%table, lexer_scope%array) + lexer%context%token(lexer%stack(it)%token)%kind = token_kind%unclosed + end select + end do + end if +end subroutine fill_buffer + +!> Actually generate the next token, unbuffered version +subroutine next_token(lexer, token) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + + ! Consume current token + lexer%pos = lexer%pos + token%last - token%first + 1 + prev = lexer%pos + pos = lexer%pos + + ! If lexer is exhausted, return EOF as early as possible + if (pos > len(lexer%chunk)) then + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%eof, prev, pos) + return + end if + + select case(peek(lexer, pos)) + case(char_kind%hash) + do while(all(peek(lexer, pos+1) /= [char_kind%carriage_return, char_kind%newline]) & + & .and. pos <= len(lexer%chunk)) + pos = pos + 1 + end do + token = toml_token(token_kind%comment, prev, pos) + + case(char_kind%space, char_kind%tab) + do while(any(match(lexer, pos+1, [char_kind%space, char_kind%tab])) & + & .and. pos <= len(lexer%chunk)) + pos = pos + 1 + end do + token = toml_token(token_kind%whitespace, prev, pos) + + case(char_kind%newline) + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%newline, prev, pos) + + case(char_kind%carriage_return) + if (match(lexer, pos+1, char_kind%newline)) then + pos = pos + 1 + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%newline, prev, pos) + else + token = toml_token(token_kind%invalid, prev, pos) + end if + + case(char_kind%dot) + if (view_scope(lexer) == lexer_scope%table) then + token = toml_token(token_kind%dot, prev, pos) + else + token = toml_token(token_kind%invalid, prev, pos) + end if + + case(char_kind%comma) + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%comma, prev, pos) + + case(char_kind%equal) + token = toml_token(token_kind%equal, prev, pos) + call push_back(lexer, lexer_scope%equal, lexer%context%top + 1) + + case(char_kind%lbrace) + token = toml_token(token_kind%lbrace, prev, pos) + call push_back(lexer, lexer_scope%table, lexer%context%top + 1) + + case(char_kind%rbrace) + call pop(lexer, lexer_scope%equal) + call pop(lexer, lexer_scope%table) + token = toml_token(token_kind%rbrace, prev, pos) + + case(char_kind%lbracket) + token = toml_token(token_kind%lbracket, prev, pos) + if (any(view_scope(lexer) == [lexer_scope%equal, lexer_scope%array])) then + call push_back(lexer, lexer_scope%array, lexer%context%top + 1) + end if + + case(char_kind%rbracket) + call pop(lexer, lexer_scope%array) + token = toml_token(token_kind%rbracket, prev, pos) + + case(char_kind%squote) + call next_sstring(lexer, token) + + case(char_kind%dquote) + call next_dstring(lexer, token) + + case default + if (view_scope(lexer) == lexer_scope%table) then + call next_keypath(lexer, token) + else + call next_literal(lexer, token) + end if + + end select +end subroutine next_token + +!> Process next literal string token, can produce normal literals and multiline literals +subroutine next_sstring(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(1, tfc) :: ch + integer :: prev, pos, it + logical :: valid + + prev = lexer%pos + pos = lexer%pos + + if (all(match(lexer, [pos+1, pos+2], char_kind%squote))) then + pos = pos + 3 + + pos = strstr(lexer%chunk(pos:), char_kind%squote3) + pos - 1 + if (pos < prev + 3) then + token = toml_token(token_kind%invalid, prev, len(lexer%chunk)) + return + end if + + do it = 1, 2 + if (match(lexer, pos+3, char_kind%squote)) pos = pos + 1 + end do + + valid = .true. + do it = prev + 3, pos - 1 + ch = peek(lexer, it) + valid = valid .and. valid_string(ch) + end do + + token = toml_token(merge(token_kind%mliteral, token_kind%invalid, valid), prev, pos+2) + return + end if + + valid = .true. + + do while(pos < len(lexer%chunk)) + pos = pos + 1 + ch = peek(lexer, pos) + valid = valid .and. valid_string(ch) + if (ch == char_kind%squote) exit + if (ch == char_kind%newline) then + pos = pos - 1 + valid = .false. + exit + end if + end do + + valid = valid .and. peek(lexer, pos) == char_kind%squote .and. pos /= prev + token = toml_token(merge(token_kind%literal, token_kind%invalid, valid), prev, pos) +end subroutine next_sstring + +!> Process next string token, can produce normal string and multiline string tokens +subroutine next_dstring(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(1, tfc) :: ch + character(*, tfc), parameter :: hexnum = "0123456789ABCDEF", valid_escape = "betnfr\""" + integer :: prev, pos, expect, it, hex + logical :: escape, valid, space + + prev = lexer%pos + pos = lexer%pos + hex = 0 + + if (all(match(lexer, [pos+1, pos+2], char_kind%dquote))) then + pos = pos + 3 + + do + it = strstr(lexer%chunk(pos:), char_kind%dquote3) + pos = it + pos - 1 + if (pos < prev + 3 .or. it == 0) then + token = toml_token(token_kind%invalid, prev, len(lexer%chunk)) + return + end if + + if (match(lexer, pos-1, char_kind%backslash)) then + pos = pos + 1 + cycle + end if + + do it = 1, 2 + if (match(lexer, pos+3, char_kind%dquote)) pos = pos + 1 + end do + exit + end do + + valid = .true. + escape = .false. + space = .false. + expect = 0 + + do it = prev + 3, pos - 1 + ch = peek(lexer, it) + if (escape) then + space = verify(ch, char_kind%space//char_kind%tab//& + & char_kind%carriage_return//char_kind%newline) == 0 + end if + if (space) then + escape = .false. + if (ch == char_kind%newline) then + if (expect > 0) expect = expect - 1 + space = .false. + cycle + end if + if (verify(ch, char_kind%space//char_kind%tab) == 0 .and. expect == 0) cycle + if (ch == char_kind%carriage_return) then + expect = 1 + cycle + end if + valid = .false. + space = .false. + expect = 0 + cycle + end if + valid = valid .and. valid_string(ch) + if (escape) then + escape = .false. + space = .false. + if (verify(ch, valid_escape) == 0) cycle + if (ch == "x") then + expect = 2 + hex = it + 1 + cycle + end if + if (ch == "u") then + expect = 4 + hex = pos + 1 + cycle + end if + if (ch == "U") then + expect = 8 + hex = pos + 1 + cycle + end if + valid = .false. + cycle + end if + if (expect > 0) then + expect = expect - 1 + valid = valid .and. verify(ch, hexnum) == 0 + if (expect == 0) valid = valid .and. verify_ucs(lexer%chunk(hex:pos)) + cycle + end if + escape = ch == char_kind%backslash + end do + + ! Check for any unfinished escape sequences + valid = valid .and. expect == 0 .and. .not.(escape.or.space) + + token = toml_token(merge(token_kind%mstring, token_kind%invalid, valid), prev, pos+2) + return + end if + + valid = .true. + escape = .false. + expect = 0 + + do while(pos < len(lexer%chunk)) + pos = pos + 1 + ch = peek(lexer, pos) + valid = valid .and. valid_string(ch) + if (escape) then + escape = .false. + if (verify(ch, valid_escape) == 0) cycle + if (ch == "x") then + expect = 2 + hex = it + 1 + cycle + end if + if (ch == "u") then + expect = 4 + hex = pos + 1 + cycle + end if + if (ch == "U") then + expect = 8 + hex = pos + 1 + cycle + end if + valid = .false. + cycle + end if + if (expect > 0) then + expect = expect - 1 + valid = valid .and. verify(ch, hexnum) == 0 + if (expect == 0) valid = valid .and. verify_ucs(lexer%chunk(hex:pos)) + cycle + end if + escape = ch == char_kind%backslash + if (ch == char_kind%dquote) exit + if (ch == char_kind%newline) then + pos = pos - 1 + valid = .false. + exit + end if + end do + + valid = valid .and. peek(lexer, pos) == char_kind%dquote .and. pos /= prev + token = toml_token(merge(token_kind%string, token_kind%invalid, valid), prev, pos) +end subroutine next_dstring + +!> Validate characters in string, non-printable characters are invalid in this context +pure function valid_string(ch) result(valid) + character(1, tfc), intent(in) :: ch + logical :: valid + + character(1, tfc), parameter :: x00 = achar(int(z"00")), x08 = achar(int(z"08")), & + & x0b = achar(int(z"0b")), x1f = achar(int(z"1f")), x7f = achar(int(z"7f")) + + valid = & + & .not.(x00 <= ch .and. ch <= x08) .and. & + & .not.(x0b <= ch .and. ch <= x1f) .and. & + & ch /= x7f +end function + +!> Process next bare key token, produces keypath tokens. +subroutine next_keypath(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + logical :: valid + integer :: prev, pos + character(1, tfc) :: ch + + prev = lexer%pos + pos = lexer%pos + ch = peek(lexer, pos) + + valid = (tfc_"A" <= ch .and. ch <= tfc_"Z") & + & .or. (tfc_"a" <= ch .and. ch <= tfc_"z") & + & .or. (verify(ch, char_kind%literal) == 0) + do while(verify(peek(lexer, pos+1), terminated//char_kind%dot) > 0) + pos = pos + 1 + ch = peek(lexer, pos) + + if (tfc_"A" <= ch .and. ch <= tfc_"Z") cycle + if (tfc_"a" <= ch .and. ch <= tfc_"z") cycle + if (verify(ch, char_kind%literal) == 0) cycle + + valid = .false. + cycle + end do + + token = toml_token(merge(token_kind%keypath, token_kind%invalid, valid), prev, pos) +end subroutine next_keypath + +!> Identify literal values, produces integer, float, boolean, and datetime tokens. +subroutine next_literal(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + integer, parameter :: offset(*) = [0, 1, 2, 3, 4, 5] + character(1, tfc), parameter :: & + & true(4) = ["t", "r", "u", "e"], false(5) = ["f", "a", "l", "s", "e"] + + prev = lexer%pos + pos = lexer%pos + + select case(peek(lexer, pos)) + case("t") + if (match_all(lexer, pos+offset(:4), true) .and. & + & verify(peek(lexer, pos+4), terminated) == 0) then + token = toml_token(token_kind%bool, prev, pos+3) + return + end if + + case("f") + if (match_all(lexer, pos+offset(:5), false) .and. & + & verify(peek(lexer, pos+5), terminated) == 0) then + token = toml_token(token_kind%bool, prev, pos+4) + return + end if + + case default + call next_datetime(lexer, token) + if (token%kind == token_kind%datetime) return + + call next_integer(lexer, token) + if (token%kind == token_kind%int) return + + call next_float(lexer, token) + if (token%kind == token_kind%float) return + + end select + + ! If the current token is invalid, advance to the next terminator + do while(verify(peek(lexer, pos+1), terminated) > 0) + pos = pos + 1 + end do + token = toml_token(token_kind%invalid, prev, pos) +end subroutine next_literal + +!> Process integer tokens and binary, octal, and hexadecimal literals. +subroutine next_integer(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(*, tfc), parameter :: toml_base(4) = [& + & "0123456789abcdefABCDEF", & + & "0123456789000000000000", & + & "0123456700000000000000", & + & "0100000000000000000000"] + integer, parameter :: b10 = 2, b16 = 1, b8 = 3, b2 = 4 + + character(1, tfc) :: ch + integer :: prev, pos, base + logical :: underscore, okay + + prev = lexer%pos + pos = lexer%pos + okay = .true. + underscore = .true. + base = b10 + + if (any(match(lexer, pos, ["+", "-"]))) then + pos = pos + 1 + end if + + if (match(lexer, pos, "0")) then + select case(peek(lexer, pos+1)) + case("x") + okay = pos == prev + base = b16 + pos = pos + 2 + case("o") + okay = pos == prev + base = b8 + pos = pos + 2 + case("b") + okay = pos == prev + base = b2 + pos = pos + 2 + case(char_kind%space, char_kind%tab, char_kind%newline, char_kind%carriage_return, & + & char_kind%hash, char_kind%rbrace, char_kind%rbracket, char_kind%comma) + token = toml_token(token_kind%int, prev, pos) + return + case default + do while(verify(peek(lexer, pos), terminated) > 0) + pos = pos + 1 + end do + token = toml_token(token_kind%invalid, prev, pos-1) + return + end select + end if + + + do while(pos <= len(lexer%chunk)) + ch = peek(lexer, pos) + if (ch == "_") then + if (underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (verify(ch, toml_base(base)) == 0) then + pos = pos + 1 + underscore = .false. + cycle + end if + + okay = okay .and. verify(ch, terminated) == 0 + exit + end do + + okay = .not.underscore .and. okay + token = toml_token(merge(token_kind%int, token_kind%invalid, okay), prev, pos-1) +end subroutine next_integer + +!> Process float tokens. +subroutine next_float(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + logical :: plus_minus, underscore, point, expo, okay, zero, first + character(1, tfc) :: ch + integer, parameter :: offset(*) = [0, 1, 2] + character(1, tfc), parameter :: nan(3) = ["n", "a", "n"], inf(3) = ["i", "n", "f"] + + prev = lexer%pos + pos = lexer%pos + point = .false. + expo = .false. + zero = .false. + first = .true. + underscore = .true. + plus_minus = any(match(lexer, pos, ["+", "-"])) + if (plus_minus) pos = pos + 1 + + if (match_all(lexer, pos+offset, nan) .and. & + & verify(peek(lexer, pos+3), terminated) == 0) then + token = toml_token(token_kind%float, prev, pos+2) + return + end if + + if (match_all(lexer, pos+offset, inf) .and. & + & verify(peek(lexer, pos+3), terminated) == 0) then + token = toml_token(token_kind%float, prev, pos+2) + return + end if + + do while(pos <= len(lexer%chunk)) + ch = peek(lexer, pos) + if (ch == "_") then + if (underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (ch == ".") then + if (point .or. expo .or. underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = .false. + underscore = .true. + point = .true. + pos = pos + 1 + cycle + end if + + if (ch == "e" .or. ch == "E") then + if (expo .or. underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = .false. + underscore = .true. + expo = .true. + pos = pos + 1 + cycle + end if + + if (ch == "+" .or. ch == "-") then + if (.not.any(match(lexer, pos-1, ["e", "E"]))) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (verify(ch, "0123456789") == 0) then + if (zero) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = first .and. ch == "0" + first = .false. + pos = pos + 1 + underscore = .false. + cycle + end if + + exit + end do + + okay = .not.underscore .and. (expo .or. point) + token = toml_token(merge(token_kind%float, token_kind%invalid, okay), prev, pos-1) +end subroutine next_float + +!> Find the next datetime expression +subroutine next_datetime(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + logical :: has_date, has_time, has_millisec, has_local, okay, has_seconds + integer :: prev, pos, it, time_len + integer, parameter :: offset(*) = [(it, it = 0, 10)], & + & offset_date = 10, offset_time = 8, offset_time_no_sec = 5, offset_local = 6 + character(*, tfc), parameter :: num = "0123456789" + + prev = lexer%pos + pos = lexer%pos + + has_date = valid_date(peek(lexer, pos+offset(:offset_date))) + if (has_date) then + if (verify(peek(lexer, pos+offset_date), "Tt ") == 0 & + & .and. pos + offset_date < len(lexer%chunk) & + & .and. verify(peek(lexer, pos+offset_date+1), num) == 0) then + pos = pos + offset_date + 1 + end if + end if + + ! Try to validate time - first with 8 characters (HH:MM:SS), then 5 (HH:MM) + call valid_time(peek(lexer, pos+offset(:offset_time)), has_time, has_seconds) + if (has_time) then + if (has_seconds) then + time_len = offset_time + else + time_len = offset_time_no_sec + end if + pos = pos + time_len - 1 + if (match(lexer, pos+1, char_kind%dot)) then + it = 1 + do while(verify(peek(lexer, pos+it+1), num) == 0) + it = it + 1 + end do + has_millisec = it > 1 + if (.not.has_millisec) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + + pos = pos + it + end if + + has_local = valid_local(peek(lexer, pos+offset(:offset_local)+1)) + if (has_local) then + if (.not.has_date) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + pos = pos + offset_local + else if (verify(peek(lexer, pos+1), "zZ") == 0) then + pos = pos + 1 + end if + end if + + if (.not.(has_time.or.has_date)) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + + if (.not.has_time.and.has_date) pos = pos + offset_date - 1 + okay = verify(peek(lexer, pos+1), terminated) == 0 .and. pos <= len(lexer%chunk) + token = toml_token(merge(token_kind%datetime, token_kind%invalid, okay), prev, pos) +end subroutine next_datetime + +!> Validate a string as date +pure function valid_date(string) result(valid) + !> Input string, 10 characters + character(1, tfc), intent(in) :: string(:) + !> Valid date + logical :: valid + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: year, month, day, mday + logical :: leap + + valid = .false. + if (any(string([5, 8]) /= "-")) return + + year = 0 + do it = 1, 4 + val = scan(num, string(it)) - 1 + if (val < 0) return + year = year * 10 + val + end do + + month = 0 + do it = 6, 7 + val = scan(num, string(it)) - 1 + if (val < 0) return + month = month * 10 + val + end do + + day = 0 + do it = 9, 10 + val = scan(num, string(it)) - 1 + if (val < 0) return + day = day * 10 + val + end do + + mday = 0 + select case(month) + case(1, 3, 5, 7, 8, 10, 12) + mday = 31 + case(2) + leap = mod(year, 4) == 0 .and. (mod(year, 100) /= 0 .or. mod(year, 400) == 0) + mday = merge(29, 28, leap) + case(4, 6, 9, 11) + mday = 30 + end select + valid = day >= 1 .and. day <= mday +end function valid_date + + +!> Validate a string as time (HH:MM or HH:MM:SS) +subroutine valid_time(string, valid, has_seconds) + !> Input string, 5 characters (HH:MM) or 8 characters (HH:MM:SS) + character(1, tfc), intent(in) :: string(:) + !> Valid time + logical, intent(out) :: valid + !> Whether the time has seconds + logical, intent(out) :: has_seconds + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: hour, minute, second + + valid = .false. + has_seconds = .false. + if (string(3) /= ":") return + + hour = 0 + do it = 1, 2 + val = scan(num, string(it)) - 1 + if (val < 0) return + hour = hour * 10 + val + end do + + minute = 0 + do it = 4, 5 + val = scan(num, string(it)) - 1 + if (val < 0) return + minute = minute * 10 + val + end do + + ! Check for seconds (optional in TOML 1.1) + if (size(string) >= 8 .and. string(6) == ":") then + second = 0 + do it = 7, 8 + val = scan(num, string(it)) - 1 + if (val < 0) return + second = second * 10 + val + end do + if (second < 0 .or. second >= 60) return + has_seconds = .true. + end if + + valid = minute >= 0 .and. minute < 60 & + & .and. hour >= 0 .and. hour < 24 +end subroutine valid_time + + +!> Validate a string as timezone +function valid_local(string) result(valid) + !> Input string, 6 characters + character(1, tfc), intent(in) :: string(:) + !> Valid timezone + logical :: valid + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: hour, minute + + valid = .false. + if (string(4) /= ":" .or. all(string(1) /= ["+", "-"])) return + + hour = 0 + do it = 2, 3 + val = scan(num, string(it)) - 1 + if (val < 0) return + hour = hour * 10 + val + end do + + minute = 0 + do it = 5, 6 + val = scan(num, string(it)) - 1 + if (val < 0) return + minute = minute * 10 + val + end do + + valid = minute >= 0 .and. minute < 60 & + & .and. hour >= 0 .and. hour < 24 +end function valid_local + + +!> Show current character +elemental function peek(lexer, pos) result(ch) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos + !> Character found + character(1, tfc) :: ch + + if (pos <= len(lexer%chunk)) then + ch = lexer%chunk(pos:pos) + else + ch = char_kind%space + end if +end function peek + +!> Compare a character +elemental function match(lexer, pos, kind) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos + !> Character to compare against + character(1, tfc), intent(in) :: kind + !> Characters match + logical :: match + + match = peek(lexer, pos) == kind +end function match + +!> Compare a set of characters +pure function match_all(lexer, pos, kind) result(match) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos(:) + !> Character to compare against + character(1, tfc), intent(in) :: kind(:) + !> Characters match + logical :: match + + match = all(peek(lexer, pos) == kind) +end function match_all + +pure function strstr(string, pattern) result(res) + character(*, tfc), intent(in) :: string + character(*, tfc), intent(in) :: pattern + integer :: lps_array(len(pattern)) + integer :: res, s_i, p_i, length_string, length_pattern + res = 0 + length_string = len(string) + length_pattern = len(pattern) + + if (length_pattern > 0 .and. length_pattern <= length_string) then + lps_array = compute_lps(pattern) + + s_i = 1 + p_i = 1 + do while(s_i <= length_string) + if (string(s_i:s_i) == pattern(p_i:p_i)) then + if (p_i == length_pattern) then + res = s_i - length_pattern + 1 + exit + end if + s_i = s_i + 1 + p_i = p_i + 1 + else if (p_i > 1) then + p_i = lps_array(p_i - 1) + 1 + else + s_i = s_i + 1 + end if + end do + end if + +contains + + pure function compute_lps(string) result(lps_array) + character(*, tfc), intent(in) :: string + integer :: lps_array(len(string)) + integer :: i, j, length_string + + length_string = len(string) + + if (length_string > 0) then + lps_array(1) = 0 + + i = 2 + j = 1 + do while (i <= length_string) + if (string(j:j) == string(i:i)) then + lps_array(i) = j + i = i + 1 + j = j + 1 + else if (j > 1) then + j = lps_array(j - 1) + 1 + else + lps_array(i) = 0 + i = i + 1 + end if + end do + end if + + end function compute_lps + +end function strstr + +!> Extract string value of token, works for keypath, string, multiline string, literal, +!> and mulitline literal tokens. +subroutine extract_string(lexer, token, string) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract string value from + type(toml_token), intent(in) :: token + !> String value of token + character(len=:), allocatable, intent(out) :: string + + integer :: it, length + logical :: escape, leading_newline + character(1, tfc) :: ch + + length = token%last - token%first + 1 + + select case(token%kind) + case(token_kind%string) + string = "" + escape = .false. + it = token%first + 1 + do while(it <= token%last - 1) + ch = peek(lexer, it) + if (escape) then + escape = .false. + select case(ch) + case("""", "\"); string = string // ch + case("b"); string = string // TOML_BACKSPACE + case("e"); string = string // TOML_ESC + case("t"); string = string // TOML_TABULATOR + case("n"); string = string // TOML_NEWLINE + case("r"); string = string // TOML_CARRIAGE_RETURN + case("f"); string = string // TOML_FORMFEED + case("x"); string = string // convert_ucs(lexer%chunk(it+1:it+2)); it = it + 3 + case("u"); string = string // convert_ucs(lexer%chunk(it+1:it+4)); it = it + 5 + case("U"); string = string // convert_ucs(lexer%chunk(it+1:it+8)); it = it + 9 + end select + else + escape = ch == char_kind%backslash + if (.not.escape) string = string // ch + end if + it = it + 1 + end do + case(token_kind%mstring) + leading_newline = peek(lexer, token%first+3) == char_kind%newline + string = "" + escape = .false. + it = token%first + merge(4, 3, leading_newline) + do while(it <= token%last - 3) + ch = peek(lexer, it) + if (escape) then + escape = .false. + select case(ch) + case("""", "\"); string = string // ch + case("b"); string = string // TOML_BACKSPACE + case("e"); string = string // TOML_ESC + case("t"); string = string // TOML_TABULATOR + case("n"); string = string // TOML_NEWLINE + case("r"); string = string // TOML_CARRIAGE_RETURN + case("f"); string = string // TOML_FORMFEED + case("x"); string = string // convert_ucs(lexer%chunk(it+1:it+2)); it = it + 3 + case("u"); string = string // convert_ucs(lexer%chunk(it+1:it+4)); it = it + 5 + case("U"); string = string // convert_ucs(lexer%chunk(it+1:it+8)); it = it + 9 + case(char_kind%space, char_kind%tab, char_kind%carriage_return) + escape = .true. + case(char_kind%newline) + continue + end select + else + escape = ch == char_kind%backslash + if (.not.escape) string = string // ch + end if + it = it + 1 + end do + case(token_kind%literal) + allocate(character(length - 2)::string) + string = lexer%chunk(token%first+1:token%last-1) + case(token_kind%mliteral) + leading_newline = peek(lexer, token%first+3) == char_kind%newline + allocate(character(length - merge(7, 6, leading_newline))::string) + string = lexer%chunk(token%first+merge(4, 3, leading_newline):token%last-3) + case(token_kind%keypath) + allocate(character(length)::string) + string = lexer%chunk(token%first:token%last) + end select + +end subroutine extract_string + +!> Extract integer value of token +subroutine extract_integer(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract integer value from + type(toml_token), intent(in) :: token + !> Integer value of token + integer(tfi), intent(out) :: val + + integer :: first, base, it, tmp + logical :: minus + character(1, tfc) :: ch + character(*, tfc), parameter :: num = "0123456789abcdef" + + if (token%kind /= token_kind%int) return + + val = 0 + base = 10 + first = token%first + + if (any(peek(lexer, first) == ["+", "-"])) first = first + 1 + + if (peek(lexer, first) == "0") then + select case(peek(lexer, first + 1)) + case("x") + first = first + 2 + base = 16 + case("o") + first = first + 2 + base = 8 + case("b") + first = first + 2 + base = 2 + case default + return + end select + end if + + minus = match(lexer, token%first, char_kind%minus) + + do it = first, token%last + ch = peek(lexer, it) + if ("A" <= ch .and. ch <= "Z") ch = achar(iachar(ch) - iachar("A") + iachar("a")) + tmp = scan(num(:abs(base)), ch) - 1 + if (tmp < 0) cycle + val = val * base + merge(-tmp, tmp, minus) + end do +end subroutine extract_integer + +!> Extract floating point value of token +subroutine extract_float(lexer, token, val) + ! Not useable since unsupported with GFortran on some platforms (MacOS/ppc) + ! use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quite_nan, & + ! & ieee_positive_inf, ieee_negative_inf + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract floating point value from + type(toml_token), intent(in) :: token + !> Floating point value of token + real(tfr), intent(out) :: val + + integer :: first, it, ic + character(len=token%last - token%first + 1) :: buffer + character(1, tfc) :: ch + + if (token%kind /= token_kind%float) return + + first = token%first + + if (any(peek(lexer, first) == ["+", "-"])) first = first + 1 + + if (match(lexer, first, "n")) then + ! val = ieee_value(val, ieee_quite_nan) + buffer = "NaN" + read(buffer, *, iostat=ic) val + return + end if + + if (match(lexer, first, "i")) then + ! val = ieee_value(val, ieee_positive_inf) + buffer = "Inf" + read(buffer, *, iostat=ic) val + if (match(lexer, token%first, char_kind%minus)) val = -val + return + end if + +! ival = 0 +! idot = 0 +! +! do it = first, token%last +! ch = peek(lexer, it) +! if (any(ch == [".", "e", "E"])) exit +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! ival = ival * base + tmp +! end do +! first = it +! +! if (ch == ".") then +! idot = 0 +! do it = first, token%last +! ch = peek(lexer, it) +! if (any(ch == ["e", "E"])) exit +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! idot = idot + 1 +! ival = ival * base + tmp +! end do +! first = it +! end if +! +! expo = 0 +! if (any(ch == ["e", "E"])) then +! first = first + 1 +! do it = first, token%last +! ch = peek(lexer, it) +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! expo = expo * base + tmp +! end do +! if (match(lexer, first, char_kind%minus)) expo = -expo +! end if +! expo = expo - idot +! val = ival * 10.0_tfr ** expo ! FIXME +! +! if (match(lexer, token%first, char_kind%minus)) val = -val + + ic = 0 + do it = token%first, token%last + ch = peek(lexer, it) + if (ch == "_") cycle + ic = ic + 1 + buffer(ic:ic) = ch + end do + + read(buffer(:ic), *, iostat=it) val +end subroutine extract_float + +!> Extract boolean value of token +subroutine extract_bool(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract boolean value from + type(toml_token), intent(in) :: token + !> Boolean value of token + logical, intent(out) :: val + + if (token%kind /= token_kind%bool) return + + val = peek(lexer, token%first) == "t" +end subroutine extract_bool + +!> Extract datetime value of token +subroutine extract_datetime(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract datetime value from + type(toml_token), intent(in) :: token + !> Datetime value of token + type(toml_datetime), intent(out) :: val + + if (token%kind /= token_kind%datetime) return + + val = toml_datetime(lexer%chunk(token%first:token%last)) +end subroutine extract_datetime + + +!> Push a new scope onto the lexer stack and record the token +pure subroutine push_back(lexer, scope, token) + type(toml_lexer), intent(inout) :: lexer + integer, intent(in) :: scope + integer, intent(in) :: token + + lexer%top = lexer%top + 1 + if (lexer%top > size(lexer%stack)) call resize(lexer%stack) + lexer%stack(lexer%top) = stack_item(scope, token) +end subroutine push_back + +!> Pop a scope from the lexer stack in case the topmost scope matches the requested scope +subroutine pop(lexer, scope) + type(toml_lexer), intent(inout) :: lexer + integer, intent(in) :: scope + + if (lexer%top > 0) then + if (lexer%stack(lexer%top)%scope == scope) lexer%top = lexer%top - 1 + end if +end subroutine pop + +!> Peek at the topmost scope on the lexer stack +pure function view_scope(lexer) result(scope) + type(toml_lexer), intent(in) :: lexer + integer :: scope + + if (lexer%top > 0) then + scope = lexer%stack(lexer%top)%scope + else + scope = lexer_scope%table + end if +end function view_scope + + +!> Reallocate list of scopes +pure subroutine resize_scope(var, n) + !> Instance of the array to be resized + type(stack_item), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(stack_item), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 8 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate(tmp) + end if + +end subroutine resize_scope + + +!> Extract information about the source +subroutine get_info(lexer, meta, output) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Query about the source + character(*, tfc), intent(in) :: meta + !> Metadata about the source + character(:, tfc), allocatable, intent(out) :: output + + select case(meta) + case("source") + output = lexer%chunk // TOML_NEWLINE + case("filename") + if (allocated(lexer%filename)) output = lexer%filename + end select +end subroutine get_info + + +function hex_to_int(hex) result(val) + character(*, tfc), intent(in) :: hex + integer(tfi) :: val + integer :: i + character(1, tfc) :: ch + character(*, tfc), parameter :: hex_digits = "0123456789abcdef" + + val = 0_tfi + do i = 1, len(hex) + ch = hex(i:i) + if ("A" <= ch .and. ch <= "Z") ch = achar(iachar(ch) - iachar("A") + iachar("a")) + val = val * 16 + max(index(hex_digits, ch) - 1, 0) + end do +end function hex_to_int + + +function verify_ucs(escape) result(valid) + character(*, tfc), intent(in) :: escape + logical :: valid + integer(tfi) :: code + + code = hex_to_int(escape) + + valid = code > 0 .and. code < int(z"7FFFFFFF", tfi) & + & .and. (code < int(z"d800", tfi) .or. code > int(z"dfff", tfi)) & + & .and. (code < int(z"fffe", tfi) .or. code > int(z"ffff", tfi)) +end function verify_ucs + + +function convert_ucs(escape) result(str) + character(*, tfc), intent(in) :: escape + character(:, tfc), allocatable :: str + integer(tfi) :: code + + code = hex_to_int(escape) + + select case(code) + case(int(z"00000000", tfi):int(z"0000007f", tfi)) + str = achar(code, kind=tfc) + case(int(z"00000080", tfi):int(z"000007ff", tfi)) + str = & + achar(ior(int(z"c0", tfi), ishft(code, -6)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00000800", tfi):int(z"0000ffff", tfi)) + str = & + achar(ior(int(z"e0", tfi), ishft(code, -12)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00010000", tfi):int(z"001fffff", tfi)) + str = & + achar(ior(int(z"f0", tfi), ishft(code, -18)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00200000", tfi):int(z"03ffffff", tfi)) + str = & + achar(ior(int(z"f8", tfi), ishft(code, -24)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -18), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"04000000", tfi):int(z"7fffffff", tfi)) + str = & + achar(ior(int(z"fc", tfi), ishft(code, -30)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -24), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -18), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + end select +end function convert_ucs + + +end module tomlf_de_lexer diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/parser.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/parser.f90 new file mode 100644 index 000000000..564ab8423 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/parser.f90 @@ -0,0 +1,862 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a parser for transforming a token stream to TOML datastructures. +module tomlf_de_parser + use tomlf_constants, only : tfc, tfr, tfi, TOML_NEWLINE + use tomlf_datetime, only : toml_datetime + use tomlf_de_context, only : toml_context + use tomlf_de_abc, only : toml_lexer => abstract_lexer + use tomlf_de_token, only : toml_token, token_kind, stringify + use tomlf_diagnostic, only : render, toml_diagnostic, toml_label, toml_level + use tomlf_terminal, only : toml_terminal + use tomlf_error, only : toml_error, toml_stat + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_value, toml_key, & + & add_table, add_array, add_keyval, cast_to_table, cast_to_array, len + implicit none + private + + public :: toml_parser, toml_parser_config, parse + + + !> Configuration of the TOML parser + type :: toml_parser_config + !> Use colorful output for diagnostics + type(toml_terminal) :: color = toml_terminal() + !> Record all tokens + integer :: context_detail = 0 + end type toml_parser_config + + interface toml_parser_config + module procedure :: new_parser_config + end interface toml_parser_config + + !> TOML parser + type :: toml_parser + !> Current token + type(toml_token) :: token + !> Table containing the document root + type(toml_table), allocatable :: root + !> Pointer to the currently processed table + type(toml_table), pointer :: current + !> Diagnostic produced while parsing + type(toml_diagnostic), allocatable :: diagnostic + !> Context for producing diagnostics + type(toml_context) :: context + !> Configuration of the parser + type(toml_parser_config) :: config + end type toml_parser + +contains + +!> Create a new instance of the TOML parser +subroutine new_parser(parser, config) + !> Instance of the parser + type(toml_parser), intent(out), target :: parser + !> Configuration of the parser + type(toml_parser_config), intent(in), optional :: config + + parser%token = toml_token(token_kind%newline, 0, 0) + parser%root = toml_table() + parser%current => parser%root + parser%config = toml_parser_config() + if (present(config)) parser%config = config +end subroutine new_parser + +!> Create new configuration for the TOML parser +pure function new_parser_config(color, context_detail) result(config) + !> Configuration of the parser + type(toml_parser_config) :: config + !> Color support for diagnostics + logical, intent(in), optional :: color + !> Record all tokens + integer, intent(in), optional :: context_detail + + if (present(color)) config%color = toml_terminal(color) + if (present(context_detail)) config%context_detail = context_detail +end function new_parser_config + +!> Parse TOML document and return root table +subroutine parse(lexer, table, config, context, error) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> TOML data structure + type(toml_table), allocatable, intent(out) :: table + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handler + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_parser) :: parser + + call new_parser(parser, config) + call parse_root(parser, lexer) + + if (present(error) .and. allocated(parser%diagnostic)) then + call make_error(error, parser%diagnostic, lexer, parser%config%color) + end if + if (allocated(parser%diagnostic)) return + + call move_alloc(parser%root, table) + + if (present(context)) then + context = parser%context + call lexer%get_info("filename", context%filename) + call lexer%get_info("source", context%source) + end if +end subroutine parse + +!> Parse the root table +subroutine parse_root(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + do while(.not.allocated(parser%diagnostic) .and. parser%token%kind /= token_kind%eof) + select case(parser%token%kind) + case(token_kind%newline, token_kind%whitespace, token_kind%comment) + call next_token(parser, lexer) + + case(token_kind%keypath, token_kind%string, token_kind%literal) + call parse_keyval(parser, lexer, parser%current) + + case(token_kind%lbracket) + call parse_table_header(parser, lexer) + + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax", & + & "unexpected "//stringify(parser%token)) + end select + end do +end subroutine parse_root + + +!> Parse a table or array of tables header +subroutine parse_table_header(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + type(toml_array), pointer :: array + type(toml_table), pointer :: table + class(toml_value), pointer :: ptr + type(toml_key) :: key + logical :: array_of_tables + + integer, parameter :: initial_size = 8 + integer :: top + type(toml_key), allocatable :: stack(:) + type(toml_token), allocatable :: leading_whitespace, trailing_whitespace + + + call consume(parser, lexer, token_kind%lbracket) + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) then + leading_whitespace = parser%token + call next_token(parser, lexer) + end if + + array_of_tables = parser%token%kind == token_kind%lbracket + + if (array_of_tables) then + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) then + call next_token(parser, lexer) + end if + end if + + call fill_stack(lexer, parser, top, stack) + if (allocated(parser%diagnostic)) return + + key = stack(top) + top = top - 1 + + call walk_stack(parser, top, stack) + + if (array_of_tables) then + call parser%current%get(key%key, ptr) + if (associated(ptr)) then + array => cast_to_array(ptr) + if (.not.associated(array)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + if (array%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(array%origin), & + & "Array of tables cannot extend inline array", & + & "extended here", & + & "defined as inline") + return + end if + else + call add_array(parser%current, key, array) + array%inline = .false. + end if + call add_table(array, table) + else + call parser%current%get(key%key, ptr) + if (associated(ptr)) then + table => cast_to_table(ptr) + if (associated(table)) then + if (.not.table%implicit) nullify(table) + end if + + if (.not.associated(table)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + else + call add_table(parser%current, key, table) + end if + end if + + parser%current => table + + call consume(parser, lexer, token_kind%rbracket) + if (allocated(parser%diagnostic)) return + + if (array_of_tables) then + if (parser%token%kind == token_kind%whitespace) then + trailing_whitespace = parser%token + call next_token(parser, lexer) + end if + call consume(parser, lexer, token_kind%rbracket) + if (allocated(parser%diagnostic)) return + end if + + if (array_of_tables .and. allocated(leading_whitespace)) then + call syntax_error(parser%diagnostic, lexer, leading_whitespace, & + & "Malformatted array of table header encountered", & + & "whitespace not allowed in header") + return + end if + + if (array_of_tables .and. allocated(trailing_whitespace)) then + call syntax_error(parser%diagnostic, lexer, trailing_whitespace, & + & "Malformatted array of table header encountered", & + & "whitespace not allowed in header") + return + end if + + do while(parser%token%kind == token_kind%whitespace) + call next_token(parser, lexer) + end do + + if (parser%token%kind == token_kind%comment) then + call next_token(parser, lexer) + end if + + if (all(parser%token%kind /= [token_kind%newline, token_kind%eof])) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Unexpected "//stringify(parser%token)//" after table header", & + & "expected newline") + end if + +contains + + !> Fill the stack with tokens + subroutine fill_stack(lexer, parser, top, stack) + class(toml_lexer), intent(inout) :: lexer + type(toml_parser), intent(inout) :: parser + !> Depth of the table key stack + integer, intent(out) :: top + !> Stack of all keys in the table header + type(toml_key), allocatable, intent(out) :: stack(:) + + top = 0 + allocate(stack(initial_size)) + + do + if (top >= size(stack)) then + call resize(stack) + end if + + if (all(parser%token%kind /= [token_kind%string, token_kind%literal, & + & token_kind%keypath])) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Missing key for table header", & + & "unexpected "//stringify(parser%token)) + return + end if + + top = top + 1 + call extract_key(parser, lexer, stack(top)) + + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + & call next_token(parser, lexer) + + if (parser%token%kind == token_kind%rbracket) exit + + call consume(parser, lexer, token_kind%dot) + if (allocated(parser%diagnostic)) return + if (parser%token%kind == token_kind%whitespace) & + & call next_token(parser, lexer) + end do + + if (top <= 0) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Empty table header", & + & "expected table header") + end if + + end subroutine fill_stack + + !> Walk the key stack to fetch the correct table, create implicit tables as necessary + subroutine walk_stack(parser, top, stack) + type(toml_parser), intent(inout), target :: parser + !> Depth of the table key stack + integer, intent(in) :: top + !> Stack of all keys in the table header + type(toml_key), intent(in), target :: stack(:) + + type(toml_table), pointer :: table, tmp_tbl + type(toml_array), pointer :: array + type(toml_key), pointer :: key + class(toml_value), pointer :: ptr + integer :: it + + table => parser%root + + do it = 1, top + key => stack(it) + + if (.not.table%has_key(key%key)) then + call add_table(table, key, tmp_tbl) + if (associated(tmp_tbl)) then + tmp_tbl%implicit = .true. + end if + end if + call table%get(key%key, ptr) + + table => cast_to_table(ptr) + if (.not.associated(table)) then + array => cast_to_array(ptr) + if (associated(array)) then + call array%get(len(array), ptr) + table => cast_to_table(ptr) + end if + if (.not.associated(table)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + end if + + if (table%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(table%origin), & + & "Inline table '"//key%key//"' cannot be used as a key", & + & "inline table cannot be extended", & + & "defined as inline first") + end if + end do + + parser%current => table + end subroutine walk_stack + + !> Change size of the stack + subroutine resize(stack, n) + !> Stack of keys to be resized + type(toml_key), allocatable, intent(inout) :: stack(:) + !> New size of the stack + integer, intent(in), optional :: n + + type(toml_key), allocatable :: tmp(:) + integer :: m + + if (present(n)) then + m = n + else + if (allocated(stack)) then + m = size(stack) + m = m + m/2 + 1 + else + m = initial_size + end if + end if + + if (allocated(stack)) then + call move_alloc(stack, tmp) + allocate(stack(m)) + + m = min(size(tmp), m) + stack(:m) = tmp(:m) + + deallocate(tmp) + else + allocate(stack(m)) + end if + end subroutine resize + +end subroutine parse_table_header + +!> Parse key value pairs in a table body +recursive subroutine parse_keyval(parser, lexer, table) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current table + type(toml_table), intent(inout) :: table + + class(toml_value), pointer :: ptr + type(toml_keyval), pointer :: vptr + type(toml_array), pointer :: aptr + type(toml_table), pointer :: tptr + type(toml_key) :: key + + call extract_key(parser, lexer, key) + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (parser%token%kind == token_kind%dot) then + call get_table(table, key, tptr) + if (tptr%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(tptr%origin), & + & "Cannot add keys to inline tables", & + & "inline table cannot be extended", & + & "defined as inline first") + return + end if + + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (any(parser%token%kind == [token_kind%keypath, token_kind%string, & + & token_kind%literal])) then + call parse_keyval(parser, lexer, tptr) + else + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax", & + & "expected key") + end if + return + end if + + call consume(parser, lexer, token_kind%equal) + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + call table%get(key%key, ptr) + if (associated(ptr)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + + select case(parser%token%kind) + case default + call add_keyval(table, key, vptr) + call parse_value(parser, lexer, vptr) + + case(token_kind%nil) + call next_token(parser, lexer) + + case(token_kind%lbracket) + call add_array(table, key, aptr) + call parse_inline_array(parser, lexer, aptr) + + case(token_kind%lbrace) + call add_table(table, key, tptr) + call parse_inline_table(parser, lexer, tptr) + + end select + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (parser%token%kind == token_kind%comment) & + call next_token(parser, lexer) +end subroutine parse_keyval + +recursive subroutine parse_inline_array(parser, lexer, array) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current array + type(toml_array), intent(inout) :: array + + type(toml_keyval), pointer :: vptr + type(toml_array), pointer :: aptr + type(toml_table), pointer :: tptr + integer, parameter :: skip_tokens(*) = & + [token_kind%whitespace, token_kind%comment, token_kind%newline] + + array%inline = .true. + call consume(parser, lexer, token_kind%lbracket) + + inline_array: do while(.not.allocated(parser%diagnostic)) + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + select case(parser%token%kind) + case(token_kind%rbracket) + exit inline_array + + case default + call add_keyval(array, vptr) + call parse_value(parser, lexer, vptr) + + case(token_kind%nil) + call next_token(parser, lexer) + + case(token_kind%lbracket) + call add_array(array, aptr) + call parse_inline_array(parser, lexer, aptr) + + case(token_kind%lbrace) + call add_table(array, tptr) + call parse_inline_table(parser, lexer, tptr) + + end select + if (allocated(parser%diagnostic)) exit inline_array + + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + if (parser%token%kind == token_kind%comma) then + call next_token(parser, lexer) + cycle inline_array + end if + exit inline_array + end do inline_array + if (allocated(parser%diagnostic)) return + + call consume(parser, lexer, token_kind%rbracket) +end subroutine parse_inline_array + +recursive subroutine parse_inline_table(parser, lexer, table) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current table + type(toml_table), intent(inout) :: table + + integer, parameter :: skip_tokens(*) = & + [token_kind%whitespace, token_kind%comment, token_kind%newline] + + table%inline = .true. + call consume(parser, lexer, token_kind%lbrace) + + inline_table: do while(.not.allocated(parser%diagnostic)) + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + select case(parser%token%kind) + case(token_kind%rbrace) + exit inline_table + + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid character in inline table", & + & "unexpected "//stringify(parser%token)) + + case(token_kind%keypath, token_kind%string, token_kind%literal) + call parse_keyval(parser, lexer, table) + + end select + if (allocated(parser%diagnostic)) exit inline_table + + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + if (parser%token%kind == token_kind%comma) then + call next_token(parser, lexer) + cycle inline_table + end if + exit inline_table + end do inline_table + if (allocated(parser%diagnostic)) return + + call consume(parser, lexer, token_kind%rbrace) +end subroutine parse_inline_table + +subroutine parse_value(parser, lexer, kval) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current key value pair + type(toml_keyval), intent(inout) :: kval + + select case(parser%token%kind) + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid expression for value", & + & "unexpected "//stringify(parser%token)) + + case(token_kind%unclosed) + ! Handle runaway expressions separately + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Inline expression contains unclosed or runaway group", & + & "unclosed inline expression") + + case(token_kind%string, token_kind%mstring, token_kind%literal, token_kind%mliteral, & + & token_kind%int, token_kind%float, token_kind%bool, token_kind%datetime) + call extract_value(parser, lexer, kval) + + call next_token(parser, lexer) + end select +end subroutine parse_value + +!> Check whether the current token is the expected one and advance the lexer +subroutine consume(parser, lexer, kind) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Expected token kind + integer, intent(in) :: kind + + if (parser%token%kind /= kind) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax in this context", & + & "expected "//stringify(toml_token(kind))) + return + end if + + call next_token(parser, lexer) +end subroutine consume + +!> Create diagnostic for invalid syntax +subroutine syntax_error(diagnostic, lexer, token, message, label) + !> Diagnostic for the syntax error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token that caused the error + type(toml_token), intent(in) :: token + !> Message for the error + character(len=*), intent(in) :: message + !> Label for the token + character(len=*), intent(in) :: label + + character(:, tfc), allocatable :: filename + + call lexer%get_info("filename", filename) + + allocate(diagnostic) + diagnostic = toml_diagnostic( & + & toml_level%error, & + & message, & + & filename, & + & [toml_label(toml_level%error, token%first, token%last, label, .true.)]) +end subroutine syntax_error + +!> Create diagnostic for incorrect semantics +subroutine semantic_error(diagnostic, lexer, token1, token2, message, label1, label2) + !> Diagnostic for the duplicate key error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token identifying the duplicate key + type(toml_token), intent(in) :: token1 + !> Token identifying the original key + type(toml_token), intent(in) :: token2 + !> Message for the error + character(len=*), intent(in) :: message + !> Label for the first token + character(len=*), intent(in) :: label1 + !> Label for the second token + character(len=*), intent(in) :: label2 + + character(:, tfc), allocatable :: filename + + call lexer%get_info("filename", filename) + + allocate(diagnostic) + diagnostic = toml_diagnostic( & + & toml_level%error, & + & message, & + & filename, & + & [toml_label(toml_level%error, token1%first, token1%last, label1, .true.), & + & toml_label(toml_level%info, token2%first, token2%last, label2, .false.)]) +end subroutine semantic_error + +!> Create a diagnostic for a duplicate key entry +subroutine duplicate_key_error(diagnostic, lexer, token1, token2, message) + !> Diagnostic for the duplicate key error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token identifying the duplicate key + type(toml_token), intent(in) :: token1 + !> Token identifying the original key + type(toml_token), intent(in) :: token2 + !> Message for the error + character(len=*), intent(in) :: message + + call semantic_error(diagnostic, lexer, token1, token2, & + & message, "key already used", "first defined here") +end subroutine duplicate_key_error + +!> Create an error from a diagnostic +subroutine make_error(error, diagnostic, lexer, color) + !> Error to be created + type(toml_error), allocatable, intent(out) :: error + !> Diagnostic to be used + type(toml_diagnostic), intent(in) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(in) :: lexer + !> Use colorful error messages + type(toml_terminal), intent(in) :: color + + character(len=:), allocatable :: str + + allocate(error) + call lexer%get_info("source", str) + error%message = render(diagnostic, str, color) + error%stat = toml_stat%fatal +end subroutine make_error + +!> Wrapper around the lexer to retrieve the next token. +!> Allows to record the tokens for keys and values in the parser context +subroutine next_token(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + call lexer%next(parser%token) + + select case(parser%token%kind) + case(token_kind%keypath, token_kind%string, token_kind%literal, token_kind%int, & + & token_kind%float, token_kind%bool, token_kind%datetime) + call parser%context%push_back(parser%token) + case(token_kind%newline, token_kind%dot, token_kind%comma, token_kind%equal, & + & token_kind%lbrace, token_kind%rbrace, token_kind%lbracket, token_kind%rbracket) + if (parser%config%context_detail > 0) & + call parser%context%push_back(parser%token) + case default + if (parser%config%context_detail > 1) & + call parser%context%push_back(parser%token) + end select +end subroutine next_token + +!> Extract key from token +subroutine extract_key(parser, lexer, key) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Key to be extracted + type(toml_key), intent(out) :: key + + call lexer%extract(parser%token, key%key) + key%origin = parser%context%top + if (scan(key%key, TOML_NEWLINE) > 0) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid character in key", & + & "key cannot contain newline") + return + end if +end subroutine extract_key + +!> Extract value from token +subroutine extract_value(parser, lexer, kval) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Value to be extracted + type(toml_keyval), intent(inout) :: kval + + character(:, tfc), allocatable :: sval + real(tfr) :: rval + integer(tfi) :: ival + logical :: bval + type(toml_datetime) :: dval + + kval%origin_value = parser%context%top + + select case(parser%token%kind) + case(token_kind%string, token_kind%literal, token_kind%mstring, token_kind%mliteral) + call lexer%extract_string(parser%token, sval) + call kval%set(sval) + + case(token_kind%int) + call lexer%extract_integer(parser%token, ival) + call kval%set(ival) + + case(token_kind%float) + call lexer%extract_float(parser%token, rval) + call kval%set(rval) + + case(token_kind%bool) + call lexer%extract_bool(parser%token, bval) + call kval%set(bval) + + case(token_kind%datetime) + call lexer%extract_datetime(parser%token, dval) + call kval%set(dval) + end select +end subroutine extract_value + +!> Try to retrieve TOML table with key or create it +subroutine get_table(table, key, ptr, stat) + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + !> Key for the new table + type(toml_key), intent(in) :: key + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), pointer :: tmp + + nullify(ptr) + call table%get(key%key, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) stat = merge(toml_stat%success, toml_stat%fatal, associated(ptr)) + else + call add_table(table, key, ptr, stat) + end if +end subroutine get_table + +end module tomlf_de_parser diff --git a/source/third_party_open/utils/toml-f/src/tomlf/de/token.f90 b/source/third_party_open/utils/toml-f/src/tomlf/de/token.f90 new file mode 100644 index 000000000..34d12a509 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/de/token.f90 @@ -0,0 +1,163 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides a definition for a token +module tomlf_de_token + implicit none + private + + public :: toml_token, stringify, token_kind, resize + + + !> Possible token kinds + type :: enum_token + !> Invalid token found + integer :: invalid = -1 + !> End of file + integer :: eof = -2 + !> Unclosed group from inline table or array + integer :: unclosed = -3 + !> Whitespace (space, tab) + integer :: whitespace = 0 + !> Newline character (\r\n, \n) + integer :: newline = 1 + !> Comments (#) + integer :: comment = 2 + !> Separator in table path (.) + integer :: dot = 3 + !> Separator in inline arrays and inline tables (,) + integer :: comma = 4 + !> Separator in key-value pairs (=) + integer :: equal = 5 + !> Beginning of an inline table ({) + integer :: lbrace = 6 + !> End of an inline table (}) + integer :: rbrace = 7 + !> Beginning of an inline array or table header ([) + integer :: lbracket = 8 + !> End of an inline array or table header (]) + integer :: rbracket = 9 + !> String literal + integer :: string = 10 + !> String literal + integer :: mstring = 11 + !> String literal + integer :: literal = 12 + !> String literal + integer :: mliteral = 13 + !> String literal + integer :: keypath = 14 + !> Floating point value + integer :: float = 15 + !> Integer value + integer :: int = 16 + !> Boolean value + integer :: bool = 17 + !> Datetime value + integer :: datetime = 18 + !> Absence of value + integer :: nil = 19 + end type enum_token + + !> Actual enumerator for token kinds + type(enum_token), parameter :: token_kind = enum_token() + + !> Token containing + type :: toml_token + !> Kind of token + integer :: kind = token_kind%newline + !> Starting position of the token in character stream + integer :: first = 0 + !> Last position of the token in character stream + integer :: last = 0 + !> Identifier for the chunk index in case of buffered reading + integer :: chunk = 0 + end type toml_token + + !> Reallocate a list of tokens + interface resize + module procedure :: resize_token + end interface + +contains + +!> Reallocate list of tokens +pure subroutine resize_token(var, n) + !> Instance of the array to be resized + type(toml_token), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(toml_token), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 8 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate(tmp) + end if + +end subroutine resize_token + +!> Represent a token as string +pure function stringify(token) result(str) + !> Token to represent as string + type(toml_token), intent(in) :: token + !> String representation of token + character(len=:), allocatable :: str + + select case(token%kind) + case default; str = "unknown" + case(token_kind%invalid); str = "invalid sequence" + case(token_kind%eof); str = "end of file" + case(token_kind%unclosed); str = "unclosed group" + case(token_kind%whitespace); str = "whitespace" + case(token_kind%comment); str = "comment" + case(token_kind%newline); str = "newline" + case(token_kind%dot); str = "dot" + case(token_kind%comma); str = "comma" + case(token_kind%equal); str = "equal" + case(token_kind%lbrace); str = "opening brace" + case(token_kind%rbrace); str = "closing brace" + case(token_kind%lbracket); str = "opening bracket" + case(token_kind%rbracket); str = "closing bracket" + case(token_kind%string); str = "string" + case(token_kind%mstring); str = "multiline string" + case(token_kind%literal); str = "literal" + case(token_kind%mliteral); str = "multiline-literal" + case(token_kind%keypath); str = "keypath" + case(token_kind%int); str = "integer" + case(token_kind%float); str = "float" + case(token_kind%bool); str = "bool" + case(token_kind%datetime); str = "datetime" + case(token_kind%nil); str = "nil" + end select +end function stringify + +end module tomlf_de_token diff --git a/source/third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 b/source/third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 new file mode 100644 index 000000000..5d9ca0ae6 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/diagnostic.f90 @@ -0,0 +1,461 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Diagnostic message support for TOML Fortran +module tomlf_diagnostic + use tomlf_terminal, only : toml_terminal, ansi_code, operator(//), operator(+) + implicit none + private + + public :: render + public :: toml_diagnostic, toml_label + + + interface render + module procedure render_diagnostic + module procedure render_text + module procedure render_text_with_label + module procedure render_text_with_labels + end interface render + + + !> Enumerator for diagnostic levels + type :: level_enum + integer :: error = 0 + integer :: warning = 1 + integer :: help = 2 + integer :: note = 3 + integer :: info = 4 + end type level_enum + + !> Actual enumerator values + type(level_enum), parameter, public :: toml_level = level_enum() + + + type toml_label + !> Level of message + integer :: level + !> Primary message + logical :: primary + !> First and last character of message + integer :: first, last + !> Message text + character(len=:), allocatable :: text + !> Identifier of context + character(len=:), allocatable :: source + end type toml_label + + interface toml_label + module procedure new_label + end interface toml_label + + + !> Definition of diagnostic message + type :: toml_diagnostic + !> Level of message + integer :: level + !> Primary message + character(len=:), allocatable :: message + !> Context of the diagnostic source + character(len=:), allocatable :: source + !> Messages associated with this diagnostic + type(toml_label), allocatable :: label(:) + end type toml_diagnostic + + interface toml_diagnostic + module procedure new_diagnostic + end interface toml_diagnostic + + + type :: line_token + integer :: first, last + end type line_token + + character(len=*), parameter :: nl = new_line('a') + + +contains + + +pure function new_label(level, first, last, text, primary) result(new) + integer, intent(in) :: level + integer, intent(in) :: first, last + character(len=*), intent(in), optional :: text + logical, intent(in), optional :: primary + type(toml_label) :: new + + if (present(text)) new%text = text + new%level = level + new%first = first + new%last = last + if (present(primary)) then + new%primary = primary + else + new%primary = .false. + end if +end function new_label + + +!> Create new diagnostic message +pure function new_diagnostic(level, message, source, label) result(new) + !> Level of message + integer, intent(in) :: level + !> Primary message + character(len=*), intent(in), optional :: message + !> Context of the diagnostic source + character(len=*), intent(in), optional :: source + !> Messages associated with this diagnostic + type(toml_label), intent(in), optional :: label(:) + type(toml_diagnostic) :: new + + new%level = level + if (present(message)) new%message = message + if (present(source)) new%source = source + if (present(label)) new%label = label +end function new_diagnostic + + +pure function line_tokens(input) result(token) + character(len=*), intent(in) :: input + type(line_token), allocatable :: token(:) + + integer :: first, last + + first = 1 + last = 1 + allocate(token(0)) + do while (first <= len(input)) + if (input(last:last) /= nl) then + last = last + 1 + cycle + end if + + token = [token, line_token(first, last-1)] + first = last + 1 + last = first + end do +end function line_tokens + +recursive pure function render_diagnostic(diag, input, color) result(string) + character(len=*), intent(in) :: input + type(toml_diagnostic), intent(in) :: diag + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + render_message(diag%level, diag%message, color) + + if (allocated(diag%label)) then + string = string // nl // & + render_text_with_labels(input, diag%label, color, source=diag%source) + end if +end function render_diagnostic + +pure function render_message(level, message, color) result(string) + integer, intent(in) :: level + character(len=*), intent(in), optional :: message + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + if (present(message)) then + string = & + level_name(level, color) // color%bold // ": " // message // color%reset + else + string = & + level_name(level, color) + end if +end function render_message + +pure function level_name(level, color) result(string) + integer, intent(in) :: level + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + select case(level) + case(toml_level%error) + string = color%bold + color%red // "error" // color%reset + case(toml_level%warning) + string = color%bold + color%yellow // "warning" // color%reset + case(toml_level%help) + string = color%bold + color%cyan // "help" // color%reset + case(toml_level%note) + string = color%bold + color%blue // "note" // color%reset + case(toml_level%info) + string = color%bold + color%magenta // "info" // color%reset + case default + string = color%bold + color%blue // "unknown" // color%reset + end select +end function level_name + +pure function render_source(source, offset, color) result(string) + character(len=*), intent(in) :: source + integer, intent(in) :: offset + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + & repeat(" ", offset) // (color%bold + color%blue) // "-->" // color%reset // " " // source +end function render_source + +function render_text(input, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, offset + type(line_token), allocatable :: token(:) + + allocate(token(0)) ! avoid compiler warning + token = line_tokens(input) + offset = integer_width(size(token)) + + if (present(source)) then + string = render_source(source, offset, color) // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + else + string = & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + end if + + do it = 1, size(token) + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), to_string(it, offset), color) + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text + +function render_text_with_label(input, label, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_label), intent(in) :: label + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, offset, first, last, line, shift + type(line_token), allocatable :: token(:) + + allocate(token(0)) ! avoid compiler warning + token = line_tokens(input) + line = count(token%first < label%first) + shift = token(line)%first - 1 + first = max(1, line - 1) + last = min(size(token), line + 1) + offset = integer_width(last) + + if (present(source)) then + string = render_source(source, offset, color) // ":" // & + & to_string(line) // ":" // & + & to_string(label%first) + if (label%first /= label%last) then + string = string // "-" // to_string(label%last) + end if + end if + string = string // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + + do it = first, last + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), & + & to_string(it, offset), color) + if (it == line) then + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset // & + & render_label(label, shift, color) + end if + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text_with_label + +pure function render_text_with_labels(input, label, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_label), intent(in) :: label(:) + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, il, offset, first, last, line(size(label)), shift(size(label)) + type(line_token), allocatable :: token(:) + logical, allocatable :: display(:) + + allocate(token(0)) ! avoid compiler warning + allocate(character(len=0) :: string) ! Allocate to avoid referencing an unallocated variable + token = line_tokens(input) + line(:) = [(count(token%first <= label(it)%first), it = 1, size(label))] + shift(:) = token(line)%first - 1 + first = max(1, minval(line)) + last = min(size(token), maxval(line)) + offset = integer_width(last) + + it = 1 ! Without a primary we use the first label + do il = 1, size(label) + if (label(il)%primary) then + it = il + exit + end if + end do + + if (present(source)) then + string = render_source(source, offset, color) // ":" // & + & to_string(line(it)) // ":" // & + & to_string(label(it)%first-shift(it)) + if (label(it)%first /= label(it)%last) then + string = string // "-" // to_string(label(it)%last-shift(it)) + end if + end if + string = string // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + + allocate(display(first:last), source=.false.) + do il = 1, size(label) + ! display(max(first, line(il) - 1):min(last, line(il) + 1)) = .true. + display(line(il)) = .true. + end do + + do it = first, last + if (.not.display(it)) then + if (display(it-1) .and. count(display(it:)) > 0) then + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // ":" // color%reset + end if + cycle + end if + + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), & + & to_string(it, offset), color) + if (any(it == line)) then + do il = 1, size(label) + if (line(il) /= it) cycle + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset // & + & render_label(label(il), shift(il), color) + end do + end if + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text_with_labels + +pure function render_label(label, shift, color) result(string) + type(toml_label), intent(in) :: label + integer, intent(in) :: shift + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + integer :: width + character :: marker + type(ansi_code) :: this_color + + marker = merge("^", "-", label%primary) + width = label%last - label%first + 1 + this_color = level_color(label%level, color) + + string = & + & repeat(" ", label%first - shift) // this_color // repeat(marker, width) // color%reset + if (allocated(label%text)) then + string = string // & + & " " // this_color // label%text // color%reset + end if + +end function render_label + +pure function level_color(level, color) result(this_color) + integer, intent(in) :: level + type(toml_terminal), intent(in) :: color + type(ansi_code) :: this_color + + select case(level) + case(toml_level%error) + this_color = color%bold + color%red + case(toml_level%warning) + this_color = color%bold + color%yellow + case(toml_level%help) + this_color = color%bold + color%cyan + case(toml_level%info) + this_color = color%bold + color%magenta + case default + this_color = color%bold + color%blue + end select +end function level_color + +pure function render_line(input, line, color) result(string) + character(len=*), intent(in) :: input + character(len=*), intent(in) :: line + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + & line // " " // (color%bold + color%blue) // "|" // color%reset // " " // input +end function render_line + +pure function integer_width(input) result(width) + integer, intent(in) :: input + integer :: width + + integer :: val + + val = input + width = 0 + do while (val /= 0) + val = val / 10 + width = width + 1 + end do + +end function integer_width + +!> Represent an integer as character sequence. +pure function to_string(val, width) result(string) + integer, intent(in) :: val + integer, intent(in), optional :: width + character(len=:), allocatable :: string + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer :: n + character(len=1), parameter :: numbers(0:9) = & + ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] + + if (val == 0) then + string = numbers(0) + return + end if + + n = abs(val) + buffer = "" + + pos = buffer_len + 1 + do while (n > 0) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10)) + n = n/10 + end do + if (val < 0) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + if (present(width)) then + string = repeat(" ", max(width-(buffer_len+1-pos), 0)) // buffer(pos:) + else + string = buffer(pos:) + end if +end function to_string + + +end module tomlf_diagnostic diff --git a/source/third_party_open/utils/toml-f/src/tomlf/error.f90 b/source/third_party_open/utils/toml-f/src/tomlf/error.f90 new file mode 100644 index 000000000..7fde4344e --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/error.f90 @@ -0,0 +1,114 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Error handling for TOML Fortran +!> +!> This module provides the [[toml_error]] type for error reporting and +!> the [[toml_stat]] enumerator for status codes returned by various +!> TOML Fortran procedures. +!> +!> ## Error Handling +!> +!> Most parsing and access functions accept an optional `error` argument +!> of type [[toml_error]]. If an error occurs, this will be allocated +!> and contain a descriptive message: +!> +!>```fortran +!> type(toml_error), allocatable :: error +!> call toml_load(table, "config.toml", error=error) +!> if (allocated(error)) print '(a)', error%message +!>``` +!> +!> ## Status Codes +!> +!> The [[toml_stat]] enumerator provides named constants for common +!> error conditions like `toml_stat%duplicate_key` or `toml_stat%type_mismatch`. +module tomlf_error + use tomlf_constants, only : tfc, TOML_NEWLINE + implicit none + private + + public :: toml_stat, toml_error, make_error + + + !> Possible TOML Fortran status codes + type :: enum_stat + + !> Successful run + integer :: success = 0 + + !> Internal error: + !> + !> General undefined error state, usually caused by algorithmic errors. + integer :: fatal = -1 + + !> Duplicate key encountered + integer :: duplicate_key = -2 + + !> Incorrect type when reading a value + integer :: type_mismatch = -3 + + !> Conversion error when downcasting a value + integer :: conversion_error = -4 + + !> Key not present in table + integer :: missing_key = -5 + + end type enum_stat + + !> Actual enumerator for return states + !> + !> | Name | Description | + !> |------|-------------| + !> | `success` | Operation completed successfully | + !> | `fatal` | Internal error or undefined error state | + !> | `duplicate_key` | Duplicate key encountered in table | + !> | `type_mismatch` | Incorrect type when reading a value | + !> | `conversion_error` | Error when converting or downcasting a value | + !> | `missing_key` | Requested key not present in table | + type(enum_stat), parameter :: toml_stat = enum_stat() + + + !> Error message produced by TOML-Fortran + type :: toml_error + + !> Error code + integer :: stat = toml_stat%fatal + + !> Payload of the error + character(kind=tfc, len=:), allocatable :: message + + end type toml_error + + +contains + +!> Create new error message +subroutine make_error(error, message, stat) + !> Error report + type(toml_error), allocatable, intent(out) :: error + !> Message for the error + character(*, tfc), intent(in) :: message + !> Status code + integer, intent(in), optional :: stat + + allocate(error) + error%message = message + if (present(stat)) then + error%stat = stat + else + error%stat = toml_stat%fatal + end if +end subroutine make_error + +end module tomlf_error diff --git a/source/third_party_open/utils/toml-f/src/tomlf/ser.f90 b/source/third_party_open/utils/toml-f/src/tomlf/ser.f90 new file mode 100644 index 000000000..0dcf37140 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/ser.f90 @@ -0,0 +1,545 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML serialization module +!> +!> This module provides interfaces for serializing TOML data structures +!> back to TOML format. The primary interfaces are: +!> +!> - [[toml_dump]]: Write a TOML table to a file or I/O unit +!> - [[toml_dumps]]: Serialize a TOML table to a string +!> - [[toml_serialize]]: Low-level serialization using the visitor pattern +!> +!> The [[toml_serializer]] type implements the visitor pattern and can be +!> used directly for custom serialization workflows. +module tomlf_ser + use tomlf_constants, only : tfc, tfi, tfr, tfout, toml_type + use tomlf_datetime, only : toml_datetime, to_string + use tomlf_error, only : toml_error, toml_stat, make_error + use tomlf_type, only : toml_value, toml_visitor, toml_key, toml_table, & + & toml_array, toml_keyval, is_array_of_tables, len + use tomlf_utils, only : to_string, toml_escape_string + implicit none + private + + public :: toml_serializer, new_serializer, new + public :: toml_dump, toml_dumps, toml_serialize + + + interface toml_dumps + module procedure :: toml_dump_to_string + end interface toml_dumps + + interface toml_dump + module procedure :: toml_dump_to_file + module procedure :: toml_dump_to_unit + end interface toml_dump + + + !> Configuration for JSON serializer + type :: toml_ser_config + + !> Indentation + character(len=:), allocatable :: indent + + end type toml_ser_config + + + !> TOML serializer to produduce a TOML document from a datastructure + type, extends(toml_visitor) :: toml_serializer + private + + !> Output string + character(:), allocatable :: output + + !> Configuration for serializer + type(toml_ser_config) :: config = toml_ser_config() + + !> Special mode for printing array of tables + logical, private :: array_of_tables = .false. + + !> Special mode for printing inline arrays + logical, private :: inline_array = .false. + + !> Top of the key stack + integer, private :: top = 0 + + !> Key stack to create table headers + type(toml_key), allocatable, private :: stack(:) + + contains + + !> Visit a TOML value + procedure :: visit + + end type toml_serializer + + + !> Create standard constructor + interface toml_serializer + module procedure :: new_serializer_func + end interface toml_serializer + + + !> Overloaded constructor for TOML serializers + interface new + module procedure :: new_serializer + end interface + + + !> Initial size of the key path stack + integer, parameter :: initial_size = 8 + + +contains + + +!> Serialize a JSON value to a string and return it. +!> +!> In case of an error this function will invoke an error stop. +function toml_serialize(val, config) result(string) + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + !> Serialized JSON value + character(len=:), allocatable :: string + + type(toml_error), allocatable :: error + + call toml_dumps(val, string, error, config=config) + if (allocated(error)) then + print '(a)', "Error: " // error%message + error stop 1 + end if +end function toml_serialize + + +!> Create a string representing the JSON value +subroutine toml_dump_to_string(val, string, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Formatted unit to write to + character(:), allocatable, intent(out) :: string + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + type(toml_serializer) :: ser + + ser = toml_serializer(config=config) + call val%accept(ser) + string = ser%output +end subroutine toml_dump_to_string + + +!> Write string representation of JSON value to a connected formatted unit +subroutine toml_dump_to_unit(val, io, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Formatted unit to write to + integer, intent(in) :: io + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + character(len=:), allocatable :: string + character(512) :: msg + integer :: stat + + call toml_dumps(val, string, error, config=config) + if (allocated(error)) return + write(io, '(a)', iostat=stat, iomsg=msg) string + if (stat /= 0) then + call make_error(error, trim(msg)) + return + end if +end subroutine toml_dump_to_unit + + +!> Write string representation of JSON value to a file +subroutine toml_dump_to_file(val, filename, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> File name to write to + character(*), intent(in) :: filename + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + integer :: io + integer :: stat + character(512) :: msg + + open(file=filename, newunit=io, iostat=stat, iomsg=msg) + if (stat /= 0) then + call make_error(error, trim(msg)) + return + end if + call toml_dump(val, io, error, config=config) + close(unit=io, iostat=stat, iomsg=msg) + if (.not.allocated(error) .and. stat /= 0) then + call make_error(error, trim(msg)) + end if +end subroutine toml_dump_to_file + + +!> Constructor to create new serializer instance +subroutine new_serializer(self, config) + + !> Instance of the TOML serializer + type(toml_serializer), intent(out) :: self + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + self%output = "" + if (present(config)) self%config = config +end subroutine new_serializer + + +!> Default constructor for TOML serializer +function new_serializer_func(config) result(self) + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + !> Instance of the TOML serializer + type(toml_serializer) :: self + + call new_serializer(self, config) +end function new_serializer_func + + +!> Visit a TOML value +recursive subroutine visit(self, val) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: self + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + select type(val) + class is(toml_keyval) + call visit_keyval(self, val) + class is(toml_array) + call visit_array(self, val) + class is(toml_table) + call visit_table(self, val) + end select + +end subroutine visit + + +!> Visit a TOML key-value pair +subroutine visit_keyval(visitor, keyval) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML value to visit + type(toml_keyval), intent(inout) :: keyval + + character(kind=tfc, len=:), allocatable :: key, str + type(toml_datetime), pointer :: dval + character(:, tfc), pointer :: sval + integer(tfi), pointer :: ival + real(tfr), pointer :: rval + logical, pointer :: lval + + call keyval%get_key(key) + + select case(keyval%get_type()) + case(toml_type%string) + call keyval%get(sval) + call toml_escape_string(sval, str) + case(toml_type%int) + call keyval%get(ival) + str = to_string(ival) + case(toml_type%float) + call keyval%get(rval) + str = to_string(rval) + case(toml_type%boolean) + call keyval%get(lval) + if (lval) then + str = "true" + else + str = "false" + end if + case(toml_type%datetime) + call keyval%get(dval) + str = to_string(dval) + end select + + if (visitor%inline_array) then + visitor%output = visitor%output // " " + end if + visitor%output = visitor%output // key // " = " // str + if (.not.visitor%inline_array) then + visitor%output = visitor%output // new_line('a') + end if + +end subroutine visit_keyval + + +!> Visit a TOML array +recursive subroutine visit_array(visitor, array) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML value to visit + type(toml_array), intent(inout) :: array + + class(toml_value), pointer :: ptr + character(kind=tfc, len=:), allocatable :: key, str + type(toml_datetime), pointer :: dval + character(:, tfc), pointer :: sval + integer(tfi), pointer :: ival + real(tfr), pointer :: rval + logical, pointer :: lval + integer :: i, n + + if (visitor%inline_array) visitor%output = visitor%output // " [" + n = len(array) + do i = 1, n + call array%get(i, ptr) + select type(ptr) + class is(toml_keyval) + + select case(ptr%get_type()) + case(toml_type%string) + call ptr%get(sval) + call toml_escape_string(sval, str) + case(toml_type%int) + call ptr%get(ival) + str = to_string(ival) + case(toml_type%float) + call ptr%get(rval) + str = to_string(rval) + case(toml_type%boolean) + call ptr%get(lval) + if (lval) then + str = "true" + else + str = "false" + end if + case(toml_type%datetime) + call ptr%get(dval) + str = to_string(dval) + end select + + visitor%output = visitor%output // " " // str + if (i /= n) visitor%output = visitor%output // "," + class is(toml_array) + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + class is(toml_table) + if (visitor%inline_array) then + visitor%output = visitor%output // " {" + call ptr%accept(visitor) + visitor%output = visitor%output // " }" + if (i /= n) visitor%output = visitor%output // "," + else + visitor%array_of_tables = .true. + if (size(visitor%stack, 1) <= visitor%top) call resize(visitor%stack) + visitor%top = visitor%top + 1 + call array%get_key(key) + visitor%stack(visitor%top)%key = key + call ptr%accept(visitor) + deallocate(visitor%stack(visitor%top)%key) + visitor%top = visitor%top - 1 + end if + end select + end do + if (visitor%inline_array) visitor%output = visitor%output // " ]" + +end subroutine visit_array + + +!> Visit a TOML table +recursive subroutine visit_table(visitor, table) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML table to visit + type(toml_table), intent(inout) :: table + + class(toml_value), pointer :: ptr + type(toml_key), allocatable :: list(:) + logical, allocatable :: defer(:) + character(kind=tfc, len=:), allocatable :: key + integer :: i, n + + call table%get_keys(list) + + n = size(list, 1) + allocate(defer(n)) + + if (.not.allocated(visitor%stack)) then + call resize(visitor%stack) + else + if (.not.(visitor%inline_array .or. table%implicit)) then + visitor%output = visitor%output // "[" + if (visitor%array_of_tables) visitor%output = visitor%output // "[" + do i = 1, visitor%top-1 + visitor%output = visitor%output // visitor%stack(i)%key // "." + end do + visitor%output = visitor%output // visitor%stack(visitor%top)%key + visitor%output = visitor%output // "]" + if (visitor%array_of_tables) visitor%output = visitor%output // "]" + visitor%output = visitor%output // new_line('a') + visitor%array_of_tables = .false. + end if + end if + + do i = 1, n + defer(i) = .false. + call table%get(list(i)%key, ptr) + select type(ptr) + class is(toml_keyval) + call ptr%accept(visitor) + if (visitor%inline_array) then + if (i /= n) visitor%output = visitor%output // "," + end if + class is(toml_array) + if (visitor%inline_array) then + call ptr%get_key(key) + visitor%output = visitor%output // " " // key // " =" + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + else + if (is_array_of_tables(ptr)) then + ! Array of tables open a new section + ! -> cannot serialize them before all key-value pairs are done + defer(i) = .true. + else + visitor%inline_array = .true. + call ptr%get_key(key) + visitor%output = visitor%output // key // " =" + call ptr%accept(visitor) + visitor%inline_array = .false. + visitor%output = visitor%output // new_line('a') + end if + end if + class is(toml_table) + ! Subtables open a new section + ! -> cannot serialize them before all key-value pairs are done + defer(i) = .true. + end select + end do + + do i = 1, n + if (defer(i)) then + call table%get(list(i)%key, ptr) + select type(ptr) + class is(toml_keyval) + call ptr%accept(visitor) + if (visitor%inline_array) then + if (i /= n) visitor%output = visitor%output // "," + end if + class is(toml_array) + if (visitor%inline_array) then + call ptr%get_key(key) + visitor%output = visitor%output // " " // key // " =" + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + else + if (is_array_of_tables(ptr)) then + call ptr%accept(visitor) + else + visitor%inline_array = .true. + call ptr%get_key(key) + visitor%output = visitor%output // key // " =" + call ptr%accept(visitor) + visitor%inline_array = .false. + visitor%output = visitor%output // new_line('a') + end if + end if + class is(toml_table) + if (size(visitor%stack, 1) <= visitor%top) call resize(visitor%stack) + visitor%top = visitor%top + 1 + call ptr%get_key(key) + visitor%stack(visitor%top)%key = key + call ptr%accept(visitor) + deallocate(visitor%stack(visitor%top)%key) + visitor%top = visitor%top - 1 + end select + end if + end do + + if (.not.visitor%inline_array .and. visitor%top == 0) then + deallocate(visitor%stack) + end if + +end subroutine visit_table + + +!> Change size of the stack +subroutine resize(stack, n) + + !> Stack of keys to be resized + type(toml_key), allocatable, intent(inout) :: stack(:) + + !> New size of the stack + integer, intent(in), optional :: n + + type(toml_key), allocatable :: tmp(:) + integer :: m + + if (present(n)) then + m = n + else + if (allocated(stack)) then + m = size(stack) + m = m + m/2 + 1 + else + m = initial_size + end if + end if + + if (allocated(stack)) then + call move_alloc(stack, tmp) + allocate(stack(m)) + + m = min(size(tmp), m) + stack(:m) = tmp(:m) + + deallocate(tmp) + else + allocate(stack(m)) + end if + +end subroutine resize + + +end module tomlf_ser diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure.f90 new file mode 100644 index 000000000..54e286288 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure.f90 @@ -0,0 +1,75 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstraction layer for the actual storage of the data structure. +!> +!> The structure implementations provide the actual storage for TOML values, with +!> a generic enough interface to make the definition of the TOML data structures +!> independent of the actual algorithm used for storing the TOML values. +!> +!> Every data structure defined here should strive to only use allocatable +!> data types and limit the use of pointer attributes as they interfer with +!> the automatic memory management of Fortran. A well defined data structure +!> in allocatables allows deep-copying of TOML values by assignment, data structures +!> requiring pointer attributes have to define an assignment(=) interface to +!> allow deep-copying of TOML values. +module tomlf_structure + use tomlf_structure_list, only : toml_list_structure + use tomlf_structure_map, only : toml_map_structure + use tomlf_structure_array_list, only : toml_array_list, new_array_list + use tomlf_structure_ordered_map, only : toml_ordered_map, new_ordered_map + implicit none + private + + public :: toml_list_structure, toml_map_structure + public :: new_list_structure, new_map_structure + + +contains + + +!> Constructor for the ordered storage data structure +subroutine new_list_structure(self) + + !> Instance of the structure + class(toml_list_structure), allocatable, intent(out) :: self + + block + type(toml_array_list), allocatable :: list + + allocate(list) + call new_array_list(list) + call move_alloc(list, self) + end block + +end subroutine new_list_structure + + +!> Constructor for the storage data structure +subroutine new_map_structure(self) + + !> Instance of the structure + class(toml_map_structure), allocatable, intent(out) :: self + + block + type(toml_ordered_map), allocatable :: map + + allocate(map) + call new_ordered_map(map) + call move_alloc(map, self) + end block + +end subroutine new_map_structure + + +end module tomlf_structure diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 new file mode 100644 index 000000000..670a86c2a --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/array_list.f90 @@ -0,0 +1,209 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_array_list + use tomlf_constants, only : tfc + use tomlf_structure_list, only : toml_list_structure + use tomlf_structure_node, only : toml_node, resize + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_array_list, new_array_list + + + !> Stores TOML values in a list of pointers + type, extends(toml_list_structure) :: toml_array_list + + !> Current number of stored TOML values + integer :: n = 0 + + !> List of TOML values + type(toml_node), allocatable :: lst(:) + + contains + + !> Get number of TOML values in the structure + procedure :: get_len + + !> Get TOML value at a given index + procedure :: get + + !> Push back a TOML value to the structure + procedure :: push_back + + !> Remove the first element from the structure + procedure :: shift + + !> Remove the last element from the structure + procedure :: pop + + !> Destroy the data structure + procedure :: destroy + + end type toml_array_list + + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + + +contains + + +!> Constructor for the storage data structure +subroutine new_array_list(self, n) + + !> Instance of the structure + type(toml_array_list), intent(out) :: self + + !> Initial storage capacity + integer, intent(in), optional :: n + + self%n = 0 + if (present(n)) then + allocate(self%lst(min(1, n))) + else + allocate(self%lst(initial_size)) + end if + +end subroutine new_array_list + + +!> Get number of TOML values in the structure +pure function get_len(self) result(length) + + !> Instance of the structure + class(toml_array_list), intent(in), target :: self + + !> Current length of the ordered structure + integer :: length + + length = self%n + +end function get_len + + +!> Get TOML value at a given index +subroutine get(self, idx, ptr) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> Position in the ordered structure + integer, intent(in) :: idx + + !> Pointer to the stored value at given index + class(toml_value), pointer, intent(out) :: ptr + + nullify(ptr) + + if (idx > 0 .and. idx <= self%n) then + if (allocated(self%lst(idx)%val)) then + ptr => self%lst(idx)%val + end if + end if + +end subroutine get + + +!> Push back a TOML value to the structure +subroutine push_back(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + integer :: m + + if (.not.allocated(self%lst)) then + call resize(self%lst, initial_size) + end if + + m = size(self%lst) + if (self%n >= m) then + call resize(self%lst, m + m/2 + 1) + end if + + self%n = self%n + 1 + call move_alloc(val, self%lst(self%n)%val) + +end subroutine push_back + + +!> Remove the first element from the data structure +subroutine shift(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + integer :: i + + if (self%n > 0) then + call move_alloc(self%lst(1)%val, val) + do i = 2, self%n + call move_alloc(self%lst(i)%val, self%lst(i-1)%val) + end do + self%n = self%n - 1 + end if + +end subroutine shift + + +!> Remove the last element from the data structure +subroutine pop(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + if (self%n > 0) then + call move_alloc(self%lst(self%n)%val, val) + self%n = self%n - 1 + end if + +end subroutine pop + + +!> Deconstructor for data structure +subroutine destroy(self) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + integer :: i + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + call self%lst(i)%val%destroy + end if + end do + + deallocate(self%lst) + self%n = 0 + +end subroutine destroy + + +end module tomlf_structure_array_list diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/list.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/list.f90 new file mode 100644 index 000000000..c01f54c56 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/list.f90 @@ -0,0 +1,141 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstract base class definitions for data structures to store TOML values +module tomlf_structure_list + use tomlf_constants, only : tfc + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_list_structure + + + !> Ordered data structure, allows iterations + type, abstract :: toml_list_structure + contains + + !> Get number of TOML values in the structure + procedure(get_len), deferred :: get_len + + !> Push back a TOML value to the structure + procedure(push_back), deferred :: push_back + + !> Remove the first element from the structure + procedure(shift), deferred :: shift + + !> Remove the last element from the structure + procedure(pop), deferred :: pop + + !> Get TOML value at a given index + procedure(get), deferred :: get + + !> Destroy the data structure + procedure(destroy), deferred :: destroy + + end type toml_list_structure + + + abstract interface + !> Get number of TOML values in the structure + pure function get_len(self) result(length) + import :: toml_list_structure + + !> Instance of the structure + class(toml_list_structure), intent(in), target :: self + + !> Current length of the ordered structure + integer :: length + end function get_len + + + !> Get TOML value at a given index + subroutine get(self, idx, ptr) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> Position in the ordered structure + integer, intent(in) :: idx + + !> Pointer to the stored value at given index + class(toml_value), pointer, intent(out) :: ptr + end subroutine get + + + !> Push back a TOML value to the structure + subroutine push_back(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + end subroutine push_back + + + !> Remove the first element from the data structure + subroutine shift(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + end subroutine shift + + + !> Remove the last element from the data structure + subroutine pop(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + end subroutine pop + + + !> Delete TOML value at a given key + subroutine delete(self, key) + import :: toml_list_structure, toml_value, tfc + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + end subroutine delete + + + !> Deconstructor for data structure + subroutine destroy(self) + import :: toml_list_structure + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + end subroutine destroy + + end interface + + +end module tomlf_structure_list diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/map.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/map.f90 new file mode 100644 index 000000000..e1f4437eb --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/map.f90 @@ -0,0 +1,132 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstract base class definitions for data structures to store TOML values +module tomlf_structure_map + use tomlf_constants, only : tfc + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_map_structure + + + !> Abstract data structure + type, abstract :: toml_map_structure + contains + + !> Get TOML value at a given key + procedure(get), deferred :: get + + !> Push back a TOML value to the structure + procedure(push_back), deferred :: push_back + + !> Get list of all keys in the structure + procedure(get_keys), deferred :: get_keys + + !> Remove TOML value at a given key and return it + procedure(pop), deferred :: pop + + !> Delete TOML value at a given key + procedure(delete), deferred :: delete + + !> Destroy the data structure + procedure(destroy), deferred :: destroy + + end type toml_map_structure + + + abstract interface + !> Get TOML value at a given key + subroutine get(self, key, ptr) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the stored value at given key + class(toml_value), pointer, intent(out) :: ptr + end subroutine get + + + !> Push back a TOML value to the structure + subroutine push_back(self, val) + import :: toml_map_structure, toml_value + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + end subroutine push_back + + + !> Get list of all keys in the structure + subroutine get_keys(self, list) + import :: toml_map_structure, toml_key + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + end subroutine get_keys + + + !> Remove TOML value at a given key and return it + subroutine pop(self, key, val) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value + class(toml_value), allocatable, intent(out) :: val + + end subroutine pop + + + !> Delete TOML value at a given key + subroutine delete(self, key) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + end subroutine delete + + + !> Deconstructor for data structure + subroutine destroy(self) + import :: toml_map_structure + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + end subroutine destroy + + end interface + + +end module tomlf_structure_map diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/node.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/node.f90 new file mode 100644 index 000000000..e2d8ac38b --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/node.f90 @@ -0,0 +1,79 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_node + use tomlf_type_value, only : toml_value + implicit none + private + + public :: toml_node, resize + + + !> Wrapped TOML value to generate pointer list + type :: toml_node + + !> TOML value payload + class(toml_value), allocatable :: val + + end type toml_node + + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + + +contains + + +!> Change size of the TOML value list +subroutine resize(list, n) + + !> Array of TOML values to be resized + type(toml_node), allocatable, intent(inout), target :: list(:) + + !> New size of the list + integer, intent(in) :: n + + type(toml_node), allocatable, target :: tmp(:) + integer :: i + + + if (allocated(list)) then + call move_alloc(list, tmp) + allocate(list(n)) + + do i = 1, min(size(tmp), n) + if (allocated(tmp(i)%val)) then + call move_alloc(tmp(i)%val, list(i)%val) + end if + end do + + do i = n+1, size(tmp) + if (allocated(tmp(i)%val)) then + call tmp(i)%val%destroy + deallocate(tmp(i)%val) + end if + end do + + deallocate(tmp) + else + allocate(list(n)) + end if + +end subroutine resize + +end module tomlf_structure_node diff --git a/source/third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 b/source/third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 new file mode 100644 index 000000000..a2234a607 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/structure/ordered_map.f90 @@ -0,0 +1,240 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_ordered_map + use tomlf_constants, only : tfc + use tomlf_structure_map, only : toml_map_structure + use tomlf_structure_node, only : toml_node, resize + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_ordered_map, new_ordered_map + + + !> Stores TOML values in a list of pointers + type, extends(toml_map_structure) :: toml_ordered_map + + !> Current number of stored TOML values + integer :: n = 0 + + !> List of TOML values + type(toml_node), allocatable :: lst(:) + + contains + + !> Get TOML value at a given key + procedure :: get + + !> Push back a TOML value to the structure + procedure :: push_back + + !> Remove TOML value at a given key and return it + procedure :: pop + + !> Get list of all keys in the structure + procedure :: get_keys + + !> Delete TOML value at a given key + procedure :: delete + + !> Destroy the data structure + procedure :: destroy + + end type toml_ordered_map + + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + + +contains + + +!> Constructor for the storage data structure +subroutine new_ordered_map(self, n) + + !> Instance of the structure + type(toml_ordered_map), intent(out) :: self + + !> Initial storage capacity + integer, intent(in), optional :: n + + self%n = 0 + if (present(n)) then + allocate(self%lst(min(1, n))) + else + allocate(self%lst(initial_size)) + end if + +end subroutine new_ordered_map + + +!> Get TOML value at a given key +subroutine get(self, key, ptr) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the stored value at given key + class(toml_value), pointer, intent(out) :: ptr + + integer :: i + + nullify(ptr) + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (self%lst(i)%val%match_key(key)) then + ptr => self%lst(i)%val + exit + end if + end if + end do + +end subroutine get + + +!> Push back a TOML value to the structure +subroutine push_back(self, val) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + integer :: m + + if (.not.allocated(self%lst)) then + call resize(self%lst, initial_size) + end if + + m = size(self%lst) + if (self%n >= m) then + call resize(self%lst, m + m/2 + 1) + end if + + self%n = self%n + 1 + call move_alloc(val, self%lst(self%n)%val) + +end subroutine push_back + + +!> Get list of all keys in the structure +subroutine get_keys(self, list) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + integer :: i + + allocate(list(self%n)) + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (allocated(self%lst(i)%val%key)) then + list(i)%key = self%lst(i)%val%key + list(i)%origin = self%lst(i)%val%origin + end if + end if + end do + +end subroutine get_keys + + +!> Remove TOML value at a given key and return it +subroutine pop(self, key, val) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value + class(toml_value), allocatable, intent(out) :: val + + integer :: idx, i + + idx = 0 + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (self%lst(i)%val%match_key(key)) then + idx = i + exit + end if + end if + end do + + if (idx > 0) then + call move_alloc(self%lst(idx)%val, val) + do i = idx+1, self%n + call move_alloc(self%lst(i)%val, self%lst(i-1)%val) + end do + self%n = self%n - 1 + end if + +end subroutine pop + + +!> Delete TOML value at a given key +subroutine delete(self, key) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + class(toml_value), allocatable :: val + + call self%pop(key, val) + if (allocated(val)) then + call val%destroy() + end if + +end subroutine delete + + +!> Deconstructor for data structure +subroutine destroy(self) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + integer :: i + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + call self%lst(i)%val%destroy + end if + end do + + deallocate(self%lst) + self%n = 0 + +end subroutine destroy + + +end module tomlf_structure_ordered_map diff --git a/source/third_party_open/utils/toml-f/src/tomlf/terminal.f90 b/source/third_party_open/utils/toml-f/src/tomlf/terminal.f90 new file mode 100644 index 000000000..be587a811 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/terminal.f90 @@ -0,0 +1,326 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a terminal to provide ANSI escape sequences +!> +!> ANSI escape codes for producing terminal colors. The `ansi_code` derived +!> type is used to store ANSI escape codes and can be combined with other +!> codes or applied to strings by concatenation. The default or uninitialized +!> `ansi_code` is a stub and does not produce escape sequences when applied +!> to a string. +!> +!> Available colors are +!> +!> color | foreground | background +!> -------------- | --------------------- | ------------------------ +!> black | `black` (30) | `bg_black` (40) +!> red | `red` (31) | `bg_red` (41) +!> green | `green` (32) | `bg_green` (42) +!> yellow | `yellow` (33) | `bg_yellow` (43) +!> blue | `blue` (34) | `bg_blue` (44) +!> magenta | `magenta` (35) | `bg_magenta` (45) +!> cyan | `cyan` (36) | `bg_cyan` (46) +!> white | `white` (37) | `bg_white` (47) +!> gray | `gray` (90) | `bg_gray` (100) +!> bright red | `bright_red` (91) | `bg_bright_red` (101) +!> bright green | `bright_green` (92) | `bg_bright_green` (102) +!> bright yellow | `bright_yellow` (93) | `bg_bright_yellow` (103) +!> bright blue | `bright_blue` (94) | `bg_bright_blue` (104) +!> bright magenta | `bright_magenta` (95) | `bg_bright_magenta` (105) +!> bright cyan | `bright_cyan` (96) | `bg_bright_cyan` (106) +!> bright white | `bright_white` (97) | `bg_bright_white` (107) +!> +!> Available styles are +!> +!> style | +!> ------------| --------------- +!> reset | `reset` (0) +!> bold | `bold` (1) +!> dim | `dim` (2) +!> italic | `italic` (3) +!> underline | `underline` (4) +!> blink | `blink` (5) +!> blink rapid | `blink_rapid` (6) +!> reverse | `reverse` (7) +!> hidden | `hidden` (8) +!> crossed | `crossed` (9) +module tomlf_terminal + use tomlf_utils, only : to_string + implicit none + private + + public :: toml_terminal + public :: ansi_code, escape, operator(+), operator(//) + + + !> Char length for integers + integer, parameter :: i1 = selected_int_kind(2) + + !> Container for terminal escape code + type :: ansi_code + private + !> Style descriptor + integer(i1) :: style = -1_i1 + !> Background color descriptor + integer(i1) :: bg = -1_i1 + !> Foreground color descriptor + integer(i1) :: fg = -1_i1 + end type + + interface operator(+) + module procedure :: add + end interface operator(+) + + interface operator(//) + module procedure :: concat_left + module procedure :: concat_right + end interface operator(//) + + interface escape + module procedure :: escape + end interface escape + + type(ansi_code), public, parameter :: & + reset = ansi_code(style=0_i1), & + bold = ansi_code(style=1_i1), & + dim = ansi_code(style=2_i1), & + italic = ansi_code(style=3_i1), & + underline = ansi_code(style=4_i1), & + blink = ansi_code(style=5_i1), & + blink_rapid = ansi_code(style=6_i1), & + reverse = ansi_code(style=7_i1), & + hidden = ansi_code(style=8_i1), & + crossed = ansi_code(style=9_i1) + + type(ansi_code), public, parameter :: & + black = ansi_code(fg=30_i1), & + red = ansi_code(fg=31_i1), & + green = ansi_code(fg=32_i1), & + yellow = ansi_code(fg=33_i1), & + blue = ansi_code(fg=34_i1), & + magenta = ansi_code(fg=35_i1), & + cyan = ansi_code(fg=36_i1), & + white = ansi_code(fg=37_i1), & + gray = ansi_code(fg=90_i1), & + bright_red = ansi_code(fg=91_i1), & + bright_green = ansi_code(fg=92_i1), & + bright_yellow = ansi_code(fg=93_i1), & + bright_blue = ansi_code(fg=94_i1), & + bright_magenta = ansi_code(fg=95_i1), & + bright_cyan = ansi_code(fg=96_i1), & + bright_white = ansi_code(fg=97_i1) + + type(ansi_code), public, parameter :: & + bg_black = ansi_code(bg=40_i1), & + bg_red = ansi_code(bg=41_i1), & + bg_green = ansi_code(bg=42_i1), & + bg_yellow = ansi_code(bg=43_i1), & + bg_blue = ansi_code(bg=44_i1), & + bg_magenta = ansi_code(bg=45_i1), & + bg_cyan = ansi_code(bg=46_i1), & + bg_white = ansi_code(bg=47_i1), & + bg_gray = ansi_code(bg=100_i1), & + bg_bright_red = ansi_code(bg=101_i1), & + bg_bright_green = ansi_code(bg=102_i1), & + bg_bright_yellow = ansi_code(bg=103_i1), & + bg_bright_blue = ansi_code(bg=104_i1), & + bg_bright_magenta = ansi_code(bg=105_i1), & + bg_bright_cyan = ansi_code(bg=106_i1), & + bg_bright_white = ansi_code(bg=107_i1) + + + !> Terminal wrapper to handle color escape sequences, must be initialized with + !> color support to provide colorful output. Default and uninitialized instances + !> will remain usable but provide only stubs and do not produce colorful output. + !> This behavior is useful for creating applications which can toggle color support. + type :: toml_terminal + type(ansi_code) :: & + reset = ansi_code(), & + bold = ansi_code(), & + dim = ansi_code(), & + italic = ansi_code(), & + underline = ansi_code(), & + blink = ansi_code(), & + blink_rapid = ansi_code(), & + reverse = ansi_code(), & + hidden = ansi_code(), & + crossed = ansi_code() + + type(ansi_code) :: & + black = ansi_code(), & + red = ansi_code(), & + green = ansi_code(), & + yellow = ansi_code(), & + blue = ansi_code(), & + magenta = ansi_code(), & + cyan = ansi_code(), & + white = ansi_code(), & + gray = ansi_code(), & + bright_red = ansi_code(), & + bright_green = ansi_code(), & + bright_yellow = ansi_code(), & + bright_blue = ansi_code(), & + bright_magenta = ansi_code(), & + bright_cyan = ansi_code(), & + bright_white = ansi_code() + + type(ansi_code) :: & + bg_black = ansi_code(), & + bg_red = ansi_code(), & + bg_green = ansi_code(), & + bg_yellow = ansi_code(), & + bg_blue = ansi_code(), & + bg_magenta = ansi_code(), & + bg_cyan = ansi_code(), & + bg_white = ansi_code(), & + bg_gray = ansi_code(), & + bg_bright_red = ansi_code(), & + bg_bright_green = ansi_code(), & + bg_bright_yellow = ansi_code(), & + bg_bright_blue = ansi_code(), & + bg_bright_magenta = ansi_code(), & + bg_bright_cyan = ansi_code(), & + bg_bright_white = ansi_code() + end type toml_terminal + + !> Constructor to create new terminal + interface toml_terminal + module procedure :: new_terminal + end interface toml_terminal + +contains + +!> Create new terminal +pure function new_terminal(use_color) result(new) + !> Enable color support in terminal + logical, intent(in) :: use_color + !> New terminal instance + type(toml_terminal) :: new + + if (use_color) then + new%reset = reset + new%bold = bold + new%dim = dim + new%italic = italic + new%underline = underline + new%blink = blink + new%blink_rapid = blink_rapid + new%reverse = reverse + new%hidden = hidden + new%crossed = crossed + + new%black = black + new%red = red + new%green = green + new%yellow = yellow + new%blue = blue + new%magenta = magenta + new%cyan = cyan + new%white = white + new%gray = gray + new%bright_red = bright_red + new%bright_green = bright_green + new%bright_yellow = bright_yellow + new%bright_blue = bright_blue + new%bright_magenta = bright_magenta + new%bright_cyan = bright_cyan + new%bright_white = bright_white + + new%bg_black = bg_black + new%bg_red = bg_red + new%bg_green = bg_green + new%bg_yellow = bg_yellow + new%bg_blue = bg_blue + new%bg_magenta = bg_magenta + new%bg_cyan = bg_cyan + new%bg_white = bg_white + new%bg_gray = bg_gray + new%bg_bright_red = bg_bright_red + new%bg_bright_green = bg_bright_green + new%bg_bright_yellow = bg_bright_yellow + new%bg_bright_blue = bg_bright_blue + new%bg_bright_magenta = bg_bright_magenta + new%bg_bright_cyan = bg_bright_cyan + new%bg_bright_white = bg_bright_white + end if +end function new_terminal + +!> Add two escape sequences, attributes in the right value override the left value ones. +pure function add(lval, rval) result(code) + !> First escape code + type(ansi_code), intent(in) :: lval + !> Second escape code + type(ansi_code), intent(in) :: rval + !> Combined escape code + type(ansi_code) :: code + + code%style = merge(rval%style, lval%style, rval%style >= 0) + code%fg = merge(rval%fg, lval%fg, rval%fg >= 0) + code%bg = merge(rval%bg, lval%bg, rval%bg >= 0) +end function add + + +!> Concatenate an escape code with a string and turn it into an actual escape sequence +pure function concat_left(lval, code) result(str) + !> String to add the escape code to + character(len=*), intent(in) :: lval + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Concatenated string + character(len=:), allocatable :: str + + str = lval // escape(code) +end function concat_left + +!> Concatenate an escape code with a string and turn it into an actual escape sequence +pure function concat_right(code, rval) result(str) + !> String to add the escape code to + character(len=*), intent(in) :: rval + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Concatenated string + character(len=:), allocatable :: str + + str = escape(code) // rval +end function concat_right + + +!> Transform a color code into an actual ANSI escape sequence +pure function escape(code) result(str) + !> Color code to be used + type(ansi_code), intent(in) :: code + !> ANSI escape sequence representing the color code + character(len=:), allocatable :: str + + if (anycolor(code)) then + str = achar(27) // "[0" ! Always reset the style + if (code%style > 0) str = str // ";" // to_string(code%style) + if (code%fg >= 0) str = str // ";" // to_string(code%fg) + if (code%bg >= 0) str = str // ";" // to_string(code%bg) + str = str // "m" + else + str = "" + end if +end function escape + +!> Check whether the code describes any color or is just a stub +pure function anycolor(code) + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Any color / style is active + logical :: anycolor + + anycolor = code%fg >= 0 .or. code%bg >= 0 .or. code%style >= 0 +end function anycolor + +end module tomlf_terminal diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type.f90 new file mode 100644 index 000000000..da1c10f70 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type.f90 @@ -0,0 +1,541 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Collection of the central datatypes to define TOML data structures +!> +!> All TOML data types should inherit from an abstract value allowing to generate +!> a generic interface to deal with all more specialized TOML data types, while +!> the abstract value is interesting for developing algorithms in TOML-Fortran, +!> the user of TOML-Fortran will usually only care about TOML tables and possibly +!> arrays. +!> +!> The TOML types defined here should implement the TOML data structures (mostly) +!> without taking the actual implementation of the data structures into account. +!> This is done by providing a bare minimum interface using type bound procedures +!> to minimize the interdependencies between the datatypes. +!> +!> To make the data types extendable a visitor pattern allows access to the TOML +!> data types and can be used to implement further algorithms. +module tomlf_type + use tomlf_constants, only : tfc + use tomlf_error, only : toml_stat + use tomlf_type_array, only : toml_array, new_array, new, initialized, len + use tomlf_type_keyval, only : toml_keyval, new_keyval, new + use tomlf_type_table, only : toml_table, new_table, new, initialized + use tomlf_type_value, only : toml_value, toml_visitor, toml_key + implicit none + private + + public :: toml_value, toml_visitor, toml_table, toml_array, toml_keyval + public :: toml_key + public :: new, new_table, new_array, new_keyval, initialized, len + public :: add_table, add_array, add_keyval + public :: is_array_of_tables + public :: cast_to_table, cast_to_array, cast_to_keyval + + + !> Interface to build new tables + interface add_table + module procedure :: add_table_to_table + module procedure :: add_table_to_table_key + module procedure :: add_table_to_array + end interface add_table + + + !> Interface to build new arrays + interface add_array + module procedure :: add_array_to_table + module procedure :: add_array_to_table_key + module procedure :: add_array_to_array + end interface add_array + + + !> Interface to build new key-value pairs + interface add_keyval + module procedure :: add_keyval_to_table + module procedure :: add_keyval_to_table_key + module procedure :: add_keyval_to_array + end interface add_keyval + + +contains + + +!> Create a new TOML table inside an existing table +subroutine add_table_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_table_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_table) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_table_to_table + + +!> Create a new TOML table inside an existing table +subroutine add_table_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new table + type(toml_key), intent(in) :: key + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_table(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_table_to_table_key + + +!> Create a new TOML array inside an existing table +subroutine add_array_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new array + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_array_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_array) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_array_to_table + + +!> Create a new TOML array inside an existing table +subroutine add_array_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new array + type(toml_key), intent(in) :: key + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_array(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_array_to_table_key + + +!> Create a new key-value pair inside an existing table +subroutine add_keyval_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new key-value pair + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_keyval_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_keyval) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_keyval_to_table + + +!> Create a new key-value pair inside an existing table +subroutine add_keyval_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new key-value pair + type(toml_key), intent(in) :: key + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_keyval(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_keyval_to_table_key + + +!> Create a new TOML table inside an existing array +subroutine add_table_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_table_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_table) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_table_to_array + + +!> Create a new TOML array inside an existing array +subroutine add_array_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + allocate(toml_array :: val) + call new_array_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_array) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_array_to_array + + +!> Create a new key-value pair inside an existing array +subroutine add_keyval_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_keyval_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_keyval) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_keyval_to_array + + +!> Wrapped constructor to create a new TOML table on an abstract TOML value +subroutine new_table_(self) + + !> Newly created TOML table + class(toml_value), allocatable, intent(out) :: self + + type(toml_table), allocatable :: val + + allocate(val) + call new_table(val) + call move_alloc(val, self) + +end subroutine new_table_ + + +!> Wrapped constructor to create a new TOML array on an abstract TOML value +subroutine new_array_(self) + + !> Newly created TOML array + class(toml_value), allocatable, intent(out) :: self + + type(toml_array), allocatable :: val + + allocate(val) + call new_array(val) + call move_alloc(val, self) + +end subroutine new_array_ + + +!> Wrapped constructor to create a new TOML array on an abstract TOML value +subroutine new_keyval_(self) + + !> Newly created key-value pair + class(toml_value), allocatable, intent(out) :: self + + type(toml_keyval), allocatable :: val + + allocate(val) + call new_keyval(val) + call move_alloc(val, self) + +end subroutine new_keyval_ + + +!> Determine if array contains only tables +function is_array_of_tables(array) result(only_tables) + + !> TOML value to visit + class(toml_array), intent(inout) :: array + + !> Array contains only tables + logical :: only_tables + + class(toml_value), pointer :: ptr + integer :: i, n + + + n = len(array) + only_tables = n > 0 + + do i = 1, n + call array%get(i, ptr) + select type(ptr) + type is(toml_table) + cycle + class default + only_tables = .false. + exit + end select + end do + +end function is_array_of_tables + + +!> Cast an abstract TOML value to a TOML array +function cast_to_array(ptr) result(array) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML array view, nullified if the value is not an array + type(toml_array), pointer :: array + + nullify(array) + select type(ptr) + type is(toml_array) + array => ptr + end select +end function cast_to_array + +!> Cast an abstract TOML value to a TOML table +function cast_to_table(ptr) result(table) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML table view, nullified if the value is not a table + type(toml_table), pointer :: table + + nullify(table) + select type(ptr) + type is(toml_table) + table => ptr + end select +end function cast_to_table + +!> Cast an abstract TOML value to a TOML key-value pair +function cast_to_keyval(ptr) result(kval) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML key-value view, nullified if the value is not a table + type(toml_keyval), pointer :: kval + + nullify(kval) + select type(ptr) + type is(toml_keyval) + kval => ptr + end select +end function cast_to_keyval + + +end module tomlf_type diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type/array.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type/array.f90 new file mode 100644 index 000000000..14caae285 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/array.f90 @@ -0,0 +1,225 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML array data type +!> +!> A [[toml_array]] represents a TOML array, which is an ordered sequence +!> of values. TOML arrays can contain values of any type, including nested +!> arrays and tables (arrays of tables). +!> +!> Use [[get_value]] from the build module to retrieve array elements by +!> index, or the type-bound procedures for direct access. The intrinsic +!> [[len]] function is overloaded to return the number of elements. +module tomlf_type_array + use tomlf_error, only : toml_stat + use tomlf_type_value, only : toml_value, toml_visitor + use tomlf_structure, only : toml_list_structure, new_list_structure + implicit none + private + + public :: toml_array, new_array, new, initialized, len + + + !> TOML array + type, extends(toml_value) :: toml_array + + !> Is an inline array rather than an array of tables + logical :: inline = .true. + + !> Storage unit for TOML values of this array + class(toml_list_structure), allocatable, private :: list + + contains + + !> Get the TOML value at a given index + procedure :: get + + !> Append value to array + procedure :: push_back + + !> Remove the first element from the array + procedure :: shift + + !> Remove the last element from the array + procedure :: pop + + !> Release allocation hold by TOML array + procedure :: destroy + + end type toml_array + + + !> Create standard constructor + interface toml_array + module procedure :: new_array_func + end interface toml_array + + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_array + end interface + + + !> Overload len function + interface len + module procedure :: get_len + end interface + + + !> Check whether data structure is initialized properly + interface initialized + module procedure :: array_initialized + end interface initialized + + +contains + + +!> Constructor to create a new TOML array and allocate the internal storage +subroutine new_array(self) + + !> Instance of the TOML array + type(toml_array), intent(out) :: self + + call new_list_structure(self%list) + +end subroutine new_array + + +!> Default constructor for TOML array type +function new_array_func() result(self) + + !> Instance of the TOML array + type(toml_array) :: self + + call new_array(self) + +end function new_array_func + + +!> Check whether data structure is initialized properly +pure function array_initialized(self) result(okay) + + !> Instance of the TOML array + type(toml_array), intent(in) :: self + + !> Data structure is initialized + logical :: okay + + okay = allocated(self%list) +end function array_initialized + + +!> Get number of TOML values in the array +pure function get_len(self) result(length) + + !> Instance of the TOML array + class(toml_array), intent(in) :: self + + !> Current length of the array + integer :: length + + length = self%list%get_len() + +end function get_len + + +!> Get the TOML value at the respective index +subroutine get(self, idx, ptr) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> Index to the TOML value + integer, intent(in) :: idx + + !> Pointer to the TOML value + class(toml_value), pointer, intent(out) :: ptr + + call self%list%get(idx, ptr) + +end subroutine get + + +!> Push back a TOML value to the array +subroutine push_back(self, val, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to append to array + class(toml_value), allocatable, intent(inout) :: val + + !> Status of operation + integer, intent(out) :: stat + + if (allocated(val%key)) then + stat = toml_stat%fatal + return + end if + + call self%list%push_back(val) + + stat = toml_stat%success + +end subroutine push_back + + +!> Remove the first element from the data structure +subroutine shift(self, val) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + call self%list%shift(val) + +end subroutine shift + + +!> Remove the last element from the data structure +subroutine pop(self, val) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + call self%list%pop(val) + +end subroutine pop + + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%list)) then + call self%list%destroy + deallocate(self%list) + end if + +end subroutine destroy + + +end module tomlf_type_array diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 new file mode 100644 index 000000000..06e163412 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/keyval.f90 @@ -0,0 +1,367 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML key-value pair data type +!> +!> A [[toml_keyval]] represents a single key-value pair in a TOML document. +!> It can hold any of the TOML value types: strings, integers, floats, +!> booleans, and datetimes. +!> +!> Key-value pairs are typically accessed through their parent table using +!> [[get_value]] rather than directly manipulating this type. +module tomlf_type_keyval + use tomlf_constants, only : tfc, tfr, tfi, toml_type + use tomlf_datetime, only : toml_datetime + use tomlf_type_value, only : toml_value, toml_visitor + implicit none + private + + public :: toml_keyval, new_keyval, new + + + !> Generic TOML value + type, abstract :: generic_value + end type generic_value + + !> TOML real value + type, extends(generic_value) :: float_value + real(tfr) :: raw + end type float_value + + !> TOML integer value + type, extends(generic_value) :: integer_value + integer(tfi) :: raw + end type integer_value + + !> TOML boolean value + type, extends(generic_value) :: boolean_value + logical :: raw + end type boolean_value + + !> TOML datetime value + type, extends(generic_value) :: datetime_value + type(toml_datetime) :: raw + end type datetime_value + + !> TOML string value + type, extends(generic_value) :: string_value + character(:, tfc), allocatable :: raw + end type string_value + + + + !> TOML key-value pair + type, extends(toml_value) :: toml_keyval + + !> Actual TOML value + class(generic_value), allocatable :: val + + !> Origin of value + integer :: origin_value = 0 + + contains + + !> Get the value stored in the key-value pair + generic :: get => get_float, get_integer, get_boolean, get_datetime, get_string + procedure :: get_float + procedure :: get_integer + procedure :: get_boolean + procedure :: get_datetime + procedure :: get_string + + !> Set the value for the key-value pair + generic :: set => set_float, set_integer, set_boolean, set_datetime, set_string + procedure :: set_float + procedure :: set_integer + procedure :: set_boolean + procedure :: set_datetime + procedure :: set_string + + !> Get the type of the value stored in the key-value pair + procedure :: get_type + + !> Release allocation hold by TOML key-value pair + procedure :: destroy + + end type toml_keyval + + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_keyval + end interface + + +contains + + +!> Constructor to create a new TOML key-value pair +subroutine new_keyval(self) + + !> Instance of the TOML key-value pair + type(toml_keyval), intent(out) :: self + + associate(self => self); end associate + +end subroutine new_keyval + + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%val)) then + deallocate(self%val) + end if + +end subroutine destroy + + +!> Obtain real value from TOML key-value pair +subroutine get_float(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + real(tfr), pointer, intent(out) :: val + + val => cast_float(self%val) +end subroutine get_float + + +!> Obtain integer value from TOML key-value pair +subroutine get_integer(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + integer(tfi), pointer, intent(out) :: val + + val => cast_integer(self%val) +end subroutine get_integer + + +!> Obtain boolean value from TOML key-value pair +subroutine get_boolean(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + logical, pointer, intent(out) :: val + + val => cast_boolean(self%val) +end subroutine get_boolean + + +!> Obtain datetime value from TOML key-value pair +subroutine get_datetime(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + type(toml_datetime), pointer, intent(out) :: val + + val => cast_datetime(self%val) +end subroutine get_datetime + + +!> Obtain datetime value from TOML key-value pair +subroutine get_string(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + character(:, tfc), pointer, intent(out) :: val + + val => cast_string(self%val) +end subroutine get_string + + +!> Obtain real value from TOML key-value pair +subroutine set_float(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + real(tfr), intent(in) :: val + + type(float_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_float + + +!> Obtain integer value from TOML key-value pair +subroutine set_integer(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + integer(tfi), intent(in) :: val + + type(integer_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_integer + + +!> Obtain boolean value from TOML key-value pair +subroutine set_boolean(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + logical, intent(in) :: val + + type(boolean_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_boolean + + +!> Obtain datetime value from TOML key-value pair +subroutine set_datetime(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + type(toml_datetime), intent(in) :: val + + type(datetime_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_datetime + + +!> Obtain datetime value from TOML key-value pair +subroutine set_string(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + character(*, tfc), intent(in) :: val + + type(string_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_string + + +!> Get the type of the value stored in the key-value pair +pure function get_type(self) result(value_type) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value type + integer :: value_type + + select type(val => self%val) + class default + value_type = toml_type%invalid + type is(float_value) + value_type = toml_type%float + type is(integer_value) + value_type = toml_type%int + type is(boolean_value) + value_type = toml_type%boolean + type is(datetime_value) + value_type = toml_type%datetime + type is(string_value) + value_type = toml_type%string + end select +end function get_type + + +function cast_float(val) result(ptr) + class(generic_value), intent(in), target :: val + real(tfr), pointer :: ptr + + nullify(ptr) + select type(val) + type is(float_value) + ptr => val%raw + end select +end function cast_float + +function cast_integer(val) result(ptr) + class(generic_value), intent(in), target :: val + integer(tfi), pointer :: ptr + + nullify(ptr) + select type(val) + type is(integer_value) + ptr => val%raw + end select +end function cast_integer + +function cast_boolean(val) result(ptr) + class(generic_value), intent(in), target :: val + logical, pointer :: ptr + + nullify(ptr) + select type(val) + type is(boolean_value) + ptr => val%raw + end select +end function cast_boolean + +function cast_datetime(val) result(ptr) + class(generic_value), intent(in), target :: val + type(toml_datetime), pointer :: ptr + + nullify(ptr) + select type(val) + type is(datetime_value) + ptr => val%raw + end select +end function cast_datetime + +function cast_string(val) result(ptr) + class(generic_value), intent(in), target :: val + character(:, tfc), pointer :: ptr + + nullify(ptr) + select type(val) + type is(string_value) + ptr => val%raw + end select +end function cast_string + +end module tomlf_type_keyval diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type/table.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type/table.f90 new file mode 100644 index 000000000..fec9dbff0 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/table.f90 @@ -0,0 +1,266 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML table data type +!> +!> A [[toml_table]] represents a TOML table (also known as a hash table or +!> dictionary). Every TOML document contains at least one root table which +!> holds key-value pairs, arrays, and nested tables. +!> +!> Tables are the primary way to access parsed TOML data. Use [[get_value]] +!> from the build module to retrieve values by key, or the type-bound +!> procedures for direct access. +module tomlf_type_table + use tomlf_constants, only : tfc + use tomlf_error, only : toml_stat + use tomlf_type_value, only : toml_value, toml_visitor, toml_key + use tomlf_structure, only : toml_map_structure, new_map_structure + implicit none + private + + public :: toml_table, new_table, new, initialized + + + !> TOML table + type, extends(toml_value) :: toml_table + + !> Table was implictly created + logical :: implicit = .false. + + !> Is an inline table and is therefore non-extendable + logical :: inline = .false. + + !> Storage unit for TOML values of this table + class(toml_map_structure), allocatable, private :: map + + contains + + !> Get the TOML value associated with the respective key + procedure :: get + + !> Get list of all keys in this table + procedure :: get_keys + + !> Check if key is already present in this table instance + procedure :: has_key + + !> Append value to table (checks automatically for key) + procedure :: push_back + + !> Remove TOML value at a given key and return it + procedure :: pop + + !> Delete TOML value at a given key + procedure :: delete + + !> Release allocation hold by TOML table + procedure :: destroy + + end type toml_table + + + !> Create standard constructor + interface toml_table + module procedure :: new_table_func + end interface toml_table + + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_table + end interface + + + !> Check whether data structure is initialized properly + interface initialized + module procedure :: table_initialized + end interface initialized + + +contains + + +!> Constructor to create a new TOML table and allocate the internal storage +subroutine new_table(self) + + !> Instance of the TOML table + type(toml_table), intent(out) :: self + + call new_map_structure(self%map) + +end subroutine new_table + + +!> Default constructor for TOML table type +function new_table_func() result(self) + + !> Instance of the TOML table + type(toml_table) :: self + + call new_table(self) + +end function new_table_func + + +!> Check whether data structure is initialized properly +pure function table_initialized(self) result(okay) + + !> Instance of the TOML table + type(toml_table), intent(in) :: self + + !> Data structure is initialized + logical :: okay + + okay = allocated(self%map) +end function table_initialized + + +!> Get the TOML value associated with the respective key +subroutine get(self, key, ptr) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the TOML value + class(toml_value), pointer, intent(out) :: ptr + + call self%map%get(key, ptr) + +end subroutine get + + +!> Get list of all keys in this table +subroutine get_keys(self, list) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + call self%map%get_keys(list) + +end subroutine get_keys + + +!> Check if a key is present in the table +function has_key(self, key) result(found) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> TOML value is present in table + logical :: found + + class(toml_value), pointer :: ptr + + call self%map%get(key, ptr) + + found = associated(ptr) + +end function has_key + + +!> Push back a TOML value to the table +subroutine push_back(self, val, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> TOML value to append to table + class(toml_value), allocatable, intent(inout) :: val + + !> Status of operation + integer, intent(out) :: stat + + class(toml_value), pointer :: ptr + + if (.not.allocated(val)) then + stat = merge(self%origin, toml_stat%fatal, self%origin > 0) + return + end if + + if (.not.allocated(val%key)) then + stat = merge(val%origin, toml_stat%fatal, val%origin > 0) + return + end if + + call self%get(val%key, ptr) + if (associated(ptr)) then + stat = merge(ptr%origin, toml_stat%duplicate_key, ptr%origin > 0) + return + end if + + call self%map%push_back(val) + + stat = toml_stat%success + +end subroutine push_back + + +!> Remove TOML value at a given key and return it +subroutine pop(self, key, val) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value to return + class(toml_value), allocatable, intent(out) :: val + + call self%map%pop(key, val) + +end subroutine pop + + +!> Delete TOML value at a given key +subroutine delete(self, key) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + call self%map%delete(key) + +end subroutine delete + + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%map)) then + call self%map%destroy + deallocate(self%map) + end if + +end subroutine destroy + + +end module tomlf_type_table diff --git a/source/third_party_open/utils/toml-f/src/tomlf/type/value.f90 b/source/third_party_open/utils/toml-f/src/tomlf/type/value.f90 new file mode 100644 index 000000000..1eb28f8b9 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/type/value.f90 @@ -0,0 +1,162 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstract base types for TOML values +!> +!> This module defines the abstract [[toml_value]] base type from which all +!> concrete TOML types ([[toml_table]], [[toml_array]], [[toml_keyval]]) +!> inherit. It also provides the [[toml_visitor]] abstract type for +!> implementing the visitor pattern. +!> +!> Most users will not need to work with these types directly, but they +!> are useful for implementing custom algorithms that traverse TOML +!> data structures. +module tomlf_type_value + use tomlf_constants, only : tfc, TOML_BAREKEY + use tomlf_utils, only : toml_escape_string + implicit none + private + + public :: toml_value, toml_visitor, toml_key + + + !> Abstract base value for TOML data types + type, abstract :: toml_value + + !> Raw representation of the key to the TOML value + character(kind=tfc, len=:), allocatable :: key + + !> Original source of the value + integer :: origin = 0 + + contains + + !> Accept a visitor to transverse the data structure + procedure :: accept + + !> Get escaped key to TOML value + procedure :: get_key + + !> Compare raw key of TOML value to input key + procedure :: match_key + + !> Release allocation hold by TOML value + procedure(destroy), deferred :: destroy + + end type toml_value + + + !> Abstract visitor for TOML values + type, abstract :: toml_visitor + contains + + !> Visitor visiting a TOML value + procedure(visit), deferred :: visit + + end type toml_visitor + + + !> Thin wrapper around the deferred-size character intrinisc + type :: toml_key + + !> Raw representation of the key to the TOML value + character(kind=tfc, len=:), allocatable :: key + + !> Original source of the value + integer :: origin = 0 + + end type toml_key + + + abstract interface + !> Accept a visitor to transverse the data structure + recursive subroutine visit(self, val) + import toml_value, toml_visitor + + !> Instance of the visitor + class(toml_visitor), intent(inout) :: self + + !> Value to visit + class(toml_value), intent(inout) :: val + end subroutine visit + + !> Deconstructor to cleanup allocations (optional) + subroutine destroy(self) + import toml_value + + !> Instance of the TOML value + class(toml_value), intent(inout) :: self + + end subroutine destroy + + end interface + + +contains + + +!> Accept a visitor to transverse the data structure +recursive subroutine accept(self, visitor) + + !> Instance of the TOML value + class(toml_value), intent(inout) :: self + + !> Visitor for this value + class(toml_visitor), intent(inout) :: visitor + + call visitor%visit(self) + +end subroutine accept + + +!> Get escaped key to TOML value +subroutine get_key(self, key) + + !> TOML value instance. + class(toml_value), intent(in) :: self + + !> Contains valid TOML key on exit + character(kind=tfc, len=:), allocatable :: key + + if (allocated(self%key)) then + if (verify(self%key, TOML_BAREKEY) == 0 .and. len(self%key) > 0) then + key = self%key + else + call toml_escape_string(self%key, key) + end if + end if + +end subroutine get_key + + +!> Compare raw key of TOML value to input key +pure function match_key(self, key) result(match) + + !> TOML value instance. + class(toml_value), intent(in) :: self + + !> TOML raw key to compare to + character(kind=tfc, len=*), intent(in) :: key + + logical :: match + + if (allocated(self%key)) then + match = key == self%key + else + match = .false. + end if + +end function match_key + + +end module tomlf_type_value diff --git a/source/third_party_open/utils/toml-f/src/tomlf/utils.f90 b/source/third_party_open/utils/toml-f/src/tomlf/utils.f90 new file mode 100644 index 000000000..00648f728 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/utils.f90 @@ -0,0 +1,260 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +module tomlf_utils + use tomlf_constants + use tomlf_datetime, only : toml_datetime, toml_date, toml_time, to_string + use tomlf_utils_io, only : read_whole_file, read_whole_line + implicit none + private + + public :: toml_escape_string + public :: to_string + public :: read_whole_file, read_whole_line + + + interface to_string + module procedure :: to_string_i1 + module procedure :: to_string_i2 + module procedure :: to_string_i4 + module procedure :: to_string_i8 + module procedure :: to_string_r8 + end interface to_string + + +contains + + +!> Escape all special characters in a TOML string +subroutine toml_escape_string(raw, escaped, multiline) + + !> Raw representation of TOML string + character(kind=tfc, len=*), intent(in) :: raw + + !> Escaped view of the TOML string + character(kind=tfc, len=:), allocatable, intent(out) :: escaped + + !> Preserve newline characters + logical, intent(in), optional :: multiline + + integer :: i + logical :: preserve_newline + + preserve_newline = .false. + if (present(multiline)) preserve_newline = multiline + + escaped = '"' + do i = 1, len(raw) + select case(raw(i:i)) + case default; escaped = escaped // raw(i:i) + case('\'); escaped = escaped // '\\' + case('"'); escaped = escaped // '\"' + case(TOML_NEWLINE) + if (preserve_newline) then + escaped = escaped // raw(i:i) + else + escaped = escaped // '\n' + end if + case(TOML_FORMFEED); escaped = escaped // '\f' + case(TOML_CARRIAGE_RETURN); escaped = escaped // '\r' + case(TOML_TABULATOR); escaped = escaped // '\t' + case(TOML_BACKSPACE); escaped = escaped // '\b' + end select + end do + escaped = escaped // '"' + +end subroutine toml_escape_string + + +!> Represent an integer as character sequence. +pure function to_string_i1(val) result(string) + integer, parameter :: ik = tf_i1 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i1 + + +!> Represent an integer as character sequence. +pure function to_string_i2(val) result(string) + integer, parameter :: ik = tf_i2 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i2 + + +!> Represent an integer as character sequence. +pure function to_string_i4(val) result(string) + integer, parameter :: ik = tf_i4 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i4 + + +!> Represent an integer as character sequence. +pure function to_string_i8(val) result(string) + integer, parameter :: ik = tf_i8 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i8 + +!> Represent an real as character sequence. +pure function to_string_r8(val) result(string) + integer, parameter :: rk = tfr + !> Real value to create string from + real(rk), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + character(128, tfc) :: buffer + + if (val > huge(val)) then + string = "+inf" + else if (val < -huge(val)) then + string = "-inf" + else if (val /= val) then + string = "nan" + else + if (abs(val) >= 1.0e+100_rk) then + write(buffer, '(es24.16e3)') val + else if (abs(val) >= 1.0e+10_rk) then + write(buffer, '(es24.16e2)') val + else if (abs(val) >= 1.0e+3_rk) then + write(buffer, '(es24.16e1)') val + else + write(buffer, '(f24.16)') val + end if + string = trim(adjustl(buffer)) + end if +end function to_string_r8 + +end module tomlf_utils diff --git a/source/third_party_open/utils/toml-f/src/tomlf/utils/io.f90 b/source/third_party_open/utils/toml-f/src/tomlf/utils/io.f90 new file mode 100644 index 000000000..5580c1ac6 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/utils/io.f90 @@ -0,0 +1,90 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Utilities for handling input and output operations +module tomlf_utils_io + use tomlf_constants, only : tfc + implicit none + private + + public :: read_whole_file, read_whole_line + + +contains + +!> Read a whole file into an array of characters +subroutine read_whole_file(filename, string, stat) + !> File to read + character(*, tfc), intent(in) :: filename + !> Array of characters representing the file + character(:, tfc), allocatable, intent(out) :: string + !> Error status + integer, intent(out) :: stat + + integer :: io, length + + open(file=filename, & + & status="old", & + & access="stream", & + & position="append", & + & newunit=io, & + & iostat=stat) + if (stat == 0) then + inquire(unit=io, pos=length) + allocate(character(length-1, tfc) :: string, stat=stat) + end if + if (stat == 0) then + read(io, pos=1, iostat=stat) string(:length-1) + end if + if (stat == 0) then + close(io) + end if +end subroutine read_whole_file + +!> Read a whole line from a formatted unit into a deferred length character variable +subroutine read_whole_line(io, string, stat) + !> Formatted IO unit + integer, intent(in) :: io + !> Line to read + character(:, tfc), allocatable, intent(out) :: string + !> Status of operation + integer, intent(out) :: stat + + integer, parameter :: bufsize = 4096 + character(bufsize, tfc) :: buffer, msg + integer :: chunk + logical :: opened + + if (io /= -1) then + inquire(unit=io, opened=opened) + else + opened = .false. + end if + + if (opened) then + open(unit=io, pad="yes", iostat=stat) + else + stat = 1 + msg = "Unit is not connected" + end if + + string = "" + do while (stat == 0) + read(io, '(a)', advance='no', iostat=stat, size=chunk) buffer + if (stat > 0) exit + string = string // buffer(:chunk) + end do + if (is_iostat_eor(stat)) stat = 0 +end subroutine read_whole_line + +end module tomlf_utils_io diff --git a/source/third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 b/source/third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 new file mode 100644 index 000000000..af76ebe82 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/utils/sort.f90 @@ -0,0 +1,141 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Sorting algorithms to work with hash maps +module tomlf_utils_sort + use tomlf_type_value, only : toml_key + implicit none + private + + public :: sort, compare_less + + + !> Create overloaded interface for export + interface sort + module procedure :: sort_keys + end interface + + + abstract interface + !> Define order relation between two TOML keys + pure function compare_less(lhs, rhs) result(less) + import :: toml_key + !> Left hand side TOML key in comparison + type(toml_key), intent (in) :: lhs + !> Right hand side TOML key in comparison + type(toml_key), intent (in) :: rhs + !> Comparison result + logical :: less + end function compare_less + end interface + + +contains + + + !> Entry point for sorting algorithm + pure subroutine sort_keys(list, idx, compare) + + !> List of TOML keys to be sorted + type(toml_key), intent(inout) :: list(:) + + !> Optionally, mapping from unsorted list to sorted list + integer, intent(out), optional :: idx(:) + + !> Function implementing the order relation between two TOML keys + procedure(compare_less), optional :: compare + + integer :: low, high, i + type(toml_key), allocatable :: sorted(:) + integer, allocatable :: indexarray(:) + + low = 1 + high = size(list) + + allocate(sorted, source=list) + + allocate(indexarray(high), source=[(i, i=low, high)]) + + if (present(compare)) then + call quicksort(sorted, indexarray, low, high, compare) + else + call quicksort(sorted, indexarray, low, high, compare_keys_less) + end if + + do i = low, high + list(i) = sorted(indexarray(i)) + end do + + if (present(idx)) then + idx = indexarray + end if + + end subroutine sort_keys + + + !> Actual quick sort implementation + pure recursive subroutine quicksort(list, idx, low, high, less) + type(toml_key), intent(inout) :: list(:) + integer, intent(inout) :: idx(:) + integer, intent(in) :: low, high + procedure(compare_less) :: less + + integer :: i, last + integer :: pivot + + if (low < high) then + + call swap(idx(low), idx((low + high)/2)) + last = low + do i = low + 1, high + if (less(list(idx(i)), list(idx(low)))) then + last = last + 1 + call swap(idx(last), idx(i)) + end if + end do + call swap(idx(low), idx(last)) + pivot = last + + call quicksort(list, idx, low, pivot - 1, less) + call quicksort(list, idx, pivot + 1, high, less) + end if + + end subroutine quicksort + + + !> Swap two integer values + pure subroutine swap(lhs, rhs) + integer, intent(inout) :: lhs + integer, intent(inout) :: rhs + + integer :: tmp + + tmp = lhs + lhs = rhs + rhs = tmp + + end subroutine swap + + + !> Default comparison between two TOML keys + pure function compare_keys_less(lhs, rhs) result(less) + type(toml_key), intent (in) :: lhs + type(toml_key), intent (in) :: rhs + logical :: less + + less = lhs%key < rhs%key + + end function compare_keys_less + + +end module tomlf_utils_sort diff --git a/source/third_party_open/utils/toml-f/src/tomlf/version.f90 b/source/third_party_open/utils/toml-f/src/tomlf/version.f90 new file mode 100644 index 000000000..89b36d3f0 --- /dev/null +++ b/source/third_party_open/utils/toml-f/src/tomlf/version.f90 @@ -0,0 +1,74 @@ +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Version information on TOML-Fortran +module tomlf_version + implicit none + private + + public :: get_tomlf_version + public :: tomlf_version_string, tomlf_version_compact + + + !> String representation of the TOML-Fortran version + character(len=*), parameter :: tomlf_version_string = "0.5.0" + + !> Major version number of the above TOML-Fortran version + integer, parameter :: tomlf_major = 0 + + !> Minor version number of the above TOML-Fortran version + integer, parameter :: tomlf_minor = 5 + + !> Patch version number of the above TOML-Fortran version + integer, parameter :: tomlf_patch = 0 + + !> Compact numeric representation of the TOML-Fortran version + integer, parameter :: tomlf_version_compact = & + & tomlf_major*10000 + tomlf_minor*100 + tomlf_patch + + +contains + + +!> Getter function to retrieve TOML-Fortran version +subroutine get_tomlf_version(major, minor, patch, string) + + !> Major version number of the TOML-Fortran version + integer, intent(out), optional :: major + + !> Minor version number of the TOML-Fortran version + integer, intent(out), optional :: minor + + !> Patch version number of the TOML-Fortran version + integer, intent(out), optional :: patch + + !> String representation of the TOML-Fortran version + character(len=:), allocatable, intent(out), optional :: string + + if (present(major)) then + major = tomlf_major + end if + if (present(minor)) then + minor = tomlf_minor + end if + if (present(patch)) then + patch = tomlf_patch + end if + if (present(string)) then + string = tomlf_version_string + end if + +end subroutine get_tomlf_version + + +end module tomlf_version From ba0ee380d60a83861718d0a76093cfba2d0c0989 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Fri, 17 Apr 2026 10:36:26 +0200 Subject: [PATCH 23/65] Move src-structure state into sfincs_src_structures Move all runtime flat arrays and state for source/sink structures out of sfincs_data and into a dedicated sfincs_src_structures module. Rename drainage_* symbols to struc_* (e.g. qdrain -> qstruc, nmindrn_in/out -> struc_nm_in/out, drainage_params -> individual struc_* param arrays) and update readers and runtime code to use the new names. Add helpers allocate_struc_flat_arrays, finalize_src_structures_state and marshal_src_structures_to_flat_arrays to initialize, post-process (cell lookup, distances) and convert TOML-derived structures into the flat arrays. Update sfincs_openacc OpenACC present lists and update_src_structures to reference the new arrays, and remove deallocation/ownership of structure state from sfincs_data. Log messages and comments updated to reflect the new ownership and data flow. --- source/src/sfincs_data.f90 | 20 +- source/src/sfincs_openacc.f90 | 12 +- source/src/sfincs_src_structures.f90 | 559 +++++++++++++++++++++------ 3 files changed, 450 insertions(+), 141 deletions(-) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index a1685dd9c..4d4c43a5b 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -791,18 +791,8 @@ module sfincs_data real*4, dimension(:), allocatable :: xsrc real*4, dimension(:), allocatable :: ysrc ! - ! Src-point structures: pumps, culverts, check valves, controlled gates - ! (sfincs_src_structures) - ! - integer :: ndrn - integer*4, dimension(:), allocatable :: nmindrn_in ! (ndrn) intake (sink) cell indices - integer*4, dimension(:), allocatable :: nmindrn_out ! (ndrn) outfall (source) cell indices - real*4, dimension(:), allocatable :: qdrain ! (ndrn) signed discharge per structure, for his output - integer*1, dimension(:), allocatable :: drainage_type - real*4, dimension(:,:), allocatable :: drainage_params - real*4, dimension(:), allocatable :: drainage_distance - integer*1, dimension(:), allocatable :: drainage_status - real*4, dimension(:), allocatable :: drainage_fraction_open + ! Src-point structures (pumps, culverts, check valves, controlled gates) + ! live in module sfincs_src_structures. !!! !!! Structures !!! @@ -1131,9 +1121,9 @@ subroutine finalize_parameters() if(allocated(qsrc_ts)) deallocate(qsrc_ts) if(allocated(qtsrc)) deallocate(qtsrc) if(allocated(nmindsrc)) deallocate(nmindsrc) - if(allocated(nmindrn_in)) deallocate(nmindrn_in) - if(allocated(nmindrn_out)) deallocate(nmindrn_out) - if(allocated(qdrain)) deallocate(qdrain) + ! + ! Src-point structure state is owned by sfincs_src_structures and is + ! deallocated there. !!! !!! Structures !!! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 3847cee7f..061830ffe 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -21,7 +21,11 @@ subroutine initialize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc qsrc, qtsrc, qdrain, nmindsrc, nmindrn_in, nmindrn_out, drainage_type, drainage_params, drainage_distance, drainage_status, drainage_fraction_open, & + !$acc qsrc, qtsrc, qdrain, nmindsrc, nmindrn_in, nmindrn_out, drainage_type, & + !$acc drainage_q, drainage_par1, drainage_par2, drainage_par3, drainage_cd, & + !$acc drainage_width, drainage_sill_elevation, drainage_mannings_n, & + !$acc drainage_zmin, drainage_zmax, drainage_t_close, & + !$acc drainage_distance, drainage_status, drainage_fraction_open, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & @@ -51,7 +55,11 @@ subroutine finalize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc qsrc, qtsrc, qdrain, nmindsrc, nmindrn_in, nmindrn_out, drainage_type, drainage_params, drainage_distance, drainage_status, drainage_fraction_open, & + !$acc qsrc, qtsrc, qdrain, nmindsrc, nmindrn_in, nmindrn_out, drainage_type, & + !$acc drainage_q, drainage_par1, drainage_par2, drainage_par3, drainage_cd, & + !$acc drainage_width, drainage_sill_elevation, drainage_mannings_n, & + !$acc drainage_zmin, drainage_zmax, drainage_t_close, & + !$acc drainage_distance, drainage_status, drainage_fraction_open, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index ec93bf23c..430ff737b 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -13,9 +13,9 @@ module sfincs_src_structures ! each module has a single responsibility. ! ! Runtime handoff to the continuity module is via the cell-wise qsrc(np) - ! array (in sfincs_data): this module accumulates qq on intake (nmindrn_in) - ! and outfall (nmindrn_out) cells. Per-structure signed discharge is also - ! stored in qdrain(ndrn) for his output. + ! array (in sfincs_data): this module accumulates qq on intake (struc_nm_in) + ! and outfall (struc_nm_out) cells. Per-structure signed discharge is also + ! stored in qstruc(nstruc) for his output. ! ! Concurrency: qsrc updates use atomic because two structures (or a river ! source and a structure) can land in the same cell. @@ -25,6 +25,8 @@ module sfincs_src_structures ! private :: parse_action_kind, parse_rule_lhs, parse_comparator, parse_rule_rhs, parse_structure_type, to_lower, check_required private :: initialize_src_structures_legacy + private :: allocate_struc_flat_arrays, finalize_src_structures_state + private :: marshal_src_structures_to_flat_arrays ! ! ------------------------------------------------------------------ ! Named constants for the keyword-based src structure input. @@ -148,12 +150,65 @@ module sfincs_src_structures ! ! Populated by the dispatcher when the drn file parses as TOML. ! Not yet consumed by any downstream runtime code - wiring is a later - ! step. The legacy path continues to populate the flat arrays in - ! sfincs_data (drainage_type, drainage_params, etc.). + ! step. The legacy path continues to populate the flat arrays below + ! directly (struc_type, struc_q, struc_par1, etc.). ! ------------------------------------------------------------------ ! type(t_src_structure), allocatable :: src_structures(:) ! + ! ------------------------------------------------------------------ + ! Module-level runtime state for src structures (moved from sfincs_data). + ! Populated by the legacy reader or by marshal_src_structures_to_flat_arrays + ! from the TOML path; consumed by update_src_structures and the his output. + ! Public so downstream modules (sfincs_openacc, sfincs_output, sfincs_ncoutput, + ! sfincs_lib) can reference them. + ! ------------------------------------------------------------------ + ! + ! Meta / id + ! + integer, parameter :: struc_id_len = 128 ! max length of struct id / name strings + character(len=struc_id_len), dimension(:), allocatable, public :: struc_id + character(len=struc_id_len), dimension(:), allocatable, public :: struc_name + ! + ! Kind / state + ! + integer*1, dimension(:), allocatable, public :: struc_type + integer*1, dimension(:), allocatable, public :: struc_status + real*4, dimension(:), allocatable, public :: struc_distance + real*4, dimension(:), allocatable, public :: struc_fraction_open + ! + ! Cell mapping + ! + integer, public :: nstruc + integer*4, dimension(:), allocatable, public :: struc_nm_in ! (nstruc) intake (sink) cell indices + integer*4, dimension(:), allocatable, public :: struc_nm_out ! (nstruc) outfall (source) cell indices + ! + ! Coordinates + ! + real*4, dimension(:), allocatable, public :: struc_x, struc_y + real*4, dimension(:), allocatable, public :: struc_src_1_x, struc_src_1_y + real*4, dimension(:), allocatable, public :: struc_src_2_x, struc_src_2_y + real*4, dimension(:), allocatable, public :: struc_obs_1_x, struc_obs_1_y + real*4, dimension(:), allocatable, public :: struc_obs_2_x, struc_obs_2_y + ! + ! Named parameters + ! + real*4, dimension(:), allocatable, public :: struc_q ! pump discharge + real*4, dimension(:), allocatable, public :: struc_cd ! generic discharge coefficient + real*4, dimension(:), allocatable, public :: struc_par1 ! generic par1 (e.g. culvert / check_valve flow coef, or schedule-gate tclose) + real*4, dimension(:), allocatable, public :: struc_par2 ! generic par2 (e.g. schedule-gate topen) + real*4, dimension(:), allocatable, public :: struc_par3 ! generic par3 + real*4, dimension(:), allocatable, public :: struc_width ! gate width + real*4, dimension(:), allocatable, public :: struc_sill_elevation ! gate sill elevation + real*4, dimension(:), allocatable, public :: struc_mannings_n ! gate Manning's n + real*4, dimension(:), allocatable, public :: struc_zmin ! gate min water level for open + real*4, dimension(:), allocatable, public :: struc_zmax ! gate max water level for open + real*4, dimension(:), allocatable, public :: struc_t_close ! gate closing time (s) + ! + ! Runtime state + ! + real*4, dimension(:), allocatable, public :: qstruc ! (nstruc) signed discharge per structure, mirrors the qsrc pattern + ! contains ! @@ -164,7 +219,7 @@ subroutine initialize_src_structures() ! Probes the file with toml-f. If it parses as TOML, the TOML reader ! populates the module-level src_structures(:) array. If toml-f rejects ! it, falls back to the legacy fixed-column reader, which populates the - ! drainage_* arrays in sfincs_data. + ! struc_* arrays in sfincs_src_structures. ! ! If a file parses as TOML but fails semantic validation (e.g. a ! missing required field), that is treated as a hard error: we do NOT @@ -209,6 +264,12 @@ subroutine initialize_src_structures() ! endif ! + ! Flatten the parsed derived-type array into the module-level + ! struc_* 1D arrays, then deallocate src_structures(:). Both paths + ! leave runtime state in the same shape. + ! + call marshal_src_structures_to_flat_arrays() + ! return ! else @@ -229,23 +290,22 @@ subroutine initialize_src_structures() ! subroutine initialize_src_structures_legacy() ! - ! Parse drnfile in the fixed-column legacy format and populate - ! drainage_type/_params/_status/_distance/_fraction_open, - ! nmindrn_in(ndrn), nmindrn_out(ndrn), and the output buffer qdrain(ndrn). + ! Parse drnfile in the fixed-column legacy format and populate the + ! struc_* flat arrays, plus struc_nm_in/out and the + ! output buffer qstruc(nstruc). Post-processing (cell-index lookup, + ! distance, default status / fraction_open) is deferred to + ! finalize_src_structures_state(), which is shared with the TOML path. ! use sfincs_data - use quadtree ! implicit none ! - real*4, dimension(:), allocatable :: xsrc_drn, ysrc_drn - real*4, dimension(:), allocatable :: xsnk, ysnk real*4 :: dummy, xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp - integer :: idrn, nmq, stat, npars + integer :: istruc, stat, npars, dtype logical :: ok character(len=256) :: drainage_line ! - ndrn = 0 + nstruc = 0 ! if (drnfile(1:4) == 'none') return ! @@ -259,59 +319,40 @@ subroutine initialize_src_structures_legacy() ! read(501, *, iostat=stat) dummy if (stat < 0) exit - ndrn = ndrn + 1 + nstruc = nstruc + 1 ! enddo ! rewind(501) ! - if (ndrn <= 0) then + if (nstruc <= 0) then ! close(501) return ! endif ! - write(logstr,'(a,a,a,i0,a)')' Reading ', trim(drnfile), ' (', ndrn, ' drainage points found) ...' + write(logstr,'(a,a,a,i0,a)')' Reading ', trim(drnfile), ' (', nstruc, ' drainage points found) ...' call write_log(logstr, 0) ! - allocate(xsrc_drn(ndrn)) - allocate(ysrc_drn(ndrn)) - allocate(xsnk(ndrn)) - allocate(ysnk(ndrn)) - ! - allocate(nmindrn_in(ndrn)) - allocate(nmindrn_out(ndrn)) - allocate(qdrain(ndrn)) - allocate(drainage_type(ndrn)) - allocate(drainage_params(ndrn, 6)) - allocate(drainage_status(ndrn)) - allocate(drainage_distance(ndrn)) - allocate(drainage_fraction_open(ndrn)) - ! - nmindrn_in = 0 - nmindrn_out = 0 - qdrain = 0.0 - drainage_params = 0.0 - drainage_distance = 0.0 - drainage_fraction_open = 1.0 ! initially fully open (could be refined from zmin/zmax) - drainage_status = 1 ! 0=closed, 1=open, 2=closing, 3=opening - ! - do idrn = 1, ndrn + call allocate_struc_flat_arrays(nstruc) + ! + do istruc = 1, nstruc ! read(501, '(a)') drainage_line ! ! Determine drainage type first (5th integer in the line) ! - read(drainage_line, *, iostat=stat) xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp, drainage_type(idrn) + read(drainage_line, *, iostat=stat) xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp, struc_type(istruc) ! + dtype = struc_type(istruc) npars = 0 ! - if (drainage_type(idrn) == 1 .or. drainage_type(idrn) == 2 .or. drainage_type(idrn) == 3) then + if (dtype == 1 .or. dtype == 2 .or. dtype == 3) then ! npars = 1 ! pump, culvert, or check valve ! - elseif (drainage_type(idrn) == 4 .or. drainage_type(idrn) == 5) then + elseif (dtype == 4 .or. dtype == 5) then ! npars = 6 ! controlled gate (width, sill, manning, zmin/tclose, zmax/topen, closing time) ! @@ -319,28 +360,62 @@ subroutine initialize_src_structures_legacy() ! if (npars == 0) then ! - write(logstr,'(a,i0,a)') 'Drainage type ', drainage_type(idrn), ' not recognized !' + write(logstr,'(a,i0,a)') 'Drainage type ', dtype, ' not recognized !' call stop_sfincs(logstr, -1) ! endif ! if (npars == 1) then ! - read(drainage_line, *, iostat=stat) xsnk(idrn), ysnk(idrn), xsrc_drn(idrn), ysrc_drn(idrn), & - drainage_type(idrn), drainage_params(idrn, 1) + ! pump -> col 1 = q + ! culvert -> col 1 = par1 (flow coefficient) + ! check_valve -> col 1 = par1 (flow coefficient) + ! + if (dtype == 1) then + ! + read(drainage_line, *, iostat=stat) struc_src_1_x(istruc), struc_src_1_y(istruc), & + struc_src_2_x(istruc), struc_src_2_y(istruc), & + struc_type(istruc), struc_q(istruc) + ! + else + ! + read(drainage_line, *, iostat=stat) struc_src_1_x(istruc), struc_src_1_y(istruc), & + struc_src_2_x(istruc), struc_src_2_y(istruc), & + struc_type(istruc), struc_par1(istruc) + ! + endif ! elseif (npars == 6) then ! - read(drainage_line, *, iostat=stat) xsnk(idrn), ysnk(idrn), xsrc_drn(idrn), ysrc_drn(idrn), & - drainage_type(idrn), drainage_params(idrn, 1), drainage_params(idrn, 2), & - drainage_params(idrn, 3), drainage_params(idrn, 4), drainage_params(idrn, 5), & - drainage_params(idrn, 6) + ! gate water-level triggered (type 4) + ! cols 1..6 = width, sill_elevation, mannings_n, zmin, zmax, t_close + ! gate schedule triggered (type 5) + ! cols 1..6 = width, sill_elevation, mannings_n, par1 (tclose), + ! par2 (topen), t_close + ! + if (dtype == 4) then + ! + read(drainage_line, *, iostat=stat) struc_src_1_x(istruc), struc_src_1_y(istruc), & + struc_src_2_x(istruc), struc_src_2_y(istruc), & + struc_type(istruc), struc_width(istruc), struc_sill_elevation(istruc), & + struc_mannings_n(istruc), struc_zmin(istruc), struc_zmax(istruc), & + struc_t_close(istruc) + ! + else + ! + read(drainage_line, *, iostat=stat) struc_src_1_x(istruc), struc_src_1_y(istruc), & + struc_src_2_x(istruc), struc_src_2_y(istruc), & + struc_type(istruc), struc_width(istruc), struc_sill_elevation(istruc), & + struc_mannings_n(istruc), struc_par1(istruc), struc_par2(istruc), & + struc_t_close(istruc) + ! + endif ! endif ! if (stat /= 0) then ! - write(logstr,'(a,i0,a,i0,a)') 'Drainage type ', drainage_type(idrn), ' requires ', npars, ' parameters !' + write(logstr,'(a,i0,a,i0,a)') 'Drainage type ', dtype, ' requires ', npars, ' parameters !' call stop_sfincs(logstr, -1) ! endif @@ -349,35 +424,156 @@ subroutine initialize_src_structures_legacy() ! close(501) ! - ! Map intake / outfall points to cell indices and compute centre-to-centre - ! distance (needed by controlled-gate types 4 and 5). + ! Cell-index lookup, centre-to-centre distance, mismatch warning. + ! + call finalize_src_structures_state() + ! + end subroutine + ! + ! + subroutine allocate_struc_flat_arrays(n) + ! + ! Allocate every struc_* flat array to size n and initialise defaults. + ! Used by both the legacy reader and the TOML marshal helper. + ! Defensively deallocates first so re-entry is safe. + ! + use sfincs_data + ! + implicit none + ! + integer, intent(in) :: n + ! + if (allocated(struc_nm_in)) deallocate(struc_nm_in) + if (allocated(struc_nm_out)) deallocate(struc_nm_out) + if (allocated(qstruc)) deallocate(qstruc) + if (allocated(struc_type)) deallocate(struc_type) + if (allocated(struc_distance)) deallocate(struc_distance) + if (allocated(struc_status)) deallocate(struc_status) + if (allocated(struc_fraction_open)) deallocate(struc_fraction_open) + if (allocated(struc_id)) deallocate(struc_id) + if (allocated(struc_name)) deallocate(struc_name) + if (allocated(struc_x)) deallocate(struc_x) + if (allocated(struc_y)) deallocate(struc_y) + if (allocated(struc_src_1_x)) deallocate(struc_src_1_x) + if (allocated(struc_src_1_y)) deallocate(struc_src_1_y) + if (allocated(struc_src_2_x)) deallocate(struc_src_2_x) + if (allocated(struc_src_2_y)) deallocate(struc_src_2_y) + if (allocated(struc_obs_1_x)) deallocate(struc_obs_1_x) + if (allocated(struc_obs_1_y)) deallocate(struc_obs_1_y) + if (allocated(struc_obs_2_x)) deallocate(struc_obs_2_x) + if (allocated(struc_obs_2_y)) deallocate(struc_obs_2_y) + if (allocated(struc_q)) deallocate(struc_q) + if (allocated(struc_par1)) deallocate(struc_par1) + if (allocated(struc_par2)) deallocate(struc_par2) + if (allocated(struc_par3)) deallocate(struc_par3) + if (allocated(struc_cd)) deallocate(struc_cd) + if (allocated(struc_width)) deallocate(struc_width) + if (allocated(struc_sill_elevation)) deallocate(struc_sill_elevation) + if (allocated(struc_mannings_n)) deallocate(struc_mannings_n) + if (allocated(struc_zmin)) deallocate(struc_zmin) + if (allocated(struc_zmax)) deallocate(struc_zmax) + if (allocated(struc_t_close)) deallocate(struc_t_close) + ! + allocate(struc_nm_in(n)) + allocate(struc_nm_out(n)) + allocate(qstruc(n)) + allocate(struc_type(n)) + allocate(struc_distance(n)) + allocate(struc_status(n)) + allocate(struc_fraction_open(n)) + allocate(struc_id(n)) + allocate(struc_name(n)) + allocate(struc_x(n)) + allocate(struc_y(n)) + allocate(struc_src_1_x(n)) + allocate(struc_src_1_y(n)) + allocate(struc_src_2_x(n)) + allocate(struc_src_2_y(n)) + allocate(struc_obs_1_x(n)) + allocate(struc_obs_1_y(n)) + allocate(struc_obs_2_x(n)) + allocate(struc_obs_2_y(n)) + allocate(struc_q(n)) + allocate(struc_par1(n)) + allocate(struc_par2(n)) + allocate(struc_par3(n)) + allocate(struc_cd(n)) + allocate(struc_width(n)) + allocate(struc_sill_elevation(n)) + allocate(struc_mannings_n(n)) + allocate(struc_zmin(n)) + allocate(struc_zmax(n)) + allocate(struc_t_close(n)) + ! + struc_nm_in = 0 + struc_nm_out = 0 + qstruc = 0.0 + struc_type = 0 + struc_distance = 0.0 + struc_fraction_open = 1.0 ! initially fully open (could be refined from zmin/zmax) + struc_status = 1 ! 0=closed, 1=open, 2=closing, 3=opening + struc_id = ' ' + struc_name = ' ' + struc_x = 0.0 + struc_y = 0.0 + struc_src_1_x = 0.0 + struc_src_1_y = 0.0 + struc_src_2_x = 0.0 + struc_src_2_y = 0.0 + struc_obs_1_x = 0.0 + struc_obs_1_y = 0.0 + struc_obs_2_x = 0.0 + struc_obs_2_y = 0.0 + struc_q = 0.0 + struc_par1 = 0.0 + struc_par2 = 0.0 + struc_par3 = 0.0 + struc_cd = 0.0 + struc_width = 0.0 + struc_sill_elevation= 0.0 + struc_mannings_n = 0.0 + struc_zmin = 0.0 + struc_zmax = 0.0 + struc_t_close = 0.0 + ! + end subroutine + ! ! - do idrn = 1, ndrn + subroutine finalize_src_structures_state() + ! + ! Shared post-processing for both the legacy and TOML paths. Looks up + ! intake / outfall cell indices from the struc_src_1_* / _2_* coords + ! and computes centre-to-centre distance. + ! + use sfincs_data + use quadtree + ! + implicit none + ! + integer :: istruc, nmq + real*4 :: xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp + ! + do istruc = 1, nstruc ! - nmq = find_quadtree_cell(xsnk(idrn), ysnk(idrn)) - if (nmq > 0) nmindrn_in(idrn) = index_sfincs_in_quadtree(nmq) + nmq = find_quadtree_cell(struc_src_1_x(istruc), struc_src_1_y(istruc)) + if (nmq > 0) struc_nm_in(istruc) = index_sfincs_in_quadtree(nmq) ! - nmq = find_quadtree_cell(xsrc_drn(idrn), ysrc_drn(idrn)) - if (nmq > 0) nmindrn_out(idrn) = index_sfincs_in_quadtree(nmq) + nmq = find_quadtree_cell(struc_src_2_x(istruc), struc_src_2_y(istruc)) + if (nmq > 0) struc_nm_out(istruc) = index_sfincs_in_quadtree(nmq) ! - if (nmindrn_in(idrn) > 0 .and. nmindrn_out(idrn) > 0) then + if (struc_nm_in(istruc) > 0 .and. struc_nm_out(istruc) > 0) then ! - xsnk_tmp = z_xz(nmindrn_in(idrn)) - ysnk_tmp = z_yz(nmindrn_in(idrn)) - xsrc_tmp = z_xz(nmindrn_out(idrn)) - ysrc_tmp = z_yz(nmindrn_out(idrn)) - drainage_distance(idrn) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + xsnk_tmp = z_xz(struc_nm_in(istruc)) + ysnk_tmp = z_yz(struc_nm_in(istruc)) + xsrc_tmp = z_xz(struc_nm_out(istruc)) + ysrc_tmp = z_yz(struc_nm_out(istruc)) + struc_distance(istruc) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) ! endif ! enddo ! - deallocate(xsrc_drn) - deallocate(ysrc_drn) - deallocate(xsnk) - deallocate(ysnk) - ! - if (any(nmindrn_in == 0) .or. any(nmindrn_out == 0)) then + if (any(struc_nm_in == 0) .or. any(struc_nm_out == 0)) then ! write(logstr,'(a)') 'Warning ! For some sink/source drainage points no matching active grid cell was found!' call write_log(logstr, 0) @@ -389,11 +585,122 @@ subroutine initialize_src_structures_legacy() end subroutine ! ! + subroutine marshal_src_structures_to_flat_arrays() + ! + ! Copy the module-level src_structures(:) array (populated by + ! read_toml_src_structures) into the struc_* flat arrays, then run + ! the shared post-processing and deallocate src_structures(:). + ! + ! The TOML and legacy paths are mutually exclusive, so the flat arrays + ! should not yet be allocated when this is called; allocate_struc_flat_arrays + ! defensively deallocates any residual allocation first. + ! + ! Note: %actions and %rules are dropped at this point. They are not + ! consumed by any downstream runtime code yet. Follow-up work: add flat + ! arrays for action / rule counts and element data, and copy those in + ! this helper before the deallocation. + ! + use sfincs_data + ! + implicit none + ! + integer :: i, n + ! + if (.not. allocated(src_structures)) then + ! + nstruc = 0 + return + ! + endif + ! + n = size(src_structures) + nstruc = n + ! + if (n <= 0) then + ! + deallocate(src_structures) + return + ! + endif + ! + call allocate_struc_flat_arrays(n) + ! + do i = 1, n + ! + ! String fields: truncation warning if longer than struc_id_len. + ! + if (allocated(src_structures(i)%id)) then + ! + if (len(src_structures(i)%id) > struc_id_len) then + ! + write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure id length > ', struc_id_len, & + ' at entry ', i, '; truncating' + call write_log(logstr, 0) + ! + endif + ! + struc_id(i) = src_structures(i)%id + ! + endif + ! + if (allocated(src_structures(i)%name)) then + ! + if (len(src_structures(i)%name) > struc_id_len) then + ! + write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure name length > ', struc_id_len, & + ' at entry ', i, '; truncating' + call write_log(logstr, 0) + ! + endif + ! + struc_name(i) = src_structures(i)%name + ! + endif + ! + struc_type(i) = int(src_structures(i)%structure_type, 1) + struc_status(i) = int(src_structures(i)%status, 1) + ! + struc_x(i) = src_structures(i)%x + struc_y(i) = src_structures(i)%y + struc_src_1_x(i) = src_structures(i)%src_1_x + struc_src_1_y(i) = src_structures(i)%src_1_y + struc_src_2_x(i) = src_structures(i)%src_2_x + struc_src_2_y(i) = src_structures(i)%src_2_y + struc_obs_1_x(i) = src_structures(i)%obs_1_x + struc_obs_1_y(i) = src_structures(i)%obs_1_y + struc_obs_2_x(i) = src_structures(i)%obs_2_x + struc_obs_2_y(i) = src_structures(i)%obs_2_y + ! + struc_q(i) = src_structures(i)%q + struc_par1(i) = src_structures(i)%par1 + struc_par2(i) = src_structures(i)%par2 + struc_par3(i) = src_structures(i)%par3 + struc_cd(i) = src_structures(i)%cd + struc_width(i) = src_structures(i)%width + struc_sill_elevation(i) = src_structures(i)%sill_elevation + struc_mannings_n(i) = src_structures(i)%mannings_n + struc_zmin(i) = src_structures(i)%zmin + struc_zmax(i) = src_structures(i)%zmax + struc_t_close(i) = src_structures(i)%t_close + ! + enddo + ! + ! Shared post-processing. + ! + call finalize_src_structures_state() + ! + ! Drop the derived-type array; flat arrays carry all runtime state now. + ! + deallocate(src_structures) + ! + end subroutine + ! + ! subroutine update_src_structures(t, dt, tloop) ! ! Compute discharges through each drainage structure, accumulate them ! into qsrc(np) (intake: -qq, outfall: +qq), and store per-structure - ! signed discharge in qdrain(ndrn) for his output. + ! signed discharge in qstruc(nstruc) for his output. ! ! Called AFTER update_discharges, which zeros qsrc first. ! @@ -409,38 +716,42 @@ subroutine update_src_structures(t, dt, tloop) real :: tloop ! integer :: count0, count1, count_rate, count_max - integer :: idrn, nmin, nmout + integer :: istruc, nmin, nmout real*4 :: qq, qq0 real*4 :: dzds, frac, wdt, zsill, zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ! - if (ndrn <= 0) return + if (nstruc <= 0) return ! call system_clock(count0, count_rate, count_max) ! - !$acc parallel loop present( z_volume, zs, zb, qsrc, qdrain, & - !$acc nmindrn_in, nmindrn_out, & - !$acc drainage_type, drainage_params, & - !$acc drainage_distance, drainage_status, drainage_fraction_open ) & + !$acc parallel loop present( z_volume, zs, zb, qsrc, qstruc, & + !$acc struc_nm_in, struc_nm_out, & + !$acc struc_type, & + !$acc struc_q, struc_par1, struc_par2, & + !$acc struc_width, struc_sill_elevation, & + !$acc struc_mannings_n, struc_zmin, struc_zmax, & + !$acc struc_t_close, & + !$acc struc_distance, struc_status, struc_fraction_open ) & !$acc private( nmin, nmout, qq, qq0, dzds, frac, wdt, zsill, & !$acc zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ) !$omp parallel do & !$omp private( nmin, nmout, qq, qq0, dzds, frac, wdt, zsill, & !$omp zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ) & !$omp schedule ( static ) - do idrn = 1, ndrn + do istruc = 1, nstruc ! - nmin = nmindrn_in(idrn) - nmout = nmindrn_out(idrn) + nmin = struc_nm_in(istruc) + nmout = struc_nm_out(istruc) ! if (nmin > 0 .and. nmout > 0) then ! - select case(drainage_type(idrn)) + select case(struc_type(istruc)) ! case(1) ! ! Pump ! - qq = drainage_params(idrn, 1) + qq = struc_q(istruc) ! case(2) ! @@ -448,11 +759,11 @@ subroutine update_src_structures(t, dt, tloop) ! if (zs(nmin) > zs(nmout)) then ! - qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) + qq = struc_par1(istruc) * sqrt(zs(nmin) - zs(nmout)) ! else ! - qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) + qq = -struc_par1(istruc) * sqrt(zs(nmout) - zs(nmin)) ! endif ! @@ -462,11 +773,11 @@ subroutine update_src_structures(t, dt, tloop) ! if (zs(nmin) > zs(nmout)) then ! - qq = drainage_params(idrn, 1) * sqrt(zs(nmin) - zs(nmout)) + qq = struc_par1(istruc) * sqrt(zs(nmin) - zs(nmout)) ! else ! - qq = -drainage_params(idrn, 1) * sqrt(zs(nmout) - zs(nmin)) + qq = -struc_par1(istruc) * sqrt(zs(nmout) - zs(nmin)) ! endif ! @@ -476,55 +787,55 @@ subroutine update_src_structures(t, dt, tloop) ! ! Controlled gate - opens when intake water level is between zmin and zmax. ! - wdt = drainage_params(idrn, 1) ! width - zsill = drainage_params(idrn, 2) ! sill elevation - mng = drainage_params(idrn, 3) ! Manning's n - zmin = drainage_params(idrn, 4) ! min water level for open - zmax = drainage_params(idrn, 5) ! max water level for open - tcls = drainage_params(idrn, 6) ! closing time (s) + wdt = struc_width(istruc) ! width + zsill = struc_sill_elevation(istruc) ! sill elevation + mng = struc_mannings_n(istruc) ! Manning's n + zmin = struc_zmin(istruc) ! min water level for open + zmax = struc_zmax(istruc) ! max water level for open + tcls = struc_t_close(istruc) ! closing time (s) ! - dzds = (zs(nmout) - zs(nmin)) / drainage_distance(idrn) - frac = drainage_fraction_open(idrn) + dzds = (zs(nmout) - zs(nmin)) / struc_distance(istruc) + frac = struc_fraction_open(istruc) hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) dfrac = dt / tcls ! - qq0 = qdrain(idrn) / (wdt * max(frac, 0.001)) ! previous discharge per unit width, ignoring fraction + qq0 = qstruc(istruc) / (wdt * max(frac, 0.001)) ! previous discharge per unit width, ignoring fraction ! - if (drainage_status(idrn) == 0) then + if (struc_status(istruc) == 0) then ! - if (zs(nmin) > zmin .and. zs(nmin) < zmax) drainage_status(idrn) = 3 + if (zs(nmin) > zmin .and. zs(nmin) < zmax) struc_status(istruc) = 3 ! - elseif (drainage_status(idrn) == 1) then + elseif (struc_status(istruc) == 1) then ! - if (zs(nmin) <= zmin .or. zs(nmin) >= zmax) drainage_status(idrn) = 2 + if (zs(nmin) <= zmin .or. zs(nmin) >= zmax) struc_status(istruc) = 2 ! endif ! - if (drainage_status(idrn) == 2) then + if (struc_status(istruc) == 2) then ! frac = frac - dfrac ! if (frac < 0.0) then ! frac = 0.0 - drainage_status(idrn) = 0 + struc_status(istruc) = 0 ! endif ! - elseif (drainage_status(idrn) == 3) then + elseif (struc_status(istruc) == 3) then ! frac = frac + dfrac ! if (frac > 1.0) then ! frac = 1.0 - drainage_status(idrn) = 1 + struc_status(istruc) = 1 ! endif ! endif ! - drainage_fraction_open(idrn) = frac + struc_fraction_open(istruc) = frac ! qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) qq = qq * wdt * frac @@ -533,55 +844,55 @@ subroutine update_src_structures(t, dt, tloop) ! ! Controlled gate - schedule triggered (one open/close window). ! - wdt = drainage_params(idrn, 1) ! width - zsill = drainage_params(idrn, 2) ! sill elevation - mng = drainage_params(idrn, 3) ! Manning's n - tclose = drainage_params(idrn, 4) ! time wrt tref to close - topen = drainage_params(idrn, 5) ! time wrt tref to open - tcls = drainage_params(idrn, 6) ! closing time (s) + wdt = struc_width(istruc) ! width + zsill = struc_sill_elevation(istruc) ! sill elevation + mng = struc_mannings_n(istruc) ! Manning's n + tclose = struc_par1(istruc) ! time wrt tref to close + topen = struc_par2(istruc) ! time wrt tref to open + tcls = struc_t_close(istruc) ! closing time (s) ! - dzds = (zs(nmout) - zs(nmin)) / drainage_distance(idrn) - frac = drainage_fraction_open(idrn) + dzds = (zs(nmout) - zs(nmin)) / struc_distance(istruc) + frac = struc_fraction_open(istruc) hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) dfrac = dt / tcls ! - qq0 = qdrain(idrn) / (wdt * max(frac, 0.001)) + qq0 = qstruc(istruc) / (wdt * max(frac, 0.001)) ! - if (drainage_status(idrn) == 0) then + if (struc_status(istruc) == 0) then ! - if (t >= topen) drainage_status(idrn) = 3 + if (t >= topen) struc_status(istruc) = 3 ! - elseif (drainage_status(idrn) == 1) then + elseif (struc_status(istruc) == 1) then ! - if (t >= tclose .and. t < topen) drainage_status(idrn) = 2 + if (t >= tclose .and. t < topen) struc_status(istruc) = 2 ! endif ! - if (drainage_status(idrn) == 2) then + if (struc_status(istruc) == 2) then ! frac = frac - dfrac ! if (frac < 0.0) then ! frac = 0.0 - drainage_status(idrn) = 0 + struc_status(istruc) = 0 ! endif ! - elseif (drainage_status(idrn) == 3) then + elseif (struc_status(istruc) == 3) then ! frac = frac + dfrac ! if (frac > 1.0) then ! frac = 1.0 - drainage_status(idrn) = 1 + struc_status(istruc) = 1 ! endif ! endif ! - drainage_fraction_open(idrn) = frac + struc_fraction_open(istruc) = frac ! qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) qq = qq * wdt * frac @@ -590,7 +901,7 @@ subroutine update_src_structures(t, dt, tloop) ! ! Relaxation: blend new and previous discharge to damp oscillations. ! - qq = 1.0 / (structure_relax / dt) * qq + (1.0 - (1.0 / (structure_relax / dt))) * qdrain(idrn) + qq = 1.0 / (structure_relax / dt) * qq + (1.0 - (1.0 / (structure_relax / dt))) * qstruc(istruc) ! ! Limit discharge by available volume in the intake / outfall cell. ! @@ -620,7 +931,7 @@ subroutine update_src_structures(t, dt, tloop) ! endif ! - qdrain(idrn) = qq + qstruc(istruc) = qq ! ! Accumulate into cell-wise qsrc. Atomic guards against multiple ! structures (or a river and a structure) in the same cell. From 5bfd43044351447722302c81d8e03e033e9f4f1e Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Fri, 17 Apr 2026 17:46:59 +0200 Subject: [PATCH 24/65] Add rule-expression module and integrate structures Introduce a new sfincs_rule_expression module that implements a small boolean rule mini-language (parser, bytecode, evaluator and tests) for gate-like source structures. Register the module in the project (vfproj, Makefile.am) and wire it into the codebase: add uses of sfincs_rule_expression and sfincs_src_structures where needed, expose rule bytecode arrays to OpenACC, and ensure rule storage is finalized for accelerator use. Replace several checks and I/O that previously used ndrn with nr_src_structures (and qdrain -> qstruc updates) across sfincs_input.f90, sfincs_lib.f90, sfincs_ncoutput.F90, sfincs_openacc.f90, and sfincs_output.f90. Also adjust a default cd_val and set nr_src_structures=0 in the bathtub configuration. These changes enable per-structure rule-driven gating and proper NetCDF/OpenACC handling of source-structure data. --- source/sfincs_lib/sfincs_lib.vfproj | 1 + source/src/Makefile.am | 1 + source/src/sfincs_input.f90 | 5 +- source/src/sfincs_lib.f90 | 2 +- source/src/sfincs_ncoutput.F90 | 39 +- source/src/sfincs_openacc.f90 | 31 +- source/src/sfincs_output.f90 | 13 +- source/src/sfincs_rule_expression.f90 | 1253 +++++++++++++++++++++++++ source/src/sfincs_src_structures.f90 | 543 +++-------- 9 files changed, 1455 insertions(+), 433 deletions(-) create mode 100644 source/src/sfincs_rule_expression.f90 diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 884aede9a..d6909418c 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -99,6 +99,7 @@ + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index a3538a58c..bd3be5725 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -74,6 +74,7 @@ libsfincs_la_SOURCES = \ sfincs_continuity.f90 \ sfincs_crosssections.f90 \ sfincs_discharges.f90 \ + sfincs_rule_expression.f90 \ sfincs_src_structures.f90 \ sfincs_subgrid.F90 \ sfincs_timestep_analysis.f90 \ diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 014d308b9..ad9b8d411 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_src_structures, only: nr_src_structures ! implicit none ! @@ -321,7 +322,7 @@ subroutine read_sfincs_input() cd_wnd(3) = 50.0 cd_val(1) = 0.0010 cd_val(2) = 0.0025 - cd_val(3) = 0.0015 + cd_val(3) = 0.0025 ! else ! @@ -711,7 +712,7 @@ subroutine read_sfincs_input() ! Turn off some processes not needed for bathtub flooding ! nsrc = 0 - ndrn = 0 + nr_src_structures = 0 ! meteo3d = .false. wind = .false. diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 8c6b54e9a..89027c4cd 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -724,7 +724,7 @@ function sfincs_finalize() result(ierr) call write_log(logstr, 1) endif ! - if (nsrc>0 .or. ndrn>0) then + if (nsrc>0 .or. nr_src_structures>0) then write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in discharges : ', tloopsrc, ' (', 100 * tloopsrc / (tfinish_all - tstart_all), '%)' call write_log(logstr, 1) endif diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index eb04a3213..b506e1792 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -1613,13 +1613,14 @@ subroutine ncoutput_his_init() ! 2. write grid/msk/zb to file ! use sfincs_date - use sfincs_data + use sfincs_data use sfincs_structures + use sfincs_src_structures, only: nr_src_structures ! - implicit none + implicit none + ! + integer :: istruc ! - integer :: istruc - ! real*4, dimension(:,:), allocatable :: struc_info real*4, dimension(:), allocatable :: struc_x real*4, dimension(:), allocatable :: struc_y @@ -1629,7 +1630,7 @@ subroutine ncoutput_his_init() real*4, dimension(:), allocatable :: thindam_x real*4, dimension(:), allocatable :: thindam_y ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. ndrn==0 .and. .not. (nsrc>0 .and. store_river_discharge) .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources (when store_river_discharge) or run-up gauges; his file is not created + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nr_src_structures==0 .and. .not. (nsrc>0 .and. store_river_discharge) .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources (when store_river_discharge) or run-up gauges; his file is not created return endif ! @@ -1649,8 +1650,8 @@ subroutine ncoutput_his_init() NF90(nf90_def_dim(his_file%ncid, 'crosssections', nrcrosssections, his_file%crosssections_dimid)) ! nr of crosssections endif ! - if (ndrn>0) then - NF90(nf90_def_dim(his_file%ncid, 'drainage', ndrn, his_file%drain_dimid)) ! nr of drainage structures + if (nr_src_structures>0) then + NF90(nf90_def_dim(his_file%ncid, 'drainage', nr_src_structures, his_file%drain_dimid)) ! nr of drainage structures endif ! if (nsrc>0 .and. store_river_discharge) then @@ -2048,7 +2049,7 @@ subroutine ncoutput_his_init() ! endif ! - if (ndrn>0) then + if (nr_src_structures>0) then ! NF90(nf90_def_var(his_file%ncid, 'drainage_discharge', NF90_FLOAT, (/his_file%drain_dimid, his_file%time_dimid/), his_file%drain_varid)) ! time-varying discharge through drainage structure NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, '_FillValue', FILL_VALUE)) @@ -3013,14 +3014,15 @@ subroutine ncoutput_update_quadtree_map(t,ntmapout) subroutine ncoutput_update_his(t,nthisout) ! Write time, zs, u, v, prcp of points ! - use sfincs_data + use sfincs_data use sfincs_crosssections use sfincs_runup_gauges use sfincs_snapwave + use sfincs_src_structures, only: nr_src_structures, qstruc ! - implicit none + implicit none ! - integer :: iobs, nm, idrn + integer :: iobs, nm, istruc ! integer :: nthisout integer :: nmd1, nmu1, ndm1, num1 @@ -3308,11 +3310,11 @@ subroutine ncoutput_update_his(t,nthisout) ! endif ! - if (ndrn>0) then + if (nr_src_structures>0) then ! - !$acc update host(qdrain) + !$acc update host(qstruc) ! - NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, qdrain, (/1, nthisout/))) ! write per-structure discharge + NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, qstruc, (/1, nthisout/))) ! write per-structure discharge ! endif ! @@ -3904,10 +3906,11 @@ subroutine ncoutput_his_finalize() ! Add total runtime, dtavg to file and close ! use sfincs_data - ! - implicit none - ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. ndrn==0 .and. .not. (nsrc>0 .and. store_river_discharge)) then ! If no observation points, cross-sections, structures (weir or thin dam), drains or river sources (when store_river_discharge); hisfile + use sfincs_src_structures, only: nr_src_structures + ! + implicit none + ! + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. nr_src_structures==0 .and. .not. (nsrc>0 .and. store_river_discharge)) then ! If no observation points, cross-sections, structures (weir or thin dam), drains or river sources (when store_river_discharge); hisfile return endif ! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 061830ffe..31146dd1c 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -1,6 +1,9 @@ module sfincs_openacc ! use sfincs_data + use sfincs_src_structures + use sfincs_rule_expression, only: rule_opcode, rule_atom, rule_cmp, rule_threshold, & + rule_start, rule_length ! implicit none ! @@ -21,18 +24,20 @@ subroutine initialize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc qsrc, qtsrc, qdrain, nmindsrc, nmindrn_in, nmindrn_out, drainage_type, & - !$acc drainage_q, drainage_par1, drainage_par2, drainage_par3, drainage_cd, & - !$acc drainage_width, drainage_sill_elevation, drainage_mannings_n, & - !$acc drainage_zmin, drainage_zmax, drainage_t_close, & - !$acc drainage_distance, drainage_status, drainage_fraction_open, & + !$acc qsrc, qtsrc, qstruc, nmindsrc, struc_nm_in, struc_nm_out, struc_type, & + !$acc struc_q, struc_par1, struc_par2, struc_par3, struc_cd, & + !$acc struc_width, struc_sill_elevation, struc_mannings_n, & + !$acc struc_zmin, struc_zmax, struc_t_close, & + !$acc struc_distance, struc_status, struc_fraction_open, & + !$acc struc_rule_open, struc_rule_close, & + !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & !$acc tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & - !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & + !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & !$acc patm, patm0, patm1, patmb, nmindbnd, & - !$acc prcp, prcp0, prcp1, cumprcp, netprcp, prcp, qext, & + !$acc prcp, prcp0, prcp1, cumprcp, netprcp, prcp, qext, & !$acc dxminv, dxrinv, dyrinv, dxm2inv, dxr2inv, dyr2inv, dxrinvc, dyrinvc, dxm, dxrm, dyrm, cell_area_m2, cell_area, & !$acc gn2uv, fcorio2d, storage_volume, nuvisc, & !$acc cuv_index_uv, cuv_index_uv1, cuv_index_uv2, & @@ -55,11 +60,13 @@ subroutine finalize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc qsrc, qtsrc, qdrain, nmindsrc, nmindrn_in, nmindrn_out, drainage_type, & - !$acc drainage_q, drainage_par1, drainage_par2, drainage_par3, drainage_cd, & - !$acc drainage_width, drainage_sill_elevation, drainage_mannings_n, & - !$acc drainage_zmin, drainage_zmax, drainage_t_close, & - !$acc drainage_distance, drainage_status, drainage_fraction_open, & + !$acc qsrc, qtsrc, qstruc, nmindsrc, struc_nm_in, struc_nm_out, struc_type, & + !$acc struc_q, struc_par1, struc_par2, struc_par3, struc_cd, & + !$acc struc_width, struc_sill_elevation, struc_mannings_n, & + !$acc struc_zmin, struc_zmax, struc_t_close, & + !$acc struc_distance, struc_status, struc_fraction_open, & + !$acc struc_rule_open, struc_rule_close, & + !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & diff --git a/source/src/sfincs_output.f90 b/source/src/sfincs_output.f90 index b4d8e5dbb..daa93551f 100644 --- a/source/src/sfincs_output.f90 +++ b/source/src/sfincs_output.f90 @@ -8,6 +8,7 @@ module sfincs_output subroutine initialize_output(tmapout,tmaxout,thisout, trstout) ! use sfincs_data + use sfincs_src_structures, only: nr_src_structures ! implicit none ! @@ -62,7 +63,7 @@ subroutine initialize_output(tmapout,tmaxout,thisout, trstout) ! ! Create his file if either observation points, cross-sections, structures or drains present ! - if (dthisout>1.0e-6 .and. (nobs>0 .or. nrcrosssections>0 .or. nrstructures>0 .or. nrthindams>0 .or. ndrn>0 .or. nr_runup_gauges>0 )) then + if (dthisout>1.0e-6 .and. (nobs>0 .or. nrcrosssections>0 .or. nrstructures>0 .or. nrthindams>0 .or. nr_src_structures>0 .or. nr_runup_gauges>0 )) then ! thisout = t0 ! @@ -575,6 +576,7 @@ subroutine close_max_output() subroutine open_his_output() ! use sfincs_data + use sfincs_src_structures, only: nr_src_structures ! implicit none ! @@ -592,7 +594,7 @@ subroutine open_his_output() open(unit = 969, file = trim('qriver.txt')) close(unit = 969 ,status='delete') endif - if (ndrn>0) then + if (nr_src_structures>0) then open(unit = 970, file = trim('qdrain.txt')) close(unit = 970 ,status='delete') endif @@ -606,6 +608,7 @@ subroutine write_his_output(t) ! use sfincs_data use sfincs_crosssections + use sfincs_src_structures, only: nr_src_structures, qstruc ! implicit none ! @@ -664,10 +667,10 @@ subroutine write_his_output(t) close(969) endif ! - if (ndrn>0 .and. store_qdrain) then - !$acc update host(qdrain) + if (nr_src_structures>0 .and. store_qdrain) then + !$acc update host(qstruc) open(unit = 970, file = trim('qdrain.txt'), access='append') - write(970,'(f12.1,10000f9.3)')t,(qdrain(iobs), iobs = 1, ndrn) + write(970,'(f12.1,10000f9.3)')t,(qstruc(iobs), iobs = 1, nr_src_structures) close(970) endif ! diff --git a/source/src/sfincs_rule_expression.f90 b/source/src/sfincs_rule_expression.f90 new file mode 100644 index 000000000..41fcac154 --- /dev/null +++ b/source/src/sfincs_rule_expression.f90 @@ -0,0 +1,1253 @@ +module sfincs_rule_expression + ! + ! Boolean rule mini-language used by gate-like src_structures to decide + ! when to open or close. The grammar is: + ! + ! expr := or_expr + ! or_expr := and_expr ( ('|' | 'or' ) and_expr )* + ! and_expr := comp ( ('&' | 'and') comp )* + ! comp := '(' expr ')' | atom cmp_op number + ! atom := 'z1' | 'z2' | 'z2-z1' (case-insensitive) + ! cmp_op := '<' | '>' + ! number := real literal + ! + ! Precedence: paren > comp > '&' > '|'. Left-associative. + ! + ! Each rule is compiled to a reverse-polish bytecode stream in four + ! parallel module-level arrays (opcode / atom / cmp / threshold) and + ! registered in a small parallel (start, length) registry indexed by + ! integer rule_id. Callers keep only that rule_id per-structure; the + ! module owns both the op stream (so all rules across all structures + ! concatenate into one buffer) and the registry. + ! + ! The evaluator is a small fixed-depth logical stack machine that is + ! ACC-safe (no allocations, no strings, no I/O). + ! + implicit none + ! + private + ! + ! Public bytecode storage. These four parallel arrays hold the + ! concatenated op streams for every rule that has been parsed. They + ! are public so sfincs_openacc can name them in !$acc directives. + ! + public :: rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_n_ops + ! + ! Public rule registry. rule_start(id) / rule_length(id) index into + ! the op streams above. n_rules is the highest rule_id currently + ! allocated; entries at index 0 are not used (rule_id == 0 is the + ! "no rule" sentinel). + ! + public :: rule_start, rule_length, n_rules + ! + ! Public API. + ! + public :: add_rule, evaluate_rule, finalize_rule_storage + public :: test_rule_expression + ! + ! --------------------------------------------------------------- + ! Opcodes. + ! + integer, parameter :: op_cmp = 1 + integer, parameter :: op_and = 2 + integer, parameter :: op_or = 3 + ! + ! Atom codes (the z value being compared). + ! + integer, parameter :: atom_z1 = 1 + integer, parameter :: atom_z2 = 2 + integer, parameter :: atom_z2_minus_z1 = 3 + ! + ! Comparator codes. + ! + integer, parameter :: cmp_lt = 1 + integer, parameter :: cmp_gt = 2 + ! + ! Parser / evaluator capacity limits. + ! + integer, parameter :: expr_stack_max = 16 ! evaluator logical-stack depth + integer, parameter :: expr_ops_max_per_rule = 64 ! max bytecode length per rule (parser rejects longer) + integer, parameter :: expr_tokens_max = 128 ! max tokens in a single rule string + ! + ! --------------------------------------------------------------- + ! Shared bytecode storage. + ! + ! add_rule appends into these arrays and auto-grows them. Handles + ! (rule_start, rule_length) in the registry index into them. + ! + integer, allocatable, save :: rule_opcode(:) + integer, allocatable, save :: rule_atom(:) + integer, allocatable, save :: rule_cmp(:) + real, allocatable, save :: rule_threshold(:) + integer, save :: rule_n_ops = 0 + integer, save :: rule_capacity = 0 + ! + ! Rule registry. Indexed by rule_id in [1 .. n_rules]. rule_id == 0 + ! is the "never fires" sentinel and has no registry entry. + ! + integer, allocatable, save :: rule_start(:) + integer, allocatable, save :: rule_length(:) + integer, save :: n_rules = 0 + integer, save :: rule_registry_capacity = 0 + ! + integer, parameter :: initial_capacity = 256 + integer, parameter :: initial_registry_capacity = 16 + ! +contains + ! + ! + subroutine add_rule(src, rule_id, ierr, errmsg) + ! + ! Parse the boolean expression in src, append its bytecode to the + ! module-level rule_* arrays, and register a new rule entry that + ! points at it. Returns the new rule_id. An empty or whitespace-only + ! src returns rule_id = 0 (the "never fires" sentinel; no registry + ! entry is created). On parse failure ierr /= 0, rule_id = 0, and + ! errmsg carries the diagnostic. + ! + implicit none + ! + character(len=*), intent(in) :: src + integer, intent(out) :: rule_id + integer, intent(out) :: ierr + character(len=*), optional, intent(out) :: errmsg + ! + ! Per-call scratch buffers for the parsed bytecode; sized to the + ! parser's per-rule cap. Copied into the module storage on success. + ! + integer :: ops_buf (expr_ops_max_per_rule) + integer :: atoms_buf (expr_ops_max_per_rule) + integer :: cmps_buf (expr_ops_max_per_rule) + real :: thr_buf (expr_ops_max_per_rule) + integer :: nops, new_start + character(len=256):: local_errmsg + ! + rule_id = 0 + ierr = 0 + if (present(errmsg)) errmsg = '' + ! + ! Empty / whitespace-only source: never fires, no registry entry. + ! + if (len_trim(src) == 0) return + ! + call parse_rule_expression(src, ops_buf, atoms_buf, cmps_buf, thr_buf, & + nops, ierr, local_errmsg) + ! + if (ierr /= 0) then + ! + if (present(errmsg)) errmsg = local_errmsg + return + ! + endif + ! + if (nops <= 0) then + ! + ierr = 1 + if (present(errmsg)) errmsg = 'rule parse produced no ops' + return + ! + endif + ! + ! Ensure the op stream has room for the new ops. + ! + call grow_rule_storage(rule_n_ops + nops) + ! + new_start = rule_n_ops + 1 + ! + rule_opcode (new_start : new_start + nops - 1) = ops_buf (1:nops) + rule_atom (new_start : new_start + nops - 1) = atoms_buf(1:nops) + rule_cmp (new_start : new_start + nops - 1) = cmps_buf (1:nops) + rule_threshold(new_start : new_start + nops - 1) = thr_buf (1:nops) + ! + rule_n_ops = rule_n_ops + nops + ! + ! Register the new rule and return its id. + ! + call grow_rule_registry(n_rules + 1) + ! + n_rules = n_rules + 1 + rule_start(n_rules) = new_start + rule_length(n_rules)= nops + rule_id = n_rules + ! + end subroutine + ! + ! + subroutine finalize_rule_storage() + ! + ! Shrink the rule_* op streams to exactly rule_n_ops and the registry + ! to exactly n_rules. If nothing was ever allocated (no rules parsed) + ! everything is allocated to size 0 so downstream openacc directives + ! can reference the arrays safely. + ! + implicit none + ! + integer, allocatable :: tmp_i(:) + real, allocatable :: tmp_r(:) + ! + ! Op streams. + ! + if (.not. allocated(rule_opcode)) then + ! + allocate(rule_opcode(0)) + allocate(rule_atom(0)) + allocate(rule_cmp(0)) + allocate(rule_threshold(0)) + rule_capacity = 0 + rule_n_ops = 0 + ! + else if (rule_capacity /= rule_n_ops) then + ! + allocate(tmp_i(rule_n_ops)) + if (rule_n_ops > 0) tmp_i = rule_opcode(1:rule_n_ops) + call move_alloc(tmp_i, rule_opcode) + ! + allocate(tmp_i(rule_n_ops)) + if (rule_n_ops > 0) tmp_i = rule_atom(1:rule_n_ops) + call move_alloc(tmp_i, rule_atom) + ! + allocate(tmp_i(rule_n_ops)) + if (rule_n_ops > 0) tmp_i = rule_cmp(1:rule_n_ops) + call move_alloc(tmp_i, rule_cmp) + ! + allocate(tmp_r(rule_n_ops)) + if (rule_n_ops > 0) tmp_r = rule_threshold(1:rule_n_ops) + call move_alloc(tmp_r, rule_threshold) + ! + rule_capacity = rule_n_ops + ! + endif + ! + ! Registry. + ! + if (.not. allocated(rule_start)) then + ! + allocate(rule_start(0)) + allocate(rule_length(0)) + rule_registry_capacity = 0 + n_rules = 0 + ! + else if (rule_registry_capacity /= n_rules) then + ! + allocate(tmp_i(n_rules)) + if (n_rules > 0) tmp_i = rule_start(1:n_rules) + call move_alloc(tmp_i, rule_start) + ! + allocate(tmp_i(n_rules)) + if (n_rules > 0) tmp_i = rule_length(1:n_rules) + call move_alloc(tmp_i, rule_length) + ! + rule_registry_capacity = n_rules + ! + endif + ! + end subroutine + ! + ! + pure function evaluate_rule(rule_id, z1, z2) result(fired) + ! + ! Fixed-depth stack machine that evaluates a compiled rule against + ! the two water levels z1 (intake) and z2 (outfall). A rule_id of 0 + ! short-circuits to .false. ("never fires"). + ! + !$acc routine seq + ! + implicit none + ! + integer, intent(in) :: rule_id + real, intent(in) :: z1, z2 + logical :: fired + ! + logical :: stack(expr_stack_max) + integer :: sp, k, idx, rs, rl + real :: zval + logical :: a, b + ! + fired = .false. + ! + if (rule_id <= 0) return + ! + rs = rule_start(rule_id) + rl = rule_length(rule_id) + ! + if (rl <= 0) return + ! + sp = 0 + ! + do k = 1, rl + ! + idx = rs + k - 1 + ! + select case (rule_opcode(idx)) + ! + case (op_cmp) + ! + select case (rule_atom(idx)) + ! + case (atom_z1) + ! + zval = z1 + ! + case (atom_z2) + ! + zval = z2 + ! + case (atom_z2_minus_z1) + ! + zval = z2 - z1 + ! + case default + ! + zval = 0.0 + ! + end select + ! + if (sp >= expr_stack_max) return + sp = sp + 1 + ! + if (rule_cmp(idx) == cmp_lt) then + ! + stack(sp) = zval < rule_threshold(idx) + ! + else + ! + stack(sp) = zval > rule_threshold(idx) + ! + endif + ! + case (op_and) + ! + b = stack(sp) + a = stack(sp - 1) + sp = sp - 1 + stack(sp) = a .and. b + ! + case (op_or) + ! + b = stack(sp) + a = stack(sp - 1) + sp = sp - 1 + stack(sp) = a .or. b + ! + end select + ! + enddo + ! + if (sp >= 1) fired = stack(1) + ! + end function + ! + ! + subroutine test_rule_expression() + ! + ! In-binary sanity check for the rule parser and evaluator. Parses a + ! handful of expressions via add_rule, compares evaluate_rule against + ! a hard-coded truth table, and checks that malformed inputs are + ! rejected without corrupting state. On the first failure, calls + ! error stop with a diagnostic. On success, writes a single pass + ! line to stdout. + ! + ! This is a debugging hook, not a permanent test suite. It is cheap + ! (runs in microseconds) and safe to leave in the module. + ! + implicit none + ! + integer :: id_open, id_close, id_bad + integer :: ierr + character(len=256) :: errmsg + logical :: got + integer :: i + ! + ! Truth-table rows for the two live rules. + ! + real, parameter :: z1_tab(5) = [ 0.3, 0.3, 0.8, 0.8, 1.0 ] + real, parameter :: z2_tab(5) = [ 0.4, 1.6, 0.9, 1.0, 2.5 ] + logical, parameter :: open_tab(5) = [ .true., .false., .true., .true., .false. ] + logical, parameter :: close_tab(5) = [ .false., .false., .false., .false., .true. ] + ! + ! 1) Open rule. + ! + call add_rule('(z1<0.5 | z2-z1>0.05) & z2<1.5', id_open, ierr, errmsg) + ! + if (ierr /= 0 .or. id_open <= 0) then + ! + write(*,'(a,a)') 'rule test: failed to parse open rule: ', trim(errmsg) + error stop "rule test: open rule did not parse" + ! + endif + ! + ! 2) Close rule. + ! + call add_rule('z2>2.0', id_close, ierr, errmsg) + ! + if (ierr /= 0 .or. id_close <= 0) then + ! + write(*,'(a,a)') 'rule test: failed to parse close rule: ', trim(errmsg) + error stop "rule test: close rule did not parse" + ! + endif + ! + ! 3) Empty rule must yield rule_id = 0 without error. + ! + call add_rule('', id_bad, ierr, errmsg) + ! + if (ierr /= 0 .or. id_bad /= 0) then + ! + write(*,'(a,i0,a,i0)') 'rule test: empty src gave id=', id_bad, ' ierr=', ierr + error stop "rule test: empty src must return id 0" + ! + endif + ! + ! 4) evaluate_rule(0, ...) must always be .false. + ! + do i = 1, 5 + ! + if (evaluate_rule(0, z1_tab(i), z2_tab(i))) then + ! + error stop "rule test: evaluate_rule(0,...) returned .true." + ! + endif + ! + enddo + ! + ! 5) Truth-table check. + ! + do i = 1, 5 + ! + got = evaluate_rule(id_open, z1_tab(i), z2_tab(i)) + ! + if (got .neqv. open_tab(i)) then + ! + write(*,'(a,i0,a,2(f6.3,1x),a,l1,a,l1)') & + 'rule test: open row ', i, ' z1=z2=', z1_tab(i), z2_tab(i), & + ' got=', got, ' expected=', open_tab(i) + error stop "rule test: open truth-table mismatch" + ! + endif + ! + got = evaluate_rule(id_close, z1_tab(i), z2_tab(i)) + ! + if (got .neqv. close_tab(i)) then + ! + write(*,'(a,i0,a,2(f6.3,1x),a,l1,a,l1)') & + 'rule test: close row ', i, ' z1=z2=', z1_tab(i), z2_tab(i), & + ' got=', got, ' expected=', close_tab(i) + error stop "rule test: close truth-table mismatch" + ! + endif + ! + enddo + ! + ! 6) Malformed inputs must set ierr /= 0 and return rule_id = 0. + ! + call check_malformed('z3 < 1') + call check_malformed('z1 <= 2') + call check_malformed('z1 < 1 &') + call check_malformed('(z1<1') + ! + write(*,'(a,i0,a,i0,a)') & + 'rule test: PASS (n_rules=', n_rules, ', rule_n_ops=', rule_n_ops, ')' + ! + contains + ! + subroutine check_malformed(bad) + ! + character(len=*), intent(in) :: bad + integer :: id_local, ierr_local + character(len=256) :: errmsg_local + ! + call add_rule(bad, id_local, ierr_local, errmsg_local) + ! + if (ierr_local == 0 .or. id_local /= 0) then + ! + write(*,'(a,a,a)') 'rule test: malformed "', trim(bad), '" was accepted' + error stop "rule test: malformed input not rejected" + ! + endif + ! + end subroutine + ! + end subroutine + ! + ! + ! ------------------------------------------------------------------- + ! Private helpers below. + ! ------------------------------------------------------------------- + ! + ! + subroutine grow_rule_storage(min_capacity) + ! + ! Ensure rule_capacity >= min_capacity. On first growth, allocates to + ! max(initial_capacity, min_capacity). On subsequent growth, doubles + ! until the requested capacity fits. Existing contents are preserved. + ! + implicit none + ! + integer, intent(in) :: min_capacity + ! + integer :: new_capacity + integer, allocatable :: tmp_i(:) + real, allocatable :: tmp_r(:) + ! + if (.not. allocated(rule_opcode)) then + ! + new_capacity = max(initial_capacity, min_capacity) + allocate(rule_opcode (new_capacity)) + allocate(rule_atom (new_capacity)) + allocate(rule_cmp (new_capacity)) + allocate(rule_threshold(new_capacity)) + rule_capacity = new_capacity + return + ! + endif + ! + if (min_capacity <= rule_capacity) return + ! + new_capacity = max(2 * rule_capacity, min_capacity) + ! + allocate(tmp_i(new_capacity)) + if (rule_n_ops > 0) tmp_i(1:rule_n_ops) = rule_opcode(1:rule_n_ops) + call move_alloc(tmp_i, rule_opcode) + ! + allocate(tmp_i(new_capacity)) + if (rule_n_ops > 0) tmp_i(1:rule_n_ops) = rule_atom(1:rule_n_ops) + call move_alloc(tmp_i, rule_atom) + ! + allocate(tmp_i(new_capacity)) + if (rule_n_ops > 0) tmp_i(1:rule_n_ops) = rule_cmp(1:rule_n_ops) + call move_alloc(tmp_i, rule_cmp) + ! + allocate(tmp_r(new_capacity)) + if (rule_n_ops > 0) tmp_r(1:rule_n_ops) = rule_threshold(1:rule_n_ops) + call move_alloc(tmp_r, rule_threshold) + ! + rule_capacity = new_capacity + ! + end subroutine + ! + ! + subroutine grow_rule_registry(min_capacity) + ! + ! Ensure rule_registry_capacity >= min_capacity. On first growth, + ! allocates to max(initial_registry_capacity, min_capacity). On + ! subsequent growth, doubles until the requested capacity fits. + ! Existing contents are preserved. + ! + implicit none + ! + integer, intent(in) :: min_capacity + ! + integer :: new_capacity + integer, allocatable :: tmp_i(:) + ! + if (.not. allocated(rule_start)) then + ! + new_capacity = max(initial_registry_capacity, min_capacity) + allocate(rule_start (new_capacity)) + allocate(rule_length(new_capacity)) + rule_registry_capacity = new_capacity + return + ! + endif + ! + if (min_capacity <= rule_registry_capacity) return + ! + new_capacity = max(2 * rule_registry_capacity, min_capacity) + ! + allocate(tmp_i(new_capacity)) + if (n_rules > 0) tmp_i(1:n_rules) = rule_start(1:n_rules) + call move_alloc(tmp_i, rule_start) + ! + allocate(tmp_i(new_capacity)) + if (n_rules > 0) tmp_i(1:n_rules) = rule_length(1:n_rules) + call move_alloc(tmp_i, rule_length) + ! + rule_registry_capacity = new_capacity + ! + end subroutine + ! + ! + subroutine parse_rule_expression(src, ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + ! Recursive-descent parser that compiles a rule string to reverse- + ! polish bytecode in four parallel arrays. op_cmp entries use all + ! three of atoms / cmps / thresholds; op_and / op_or use only opcode. + ! + implicit none + ! + character(len=*), intent(in) :: src + integer, intent(out) :: ops(:) + integer, intent(out) :: atoms(:) + integer, intent(out) :: cmps(:) + real, intent(out) :: thresholds(:) + integer, intent(out) :: nops + integer, intent(out) :: ierr + character(len=*), intent(out) :: errmsg + ! + ! Token kinds: + ! 1 = ident (z1/z2/z2-z1) payload: atom code in tok_atom + ! 2 = number payload: real in tok_num + ! 3 = lparen + ! 4 = rparen + ! 5 = and + ! 6 = or + ! 7 = lt + ! 8 = gt + ! + integer :: tok_kind(expr_tokens_max) + integer :: tok_atom(expr_tokens_max) + real :: tok_num (expr_tokens_max) + integer :: tok_pos (expr_tokens_max) + integer :: n_tokens, ip + ! + nops = 0 + ierr = 0 + errmsg = '' + ! + call tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ierr, errmsg) + ! + if (ierr /= 0) return + ! + if (n_tokens == 0) then + ! + ierr = 1 + errmsg = 'empty rule expression' + return + ! + endif + ! + ip = 1 + ! + call parse_or_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + if (ierr /= 0) return + ! + if (ip <= n_tokens) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'unexpected trailing token at position ', tok_pos(ip) + return + ! + endif + ! + end subroutine + ! + ! + subroutine tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ierr, errmsg) + ! + ! One-pass tokenizer. Emits fixed-size parallel arrays: kind, atom + ! code, number value, source position. Token kinds match the + ! parameters above in parse_rule_expression. + ! + implicit none + ! + character(len=*), intent(in) :: src + integer, intent(out) :: tok_kind(:) + integer, intent(out) :: tok_atom(:) + real, intent(out) :: tok_num(:) + integer, intent(out) :: tok_pos(:) + integer, intent(out) :: n_tokens + integer, intent(inout) :: ierr + character(len=*), intent(inout) :: errmsg + ! + integer, parameter :: tok_ident = 1 + integer, parameter :: tok_number = 2 + integer, parameter :: tok_lparen = 3 + integer, parameter :: tok_rparen = 4 + integer, parameter :: tok_and = 5 + integer, parameter :: tok_or = 6 + integer, parameter :: tok_lt = 7 + integer, parameter :: tok_gt = 8 + ! + integer :: pos, slen, start, kstart, ic, atom_code, iostat_read + character(len=:), allocatable :: lower + character(len=32) :: num_buf + logical :: matched + ! + lower = to_lower_local(src) + slen = len(lower) + pos = 1 + n_tokens = 0 + ! + do while (pos <= slen) + ! + ! Skip whitespace. + ! + ic = iachar(lower(pos:pos)) + ! + if (ic == iachar(' ') .or. ic == 9 .or. ic == 10 .or. ic == 13) then + ! + pos = pos + 1 + cycle + ! + endif + ! + if (n_tokens >= expr_tokens_max) then + ! + ierr = 1 + write(errmsg,'(a,i0,a)') 'too many tokens (>', expr_tokens_max, ') in rule expression' + return + ! + endif + ! + start = pos + ! + ! Single-character tokens. + ! + matched = .true. + ! + select case (lower(pos:pos)) + ! + case ('(') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_lparen + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case (')') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_rparen + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case ('&') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_and + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case ('|') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_or + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case ('<') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_lt + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case ('>') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_gt + tok_pos (n_tokens) = start + pos = pos + 1 + ! + case default + ! + matched = .false. + ! + end select + ! + if (matched) cycle + ! + ! Number: optional sign is not part of the grammar (z2-z1 is a + ! fixed atom, not arithmetic). A leading '-' or '+' is only + ! treated as a number's sign when the next char is digit or dot. + ! + ic = iachar(lower(pos:pos)) + ! + if (ic == iachar('-') .or. ic == iachar('+') .or. & + ic == iachar('.') .or. (ic >= iachar('0') .and. ic <= iachar('9'))) then + ! + if (lower(pos:pos) == '-' .or. lower(pos:pos) == '+') then + ! + if (pos + 1 > slen) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'trailing sign without digits at position ', pos + return + ! + endif + ! + ic = iachar(lower(pos+1:pos+1)) + ! + if (.not. (ic == iachar('.') .or. (ic >= iachar('0') .and. ic <= iachar('9')))) then + ! + ierr = 1 + write(errmsg,'(a,a,a,i0)') 'unexpected character "', lower(pos:pos), & + '" at position ', pos + return + ! + endif + ! + endif + ! + kstart = pos + ! + ! Leading sign. + ! + if (lower(pos:pos) == '-' .or. lower(pos:pos) == '+') pos = pos + 1 + ! + ! Integer part. + ! + do while (pos <= slen) + ! + ic = iachar(lower(pos:pos)) + if (.not. (ic >= iachar('0') .and. ic <= iachar('9'))) exit + pos = pos + 1 + ! + enddo + ! + ! Fractional part. + ! + if (pos <= slen) then + ! + if (lower(pos:pos) == '.') then + ! + pos = pos + 1 + ! + do while (pos <= slen) + ! + ic = iachar(lower(pos:pos)) + if (.not. (ic >= iachar('0') .and. ic <= iachar('9'))) exit + pos = pos + 1 + ! + enddo + ! + endif + ! + endif + ! + ! Exponent. + ! + if (pos <= slen) then + ! + if (lower(pos:pos) == 'e') then + ! + pos = pos + 1 + ! + if (pos <= slen) then + ! + if (lower(pos:pos) == '+' .or. lower(pos:pos) == '-') pos = pos + 1 + ! + endif + ! + do while (pos <= slen) + ! + ic = iachar(lower(pos:pos)) + if (.not. (ic >= iachar('0') .and. ic <= iachar('9'))) exit + pos = pos + 1 + ! + enddo + ! + endif + ! + endif + ! + num_buf = lower(kstart:pos-1) + ! + read(num_buf, *, iostat=iostat_read) tok_num(n_tokens + 1) + ! + if (iostat_read /= 0) then + ! + ierr = 1 + write(errmsg,'(a,a,a,i0)') 'invalid number "', trim(num_buf), & + '" at position ', kstart + return + ! + endif + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_number + tok_pos (n_tokens) = kstart + ! + cycle + ! + endif + ! + ! Identifiers: z1, z2, z2-z1, and / or. The 'z2-z1' atom contains + ! a '-', which would otherwise be eaten by the number path; we + ! match it as a longest-match-first prefix here. + ! + kstart = pos + ! + select case (lower(pos:pos)) + ! + case ('z') + ! + if (pos + 4 <= slen) then + ! + if (lower(pos:pos+4) == 'z2-z1') then + ! + atom_code = atom_z2_minus_z1 + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_ident + tok_atom(n_tokens) = atom_code + tok_pos (n_tokens) = kstart + pos = pos + 5 + cycle + ! + endif + ! + endif + ! + if (pos + 1 <= slen) then + ! + if (lower(pos:pos+1) == 'z1') then + ! + atom_code = atom_z1 + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_ident + tok_atom(n_tokens) = atom_code + tok_pos (n_tokens) = kstart + pos = pos + 2 + cycle + ! + elseif (lower(pos:pos+1) == 'z2') then + ! + atom_code = atom_z2 + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_ident + tok_atom(n_tokens) = atom_code + tok_pos (n_tokens) = kstart + pos = pos + 2 + cycle + ! + endif + ! + endif + ! + ierr = 1 + write(errmsg,'(a,i0)') 'unknown z-identifier at position ', pos + return + ! + case ('a') + ! + if (pos + 2 <= slen) then + ! + if (lower(pos:pos+2) == 'and') then + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_and + tok_pos (n_tokens) = kstart + pos = pos + 3 + cycle + ! + endif + ! + endif + ! + ierr = 1 + write(errmsg,'(a,i0)') 'unknown identifier beginning with "a" at position ', pos + return + ! + case ('o') + ! + if (pos + 1 <= slen) then + ! + if (lower(pos:pos+1) == 'or') then + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_or + tok_pos (n_tokens) = kstart + pos = pos + 2 + cycle + ! + endif + ! + endif + ! + ierr = 1 + write(errmsg,'(a,i0)') 'unknown identifier beginning with "o" at position ', pos + return + ! + case default + ! + ierr = 1 + write(errmsg,'(a,a,a,i0)') 'unexpected character "', lower(pos:pos), & + '" at position ', pos + return + ! + end select + ! + enddo + ! + end subroutine + ! + ! + recursive subroutine parse_or_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + ! Parse an or-expression. Emits a parse_and_expr, then while the + ! next token is 'or', consumes it, parses another and-expression, + ! and emits op_or. + ! + implicit none + ! + integer, intent(in) :: tok_kind(:), tok_atom(:), tok_pos(:) + real, intent(in) :: tok_num(:) + integer, intent(in) :: n_tokens + integer, intent(inout) :: ip + integer, intent(inout) :: ops(:), atoms(:), cmps(:) + real, intent(inout) :: thresholds(:) + integer, intent(inout) :: nops + integer, intent(inout) :: ierr + character(len=*), intent(inout) :: errmsg + ! + integer, parameter :: tok_or = 6 + ! + call parse_and_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + do while (ip <= n_tokens) + ! + if (tok_kind(ip) /= tok_or) exit + ! + ip = ip + 1 + ! + call parse_and_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + if (nops >= expr_ops_max_per_rule) then + ! + ierr = 1 + errmsg = 'rule expression too long (op buffer full)' + return + ! + endif + ! + nops = nops + 1 + ops(nops) = op_or + atoms(nops) = 0 + cmps(nops) = 0 + thresholds(nops) = 0.0 + ! + enddo + ! + end subroutine + ! + ! + recursive subroutine parse_and_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + ! Parse an and-expression. Emits a parse_comp, then while the next + ! token is 'and', consumes it, parses another comp, and emits op_and. + ! + implicit none + ! + integer, intent(in) :: tok_kind(:), tok_atom(:), tok_pos(:) + real, intent(in) :: tok_num(:) + integer, intent(in) :: n_tokens + integer, intent(inout) :: ip + integer, intent(inout) :: ops(:), atoms(:), cmps(:) + real, intent(inout) :: thresholds(:) + integer, intent(inout) :: nops + integer, intent(inout) :: ierr + character(len=*), intent(inout) :: errmsg + ! + integer, parameter :: tok_and = 5 + ! + call parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + do while (ip <= n_tokens) + ! + if (tok_kind(ip) /= tok_and) exit + ! + ip = ip + 1 + ! + call parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + if (nops >= expr_ops_max_per_rule) then + ! + ierr = 1 + errmsg = 'rule expression too long (op buffer full)' + return + ! + endif + ! + nops = nops + 1 + ops(nops) = op_and + atoms(nops) = 0 + cmps(nops) = 0 + thresholds(nops) = 0.0 + ! + enddo + ! + end subroutine + ! + ! + recursive subroutine parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + ! + ! Parse either a parenthesised expression or a leaf comparison + ! "atom <|> number". Emits op_cmp for the leaf case. + ! + implicit none + ! + integer, intent(in) :: tok_kind(:), tok_atom(:), tok_pos(:) + real, intent(in) :: tok_num(:) + integer, intent(in) :: n_tokens + integer, intent(inout) :: ip + integer, intent(inout) :: ops(:), atoms(:), cmps(:) + real, intent(inout) :: thresholds(:) + integer, intent(inout) :: nops + integer, intent(inout) :: ierr + character(len=*), intent(inout) :: errmsg + ! + integer, parameter :: tok_ident = 1 + integer, parameter :: tok_number = 2 + integer, parameter :: tok_lparen = 3 + integer, parameter :: tok_rparen = 4 + integer, parameter :: tok_lt = 7 + integer, parameter :: tok_gt = 8 + ! + integer :: atom_code, cmp_code + ! + if (ip > n_tokens) then + ! + ierr = 1 + errmsg = 'unexpected end of expression' + return + ! + endif + ! + if (tok_kind(ip) == tok_lparen) then + ! + ip = ip + 1 + ! + call parse_or_expr(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ip, & + ops, atoms, cmps, thresholds, nops, ierr, errmsg) + if (ierr /= 0) return + ! + if (ip > n_tokens) then + ! + ierr = 1 + errmsg = 'missing closing ")"' + return + ! + endif + ! + if (tok_kind(ip) /= tok_rparen) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'expected ")" at position ', tok_pos(ip) + return + ! + endif + ! + ip = ip + 1 + return + ! + endif + ! + ! Leaf: atom cmp_op number. + ! + if (tok_kind(ip) /= tok_ident) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'expected atom (z1/z2/z2-z1) at position ', tok_pos(ip) + return + ! + endif + ! + atom_code = tok_atom(ip) + ip = ip + 1 + ! + if (ip > n_tokens) then + ! + ierr = 1 + errmsg = 'expected comparator after atom' + return + ! + endif + ! + select case (tok_kind(ip)) + ! + case (tok_lt) + ! + cmp_code = cmp_lt + ! + case (tok_gt) + ! + cmp_code = cmp_gt + ! + case default + ! + ierr = 1 + write(errmsg,'(a,i0)') 'expected "<" or ">" at position ', tok_pos(ip) + return + ! + end select + ! + ip = ip + 1 + ! + if (ip > n_tokens) then + ! + ierr = 1 + errmsg = 'expected number after comparator' + return + ! + endif + ! + if (tok_kind(ip) /= tok_number) then + ! + ierr = 1 + write(errmsg,'(a,i0)') 'expected numeric threshold at position ', tok_pos(ip) + return + ! + endif + ! + if (nops >= expr_ops_max_per_rule) then + ! + ierr = 1 + errmsg = 'rule expression too long (op buffer full)' + return + ! + endif + ! + nops = nops + 1 + ops(nops) = op_cmp + atoms(nops) = atom_code + cmps(nops) = cmp_code + thresholds(nops) = tok_num(ip) + ! + ip = ip + 1 + ! + end subroutine + ! + ! + function to_lower_local(str) result(lower) + ! + ! Return a lowercase copy of str (ASCII only). Local to this module + ! so rule-parsing doesn't depend on sfincs_src_structures for a case + ! fold; the trivial duplication is worth the decoupling. + ! + implicit none + ! + character(len=*), intent(in) :: str + character(len=:), allocatable :: lower + ! + integer :: k, ic + ! + lower = str + ! + do k = 1, len(lower) + ! + ic = iachar(lower(k:k)) + ! + if (ic >= iachar('A') .and. ic <= iachar('Z')) then + ! + lower(k:k) = achar(ic + 32) + ! + endif + ! + enddo + ! + end function + ! +end module diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 430ff737b..f72e6852e 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -15,15 +15,16 @@ module sfincs_src_structures ! Runtime handoff to the continuity module is via the cell-wise qsrc(np) ! array (in sfincs_data): this module accumulates qq on intake (struc_nm_in) ! and outfall (struc_nm_out) cells. Per-structure signed discharge is also - ! stored in qstruc(nstruc) for his output. + ! stored in qstruc(nr_src_structures) for his output. ! ! Concurrency: qsrc updates use atomic because two structures (or a river ! source and a structure) can land in the same cell. ! use sfincs_log use sfincs_error + use sfincs_rule_expression, only: add_rule, evaluate_rule, finalize_rule_storage ! - private :: parse_action_kind, parse_rule_lhs, parse_comparator, parse_rule_rhs, parse_structure_type, to_lower, check_required + private :: parse_structure_type, to_lower, check_required private :: initialize_src_structures_legacy private :: allocate_struc_flat_arrays, finalize_src_structures_state private :: marshal_src_structures_to_flat_arrays @@ -42,54 +43,16 @@ module sfincs_src_structures integer, parameter :: structure_culvert = 3 integer, parameter :: structure_gate = 4 ! - ! Action kind codes - ! - integer, parameter :: ACTION_OPEN = 1 - integer, parameter :: ACTION_CLOSE = 2 - ! - ! Rule left-hand-side kind codes - ! - integer, parameter :: RULE_LHS_Z1 = 1 - integer, parameter :: RULE_LHS_Z2 = 2 - ! - ! Rule comparator codes - ! - integer, parameter :: CMP_LT = 1 - integer, parameter :: CMP_LE = 2 - integer, parameter :: CMP_GT = 3 - integer, parameter :: CMP_GE = 4 - integer, parameter :: CMP_EQ = 5 - integer, parameter :: CMP_NE = 6 - ! - ! Rule right-hand-side kind codes - ! - integer, parameter :: RULE_RHS_PAR1 = 1 - integer, parameter :: RULE_RHS_PAR2 = 2 - integer, parameter :: RULE_RHS_PAR3 = 3 - integer, parameter :: RULE_RHS_CONST = 4 - ! ! ------------------------------------------------------------------ - ! Derived types for the keyword-based src structure input. + ! Derived type for the TOML-based src structure input. ! - ! Scaffolding only - not yet wired into any reader or the runtime. + ! Gate open/close triggers are described by small boolean expressions + ! in strings (e.g. "(z1<0.5 | z2-z1>0.05) & z2<1.5"). Those strings + ! live here as raw characters on the derived type; the parser runs + ! during marshalling and emits bytecode into the shared rule_* + ! streams owned by the sfincs_rule_expression module. ! ------------------------------------------------------------------ ! - type :: t_src_action - ! - integer :: kind ! ACTION_OPEN / ACTION_CLOSE - real :: value ! payload (e.g. target state / timing), unused for now - ! - end type t_src_action - ! - type :: t_src_rule - ! - integer :: lhs_kind ! RULE_LHS_* - integer :: comparator ! CMP_* - integer :: rhs_kind ! RULE_RHS_* - real :: rhs_value ! only used when rhs_kind == RULE_RHS_CONST - ! - end type t_src_rule - ! type :: t_src_structure ! ! Identification (populated by the TOML reader). id is required, @@ -138,10 +101,11 @@ module sfincs_src_structures real :: par2 real :: par3 ! - ! Actions and rules + ! Gate control rule expressions (raw strings; parsed by marshal). + ! Either or both may be unallocated, meaning "no trigger for this action". ! - type(t_src_action), allocatable :: actions(:) - type(t_src_rule), allocatable :: rules(:) + character(len=:), allocatable :: rule_open + character(len=:), allocatable :: rule_close ! end type t_src_structure ! @@ -154,7 +118,7 @@ module sfincs_src_structures ! directly (struc_type, struc_q, struc_par1, etc.). ! ------------------------------------------------------------------ ! - type(t_src_structure), allocatable :: src_structures(:) + type(t_src_structure), allocatable :: src_structures(:) ! intermediate derived-type array; flattened + deallocated by marshal_src_structures_to_flat_arrays on the toml path (gpu deep-copy avoidance). ! ! ------------------------------------------------------------------ ! Module-level runtime state for src structures (moved from sfincs_data). @@ -179,9 +143,9 @@ module sfincs_src_structures ! ! Cell mapping ! - integer, public :: nstruc - integer*4, dimension(:), allocatable, public :: struc_nm_in ! (nstruc) intake (sink) cell indices - integer*4, dimension(:), allocatable, public :: struc_nm_out ! (nstruc) outfall (source) cell indices + integer, public :: nr_src_structures + integer*4, dimension(:), allocatable, public :: struc_nm_in ! (nr_src_structures) intake (sink) cell indices + integer*4, dimension(:), allocatable, public :: struc_nm_out ! (nr_src_structures) outfall (source) cell indices ! ! Coordinates ! @@ -207,9 +171,16 @@ module sfincs_src_structures ! ! Runtime state ! - real*4, dimension(:), allocatable, public :: qstruc ! (nstruc) signed discharge per structure, mirrors the qsrc pattern + real*4, dimension(:), allocatable, public :: qstruc ! (nr_src_structures) signed discharge per structure, mirrors the qsrc pattern + ! + ! ------------------------------------------------------------------ + ! Per-structure rule ids into the registry owned by sfincs_rule_expression. + ! A rule_id of 0 means "no rule; never fires". + ! ------------------------------------------------------------------ + ! + integer, dimension(:), allocatable, public :: struc_rule_open ! (nr_src_structures) rule_id for open action, 0 = no rule + integer, dimension(:), allocatable, public :: struc_rule_close ! (nr_src_structures) rule_id for close action, 0 = no rule ! - contains ! subroutine initialize_src_structures() @@ -292,7 +263,7 @@ subroutine initialize_src_structures_legacy() ! ! Parse drnfile in the fixed-column legacy format and populate the ! struc_* flat arrays, plus struc_nm_in/out and the - ! output buffer qstruc(nstruc). Post-processing (cell-index lookup, + ! output buffer qstruc(nr_src_structures). Post-processing (cell-index lookup, ! distance, default status / fraction_open) is deferred to ! finalize_src_structures_state(), which is shared with the TOML path. ! @@ -305,7 +276,7 @@ subroutine initialize_src_structures_legacy() logical :: ok character(len=256) :: drainage_line ! - nstruc = 0 + nr_src_structures = 0 ! if (drnfile(1:4) == 'none') return ! @@ -319,25 +290,25 @@ subroutine initialize_src_structures_legacy() ! read(501, *, iostat=stat) dummy if (stat < 0) exit - nstruc = nstruc + 1 + nr_src_structures = nr_src_structures + 1 ! enddo ! rewind(501) ! - if (nstruc <= 0) then + if (nr_src_structures <= 0) then ! close(501) return ! endif ! - write(logstr,'(a,a,a,i0,a)')' Reading ', trim(drnfile), ' (', nstruc, ' drainage points found) ...' + write(logstr,'(a,a,a,i0,a)')' Reading ', trim(drnfile), ' (', nr_src_structures, ' drainage points found) ...' call write_log(logstr, 0) ! - call allocate_struc_flat_arrays(nstruc) + call allocate_struc_flat_arrays(nr_src_structures) ! - do istruc = 1, nstruc + do istruc = 1, nr_src_structures ! read(501, '(a)') drainage_line ! @@ -424,6 +395,12 @@ subroutine initialize_src_structures_legacy() ! close(501) ! + ! Ensure the shared rule-expression stream is allocated (to size 0 + ! if no rules were ever parsed) so downstream openacc directives can + ! reference rule_* safely. + ! + call finalize_rule_storage() + ! ! Cell-index lookup, centre-to-centre distance, mismatch warning. ! call finalize_src_structures_state() @@ -473,6 +450,8 @@ subroutine allocate_struc_flat_arrays(n) if (allocated(struc_zmin)) deallocate(struc_zmin) if (allocated(struc_zmax)) deallocate(struc_zmax) if (allocated(struc_t_close)) deallocate(struc_t_close) + if (allocated(struc_rule_open)) deallocate(struc_rule_open) + if (allocated(struc_rule_close)) deallocate(struc_rule_close) ! allocate(struc_nm_in(n)) allocate(struc_nm_out(n)) @@ -504,6 +483,11 @@ subroutine allocate_struc_flat_arrays(n) allocate(struc_zmin(n)) allocate(struc_zmax(n)) allocate(struc_t_close(n)) + allocate(struc_rule_open(n)) + allocate(struc_rule_close(n)) + ! + struc_rule_open = 0 + struc_rule_close = 0 ! struc_nm_in = 0 struc_nm_out = 0 @@ -553,7 +537,7 @@ subroutine finalize_src_structures_state() integer :: istruc, nmq real*4 :: xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp ! - do istruc = 1, nstruc + do istruc = 1, nr_src_structures ! nmq = find_quadtree_cell(struc_src_1_x(istruc), struc_src_1_y(istruc)) if (nmq > 0) struc_nm_in(istruc) = index_sfincs_in_quadtree(nmq) @@ -585,6 +569,34 @@ subroutine finalize_src_structures_state() end subroutine ! ! + ! ------------------------------------------------------------------ + ! why does this marshal exist? + ! + ! the runtime reads all src-structure state from flat per-struct + ! arrays (the struc_* family: struc_type, struc_q, struc_par1, ...). + ! the toml reader, however, naturally produces a derived-type array + ! src_structures(:) of t_src_structure, which carries allocatable + ! components: character(len=:), allocatable :: id, name, plus the + ! nested actions(:) and rules(:) arrays. + ! + ! nvfortran's openacc implicit deep-copy of derived types that + ! contain allocatable components has been unreliable in practice: + ! pushing a type(...), allocatable :: arr(:) with nested allocatables + ! to the device tends to produce runtime issues. flat arrays of + ! primitive types (real, integer, fixed-length character) copy + ! cleanly across !$acc enter data copyin(...), so we keep the live + ! runtime state in those. + ! + ! this routine is the one-shot bridge: toml -> src_structures(:) + ! -> struc_* flat arrays -> deallocate(src_structures). after it + ! runs, nothing of the derived-type array survives, so no gpu + ! region ever sees a problematic allocatable-in-derived-type. + ! + ! the legacy fixed-column reader populates the same struc_* flat + ! arrays directly and therefore does not need this marshal; the + ! two input paths converge here. + ! ------------------------------------------------------------------ + ! subroutine marshal_src_structures_to_flat_arrays() ! ! Copy the module-level src_structures(:) array (populated by @@ -595,26 +607,29 @@ subroutine marshal_src_structures_to_flat_arrays() ! should not yet be allocated when this is called; allocate_struc_flat_arrays ! defensively deallocates any residual allocation first. ! - ! Note: %actions and %rules are dropped at this point. They are not - ! consumed by any downstream runtime code yet. Follow-up work: add flat - ! arrays for action / rule counts and element data, and copy those in - ! this helper before the deallocation. + ! Rule expressions (rule_open / rule_close) are handed to + ! sfincs_rule_expression's add_rule, which appends bytecode to its + ! shared stream, registers a new rule, and returns an integer rule_id + ! per structure. finalize_rule_storage is called at the end to shrink + ! the stream and registry to fit (and to allocate zero-length arrays + ! when no rules were seen). ! use sfincs_data ! implicit none ! - integer :: i, n + integer :: i, n, ierr_parse + character(len=256) :: errmsg ! if (.not. allocated(src_structures)) then ! - nstruc = 0 + nr_src_structures = 0 return ! endif ! n = size(src_structures) - nstruc = n + nr_src_structures = n ! if (n <= 0) then ! @@ -625,6 +640,9 @@ subroutine marshal_src_structures_to_flat_arrays() ! call allocate_struc_flat_arrays(n) ! + ! Copy scalar / vector per-structure fields and parse rule + ! expressions into the shared rule_* stream via add_rule. + ! do i = 1, n ! ! String fields: truncation warning if longer than struc_id_len. @@ -683,8 +701,47 @@ subroutine marshal_src_structures_to_flat_arrays() struc_zmax(i) = src_structures(i)%zmax struc_t_close(i) = src_structures(i)%t_close ! + ! Parse rule expressions. Missing / empty strings leave the + ! rule_id at 0, which the evaluator interprets as "never fires". + ! + if (allocated(src_structures(i)%rule_open)) then + ! + call add_rule(src_structures(i)%rule_open, & + struc_rule_open(i), ierr_parse, errmsg) + ! + if (ierr_parse /= 0) then + ! + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(struc_id(i)), & + '" rules.open parse failed: ', trim(errmsg) + call write_log(logstr, 1) + call stop_sfincs(logstr, -1) + ! + endif + ! + endif + ! + if (allocated(src_structures(i)%rule_close)) then + ! + call add_rule(src_structures(i)%rule_close, & + struc_rule_close(i), ierr_parse, errmsg) + ! + if (ierr_parse /= 0) then + ! + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(struc_id(i)), & + '" rules.close parse failed: ', trim(errmsg) + call write_log(logstr, 1) + call stop_sfincs(logstr, -1) + ! + endif + ! + endif + ! enddo ! + ! Shrink the shared rule stream to exactly the concatenated length. + ! + call finalize_rule_storage() + ! ! Shared post-processing. ! call finalize_src_structures_state() @@ -700,7 +757,7 @@ subroutine update_src_structures(t, dt, tloop) ! ! Compute discharges through each drainage structure, accumulate them ! into qsrc(np) (intake: -qq, outfall: +qq), and store per-structure - ! signed discharge in qstruc(nstruc) for his output. + ! signed discharge in qstruc(nr_src_structures) for his output. ! ! Called AFTER update_discharges, which zeros qsrc first. ! @@ -720,7 +777,7 @@ subroutine update_src_structures(t, dt, tloop) real*4 :: qq, qq0 real*4 :: dzds, frac, wdt, zsill, zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ! - if (nstruc <= 0) return + if (nr_src_structures <= 0) return ! call system_clock(count0, count_rate, count_max) ! @@ -738,7 +795,7 @@ subroutine update_src_structures(t, dt, tloop) !$omp private( nmin, nmout, qq, qq0, dzds, frac, wdt, zsill, & !$omp zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ) & !$omp schedule ( static ) - do istruc = 1, nstruc + do istruc = 1, nr_src_structures ! nmin = struc_nm_in(istruc) nmout = struc_nm_out(istruc) @@ -974,8 +1031,8 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! width = ... ; sill_elevation = ... ; mannings_n = ... ! zmin = ... ; zmax = ... ; t_close = ... ! cd = ... ; par1 = ... ; par2 = ... ; par3 = ... - ! actions = [ { kind = "open", value = 10.0 }, ... ] - ! rules = [ { lhs = "z1", comparator = ">", rhs = "par1" }, ... ] + ! rules.open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr + ! rules.close = "z2>2.0" ! optional trigger expr ! ! Per-type required keys (enforced on parse): ! pump : x, y, q @@ -1001,11 +1058,10 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! type(toml_table), allocatable :: top type(toml_error), allocatable :: err - type(toml_array), pointer :: arr_structs, arr_actions, arr_rules - type(toml_table), pointer :: tbl_struct, tbl_entry - character(len=:), allocatable :: id_str, name_str, type_str, kind_str, lhs_str, cmp_str, rhs_str - integer :: n_struct, n_act, n_rule, i, j, stat - real :: rval + type(toml_array), pointer :: arr_structs + type(toml_table), pointer :: tbl_struct, tbl_rules + character(len=:), allocatable :: id_str, name_str, type_str, rule_str + integer :: n_struct, i, stat ! ierr = 0 ! @@ -1194,164 +1250,22 @@ subroutine read_toml_src_structures(filename, structures, ierr) call get_value(tbl_struct, 'par2', structures(i)%par2, 0.0, stat=stat) call get_value(tbl_struct, 'par3', structures(i)%par3, 0.0, stat=stat) ! - ! Optional actions array + ! Optional rules sub-table with string "open" / "close" expressions. + ! Absent sub-table, or absent keys within it, leaves the rule strings + ! unallocated on the derived type; marshal treats that as "no trigger". ! - nullify(arr_actions) - call get_value(tbl_struct, 'actions', arr_actions, requested=.false., stat=stat) + nullify(tbl_rules) + call get_value(tbl_struct, 'rules', tbl_rules, requested=.false., stat=stat) ! - if (associated(arr_actions)) then + if (associated(tbl_rules)) then ! - n_act = len(arr_actions) - allocate(structures(i)%actions(n_act)) + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_rules, 'open', rule_str, stat=stat) + if (allocated(rule_str)) structures(i)%rule_open = rule_str ! - do j = 1, n_act - ! - nullify(tbl_entry) - call get_value(arr_actions, j, tbl_entry, stat=stat) - ! - if (.not. associated(tbl_entry)) then - ! - write(logstr,'(a,i0,a,i0,a)')' Error ! actions entry ', j, & - ' of src_structure ', i, ' is not a table' - call write_log(logstr, 1) - call cleanup_on_error() - return - ! - endif - ! - if (allocated(kind_str)) deallocate(kind_str) - call get_value(tbl_entry, 'kind', kind_str, stat=stat) - ! - if (.not. allocated(kind_str)) then - ! - write(logstr,'(a,i0,a,i0)')' Error ! Missing "kind" in actions entry ', j, & - ' of src_structure ', i - call write_log(logstr, 1) - call cleanup_on_error() - return - ! - endif - ! - call parse_action_kind(kind_str, structures(i)%actions(j)%kind, ierr) - ! - if (ierr /= 0) then - ! - write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown action kind "', trim(kind_str), & - '" in actions entry ', j, ' of src_structure ', i - call write_log(logstr, 1) - call cleanup_on_error() - return - ! - endif - ! - rval = 0.0 - call get_value(tbl_entry, 'value', rval, stat=stat) - structures(i)%actions(j)%value = rval - ! - enddo - ! - else - ! - allocate(structures(i)%actions(0)) - ! - endif - ! - ! Optional rules array - ! - nullify(arr_rules) - call get_value(tbl_struct, 'rules', arr_rules, requested=.false., stat=stat) - ! - if (associated(arr_rules)) then - ! - n_rule = len(arr_rules) - allocate(structures(i)%rules(n_rule)) - ! - do j = 1, n_rule - ! - nullify(tbl_entry) - call get_value(arr_rules, j, tbl_entry, stat=stat) - ! - if (.not. associated(tbl_entry)) then - ! - write(logstr,'(a,i0,a,i0,a)')' Error ! rules entry ', j, & - ' of src_structure ', i, ' is not a table' - call write_log(logstr, 1) - call cleanup_on_error() - return - ! - endif - ! - if (allocated(lhs_str)) deallocate(lhs_str) - if (allocated(cmp_str)) deallocate(cmp_str) - if (allocated(rhs_str)) deallocate(rhs_str) - ! - call get_value(tbl_entry, 'lhs', lhs_str, stat=stat) - call get_value(tbl_entry, 'comparator', cmp_str, stat=stat) - call get_value(tbl_entry, 'rhs', rhs_str, stat=stat) - ! - if (.not. allocated(lhs_str) .or. .not. allocated(cmp_str) .or. & - .not. allocated(rhs_str)) then - ! - write(logstr,'(a,i0,a,i0)')' Error ! rules entry ', j, & - ' needs lhs/comparator/rhs keys in src_structure ', i - call write_log(logstr, 1) - ierr = 1 - call cleanup_on_error() - return - ! - endif - ! - call parse_rule_lhs(lhs_str, structures(i)%rules(j)%lhs_kind, ierr) - ! - if (ierr /= 0) then - ! - write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown rule lhs "', trim(lhs_str), & - '" in rules entry ', j, ' of src_structure ', i - call write_log(logstr, 1) - call cleanup_on_error() - return - ! - endif - ! - call parse_comparator(cmp_str, structures(i)%rules(j)%comparator, ierr) - ! - if (ierr /= 0) then - ! - write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown comparator "', trim(cmp_str), & - '" in rules entry ', j, ' of src_structure ', i - call write_log(logstr, 1) - call cleanup_on_error() - return - ! - endif - ! - call parse_rule_rhs(rhs_str, structures(i)%rules(j)%rhs_kind, ierr) - ! - if (ierr /= 0) then - ! - write(logstr,'(a,a,a,i0,a,i0)')' Error ! Unknown rule rhs "', trim(rhs_str), & - '" in rules entry ', j, ' of src_structure ', i - call write_log(logstr, 1) - call cleanup_on_error() - return - ! - endif - ! - rval = 0.0 - ! - if (structures(i)%rules(j)%rhs_kind == RULE_RHS_CONST) then - ! - call get_value(tbl_entry, 'rhs_value', rval, stat=stat) - ! - endif - ! - structures(i)%rules(j)%rhs_value = rval - ! - enddo - ! - else - ! - allocate(structures(i)%rules(0)) + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_rules, 'close', rule_str, stat=stat) + if (allocated(rule_str)) structures(i)%rule_close = rule_str ! endif ! @@ -1402,41 +1316,6 @@ subroutine check_required(table, keys, id_str, ierr) end subroutine ! ! - subroutine parse_action_kind(str, code, ierr) - ! - ! Translate a TOML action "kind" string to one of the ACTION_* codes. - ! - implicit none - ! - character(len=*), intent(in) :: str - integer, intent(out) :: code - integer, intent(out) :: ierr - ! - character(len=:), allocatable :: s - ! - ierr = 0 - code = 0 - s = to_lower(str) - ! - select case (s) - ! - case ('open') - ! - code = ACTION_OPEN - ! - case ('close') - ! - code = ACTION_CLOSE - ! - case default - ! - ierr = 1 - ! - end select - ! - end subroutine - ! - ! subroutine parse_structure_type(str, code, ierr) ! ! Translate a TOML "type" string to one of the structure_* codes. @@ -1480,132 +1359,6 @@ subroutine parse_structure_type(str, code, ierr) end subroutine ! ! - subroutine parse_rule_lhs(str, code, ierr) - ! - ! Translate a TOML rule "lhs" string to one of the RULE_LHS_* codes. - ! - implicit none - ! - character(len=*), intent(in) :: str - integer, intent(out) :: code - integer, intent(out) :: ierr - ! - character(len=:), allocatable :: s - ! - ierr = 0 - code = 0 - s = to_lower(str) - ! - select case (s) - ! - case ('z1') - ! - code = RULE_LHS_Z1 - ! - case ('z2') - ! - code = RULE_LHS_Z2 - ! - case default - ! - ierr = 1 - ! - end select - ! - end subroutine - ! - ! - subroutine parse_comparator(str, code, ierr) - ! - ! Translate a TOML "comparator" string to one of the CMP_* codes. - ! - implicit none - ! - character(len=*), intent(in) :: str - integer, intent(out) :: code - integer, intent(out) :: ierr - ! - ierr = 0 - code = 0 - ! - select case (trim(str)) - ! - case ('<') - ! - code = CMP_LT - ! - case ('<=') - ! - code = CMP_LE - ! - case ('>') - ! - code = CMP_GT - ! - case ('>=') - ! - code = CMP_GE - ! - case ('==') - ! - code = CMP_EQ - ! - case ('!=') - ! - code = CMP_NE - ! - case default - ! - ierr = 1 - ! - end select - ! - end subroutine - ! - ! - subroutine parse_rule_rhs(str, code, ierr) - ! - ! Translate a TOML rule "rhs" string to one of the RULE_RHS_* codes. - ! - implicit none - ! - character(len=*), intent(in) :: str - integer, intent(out) :: code - integer, intent(out) :: ierr - ! - character(len=:), allocatable :: s - ! - ierr = 0 - code = 0 - s = to_lower(str) - ! - select case (s) - ! - case ('par1') - ! - code = RULE_RHS_PAR1 - ! - case ('par2') - ! - code = RULE_RHS_PAR2 - ! - case ('par3') - ! - code = RULE_RHS_PAR3 - ! - case ('const') - ! - code = RULE_RHS_CONST - ! - case default - ! - ierr = 1 - ! - end select - ! - end subroutine - ! - ! function to_lower(str) result(lower) ! ! Return a lowercase copy of str (ASCII only). From 0413dbbd5ca241bcb364b8d32619f63dc6a8d8e1 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sat, 18 Apr 2026 11:41:42 +0200 Subject: [PATCH 25/65] Support TOML structures, gate state & legacy conversion Refactor src-structure handling to unify TOML and legacy drn paths and add dynamic gate state features. Introduces marshal_src_structures_to_flat_arrays, convert_legacy_to_toml, initialize_gate_status and write_src_structures_log_summary; the legacy fixed-column file is transcribed to a TOML sibling and then parsed to keep a single parser. Adds new flat arrays and fields: struc_nm_obs_1/2, struc_t_state, struc_qmax, struc_flow_coef, struc_opening_duration, struc_closing_duration, and struc_rule_open_src/struc_rule_close_src; removes the old id field and consolidates name handling. Gate handling was reworked into a state machine (closed/open/opening/closing) driven by rules evaluated against obs cells, with timed transitions using opening/closing durations and initialisation of gate status from zs. Culvert/check-valve/pump logic now uses flow_coef and qmax clamps; a number of OpenACC/OpenMP directives and private lists updated to include the new arrays. Misc: initialization/allocation/deallocation updated, truncation warnings renamed for name length, and various comments/documentation adjusted. --- source/src/sfincs_openacc.f90 | 14 +- source/src/sfincs_src_structures.f90 | 1407 ++++++++++++++++---------- 2 files changed, 907 insertions(+), 514 deletions(-) diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 31146dd1c..903242956 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -25,10 +25,11 @@ subroutine initialize_openacc() !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & !$acc qsrc, qtsrc, qstruc, nmindsrc, struc_nm_in, struc_nm_out, struc_type, & - !$acc struc_q, struc_par1, struc_par2, struc_par3, struc_cd, & + !$acc struc_nm_obs_1, struc_nm_obs_2, & + !$acc struc_q, struc_qmax, struc_flow_coef, & !$acc struc_width, struc_sill_elevation, struc_mannings_n, & - !$acc struc_zmin, struc_zmax, struc_t_close, & - !$acc struc_distance, struc_status, struc_fraction_open, & + !$acc struc_opening_duration, struc_closing_duration, & + !$acc struc_distance, struc_status, struc_fraction_open, struc_t_state, & !$acc struc_rule_open, struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & @@ -61,10 +62,11 @@ subroutine finalize_openacc() !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & !$acc qsrc, qtsrc, qstruc, nmindsrc, struc_nm_in, struc_nm_out, struc_type, & - !$acc struc_q, struc_par1, struc_par2, struc_par3, struc_cd, & + !$acc struc_nm_obs_1, struc_nm_obs_2, & + !$acc struc_q, struc_qmax, struc_flow_coef, & !$acc struc_width, struc_sill_elevation, struc_mannings_n, & - !$acc struc_zmin, struc_zmax, struc_t_close, & - !$acc struc_distance, struc_status, struc_fraction_open, & + !$acc struc_opening_duration, struc_closing_duration, & + !$acc struc_distance, struc_status, struc_fraction_open, struc_t_state, & !$acc struc_rule_open, struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index f72e6852e..715db6f05 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -3,7 +3,7 @@ module sfincs_src_structures ! Point structures that move water between two grid cells by user-specified ! rules rather than by momentum conservation: ! type 1 - pump (fixed discharge) - ! type 2 - culvert (bidirectional, weir-like) + ! type 2 - culvert (bidirectional) ! type 3 - check valve (unidirectional culvert) ! type 4 - controlled gate, water-level triggered ! type 5 - controlled gate, schedule triggered @@ -25,9 +25,10 @@ module sfincs_src_structures use sfincs_rule_expression, only: add_rule, evaluate_rule, finalize_rule_storage ! private :: parse_structure_type, to_lower, check_required - private :: initialize_src_structures_legacy + private :: convert_legacy_to_toml private :: allocate_struc_flat_arrays, finalize_src_structures_state private :: marshal_src_structures_to_flat_arrays + private :: initialize_gate_status, write_src_structures_log_summary ! ! ------------------------------------------------------------------ ! Named constants for the keyword-based src structure input. @@ -55,51 +56,46 @@ module sfincs_src_structures ! type :: t_src_structure ! - ! Identification (populated by the TOML reader). id is required, - ! name is a human-friendly label and optional. + ! Identification (populated by the TOML reader). name is the sole + ! identifier and is required for every structure type. ! - character(len=:), allocatable :: id character(len=:), allocatable :: name ! ! Structure kind (one of the structure_* codes) ! integer :: structure_type ! - ! Geometry - single representative point (x, y), and two paired - ! coords: src_1/src_2 (the old source/sink pair) and obs_1/obs_2. + ! Geometry - src_1/src_2 define the intake/outfall cell pair; + ! obs_1/obs_2 are optional and default to src_1/src_2 in the + ! marshal when the TOML reader did not see the keys (tracked via + ! has_obs_1 / has_obs_2). ! - real :: x, y real :: src_1_x, src_1_y real :: src_2_x, src_2_y real :: obs_1_x, obs_1_y real :: obs_2_x, obs_2_y - ! - ! State - ! - integer :: status ! 0/1/2/3 - meaning reserved for later + logical :: has_obs_1 + logical :: has_obs_2 ! ! Parameters ! - ! q - pump discharge - ! width - gate width - ! sill_elevation - gate sill elevation - ! mannings_n - gate Manning's n - ! zmin - gate min water level for open - ! zmax - gate max water level for open - ! t_close - gate closing time (seconds) - ! cd, par1, par2, par3 - generic parameters (use depends on type) + ! q - pump discharge + ! qmax - maximum discharge magnitude (safety clamp) + ! width - gate width + ! sill_elevation - gate sill elevation + ! mannings_n - gate Manning's n + ! opening_duration - time (s) to go from closed to fully open + ! closing_duration - time (s) to go from open to fully closed + ! flow_coef - culvert / check_valve flow coefficient ! real :: q + real :: qmax real :: width real :: sill_elevation real :: mannings_n - real :: zmin - real :: zmax - real :: t_close - real :: cd - real :: par1 - real :: par2 - real :: par3 + real :: opening_duration + real :: closing_duration + real :: flow_coef ! ! Gate control rule expressions (raw strings; parsed by marshal). ! Either or both may be unallocated, meaning "no trigger for this action". @@ -115,7 +111,7 @@ module sfincs_src_structures ! Populated by the dispatcher when the drn file parses as TOML. ! Not yet consumed by any downstream runtime code - wiring is a later ! step. The legacy path continues to populate the flat arrays below - ! directly (struc_type, struc_q, struc_par1, etc.). + ! directly (struc_type, struc_q, struc_flow_coef, etc.). ! ------------------------------------------------------------------ ! type(t_src_structure), allocatable :: src_structures(:) ! intermediate derived-type array; flattened + deallocated by marshal_src_structures_to_flat_arrays on the toml path (gpu deep-copy avoidance). @@ -128,11 +124,10 @@ module sfincs_src_structures ! sfincs_lib) can reference them. ! ------------------------------------------------------------------ ! - ! Meta / id + ! Meta / name ! - integer, parameter :: struc_id_len = 128 ! max length of struct id / name strings - character(len=struc_id_len), dimension(:), allocatable, public :: struc_id - character(len=struc_id_len), dimension(:), allocatable, public :: struc_name + integer, parameter :: struc_name_len = 128 ! max length of struct name strings + character(len=struc_name_len), dimension(:), allocatable, public :: struc_name ! ! Kind / state ! @@ -144,12 +139,18 @@ module sfincs_src_structures ! Cell mapping ! integer, public :: nr_src_structures - integer*4, dimension(:), allocatable, public :: struc_nm_in ! (nr_src_structures) intake (sink) cell indices - integer*4, dimension(:), allocatable, public :: struc_nm_out ! (nr_src_structures) outfall (source) cell indices + integer*4, dimension(:), allocatable, public :: struc_nm_in ! (nr_src_structures) intake (sink) cell indices + integer*4, dimension(:), allocatable, public :: struc_nm_out ! (nr_src_structures) outfall (source) cell indices + integer*4, dimension(:), allocatable, public :: struc_nm_obs_1 ! (nr_src_structures) obs_1 cell indices (gate rule inputs; defaults to src_1 cell) + integer*4, dimension(:), allocatable, public :: struc_nm_obs_2 ! (nr_src_structures) obs_2 cell indices (gate rule inputs; defaults to src_2 cell) + ! + ! Gate transition timer (simulation time at which current status was entered). + ! Only meaningful for structure_gate; ignored for other types. + ! + real*4, dimension(:), allocatable, public :: struc_t_state ! ! Coordinates ! - real*4, dimension(:), allocatable, public :: struc_x, struc_y real*4, dimension(:), allocatable, public :: struc_src_1_x, struc_src_1_y real*4, dimension(:), allocatable, public :: struc_src_2_x, struc_src_2_y real*4, dimension(:), allocatable, public :: struc_obs_1_x, struc_obs_1_y @@ -158,16 +159,13 @@ module sfincs_src_structures ! Named parameters ! real*4, dimension(:), allocatable, public :: struc_q ! pump discharge - real*4, dimension(:), allocatable, public :: struc_cd ! generic discharge coefficient - real*4, dimension(:), allocatable, public :: struc_par1 ! generic par1 (e.g. culvert / check_valve flow coef, or schedule-gate tclose) - real*4, dimension(:), allocatable, public :: struc_par2 ! generic par2 (e.g. schedule-gate topen) - real*4, dimension(:), allocatable, public :: struc_par3 ! generic par3 + real*4, dimension(:), allocatable, public :: struc_qmax ! max discharge magnitude (safety clamp) + real*4, dimension(:), allocatable, public :: struc_flow_coef ! culvert / check_valve flow coefficient real*4, dimension(:), allocatable, public :: struc_width ! gate width real*4, dimension(:), allocatable, public :: struc_sill_elevation ! gate sill elevation real*4, dimension(:), allocatable, public :: struc_mannings_n ! gate Manning's n - real*4, dimension(:), allocatable, public :: struc_zmin ! gate min water level for open - real*4, dimension(:), allocatable, public :: struc_zmax ! gate max water level for open - real*4, dimension(:), allocatable, public :: struc_t_close ! gate closing time (s) + real*4, dimension(:), allocatable, public :: struc_opening_duration ! gate opening duration (s) + real*4, dimension(:), allocatable, public :: struc_closing_duration ! gate closing duration (s) ! ! Runtime state ! @@ -176,11 +174,18 @@ module sfincs_src_structures ! ------------------------------------------------------------------ ! Per-structure rule ids into the registry owned by sfincs_rule_expression. ! A rule_id of 0 means "no rule; never fires". + ! + ! struc_rule_open_src / struc_rule_close_src hold the raw source strings + ! (for log emission only); these do not need to travel to GPU. ! ------------------------------------------------------------------ ! integer, dimension(:), allocatable, public :: struc_rule_open ! (nr_src_structures) rule_id for open action, 0 = no rule integer, dimension(:), allocatable, public :: struc_rule_close ! (nr_src_structures) rule_id for close action, 0 = no rule ! + integer, parameter :: struc_rule_src_len = 256 + character(len=struc_rule_src_len), dimension(:), allocatable, public :: struc_rule_open_src + character(len=struc_rule_src_len), dimension(:), allocatable, public :: struc_rule_close_src + ! contains ! subroutine initialize_src_structures() @@ -189,13 +194,13 @@ subroutine initialize_src_structures() ! ! Probes the file with toml-f. If it parses as TOML, the TOML reader ! populates the module-level src_structures(:) array. If toml-f rejects - ! it, falls back to the legacy fixed-column reader, which populates the - ! struc_* arrays in sfincs_src_structures. + ! it, the file is assumed to be in the legacy fixed-column format and + ! is transcribed on-the-fly into a TOML sibling file, which is then + ! read via the same TOML path. This keeps only one parser alive in the + ! source tree. ! ! If a file parses as TOML but fails semantic validation (e.g. a - ! missing required field), that is treated as a hard error: we do NOT - ! fall back to the legacy reader, because the file was already - ! unambiguously TOML. + ! missing required field), that is treated as a hard error. ! use sfincs_data use tomlf, only : toml_table, toml_error, toml_load @@ -204,8 +209,10 @@ subroutine initialize_src_structures() ! type(toml_table), allocatable :: probe_top type(toml_error), allocatable :: probe_err - integer :: ierr_toml - logical :: ok + integer :: ierr_toml, ierr_conv + logical :: ok, is_toml + character(len=512) :: toml_path + integer :: n, p ! if (drnfile(1:4) == 'none') return ! @@ -217,193 +224,84 @@ subroutine initialize_src_structures() ! call toml_load(probe_top, drnfile, error=probe_err) ! - if (.not. allocated(probe_err)) then - ! - ! TOML path - ! - if (allocated(probe_top)) deallocate(probe_top) - ! - call read_toml_src_structures(drnfile, src_structures, ierr_toml) - ! - if (ierr_toml /= 0) then - ! - ! File was valid TOML but failed semantic validation; do NOT - ! fall back to legacy. - ! - write(logstr,'(a,a,a)')' Error ! Failed to load TOML src_structures file ', trim(drnfile), ' !' - call stop_sfincs(logstr, -1) - ! - endif - ! - ! Flatten the parsed derived-type array into the module-level - ! struc_* 1D arrays, then deallocate src_structures(:). Both paths - ! leave runtime state in the same shape. - ! - call marshal_src_structures_to_flat_arrays() - ! - return - ! - else - ! - ! Legacy path - ! - deallocate(probe_err) - if (allocated(probe_top)) deallocate(probe_top) - ! - call initialize_src_structures_legacy() - ! - return - ! - endif - ! - end subroutine - ! - ! - subroutine initialize_src_structures_legacy() - ! - ! Parse drnfile in the fixed-column legacy format and populate the - ! struc_* flat arrays, plus struc_nm_in/out and the - ! output buffer qstruc(nr_src_structures). Post-processing (cell-index lookup, - ! distance, default status / fraction_open) is deferred to - ! finalize_src_structures_state(), which is shared with the TOML path. - ! - use sfincs_data - ! - implicit none - ! - real*4 :: dummy, xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp - integer :: istruc, stat, npars, dtype - logical :: ok - character(len=256) :: drainage_line - ! - nr_src_structures = 0 - ! - if (drnfile(1:4) == 'none') return - ! - ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) - ! - ! Count lines - ! - open(501, file=trim(drnfile)) - ! - do while (.true.) - ! - read(501, *, iostat=stat) dummy - if (stat < 0) exit - nr_src_structures = nr_src_structures + 1 - ! - enddo - ! - rewind(501) - ! - if (nr_src_structures <= 0) then - ! - close(501) - return - ! - endif - ! - write(logstr,'(a,a,a,i0,a)')' Reading ', trim(drnfile), ' (', nr_src_structures, ' drainage points found) ...' - call write_log(logstr, 0) + is_toml = .not. allocated(probe_err) ! - call allocate_struc_flat_arrays(nr_src_structures) + if (allocated(probe_err)) deallocate(probe_err) + if (allocated(probe_top)) deallocate(probe_top) ! - do istruc = 1, nr_src_structures + if (is_toml) then ! - read(501, '(a)') drainage_line + ! TOML path: read drnfile directly. ! - ! Determine drainage type first (5th integer in the line) + toml_path = drnfile ! - read(drainage_line, *, iostat=stat) xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp, struc_type(istruc) + else ! - dtype = struc_type(istruc) - npars = 0 + ! Legacy path: transcribe to a TOML sibling file, then fall through + ! to the TOML reader. Derived path: if drnfile ends in ".drn" + ! (case-insensitive), insert ".toml" before the extension; else + ! append ".toml". ! - if (dtype == 1 .or. dtype == 2 .or. dtype == 3) then - ! - npars = 1 ! pump, culvert, or check valve - ! - elseif (dtype == 4 .or. dtype == 5) then - ! - npars = 6 ! controlled gate (width, sill, manning, zmin/tclose, zmax/topen, closing time) - ! - endif + n = len_trim(drnfile) + p = 0 ! - if (npars == 0) then - ! - write(logstr,'(a,i0,a)') 'Drainage type ', dtype, ' not recognized !' - call stop_sfincs(logstr, -1) + if (n >= 4) then ! - endif - ! - if (npars == 1) then - ! - ! pump -> col 1 = q - ! culvert -> col 1 = par1 (flow coefficient) - ! check_valve -> col 1 = par1 (flow coefficient) - ! - if (dtype == 1) then - ! - read(drainage_line, *, iostat=stat) struc_src_1_x(istruc), struc_src_1_y(istruc), & - struc_src_2_x(istruc), struc_src_2_y(istruc), & - struc_type(istruc), struc_q(istruc) - ! - else + if (to_lower(drnfile(n-3:n)) == '.drn') then ! - read(drainage_line, *, iostat=stat) struc_src_1_x(istruc), struc_src_1_y(istruc), & - struc_src_2_x(istruc), struc_src_2_y(istruc), & - struc_type(istruc), struc_par1(istruc) + p = n - 3 ! endif ! - elseif (npars == 6) then + endif + ! + if (p > 0) then ! - ! gate water-level triggered (type 4) - ! cols 1..6 = width, sill_elevation, mannings_n, zmin, zmax, t_close - ! gate schedule triggered (type 5) - ! cols 1..6 = width, sill_elevation, mannings_n, par1 (tclose), - ! par2 (topen), t_close + toml_path = drnfile(1:p-1) // '.toml' // drnfile(p:n) ! - if (dtype == 4) then - ! - read(drainage_line, *, iostat=stat) struc_src_1_x(istruc), struc_src_1_y(istruc), & - struc_src_2_x(istruc), struc_src_2_y(istruc), & - struc_type(istruc), struc_width(istruc), struc_sill_elevation(istruc), & - struc_mannings_n(istruc), struc_zmin(istruc), struc_zmax(istruc), & - struc_t_close(istruc) - ! - else - ! - read(drainage_line, *, iostat=stat) struc_src_1_x(istruc), struc_src_1_y(istruc), & - struc_src_2_x(istruc), struc_src_2_y(istruc), & - struc_type(istruc), struc_width(istruc), struc_sill_elevation(istruc), & - struc_mannings_n(istruc), struc_par1(istruc), struc_par2(istruc), & - struc_t_close(istruc) - ! - endif + else + ! + toml_path = drnfile(1:n) // '.toml' ! endif ! - if (stat /= 0) then + call convert_legacy_to_toml(drnfile, trim(toml_path), ierr_conv) + ! + if (ierr_conv /= 0) then ! - write(logstr,'(a,i0,a,i0,a)') 'Drainage type ', dtype, ' requires ', npars, ' parameters !' - call stop_sfincs(logstr, -1) + write(logstr,'(a,a,a)')' Error ! Failed to convert legacy drn file "', trim(drnfile), & + '" to TOML; see preceding log entries for the reason' + call stop_sfincs(trim(logstr), -1) ! endif ! - enddo + endif ! - close(501) + call read_toml_src_structures(trim(toml_path), src_structures, ierr_toml) ! - ! Ensure the shared rule-expression stream is allocated (to size 0 - ! if no rules were ever parsed) so downstream openacc directives can - ! reference rule_* safely. + if (ierr_toml /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Failed to load TOML src_structures file ', trim(toml_path), ' !' + call stop_sfincs(trim(logstr), -1) + ! + endif ! - call finalize_rule_storage() + ! Flatten the parsed derived-type array into the module-level + ! struc_* 1D arrays, then deallocate src_structures(:). ! - ! Cell-index lookup, centre-to-centre distance, mismatch warning. + call marshal_src_structures_to_flat_arrays() ! - call finalize_src_structures_state() + ! Dump a per-structure description block to the log file. + ! + call write_src_structures_log_summary() + ! + ! Seed gate status + fraction_open from the initial water-level field. + ! zs(:) has already been populated by initialize_domain -> initialize_hydro + ! -> set_initial_conditions by the time we get here, so obs-point lookups + ! against zs are valid. Emitted after the summary so the per-gate init + ! status lines trail the structure block they annotate. + ! + call initialize_gate_status() ! end subroutine ! @@ -422,15 +320,15 @@ subroutine allocate_struc_flat_arrays(n) ! if (allocated(struc_nm_in)) deallocate(struc_nm_in) if (allocated(struc_nm_out)) deallocate(struc_nm_out) + if (allocated(struc_nm_obs_1)) deallocate(struc_nm_obs_1) + if (allocated(struc_nm_obs_2)) deallocate(struc_nm_obs_2) if (allocated(qstruc)) deallocate(qstruc) if (allocated(struc_type)) deallocate(struc_type) if (allocated(struc_distance)) deallocate(struc_distance) if (allocated(struc_status)) deallocate(struc_status) if (allocated(struc_fraction_open)) deallocate(struc_fraction_open) - if (allocated(struc_id)) deallocate(struc_id) + if (allocated(struc_t_state)) deallocate(struc_t_state) if (allocated(struc_name)) deallocate(struc_name) - if (allocated(struc_x)) deallocate(struc_x) - if (allocated(struc_y)) deallocate(struc_y) if (allocated(struc_src_1_x)) deallocate(struc_src_1_x) if (allocated(struc_src_1_y)) deallocate(struc_src_1_y) if (allocated(struc_src_2_x)) deallocate(struc_src_2_x) @@ -440,30 +338,29 @@ subroutine allocate_struc_flat_arrays(n) if (allocated(struc_obs_2_x)) deallocate(struc_obs_2_x) if (allocated(struc_obs_2_y)) deallocate(struc_obs_2_y) if (allocated(struc_q)) deallocate(struc_q) - if (allocated(struc_par1)) deallocate(struc_par1) - if (allocated(struc_par2)) deallocate(struc_par2) - if (allocated(struc_par3)) deallocate(struc_par3) - if (allocated(struc_cd)) deallocate(struc_cd) + if (allocated(struc_qmax)) deallocate(struc_qmax) + if (allocated(struc_flow_coef)) deallocate(struc_flow_coef) if (allocated(struc_width)) deallocate(struc_width) if (allocated(struc_sill_elevation)) deallocate(struc_sill_elevation) if (allocated(struc_mannings_n)) deallocate(struc_mannings_n) - if (allocated(struc_zmin)) deallocate(struc_zmin) - if (allocated(struc_zmax)) deallocate(struc_zmax) - if (allocated(struc_t_close)) deallocate(struc_t_close) + if (allocated(struc_opening_duration)) deallocate(struc_opening_duration) + if (allocated(struc_closing_duration)) deallocate(struc_closing_duration) if (allocated(struc_rule_open)) deallocate(struc_rule_open) if (allocated(struc_rule_close)) deallocate(struc_rule_close) + if (allocated(struc_rule_open_src)) deallocate(struc_rule_open_src) + if (allocated(struc_rule_close_src)) deallocate(struc_rule_close_src) ! allocate(struc_nm_in(n)) allocate(struc_nm_out(n)) + allocate(struc_nm_obs_1(n)) + allocate(struc_nm_obs_2(n)) allocate(qstruc(n)) allocate(struc_type(n)) allocate(struc_distance(n)) allocate(struc_status(n)) allocate(struc_fraction_open(n)) - allocate(struc_id(n)) + allocate(struc_t_state(n)) allocate(struc_name(n)) - allocate(struc_x(n)) - allocate(struc_y(n)) allocate(struc_src_1_x(n)) allocate(struc_src_1_y(n)) allocate(struc_src_2_x(n)) @@ -473,52 +370,50 @@ subroutine allocate_struc_flat_arrays(n) allocate(struc_obs_2_x(n)) allocate(struc_obs_2_y(n)) allocate(struc_q(n)) - allocate(struc_par1(n)) - allocate(struc_par2(n)) - allocate(struc_par3(n)) - allocate(struc_cd(n)) + allocate(struc_qmax(n)) + allocate(struc_flow_coef(n)) allocate(struc_width(n)) allocate(struc_sill_elevation(n)) allocate(struc_mannings_n(n)) - allocate(struc_zmin(n)) - allocate(struc_zmax(n)) - allocate(struc_t_close(n)) + allocate(struc_opening_duration(n)) + allocate(struc_closing_duration(n)) allocate(struc_rule_open(n)) allocate(struc_rule_close(n)) - ! - struc_rule_open = 0 - struc_rule_close = 0 - ! - struc_nm_in = 0 - struc_nm_out = 0 - qstruc = 0.0 - struc_type = 0 - struc_distance = 0.0 - struc_fraction_open = 1.0 ! initially fully open (could be refined from zmin/zmax) - struc_status = 1 ! 0=closed, 1=open, 2=closing, 3=opening - struc_id = ' ' - struc_name = ' ' - struc_x = 0.0 - struc_y = 0.0 - struc_src_1_x = 0.0 - struc_src_1_y = 0.0 - struc_src_2_x = 0.0 - struc_src_2_y = 0.0 - struc_obs_1_x = 0.0 - struc_obs_1_y = 0.0 - struc_obs_2_x = 0.0 - struc_obs_2_y = 0.0 - struc_q = 0.0 - struc_par1 = 0.0 - struc_par2 = 0.0 - struc_par3 = 0.0 - struc_cd = 0.0 - struc_width = 0.0 - struc_sill_elevation= 0.0 - struc_mannings_n = 0.0 - struc_zmin = 0.0 - struc_zmax = 0.0 - struc_t_close = 0.0 + allocate(struc_rule_open_src(n)) + allocate(struc_rule_close_src(n)) + ! + struc_rule_open = 0 + struc_rule_close = 0 + struc_rule_open_src = ' ' + struc_rule_close_src = ' ' + ! + struc_nm_in = 0 + struc_nm_out = 0 + struc_nm_obs_1 = 0 + struc_nm_obs_2 = 0 + qstruc = 0.0 + struc_type = 0 + struc_distance = 0.0 + struc_fraction_open = 1.0 ! 1.0 => no-op multiplier for non-gate types; gates get their real value from initialize_gate_status + struc_status = 0 ! 0=closed, 1=open, 2=opening, 3=closing + struc_t_state = 0.0 + struc_name = ' ' + struc_src_1_x = 0.0 + struc_src_1_y = 0.0 + struc_src_2_x = 0.0 + struc_src_2_y = 0.0 + struc_obs_1_x = 0.0 + struc_obs_1_y = 0.0 + struc_obs_2_x = 0.0 + struc_obs_2_y = 0.0 + struc_q = 0.0 + struc_qmax = 1.0e30 + struc_flow_coef = 1.0 + struc_width = 0.0 + struc_sill_elevation = 0.0 + struc_mannings_n = 0.024 + struc_opening_duration = 600.0 + struc_closing_duration = 600.0 ! end subroutine ! @@ -545,6 +440,17 @@ subroutine finalize_src_structures_state() nmq = find_quadtree_cell(struc_src_2_x(istruc), struc_src_2_y(istruc)) if (nmq > 0) struc_nm_out(istruc) = index_sfincs_in_quadtree(nmq) ! + ! obs cell indices feed the gate rule evaluator. The marshal has + ! already defaulted obs_*_x/y to src_*_x/y when the TOML reader + ! did not see the keys, so this lookup gives us obs_1 == src_1 + ! and obs_2 == src_2 for those cases without extra branching. + ! + nmq = find_quadtree_cell(struc_obs_1_x(istruc), struc_obs_1_y(istruc)) + if (nmq > 0) struc_nm_obs_1(istruc) = index_sfincs_in_quadtree(nmq) + ! + nmq = find_quadtree_cell(struc_obs_2_x(istruc), struc_obs_2_y(istruc)) + if (nmq > 0) struc_nm_obs_2(istruc) = index_sfincs_in_quadtree(nmq) + ! if (struc_nm_in(istruc) > 0 .and. struc_nm_out(istruc) > 0) then ! xsnk_tmp = z_xz(struc_nm_in(istruc)) @@ -569,14 +475,31 @@ subroutine finalize_src_structures_state() end subroutine ! ! + subroutine marshal_src_structures_to_flat_arrays() + ! + ! Copy the module-level src_structures(:) array (populated by + ! read_toml_src_structures) into the struc_* flat arrays, then run + ! the shared post-processing and deallocate src_structures(:). + ! + ! The TOML and legacy paths are mutually exclusive, so the flat arrays + ! should not yet be allocated when this is called; allocate_struc_flat_arrays + ! defensively deallocates any residual allocation first. + ! + ! Rule expressions (rule_open / rule_close) are handed to + ! sfincs_rule_expression's add_rule, which appends bytecode to its + ! shared stream, registers a new rule, and returns an integer rule_id + ! per structure. finalize_rule_storage is called at the end to shrink + ! the stream and registry to fit (and to allocate zero-length arrays + ! when no rules were seen). + ! ! ------------------------------------------------------------------ ! why does this marshal exist? ! ! the runtime reads all src-structure state from flat per-struct - ! arrays (the struc_* family: struc_type, struc_q, struc_par1, ...). + ! arrays (the struc_* family: struc_type, struc_q, struc_flow_coef, ...). ! the toml reader, however, naturally produces a derived-type array ! src_structures(:) of t_src_structure, which carries allocatable - ! components: character(len=:), allocatable :: id, name, plus the + ! components: character(len=:), allocatable :: name, plus the ! nested actions(:) and rules(:) arrays. ! ! nvfortran's openacc implicit deep-copy of derived types that @@ -597,23 +520,6 @@ subroutine finalize_src_structures_state() ! two input paths converge here. ! ------------------------------------------------------------------ ! - subroutine marshal_src_structures_to_flat_arrays() - ! - ! Copy the module-level src_structures(:) array (populated by - ! read_toml_src_structures) into the struc_* flat arrays, then run - ! the shared post-processing and deallocate src_structures(:). - ! - ! The TOML and legacy paths are mutually exclusive, so the flat arrays - ! should not yet be allocated when this is called; allocate_struc_flat_arrays - ! defensively deallocates any residual allocation first. - ! - ! Rule expressions (rule_open / rule_close) are handed to - ! sfincs_rule_expression's add_rule, which appends bytecode to its - ! shared stream, registers a new rule, and returns an integer rule_id - ! per structure. finalize_rule_storage is called at the end to shrink - ! the stream and registry to fit (and to allocate zero-length arrays - ! when no rules were seen). - ! use sfincs_data ! implicit none @@ -645,27 +551,13 @@ subroutine marshal_src_structures_to_flat_arrays() ! do i = 1, n ! - ! String fields: truncation warning if longer than struc_id_len. - ! - if (allocated(src_structures(i)%id)) then - ! - if (len(src_structures(i)%id) > struc_id_len) then - ! - write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure id length > ', struc_id_len, & - ' at entry ', i, '; truncating' - call write_log(logstr, 0) - ! - endif - ! - struc_id(i) = src_structures(i)%id - ! - endif + ! String fields: truncation warning if longer than struc_name_len. ! if (allocated(src_structures(i)%name)) then ! - if (len(src_structures(i)%name) > struc_id_len) then + if (len(src_structures(i)%name) > struc_name_len) then ! - write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure name length > ', struc_id_len, & + write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure name length > ', struc_name_len, & ' at entry ', i, '; truncating' call write_log(logstr, 0) ! @@ -676,33 +568,55 @@ subroutine marshal_src_structures_to_flat_arrays() endif ! struc_type(i) = int(src_structures(i)%structure_type, 1) - struc_status(i) = int(src_structures(i)%status, 1) ! - struc_x(i) = src_structures(i)%x - struc_y(i) = src_structures(i)%y + ! struc_status is runtime-only (not on the TOML type); leave it at + ! the default of 0 (open) set by allocate_struc_flat_arrays. + ! struc_src_1_x(i) = src_structures(i)%src_1_x struc_src_1_y(i) = src_structures(i)%src_1_y struc_src_2_x(i) = src_structures(i)%src_2_x struc_src_2_y(i) = src_structures(i)%src_2_y - struc_obs_1_x(i) = src_structures(i)%obs_1_x - struc_obs_1_y(i) = src_structures(i)%obs_1_y - struc_obs_2_x(i) = src_structures(i)%obs_2_x - struc_obs_2_y(i) = src_structures(i)%obs_2_y - ! - struc_q(i) = src_structures(i)%q - struc_par1(i) = src_structures(i)%par1 - struc_par2(i) = src_structures(i)%par2 - struc_par3(i) = src_structures(i)%par3 - struc_cd(i) = src_structures(i)%cd - struc_width(i) = src_structures(i)%width - struc_sill_elevation(i) = src_structures(i)%sill_elevation - struc_mannings_n(i) = src_structures(i)%mannings_n - struc_zmin(i) = src_structures(i)%zmin - struc_zmax(i) = src_structures(i)%zmax - struc_t_close(i) = src_structures(i)%t_close + ! + ! obs_1 / obs_2 default to the corresponding src_* when the TOML + ! reader did not see the key (tracked via has_obs_1 / has_obs_2). + ! This lets 0.0 remain a legal coordinate value. + ! + if (src_structures(i)%has_obs_1) then + ! + struc_obs_1_x(i) = src_structures(i)%obs_1_x + struc_obs_1_y(i) = src_structures(i)%obs_1_y + ! + else + ! + struc_obs_1_x(i) = src_structures(i)%src_1_x + struc_obs_1_y(i) = src_structures(i)%src_1_y + ! + endif + ! + if (src_structures(i)%has_obs_2) then + ! + struc_obs_2_x(i) = src_structures(i)%obs_2_x + struc_obs_2_y(i) = src_structures(i)%obs_2_y + ! + else + ! + struc_obs_2_x(i) = src_structures(i)%src_2_x + struc_obs_2_y(i) = src_structures(i)%src_2_y + ! + endif + ! + struc_q(i) = src_structures(i)%q + struc_qmax(i) = src_structures(i)%qmax + struc_flow_coef(i) = src_structures(i)%flow_coef + struc_width(i) = src_structures(i)%width + struc_sill_elevation(i) = src_structures(i)%sill_elevation + struc_mannings_n(i) = src_structures(i)%mannings_n + struc_opening_duration(i) = src_structures(i)%opening_duration + struc_closing_duration(i) = src_structures(i)%closing_duration ! ! Parse rule expressions. Missing / empty strings leave the ! rule_id at 0, which the evaluator interprets as "never fires". + ! Stash the source string for the init-time log summary. ! if (allocated(src_structures(i)%rule_open)) then ! @@ -711,13 +625,15 @@ subroutine marshal_src_structures_to_flat_arrays() ! if (ierr_parse /= 0) then ! - write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(struc_id(i)), & + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(struc_name(i)), & '" rules.open parse failed: ', trim(errmsg) call write_log(logstr, 1) - call stop_sfincs(logstr, -1) + call stop_sfincs(trim(logstr), -1) ! endif ! + struc_rule_open_src(i) = src_structures(i)%rule_open + ! endif ! if (allocated(src_structures(i)%rule_close)) then @@ -727,13 +643,15 @@ subroutine marshal_src_structures_to_flat_arrays() ! if (ierr_parse /= 0) then ! - write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(struc_id(i)), & + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(struc_name(i)), & '" rules.close parse failed: ', trim(errmsg) call write_log(logstr, 1) - call stop_sfincs(logstr, -1) + call stop_sfincs(trim(logstr), -1) ! endif ! + struc_rule_close_src(i) = src_structures(i)%rule_close + ! endif ! enddo @@ -773,9 +691,10 @@ subroutine update_src_structures(t, dt, tloop) real :: tloop ! integer :: count0, count1, count_rate, count_max - integer :: istruc, nmin, nmout - real*4 :: qq, qq0 - real*4 :: dzds, frac, wdt, zsill, zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose + integer :: istruc, nmin, nmout, nm_o1, nm_o2 + real*4 :: qq, qqmax, elapsed, z1r, z2r + real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0 + logical :: open_fires, close_fires ! if (nr_src_structures <= 0) return ! @@ -783,182 +702,210 @@ subroutine update_src_structures(t, dt, tloop) ! !$acc parallel loop present( z_volume, zs, zb, qsrc, qstruc, & !$acc struc_nm_in, struc_nm_out, & + !$acc struc_nm_obs_1, struc_nm_obs_2, & !$acc struc_type, & - !$acc struc_q, struc_par1, struc_par2, & + !$acc struc_q, struc_qmax, struc_flow_coef, & !$acc struc_width, struc_sill_elevation, & - !$acc struc_mannings_n, struc_zmin, struc_zmax, & - !$acc struc_t_close, & - !$acc struc_distance, struc_status, struc_fraction_open ) & - !$acc private( nmin, nmout, qq, qq0, dzds, frac, wdt, zsill, & - !$acc zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ) + !$acc struc_mannings_n, & + !$acc struc_opening_duration, struc_closing_duration, & + !$acc struc_distance, struc_status, struc_fraction_open, & + !$acc struc_t_state, & + !$acc struc_rule_open, struc_rule_close, & + !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, & + !$acc rule_start, rule_length ) & + !$acc private( nmin, nmout, nm_o1, nm_o2, qq, qqmax, elapsed, & + !$acc z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, & + !$acc open_fires, close_fires ) !$omp parallel do & - !$omp private( nmin, nmout, qq, qq0, dzds, frac, wdt, zsill, & - !$omp zmin, zmax, mng, hgate, dfrac, tcls, topen, tclose ) & + !$omp private( nmin, nmout, nm_o1, nm_o2, qq, qqmax, elapsed, & + !$omp z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, & + !$omp open_fires, close_fires ) & !$omp schedule ( static ) do istruc = 1, nr_src_structures ! nmin = struc_nm_in(istruc) nmout = struc_nm_out(istruc) + qqmax = struc_qmax(istruc) ! if (nmin > 0 .and. nmout > 0) then ! select case(struc_type(istruc)) ! - case(1) - ! - ! Pump + case(structure_pump) ! qq = struc_q(istruc) ! - case(2) + case(structure_culvert) ! - ! Culvert (bidirectional) + ! Bidirectional: Q = flow_coef * sign(dh) * sqrt(|dh|) ! if (zs(nmin) > zs(nmout)) then ! - qq = struc_par1(istruc) * sqrt(zs(nmin) - zs(nmout)) + qq = struc_flow_coef(istruc) * sqrt(zs(nmin) - zs(nmout)) ! else ! - qq = -struc_par1(istruc) * sqrt(zs(nmout) - zs(nmin)) + qq = -struc_flow_coef(istruc) * sqrt(zs(nmout) - zs(nmin)) ! endif ! - case(3) + qq = sign(min(abs(qq), qqmax), qq) ! - ! Check valve (culvert, but flow only from intake to outfall) - ! - if (zs(nmin) > zs(nmout)) then - ! - qq = struc_par1(istruc) * sqrt(zs(nmin) - zs(nmout)) - ! - else - ! - qq = -struc_par1(istruc) * sqrt(zs(nmout) - zs(nmin)) - ! - endif + case(structure_check_valve) ! - qq = max(qq, 0.0) + ! One-way: flow only when z(in) > z(out); clipped to [0, qmax]. ! - case(4) + qq = struc_flow_coef(istruc) * sqrt(max(0.0, zs(nmin) - zs(nmout))) + qq = min(qq, qqmax) ! - ! Controlled gate - opens when intake water level is between zmin and zmax. + case(structure_gate) ! - wdt = struc_width(istruc) ! width - zsill = struc_sill_elevation(istruc) ! sill elevation - mng = struc_mannings_n(istruc) ! Manning's n - zmin = struc_zmin(istruc) ! min water level for open - zmax = struc_zmax(istruc) ! max water level for open - tcls = struc_t_close(istruc) ! closing time (s) + ! Rule-driven state machine + bidirectional culvert-style + ! flow, scaled by the momentary open fraction. ! - dzds = (zs(nmout) - zs(nmin)) / struc_distance(istruc) - frac = struc_fraction_open(istruc) - hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) - dfrac = dt / tcls + ! Status codes: 0=closed, 1=open, 2=opening, 3=closing. + ! Opening/closing re-use the rule-evaluation branch only in + ! the terminal (0) and (1) states; transient states (2, 3) + ! advance purely on elapsed time so they cannot thrash. ! - qq0 = qstruc(istruc) / (wdt * max(frac, 0.001)) ! previous discharge per unit width, ignoring fraction + nm_o1 = struc_nm_obs_1(istruc) + nm_o2 = struc_nm_obs_2(istruc) ! - if (struc_status(istruc) == 0) then + if (nm_o1 > 0) then ! - if (zs(nmin) > zmin .and. zs(nmin) < zmax) struc_status(istruc) = 3 + z1r = real(zs(nm_o1), 4) ! - elseif (struc_status(istruc) == 1) then + else ! - if (zs(nmin) <= zmin .or. zs(nmin) >= zmax) struc_status(istruc) = 2 + z1r = 0.0 ! endif ! - if (struc_status(istruc) == 2) then + if (nm_o2 > 0) then ! - frac = frac - dfrac + z2r = real(zs(nm_o2), 4) ! - if (frac < 0.0) then - ! - frac = 0.0 - struc_status(istruc) = 0 - ! - endif + else ! - elseif (struc_status(istruc) == 3) then + z2r = 0.0 ! - frac = frac + dfrac + endif + ! + select case (int(struc_status(istruc))) ! - if (frac > 1.0) then + case (0) ! - frac = 1.0 - struc_status(istruc) = 1 + ! closed - look for an open trigger ! - endif - ! - endif - ! - struc_fraction_open(istruc) = frac - ! - qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) - qq = qq * wdt * frac - ! - case(5) - ! - ! Controlled gate - schedule triggered (one open/close window). + open_fires = evaluate_rule(struc_rule_open(istruc), z1r, z2r) + ! + if (open_fires) then + ! + struc_status(istruc) = 2 + struc_t_state(istruc) = real(t, 4) + ! + endif + ! + case (1) + ! + ! open - look for a close trigger + ! + close_fires = evaluate_rule(struc_rule_close(istruc), z1r, z2r) + ! + if (close_fires) then + ! + struc_status(istruc) = 3 + struc_t_state(istruc) = real(t, 4) + ! + endif + ! + case (2) + ! + ! opening - advance on elapsed time; do not re-check rules + ! + elapsed = real(t, 4) - struc_t_state(istruc) + ! + if (struc_opening_duration(istruc) <= 0.0 .or. & + elapsed >= struc_opening_duration(istruc)) then + ! + struc_status(istruc) = 1 + struc_fraction_open(istruc) = 1.0 + ! + else + ! + struc_fraction_open(istruc) = elapsed / struc_opening_duration(istruc) + ! + endif + ! + case (3) + ! + ! closing - advance on elapsed time; do not re-check rules + ! + elapsed = real(t, 4) - struc_t_state(istruc) + ! + if (struc_closing_duration(istruc) <= 0.0 .or. & + elapsed >= struc_closing_duration(istruc)) then + ! + struc_status(istruc) = 0 + struc_fraction_open(istruc) = 0.0 + ! + else + ! + struc_fraction_open(istruc) = 1.0 - elapsed / struc_closing_duration(istruc) + ! + endif + ! + end select ! - wdt = struc_width(istruc) ! width - zsill = struc_sill_elevation(istruc) ! sill elevation - mng = struc_mannings_n(istruc) ! Manning's n - tclose = struc_par1(istruc) ! time wrt tref to close - topen = struc_par2(istruc) ! time wrt tref to open - tcls = struc_t_close(istruc) ! closing time (s) + ! Flow uses the src pair (nmin/nmout), not the obs pair. + ! Bates et al. (2010) inertial formulation, per unit width: + ! q^{n+1} = (q^n - g*h*(dzs/ds)*dt) / + ! (1 + g*n^2*dt*|q^n| / h^{7/3}) + ! with h = max(max(zs_in, zs_out) - zsill, 0). + ! Multiply by width * fraction_open to get the structure + ! discharge. qstruc(istruc) holds q from the previous step + ! in full (signed, m^3/s) discharge form, so convert via + ! width * fraction_open to get qq0 in per-unit-width units. + ! Sign convention: qq > 0 means flow nmin -> nmout, matching + ! dzds = (zs_out - zs_in)/dist (positive downstream level + ! -> negative dzds -> positive qq). ! - dzds = (zs(nmout) - zs(nmin)) / struc_distance(istruc) frac = struc_fraction_open(istruc) - hgate = max(max(zs(nmin), zs(nmout)) - zsill, 0.0) - dfrac = dt / tcls + wdt = struc_width(istruc) + mng = struc_mannings_n(istruc) + zsill = struc_sill_elevation(istruc) + dist = struc_distance(istruc) ! - qq0 = qstruc(istruc) / (wdt * max(frac, 0.001)) - ! - if (struc_status(istruc) == 0) then - ! - if (t >= topen) struc_status(istruc) = 3 - ! - elseif (struc_status(istruc) == 1) then - ! - if (t >= tclose .and. t < topen) struc_status(istruc) = 2 - ! - endif + dzds = (real(zs(nmout), 4) - real(zs(nmin), 4)) / dist + hgate = max(max(real(zs(nmin), 4), real(zs(nmout), 4)) - zsill, 0.0) ! - if (struc_status(istruc) == 2) then - ! - frac = frac - dfrac + if (hgate > 0.0 .and. frac > 0.0) then ! - if (frac < 0.0) then - ! - frac = 0.0 - struc_status(istruc) = 0 - ! - endif + qq0 = qstruc(istruc) / (wdt * max(frac, 0.001)) + qq = (qq0 - g * hgate * dzds * dt) / & + (1.0 + g * mng * mng * dt * abs(qq0) / hgate**(7.0/3.0)) + qq = qq * wdt * frac ! - elseif (struc_status(istruc) == 3) then - ! - frac = frac + dfrac + else ! - if (frac > 1.0) then - ! - frac = 1.0 - struc_status(istruc) = 1 - ! - endif + qq = 0.0 ! endif ! - struc_fraction_open(istruc) = frac - ! - qq = (qq0 - g * hgate * dzds * dt) / (1.0 + g * mng**2 * dt * abs(qq0) / hgate**(7.0 / 3.0)) - qq = qq * wdt * frac + qq = sign(min(abs(qq), qqmax), qq) ! end select ! ! Relaxation: blend new and previous discharge to damp oscillations. + ! Gates use the Bates (2010) inertial form which already carries + ! its own temporal inertia via qq0; additional blending would + ! double-damp and suppress the dynamic response. ! - qq = 1.0 / (structure_relax / dt) * qq + (1.0 - (1.0 / (structure_relax / dt))) * qstruc(istruc) + if (struc_type(istruc) /= structure_gate) then + ! + qq = 1.0 / (structure_relax / dt) * qq + (1.0 - (1.0 / (structure_relax / dt))) * qstruc(istruc) + ! + endif ! ! Limit discharge by available volume in the intake / outfall cell. ! @@ -1020,26 +967,23 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! The TOML schema is an array of tables under the key "src_structure": ! ! [[src_structure]] - ! id = "gate_south" ! required, string - ! name = "South tide gate" ! optional, string + ! name = "south_tide_gate" ! required, string (sole identifier) ! type = "gate" ! required, one of pump/check_valve/culvert/gate - ! x = ... ; y = ... ! optional single-point coord ! src_1_x = ... ; src_1_y = ... ; src_2_x = ... ; src_2_y = ... ! obs_1_x = ... ; obs_1_y = ... ; obs_2_x = ... ; obs_2_y = ... - ! status = 0 ! q = ... ! pump discharge + ! qmax = ... ! max discharge magnitude (safety clamp) ! width = ... ; sill_elevation = ... ; mannings_n = ... - ! zmin = ... ; zmax = ... ; t_close = ... - ! cd = ... ; par1 = ... ; par2 = ... ; par3 = ... + ! opening_duration = ... ; closing_duration = ... + ! flow_coef = ... ! culvert / check_valve flow coefficient ! rules.open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr ! rules.close = "z2>2.0" ! optional trigger expr ! ! Per-type required keys (enforced on parse): - ! pump : x, y, q - ! check_valve : src_1_x, src_1_y, src_2_x, src_2_y, par1 - ! culvert : src_1_x, src_1_y, src_2_x, src_2_y, par1 - ! gate : src_1_x, src_1_y, src_2_x, src_2_y, - ! width, sill_elevation, mannings_n, zmin, zmax, t_close + ! pump : name, src_1_x, src_1_y, src_2_x, src_2_y, q + ! culvert : name, src_1_x, src_1_y, src_2_x, src_2_y, flow_coef + ! check_valve : name, src_1_x, src_1_y, src_2_x, src_2_y + ! gate : name, src_1_x, src_1_y, src_2_x, src_2_y, width, sill_elevation ! ! On success, structures is allocated to the exact number of entries ! (can be 0). On any I/O or parse failure, structures is left @@ -1060,7 +1004,7 @@ subroutine read_toml_src_structures(filename, structures, ierr) type(toml_error), allocatable :: err type(toml_array), pointer :: arr_structs type(toml_table), pointer :: tbl_struct, tbl_rules - character(len=:), allocatable :: id_str, name_str, type_str, rule_str + character(len=:), allocatable :: name_str, type_str, rule_str integer :: n_struct, i, stat ! ierr = 0 @@ -1127,25 +1071,8 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! endif ! - ! Required id string - ! - if (allocated(id_str)) deallocate(id_str) - call get_value(tbl_struct, 'id', id_str, stat=stat) - ! - if (.not. allocated(id_str)) then - ! - write(logstr,'(a,i0,a,a)')' Error ! Missing required "id" in src_structure entry ', i, & - ' of ', trim(filename) - call write_log(logstr, 1) - ierr = 1 - call cleanup_on_error() - return - ! - endif - ! - structures(i)%id = id_str - ! - ! Optional name + ! Required name string (presence enforced by check_required below, + ! so that the missing-key error path flows through a single place). ! if (allocated(name_str)) deallocate(name_str) call get_value(tbl_struct, 'name', name_str, stat=stat) @@ -1186,25 +1113,24 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! case (structure_pump) ! - call check_required(tbl_struct, [ character(len=14) :: & - 'x', 'y', 'q' ], id_str, ierr) + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'q' ], i, ierr) ! case (structure_check_valve) ! - call check_required(tbl_struct, [ character(len=14) :: & - 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'par1' ], id_str, ierr) + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y' ], i, ierr) ! case (structure_culvert) ! - call check_required(tbl_struct, [ character(len=14) :: & - 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'par1' ], id_str, ierr) + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'flow_coef' ], i, ierr) ! case (structure_gate) ! - call check_required(tbl_struct, [ character(len=14) :: & - 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & - 'width', 'sill_elevation', 'mannings_n', & - 'zmin', 'zmax', 't_close' ], id_str, ierr) + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & + 'width', 'sill_elevation' ], i, ierr) ! end select ! @@ -1215,40 +1141,35 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! endif ! - ! Coordinates - all default to 0.0 if missing. A structure may use only - ! the single point (x, y), or only the paired coords. + ! Coordinates - src pair is required (enforced above). obs pair + ! defaults to src in the marshal when the key is absent; track + ! presence here so the marshal can distinguish "user gave (0,0)" + ! from "user gave nothing". ! - call get_value(tbl_struct, 'x', structures(i)%x, 0.0, stat=stat) - call get_value(tbl_struct, 'y', structures(i)%y, 0.0, stat=stat) call get_value(tbl_struct, 'src_1_x', structures(i)%src_1_x, 0.0, stat=stat) call get_value(tbl_struct, 'src_1_y', structures(i)%src_1_y, 0.0, stat=stat) call get_value(tbl_struct, 'src_2_x', structures(i)%src_2_x, 0.0, stat=stat) call get_value(tbl_struct, 'src_2_y', structures(i)%src_2_y, 0.0, stat=stat) + ! + structures(i)%has_obs_1 = tbl_struct%has_key('obs_1_x') .or. tbl_struct%has_key('obs_1_y') + structures(i)%has_obs_2 = tbl_struct%has_key('obs_2_x') .or. tbl_struct%has_key('obs_2_y') + ! call get_value(tbl_struct, 'obs_1_x', structures(i)%obs_1_x, 0.0, stat=stat) call get_value(tbl_struct, 'obs_1_y', structures(i)%obs_1_y, 0.0, stat=stat) call get_value(tbl_struct, 'obs_2_x', structures(i)%obs_2_x, 0.0, stat=stat) call get_value(tbl_struct, 'obs_2_y', structures(i)%obs_2_y, 0.0, stat=stat) ! - ! State - ! - call get_value(tbl_struct, 'status', structures(i)%status, 0, stat=stat) - ! - ! Named physical parameters + ! Named physical parameters. Defaults are picked to avoid NaN in + ! arithmetic and to match the legacy-reader fallbacks. ! - call get_value(tbl_struct, 'q', structures(i)%q, 0.0, stat=stat) - call get_value(tbl_struct, 'width', structures(i)%width, 0.0, stat=stat) - call get_value(tbl_struct, 'sill_elevation', structures(i)%sill_elevation, 0.0, stat=stat) - call get_value(tbl_struct, 'mannings_n', structures(i)%mannings_n, 0.0, stat=stat) - call get_value(tbl_struct, 'zmin', structures(i)%zmin, 0.0, stat=stat) - call get_value(tbl_struct, 'zmax', structures(i)%zmax, 0.0, stat=stat) - call get_value(tbl_struct, 't_close', structures(i)%t_close, 0.0, stat=stat) - ! - ! Generic parameters (kept for future use / rule rhs) - ! - call get_value(tbl_struct, 'cd', structures(i)%cd, 0.0, stat=stat) - call get_value(tbl_struct, 'par1', structures(i)%par1, 0.0, stat=stat) - call get_value(tbl_struct, 'par2', structures(i)%par2, 0.0, stat=stat) - call get_value(tbl_struct, 'par3', structures(i)%par3, 0.0, stat=stat) + call get_value(tbl_struct, 'q', structures(i)%q, 0.0, stat=stat) + call get_value(tbl_struct, 'qmax', structures(i)%qmax, 1.0e30, stat=stat) + call get_value(tbl_struct, 'width', structures(i)%width, 0.0, stat=stat) + call get_value(tbl_struct, 'sill_elevation', structures(i)%sill_elevation, 0.0, stat=stat) + call get_value(tbl_struct, 'mannings_n', structures(i)%mannings_n, 0.024, stat=stat) + call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 600.0, stat=stat) + call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 600.0, stat=stat) + call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 1.0, stat=stat) ! ! Optional rules sub-table with string "open" / "close" expressions. ! Absent sub-table, or absent keys within it, leaves the rule strings @@ -1282,11 +1203,12 @@ subroutine cleanup_on_error() end subroutine ! ! - subroutine check_required(table, keys, id_str, ierr) + subroutine check_required(table, keys, seq_index, ierr) ! ! Verify that every key in "keys" is present in the TOML table. Missing - ! keys are reported to the log (naming the structure id and key) and - ! ierr is set non-zero. Presence is checked via has_key so that a legal + ! keys are reported to the log (naming the structure by its 1-based + ! sequence index, since "name" itself may be the missing key) and ierr + ! is set non-zero. Presence is checked via has_key so that a legal ! value of 0.0 is not mistaken for "missing". ! use tomlf @@ -1295,7 +1217,7 @@ subroutine check_required(table, keys, id_str, ierr) ! type(toml_table), pointer, intent(in) :: table character(len=*), intent(in) :: keys(:) - character(len=*), intent(in) :: id_str + integer, intent(in) :: seq_index integer, intent(inout) :: ierr ! integer :: k @@ -1304,8 +1226,8 @@ subroutine check_required(table, keys, id_str, ierr) ! if (.not. table%has_key(trim(keys(k)))) then ! - write(logstr,'(a,a,a,a,a)')' Error ! src_structure "', trim(id_str), & - '" is missing required key "', trim(keys(k)), '"' + write(logstr,'(a,i0,a,a,a)')' Error ! Structure #', seq_index, & + ' is missing required key "', trim(keys(k)), '"' call write_log(logstr, 1) ierr = 1 ! @@ -1385,5 +1307,474 @@ function to_lower(str) result(lower) enddo ! end function + ! + ! + subroutine initialize_gate_status() + ! + ! Seed each gate's status and fraction_open from the initial water-level + ! field. Called right after the marshal, by which point zs(:) has already + ! been populated by initialize_hydro -> set_initial_conditions. For + ! non-gate structures the defaults from allocate_struc_flat_arrays + ! (status=0=closed, fraction_open=1.0) already encode "no-op"; we only + ! touch rows where struc_type == structure_gate. + ! + ! Status encoding: 0=closed, 1=open, 2=opening, 3=closing. + ! + use sfincs_data + ! + implicit none + ! + integer :: istruc, nm1, nm2 + real :: z1, z2 + logical :: open_fires, close_fires + character(len=16) :: status_str + ! + if (nr_src_structures <= 0) return + ! + do istruc = 1, nr_src_structures + ! + if (struc_type(istruc) /= structure_gate) cycle + ! + nm1 = struc_nm_obs_1(istruc) + nm2 = struc_nm_obs_2(istruc) + ! + if (nm1 > 0) then + ! + z1 = real(zs(nm1), 4) + ! + else + ! + z1 = 0.0 + ! + endif + ! + if (nm2 > 0) then + ! + z2 = real(zs(nm2), 4) + ! + else + ! + z2 = 0.0 + ! + endif + ! + open_fires = evaluate_rule(struc_rule_open(istruc), z1, z2) + close_fires = evaluate_rule(struc_rule_close(istruc), z1, z2) + ! + if (open_fires .and. .not. close_fires) then + ! + struc_status(istruc) = 1 + struc_fraction_open(istruc) = 1.0 + status_str = 'open' + ! + elseif (.not. open_fires .and. close_fires) then + ! + struc_status(istruc) = 0 + struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + elseif (open_fires .and. close_fires) then + ! + struc_status(istruc) = 1 + struc_fraction_open(istruc) = 1.0 + status_str = 'open' + write(logstr,'(a,a,a)')'Warning ! gate ', trim(struc_name(istruc)), & + ': both open and close rules fire at init; keeping gate open' + call write_log(logstr, 0) + ! + else + ! + struc_status(istruc) = 0 + struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + endif + ! + ! Transition timer is only consulted after a transition triggers; + ! seed with t0 so the first rule-driven transition has a sane baseline. + ! + struc_t_state(istruc) = t0 + ! + write(logstr,'(a,a,a,a)')'gate ', trim(struc_name(istruc)), & + ' initialised status=', trim(status_str) + call write_log(logstr, 0) + ! + enddo + ! + end subroutine + ! + ! + subroutine write_src_structures_log_summary() + ! + ! Emit a one-block-per-structure description of every parsed src + ! structure to the log file. Intended for operator review at init + ! time; not printed to stdout. + ! + implicit none + ! + integer :: i + character(len=32) :: type_str + ! + if (nr_src_structures <= 0) return + ! + call write_log('------------------------------------------', 0) + call write_log('Flow control structures', 0) + call write_log('------------------------------------------', 0) + ! + write(logstr,'(a,i0,a)')'Added ', nr_src_structures, ' flow control structures' + call write_log(logstr, 0) + call write_log('', 0) + ! + do i = 1, nr_src_structures + ! + select case (int(struc_type(i))) + ! + case (structure_pump) + ! + type_str = 'pump' + ! + case (structure_culvert) + ! + type_str = 'culvert' + ! + case (structure_check_valve) + ! + type_str = 'check_valve' + ! + case (structure_gate) + ! + type_str = 'gate' + ! + case default + ! + type_str = 'unknown' + ! + end select + ! + write(logstr,'(a,i0,a)')'Structure ', i, ':' + call write_log(logstr, 0) + ! + write(logstr,'(a,a)')' name: ', trim(struc_name(i)) + call write_log(logstr, 0) + ! + write(logstr,'(a,a)')' type: ', trim(type_str) + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.3,a,f0.3,a)')' src_1: (', struc_src_1_x(i), ', ', struc_src_1_y(i), ')' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.3,a,f0.3,a)')' src_2: (', struc_src_2_x(i), ', ', struc_src_2_y(i), ')' + call write_log(logstr, 0) + ! + ! obs coords are meaningful for culvert / check_valve / gate. + ! + if (struc_type(i) == structure_culvert .or. & + struc_type(i) == structure_check_valve .or. & + struc_type(i) == structure_gate) then + ! + write(logstr,'(a,f0.3,a,f0.3,a)')' obs_1: (', struc_obs_1_x(i), ', ', struc_obs_1_y(i), ')' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.3,a,f0.3,a)')' obs_2: (', struc_obs_2_x(i), ', ', struc_obs_2_y(i), ')' + call write_log(logstr, 0) + ! + endif + ! + if (struc_type(i) == structure_pump) then + ! + write(logstr,'(a,f0.4,a)')' discharge: ', struc_q(i), ' (m3/s)' + call write_log(logstr, 0) + ! + endif + ! + if (struc_type(i) == structure_culvert .or. & + struc_type(i) == structure_check_valve .or. & + struc_type(i) == structure_gate) then + ! + write(logstr,'(a,es12.4,a)')' qmax: ', struc_qmax(i), ' (m3/s)' + call write_log(logstr, 0) + ! + endif + ! + if (struc_type(i) == structure_culvert .or. & + struc_type(i) == structure_check_valve) then + ! + write(logstr,'(a,f0.4)')' flow_coef: ', struc_flow_coef(i) + call write_log(logstr, 0) + ! + endif + ! + if (struc_type(i) == structure_gate) then + ! + write(logstr,'(a,f0.4,a)')' width: ', struc_width(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4,a)')' sill_elev.: ', struc_sill_elevation(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4)')' mannings_n: ', struc_mannings_n(i) + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.2,a)')' opening: ', struc_opening_duration(i), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.2,a)')' closing: ', struc_closing_duration(i), ' (s)' + call write_log(logstr, 0) + ! + endif + ! + if (struc_rule_open(i) > 0) then + ! + if (len_trim(struc_rule_open_src(i)) > 0) then + ! + write(logstr,'(a,a,a)')' rules.open: "', trim(struc_rule_open_src(i)), '"' + ! + else + ! + write(logstr,'(a)')' rules.open: (set)' + ! + endif + ! + call write_log(logstr, 0) + ! + endif + ! + if (struc_rule_close(i) > 0) then + ! + if (len_trim(struc_rule_close_src(i)) > 0) then + ! + write(logstr,'(a,a,a)')' rules.close: "', trim(struc_rule_close_src(i)), '"' + ! + else + ! + write(logstr,'(a)')' rules.close: (set)' + ! + endif + ! + call write_log(logstr, 0) + ! + endif + ! + call write_log('', 0) + ! + enddo + ! + end subroutine + ! + ! + subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) + ! + ! Transcribe a legacy fixed-column drn file into a TOML sibling file, + ! so that downstream code only has to consume the TOML schema. One + ! [[src_structure]] block is emitted per non-blank, non-comment line + ! of the legacy file. Water-level-triggered gates (legacy dtype 4) are + ! converted to TOML gate blocks with synthesised rule expressions. + ! Schedule-triggered gates (legacy dtype 5) are refused; the new rule + ! grammar is water-level-only and has no time atom. + ! + ! The converter is deliberately minimal: no coord sanity checks, no + ! duplicate-name detection, no preservation of comments. It exists only + ! to remove the parallel legacy parsing machinery that used to live + ! in this module. + ! + implicit none + ! + character(len=*), intent(in) :: legacy_path + character(len=*), intent(in) :: toml_path + integer, intent(out) :: ierr + ! + integer :: u_in, u_out, stat, n_struct, dtype + real*4 :: x2, y2, x1, y1, par + real*4 :: g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls + character(len=512) :: line, trimmed + character(len=32) :: name_str + character(len=16) :: type_name, par_name + character(len=13) :: zmin_str, zmax_str + character(len=128) :: rule_open_str, rule_close_str + ! + ierr = 0 + n_struct = 0 + u_in = 501 + u_out = 502 + ! + open(u_in, file=trim(legacy_path), status='old', action='read', iostat=stat) + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not open legacy drn file "', trim(legacy_path), '" for reading' + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + open(u_out, file=trim(toml_path), status='replace', action='write', iostat=stat) + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not open TOML output file "', trim(toml_path), '" for writing' + close(u_in) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + write(u_out,'(a)') '# Auto-generated from legacy drn file by SFINCS.' + write(u_out,'(a)') '# Do not edit; edit the legacy source or rewrite as TOML directly.' + write(u_out,'(a)') '' + ! + do while (.true.) + ! + read(u_in,'(a)', iostat=stat) line + ! + if (stat /= 0) exit + ! + ! Skip blank / comment lines. + ! + trimmed = adjustl(line) + ! + if (len_trim(trimmed) == 0) cycle + if (trimmed(1:1) == '#' .or. trimmed(1:1) == '!') cycle + ! + ! Columns: x2, y2, x1, y1, dtype, par. + ! (legacy snk -> src_2; legacy src -> src_1). + ! + read(line, *, iostat=stat) x2, y2, x1, y1, dtype, par + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not parse legacy drn line in "', trim(legacy_path), '"' + call write_log(logstr, 1) + write(logstr,'(a,a)')' line: ', trim(line) + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + endif + ! + ! Branch on dtype. Gates (4, 5) and unknown codes set ierr and bail. + ! + select case (dtype) + ! + case (1) + ! + type_name = 'pump' + par_name = 'q' + ! + case (2) + ! + type_name = 'culvert' + par_name = 'flow_coef' + ! + case (3) + ! + type_name = 'check_valve' + par_name = 'flow_coef' + ! + case (4) + ! + ! Water-level-triggered gate. Legacy columns past dtype: + ! width, sill_elevation, mannings_n, zmin, zmax, t_close. + ! Re-read the whole line to pull those extra columns. + ! + read(line, *, iostat=stat) x2, y2, x1, y1, dtype, & + g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not parse legacy dtype-4 gate line in "', trim(legacy_path), '"' + call write_log(logstr, 1) + write(logstr,'(a,a)')' line: ', trim(line) + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + endif + ! + ! Synthesise rule strings with the legacy numeric values baked in. + ! Grammar accepts '<', '>', '&', '|' only (no '<=' / '>='). + ! + write(zmin_str,'(es13.6)') g_zmin + write(zmax_str,'(es13.6)') g_zmax + write(rule_open_str, '(a,a,a,a)') 'z1>', trim(adjustl(zmin_str)), ' & z1<', trim(adjustl(zmax_str)) + write(rule_close_str,'(a,a,a,a)') 'z1<', trim(adjustl(zmin_str)), ' | z1>', trim(adjustl(zmax_str)) + ! + n_struct = n_struct + 1 + ! + if (g_zmin >= g_zmax) then + ! + write(logstr,'(a,i0,a)')' Warning ! legacy gate entry ', n_struct, ': zmin >= zmax, open rule will never fire' + call write_log(logstr, 0) + ! + endif + ! + write(name_str,'(a,i0)') 'legacy_', n_struct + ! + write(u_out,'(a)') '[[src_structure]]' + write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' + write(u_out,'(a)') 'type = "gate"' + write(u_out,'(a,es14.6)') 'src_1_x = ', x1 + write(u_out,'(a,es14.6)') 'src_1_y = ', y1 + write(u_out,'(a,es14.6)') 'src_2_x = ', x2 + write(u_out,'(a,es14.6)') 'src_2_y = ', y2 + write(u_out,'(a,es14.6)') 'width = ', g_width + write(u_out,'(a,es14.6)') 'sill_elevation = ', g_sill + write(u_out,'(a,es14.6)') 'mannings_n = ', g_mann + write(u_out,'(a,es14.6)') 'opening_duration = ', g_tcls + write(u_out,'(a,es14.6)') 'closing_duration = ', g_tcls + write(u_out,'(a,a,a)') 'rules.open = "', trim(rule_open_str), '"' + write(u_out,'(a,a,a)') 'rules.close = "', trim(rule_close_str), '"' + write(u_out,'(a)') '' + ! + cycle + ! + case (5) + ! + write(logstr,'(a)')' Error ! legacy schedule-triggered gate (dtype 5) not supported - rewrite as TOML with rule-based triggers or file an issue to add a time atom to the rule grammar' + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + case default + ! + write(logstr,'(a,i0,a)')' Error ! unknown drainage_type ', dtype, ' in legacy drn file' + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + end select + ! + n_struct = n_struct + 1 + write(name_str,'(a,i0)') 'legacy_', n_struct + ! + write(u_out,'(a)') '[[src_structure]]' + write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' + write(u_out,'(a,a,a)') 'type = "', trim(type_name),'"' + write(u_out,'(a,es14.6)') 'src_1_x = ', x1 + write(u_out,'(a,es14.6)') 'src_1_y = ', y1 + write(u_out,'(a,es14.6)') 'src_2_x = ', x2 + write(u_out,'(a,es14.6)') 'src_2_y = ', y2 + write(u_out,'(a,a,a,es14.6)') trim(par_name), repeat(' ', max(1, 7 - len_trim(par_name))), '= ', par + write(u_out,'(a)') '' + ! + enddo + ! + close(u_in) + close(u_out) + ! + write(logstr,'(a,a,a,a,a)')' Converted legacy drn file "', trim(legacy_path), & + '" to TOML "', trim(toml_path), '"' + call write_log(logstr, 0) + ! + end subroutine end module From 2472672afb0e60a4a8bd835ab6cb5eb6295e6fc1 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sat, 18 Apr 2026 15:02:42 +0200 Subject: [PATCH 26/65] Refactor river discharge and source-structure state Move river-point discharge runtime state out of sfincs_data into a dedicated sfincs_discharges module and rename/clarify identifiers for source structures. - Introduce nr_discharge_points (replacing nsrc) and move per-point runtime arrays (qtsrc, nmindsrc, src_name, itsrclast) into sfincs_discharges so the discharge module owns its state and avoids circular back-references. - Update all readers and writers to use nr_discharge_points: sfincs_ncinput, sfincs_input, sfincs_lib, sfincs_output, sfincs_ncoutput, sfincs_openacc, sfincs_output and other call sites. - Add src_name handling and auto-generate names when reading netCDF discharge inputs; support optional name token in legacy srcfile lines. Implement count_tokens helper to parse srcfile lines robustly. - Clamp time bracket indices during interpolation to avoid out-of-bounds reads for netCDF path. - Move qtsrc/nmindsrc allocation/deallocation responsibility to sfincs_discharges; sfincs_data no longer deallocates these. - Rename many src-structure symbols to a consistent src_struc_* prefix (formerly struc_*) and qstruc -> q_src_struc, updating allocations, OpenACC present lists, and all uses to match the new names. Update TOML/legacy marshal and output handling to use new names and to copy name buffers for netCDF his output. These changes separate module responsibilities, clarify naming, fix netCDF name handling, and adjust GPU/OpenACC variable lists to match the refactored state ownership. --- source/src/sfincs_data.f90 | 16 +- source/src/sfincs_discharges.f90 | 168 ++++- source/src/sfincs_input.f90 | 2 +- source/src/sfincs_lib.f90 | 2 +- source/src/sfincs_ncinput.F90 | 8 +- source/src/sfincs_ncoutput.F90 | 83 +- source/src/sfincs_openacc.f90 | 29 +- source/src/sfincs_output.f90 | 13 +- source/src/sfincs_src_structures.f90 | 1045 ++++++++++++-------------- 9 files changed, 730 insertions(+), 636 deletions(-) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 4d4c43a5b..4fe03b794 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -781,13 +781,14 @@ module sfincs_data ! ! River point discharges (sfincs_discharges) ! - integer :: nsrc + ! Identifiers that are read by sfincs_input / sfincs_ncinput stay here; + ! the pure discharge-module-only state (itsrclast, nmindsrc, qtsrc, + ! src_name, src_name_len) has been moved into sfincs_discharges. + ! + integer :: nr_discharge_points integer :: ntsrc - integer :: itsrclast real*4, dimension(:), allocatable :: tsrc ! (ntsrc) time stamps of river discharge time series - real*4, dimension(:,:), allocatable :: qsrc_ts ! (nsrc, ntsrc) river discharge time series matrix - real*4, dimension(:), allocatable :: qtsrc ! (nsrc) interpolated discharge at current time, for his output - integer*4, dimension(:), allocatable :: nmindsrc ! (nsrc) river source cell indices + real*4, dimension(:,:), allocatable :: qsrc_ts ! (nr_discharge_points, ntsrc) river discharge time series matrix real*4, dimension(:), allocatable :: xsrc real*4, dimension(:), allocatable :: ysrc ! @@ -1119,8 +1120,9 @@ subroutine finalize_parameters() if(allocated(qsrc)) deallocate(qsrc) if(allocated(tsrc)) deallocate(tsrc) if(allocated(qsrc_ts)) deallocate(qsrc_ts) - if(allocated(qtsrc)) deallocate(qtsrc) - if(allocated(nmindsrc)) deallocate(nmindsrc) + ! + ! River-point-discharge module-private state (qtsrc, nmindsrc, src_name) + ! is owned by sfincs_discharges and is deallocated there. ! ! Src-point structure state is owned by sfincs_src_structures and is ! deallocated there. diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index 367b0060e..f77749948 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -1,9 +1,9 @@ module sfincs_discharges ! - ! River point discharges: nsrc (x,y) locations from srcfile with matching + ! River point discharges: nr_discharge_points (x,y) locations from srcfile with matching ! time series qsrc_ts(:,:) from disfile, OR from a FEWS-style netCDF input ! via netsrcdisfile. Interpolates to the current model time every step, - ! stores the interpolated value in qtsrc(nsrc) (for his output), and + ! stores the interpolated value in qtsrc(nr_discharge_points) (for his output), and ! accumulates the per-cell discharge into the global qsrc(np) array used ! by sfincs_continuity. ! @@ -14,11 +14,38 @@ module sfincs_discharges use sfincs_log use sfincs_error ! + implicit none + ! + ! ------------------------------------------------------------------ + ! Module-level runtime state for river point discharges (moved from + ! sfincs_data). The count, coordinate arrays, file-path strings, and + ! qsrc_ts / tsrc / ntsrc stay in sfincs_data because they are also + ! set by sfincs_input (keyword reader) or sfincs_ncinput (which this + ! module uses, so a back-reference would be circular). + ! + ! Public so downstream output modules (sfincs_output, sfincs_ncoutput) + ! and the openacc bookkeeping module can reference them. + ! ------------------------------------------------------------------ + ! + ! Name length (matches src_struc_name_len from sfincs_src_structures). + ! + integer, parameter, public :: src_name_len = 128 + ! + ! Per-river-source names + ! + character(len=src_name_len), dimension(:), allocatable, public :: src_name ! (nr_discharge_points) user-supplied or auto-generated names for river point sources + ! + ! Runtime state + ! + integer, public :: itsrclast ! last-used bracket index into tsrc, for time-series interpolation + real*4, dimension(:), allocatable, public :: qtsrc ! (nr_discharge_points) interpolated discharge at current time, for his output + integer*4, dimension(:), allocatable, public :: nmindsrc ! (nr_discharge_points) river source cell indices + ! contains ! subroutine initialize_discharges() ! - ! Read src/dis or netsrcdis. Allocate nmindsrc(nsrc), qtsrc(nsrc). + ! Read src/dis or netsrcdis. Allocate nmindsrc(nr_discharge_points), qtsrc(nr_discharge_points). ! use sfincs_data use sfincs_ncinput @@ -27,16 +54,16 @@ subroutine initialize_discharges() implicit none ! real*4 :: dummy - integer :: isrc, itsrc, nmq, n, stat + integer :: isrc, itsrc, nmq, n, stat, ntok logical :: ok + character(len=1024) :: line, line_trim + character(len=src_name_len) :: name_tmp ! - nsrc = 0 - ntsrc = 0 - itsrclast = 1 + nr_discharge_points = 0 + ntsrc = 0 + itsrclast = 1 ! if (srcfile(1:4) /= 'none') then - ! - ok = check_file_exists(srcfile, 'Source points file', .true.) ! write(logstr,'(a)') 'Info : reading discharges' call write_log(logstr, 0) @@ -49,7 +76,7 @@ subroutine initialize_discharges() ! read(500, *, iostat=stat) dummy if (stat < 0) exit - nsrc = nsrc + 1 + nr_discharge_points = nr_discharge_points + 1 ! enddo ! @@ -59,7 +86,24 @@ subroutine initialize_discharges() ! ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) ! - call read_netcdf_discharge_data() ! sets nsrc, ntsrc, xsrc, ysrc, qsrc_ts, tsrc + call read_netcdf_discharge_data() ! sets nr_discharge_points, ntsrc, xsrc, ysrc, qsrc_ts, tsrc + ! + ! The netcdf discharge file does not carry per-point names; auto-generate + ! the same way as the 2-column srcfile path. + ! + if (nr_discharge_points > 0) then + ! + allocate(src_name(nr_discharge_points)) + ! + src_name = ' ' + ! + do n = 1, nr_discharge_points + ! + write(src_name(n), '(a,i4.4)') 'discharge_', n + ! + enddo + ! + endif ! if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then ! @@ -70,10 +114,10 @@ subroutine initialize_discharges() ! endif ! - if (nsrc <= 0) return + if (nr_discharge_points <= 0) return ! - allocate(nmindsrc(nsrc)) - allocate(qtsrc(nsrc)) + allocate(nmindsrc(nr_discharge_points)) + allocate(qtsrc(nr_discharge_points)) ! nmindsrc = 0 qtsrc = 0.0 @@ -82,12 +126,40 @@ subroutine initialize_discharges() ! if (srcfile(1:4) /= 'none') then ! - allocate(xsrc(nsrc)) - allocate(ysrc(nsrc)) + allocate(xsrc(nr_discharge_points)) + allocate(ysrc(nr_discharge_points)) + allocate(src_name(nr_discharge_points)) + ! + src_name = ' ' ! - do n = 1, nsrc + do n = 1, nr_discharge_points + ! + read(500, '(a)') line + line_trim = adjustl(line) ! - read(500, *) xsrc(n), ysrc(n) + ! Count whitespace-separated tokens on the line. + ! + call count_tokens(line_trim, ntok) + ! + if (ntok == 2) then + ! + read(line_trim, *) xsrc(n), ysrc(n) + write(src_name(n), '(a,i4.4)') 'discharge_', n + ! + elseif (ntok == 3) then + ! + read(line_trim, *) xsrc(n), ysrc(n), name_tmp + src_name(n) = adjustl(trim(name_tmp)) + ! + else + ! + write(logstr,'(a,i0,a,i0,a)') ' Error ! src file line ', n, ' has ', ntok, & + ' tokens -- expected 2 (x y) or 3 (x y name) !' + call write_log(logstr, 1) + error = 1 + return + ! + endif ! enddo ! @@ -109,11 +181,11 @@ subroutine initialize_discharges() ! rewind(502) allocate(tsrc(ntsrc)) - allocate(qsrc_ts(nsrc, ntsrc)) + allocate(qsrc_ts(nr_discharge_points, ntsrc)) ! do itsrc = 1, ntsrc ! - read(502, *) tsrc(itsrc), (qsrc_ts(isrc, itsrc), isrc = 1, nsrc) + read(502, *) tsrc(itsrc), (qsrc_ts(isrc, itsrc), isrc = 1, nr_discharge_points) ! enddo ! @@ -144,7 +216,7 @@ subroutine initialize_discharges() ! ! --- Map river sources to grid cells -------------------------------- ! - do isrc = 1, nsrc + do isrc = 1, nr_discharge_points ! nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) ! @@ -165,7 +237,7 @@ subroutine initialize_discharges() subroutine update_discharges(t, dt, tloop) ! ! Zero qsrc(np); interpolate the river discharge time series to t, - ! store in qtsrc(1..nsrc), and accumulate into qsrc(nmindsrc(:)). + ! store in qtsrc(1..nr_discharge_points), and accumulate into qsrc(nmindsrc(:)). ! ! update_discharges is called BEFORE update_src_structures -- that is ! why it owns the qsrc zeroing. Both routines then additively write @@ -191,7 +263,7 @@ subroutine update_discharges(t, dt, tloop) qsrc = 0.0 !$acc end kernels ! - if (nsrc > 0) then + if (nr_discharge_points > 0) then ! ! Locate the bracketing interval in tsrc and compute the interpolation ! weight once. Then run a single parallel loop that both interpolates @@ -213,6 +285,13 @@ subroutine update_discharges(t, dt, tloop) ! enddo ! + ! Clamp to valid bracket. If t is outside [tsrc(1), tsrc(ntsrc)] (which + ! can happen on the netcdf path, where the srcfile pre-padding is not + ! applied), hold the endpoint value rather than read out of bounds. + ! + it_prev = min(max(it_prev, 1), ntsrc - 1) + it_next = it_prev + 1 + ! wt = (t - tsrc(it_prev)) / (tsrc(it_next) - tsrc(it_prev)) ! ! Atomic accumulation because two river sources (or a river and a @@ -220,7 +299,7 @@ subroutine update_discharges(t, dt, tloop) ! !$acc parallel loop present( qsrc, qtsrc, nmindsrc, qsrc_ts ) private( nm ) !$omp parallel do private( nm ) schedule ( static ) - do isrc = 1, nsrc + do isrc = 1, nr_discharge_points ! qtsrc(isrc) = qsrc_ts(isrc, it_prev) + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt nm = nmindsrc(isrc) @@ -243,5 +322,46 @@ subroutine update_discharges(t, dt, tloop) tloop = tloop + 1.0 * (count1 - count0) / count_rate ! end subroutine + ! + subroutine count_tokens(line, ntok) + ! + ! Count the number of whitespace-separated tokens in a string. + ! Whitespace = spaces and tabs. Empty string returns 0. + ! + implicit none + ! + character(len=*), intent(in) :: line + integer, intent(out) :: ntok + ! + integer :: i, n + logical :: in_tok + character(len=1) :: c + ! + ntok = 0 + in_tok = .false. + n = len_trim(line) + ! + do i = 1, n + ! + c = line(i:i) + ! + if (c == ' ' .or. c == char(9)) then + ! + in_tok = .false. + ! + else + ! + if (.not. in_tok) then + ! + ntok = ntok + 1 + in_tok = .true. + ! + endif + ! + endif + ! + enddo + ! + end subroutine end module diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index ad9b8d411..db9a6aef9 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -711,7 +711,7 @@ subroutine read_sfincs_input() ! ! Turn off some processes not needed for bathtub flooding ! - nsrc = 0 + nr_discharge_points = 0 nr_src_structures = 0 ! meteo3d = .false. diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 89027c4cd..f18094ad1 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -724,7 +724,7 @@ function sfincs_finalize() result(ierr) call write_log(logstr, 1) endif ! - if (nsrc>0 .or. nr_src_structures>0) then + if (nr_discharge_points>0 .or. nr_src_structures>0) then write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in discharges : ', tloopsrc, ' (', 100 * tloopsrc / (tfinish_all - tstart_all), '%)' call write_log(logstr, 1) endif diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index b56b13030..5b48f7870 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -206,7 +206,7 @@ subroutine read_netcdf_discharge_data() ! ! Get dimensions sizes: time, stations NF90(nf90_inquire_dimension(net_file_srcdis%ncid, net_file_srcdis%time_dimid, len = ntsrc)) !nr of timesteps in file - NF90(nf90_inquire_dimension(net_file_srcdis%ncid, net_file_srcdis%points_dimid, len = nsrc)) !nr of discharge points + NF90(nf90_inquire_dimension(net_file_srcdis%ncid, net_file_srcdis%points_dimid, len = nr_discharge_points)) !nr of discharge points ! ! Get variable id's NF90(nf90_inq_varid(net_file_srcdis%ncid, x_varname, net_file_srcdis%x_varid) ) ! Has to be in the same UTM zone as SFINCS grid @@ -215,10 +215,10 @@ subroutine read_netcdf_discharge_data() NF90(nf90_inq_varid(net_file_srcdis%ncid, q_varname, net_file_srcdis%q_varid) ) ! ! Allocate variables - allocate(xsrc(nsrc)) - allocate(ysrc(nsrc)) + allocate(xsrc(nr_discharge_points)) + allocate(ysrc(nr_discharge_points)) allocate(tsrc(ntsrc)) - allocate(qsrc_ts(nsrc,ntsrc)) + allocate(qsrc_ts(nr_discharge_points,ntsrc)) ! ! Read values NF90(nf90_get_var(net_file_srcdis%ncid, net_file_srcdis%x_varid, xsrc(:)) ) diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index b506e1792..721e9d671 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -49,7 +49,7 @@ module sfincs_ncoutput integer :: structure_height_varid, structure_x_varid, structure_y_varid integer :: thindam_x_varid, thindam_y_varid integer :: drain_varid, drain_name_varid - integer :: river_varid + integer :: river_varid, river_name_varid integer :: zb_varid integer :: time_varid integer :: zs_varid, h_varid, u_varid, v_varid, prcp_varid, cumprcp_varid, discharge_varid, uvmag_varid, uvdir_varid @@ -1615,7 +1615,8 @@ subroutine ncoutput_his_init() use sfincs_date use sfincs_data use sfincs_structures - use sfincs_src_structures, only: nr_src_structures + use sfincs_src_structures, only: nr_src_structures, src_struc_name + use sfincs_discharges, only: src_name ! implicit none ! @@ -1628,9 +1629,12 @@ subroutine ncoutput_his_init() ! real*4, dimension(:,:), allocatable :: thindam_info real*4, dimension(:), allocatable :: thindam_x - real*4, dimension(:), allocatable :: thindam_y + real*4, dimension(:), allocatable :: thindam_y + ! + character*256, dimension(:), allocatable :: drain_name_buf + character*256, dimension(:), allocatable :: river_name_buf ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nr_src_structures==0 .and. .not. (nsrc>0 .and. store_river_discharge) .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources (when store_river_discharge) or run-up gauges; his file is not created + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nr_src_structures==0 .and. .not. (nr_discharge_points>0 .and. store_river_discharge) .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources (when store_river_discharge) or run-up gauges; his file is not created return endif ! @@ -1654,8 +1658,8 @@ subroutine ncoutput_his_init() NF90(nf90_def_dim(his_file%ncid, 'drainage', nr_src_structures, his_file%drain_dimid)) ! nr of drainage structures endif ! - if (nsrc>0 .and. store_river_discharge) then - NF90(nf90_def_dim(his_file%ncid, 'rivers', nsrc, his_file%river_dimid)) ! nr of river point sources + if (nr_discharge_points>0 .and. store_river_discharge) then + NF90(nf90_def_dim(his_file%ncid, 'rivers', nr_discharge_points, his_file%river_dimid)) ! nr of river point sources endif ! if (nrstructures>0) then @@ -1698,9 +1702,17 @@ subroutine ncoutput_his_init() ! if (nr_runup_gauges > 0) then NF90(nf90_def_var(his_file%ncid, 'runup_gauge_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%runup_gauges_dimid/), his_file%runup_gauge_name_varid)) - endif + endif ! - !NF90(nf90_put_att(his_file%ncid, his_file%station_name_varid, 'units', '-')) !not wanted in fews + if (nr_src_structures > 0) then + NF90(nf90_def_var(his_file%ncid, 'drainage_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%drain_dimid/), his_file%drain_name_varid)) + endif + ! + if (nr_discharge_points > 0 .and. store_river_discharge) then + NF90(nf90_def_var(his_file%ncid, 'river_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%river_dimid/), his_file%river_name_varid)) + endif + ! + !NF90(nf90_put_att(his_file%ncid, his_file%station_name_varid, 'units', '-')) !not wanted in fews ! ! Domain NF90(nf90_def_var(his_file%ncid, 'station_x', NF90_FLOAT, (/his_file%points_dimid/), his_file%station_x_varid)) ! non snapped input coordinate @@ -2059,12 +2071,13 @@ subroutine ncoutput_his_init() ! endif ! - if (nsrc>0 .and. store_river_discharge) then + if (nr_discharge_points>0 .and. store_river_discharge) then ! NF90(nf90_def_var(his_file%ncid, 'river_discharge', NF90_FLOAT, (/his_file%river_dimid, his_file%time_dimid/), his_file%river_varid)) ! time-varying river point discharge NF90(nf90_put_att(his_file%ncid, his_file%river_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'units', 'm3 s-1')) NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'long_name', 'river point discharge')) + NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'coordinates', 'river_name')) ! endif ! @@ -2106,7 +2119,46 @@ subroutine ncoutput_his_init() ! if (nr_runup_gauges > 0) then NF90(nf90_put_var(his_file%ncid, his_file%runup_gauge_name_varid, runup_gauge_name)) ! write rug name - endif + endif + ! + if (nr_src_structures > 0) then + ! + ! Copy src_struc_name (length src_struc_name_len = 128) into a length-256 buffer + ! to match the pointnamelength netCDF dimension used for all his_file name + ! variables. + ! + allocate(drain_name_buf(nr_src_structures)) + ! + do istruc = 1, nr_src_structures + ! + drain_name_buf(istruc) = src_struc_name(istruc) + ! + enddo + ! + NF90(nf90_put_var(his_file%ncid, his_file%drain_name_varid, drain_name_buf)) ! write drainage_name + ! + deallocate(drain_name_buf) + ! + endif + ! + if (nr_discharge_points > 0 .and. store_river_discharge) then + ! + ! Copy src_name (length src_name_len) into a length-256 buffer to match + ! the pointnamelength netCDF dimension. + ! + allocate(river_name_buf(nr_discharge_points)) + ! + do istruc = 1, nr_discharge_points + ! + river_name_buf(istruc) = src_name(istruc) + ! + enddo + ! + NF90(nf90_put_var(his_file%ncid, his_file%river_name_varid, river_name_buf)) ! write river_name + ! + deallocate(river_name_buf) + ! + endif ! if (nrstructures>0) then ! @@ -3018,7 +3070,8 @@ subroutine ncoutput_update_his(t,nthisout) use sfincs_crosssections use sfincs_runup_gauges use sfincs_snapwave - use sfincs_src_structures, only: nr_src_structures, qstruc + use sfincs_src_structures, only: nr_src_structures, q_src_struc + use sfincs_discharges, only: qtsrc ! implicit none ! @@ -3312,13 +3365,13 @@ subroutine ncoutput_update_his(t,nthisout) ! if (nr_src_structures>0) then ! - !$acc update host(qstruc) + !$acc update host(q_src_struc) ! - NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, qstruc, (/1, nthisout/))) ! write per-structure discharge + NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, q_src_struc, (/1, nthisout/))) ! write per-structure discharge ! endif ! - if (nsrc>0 .and. store_river_discharge) then + if (nr_discharge_points>0 .and. store_river_discharge) then ! !$acc update host(qtsrc) ! @@ -3910,7 +3963,7 @@ subroutine ncoutput_his_finalize() ! implicit none ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. nr_src_structures==0 .and. .not. (nsrc>0 .and. store_river_discharge)) then ! If no observation points, cross-sections, structures (weir or thin dam), drains or river sources (when store_river_discharge); hisfile + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. nr_src_structures==0 .and. .not. (nr_discharge_points>0 .and. store_river_discharge)) then ! If no observation points, cross-sections, structures (weir or thin dam), drains or river sources (when store_river_discharge); hisfile return endif ! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 903242956..c68c96fff 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -2,6 +2,7 @@ module sfincs_openacc ! use sfincs_data use sfincs_src_structures + use sfincs_discharges, only: qtsrc, nmindsrc use sfincs_rule_expression, only: rule_opcode, rule_atom, rule_cmp, rule_threshold, & rule_start, rule_length ! @@ -24,13 +25,13 @@ subroutine initialize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc qsrc, qtsrc, qstruc, nmindsrc, struc_nm_in, struc_nm_out, struc_type, & - !$acc struc_nm_obs_1, struc_nm_obs_2, & - !$acc struc_q, struc_qmax, struc_flow_coef, & - !$acc struc_width, struc_sill_elevation, struc_mannings_n, & - !$acc struc_opening_duration, struc_closing_duration, & - !$acc struc_distance, struc_status, struc_fraction_open, struc_t_state, & - !$acc struc_rule_open, struc_rule_close, & + !$acc qsrc, qtsrc, q_src_struc, nmindsrc, src_struc_nm_in, src_struc_nm_out, src_struc_type, & + !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & + !$acc src_struc_q, src_struc_qmax, src_struc_flow_coef, & + !$acc src_struc_width, src_struc_sill_elevation, src_struc_mannings_n, & + !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, src_struc_t_state, & + !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & @@ -61,13 +62,13 @@ subroutine finalize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc qsrc, qtsrc, qstruc, nmindsrc, struc_nm_in, struc_nm_out, struc_type, & - !$acc struc_nm_obs_1, struc_nm_obs_2, & - !$acc struc_q, struc_qmax, struc_flow_coef, & - !$acc struc_width, struc_sill_elevation, struc_mannings_n, & - !$acc struc_opening_duration, struc_closing_duration, & - !$acc struc_distance, struc_status, struc_fraction_open, struc_t_state, & - !$acc struc_rule_open, struc_rule_close, & + !$acc qsrc, qtsrc, q_src_struc, nmindsrc, src_struc_nm_in, src_struc_nm_out, src_struc_type, & + !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & + !$acc src_struc_q, src_struc_qmax, src_struc_flow_coef, & + !$acc src_struc_width, src_struc_sill_elevation, src_struc_mannings_n, & + !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, src_struc_t_state, & + !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & diff --git a/source/src/sfincs_output.f90 b/source/src/sfincs_output.f90 index daa93551f..f9dc5c1c3 100644 --- a/source/src/sfincs_output.f90 +++ b/source/src/sfincs_output.f90 @@ -590,7 +590,7 @@ subroutine open_his_output() open(unit = 966, file = trim('qt.txt')) close(unit = 966 ,status='delete') endif - if (nsrc>0) then + if (nr_discharge_points>0) then open(unit = 969, file = trim('qriver.txt')) close(unit = 969 ,status='delete') endif @@ -608,7 +608,8 @@ subroutine write_his_output(t) ! use sfincs_data use sfincs_crosssections - use sfincs_src_structures, only: nr_src_structures, qstruc + use sfincs_src_structures, only: nr_src_structures, q_src_struc + use sfincs_discharges, only: qtsrc ! implicit none ! @@ -660,17 +661,17 @@ subroutine write_his_output(t) ! endif ! - if (nsrc>0) then + if (nr_discharge_points>0) then !$acc update host(qtsrc) open(unit = 969, file = trim('qriver.txt'), access='append') - write(969,'(f12.1,10000f9.3)')t,(qtsrc(iobs), iobs = 1, nsrc) + write(969,'(f12.1,10000f9.3)')t,(qtsrc(iobs), iobs = 1, nr_discharge_points) close(969) endif ! if (nr_src_structures>0 .and. store_qdrain) then - !$acc update host(qstruc) + !$acc update host(q_src_struc) open(unit = 970, file = trim('qdrain.txt'), access='append') - write(970,'(f12.1,10000f9.3)')t,(qstruc(iobs), iobs = 1, nr_src_structures) + write(970,'(f12.1,10000f9.3)')t,(q_src_struc(iobs), iobs = 1, nr_src_structures) close(970) endif ! diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 715db6f05..4e89a4da4 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -13,9 +13,9 @@ module sfincs_src_structures ! each module has a single responsibility. ! ! Runtime handoff to the continuity module is via the cell-wise qsrc(np) - ! array (in sfincs_data): this module accumulates qq on intake (struc_nm_in) - ! and outfall (struc_nm_out) cells. Per-structure signed discharge is also - ! stored in qstruc(nr_src_structures) for his output. + ! array (in sfincs_data): this module accumulates qq on intake (src_struc_nm_in) + ! and outfall (src_struc_nm_out) cells. Per-structure signed discharge is also + ! stored in q_src_struc(nr_src_structures) for his output. ! ! Concurrency: qsrc updates use atomic because two structures (or a river ! source and a structure) can land in the same cell. @@ -26,18 +26,11 @@ module sfincs_src_structures ! private :: parse_structure_type, to_lower, check_required private :: convert_legacy_to_toml - private :: allocate_struc_flat_arrays, finalize_src_structures_state - private :: marshal_src_structures_to_flat_arrays - private :: initialize_gate_status, write_src_structures_log_summary + private :: write_src_structures_log_summary ! ! ------------------------------------------------------------------ - ! Named constants for the keyword-based src structure input. - ! - ! These are scaffolding for a future TOML/YAML reader; no runtime - ! code consumes them yet. - ! ------------------------------------------------------------------ - ! ! Structure type codes + ! ------------------------------------------------------------------ ! integer, parameter :: structure_pump = 1 integer, parameter :: structure_check_valve = 2 @@ -107,11 +100,8 @@ module sfincs_src_structures ! ! ------------------------------------------------------------------ ! Module-level storage for structures parsed from a TOML input file. - ! - ! Populated by the dispatcher when the drn file parses as TOML. - ! Not yet consumed by any downstream runtime code - wiring is a later - ! step. The legacy path continues to populate the flat arrays below - ! directly (struc_type, struc_q, struc_flow_coef, etc.). + ! Populated by the dispatcher and flattened into the flat arrays below + ! by the marshal. ! ------------------------------------------------------------------ ! type(t_src_structure), allocatable :: src_structures(:) ! intermediate derived-type array; flattened + deallocated by marshal_src_structures_to_flat_arrays on the toml path (gpu deep-copy avoidance). @@ -126,65 +116,65 @@ module sfincs_src_structures ! ! Meta / name ! - integer, parameter :: struc_name_len = 128 ! max length of struct name strings - character(len=struc_name_len), dimension(:), allocatable, public :: struc_name + integer, parameter :: src_struc_name_len = 128 ! max length of struct name strings + character(len=src_struc_name_len), dimension(:), allocatable, public :: src_struc_name ! ! Kind / state ! - integer*1, dimension(:), allocatable, public :: struc_type - integer*1, dimension(:), allocatable, public :: struc_status - real*4, dimension(:), allocatable, public :: struc_distance - real*4, dimension(:), allocatable, public :: struc_fraction_open + integer*1, dimension(:), allocatable, public :: src_struc_type + integer*1, dimension(:), allocatable, public :: src_struc_status + real*4, dimension(:), allocatable, public :: src_struc_distance + real*4, dimension(:), allocatable, public :: src_struc_fraction_open ! ! Cell mapping ! integer, public :: nr_src_structures - integer*4, dimension(:), allocatable, public :: struc_nm_in ! (nr_src_structures) intake (sink) cell indices - integer*4, dimension(:), allocatable, public :: struc_nm_out ! (nr_src_structures) outfall (source) cell indices - integer*4, dimension(:), allocatable, public :: struc_nm_obs_1 ! (nr_src_structures) obs_1 cell indices (gate rule inputs; defaults to src_1 cell) - integer*4, dimension(:), allocatable, public :: struc_nm_obs_2 ! (nr_src_structures) obs_2 cell indices (gate rule inputs; defaults to src_2 cell) + integer*4, dimension(:), allocatable, public :: src_struc_nm_in ! (nr_src_structures) intake (sink) cell indices + integer*4, dimension(:), allocatable, public :: src_struc_nm_out ! (nr_src_structures) outfall (source) cell indices + integer*4, dimension(:), allocatable, public :: src_struc_nm_obs_1 ! (nr_src_structures) obs_1 cell indices (gate rule inputs; defaults to src_1 cell) + integer*4, dimension(:), allocatable, public :: src_struc_nm_obs_2 ! (nr_src_structures) obs_2 cell indices (gate rule inputs; defaults to src_2 cell) ! ! Gate transition timer (simulation time at which current status was entered). ! Only meaningful for structure_gate; ignored for other types. ! - real*4, dimension(:), allocatable, public :: struc_t_state + real*4, dimension(:), allocatable, public :: src_struc_t_state ! ! Coordinates ! - real*4, dimension(:), allocatable, public :: struc_src_1_x, struc_src_1_y - real*4, dimension(:), allocatable, public :: struc_src_2_x, struc_src_2_y - real*4, dimension(:), allocatable, public :: struc_obs_1_x, struc_obs_1_y - real*4, dimension(:), allocatable, public :: struc_obs_2_x, struc_obs_2_y + real*4, dimension(:), allocatable, public :: src_struc_src_1_x, src_struc_src_1_y + real*4, dimension(:), allocatable, public :: src_struc_src_2_x, src_struc_src_2_y + real*4, dimension(:), allocatable, public :: src_struc_obs_1_x, src_struc_obs_1_y + real*4, dimension(:), allocatable, public :: src_struc_obs_2_x, src_struc_obs_2_y ! ! Named parameters ! - real*4, dimension(:), allocatable, public :: struc_q ! pump discharge - real*4, dimension(:), allocatable, public :: struc_qmax ! max discharge magnitude (safety clamp) - real*4, dimension(:), allocatable, public :: struc_flow_coef ! culvert / check_valve flow coefficient - real*4, dimension(:), allocatable, public :: struc_width ! gate width - real*4, dimension(:), allocatable, public :: struc_sill_elevation ! gate sill elevation - real*4, dimension(:), allocatable, public :: struc_mannings_n ! gate Manning's n - real*4, dimension(:), allocatable, public :: struc_opening_duration ! gate opening duration (s) - real*4, dimension(:), allocatable, public :: struc_closing_duration ! gate closing duration (s) + real*4, dimension(:), allocatable, public :: src_struc_q ! pump discharge + real*4, dimension(:), allocatable, public :: src_struc_qmax ! max discharge magnitude (safety clamp) + real*4, dimension(:), allocatable, public :: src_struc_flow_coef ! culvert / check_valve flow coefficient + real*4, dimension(:), allocatable, public :: src_struc_width ! gate width + real*4, dimension(:), allocatable, public :: src_struc_sill_elevation ! gate sill elevation + real*4, dimension(:), allocatable, public :: src_struc_mannings_n ! gate Manning's n + real*4, dimension(:), allocatable, public :: src_struc_opening_duration ! gate opening duration (s) + real*4, dimension(:), allocatable, public :: src_struc_closing_duration ! gate closing duration (s) ! ! Runtime state ! - real*4, dimension(:), allocatable, public :: qstruc ! (nr_src_structures) signed discharge per structure, mirrors the qsrc pattern + real*4, dimension(:), allocatable, public :: q_src_struc ! (nr_src_structures) signed discharge per structure, mirrors the qsrc pattern ! ! ------------------------------------------------------------------ ! Per-structure rule ids into the registry owned by sfincs_rule_expression. ! A rule_id of 0 means "no rule; never fires". ! - ! struc_rule_open_src / struc_rule_close_src hold the raw source strings + ! src_struc_rule_open_src / src_struc_rule_close_src hold the raw source strings ! (for log emission only); these do not need to travel to GPU. ! ------------------------------------------------------------------ ! - integer, dimension(:), allocatable, public :: struc_rule_open ! (nr_src_structures) rule_id for open action, 0 = no rule - integer, dimension(:), allocatable, public :: struc_rule_close ! (nr_src_structures) rule_id for close action, 0 = no rule + integer, dimension(:), allocatable, public :: src_struc_rule_open ! (nr_src_structures) rule_id for open action, 0 = no rule + integer, dimension(:), allocatable, public :: src_struc_rule_close ! (nr_src_structures) rule_id for close action, 0 = no rule ! - integer, parameter :: struc_rule_src_len = 256 - character(len=struc_rule_src_len), dimension(:), allocatable, public :: struc_rule_open_src - character(len=struc_rule_src_len), dimension(:), allocatable, public :: struc_rule_close_src + integer, parameter :: src_struc_rule_src_len = 256 + character(len=src_struc_rule_src_len), dimension(:), allocatable, public :: src_struc_rule_open_src + character(len=src_struc_rule_src_len), dimension(:), allocatable, public :: src_struc_rule_close_src ! contains ! @@ -202,25 +192,58 @@ subroutine initialize_src_structures() ! If a file parses as TOML but fails semantic validation (e.g. a ! missing required field), that is treated as a hard error. ! + ! After parsing, the derived-type src_structures(:) array is flattened + ! into the src_struc_* 1D arrays (the runtime's sole state representation), + ! grid-cell indices and distances are resolved, a descriptive block is + ! written to the log, and gate statuses are seeded from the initial + ! water-level field. + ! use sfincs_data + use quadtree use tomlf, only : toml_table, toml_error, toml_load ! implicit none ! + ! Dispatcher locals + ! type(toml_table), allocatable :: probe_top type(toml_error), allocatable :: probe_err integer :: ierr_toml, ierr_conv logical :: ok, is_toml character(len=512) :: toml_path - integer :: n, p + ! + ! Marshal locals + ! + integer :: i, ierr_parse + character(len=256) :: errmsg + ! + ! Cell-index / distance locals + ! + integer :: istruc, nmq + real*4 :: xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp + ! + ! Gate-status seeding locals + ! + integer :: nm1, nm2 + real :: z1, z2 + logical :: open_fires, close_fires + character(len=16) :: status_str ! if (drnfile(1:4) == 'none') return ! + ! ------------------------------------------------------------------ + ! Existence check + ! ------------------------------------------------------------------ + ! ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) ! + ! ------------------------------------------------------------------ + ! Probe TOML / convert legacy / re-read TOML + ! ! Probe: try to parse as TOML. This is a cheap check; on success we ! discard the probe table and let read_toml_src_structures re-parse, ! which keeps the two code paths decoupled. + ! ------------------------------------------------------------------ ! call toml_load(probe_top, drnfile, error=probe_err) ! @@ -238,34 +261,10 @@ subroutine initialize_src_structures() else ! ! Legacy path: transcribe to a TOML sibling file, then fall through - ! to the TOML reader. Derived path: if drnfile ends in ".drn" - ! (case-insensitive), insert ".toml" before the extension; else - ! append ".toml". + ! to the TOML reader. The converter derives its own output path from + ! drnfile. ! - n = len_trim(drnfile) - p = 0 - ! - if (n >= 4) then - ! - if (to_lower(drnfile(n-3:n)) == '.drn') then - ! - p = n - 3 - ! - endif - ! - endif - ! - if (p > 0) then - ! - toml_path = drnfile(1:p-1) // '.toml' // drnfile(p:n) - ! - else - ! - toml_path = drnfile(1:n) // '.toml' - ! - endif - ! - call convert_legacy_to_toml(drnfile, trim(toml_path), ierr_conv) + call convert_legacy_to_toml(drnfile, toml_path, ierr_conv) ! if (ierr_conv /= 0) then ! @@ -286,296 +285,153 @@ subroutine initialize_src_structures() ! endif ! - ! Flatten the parsed derived-type array into the module-level - ! struc_* 1D arrays, then deallocate src_structures(:). - ! - call marshal_src_structures_to_flat_arrays() - ! - ! Dump a per-structure description block to the log file. - ! - call write_src_structures_log_summary() - ! - ! Seed gate status + fraction_open from the initial water-level field. - ! zs(:) has already been populated by initialize_domain -> initialize_hydro - ! -> set_initial_conditions by the time we get here, so obs-point lookups - ! against zs are valid. Emitted after the summary so the per-gate init - ! status lines trail the structure block they annotate. - ! - call initialize_gate_status() - ! - end subroutine - ! - ! - subroutine allocate_struc_flat_arrays(n) - ! - ! Allocate every struc_* flat array to size n and initialise defaults. - ! Used by both the legacy reader and the TOML marshal helper. - ! Defensively deallocates first so re-entry is safe. - ! - use sfincs_data - ! - implicit none - ! - integer, intent(in) :: n - ! - if (allocated(struc_nm_in)) deallocate(struc_nm_in) - if (allocated(struc_nm_out)) deallocate(struc_nm_out) - if (allocated(struc_nm_obs_1)) deallocate(struc_nm_obs_1) - if (allocated(struc_nm_obs_2)) deallocate(struc_nm_obs_2) - if (allocated(qstruc)) deallocate(qstruc) - if (allocated(struc_type)) deallocate(struc_type) - if (allocated(struc_distance)) deallocate(struc_distance) - if (allocated(struc_status)) deallocate(struc_status) - if (allocated(struc_fraction_open)) deallocate(struc_fraction_open) - if (allocated(struc_t_state)) deallocate(struc_t_state) - if (allocated(struc_name)) deallocate(struc_name) - if (allocated(struc_src_1_x)) deallocate(struc_src_1_x) - if (allocated(struc_src_1_y)) deallocate(struc_src_1_y) - if (allocated(struc_src_2_x)) deallocate(struc_src_2_x) - if (allocated(struc_src_2_y)) deallocate(struc_src_2_y) - if (allocated(struc_obs_1_x)) deallocate(struc_obs_1_x) - if (allocated(struc_obs_1_y)) deallocate(struc_obs_1_y) - if (allocated(struc_obs_2_x)) deallocate(struc_obs_2_x) - if (allocated(struc_obs_2_y)) deallocate(struc_obs_2_y) - if (allocated(struc_q)) deallocate(struc_q) - if (allocated(struc_qmax)) deallocate(struc_qmax) - if (allocated(struc_flow_coef)) deallocate(struc_flow_coef) - if (allocated(struc_width)) deallocate(struc_width) - if (allocated(struc_sill_elevation)) deallocate(struc_sill_elevation) - if (allocated(struc_mannings_n)) deallocate(struc_mannings_n) - if (allocated(struc_opening_duration)) deallocate(struc_opening_duration) - if (allocated(struc_closing_duration)) deallocate(struc_closing_duration) - if (allocated(struc_rule_open)) deallocate(struc_rule_open) - if (allocated(struc_rule_close)) deallocate(struc_rule_close) - if (allocated(struc_rule_open_src)) deallocate(struc_rule_open_src) - if (allocated(struc_rule_close_src)) deallocate(struc_rule_close_src) - ! - allocate(struc_nm_in(n)) - allocate(struc_nm_out(n)) - allocate(struc_nm_obs_1(n)) - allocate(struc_nm_obs_2(n)) - allocate(qstruc(n)) - allocate(struc_type(n)) - allocate(struc_distance(n)) - allocate(struc_status(n)) - allocate(struc_fraction_open(n)) - allocate(struc_t_state(n)) - allocate(struc_name(n)) - allocate(struc_src_1_x(n)) - allocate(struc_src_1_y(n)) - allocate(struc_src_2_x(n)) - allocate(struc_src_2_y(n)) - allocate(struc_obs_1_x(n)) - allocate(struc_obs_1_y(n)) - allocate(struc_obs_2_x(n)) - allocate(struc_obs_2_y(n)) - allocate(struc_q(n)) - allocate(struc_qmax(n)) - allocate(struc_flow_coef(n)) - allocate(struc_width(n)) - allocate(struc_sill_elevation(n)) - allocate(struc_mannings_n(n)) - allocate(struc_opening_duration(n)) - allocate(struc_closing_duration(n)) - allocate(struc_rule_open(n)) - allocate(struc_rule_close(n)) - allocate(struc_rule_open_src(n)) - allocate(struc_rule_close_src(n)) - ! - struc_rule_open = 0 - struc_rule_close = 0 - struc_rule_open_src = ' ' - struc_rule_close_src = ' ' - ! - struc_nm_in = 0 - struc_nm_out = 0 - struc_nm_obs_1 = 0 - struc_nm_obs_2 = 0 - qstruc = 0.0 - struc_type = 0 - struc_distance = 0.0 - struc_fraction_open = 1.0 ! 1.0 => no-op multiplier for non-gate types; gates get their real value from initialize_gate_status - struc_status = 0 ! 0=closed, 1=open, 2=opening, 3=closing - struc_t_state = 0.0 - struc_name = ' ' - struc_src_1_x = 0.0 - struc_src_1_y = 0.0 - struc_src_2_x = 0.0 - struc_src_2_y = 0.0 - struc_obs_1_x = 0.0 - struc_obs_1_y = 0.0 - struc_obs_2_x = 0.0 - struc_obs_2_y = 0.0 - struc_q = 0.0 - struc_qmax = 1.0e30 - struc_flow_coef = 1.0 - struc_width = 0.0 - struc_sill_elevation = 0.0 - struc_mannings_n = 0.024 - struc_opening_duration = 600.0 - struc_closing_duration = 600.0 - ! - end subroutine - ! - ! - subroutine finalize_src_structures_state() - ! - ! Shared post-processing for both the legacy and TOML paths. Looks up - ! intake / outfall cell indices from the struc_src_1_* / _2_* coords - ! and computes centre-to-centre distance. - ! - use sfincs_data - use quadtree - ! - implicit none - ! - integer :: istruc, nmq - real*4 :: xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp - ! - do istruc = 1, nr_src_structures - ! - nmq = find_quadtree_cell(struc_src_1_x(istruc), struc_src_1_y(istruc)) - if (nmq > 0) struc_nm_in(istruc) = index_sfincs_in_quadtree(nmq) - ! - nmq = find_quadtree_cell(struc_src_2_x(istruc), struc_src_2_y(istruc)) - if (nmq > 0) struc_nm_out(istruc) = index_sfincs_in_quadtree(nmq) - ! - ! obs cell indices feed the gate rule evaluator. The marshal has - ! already defaulted obs_*_x/y to src_*_x/y when the TOML reader - ! did not see the keys, so this lookup gives us obs_1 == src_1 - ! and obs_2 == src_2 for those cases without extra branching. - ! - nmq = find_quadtree_cell(struc_obs_1_x(istruc), struc_obs_1_y(istruc)) - if (nmq > 0) struc_nm_obs_1(istruc) = index_sfincs_in_quadtree(nmq) - ! - nmq = find_quadtree_cell(struc_obs_2_x(istruc), struc_obs_2_y(istruc)) - if (nmq > 0) struc_nm_obs_2(istruc) = index_sfincs_in_quadtree(nmq) - ! - if (struc_nm_in(istruc) > 0 .and. struc_nm_out(istruc) > 0) then - ! - xsnk_tmp = z_xz(struc_nm_in(istruc)) - ysnk_tmp = z_yz(struc_nm_in(istruc)) - xsrc_tmp = z_xz(struc_nm_out(istruc)) - ysrc_tmp = z_yz(struc_nm_out(istruc)) - struc_distance(istruc) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) - ! - endif - ! - enddo - ! - if (any(struc_nm_in == 0) .or. any(struc_nm_out == 0)) then - ! - write(logstr,'(a)') 'Warning ! For some sink/source drainage points no matching active grid cell was found!' - call write_log(logstr, 0) - write(logstr,'(a)') 'Warning ! These points will be skipped, please check your input!' - call write_log(logstr, 0) - ! - endif - ! - end subroutine - ! - ! - subroutine marshal_src_structures_to_flat_arrays() - ! - ! Copy the module-level src_structures(:) array (populated by - ! read_toml_src_structures) into the struc_* flat arrays, then run - ! the shared post-processing and deallocate src_structures(:). - ! - ! The TOML and legacy paths are mutually exclusive, so the flat arrays - ! should not yet be allocated when this is called; allocate_struc_flat_arrays - ! defensively deallocates any residual allocation first. - ! - ! Rule expressions (rule_open / rule_close) are handed to - ! sfincs_rule_expression's add_rule, which appends bytecode to its - ! shared stream, registers a new rule, and returns an integer rule_id - ! per structure. finalize_rule_storage is called at the end to shrink - ! the stream and registry to fit (and to allocate zero-length arrays - ! when no rules were seen). - ! ! ------------------------------------------------------------------ - ! why does this marshal exist? + ! Marshal src_structures(:) -> src_struc_* flat arrays. ! - ! the runtime reads all src-structure state from flat per-struct - ! arrays (the struc_* family: struc_type, struc_q, struc_flow_coef, ...). - ! the toml reader, however, naturally produces a derived-type array + ! The runtime reads all src-structure state from flat per-struct + ! arrays (the src_struc_* family: src_struc_type, src_struc_q, src_struc_flow_coef, ...). + ! The TOML reader, however, naturally produces a derived-type array ! src_structures(:) of t_src_structure, which carries allocatable - ! components: character(len=:), allocatable :: name, plus the - ! nested actions(:) and rules(:) arrays. + ! components: character(len=:), allocatable :: name, plus the rule + ! expression strings. ! ! nvfortran's openacc implicit deep-copy of derived types that ! contain allocatable components has been unreliable in practice: ! pushing a type(...), allocatable :: arr(:) with nested allocatables - ! to the device tends to produce runtime issues. flat arrays of + ! to the device tends to produce runtime issues. Flat arrays of ! primitive types (real, integer, fixed-length character) copy ! cleanly across !$acc enter data copyin(...), so we keep the live ! runtime state in those. ! - ! this routine is the one-shot bridge: toml -> src_structures(:) - ! -> struc_* flat arrays -> deallocate(src_structures). after it + ! The marshal is the one-shot bridge: toml -> src_structures(:) + ! -> src_struc_* flat arrays -> deallocate(src_structures). After it ! runs, nothing of the derived-type array survives, so no gpu ! region ever sees a problematic allocatable-in-derived-type. - ! - ! the legacy fixed-column reader populates the same struc_* flat - ! arrays directly and therefore does not need this marshal; the - ! two input paths converge here. ! ------------------------------------------------------------------ ! - use sfincs_data - ! - implicit none - ! - integer :: i, n, ierr_parse - character(len=256) :: errmsg - ! if (.not. allocated(src_structures)) then ! nr_src_structures = 0 + ! + call write_src_structures_log_summary() + ! return ! endif ! - n = size(src_structures) - nr_src_structures = n + nr_src_structures = size(src_structures) ! - if (n <= 0) then + if (nr_src_structures <= 0) then ! deallocate(src_structures) + ! + call write_src_structures_log_summary() + ! return ! endif ! - call allocate_struc_flat_arrays(n) + ! ------------------------------------------------------------------ + ! Allocate flat arrays to size nr_src_structures and seed defaults. + ! ------------------------------------------------------------------ + ! + allocate(src_struc_nm_in(nr_src_structures)) + allocate(src_struc_nm_out(nr_src_structures)) + allocate(src_struc_nm_obs_1(nr_src_structures)) + allocate(src_struc_nm_obs_2(nr_src_structures)) + allocate(q_src_struc(nr_src_structures)) + allocate(src_struc_type(nr_src_structures)) + allocate(src_struc_distance(nr_src_structures)) + allocate(src_struc_status(nr_src_structures)) + allocate(src_struc_fraction_open(nr_src_structures)) + allocate(src_struc_t_state(nr_src_structures)) + allocate(src_struc_name(nr_src_structures)) + allocate(src_struc_src_1_x(nr_src_structures)) + allocate(src_struc_src_1_y(nr_src_structures)) + allocate(src_struc_src_2_x(nr_src_structures)) + allocate(src_struc_src_2_y(nr_src_structures)) + allocate(src_struc_obs_1_x(nr_src_structures)) + allocate(src_struc_obs_1_y(nr_src_structures)) + allocate(src_struc_obs_2_x(nr_src_structures)) + allocate(src_struc_obs_2_y(nr_src_structures)) + allocate(src_struc_q(nr_src_structures)) + allocate(src_struc_qmax(nr_src_structures)) + allocate(src_struc_flow_coef(nr_src_structures)) + allocate(src_struc_width(nr_src_structures)) + allocate(src_struc_sill_elevation(nr_src_structures)) + allocate(src_struc_mannings_n(nr_src_structures)) + allocate(src_struc_opening_duration(nr_src_structures)) + allocate(src_struc_closing_duration(nr_src_structures)) + allocate(src_struc_rule_open(nr_src_structures)) + allocate(src_struc_rule_close(nr_src_structures)) + allocate(src_struc_rule_open_src(nr_src_structures)) + allocate(src_struc_rule_close_src(nr_src_structures)) + ! + src_struc_rule_open = 0 + src_struc_rule_close = 0 + src_struc_rule_open_src = ' ' + src_struc_rule_close_src = ' ' + ! + src_struc_nm_in = 0 + src_struc_nm_out = 0 + src_struc_nm_obs_1 = 0 + src_struc_nm_obs_2 = 0 + q_src_struc = 0.0 + src_struc_type = 0 + src_struc_distance = 0.0 + src_struc_fraction_open = 1.0 ! 1.0 => no-op multiplier for non-gate types; gates get their real value from the gate-status seeding pass below + src_struc_status = 0 ! 0=closed, 1=open, 2=opening, 3=closing + src_struc_t_state = 0.0 + src_struc_name = ' ' + src_struc_src_1_x = 0.0 + src_struc_src_1_y = 0.0 + src_struc_src_2_x = 0.0 + src_struc_src_2_y = 0.0 + src_struc_obs_1_x = 0.0 + src_struc_obs_1_y = 0.0 + src_struc_obs_2_x = 0.0 + src_struc_obs_2_y = 0.0 + src_struc_q = 0.0 + src_struc_qmax = 1.0e30 + src_struc_flow_coef = 1.0 + src_struc_width = 0.0 + src_struc_sill_elevation = 0.0 + src_struc_mannings_n = 0.024 + src_struc_opening_duration = 600.0 + src_struc_closing_duration = 600.0 ! - ! Copy scalar / vector per-structure fields and parse rule - ! expressions into the shared rule_* stream via add_rule. + ! ------------------------------------------------------------------ + ! Copy scalar / coord / string / parameter fields from src_structures(:) + ! into the flat arrays, and parse rule source strings via add_rule. + ! ------------------------------------------------------------------ ! - do i = 1, n + do i = 1, nr_src_structures ! - ! String fields: truncation warning if longer than struc_name_len. + ! String fields: truncation warning if longer than src_struc_name_len. ! if (allocated(src_structures(i)%name)) then ! - if (len(src_structures(i)%name) > struc_name_len) then + if (len(src_structures(i)%name) > src_struc_name_len) then ! - write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure name length > ', struc_name_len, & + write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure name length > ', src_struc_name_len, & ' at entry ', i, '; truncating' call write_log(logstr, 0) ! endif ! - struc_name(i) = src_structures(i)%name + src_struc_name(i) = src_structures(i)%name ! endif ! - struc_type(i) = int(src_structures(i)%structure_type, 1) + src_struc_type(i) = int(src_structures(i)%structure_type, 1) ! - ! struc_status is runtime-only (not on the TOML type); leave it at - ! the default of 0 (open) set by allocate_struc_flat_arrays. + ! src_struc_status is runtime-only (not on the TOML type); leave it at + ! the default of 0 (closed) set above. ! - struc_src_1_x(i) = src_structures(i)%src_1_x - struc_src_1_y(i) = src_structures(i)%src_1_y - struc_src_2_x(i) = src_structures(i)%src_2_x - struc_src_2_y(i) = src_structures(i)%src_2_y + src_struc_src_1_x(i) = src_structures(i)%src_1_x + src_struc_src_1_y(i) = src_structures(i)%src_1_y + src_struc_src_2_x(i) = src_structures(i)%src_2_x + src_struc_src_2_y(i) = src_structures(i)%src_2_y ! ! obs_1 / obs_2 default to the corresponding src_* when the TOML ! reader did not see the key (tracked via has_obs_1 / has_obs_2). @@ -583,36 +439,36 @@ subroutine marshal_src_structures_to_flat_arrays() ! if (src_structures(i)%has_obs_1) then ! - struc_obs_1_x(i) = src_structures(i)%obs_1_x - struc_obs_1_y(i) = src_structures(i)%obs_1_y + src_struc_obs_1_x(i) = src_structures(i)%obs_1_x + src_struc_obs_1_y(i) = src_structures(i)%obs_1_y ! else ! - struc_obs_1_x(i) = src_structures(i)%src_1_x - struc_obs_1_y(i) = src_structures(i)%src_1_y + src_struc_obs_1_x(i) = src_structures(i)%src_1_x + src_struc_obs_1_y(i) = src_structures(i)%src_1_y ! endif ! if (src_structures(i)%has_obs_2) then ! - struc_obs_2_x(i) = src_structures(i)%obs_2_x - struc_obs_2_y(i) = src_structures(i)%obs_2_y + src_struc_obs_2_x(i) = src_structures(i)%obs_2_x + src_struc_obs_2_y(i) = src_structures(i)%obs_2_y ! else ! - struc_obs_2_x(i) = src_structures(i)%src_2_x - struc_obs_2_y(i) = src_structures(i)%src_2_y + src_struc_obs_2_x(i) = src_structures(i)%src_2_x + src_struc_obs_2_y(i) = src_structures(i)%src_2_y ! endif ! - struc_q(i) = src_structures(i)%q - struc_qmax(i) = src_structures(i)%qmax - struc_flow_coef(i) = src_structures(i)%flow_coef - struc_width(i) = src_structures(i)%width - struc_sill_elevation(i) = src_structures(i)%sill_elevation - struc_mannings_n(i) = src_structures(i)%mannings_n - struc_opening_duration(i) = src_structures(i)%opening_duration - struc_closing_duration(i) = src_structures(i)%closing_duration + src_struc_q(i) = src_structures(i)%q + src_struc_qmax(i) = src_structures(i)%qmax + src_struc_flow_coef(i) = src_structures(i)%flow_coef + src_struc_width(i) = src_structures(i)%width + src_struc_sill_elevation(i) = src_structures(i)%sill_elevation + src_struc_mannings_n(i) = src_structures(i)%mannings_n + src_struc_opening_duration(i) = src_structures(i)%opening_duration + src_struc_closing_duration(i) = src_structures(i)%closing_duration ! ! Parse rule expressions. Missing / empty strings leave the ! rule_id at 0, which the evaluator interprets as "never fires". @@ -621,53 +477,188 @@ subroutine marshal_src_structures_to_flat_arrays() if (allocated(src_structures(i)%rule_open)) then ! call add_rule(src_structures(i)%rule_open, & - struc_rule_open(i), ierr_parse, errmsg) + src_struc_rule_open(i), ierr_parse, errmsg) ! if (ierr_parse /= 0) then ! - write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(struc_name(i)), & - '" rules.open parse failed: ', trim(errmsg) + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & + '" rules_open parse failed: ', trim(errmsg) call write_log(logstr, 1) call stop_sfincs(trim(logstr), -1) ! endif ! - struc_rule_open_src(i) = src_structures(i)%rule_open + src_struc_rule_open_src(i) = src_structures(i)%rule_open ! endif ! if (allocated(src_structures(i)%rule_close)) then ! call add_rule(src_structures(i)%rule_close, & - struc_rule_close(i), ierr_parse, errmsg) + src_struc_rule_close(i), ierr_parse, errmsg) ! if (ierr_parse /= 0) then ! - write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(struc_name(i)), & - '" rules.close parse failed: ', trim(errmsg) + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & + '" rules_close parse failed: ', trim(errmsg) call write_log(logstr, 1) call stop_sfincs(trim(logstr), -1) ! endif ! - struc_rule_close_src(i) = src_structures(i)%rule_close + src_struc_rule_close_src(i) = src_structures(i)%rule_close ! endif ! enddo ! - ! Shrink the shared rule stream to exactly the concatenated length. + ! ------------------------------------------------------------------ + ! Shrink the shared rule bytecode stream to exactly the concatenated + ! length (also allocates zero-length arrays when no rules were seen). + ! ------------------------------------------------------------------ ! call finalize_rule_storage() ! - ! Shared post-processing. - ! - call finalize_src_structures_state() - ! + ! ------------------------------------------------------------------ ! Drop the derived-type array; flat arrays carry all runtime state now. + ! ------------------------------------------------------------------ ! deallocate(src_structures) ! + ! ------------------------------------------------------------------ + ! Resolve cell-index lookups (src_struc_nm_in / _out / _obs_1 / _obs_2) + ! and centre-to-centre distance from coordinate pairs. + ! ------------------------------------------------------------------ + ! + do istruc = 1, nr_src_structures + ! + nmq = find_quadtree_cell(src_struc_src_1_x(istruc), src_struc_src_1_y(istruc)) + if (nmq > 0) src_struc_nm_in(istruc) = index_sfincs_in_quadtree(nmq) + ! + nmq = find_quadtree_cell(src_struc_src_2_x(istruc), src_struc_src_2_y(istruc)) + if (nmq > 0) src_struc_nm_out(istruc) = index_sfincs_in_quadtree(nmq) + ! + ! obs cell indices feed the gate rule evaluator. The marshal has + ! already defaulted obs_*_x/y to src_*_x/y when the TOML reader + ! did not see the keys, so this lookup gives us obs_1 == src_1 + ! and obs_2 == src_2 for those cases without extra branching. + ! + nmq = find_quadtree_cell(src_struc_obs_1_x(istruc), src_struc_obs_1_y(istruc)) + if (nmq > 0) src_struc_nm_obs_1(istruc) = index_sfincs_in_quadtree(nmq) + ! + nmq = find_quadtree_cell(src_struc_obs_2_x(istruc), src_struc_obs_2_y(istruc)) + if (nmq > 0) src_struc_nm_obs_2(istruc) = index_sfincs_in_quadtree(nmq) + ! + if (src_struc_nm_in(istruc) > 0 .and. src_struc_nm_out(istruc) > 0) then + ! + xsnk_tmp = z_xz(src_struc_nm_in(istruc)) + ysnk_tmp = z_yz(src_struc_nm_in(istruc)) + xsrc_tmp = z_xz(src_struc_nm_out(istruc)) + ysrc_tmp = z_yz(src_struc_nm_out(istruc)) + src_struc_distance(istruc) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + ! + endif + ! + enddo + ! + if (any(src_struc_nm_in == 0) .or. any(src_struc_nm_out == 0)) then + ! + write(logstr,'(a)') 'Warning ! For some sink/source drainage points no matching active grid cell was found!' + call write_log(logstr, 0) + write(logstr,'(a)') 'Warning ! These points will be skipped, please check your input!' + call write_log(logstr, 0) + ! + endif + ! + ! ------------------------------------------------------------------ + ! Write the per-structure descriptive block to the log file. + ! Emitted before the gate-status seeding so the per-gate init status + ! lines trail the structure block they annotate. + ! ------------------------------------------------------------------ + ! + call write_src_structures_log_summary() + ! + ! ------------------------------------------------------------------ + ! Gate-specific initial status from the current zs field. + ! + ! zs(:) has already been populated by initialize_domain -> initialize_hydro + ! -> set_initial_conditions by the time we get here, so obs-point lookups + ! against zs are valid. For non-gate structures the defaults assigned + ! above (status=0=closed, fraction_open=1.0) already encode "no-op". + ! + ! Status encoding: 0=closed, 1=open, 2=opening, 3=closing. + ! ------------------------------------------------------------------ + ! + do istruc = 1, nr_src_structures + ! + if (src_struc_type(istruc) /= structure_gate) cycle + ! + nm1 = src_struc_nm_obs_1(istruc) + nm2 = src_struc_nm_obs_2(istruc) + ! + if (nm1 > 0) then + ! + z1 = real(zs(nm1), 4) + ! + else + ! + z1 = 0.0 + ! + endif + ! + if (nm2 > 0) then + ! + z2 = real(zs(nm2), 4) + ! + else + ! + z2 = 0.0 + ! + endif + ! + open_fires = evaluate_rule(src_struc_rule_open(istruc), z1, z2) + close_fires = evaluate_rule(src_struc_rule_close(istruc), z1, z2) + ! + if (open_fires .and. .not. close_fires) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + status_str = 'open' + ! + elseif (.not. open_fires .and. close_fires) then + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + elseif (open_fires .and. close_fires) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + status_str = 'open' + write(logstr,'(a,a,a)')'Warning ! gate ', trim(src_struc_name(istruc)), & + ': both open and close rules fire at init; keeping gate open' + call write_log(logstr, 0) + ! + else + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + endif + ! + ! Transition timer is only consulted after a transition triggers; + ! seed with t0 so the first rule-driven transition has a sane baseline. + ! + src_struc_t_state(istruc) = t0 + ! + write(logstr,'(a,a,a,a)')'gate ', trim(src_struc_name(istruc)), & + ' initialised status=', trim(status_str) + call write_log(logstr, 0) + ! + enddo + ! end subroutine ! ! @@ -675,7 +666,7 @@ subroutine update_src_structures(t, dt, tloop) ! ! Compute discharges through each drainage structure, accumulate them ! into qsrc(np) (intake: -qq, outfall: +qq), and store per-structure - ! signed discharge in qstruc(nr_src_structures) for his output. + ! signed discharge in q_src_struc(nr_src_structures) for his output. ! ! Called AFTER update_discharges, which zeros qsrc first. ! @@ -693,47 +684,47 @@ subroutine update_src_structures(t, dt, tloop) integer :: count0, count1, count_rate, count_max integer :: istruc, nmin, nmout, nm_o1, nm_o2 real*4 :: qq, qqmax, elapsed, z1r, z2r - real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0 + real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha logical :: open_fires, close_fires ! if (nr_src_structures <= 0) return ! call system_clock(count0, count_rate, count_max) ! - !$acc parallel loop present( z_volume, zs, zb, qsrc, qstruc, & - !$acc struc_nm_in, struc_nm_out, & - !$acc struc_nm_obs_1, struc_nm_obs_2, & - !$acc struc_type, & - !$acc struc_q, struc_qmax, struc_flow_coef, & - !$acc struc_width, struc_sill_elevation, & - !$acc struc_mannings_n, & - !$acc struc_opening_duration, struc_closing_duration, & - !$acc struc_distance, struc_status, struc_fraction_open, & - !$acc struc_t_state, & - !$acc struc_rule_open, struc_rule_close, & + !$acc parallel loop present( z_volume, zs, zb, qsrc, q_src_struc, & + !$acc src_struc_nm_in, src_struc_nm_out, & + !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & + !$acc src_struc_type, & + !$acc src_struc_q, src_struc_qmax, src_struc_flow_coef, & + !$acc src_struc_width, src_struc_sill_elevation, & + !$acc src_struc_mannings_n, & + !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, & + !$acc src_struc_t_state, & + !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, & !$acc rule_start, rule_length ) & !$acc private( nmin, nmout, nm_o1, nm_o2, qq, qqmax, elapsed, & - !$acc z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, & + !$acc z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & !$acc open_fires, close_fires ) !$omp parallel do & !$omp private( nmin, nmout, nm_o1, nm_o2, qq, qqmax, elapsed, & - !$omp z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, & + !$omp z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & !$omp open_fires, close_fires ) & !$omp schedule ( static ) do istruc = 1, nr_src_structures ! - nmin = struc_nm_in(istruc) - nmout = struc_nm_out(istruc) - qqmax = struc_qmax(istruc) + nmin = src_struc_nm_in(istruc) + nmout = src_struc_nm_out(istruc) + qqmax = src_struc_qmax(istruc) ! if (nmin > 0 .and. nmout > 0) then ! - select case(struc_type(istruc)) + select case(src_struc_type(istruc)) ! case(structure_pump) ! - qq = struc_q(istruc) + qq = src_struc_q(istruc) ! case(structure_culvert) ! @@ -741,11 +732,11 @@ subroutine update_src_structures(t, dt, tloop) ! if (zs(nmin) > zs(nmout)) then ! - qq = struc_flow_coef(istruc) * sqrt(zs(nmin) - zs(nmout)) + qq = src_struc_flow_coef(istruc) * sqrt(zs(nmin) - zs(nmout)) ! else ! - qq = -struc_flow_coef(istruc) * sqrt(zs(nmout) - zs(nmin)) + qq = -src_struc_flow_coef(istruc) * sqrt(zs(nmout) - zs(nmin)) ! endif ! @@ -755,7 +746,7 @@ subroutine update_src_structures(t, dt, tloop) ! ! One-way: flow only when z(in) > z(out); clipped to [0, qmax]. ! - qq = struc_flow_coef(istruc) * sqrt(max(0.0, zs(nmin) - zs(nmout))) + qq = src_struc_flow_coef(istruc) * sqrt(max(0.0, zs(nmin) - zs(nmout))) qq = min(qq, qqmax) ! case(structure_gate) @@ -768,8 +759,8 @@ subroutine update_src_structures(t, dt, tloop) ! the terminal (0) and (1) states; transient states (2, 3) ! advance purely on elapsed time so they cannot thrash. ! - nm_o1 = struc_nm_obs_1(istruc) - nm_o2 = struc_nm_obs_2(istruc) + nm_o1 = src_struc_nm_obs_1(istruc) + nm_o2 = src_struc_nm_obs_2(istruc) ! if (nm_o1 > 0) then ! @@ -791,18 +782,18 @@ subroutine update_src_structures(t, dt, tloop) ! endif ! - select case (int(struc_status(istruc))) + select case (int(src_struc_status(istruc))) ! case (0) ! ! closed - look for an open trigger ! - open_fires = evaluate_rule(struc_rule_open(istruc), z1r, z2r) + open_fires = evaluate_rule(src_struc_rule_open(istruc), z1r, z2r) ! if (open_fires) then ! - struc_status(istruc) = 2 - struc_t_state(istruc) = real(t, 4) + src_struc_status(istruc) = 2 + src_struc_t_state(istruc) = real(t, 4) ! endif ! @@ -810,12 +801,12 @@ subroutine update_src_structures(t, dt, tloop) ! ! open - look for a close trigger ! - close_fires = evaluate_rule(struc_rule_close(istruc), z1r, z2r) + close_fires = evaluate_rule(src_struc_rule_close(istruc), z1r, z2r) ! if (close_fires) then ! - struc_status(istruc) = 3 - struc_t_state(istruc) = real(t, 4) + src_struc_status(istruc) = 3 + src_struc_t_state(istruc) = real(t, 4) ! endif ! @@ -823,17 +814,17 @@ subroutine update_src_structures(t, dt, tloop) ! ! opening - advance on elapsed time; do not re-check rules ! - elapsed = real(t, 4) - struc_t_state(istruc) + elapsed = real(t, 4) - src_struc_t_state(istruc) ! - if (struc_opening_duration(istruc) <= 0.0 .or. & - elapsed >= struc_opening_duration(istruc)) then + if (src_struc_opening_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_opening_duration(istruc)) then ! - struc_status(istruc) = 1 - struc_fraction_open(istruc) = 1.0 + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 ! else ! - struc_fraction_open(istruc) = elapsed / struc_opening_duration(istruc) + src_struc_fraction_open(istruc) = elapsed / src_struc_opening_duration(istruc) ! endif ! @@ -841,17 +832,17 @@ subroutine update_src_structures(t, dt, tloop) ! ! closing - advance on elapsed time; do not re-check rules ! - elapsed = real(t, 4) - struc_t_state(istruc) + elapsed = real(t, 4) - src_struc_t_state(istruc) ! - if (struc_closing_duration(istruc) <= 0.0 .or. & - elapsed >= struc_closing_duration(istruc)) then + if (src_struc_closing_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_closing_duration(istruc)) then ! - struc_status(istruc) = 0 - struc_fraction_open(istruc) = 0.0 + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 ! else ! - struc_fraction_open(istruc) = 1.0 - elapsed / struc_closing_duration(istruc) + src_struc_fraction_open(istruc) = 1.0 - elapsed / src_struc_closing_duration(istruc) ! endif ! @@ -863,25 +854,25 @@ subroutine update_src_structures(t, dt, tloop) ! (1 + g*n^2*dt*|q^n| / h^{7/3}) ! with h = max(max(zs_in, zs_out) - zsill, 0). ! Multiply by width * fraction_open to get the structure - ! discharge. qstruc(istruc) holds q from the previous step + ! discharge. q_src_struc(istruc) holds q from the previous step ! in full (signed, m^3/s) discharge form, so convert via ! width * fraction_open to get qq0 in per-unit-width units. ! Sign convention: qq > 0 means flow nmin -> nmout, matching ! dzds = (zs_out - zs_in)/dist (positive downstream level ! -> negative dzds -> positive qq). ! - frac = struc_fraction_open(istruc) - wdt = struc_width(istruc) - mng = struc_mannings_n(istruc) - zsill = struc_sill_elevation(istruc) - dist = struc_distance(istruc) + frac = src_struc_fraction_open(istruc) + wdt = src_struc_width(istruc) + mng = src_struc_mannings_n(istruc) + zsill = src_struc_sill_elevation(istruc) + dist = src_struc_distance(istruc) ! dzds = (real(zs(nmout), 4) - real(zs(nmin), 4)) / dist hgate = max(max(real(zs(nmin), 4), real(zs(nmout), 4)) - zsill, 0.0) ! if (hgate > 0.0 .and. frac > 0.0) then ! - qq0 = qstruc(istruc) / (wdt * max(frac, 0.001)) + qq0 = q_src_struc(istruc) / (wdt * max(frac, 0.001)) qq = (qq0 - g * hgate * dzds * dt) / & (1.0 + g * mng * mng * dt * abs(qq0) / hgate**(7.0/3.0)) qq = qq * wdt * frac @@ -897,15 +888,9 @@ subroutine update_src_structures(t, dt, tloop) end select ! ! Relaxation: blend new and previous discharge to damp oscillations. - ! Gates use the Bates (2010) inertial form which already carries - ! its own temporal inertia via qq0; additional blending would - ! double-damp and suppress the dynamic response. ! - if (struc_type(istruc) /= structure_gate) then - ! - qq = 1.0 / (structure_relax / dt) * qq + (1.0 - (1.0 / (structure_relax / dt))) * qstruc(istruc) - ! - endif + alpha = dt / structure_relax + qq = alpha * qq + (1.0 - alpha) * q_src_struc(istruc) ! ! Limit discharge by available volume in the intake / outfall cell. ! @@ -935,7 +920,7 @@ subroutine update_src_structures(t, dt, tloop) ! endif ! - qstruc(istruc) = qq + q_src_struc(istruc) = qq ! ! Accumulate into cell-wise qsrc. Atomic guards against multiple ! structures (or a river and a structure) in the same cell. @@ -976,8 +961,8 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! width = ... ; sill_elevation = ... ; mannings_n = ... ! opening_duration = ... ; closing_duration = ... ! flow_coef = ... ! culvert / check_valve flow coefficient - ! rules.open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr - ! rules.close = "z2>2.0" ! optional trigger expr + ! rules_open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr + ! rules_close = "z2>2.0" ! optional trigger expr ! ! Per-type required keys (enforced on parse): ! pump : name, src_1_x, src_1_y, src_2_x, src_2_y, q @@ -1003,9 +988,9 @@ subroutine read_toml_src_structures(filename, structures, ierr) type(toml_table), allocatable :: top type(toml_error), allocatable :: err type(toml_array), pointer :: arr_structs - type(toml_table), pointer :: tbl_struct, tbl_rules + type(toml_table), pointer :: tbl_struct character(len=:), allocatable :: name_str, type_str, rule_str - integer :: n_struct, i, stat + integer :: n_struct, i, stat, ierr_parse ! ierr = 0 ! @@ -1094,10 +1079,11 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! endif ! - call parse_structure_type(type_str, structures(i)%structure_type, ierr) + call parse_structure_type(type_str, structures(i)%structure_type, ierr_parse) ! - if (ierr /= 0) then + if (ierr_parse /= 0) then ! + ierr = ierr_parse write(logstr,'(a,a,a,i0)')' Error ! Unknown structure type "', trim(type_str), & '" in src_structure entry ', i call write_log(logstr, 1) @@ -1171,24 +1157,17 @@ subroutine read_toml_src_structures(filename, structures, ierr) call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 600.0, stat=stat) call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 1.0, stat=stat) ! - ! Optional rules sub-table with string "open" / "close" expressions. - ! Absent sub-table, or absent keys within it, leaves the rule strings - ! unallocated on the derived type; marshal treats that as "no trigger". + ! Optional rules_open / rules_close string expressions. Absent keys + ! leave the rule strings unallocated on the derived type; marshal + ! treats that as "no trigger". ! - nullify(tbl_rules) - call get_value(tbl_struct, 'rules', tbl_rules, requested=.false., stat=stat) + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_struct, 'rules_open', rule_str, stat=stat) + if (allocated(rule_str)) structures(i)%rule_open = rule_str ! - if (associated(tbl_rules)) then - ! - if (allocated(rule_str)) deallocate(rule_str) - call get_value(tbl_rules, 'open', rule_str, stat=stat) - if (allocated(rule_str)) structures(i)%rule_open = rule_str - ! - if (allocated(rule_str)) deallocate(rule_str) - call get_value(tbl_rules, 'close', rule_str, stat=stat) - if (allocated(rule_str)) structures(i)%rule_close = rule_str - ! - endif + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_struct, 'rules_close', rule_str, stat=stat) + if (allocated(rule_str)) structures(i)%rule_close = rule_str ! enddo ! @@ -1309,101 +1288,6 @@ function to_lower(str) result(lower) end function ! ! - subroutine initialize_gate_status() - ! - ! Seed each gate's status and fraction_open from the initial water-level - ! field. Called right after the marshal, by which point zs(:) has already - ! been populated by initialize_hydro -> set_initial_conditions. For - ! non-gate structures the defaults from allocate_struc_flat_arrays - ! (status=0=closed, fraction_open=1.0) already encode "no-op"; we only - ! touch rows where struc_type == structure_gate. - ! - ! Status encoding: 0=closed, 1=open, 2=opening, 3=closing. - ! - use sfincs_data - ! - implicit none - ! - integer :: istruc, nm1, nm2 - real :: z1, z2 - logical :: open_fires, close_fires - character(len=16) :: status_str - ! - if (nr_src_structures <= 0) return - ! - do istruc = 1, nr_src_structures - ! - if (struc_type(istruc) /= structure_gate) cycle - ! - nm1 = struc_nm_obs_1(istruc) - nm2 = struc_nm_obs_2(istruc) - ! - if (nm1 > 0) then - ! - z1 = real(zs(nm1), 4) - ! - else - ! - z1 = 0.0 - ! - endif - ! - if (nm2 > 0) then - ! - z2 = real(zs(nm2), 4) - ! - else - ! - z2 = 0.0 - ! - endif - ! - open_fires = evaluate_rule(struc_rule_open(istruc), z1, z2) - close_fires = evaluate_rule(struc_rule_close(istruc), z1, z2) - ! - if (open_fires .and. .not. close_fires) then - ! - struc_status(istruc) = 1 - struc_fraction_open(istruc) = 1.0 - status_str = 'open' - ! - elseif (.not. open_fires .and. close_fires) then - ! - struc_status(istruc) = 0 - struc_fraction_open(istruc) = 0.0 - status_str = 'closed' - ! - elseif (open_fires .and. close_fires) then - ! - struc_status(istruc) = 1 - struc_fraction_open(istruc) = 1.0 - status_str = 'open' - write(logstr,'(a,a,a)')'Warning ! gate ', trim(struc_name(istruc)), & - ': both open and close rules fire at init; keeping gate open' - call write_log(logstr, 0) - ! - else - ! - struc_status(istruc) = 0 - struc_fraction_open(istruc) = 0.0 - status_str = 'closed' - ! - endif - ! - ! Transition timer is only consulted after a transition triggers; - ! seed with t0 so the first rule-driven transition has a sane baseline. - ! - struc_t_state(istruc) = t0 - ! - write(logstr,'(a,a,a,a)')'gate ', trim(struc_name(istruc)), & - ' initialised status=', trim(status_str) - call write_log(logstr, 0) - ! - enddo - ! - end subroutine - ! - ! subroutine write_src_structures_log_summary() ! ! Emit a one-block-per-structure description of every parsed src @@ -1427,7 +1311,7 @@ subroutine write_src_structures_log_summary() ! do i = 1, nr_src_structures ! - select case (int(struc_type(i))) + select case (int(src_struc_type(i))) ! case (structure_pump) ! @@ -1454,84 +1338,84 @@ subroutine write_src_structures_log_summary() write(logstr,'(a,i0,a)')'Structure ', i, ':' call write_log(logstr, 0) ! - write(logstr,'(a,a)')' name: ', trim(struc_name(i)) + write(logstr,'(a,a)')' name: ', trim(src_struc_name(i)) call write_log(logstr, 0) ! write(logstr,'(a,a)')' type: ', trim(type_str) call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a,f0.3,a)')' src_1: (', struc_src_1_x(i), ', ', struc_src_1_y(i), ')' + write(logstr,'(a,f0.3,a,f0.3,a)')' src_1: (', src_struc_src_1_x(i), ', ', src_struc_src_1_y(i), ')' call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a,f0.3,a)')' src_2: (', struc_src_2_x(i), ', ', struc_src_2_y(i), ')' + write(logstr,'(a,f0.3,a,f0.3,a)')' src_2: (', src_struc_src_2_x(i), ', ', src_struc_src_2_y(i), ')' call write_log(logstr, 0) ! ! obs coords are meaningful for culvert / check_valve / gate. ! - if (struc_type(i) == structure_culvert .or. & - struc_type(i) == structure_check_valve .or. & - struc_type(i) == structure_gate) then + if (src_struc_type(i) == structure_culvert .or. & + src_struc_type(i) == structure_check_valve .or. & + src_struc_type(i) == structure_gate) then ! - write(logstr,'(a,f0.3,a,f0.3,a)')' obs_1: (', struc_obs_1_x(i), ', ', struc_obs_1_y(i), ')' + write(logstr,'(a,f0.3,a,f0.3,a)')' obs_1: (', src_struc_obs_1_x(i), ', ', src_struc_obs_1_y(i), ')' call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a,f0.3,a)')' obs_2: (', struc_obs_2_x(i), ', ', struc_obs_2_y(i), ')' + write(logstr,'(a,f0.3,a,f0.3,a)')' obs_2: (', src_struc_obs_2_x(i), ', ', src_struc_obs_2_y(i), ')' call write_log(logstr, 0) ! endif ! - if (struc_type(i) == structure_pump) then + if (src_struc_type(i) == structure_pump) then ! - write(logstr,'(a,f0.4,a)')' discharge: ', struc_q(i), ' (m3/s)' + write(logstr,'(a,f0.4,a)')' discharge: ', src_struc_q(i), ' (m3/s)' call write_log(logstr, 0) ! endif ! - if (struc_type(i) == structure_culvert .or. & - struc_type(i) == structure_check_valve .or. & - struc_type(i) == structure_gate) then + if (src_struc_type(i) == structure_culvert .or. & + src_struc_type(i) == structure_check_valve .or. & + src_struc_type(i) == structure_gate) then ! - write(logstr,'(a,es12.4,a)')' qmax: ', struc_qmax(i), ' (m3/s)' + write(logstr,'(a,es12.4,a)')' qmax: ', src_struc_qmax(i), ' (m3/s)' call write_log(logstr, 0) ! endif ! - if (struc_type(i) == structure_culvert .or. & - struc_type(i) == structure_check_valve) then + if (src_struc_type(i) == structure_culvert .or. & + src_struc_type(i) == structure_check_valve) then ! - write(logstr,'(a,f0.4)')' flow_coef: ', struc_flow_coef(i) + write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) call write_log(logstr, 0) ! endif ! - if (struc_type(i) == structure_gate) then + if (src_struc_type(i) == structure_gate) then ! - write(logstr,'(a,f0.4,a)')' width: ', struc_width(i), ' (m)' + write(logstr,'(a,f0.4,a)')' width: ', src_struc_width(i), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4,a)')' sill_elev.: ', struc_sill_elevation(i), ' (m)' + write(logstr,'(a,f0.4,a)')' sill_elev.: ', src_struc_sill_elevation(i), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4)')' mannings_n: ', struc_mannings_n(i) + write(logstr,'(a,f0.4)')' mannings_n: ', src_struc_mannings_n(i) call write_log(logstr, 0) ! - write(logstr,'(a,f0.2,a)')' opening: ', struc_opening_duration(i), ' (s)' + write(logstr,'(a,f0.2,a)')' opening: ', src_struc_opening_duration(i), ' (s)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.2,a)')' closing: ', struc_closing_duration(i), ' (s)' + write(logstr,'(a,f0.2,a)')' closing: ', src_struc_closing_duration(i), ' (s)' call write_log(logstr, 0) ! endif ! - if (struc_rule_open(i) > 0) then + if (src_struc_rule_open(i) > 0) then ! - if (len_trim(struc_rule_open_src(i)) > 0) then + if (len_trim(src_struc_rule_open_src(i)) > 0) then ! - write(logstr,'(a,a,a)')' rules.open: "', trim(struc_rule_open_src(i)), '"' + write(logstr,'(a,a,a)')' rules_open: "', trim(src_struc_rule_open_src(i)), '"' ! else ! - write(logstr,'(a)')' rules.open: (set)' + write(logstr,'(a)')' rules_open: (set)' ! endif ! @@ -1539,15 +1423,15 @@ subroutine write_src_structures_log_summary() ! endif ! - if (struc_rule_close(i) > 0) then + if (src_struc_rule_close(i) > 0) then ! - if (len_trim(struc_rule_close_src(i)) > 0) then + if (len_trim(src_struc_rule_close_src(i)) > 0) then ! - write(logstr,'(a,a,a)')' rules.close: "', trim(struc_rule_close_src(i)), '"' + write(logstr,'(a,a,a)')' rules_close: "', trim(src_struc_rule_close_src(i)), '"' ! else ! - write(logstr,'(a)')' rules.close: (set)' + write(logstr,'(a)')' rules_close: (set)' ! endif ! @@ -1572,6 +1456,11 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) ! Schedule-triggered gates (legacy dtype 5) are refused; the new rule ! grammar is water-level-only and has no time atom. ! + ! The output path is derived from legacy_path: if it ends in ".drn" + ! (case-insensitive) the suffix ".toml" is inserted before the ".drn", + ! otherwise ".toml" is appended. The resolved path is returned in + ! toml_path for the caller to feed into the TOML reader. + ! ! The converter is deliberately minimal: no coord sanity checks, no ! duplicate-name detection, no preservation of comments. It exists only ! to remove the parallel legacy parsing machinery that used to live @@ -1580,10 +1469,11 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) implicit none ! character(len=*), intent(in) :: legacy_path - character(len=*), intent(in) :: toml_path + character(len=*), intent(out) :: toml_path integer, intent(out) :: ierr ! integer :: u_in, u_out, stat, n_struct, dtype + integer :: len_in, ext_pos real*4 :: x2, y2, x1, y1, par real*4 :: g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls character(len=512) :: line, trimmed @@ -1597,6 +1487,33 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) u_in = 501 u_out = 502 ! + ! Derive the TOML sibling path from legacy_path. If legacy_path ends + ! in ".drn" (case-insensitive), insert ".toml" before the extension; + ! else append ".toml". + ! + len_in = len_trim(legacy_path) + ext_pos = 0 + ! + if (len_in >= 4) then + ! + if (to_lower(legacy_path(len_in-3:len_in)) == '.drn') then + ! + ext_pos = len_in - 3 + ! + endif + ! + endif + ! + if (ext_pos > 0) then + ! + toml_path = legacy_path(1:ext_pos-1) // '.toml' // legacy_path(ext_pos:len_in) + ! + else + ! + toml_path = legacy_path(1:len_in) // '.toml' + ! + endif + ! open(u_in, file=trim(legacy_path), status='old', action='read', iostat=stat) ! if (stat /= 0) then @@ -1637,10 +1554,10 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) if (len_trim(trimmed) == 0) cycle if (trimmed(1:1) == '#' .or. trimmed(1:1) == '!') cycle ! - ! Columns: x2, y2, x1, y1, dtype, par. - ! (legacy snk -> src_2; legacy src -> src_1). + ! Columns: x1, y1, x2, y2, dtype, par. + ! (legacy xsnk=intake -> src_1; legacy xsrc=outfall -> src_2). ! - read(line, *, iostat=stat) x2, y2, x1, y1, dtype, par + read(line, *, iostat=stat) x1, y1, x2, y2, dtype, par ! if (stat /= 0) then ! @@ -1680,7 +1597,7 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) ! width, sill_elevation, mannings_n, zmin, zmax, t_close. ! Re-read the whole line to pull those extra columns. ! - read(line, *, iostat=stat) x2, y2, x1, y1, dtype, & + read(line, *, iostat=stat) x1, y1, x2, y2, dtype, & g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls ! if (stat /= 0) then @@ -1727,8 +1644,8 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) write(u_out,'(a,es14.6)') 'mannings_n = ', g_mann write(u_out,'(a,es14.6)') 'opening_duration = ', g_tcls write(u_out,'(a,es14.6)') 'closing_duration = ', g_tcls - write(u_out,'(a,a,a)') 'rules.open = "', trim(rule_open_str), '"' - write(u_out,'(a,a,a)') 'rules.close = "', trim(rule_close_str), '"' + write(u_out,'(a,a,a)') 'rules_open = "', trim(rule_open_str), '"' + write(u_out,'(a,a,a)') 'rules_close = "', trim(rule_close_str), '"' write(u_out,'(a)') '' ! cycle From 29937f267dbf85b2596a51635cd0d91d1616870e Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sat, 18 Apr 2026 20:27:23 +0200 Subject: [PATCH 27/65] Implement TOML drainage structures and gates Add full support for TOML-based drainage structures and expand structure semantics. Documentation (docs/input_structures.rst) rewritten to describe the new TOML schema, rule grammar, culvert/gate/pump types, examples, legacy .drn transcription guidance, and clarifications. Add docs/_build to .gitignore. Fortran changes: introduce new structure kinds and direction codes, extra per-structure parameters (height, invert_1/2, submergence_ratio, etc.), allocate and initialize the new arrays, and update OpenACC data lists. Improve comments and subroutine summaries in sfincs_discharges.f90 and sfincs_src_structures.f90. Change default structure_relax from 10.0 to 4.0 in sfincs_input.f90. Also adjust initial state/seeding logic (default structures open, rule-driven seeding for gated structures) and map legacy check_valve/legacy .drn handling to the new TOML format. --- .gitignore | 1 + docs/input_structures.rst | 493 ++++++++++++++--- source/src/sfincs_discharges.f90 | 26 +- source/src/sfincs_input.f90 | 2 +- source/src/sfincs_openacc.f90 | 12 +- source/src/sfincs_src_structures.f90 | 800 ++++++++++++++++++++------- 6 files changed, 1069 insertions(+), 265 deletions(-) diff --git a/.gitignore b/.gitignore index bfe26a593..1f2f22b60 100644 --- a/.gitignore +++ b/.gitignore @@ -68,3 +68,4 @@ source/sfincs/sfincs.opt.yaml # Local Claude Code agents / settings (not shared with co-developers) .claude/ +/docs/_build diff --git a/docs/input_structures.rst b/docs/input_structures.rst index 82847e3c4..17038ceef 100644 --- a/docs/input_structures.rst +++ b/docs/input_structures.rst @@ -5,10 +5,9 @@ Overview ----- The input for SFINCS is supplied using various text and binary files, which are linked through the main input file: sfincs.inp. -Within this section of the user manual all different types of structures to reduce flood hazards with input settings and files are discussed. -The figure below gives an overview of all different types of input files and whether they are required or not. -Below an example is given of this file, which uses a keyword/value layout. -For more information regarding specific parameters see the pages 'Input parameters' or 'Output parameters'. +This section of the user manual describes the different types of structures that can be used to represent flood hazard reduction measures, together with their input settings and files. +The figure below gives an overview of the input files and indicates whether each one is required or optional. +For more information regarding specific parameters, see the pages 'Input parameters' or 'Output parameters'. **NOTE - In the manual below, blocks named 'Python example using HydroMT-SFINCS' are included, referring to easy setup functions of the HydroMT-SFINCS Python toolbox: https://deltares.github.io/hydromt_sfincs/latest/** @@ -16,18 +15,18 @@ For more information regarding specific parameters see the pages 'Input paramete :width: 800px :align: center - Overview of input file of SFINCS with indication whther they are required or not + Overview of input file of SFINCS with indication whether they are required or not -Structures ------ +Flow-blocking structures +------------------------ -SFINCS consists of multiple options for adding structures that can divert or block flow of water, which can be used to simulate flood hazard reduction methods. +SFINCS provides several types of structures that block or throttle the flow of water between grid cells, which can be used to simulate flood hazard reduction measures. Thin dam ^^^^^ -With a thin dam flow through certain grid cells is completely blocked (i.e. an infinitely high wall). -One can provide multiple polylines within one file, a maximum of 5000 supplied points is supported. +A thin dam blocks the cell-to-cell connections (u/v faces) that the polyline snaps to, acting as an infinitely high wall along those faces. Flow parallel to the dam is unaffected — only the normal-component fluxes across the snapped faces are set to zero. +Multiple polylines can be supplied within a single file. The supplied polylines are snapped onto the SFINCS grid within the model. .. figure:: ./figures/SFINCS_thindam_grid.png @@ -77,14 +76,27 @@ The supplied polylines are snapped onto the SFINCS grid within the model. Weirs ^^^^^ -Weirs are in principle the same as a thin dam, but then with a certain height (levee). -When the water level on either or both sides of the weir are higher than that of the weir, a flux over the weir is calculated. -Hereby a situation where the weir is partly or fully submerged is distinguished. -Besides the x&y locations per points, also the elevation z and a Cd coefficient for the weir formula (recommended to use 0.6). +Weirs are similar to a thin dam, but with a finite crest elevation (like a levee). +When the water level on either or both sides of the weir is higher than the weir crest, a flux over the weir is calculated. +A distinction is made between free (modular) flow and submerged flow, using a broad-crested weir formula: + +.. math:: + + q = + \begin{cases} + C_d \cdot 1.7049 \cdot h_1^{3/2}, & h_2 \le \tfrac{2}{3}\, h_1 \quad\text{(free flow)} \\ + C_d \cdot h_2 \cdot \sqrt{2\, g\, (h_1 - h_2)}, & h_2 > \tfrac{2}{3}\, h_1 \quad\text{(submerged)} + \end{cases} + +where :math:`h_1 = \max(z_{s,\text{up}} - z_\text{weir},\, 0)` is the head above the crest on the upstream side, :math:`h_2 = \max(z_{s,\text{dn}} - z_\text{weir},\, 0)` is the head on the downstream side, :math:`z_\text{weir}` is the user-supplied crest elevation, :math:`C_d` is the user-supplied discharge coefficient (0.6 is a typical value), and :math:`g = 9.81` m/s². The discharge :math:`q` is per unit width; SFINCS multiplies by the length of the weir segment inside each grid cell. The constant 1.7049 is :math:`\tfrac{2}{3}\sqrt{\tfrac{2}{3} g}`, the standard broad-crested free-flow coefficient. + +Each point in the weir file carries its x and y location, the crest elevation z, and the :math:`C_d` coefficient. The supplied polylines are snapped onto the SFINCS grid within the model. -While running SFINCS the number of structure uv points found is displayed, e.g.: - Info : 7932 structure u/v points found -Note that SFINCS displays the points found after snapping to the grid (max 2 per grid cell), not how many were specified in the input. +While running SFINCS, the number of structure uv-points found (after snapping) is displayed, e.g.:: + + Info : 7932 structure u/v points found + +Note that this is the count after snapping to the grid (at most 2 per grid cell), not the number of points supplied in the input. The snapped coordinates are available in sfincs_his.nc as structure_x, structure_y & structure_height from SFINCS v2.0.2 onwards. @@ -131,30 +143,38 @@ The snapped coordinates are available in sfincs_his.nc as structure_x, structure **NOTE - If your weir elevation is unknown a priori, you can also let HydroMT-SFINCS derive this from an input (low-resolution) DEM by specifying 'dep' and adding a certain assumed elevation 'dz'** -Drainage Pumps and Culverts -^^^^^ +Drainage Structures +------------------- + +.. important:: -**Introduction** + **Drainage structures do not block flow.** They simply transfer water + from one grid cell (the intake, ``src_1``) to another (the outfall, + ``src_2``), without representing any physical barrier. If the drainage + path passes through an embankment, dam face, or culvert wall that is + not already resolved by the model topography, that blocking + geometry must be added separately using a thin dam or a weir. Without + it, water will simply flow around the drainage structure as if it were + not there. -In SFINCS, drainage pumps, culverts and check valves (one way culverts) are specified using the same input file format, with the structure type distinguished by an indicator: +**Overview** -- type=1: Drainage pump -- type=2: Culvert -- type=3: Check valve +SFINCS supports four types of internal drainage structures that move water between two grid cells without resolving the flow through a physical momentum equation. They are configured through a single file (typically sfincs.drn, TOML format), referenced from ``sfincs.inp`` with the ``drnfile`` keyword: -A drainage pump moves water from a retraction point (source location) to an outflow point (sink location) at a specified discharge rate, as long as there is enough water available at the retraction point. The discharge rate is defined using the par1 parameter. +.. code-block:: text -For culverts, par1 represents the discharge capacity. The actual flow through the culvert depends on the water level difference (head difference) between the upstream and downstream ends. This gradient determines how much water flows through the culvert based on the capacity defined in par1. + drnfile = sfincs.drn -The check valve requires the same par1 discharge capacity input as a culvert, but only allows flow in one direction, preventing backflow (e.g. for a one-way tide gate). Water is only flowing if the water level at input point 1 is larger than the water level at output point 2. +The four structure types are: -**Input Parameters** +- ``pump`` — drainage pump. Moves a prescribed discharge ``q`` from ``src_1`` to ``src_2``, limited by available water. +- ``culvert_simple`` — lumped one-coefficient culvert. Bidirectional by default. +- ``culvert`` — regime-aware detailed culvert with geometry (width, height, invert elevations) and a submergence threshold. +- ``gate`` — bidirectional gate with a sill and an inertial culvert-style momentum update (Bates et al., 2010). -- x & y locations: Coordinates for the retraction (source) and outflow (sink) points. -- Type: Specifies if the structure is a drainage pump (type=1), a culvert (type=2) or a check valve (type=3). -- par1: Sets the discharge capacity. Additional parameters (par2 to par5) are included as placeholders for future updates. +All structures can be driven by optional rule expressions (see :ref:`open/close rules ` below) that open or close the structure based on water levels at user-chosen observation cells. -You can know how much discharge is extracted by the model in the sfincs_his.nc output by specifying 'storeqdrain=1' from SFINCS v2.0.2 onwards, see the description in "Input parameters". +You can record how much discharge each structure extracts in the ``sfincs_his.nc`` output by setting ``storeqdrain = 1`` in ``sfincs.inp``. .. figure:: ./figures/SFINCS_drainage_grid.png :width: 400px @@ -162,61 +182,394 @@ You can know how much discharge is extracted by the model in the sfincs_his.nc o Example of how drainage pump/culvert input points with sink and source locations from 2 different structures are snapped to the grid of SFINCS. -**drnfile = sfincs.drn** +**Common input keys** + +Every ``[[src_structure]]`` block carries a small set of keys that are shared across all four types. Per-type required and optional keys are documented in the sub-subsections further below. + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **name** + - string + - Unique identifier for the structure. Required. + * - **type** + - string + - One of ``"pump"``, ``"culvert_simple"``, ``"culvert"``, ``"gate"``. The legacy alias ``"check_valve"`` maps to ``culvert_simple`` with ``direction = "positive"``. Required. + * - **src_1_x, src_1_y** + - real + - Coordinates of the intake (``src_1``) cell, in the grid CRS. Required. + * - **src_2_x, src_2_y** + - real + - Coordinates of the outfall (``src_2``) cell, in the grid CRS. Required. + * - obs_1_x, obs_1_y + - real + - Coordinates of the observation cell feeding the ``z1`` atom in rule expressions. Default: the ``src_1`` coordinates. + * - obs_2_x, obs_2_y + - real + - Coordinates of the observation cell feeding the ``z2`` atom in rule expressions. Default: the ``src_2`` coordinates. + * - direction + - string + - Flow-direction filter. One of ``"both"`` (default), ``"positive"`` (allow flow ``src_1 -> src_2`` only), ``"negative"`` (allow flow ``src_2 -> src_1`` only). Meaningful for bidirectional types (``culvert_simple``, ``culvert``); ``pump`` is one-way by construction and ``gate`` is typically left bidirectional. + * - opening_duration + - real + - Ramp time (s) for the closed → open transition. Default: **600.0** for ``gate``; **0.0** (instant) for ``pump``, ``culvert_simple``, ``culvert``. + * - closing_duration + - real + - Ramp time (s) for the open → closed transition. Same defaults as ``opening_duration``. + * - rules_open + - string + - Water-level expression that triggers opening. See :ref:`open/close rules `. + * - rules_close + - string + - Water-level expression that triggers closing. See :ref:`open/close rules `. + +Pump +^^^^ + +A drainage pump moves water from the intake cell ``src_1`` to the outfall cell ``src_2`` at a prescribed discharge ``q`` (m³/s). The discharge is signed in the sense that ``q > 0`` pumps from ``src_1`` to ``src_2``; ``q < 0`` reverses the direction. As the upstream depth drops below a small internal threshold (0.1 m, hard-coded), the discharge is scaled linearly so the pump cannot pump a cell dry: + +.. math:: + + Q = q \cdot \min\!\left(1,\, \frac{h_\text{up}}{0.1~\text{m}}\right) + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **q** + - real + - Nominal pump discharge in m³/s. Required. The dry-prevention scaling above is an internal safety and is not user-tunable. + +All common keys (``name``, ``type``, ``src_*``, ``obs_*``, ``direction``, ``opening_duration``, ``closing_duration``, ``rules_open``, ``rules_close``) are accepted as documented in the common-keys table above. + +.. code-block:: toml + + [[src_structure]] + name = "south_pump" + type = "pump" + src_1_x = 50.0 + src_1_y = 25.0 + src_2_x = 150.0 + src_2_y = 25.0 + q = 0.345 + rules_open = "z1 > 0.20" + rules_close = "z1 < 0.05" + +Culvert (simple) +^^^^^^^^^^^^^^^^ + +The simple culvert uses a single lumped coefficient and a square-root head-difference law. It is the fastest choice when geometry is unknown or unimportant. Setting ``direction = "positive"`` (or equivalently using the ``check_valve`` type alias) turns the structure into a check valve that blocks backflow — useful for one-way tide gates and similar features. + +.. math:: + + Q = c_f \cdot \operatorname{sign}(\Delta h) \cdot \sqrt{|\Delta h|} + +with :math:`\Delta h = z_{s,1} - z_{s,2}`. + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **flow_coef** + - real + - Lumped discharge coefficient :math:`c_f` from the formula above (units chosen so the formula returns m³/s when ``Δh`` is in m). Required. + +All common keys are accepted. Set ``direction = "positive"`` (or use ``type = "check_valve"``) to block backflow. + +.. code-block:: toml + + [[src_structure]] + name = "north_check_valve" + type = "culvert_simple" + direction = "positive" + src_1_x = 75.0 + src_1_y = 25.0 + src_2_x = 125.0 + src_2_y = 25.0 + flow_coef = 0.345 + +Culvert (detailed) +^^^^^^^^^^^^^^^^^^ + +The detailed culvert resolves the two usual culvert regimes — submerged (orifice-like) and free / inlet-controlled — based on the ratio of downstream to upstream heads above the controlling sill. The controlling sill is the higher of the two inverts, :math:`z_\text{sill} = \max(\text{invert}_1, \text{invert}_2)`; upstream and downstream are assigned on the fly from the sign of :math:`\Delta h`, so the structure is bidirectional (restrict with ``direction`` if needed). + +Let :math:`h_\text{up}`, :math:`h_\text{dn}` be the upstream and downstream depths above :math:`z_\text{sill}`, and :math:`A_\text{eff} = w \cdot \min(h_\text{up}, H)` (capped at barrel height). Then + +.. math:: + + Q = + \begin{cases} + c_f \cdot A_\text{eff} \cdot \sqrt{2 g\, |\Delta h|}, & h_\text{dn}/h_\text{up} \ge r_\text{sub} \quad\text{(submerged)} \\ + c_f \cdot A_\text{eff} \cdot \sqrt{2 g\, h_\text{up}}, & h_\text{dn}/h_\text{up} < r_\text{sub} \quad\text{(free / inlet-controlled)} + \end{cases} + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **width** + - real + - Culvert barrel width (m). Required. + * - **height** + - real + - Culvert barrel height (m). Used to cap the flow area. Required. + * - **invert_1** + - real + - Invert elevation at the ``src_1`` end (m, same datum as ``zb``). Required. + * - **invert_2** + - real + - Invert elevation at the ``src_2`` end (m, same datum as ``zb``). Required. + * - flow_coef + - real + - Orifice discharge coefficient :math:`c_f`. Default: **0.6**. + * - submergence_ratio + - real + - Threshold :math:`r_\text{sub}` on :math:`h_\text{dn}/h_\text{up}` that switches between the two regimes. Default: **0.667** (the classic broad-crested-weir / Villemonte value). + +All common keys are accepted. + +.. code-block:: toml + + [[src_structure]] + name = "west_culvert" + type = "culvert" + src_1_x = 100.0 + src_1_y = 50.0 + src_2_x = 100.0 + src_2_y = 150.0 + width = 1.2 + height = 1.0 + invert_1 = 0.20 + invert_2 = 0.15 + flow_coef = 0.6 + submergence_ratio = 0.667 + +Gate +^^^^ + +The gate is a bidirectional opening with a horizontal sill. Discharge is computed from an inertial culvert-style momentum update (Bates et al., 2010), per unit width, and then multiplied by the gate ``width``. The previous-step discharge :math:`q^n` is carried through the relaxation blend, so the gate has memory on the order of ``structure_relax`` time steps. + +With :math:`h = \max(\max(z_{s,1}, z_{s,2}) - z_\text{sill},\, 0)` and :math:`\partial z_s/\partial s = (z_{s,2} - z_{s,1})/L`: + +.. math:: + + q^{n+1} = + \frac{q^n - g\, h\, (\partial z_s/\partial s)\, \Delta t} + {1 + g\, n^2\, \Delta t\, |q^n| / h^{7/3}} + +then :math:`Q = c_f \cdot q^{n+1} \cdot w \cdot \text{fraction\_open}`, where :math:`c_f` is ``flow_coef``. + +.. list-table:: + :header-rows: 1 + :widths: 22 14 64 + + * - Key + - Type + - Description + * - **width** + - real + - Gate width (m). Required. + * - **sill_elevation** + - real + - Sill elevation :math:`z_\text{sill}` (m, same datum as ``zb``). Required. + * - mannings_n + - real + - Manning's roughness coefficient on the gate sill. Default: **0.024** (concrete-lined). + * - flow_coef + - real + - Lumped discharge coefficient :math:`c_f` from the formula above, accounting for additional losses not captured by the Manning friction term. Default: **1.0** (no extra loss). + +All common keys are accepted. The gate defaults ``opening_duration`` and ``closing_duration`` to **600 s** (matching legacy ``dtype = 4`` behaviour) rather than the 0 s default used by the other three types. + +.. code-block:: toml + + [[src_structure]] + name = "east_tide_gate" + type = "gate" + src_1_x = 200.0 + src_1_y = 25.0 + src_2_x = 250.0 + src_2_y = 25.0 + obs_2_x = 260.0 # observe water level just outside the gate + obs_2_y = 25.0 + width = 3.0 + sill_elevation = 0.20 + mannings_n = 0.024 + opening_duration = 300.0 + closing_duration = 300.0 + rules_open = "z2-z1 > 0.10" + rules_close = "z2-z1 < 0.0 | z2>1.0" + +.. _drn_rules: + +**Open/close rules and the state machine** + +Each structure has an internal state machine with four states: + +- ``0`` — closed +- ``1`` — open +- ``2`` — opening (transient, time-based) +- ``3`` — closing (transient, time-based) + +On a time step, if the current state is ``0`` (closed), the ``rules_open`` expression is evaluated; if it fires, the state advances to ``2`` (opening) and ``fraction_open`` ramps from 0 to 1 linearly over ``opening_duration`` seconds. Symmetrically, from state ``1`` (open) a firing ``rules_close`` expression moves the state to ``3`` (closing) with ``fraction_open`` ramping from 1 to 0 over ``closing_duration`` seconds. The transient states advance on elapsed time only, so rule hysteresis cannot thrash. When ``opening_duration`` (or ``closing_duration``) is ``0.0``, the transition is instantaneous and the transient state is skipped. Structures that specify neither ``rules_open`` nor ``rules_close`` stay at the init-time default (``status = 1``, ``fraction_open = 1.0``) and the state-machine scaling is a no-op. + +The rule expressions use a compact boolean grammar. Atoms are ``z1``, ``z2``, and ``z2-z1`` (all three case-insensitive); there is **no** ``z1-z2`` atom — invert the comparison sign instead. ``z1`` is the water level in the ``obs_1`` cell and ``z2`` is the water level in the ``obs_2`` cell. Comparison operators are ``<`` and ``>`` only (no ``<=`` / ``>=``). Boolean connectives are ``&`` (and) and ``|`` (or); parentheses can be used for grouping. + +Examples: .. code-block:: text - par2-1 par3-1 par4-1 par5-1 - par2-2 par3-2 par4-2 par5-2 + rules_open = "z1 > 0.5" # open whenever intake rises above 0.5 m + rules_close = "z2 > 2.0" # close when the outfall floods above 2 m + rules_open = "(z1 < 0.5 | z2-z1 > 0.05) & z2 < 1.5" # complex trigger + rules_close = "z2-z1 > 0.3" # close when outfall gets 0.3 m higher than intake + +**Discharge relaxation: structure_relax** + +Discharges from src structures are relaxation-blended between time steps to damp oscillations: + +.. math:: + + q^{n+1}_{\text{blended}} = \alpha \, q^{n+1}_{\text{raw}} + (1 - \alpha) \, q^{n}, \qquad \alpha = \frac{1}{N} + +where :math:`N` is set by the ``structure_relax`` keyword in ``sfincs.inp`` — a dimensionless step count: a value of :math:`N` damps the discharge response over roughly :math:`N` time steps. Default is ``4.0``; typical range is 1 (no smoothing) to 10. + +**Output: storing structure discharges** + +Set ``storeqdrain = 1`` in ``sfincs.inp`` to write the time-series discharge per structure into ``sfincs_his.nc``. + +**Example sfincs.drn file** + +.. code-block:: toml + + # sfincs.drn + + [[src_structure]] + name = "south_pump" + type = "pump" + src_1_x = 50.0 + src_1_y = 25.0 + src_2_x = 150.0 + src_2_y = 25.0 + q = 0.345 # pump discharge (m^3/s) + rules_open = "z1 > 0.20" # start pumping when intake > 0.20 m + rules_close = "z1 < 0.05" # stop pumping when intake drops below 0.05 m + + [[src_structure]] + name = "north_check_valve" + type = "culvert_simple" + direction = "positive" # one-way; blocks backflow + src_1_x = 75.0 + src_1_y = 25.0 + src_2_x = 125.0 + src_2_y = 25.0 + flow_coef = 0.345 + + [[src_structure]] + name = "west_culvert" + type = "culvert" + src_1_x = 100.0 + src_1_y = 50.0 + src_2_x = 100.0 + src_2_y = 150.0 + width = 1.2 + height = 1.0 + invert_1 = 0.20 + invert_2 = 0.15 + flow_coef = 0.6 # orifice discharge coefficient + submergence_ratio = 0.667 # h_dn/h_up threshold between submerged and inlet control + + [[src_structure]] + name = "east_tide_gate" + type = "gate" + src_1_x = 200.0 + src_1_y = 25.0 + src_2_x = 250.0 + src_2_y = 25.0 + obs_2_x = 260.0 # observe water level just outside the gate + obs_2_y = 25.0 + width = 3.0 + sill_elevation = 0.20 + mannings_n = 0.024 + opening_duration = 300.0 # 5-minute ramp open + closing_duration = 300.0 + rules_open = "z2-z1 > 0.10" # open when outer level exceeds inner by 0.10 m + rules_close = "z2-z1 < 0.0 | z2>1.0" # close on reversal (prevents backflow) or when outer water level exceeds 1.0 m - e.g. pump: - 50.00 25.00 150.00 25.00 1 0.345 0.000 0.000 0.000 0.000 - 75.00 25.00 125.00 25.00 1 0.345 0.000 0.000 0.000 0.000 - - e.g. culvert: - 50.00 25.00 150.00 25.00 2 0.345 0.000 0.000 0.000 0.000 - 75.00 25.00 125.00 25.00 2 0.345 0.000 0.000 0.000 0.000 - **Python example using HydroMT-SFINCS** .. code-block:: python - sf.drainage_structures.create( - locations="drainage_input.geojson", - stype='pump', - discharge=100.0, - merge=True - ) + sf.drainage_structures.create( + locations="drainage_input.geojson", + stype='pump', + discharge=100.0, + merge=True + ) - OR as a culvert: + # OR as a culvert: - sf.drainage_structures.create( - locations="drainage_input.geojson", - stype='culvert', - discharge=100.0, - merge=True - ) + sf.drainage_structures.create( + locations="drainage_input.geojson", + stype='culvert', + discharge=100.0, + merge=True + ) - More information: - https://deltares.github.io/hydromt_sfincs/latest/_generated/hydromt_sfincs.components.geometries.SfincsDrainageStructures.create.html +More information: +https://deltares.github.io/hydromt_sfincs/latest/_generated/hydromt_sfincs.components.geometries.SfincsDrainageStructures.create.html + +**Legacy fixed-column drn format** -**Calculating Culvert Discharge Capacity** +The legacy ASCII fixed-column ``.drn`` format is still accepted for back-compatibility. Each non-blank, non-comment line describes one structure with the columns: -For culverts, par1 (discharge capacity) can be calculated as: +.. code-block:: text -``par1 = \(\mu \cdot A \cdot \sqrt{2g}\)`` + + +where ``type`` is: + +- ``1`` — pump (``par1`` = pump discharge) +- ``2`` — culvert (``par1`` = ``flow_coef``; maps to ``culvert_simple``) +- ``3`` — check valve (``par1`` = ``flow_coef``; maps to ``culvert_simple`` with ``direction = "positive"``) + +Example: + +.. code-block:: text -where: + # pump: + 50.00 25.00 150.00 25.00 1 0.345 + 75.00 25.00 125.00 25.00 1 0.345 -* \(\mu\) = dimensionless culvert loss coefficient, typically between 0 and 1 -* \(A\) = area of the culvert opening (m²) -* \(g\) = gravitational acceleration (9.81 m/s²) + # culvert: + 50.00 25.00 150.00 25.00 2 0.345 + 75.00 25.00 125.00 25.00 2 0.345 -This formula is derived from the Bernoulli Equation, which estimates flow based on the head difference. +When SFINCS sees a legacy ``.drn`` file it automatically transcribes it to a sibling TOML file (``sfincs.toml.drn`` if the input was ``sfincs.drn``) and then reads that. Water-level-triggered legacy gates (``type = 4``) are converted to TOML ``gate`` blocks with synthesised ``rules_open`` / ``rules_close`` expressions derived from the legacy ``zmin`` / ``zmax`` columns. Schedule-triggered legacy gates (``type = 5``) are refused; the rule grammar is water-level-only and has no time atom — rewrite those as TOML gates driven by observed water levels. -* If \(\mu = 1\), the flow is assumed to be driven entirely by the head difference, with no friction or length-based losses. -* If \(\mu < 1\), it accounts for additional energy losses, such as friction and entry/exit losses. +.. important:: -**Planned Enhancements** + **After a legacy transcription, strongly consider renaming the generated + ``sfincs.toml.drn`` file to ``sfincs.drn`` (overwriting the original legacy + file) and pointing ``drnfile`` at it.** Future simulations will then read + the TOML directly, skipping the transcription step and giving you a single + source of truth that you can edit, version-control, and extend with the + newer keywords (``rules_open`` / ``rules_close``, ``reduction_depth``, + ``submergence_ratio``, ``direction``, per-structure invert pairs, etc.) + that the legacy format cannot express. Keep a backup of the original + legacy file elsewhere if you need it for reference. -Future updates will incorporate the Darcy–Weisbach equation for more accurate discharge estimates by considering frictional and minor losses along the culvert length, which is particularly useful for longer or rougher conduits. +New models should be written directly in TOML; the legacy reader exists purely so that pre-TOML input decks keep running. diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index f77749948..aa4029919 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -11,6 +11,22 @@ module sfincs_discharges ! live in sfincs_src_structures. The two modules no longer share any ! arrays -- they cooperate only by both writing into qsrc(np). ! + ! ----------------------------------------------------------------- + ! Subroutines in this module: + ! + ! initialize_discharges + ! Read srcfile/disfile (ascii) or netsrcdisfile (netcdf), resolve + ! each source to its quadtree cell, and allocate runtime state. + ! + ! update_discharges + ! Zero qsrc(np), interpolate the river discharge time series to the + ! current time, and accumulate into qsrc at each source cell. + ! + ! count_tokens + ! Count whitespace-separated tokens in a string; used to decide + ! between the 2-column (x y) and 3-column (x y name) src formats. + ! ----------------------------------------------------------------- + ! use sfincs_log use sfincs_error ! @@ -45,7 +61,15 @@ module sfincs_discharges ! subroutine initialize_discharges() ! - ! Read src/dis or netsrcdis. Allocate nmindsrc(nr_discharge_points), qtsrc(nr_discharge_points). + ! Read the river-point-discharge input and wire each source up to a grid + ! cell. Two mutually-exclusive input paths: + ! - srcfile (+ disfile): ascii, 2-column (x y) or 3-column (x y name) + ! location file plus a separate time-series file. + ! - netsrcdisfile: FEWS-style netcdf with locations and time series + ! in one file (no per-point names; auto-generated). + ! Allocates nmindsrc(nr_discharge_points) and qtsrc(nr_discharge_points), + ! and populates shared tsrc/qsrc_ts arrays in sfincs_data. + ! Called once at init time. ! use sfincs_data use sfincs_ncinput diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index db9a6aef9..8c93487d2 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -178,7 +178,7 @@ subroutine read_sfincs_input() call read_char_input(500,'advection_scheme',advstr,'upw1') call read_real_input(500,'btrelax',btrelax,3600.0) call read_logical_input(500,'wiggle_suppression', wiggle_suppression, .true.) - call read_real_input(500,'structure_relax',structure_relax,10.0) + call read_real_input(500, 'structure_relax', structure_relax, 4.0) call read_real_input(500,'wiggle_factor',wiggle_factor,0.1) call read_real_input(500,'wiggle_threshold',wiggle_threshold,0.1) call read_real_input(500, 'uvlim', uvlim, 10.0) diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index c68c96fff..00c636f8a 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -26,10 +26,14 @@ subroutine initialize_openacc() !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & !$acc qsrc, qtsrc, q_src_struc, nmindsrc, src_struc_nm_in, src_struc_nm_out, src_struc_type, & + !$acc src_struc_direction, & !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & - !$acc src_struc_q, src_struc_qmax, src_struc_flow_coef, & + !$acc src_struc_q, src_struc_flow_coef, & !$acc src_struc_width, src_struc_sill_elevation, src_struc_mannings_n, & !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_height, & + !$acc src_struc_invert_1, src_struc_invert_2, & + !$acc src_struc_submergence_ratio, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, src_struc_t_state, & !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & @@ -63,10 +67,14 @@ subroutine finalize_openacc() !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & !$acc qsrc, qtsrc, q_src_struc, nmindsrc, src_struc_nm_in, src_struc_nm_out, src_struc_type, & + !$acc src_struc_direction, & !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & - !$acc src_struc_q, src_struc_qmax, src_struc_flow_coef, & + !$acc src_struc_q, src_struc_flow_coef, & !$acc src_struc_width, src_struc_sill_elevation, src_struc_mannings_n, & !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_height, & + !$acc src_struc_invert_1, src_struc_invert_2, & + !$acc src_struc_submergence_ratio, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, src_struc_t_state, & !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 4e89a4da4..97f6284da 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -2,11 +2,15 @@ module sfincs_src_structures ! ! Point structures that move water between two grid cells by user-specified ! rules rather than by momentum conservation: - ! type 1 - pump (fixed discharge) - ! type 2 - culvert (bidirectional) - ! type 3 - check valve (unidirectional culvert) - ! type 4 - controlled gate, water-level triggered - ! type 5 - controlled gate, schedule triggered + ! type 1 - pump (fixed discharge) + ! type 3 - culvert_simple (bidirectional, optional direction filter) + ! type 4 - gate (rule-driven state machine, bidirectional) + ! type 6 - culvert (physics-based pipe flow with entrance / + ! friction / exit losses, bidirectional, + ! optional direction filter) + ! + ! Legacy TOML alias accepted by the parser: + ! "check_valve" -> culvert_simple + direction = "positive" ! ! These used to live in sfincs_discharges.f90 alongside the river point ! discharges read from src/dis/netsrcdis. They have been split out so that @@ -20,11 +24,50 @@ module sfincs_src_structures ! Concurrency: qsrc updates use atomic because two structures (or a river ! source and a structure) can land in the same cell. ! + ! ----------------------------------------------------------------- + ! Subroutines in this module: + ! + ! initialize_src_structures + ! Main entry point. Detects legacy vs TOML, dispatches through the + ! TOML reader, flattens into src_struc_* arrays, resolves grid-cell + ! indices, and seeds rule-driven gate statuses from the initial zs. + ! + ! update_src_structures + ! Called per time step. Advances the open/close state machine for + ! rule-driven structures, evaluates the per-type flux formula, and + ! accumulates signed discharges into qsrc and q_src_struc. + ! + ! read_toml_src_structures + ! Parse a TOML drn file into an allocatable t_src_structure(:) array. + ! Validates required per-type keys; returns ierr /= 0 on failure. + ! + ! check_required + ! Helper for read_toml_src_structures: verifies that every key in a + ! required-key list is present in a given TOML table. + ! + ! parse_structure_type + ! Translate a TOML "type" string to one of the structure_* codes. + ! + ! parse_direction + ! Translate a TOML "direction" string to one of the direction_* codes. + ! + ! to_lower + ! Return a lowercase copy of a string (ASCII). + ! + ! write_src_structures_log_summary + ! Emit a one-block-per-structure human-readable description to the + ! log file; called once at init time after marshalling. + ! + ! convert_legacy_to_toml + ! Transcribe a legacy fixed-column .drn file into a TOML sibling so + ! the downstream code only has to consume the TOML schema. + ! ----------------------------------------------------------------- + ! use sfincs_log use sfincs_error use sfincs_rule_expression, only: add_rule, evaluate_rule, finalize_rule_storage ! - private :: parse_structure_type, to_lower, check_required + private :: parse_structure_type, parse_direction, to_lower, check_required private :: convert_legacy_to_toml private :: write_src_structures_log_summary ! @@ -32,10 +75,25 @@ module sfincs_src_structures ! Structure type codes ! ------------------------------------------------------------------ ! - integer, parameter :: structure_pump = 1 - integer, parameter :: structure_check_valve = 2 - integer, parameter :: structure_culvert = 3 - integer, parameter :: structure_gate = 4 + integer, parameter :: structure_pump = 1 + integer, parameter :: structure_culvert_simple = 3 + integer, parameter :: structure_gate = 4 + integer, parameter :: structure_culvert = 6 + ! + ! Direction filter codes (culvert_simple / culvert). Controls which sign + ! of discharge is allowed through the structure. Default is "both". + ! + integer, parameter :: direction_both = 1 + integer, parameter :: direction_positive = 2 + integer, parameter :: direction_negative = 3 + ! + ! ------------------------------------------------------------------ + ! Pump reduction curve depth (m). Pump discharge is scaled by + ! min(1, h_up/reduction_depth) so the pump cannot pump the intake + ! cell dry. Fixed constant, not user-tunable. + ! ------------------------------------------------------------------ + ! + real*4, parameter :: reduction_depth = 0.1 ! ! ------------------------------------------------------------------ ! Derived type for the TOML-based src structure input. @@ -58,6 +116,11 @@ module sfincs_src_structures ! integer :: structure_type ! + ! Direction filter (one of direction_both / _positive / _negative). + ! Honoured only for culvert_simple and culvert; other types ignore it. + ! + integer :: direction + ! ! Geometry - src_1/src_2 define the intake/outfall cell pair; ! obs_1/obs_2 are optional and default to src_1/src_2 in the ! marshal when the TOML reader did not see the keys (tracked via @@ -73,16 +136,18 @@ module sfincs_src_structures ! Parameters ! ! q - pump discharge - ! qmax - maximum discharge magnitude (safety clamp) - ! width - gate width + ! width - gate / culvert width ! sill_elevation - gate sill elevation ! mannings_n - gate Manning's n ! opening_duration - time (s) to go from closed to fully open ! closing_duration - time (s) to go from open to fully closed - ! flow_coef - culvert / check_valve flow coefficient + ! flow_coef - culvert_simple / check_valve / culvert flow coefficient + ! height - culvert pipe height (m, rectangular cross-section) + ! invert_1 - culvert bed elevation at src_1 end (m) + ! invert_2 - culvert bed elevation at src_2 end (m) + ! submergence_ratio - culvert submergence threshold h_dn/h_up (-) ! real :: q - real :: qmax real :: width real :: sill_elevation real :: mannings_n @@ -90,6 +155,13 @@ module sfincs_src_structures real :: closing_duration real :: flow_coef ! + ! Detailed-culvert geometry + submergence threshold + ! + real :: height + real :: invert_1 + real :: invert_2 + real :: submergence_ratio + ! ! Gate control rule expressions (raw strings; parsed by marshal). ! Either or both may be unallocated, meaning "no trigger for this action". ! @@ -122,6 +194,7 @@ module sfincs_src_structures ! Kind / state ! integer*1, dimension(:), allocatable, public :: src_struc_type + integer, dimension(:), allocatable, public :: src_struc_direction ! direction_* code; honoured by culvert_simple and culvert integer*1, dimension(:), allocatable, public :: src_struc_status real*4, dimension(:), allocatable, public :: src_struc_distance real*4, dimension(:), allocatable, public :: src_struc_fraction_open @@ -149,14 +222,23 @@ module sfincs_src_structures ! Named parameters ! real*4, dimension(:), allocatable, public :: src_struc_q ! pump discharge - real*4, dimension(:), allocatable, public :: src_struc_qmax ! max discharge magnitude (safety clamp) - real*4, dimension(:), allocatable, public :: src_struc_flow_coef ! culvert / check_valve flow coefficient - real*4, dimension(:), allocatable, public :: src_struc_width ! gate width + real*4, dimension(:), allocatable, public :: src_struc_flow_coef ! culvert_simple / check_valve / culvert flow coefficient + real*4, dimension(:), allocatable, public :: src_struc_width ! gate / culvert width real*4, dimension(:), allocatable, public :: src_struc_sill_elevation ! gate sill elevation - real*4, dimension(:), allocatable, public :: src_struc_mannings_n ! gate Manning's n + real*4, dimension(:), allocatable, public :: src_struc_mannings_n ! gate / culvert Manning's n real*4, dimension(:), allocatable, public :: src_struc_opening_duration ! gate opening duration (s) real*4, dimension(:), allocatable, public :: src_struc_closing_duration ! gate closing duration (s) ! + ! Detailed-culvert geometry + ! + real*4, dimension(:), allocatable, public :: src_struc_height ! culvert pipe height (m) + real*4, dimension(:), allocatable, public :: src_struc_invert_1 ! culvert bed elevation at src_1 end (m) + real*4, dimension(:), allocatable, public :: src_struc_invert_2 ! culvert bed elevation at src_2 end (m) + ! + ! Detailed-culvert submergence threshold + ! + real*4, dimension(:), allocatable, public :: src_struc_submergence_ratio ! culvert submergence threshold h_dn/h_up (-) + ! ! Runtime state ! real*4, dimension(:), allocatable, public :: q_src_struc ! (nr_src_structures) signed discharge per structure, mirrors the qsrc pattern @@ -341,6 +423,7 @@ subroutine initialize_src_structures() allocate(src_struc_nm_obs_2(nr_src_structures)) allocate(q_src_struc(nr_src_structures)) allocate(src_struc_type(nr_src_structures)) + allocate(src_struc_direction(nr_src_structures)) allocate(src_struc_distance(nr_src_structures)) allocate(src_struc_status(nr_src_structures)) allocate(src_struc_fraction_open(nr_src_structures)) @@ -355,13 +438,16 @@ subroutine initialize_src_structures() allocate(src_struc_obs_2_x(nr_src_structures)) allocate(src_struc_obs_2_y(nr_src_structures)) allocate(src_struc_q(nr_src_structures)) - allocate(src_struc_qmax(nr_src_structures)) allocate(src_struc_flow_coef(nr_src_structures)) allocate(src_struc_width(nr_src_structures)) allocate(src_struc_sill_elevation(nr_src_structures)) allocate(src_struc_mannings_n(nr_src_structures)) allocate(src_struc_opening_duration(nr_src_structures)) allocate(src_struc_closing_duration(nr_src_structures)) + allocate(src_struc_height(nr_src_structures)) + allocate(src_struc_invert_1(nr_src_structures)) + allocate(src_struc_invert_2(nr_src_structures)) + allocate(src_struc_submergence_ratio(nr_src_structures)) allocate(src_struc_rule_open(nr_src_structures)) allocate(src_struc_rule_close(nr_src_structures)) allocate(src_struc_rule_open_src(nr_src_structures)) @@ -378,9 +464,10 @@ subroutine initialize_src_structures() src_struc_nm_obs_2 = 0 q_src_struc = 0.0 src_struc_type = 0 + src_struc_direction = direction_both src_struc_distance = 0.0 - src_struc_fraction_open = 1.0 ! 1.0 => no-op multiplier for non-gate types; gates get their real value from the gate-status seeding pass below - src_struc_status = 0 ! 0=closed, 1=open, 2=opening, 3=closing + src_struc_fraction_open = 1.0 ! default "fully open": structures without rules bypass the state machine and use this as a no-op multiplier in the common-tail scaling + src_struc_status = 1 ! 0=closed, 1=open, 2=opening, 3=closing; default open (see above). Rule-driven structures overwrite this in the init-time seeding below. src_struc_t_state = 0.0 src_struc_name = ' ' src_struc_src_1_x = 0.0 @@ -392,13 +479,16 @@ subroutine initialize_src_structures() src_struc_obs_2_x = 0.0 src_struc_obs_2_y = 0.0 src_struc_q = 0.0 - src_struc_qmax = 1.0e30 src_struc_flow_coef = 1.0 src_struc_width = 0.0 src_struc_sill_elevation = 0.0 src_struc_mannings_n = 0.024 src_struc_opening_duration = 600.0 src_struc_closing_duration = 600.0 + src_struc_height = 0.0 + src_struc_invert_1 = 0.0 + src_struc_invert_2 = 0.0 + src_struc_submergence_ratio = 0.667 ! ! ------------------------------------------------------------------ ! Copy scalar / coord / string / parameter fields from src_structures(:) @@ -423,7 +513,8 @@ subroutine initialize_src_structures() ! endif ! - src_struc_type(i) = int(src_structures(i)%structure_type, 1) + src_struc_type(i) = int(src_structures(i)%structure_type, 1) + src_struc_direction(i) = src_structures(i)%direction ! ! src_struc_status is runtime-only (not on the TOML type); leave it at ! the default of 0 (closed) set above. @@ -462,13 +553,16 @@ subroutine initialize_src_structures() endif ! src_struc_q(i) = src_structures(i)%q - src_struc_qmax(i) = src_structures(i)%qmax src_struc_flow_coef(i) = src_structures(i)%flow_coef src_struc_width(i) = src_structures(i)%width src_struc_sill_elevation(i) = src_structures(i)%sill_elevation src_struc_mannings_n(i) = src_structures(i)%mannings_n src_struc_opening_duration(i) = src_structures(i)%opening_duration src_struc_closing_duration(i) = src_structures(i)%closing_duration + src_struc_height(i) = src_structures(i)%height + src_struc_invert_1(i) = src_structures(i)%invert_1 + src_struc_invert_2(i) = src_structures(i)%invert_2 + src_struc_submergence_ratio(i) = src_structures(i)%submergence_ratio ! ! Parse rule expressions. Missing / empty strings leave the ! rule_id at 0, which the evaluator interprets as "never fires". @@ -579,19 +673,23 @@ subroutine initialize_src_structures() call write_src_structures_log_summary() ! ! ------------------------------------------------------------------ - ! Gate-specific initial status from the current zs field. + ! Initial-status seeding for rule-driven structures. ! ! zs(:) has already been populated by initialize_domain -> initialize_hydro ! -> set_initial_conditions by the time we get here, so obs-point lookups - ! against zs are valid. For non-gate structures the defaults assigned - ! above (status=0=closed, fraction_open=1.0) already encode "no-op". + ! against zs are valid. For structures with no rule expressions the defaults + ! assigned above (status=1=open, fraction_open=1.0) already encode "no-op": + ! the state machine is skipped at runtime and the common-tail scaling by + ! fraction_open is a 1.0 multiply. ! ! Status encoding: 0=closed, 1=open, 2=opening, 3=closing. ! ------------------------------------------------------------------ ! do istruc = 1, nr_src_structures ! - if (src_struc_type(istruc) /= structure_gate) cycle + ! Skip structures without rules - keep the "always open" defaults. + ! + if (src_struc_rule_open(istruc) <= 0 .and. src_struc_rule_close(istruc) <= 0) cycle ! nm1 = src_struc_nm_obs_1(istruc) nm2 = src_struc_nm_obs_2(istruc) @@ -636,8 +734,8 @@ subroutine initialize_src_structures() src_struc_status(istruc) = 1 src_struc_fraction_open(istruc) = 1.0 status_str = 'open' - write(logstr,'(a,a,a)')'Warning ! gate ', trim(src_struc_name(istruc)), & - ': both open and close rules fire at init; keeping gate open' + write(logstr,'(a,a,a,a)')'Warning ! structure ', trim(src_struc_name(istruc)), & + ': both open and close rules fire at init; keeping structure open' call write_log(logstr, 0) ! else @@ -653,7 +751,7 @@ subroutine initialize_src_structures() ! src_struc_t_state(istruc) = t0 ! - write(logstr,'(a,a,a,a)')'gate ', trim(src_struc_name(istruc)), & + write(logstr,'(a,a,a,a)')'structure ', trim(src_struc_name(istruc)), & ' initialised status=', trim(status_str) call write_log(logstr, 0) ! @@ -683,8 +781,10 @@ subroutine update_src_structures(t, dt, tloop) ! integer :: count0, count1, count_rate, count_max integer :: istruc, nmin, nmout, nm_o1, nm_o2 - real*4 :: qq, qqmax, elapsed, z1r, z2r + real*4 :: qq, elapsed, z1r, z2r real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha + real*4 :: dh, a_eff + real*4 :: h_up, h_dn, qq_sign logical :: open_fires, close_fires ! if (nr_src_structures <= 0) return @@ -694,172 +794,197 @@ subroutine update_src_structures(t, dt, tloop) !$acc parallel loop present( z_volume, zs, zb, qsrc, q_src_struc, & !$acc src_struc_nm_in, src_struc_nm_out, & !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & - !$acc src_struc_type, & - !$acc src_struc_q, src_struc_qmax, src_struc_flow_coef, & + !$acc src_struc_type, src_struc_direction, & + !$acc src_struc_q, src_struc_flow_coef, & !$acc src_struc_width, src_struc_sill_elevation, & !$acc src_struc_mannings_n, & !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_height, & + !$acc src_struc_invert_1, src_struc_invert_2, & + !$acc src_struc_submergence_ratio, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, & !$acc src_struc_t_state, & !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, & !$acc rule_start, rule_length ) & - !$acc private( nmin, nmout, nm_o1, nm_o2, qq, qqmax, elapsed, & + !$acc private( nmin, nmout, nm_o1, nm_o2, qq, elapsed, & !$acc z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & + !$acc dh, a_eff, & + !$acc h_up, h_dn, qq_sign, & !$acc open_fires, close_fires ) !$omp parallel do & - !$omp private( nmin, nmout, nm_o1, nm_o2, qq, qqmax, elapsed, & + !$omp private( nmin, nmout, nm_o1, nm_o2, qq, elapsed, & !$omp z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & + !$omp dh, a_eff, & + !$omp h_up, h_dn, qq_sign, & !$omp open_fires, close_fires ) & !$omp schedule ( static ) do istruc = 1, nr_src_structures ! nmin = src_struc_nm_in(istruc) nmout = src_struc_nm_out(istruc) - qqmax = src_struc_qmax(istruc) ! if (nmin > 0 .and. nmout > 0) then ! - select case(src_struc_type(istruc)) + ! --------------------------------------------------------------- + ! Open/close rule state machine (any structure type, any status). + ! + ! Only runs if the user provided at least one of rules_open / + ! rules_close. Structures without rules stay at the init-time + ! defaults (status=1=open, fraction_open=1.0), which turns the + ! common-tail scaling below into a no-op. + ! + ! Status codes: 0=closed, 1=open, 2=opening, 3=closing. + ! Transient states 2 and 3 advance purely on elapsed time so the + ! state machine cannot thrash; rule evaluation happens in the + ! terminal states 0 and 1 only. Obs points feed the rule inputs + ! and default to the src pair in the marshal. + ! --------------------------------------------------------------- + ! + if (src_struc_rule_open(istruc) > 0 .or. src_struc_rule_close(istruc) > 0) then ! - case(structure_pump) - ! - qq = src_struc_q(istruc) - ! - case(structure_culvert) - ! - ! Bidirectional: Q = flow_coef * sign(dh) * sqrt(|dh|) - ! - if (zs(nmin) > zs(nmout)) then - ! - qq = src_struc_flow_coef(istruc) * sqrt(zs(nmin) - zs(nmout)) - ! - else - ! - qq = -src_struc_flow_coef(istruc) * sqrt(zs(nmout) - zs(nmin)) - ! - endif + nm_o1 = src_struc_nm_obs_1(istruc) + nm_o2 = src_struc_nm_obs_2(istruc) + ! + if (nm_o1 > 0) then ! - qq = sign(min(abs(qq), qqmax), qq) + z1r = real(zs(nm_o1), 4) ! - case(structure_check_valve) + else ! - ! One-way: flow only when z(in) > z(out); clipped to [0, qmax]. + z1r = 0.0 ! - qq = src_struc_flow_coef(istruc) * sqrt(max(0.0, zs(nmin) - zs(nmout))) - qq = min(qq, qqmax) + endif + ! + if (nm_o2 > 0) then ! - case(structure_gate) + z2r = real(zs(nm_o2), 4) ! - ! Rule-driven state machine + bidirectional culvert-style - ! flow, scaled by the momentary open fraction. + else ! - ! Status codes: 0=closed, 1=open, 2=opening, 3=closing. - ! Opening/closing re-use the rule-evaluation branch only in - ! the terminal (0) and (1) states; transient states (2, 3) - ! advance purely on elapsed time so they cannot thrash. + z2r = 0.0 ! - nm_o1 = src_struc_nm_obs_1(istruc) - nm_o2 = src_struc_nm_obs_2(istruc) + endif + ! + select case (int(src_struc_status(istruc))) ! - if (nm_o1 > 0) then - ! - z1r = real(zs(nm_o1), 4) + case (0) ! - else + ! closed - look for an open trigger ! - z1r = 0.0 + open_fires = evaluate_rule(src_struc_rule_open(istruc), z1r, z2r) ! - endif - ! - if (nm_o2 > 0) then + if (open_fires) then + ! + src_struc_status(istruc) = 2 + src_struc_t_state(istruc) = real(t, 4) + ! + endif ! - z2r = real(zs(nm_o2), 4) + case (1) ! - else + ! open - look for a close trigger ! - z2r = 0.0 + close_fires = evaluate_rule(src_struc_rule_close(istruc), z1r, z2r) ! - endif - ! - select case (int(src_struc_status(istruc))) - ! - case (0) - ! - ! closed - look for an open trigger - ! - open_fires = evaluate_rule(src_struc_rule_open(istruc), z1r, z2r) - ! - if (open_fires) then - ! - src_struc_status(istruc) = 2 - src_struc_t_state(istruc) = real(t, 4) - ! - endif - ! - case (1) - ! - ! open - look for a close trigger - ! - close_fires = evaluate_rule(src_struc_rule_close(istruc), z1r, z2r) + if (close_fires) then ! - if (close_fires) then - ! - src_struc_status(istruc) = 3 - src_struc_t_state(istruc) = real(t, 4) - ! - endif + src_struc_status(istruc) = 3 + src_struc_t_state(istruc) = real(t, 4) ! - case (2) + endif + ! + case (2) + ! + ! opening - advance on elapsed time; do not re-check rules + ! + elapsed = real(t, 4) - src_struc_t_state(istruc) + ! + if (src_struc_opening_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_opening_duration(istruc)) then ! - ! opening - advance on elapsed time; do not re-check rules + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 ! - elapsed = real(t, 4) - src_struc_t_state(istruc) + else ! - if (src_struc_opening_duration(istruc) <= 0.0 .or. & - elapsed >= src_struc_opening_duration(istruc)) then - ! - src_struc_status(istruc) = 1 - src_struc_fraction_open(istruc) = 1.0 - ! - else - ! - src_struc_fraction_open(istruc) = elapsed / src_struc_opening_duration(istruc) - ! - endif + src_struc_fraction_open(istruc) = elapsed / src_struc_opening_duration(istruc) ! - case (3) + endif + ! + case (3) + ! + ! closing - advance on elapsed time; do not re-check rules + ! + elapsed = real(t, 4) - src_struc_t_state(istruc) + ! + if (src_struc_closing_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_closing_duration(istruc)) then ! - ! closing - advance on elapsed time; do not re-check rules + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 ! - elapsed = real(t, 4) - src_struc_t_state(istruc) + else ! - if (src_struc_closing_duration(istruc) <= 0.0 .or. & - elapsed >= src_struc_closing_duration(istruc)) then - ! - src_struc_status(istruc) = 0 - src_struc_fraction_open(istruc) = 0.0 - ! - else - ! - src_struc_fraction_open(istruc) = 1.0 - elapsed / src_struc_closing_duration(istruc) - ! - endif + src_struc_fraction_open(istruc) = 1.0 - elapsed / src_struc_closing_duration(istruc) ! - end select + endif + ! + end select + ! + endif + ! + ! --------------------------------------------------------------- + ! Per-type flux formula. Produces a raw signed discharge qq in + ! m^3/s, before the common-tail scaling by fraction_open and + ! direction filter. + ! --------------------------------------------------------------- + ! + select case(src_struc_type(istruc)) + ! + case(structure_pump) + ! + qq = src_struc_q(istruc) ! - ! Flow uses the src pair (nmin/nmout), not the obs pair. - ! Bates et al. (2010) inertial formulation, per unit width: + ! Reduction curve: scale by upstream depth so the pump cannot + ! pump the intake cell dry. reduction_depth is a module-level + ! constant (see top of module); not user-tunable. + ! + h_up = max(real(zs(nmin), 4) - zb(nmin), 0.0) + qq = qq * min(1.0, h_up / reduction_depth) + ! + case(structure_culvert_simple) + ! + ! Bidirectional: Q = flow_coef * sign(dh) * sqrt(|dh|). + ! The legacy "check_valve" alias maps to direction_positive + ! in the parser; the direction filter in the common tail + ! below restricts the allowed sign when requested. + ! + if (zs(nmin) > zs(nmout)) then + ! + qq = src_struc_flow_coef(istruc) * sqrt(zs(nmin) - zs(nmout)) + ! + else + ! + qq = -src_struc_flow_coef(istruc) * sqrt(zs(nmout) - zs(nmin)) + ! + endif + ! + case(structure_gate) + ! + ! Bidirectional culvert-style flow. Flow uses the src pair + ! (nmin/nmout), not the obs pair. Bates et al. (2010) + ! inertial formulation, per unit width: ! q^{n+1} = (q^n - g*h*(dzs/ds)*dt) / ! (1 + g*n^2*dt*|q^n| / h^{7/3}) ! with h = max(max(zs_in, zs_out) - zsill, 0). - ! Multiply by width * fraction_open to get the structure - ! discharge. q_src_struc(istruc) holds q from the previous step - ! in full (signed, m^3/s) discharge form, so convert via - ! width * fraction_open to get qq0 in per-unit-width units. - ! Sign convention: qq > 0 means flow nmin -> nmout, matching - ! dzds = (zs_out - zs_in)/dist (positive downstream level - ! -> negative dzds -> positive qq). + ! Multiply by width to get the full structure discharge; + ! scaling by fraction_open happens in the common tail. + ! q_src_struc(istruc) holds the previous step's discharge + ! after the full common-tail scaling (width*fraction_open), + ! so unscale by (width*fraction_open) to recover qq0 in + ! per-unit-width form. Sign convention: qq > 0 means flow + ! nmin -> nmout, matching dzds = (zs_out - zs_in)/dist. ! frac = src_struc_fraction_open(istruc) wdt = src_struc_width(istruc) @@ -875,7 +1000,8 @@ subroutine update_src_structures(t, dt, tloop) qq0 = q_src_struc(istruc) / (wdt * max(frac, 0.001)) qq = (qq0 - g * hgate * dzds * dt) / & (1.0 + g * mng * mng * dt * abs(qq0) / hgate**(7.0/3.0)) - qq = qq * wdt * frac + qq = qq * wdt + qq = src_struc_flow_coef(istruc) * qq ! else ! @@ -883,13 +1009,85 @@ subroutine update_src_structures(t, dt, tloop) ! endif ! - qq = sign(min(abs(qq), qqmax), qq) + case(structure_culvert) + ! + ! Regime-aware culvert. The controlling sill is the higher + ! of the two inverts (flow cannot pass until the upstream + ! water level reaches it). Upstream / downstream are picked + ! by the water-level difference, so the structure is + ! bidirectional and the direction filter in the common tail + ! below restricts the sign when requested. + ! + ! Two regimes, selected by h_dn/h_up against the user-set + ! submergence_ratio threshold (default 2/3 = 0.667, the + ! standard broad-crested-weir / Villemonte value): + ! + ! submerged (h_dn/h_up >= threshold): + ! qq = flow_coef * a_eff * sqrt(2 g |dh|) + ! free / inlet-controlled (h_dn/h_up < threshold): + ! qq = flow_coef * a_eff * sqrt(2 g h_up) + ! + ! The flow area a_eff = width * min(h_up, height) caps at + ! the barrel height, so a deeply-submerged inlet can't + ! give unbounded discharge. + ! + zsill = max(src_struc_invert_1(istruc), src_struc_invert_2(istruc)) + ! + dh = real(zs(nmin), 4) - real(zs(nmout), 4) + ! + if (dh >= 0.0) then + ! + h_up = max(real(zs(nmin), 4) - zsill, 0.0) + h_dn = max(real(zs(nmout), 4) - zsill, 0.0) + qq_sign = 1.0 + ! + else + ! + h_up = max(real(zs(nmout), 4) - zsill, 0.0) + h_dn = max(real(zs(nmin), 4) - zsill, 0.0) + qq_sign = -1.0 + ! + endif + ! + if (h_up <= 0.0) then + ! + qq = 0.0 + ! + else + ! + a_eff = src_struc_width(istruc) * min(h_up, src_struc_height(istruc)) + ! + if (h_dn / h_up >= src_struc_submergence_ratio(istruc)) then + ! + qq = qq_sign * src_struc_flow_coef(istruc) * a_eff * sqrt(2.0 * g * abs(dh)) + ! + else + ! + qq = qq_sign * src_struc_flow_coef(istruc) * a_eff * sqrt(2.0 * g * h_up) + ! + endif + ! + endif ! end select ! + ! --------------------------------------------------------------- + ! Common tail: scale by fraction_open (state-machine output) and + ! apply the direction filter. Structures without rules sit at + ! fraction_open=1.0 so the scaling is a no-op; structures with + ! direction_both (the default) see the filter as a no-op too. + ! --------------------------------------------------------------- + ! + qq = qq * src_struc_fraction_open(istruc) + ! + if (src_struc_direction(istruc) == direction_positive .and. qq < 0.0) qq = 0.0 + if (src_struc_direction(istruc) == direction_negative .and. qq > 0.0) qq = 0.0 + ! ! Relaxation: blend new and previous discharge to damp oscillations. + ! structure_relax is a dimensionless step count: alpha = 1/N damps + ! the discharge response over roughly N time steps. Typical 1-10. ! - alpha = dt / structure_relax + alpha = 1.0 / structure_relax qq = alpha * qq + (1.0 - alpha) * q_src_struc(istruc) ! ! Limit discharge by available volume in the intake / outfall cell. @@ -953,22 +1151,35 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! ! [[src_structure]] ! name = "south_tide_gate" ! required, string (sole identifier) - ! type = "gate" ! required, one of pump/check_valve/culvert/gate + ! type = "gate" ! required, one of pump/culvert_simple/gate/culvert + ! ! legacy alias: "check_valve" -> culvert_simple + direction="positive" + ! ! note: "culvert" now resolves to the detailed-culvert physics type; + ! ! users wanting the lumped one-coefficient form must say + ! ! "culvert_simple" explicitly. Orifice behaviour is recoverable + ! ! as "culvert" with submergence_ratio = 0.0. + ! direction = "both" ! optional, culvert_simple/culvert only + ! ! one of "both" (default), "positive", "negative" + ! ! positive: allow flow src_1 -> src_2 only + ! ! negative: allow flow src_2 -> src_1 only ! src_1_x = ... ; src_1_y = ... ; src_2_x = ... ; src_2_y = ... ! obs_1_x = ... ; obs_1_y = ... ; obs_2_x = ... ; obs_2_y = ... ! q = ... ! pump discharge - ! qmax = ... ! max discharge magnitude (safety clamp) ! width = ... ; sill_elevation = ... ; mannings_n = ... ! opening_duration = ... ; closing_duration = ... - ! flow_coef = ... ! culvert / check_valve flow coefficient + ! flow_coef = ... ! culvert_simple / culvert flow coefficient + ! height = ... ! culvert pipe height (m) + ! invert_1 = ... ; invert_2 = ... ! culvert invert elevations at src_1/src_2 ends + ! submergence_ratio = ... ! culvert submergence threshold h_dn/h_up (-) ! rules_open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr ! rules_close = "z2>2.0" ! optional trigger expr ! ! Per-type required keys (enforced on parse): - ! pump : name, src_1_x, src_1_y, src_2_x, src_2_y, q - ! culvert : name, src_1_x, src_1_y, src_2_x, src_2_y, flow_coef - ! check_valve : name, src_1_x, src_1_y, src_2_x, src_2_y - ! gate : name, src_1_x, src_1_y, src_2_x, src_2_y, width, sill_elevation + ! pump : name, src_1_x, src_1_y, src_2_x, src_2_y, q + ! culvert_simple : name, src_1_x, src_1_y, src_2_x, src_2_y, flow_coef + ! gate : name, src_1_x, src_1_y, src_2_x, src_2_y, width, sill_elevation + ! culvert : name, src_1_x, src_1_y, src_2_x, src_2_y, + ! width, height, invert_1, invert_2 + ! (optional: flow_coef=0.6, submergence_ratio=0.667) ! ! On success, structures is allocated to the exact number of entries ! (can be 0). On any I/O or parse failure, structures is left @@ -989,7 +1200,7 @@ subroutine read_toml_src_structures(filename, structures, ierr) type(toml_error), allocatable :: err type(toml_array), pointer :: arr_structs type(toml_table), pointer :: tbl_struct - character(len=:), allocatable :: name_str, type_str, rule_str + character(len=:), allocatable :: name_str, type_str, rule_str, dir_str, type_str_lc integer :: n_struct, i, stat, ierr_parse ! ierr = 0 @@ -1102,12 +1313,7 @@ subroutine read_toml_src_structures(filename, structures, ierr) call check_required(tbl_struct, [ character(len=16) :: & 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'q' ], i, ierr) ! - case (structure_check_valve) - ! - call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y' ], i, ierr) - ! - case (structure_culvert) + case (structure_culvert_simple) ! call check_required(tbl_struct, [ character(len=16) :: & 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'flow_coef' ], i, ierr) @@ -1118,6 +1324,12 @@ subroutine read_toml_src_structures(filename, structures, ierr) 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & 'width', 'sill_elevation' ], i, ierr) ! + case (structure_culvert) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & + 'width', 'height', 'invert_1', 'invert_2' ], i, ierr) + ! end select ! if (ierr /= 0) then @@ -1149,13 +1361,89 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! arithmetic and to match the legacy-reader fallbacks. ! call get_value(tbl_struct, 'q', structures(i)%q, 0.0, stat=stat) - call get_value(tbl_struct, 'qmax', structures(i)%qmax, 1.0e30, stat=stat) call get_value(tbl_struct, 'width', structures(i)%width, 0.0, stat=stat) call get_value(tbl_struct, 'sill_elevation', structures(i)%sill_elevation, 0.0, stat=stat) - call get_value(tbl_struct, 'mannings_n', structures(i)%mannings_n, 0.024, stat=stat) - call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 600.0, stat=stat) - call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 600.0, stat=stat) - call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 1.0, stat=stat) + ! + ! opening_duration / closing_duration default depends on type: gate keeps + ! its historical 600 s (legacy "dtype 4" gates always had finite ramp + ! durations), pump / culvert_simple / culvert default to 0 s (instant + ! open/close when a rule fires; skips the transient states 2 and 3). + ! + if (structures(i)%structure_type == structure_gate) then + ! + call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 600.0, stat=stat) + call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 600.0, stat=stat) + ! + else + ! + call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 0.0, stat=stat) + call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 0.0, stat=stat) + ! + endif + ! + ! flow_coef default differs by type: 1.0 for culvert_simple (legacy + ! lumped one-coefficient form), 0.6 for the detailed culvert + ! (standard orifice discharge coefficient). + ! + if (structures(i)%structure_type == structure_culvert) then + ! + call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 0.6, stat=stat) + ! + else + ! + call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 1.0, stat=stat) + ! + endif + ! + ! mannings_n (gate only). Default 0.024 for concrete-lined gate sill. + ! + call get_value(tbl_struct, 'mannings_n', structures(i)%mannings_n, 0.024, stat=stat) + ! + ! Detailed-culvert geometry + submergence threshold. Geometry keys + ! are required (enforced above); submergence_ratio defaults to 2/3 + ! (0.667), the standard broad-crested-weir / Villemonte value. + ! + call get_value(tbl_struct, 'height', structures(i)%height, 0.0, stat=stat) + call get_value(tbl_struct, 'invert_1', structures(i)%invert_1, 0.0, stat=stat) + call get_value(tbl_struct, 'invert_2', structures(i)%invert_2, 0.0, stat=stat) + call get_value(tbl_struct, 'submergence_ratio', structures(i)%submergence_ratio, 0.667, stat=stat) + ! + ! Optional direction filter (culvert_simple / culvert). Default is + ! direction_both. Unknown strings are a hard error. + ! + structures(i)%direction = direction_both + ! + if (allocated(dir_str)) deallocate(dir_str) + call get_value(tbl_struct, 'direction', dir_str, stat=stat) + ! + if (allocated(dir_str)) then + ! + call parse_direction(dir_str, structures(i)%direction, ierr_parse) + ! + if (ierr_parse /= 0) then + ! + ierr = ierr_parse + write(logstr,'(a,a,a,i0)')' Error ! Unknown direction "', trim(dir_str), & + '" in src_structure entry ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + endif + ! + ! Legacy alias side-effect: "check_valve" always pins direction_positive + ! regardless of any explicit direction key. Detect on the lowered type + ! string so "Check_Valve" etc. are handled identically. + ! + type_str_lc = to_lower(type_str) + ! + if (type_str_lc == 'check_valve') then + ! + structures(i)%direction = direction_positive + ! + endif ! ! Optional rules_open / rules_close string expressions. Absent keys ! leave the rule strings unallocated on the derived type; marshal @@ -1175,6 +1463,10 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! subroutine cleanup_on_error() ! + ! Internal helper for the parse loop: drop the partially-filled + ! structures(:) array so the caller always sees it unallocated on + ! error exit. Trivial deallocator. + ! if (allocated(structures)) deallocate(structures) ! end subroutine @@ -1221,6 +1513,14 @@ subroutine parse_structure_type(str, code, ierr) ! ! Translate a TOML "type" string to one of the structure_* codes. ! + ! Legacy alias accepted (quietly, no warning): + ! "check_valve" -> structure_culvert_simple + ! (caller is responsible for pinning direction_positive) + ! + ! Note: "culvert" now resolves to structure_culvert (the detailed + ! physics-based pipe-flow type). Users wanting the lumped one-coefficient + ! form must say "culvert_simple" explicitly. + ! implicit none ! character(len=*), intent(in) :: str @@ -1239,17 +1539,57 @@ subroutine parse_structure_type(str, code, ierr) ! code = structure_pump ! - case ('check_valve') + case ('culvert_simple', 'check_valve') ! - code = structure_check_valve + code = structure_culvert_simple + ! + case ('gate') + ! + code = structure_gate ! case ('culvert') ! code = structure_culvert ! - case ('gate') + case default ! - code = structure_gate + ierr = 1 + ! + end select + ! + end subroutine + ! + ! + subroutine parse_direction(str, code, ierr) + ! + ! Translate a TOML "direction" string to one of the direction_* codes. + ! Accepts "both" / "positive" / "negative" case-insensitively. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = 0 + s = to_lower(str) + ! + select case (s) + ! + case ('both') + ! + code = direction_both + ! + case ('positive') + ! + code = direction_positive + ! + case ('negative') + ! + code = direction_negative ! case default ! @@ -1297,7 +1637,7 @@ subroutine write_src_structures_log_summary() implicit none ! integer :: i - character(len=32) :: type_str + character(len=32) :: type_str, dir_str ! if (nr_src_structures <= 0) return ! @@ -1317,18 +1657,18 @@ subroutine write_src_structures_log_summary() ! type_str = 'pump' ! - case (structure_culvert) - ! - type_str = 'culvert' + case (structure_culvert_simple) ! - case (structure_check_valve) - ! - type_str = 'check_valve' + type_str = 'culvert_simple' ! case (structure_gate) ! type_str = 'gate' ! + case (structure_culvert) + ! + type_str = 'culvert' + ! case default ! type_str = 'unknown' @@ -1350,10 +1690,9 @@ subroutine write_src_structures_log_summary() write(logstr,'(a,f0.3,a,f0.3,a)')' src_2: (', src_struc_src_2_x(i), ', ', src_struc_src_2_y(i), ')' call write_log(logstr, 0) ! - ! obs coords are meaningful for culvert / check_valve / gate. + ! obs coords are meaningful for culvert_simple / gate. ! - if (src_struc_type(i) == structure_culvert .or. & - src_struc_type(i) == structure_check_valve .or. & + if (src_struc_type(i) == structure_culvert_simple .or. & src_struc_type(i) == structure_gate) then ! write(logstr,'(a,f0.3,a,f0.3,a)')' obs_1: (', src_struc_obs_1_x(i), ', ', src_struc_obs_1_y(i), ')' @@ -1371,21 +1710,63 @@ subroutine write_src_structures_log_summary() ! endif ! - if (src_struc_type(i) == structure_culvert .or. & - src_struc_type(i) == structure_check_valve .or. & - src_struc_type(i) == structure_gate) then + if (src_struc_type(i) == structure_culvert_simple) then ! - write(logstr,'(a,es12.4,a)')' qmax: ', src_struc_qmax(i), ' (m3/s)' + write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) call write_log(logstr, 0) ! endif ! - if (src_struc_type(i) == structure_culvert .or. & - src_struc_type(i) == structure_check_valve) then + ! Direction filter (culvert_simple / culvert) + ! + if (src_struc_type(i) == structure_culvert_simple .or. & + src_struc_type(i) == structure_culvert) then + ! + select case (src_struc_direction(i)) + ! + case (direction_both) + ! + dir_str = 'both' + ! + case (direction_positive) + ! + dir_str = 'positive' + ! + case (direction_negative) + ! + dir_str = 'negative' + ! + case default + ! + dir_str = 'unknown' + ! + end select + ! + write(logstr,'(a,a)')' direction: ', trim(dir_str) + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_type(i) == structure_culvert) then + ! + write(logstr,'(a,f0.4,a)')' width: ', src_struc_width(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4,a)')' height: ', src_struc_height(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4,a)')' invert_1: ', src_struc_invert_1(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4,a)')' invert_2: ', src_struc_invert_2(i), ' (m)' + call write_log(logstr, 0) ! write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) call write_log(logstr, 0) ! + write(logstr,'(a,f0.4)')' submerg_r: ', src_struc_submergence_ratio(i) + call write_log(logstr, 0) + ! endif ! if (src_struc_type(i) == structure_gate) then @@ -1439,6 +1820,25 @@ subroutine write_src_structures_log_summary() ! endif ! + ! Opening/closing durations. For gate structures these are always + ! printed (above); for other types only print if rules are set and + ! the duration is non-zero (non-default). + ! + if (src_struc_type(i) /= structure_gate) then + ! + if ((src_struc_rule_open(i) > 0 .or. src_struc_rule_close(i) > 0) .and. & + (src_struc_opening_duration(i) > 0.0 .or. src_struc_closing_duration(i) > 0.0)) then + ! + write(logstr,'(a,f0.2,a)')' opening: ', src_struc_opening_duration(i), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.2,a)')' closing: ', src_struc_closing_duration(i), ' (s)' + call write_log(logstr, 0) + ! + endif + ! + endif + ! call write_log('', 0) ! enddo @@ -1478,7 +1878,7 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) real*4 :: g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls character(len=512) :: line, trimmed character(len=32) :: name_str - character(len=16) :: type_name, par_name + character(len=16) :: type_name, par_name, dir_name character(len=13) :: zmin_str, zmax_str character(len=128) :: rule_open_str, rule_close_str ! @@ -1574,6 +1974,12 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) ! ! Branch on dtype. Gates (4, 5) and unknown codes set ierr and bail. ! + ! dir_name is left blank unless dtype pins a direction filter; a blank + ! dir_name causes the emitter below to skip the direction key entirely, + ! which reads back as direction_both (the default). + ! + dir_name = '' + ! select case (dtype) ! case (1) @@ -1583,13 +1989,18 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) ! case (2) ! - type_name = 'culvert' + ! legacy culvert -> bidirectional culvert_simple + ! + type_name = 'culvert_simple' par_name = 'flow_coef' ! case (3) ! - type_name = 'check_valve' + ! legacy check_valve -> culvert_simple with direction = "positive" + ! + type_name = 'culvert_simple' par_name = 'flow_coef' + dir_name = 'positive' ! case (4) ! @@ -1676,6 +2087,13 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) write(u_out,'(a)') '[[src_structure]]' write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' write(u_out,'(a,a,a)') 'type = "', trim(type_name),'"' + ! + if (len_trim(dir_name) > 0) then + ! + write(u_out,'(a,a,a)') 'direction = "', trim(dir_name), '"' + ! + endif + ! write(u_out,'(a,es14.6)') 'src_1_x = ', x1 write(u_out,'(a,es14.6)') 'src_1_y = ', y1 write(u_out,'(a,es14.6)') 'src_2_x = ', x2 From 098a2ccf7b64dc5eb71799e283a7b7437ad3aeef Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sat, 18 Apr 2026 20:36:40 +0200 Subject: [PATCH 28/65] Clarify structure state machine and rule syntax Update docs/input_structures.rst to rewrite and clarify the structure state-machine and the rule expression language. The state-machine paragraph was reworded to explicitly mention SFINCS, describe opening/closing behavior, instantaneous transitions when durations are 0.0, and that structures without rules stay fully open. The rule syntax section was expanded into a short, explicit list of atoms (z1, z2, z2-z1), their meaning (with units), the allowed comparison operators (< and > only), logical connectives (& and |), grouping with parentheses, and case-insensitivity. Also replace the vague term "src structures" with "drainage structures" for clarity. --- docs/input_structures.rst | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/docs/input_structures.rst b/docs/input_structures.rst index 17038ceef..1cf6fafbe 100644 --- a/docs/input_structures.rst +++ b/docs/input_structures.rst @@ -424,9 +424,15 @@ Each structure has an internal state machine with four states: - ``2`` — opening (transient, time-based) - ``3`` — closing (transient, time-based) -On a time step, if the current state is ``0`` (closed), the ``rules_open`` expression is evaluated; if it fires, the state advances to ``2`` (opening) and ``fraction_open`` ramps from 0 to 1 linearly over ``opening_duration`` seconds. Symmetrically, from state ``1`` (open) a firing ``rules_close`` expression moves the state to ``3`` (closing) with ``fraction_open`` ramping from 1 to 0 over ``closing_duration`` seconds. The transient states advance on elapsed time only, so rule hysteresis cannot thrash. When ``opening_duration`` (or ``closing_duration``) is ``0.0``, the transition is instantaneous and the transient state is skipped. Structures that specify neither ``rules_open`` nor ``rules_close`` stay at the init-time default (``status = 1``, ``fraction_open = 1.0``) and the state-machine scaling is a no-op. +At every time step, SFINCS checks the current state of the structure. If the structure is closed, it evaluates the ``rules_open`` expression; when that rule becomes true, the structure starts opening and ``fraction_open`` increases linearly from 0 to 1 over ``opening_duration`` seconds. If the structure is open, it evaluates the ``rules_close`` expression; when that rule becomes true, the structure starts closing and ``fraction_open`` decreases linearly from 1 to 0 over ``closing_duration`` seconds. While a structure is opening or closing, SFINCS only looks at the clock — the rules are not re-checked — so the structure cannot rapidly toggle on and off. Set ``opening_duration`` or ``closing_duration`` to ``0.0`` for an instantaneous transition. A structure without rules simply stays fully open for the entire simulation. -The rule expressions use a compact boolean grammar. Atoms are ``z1``, ``z2``, and ``z2-z1`` (all three case-insensitive); there is **no** ``z1-z2`` atom — invert the comparison sign instead. ``z1`` is the water level in the ``obs_1`` cell and ``z2`` is the water level in the ``obs_2`` cell. Comparison operators are ``<`` and ``>`` only (no ``<=`` / ``>=``). Boolean connectives are ``&`` (and) and ``|`` (or); parentheses can be used for grouping. +The rules use a small expression language. The building blocks are: + +- ``z1`` — water level at the ``obs_1`` cell (m) +- ``z2`` — water level at the ``obs_2`` cell (m) +- ``z2-z1`` — the head difference (m); note there is no ``z1-z2`` form, so flip the comparison sign instead (``z1-z2 > 0.1`` becomes ``z2-z1 < -0.1``) + +You compare one of these against a number using ``<`` or ``>`` (the ``<=`` and ``>=`` forms are not supported). Multiple comparisons can be combined with ``&`` for "and" and ``|`` for "or", and you can use parentheses to group them. All names are case-insensitive. Examples: @@ -439,7 +445,7 @@ Examples: **Discharge relaxation: structure_relax** -Discharges from src structures are relaxation-blended between time steps to damp oscillations: +Discharges from drainage structures are relaxation-blended between time steps to damp oscillations: .. math:: From 5b582ab0aed89a7a58779c6b64d7a3dda9de5634 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sat, 18 Apr 2026 20:44:31 +0200 Subject: [PATCH 29/65] Clarify discharge argument for drainage structures Replace the culvert example with a clarifying note that the `discharge` argument is for pumps only. Document that culverts and gates use geometry-based parameters (width, height, inverts, flow coefficients, etc.) and point readers to the HydroMT-SFINCS documentation for the full argument list. Removed the redundant culvert sample and 'More information:' label. --- docs/input_structures.rst | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/docs/input_structures.rst b/docs/input_structures.rst index 1cf6fafbe..249abd265 100644 --- a/docs/input_structures.rst +++ b/docs/input_structures.rst @@ -526,16 +526,8 @@ Set ``storeqdrain = 1`` in ``sfincs.inp`` to write the time-series discharge per merge=True ) - # OR as a culvert: +The ``discharge`` argument above is the pump discharge and applies to pumps only. Culverts and gates carry their own geometry-based parameters (width, height, inverts, flow coefficients, etc.) rather than a single discharge value — see the HydroMT-SFINCS documentation for the full argument list per structure type: - sf.drainage_structures.create( - locations="drainage_input.geojson", - stype='culvert', - discharge=100.0, - merge=True - ) - -More information: https://deltares.github.io/hydromt_sfincs/latest/_generated/hydromt_sfincs.components.geometries.SfincsDrainageStructures.create.html **Legacy fixed-column drn format** From a99fd78a39572f0bec6184bc934541c83bf4d25d Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 08:10:26 +0200 Subject: [PATCH 30/65] refactor(timers): extract wall-clock timing into sfincs_timers module Replaces the scattered system_clock / tloop* bookkeeping spread across the SFINCS modules with a single, named-timer module (sfincs_timers). The module exposes timer_start(name) / timer_stop(name) / timer_elapsed, plus helpers that render the post-run summary (timer_write_headers, timer_write_summary, timer_write_runtimes_file). Timers are registered lazily on first start and accumulate across calls. Per-phase timers now live next to the code they measure: Input, Simulation loop, Boundaries, Discharges, Meteo fields, Meteo forcing, Infiltration, Momentum, Structures, Continuity, Non-hydrostatic, SnapWave, Wavemaker, Output. Driver and callee subroutine signatures lose their trailing tloop argument; sfincs_data drops the orphaned tstart_all / tfinish_all globals. The progress reporter in sfincs_lib now reads elapsed loop wall time via timer_elapsed('Simulation loop'), and the net-CDF total_runtime attribute is written from the same source. Build: clean (sfincs_lib, sfincs, netcdff all 0 errors). Smoke test: legacy_main/pump reproduces point_zs and crosssection_discharge bit-exactly against the main-branch reference; summary / percent-done lines render as expected. Co-Authored-By: Claude Opus 4.7 (1M context) --- source/sfincs_lib/sfincs_lib.vfproj | 1 + source/src/Makefile.am | 1 + source/src/sfincs_bathtub.f90 | 14 +- source/src/sfincs_boundaries.f90 | 20 +- source/src/sfincs_continuity.f90 | 26 +- source/src/sfincs_data.f90 | 1 - source/src/sfincs_discharges.f90 | 14 +- source/src/sfincs_infiltration.f90 | 18 +- source/src/sfincs_lib.f90 | 156 +++-------- source/src/sfincs_meteo.f90 | 34 +-- source/src/sfincs_momentum.f90 | 16 +- source/src/sfincs_ncoutput.F90 | 24 +- source/src/sfincs_nonhydrostatic.f90 | 18 +- source/src/sfincs_output.f90 | 45 ++-- source/src/sfincs_snapwave.f90 | 14 +- source/src/sfincs_structures.f90 | 16 +- source/src/sfincs_timers.f90 | 385 +++++++++++++++++++++++++++ source/src/sfincs_wavemaker.f90 | 18 +- 18 files changed, 519 insertions(+), 302 deletions(-) create mode 100644 source/src/sfincs_timers.f90 diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 34bf8f520..0a926291c 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -116,6 +116,7 @@ + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index 891652f08..09df42953 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -16,6 +16,7 @@ lib_LTLIBRARIES = libsfincs.la #all sources for sfincs that go into the library (all but the program) libsfincs_la_SOURCES = \ sfincs_log.f90 \ + sfincs_timers.f90 \ sfincs_date.f90 \ sfincs_spiderweb.f90 \ sfincs_data.f90 \ diff --git a/source/src/sfincs_bathtub.f90 b/source/src/sfincs_bathtub.f90 index 76e1c60f9..c63a29e88 100644 --- a/source/src/sfincs_bathtub.f90 +++ b/source/src/sfincs_bathtub.f90 @@ -114,23 +114,18 @@ subroutine initialize_bathtub() end subroutine - subroutine bathtub_compute_water_levels(tloop) + subroutine bathtub_compute_water_levels() ! use sfincs_data + use sfincs_timers use geometry ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! integer :: nm, i1, i2 real*4 :: zbt, w1, w2 ! - call system_clock(count0, count_rate, count_max) + call timer_start('Continuity') ! !$omp parallel & !$omp private ( nm, i1, i2, w1, w2 ) @@ -168,8 +163,7 @@ subroutine bathtub_compute_water_levels(tloop) ! !$acc update device( zs, zsmax ) ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate + call timer_stop('Continuity') ! end subroutine diff --git a/source/src/sfincs_boundaries.f90 b/source/src/sfincs_boundaries.f90 index 13a49477c..80f84c645 100644 --- a/source/src/sfincs_boundaries.f90 +++ b/source/src/sfincs_boundaries.f90 @@ -1125,26 +1125,21 @@ subroutine update_boundary_fluxes(dt, t) - subroutine update_boundaries(t, dt, tloop) + subroutine update_boundaries(t, dt) ! ! Update all boundary conditions ! use sfincs_data + use sfincs_timers ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*8 :: t real*4 :: dt ! - call system_clock(count0, count_rate, count_max) - ! if (boundaries_in_mask) then + ! + call timer_start('Boundaries') ! if (nbnd > 0) then ! @@ -1158,7 +1153,7 @@ subroutine update_boundaries(t, dt, tloop) ! as these are not used in bathtub mode ! if (.not. bathtub) then - ! + ! ! Update boundary conditions at grid points (water levels) ! call update_boundary_conditions(t, dt) @@ -1169,11 +1164,10 @@ subroutine update_boundaries(t, dt, tloop) ! endif ! + call timer_stop('Boundaries') + ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate - ! end subroutine ! ! diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index 592477666..0ffa4c548 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -2,22 +2,17 @@ module sfincs_continuity contains - subroutine compute_water_levels(t, dt, tloop) + subroutine compute_water_levels(t, dt) ! use sfincs_data + use sfincs_timers ! implicit none ! real*4 :: dt real*8 :: t ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! - call system_clock(count0, count_rate, count_max) + call timer_start('Continuity') ! if (subgrid) then ! @@ -27,18 +22,17 @@ subroutine compute_water_levels(t, dt, tloop) ! call compute_water_levels_regular(dt,t) ! - endif + endif ! ! Put non-default store options in a separate subroutine (all but zsmax) to save computation time when not used (both regular and subgrid): ! - if ((store_maximum_velocity .eqv. .true.) .or. (store_maximum_flux .eqv. .true.) .or. (store_twet .eqv. .true.)) then - ! - call compute_store_variables(dt) - ! + if ((store_maximum_velocity .eqv. .true.) .or. (store_maximum_flux .eqv. .true.) .or. (store_twet .eqv. .true.)) then + ! + call compute_store_variables(dt) + ! endif - ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + ! + call timer_stop('Continuity') ! end subroutine diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 935be5983..e29b66135 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -4,7 +4,6 @@ module sfincs_data character*256 :: build_revision, build_date !!!! !!! Time variables - real :: tstart_all, tfinish_all real*4 :: dtavg real*4 :: min_dt !!! diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index dd50ffd27..c26e5499a 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -310,20 +310,15 @@ subroutine read_discharges() ! ! ! - subroutine update_discharges(t, dt, tloop) + subroutine update_discharges(t, dt) ! ! Update discharges ! use sfincs_data + use sfincs_timers ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*8 :: t real*4 :: dt real*4 :: qq @@ -334,7 +329,7 @@ subroutine update_discharges(t, dt, tloop) ! integer isrc, itsrc, idrn, jin, jout, nmin, nmout ! - call system_clock(count0, count_rate, count_max) + call timer_start('Discharges') ! ! Compute instantaneous discharges from point sources ! @@ -640,8 +635,7 @@ subroutine update_discharges(t, dt, tloop) ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate + call timer_stop('Discharges') ! end subroutine diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index bce4af73f..fe83b05ac 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -604,11 +604,12 @@ subroutine initialize_infiltration() end subroutine - subroutine update_infiltration_map(dt, tloop) + subroutine update_infiltration_map(dt) ! ! Update infiltration rates in each grid cell ! use sfincs_data + use sfincs_timers ! implicit none ! @@ -617,15 +618,9 @@ subroutine update_infiltration_map(dt, tloop) real*4 :: Qq real*4 :: I real*4 :: hh_local, a - real*4 :: dt + real*4 :: dt ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! - call system_clock(count0, count_rate, count_max) + call timer_start('Infiltration') ! if (inftype == 'con' .or. inftype == 'c2d') then ! @@ -1026,9 +1021,8 @@ subroutine update_infiltration_map(dt, tloop) ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate + call timer_stop('Infiltration') ! - end subroutine + end subroutine end module diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index ca3441bf4..2f66e62c6 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -26,6 +26,7 @@ module sfincs_lib use sfincs_bathtub use sfincs_openacc use sfincs_log + use sfincs_timers use sfincs_timestep_analysis ! implicit none @@ -41,13 +42,6 @@ module sfincs_lib ! private ! - integer*8 :: count0 - integer*8 :: count00 - integer*8 :: countdt0 - integer*8 :: countdt1 - integer*8 :: count1 - integer*8 :: count_rate - integer*8 :: count_max integer :: nt ! integer :: ntmapout @@ -75,9 +69,7 @@ module sfincs_lib logical :: update_meteo logical :: update_waves ! - real :: tstart, tfinish, tloopflux, tloopcont, tloopstruc, tloopbnd, tloopsrc, tloopwnd1, tloopwnd2, tloopinf, tloopoutput, tloopsnapwave, tloopwavemaker, tloopnonh real :: time_per_timestep - real :: tinput real :: percdone,percdonenext,trun,trem ! contains @@ -134,7 +126,7 @@ function sfincs_initialize() result(ierr) call write_log('Build-Date: '//trim(build_date), 1) call write_log('', 1) ! - call system_clock(count0, count_rate, count_max) + call timer_start('Input') ! call write_log('------ Preparing model simulation --------', 1) call write_log('', 1) @@ -270,9 +262,7 @@ function sfincs_initialize() result(ierr) ! endif ! - call system_clock(count1, count_rate, count_max) - ! - tinput = 1.0 * (count1 - count0) / count_rate + call timer_stop('Input') ! ! Initialize some parameters ! @@ -298,18 +288,6 @@ function sfincs_initialize() result(ierr) update_meteo = .false. ! update meteo fields update_waves = .false. ! update wave fields ! - tloopflux = 0.0 - tloopcont = 0.0 - tloopstruc = 0.0 - tloopbnd = 0.0 - tloopsrc = 0.0 - tloopwnd1 = 0.0 - tloopwnd2 = 0.0 - tloopinf = 0.0 - tloopsnapwave = 0.0 - tloopwavemaker = 0.0 - tloopnonh = 0.0 - ! call write_log('Initializing output ...', 0) ! call initialize_output(tmapout, tmaxout, thisout, trstout) @@ -328,7 +306,7 @@ function sfincs_initialize() result(ierr) call write_log(logstr, 1) call write_log('', 1) ! - call system_clock(count00, count_rate, count_max) + call timer_start('Simulation loop') ! end function sfincs_initialize ! @@ -377,8 +355,6 @@ function sfincs_update(dtrange) result(ierr) ! Start computational loop ! do while (t < tend) - ! - call system_clock(countdt0, count_rate, count_max) ! write_map = .false. write_his = .false. @@ -521,13 +497,13 @@ function sfincs_update(dtrange) result(ierr) ! Update spatially-varying meteo (this does not happen every time step) ! Read and interpolate to grid ! - call update_meteo_fields(t, tloopwnd1) + call update_meteo_fields(t) ! endif ! ! Update forcing used in momentum and continuity equations (this does happen every time step) ! - call update_meteo_forcing(t, dt, tloopwnd2) + call update_meteo_forcing(t, dt) ! ! Update infiltration ! @@ -535,7 +511,7 @@ function sfincs_update(dtrange) result(ierr) ! ! Compute infiltration rates ! - call update_infiltration_map(dt, tloopinf) + call update_infiltration_map(dt) ! endif ! @@ -543,17 +519,17 @@ function sfincs_update(dtrange) result(ierr) ! ! Update boundary conditions ! - call update_boundaries(t, dt, tloopbnd) + call update_boundaries(t, dt) ! ! Update discharges ! - call update_discharges(t, dt, tloopsrc) + call update_discharges(t, dt) ! if (snapwave .and. update_waves) then ! call timer(t3) ! - call update_wave_field(t, tloopsnapwave) + call update_wave_field(t) ! call timer(t4) write(logstr,'(a,f10.1,a,f6.2,a)')'Computing SnapWave at t = ', t, ' s took ', t4 - t3, ' seconds' @@ -573,7 +549,7 @@ function sfincs_update(dtrange) result(ierr) ! ! In bathtub mode, only update water levels based on boundary conditions ! - call bathtub_compute_water_levels(tloopcont) + call bathtub_compute_water_levels() ! else ! @@ -581,7 +557,7 @@ function sfincs_update(dtrange) result(ierr) ! ! First compute fluxes ! - call compute_fluxes(dt, tloopflux) + call compute_fluxes(dt) ! if (timestep_analysis) then ! @@ -591,13 +567,13 @@ function sfincs_update(dtrange) result(ierr) ! if (wavemaker) then ! - call update_wavemaker_fluxes(t, dt, tloopwavemaker) + call update_wavemaker_fluxes(t, dt) ! endif ! if (nrstructures>0) then ! - call compute_fluxes_over_structures(tloopstruc) + call compute_fluxes_over_structures() ! endif ! @@ -607,7 +583,7 @@ function sfincs_update(dtrange) result(ierr) ! ! Apply non-hydrostatic pressure corrections to q and uv ! - call compute_nonhydrostatic(dt, tloopnonh) + call compute_nonhydrostatic(dt) ! endif ! @@ -615,7 +591,7 @@ function sfincs_update(dtrange) result(ierr) ! ! Update water levels ! - call compute_water_levels(t, dt, tloopcont) + call compute_water_levels(t, dt) ! endif ! @@ -625,7 +601,7 @@ function sfincs_update(dtrange) result(ierr) ! ! if (.not. fixed_output_intervals) tout = t ! - call write_output(tout, write_map, write_his, write_max, write_rst, ntmapout, ntmaxout, nthisout, tloopoutput) + call write_output(tout, write_map, write_his, write_max, write_rst, ntmapout, ntmaxout, nthisout) ! endif ! @@ -641,7 +617,7 @@ function sfincs_update(dtrange) result(ierr) ! ntmaxout = ntmaxout + 1 ! Max sure that max output is not called again through 'finalize_output' ! - call write_output(t, .true., .true., .true., .false., ntmapout + 1, ntmaxout, nthisout + 1, tloopoutput) + call write_output(t, .true., .true., .true., .false., ntmapout + 1, ntmaxout, nthisout + 1) ! t = t1 + 1.0 ! @@ -652,11 +628,9 @@ function sfincs_update(dtrange) result(ierr) if (percdone >= percdonenext) then ! ! percdoneval is increment of % to show to log, default=+5% - percdonenext = 1.0 * (int(percdone) + percdoneval) + percdonenext = 1.0 * (int(percdone) + percdoneval) ! - call system_clock(count1, count_rate, count_max) - ! - trun = 1.0*(count1 - count00)/count_rate + trun = real(timer_elapsed('Simulation loop'), 4) trem = trun / max(0.01*percdone, 1.0e-6) - trun ! if (int(percdone)>0) then @@ -688,86 +662,30 @@ function sfincs_finalize() result(ierr) ! integer :: ierr ! - call system_clock(count1, count_rate, count_max) - ! - tstart_all = 0.0 - tfinish_all = 1.0 * (count1 - count00) / count_rate + call timer_stop('Simulation loop') ! if (timestep_analysis) then ! call timestep_analysis_finalize(nt) ! - endif + endif ! - call finalize_output(t, ntmaxout, tloopoutput, tmaxout) + call finalize_output(t, ntmaxout, tmaxout) ! call finalize_openacc() ! Exit data region ! dtavg = dtavg / (nt - 1) ! call write_log('', 1) - call write_log('---------- Simulation finished -----------', 1) + call write_log('---------- Simulation finished -----------', 1) call write_log('', 1) - write(logstr,'(a,f10.3)') ' Total time : ', tinput + tfinish_all - tstart_all - call write_log(logstr, 1) - write(logstr,'(a,f10.3)') ' Total simulation time : ', tfinish_all - tstart_all - call write_log(logstr, 1) - write(logstr,'(a,f10.3)') ' Time in input : ', tinput - call write_log(logstr, 1) - ! - if (boundaries_in_mask) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in boundaries : ', tloopbnd, ' (', 100 * tloopbnd / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (nsrc>0 .or. ndrn>0) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in discharges : ', tloopsrc, ' (', 100 * tloopsrc / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (meteo3d) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in meteo fields : ', tloopwnd1, ' (', 100 * tloopwnd1 / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (wind .or. patmos .or. precip) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in meteo forcing : ', tloopwnd2, ' (', 100 * tloopwnd2 / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (infiltration) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in infiltration : ', tloopinf, ' (', 100 * tloopinf / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in momentum : ', tloopflux, ' (', 100 * tloopflux / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - ! - if (nonhydrostatic) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in non-hydrostatic: ', tloopnonh, ' (', 100 * tloopnonh / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif ! - if (nrstructures>0) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in structures : ', tloopstruc, ' (', 100 * tloopstruc / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif + call timer_write_headers(1) ! - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in continuity : ', tloopcont, ' (', 100 * tloopcont / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) + ! Per-phase timing summary. Percentages are relative to the total wall + ! time of the simulation loop. ! - if (snapwave) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in SnapWave : ', tloopsnapwave, ' (', 100 * tloopsnapwave / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - if (wavemaker) then - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in wave maker : ', tloopwavemaker, ' (', 100 * tloopwavemaker / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) - endif - ! - write(logstr,'(a,f10.3,a,f5.1,a)') ' Time in output : ', tloopoutput, ' (', 100 * tloopoutput / (tfinish_all - tstart_all), '%)' - call write_log(logstr, 1) + call timer_write_summary(1, timer_elapsed('Simulation loop'), 0.0005_8) ! call write_log('', 1) ! @@ -780,22 +698,12 @@ function sfincs_finalize() result(ierr) ! call timestep_analysis_write_log() ! - endif + endif ! if (write_time_output) then - open(123,file='runtimes.txt') - write(123,'(f10.3,a)')tfinish_all - tstart_all,' % total' - write(123,'(f10.3,a)')tinput,' % input' - write(123,'(f10.3,a)')tloopbnd,' % boundaries' - write(123,'(f10.3,a)')tloopsrc,' % discharges' - write(123,'(f10.3,a)')tloopwnd1,' % meteo1' - write(123,'(f10.3,a)')tloopwnd2,' % meteo2' - write(123,'(f10.3,a)')tloopinf,' % infiltration' - write(123,'(f10.3,a)')tloopflux,' % momentum' - write(123,'(f10.3,a)')tloopstruc,' % structures' - write(123,'(f10.3,a)')tloopcont,' % continuity' - write(123,'(f10.3,a)')tloopoutput,' % output' - close(123) + ! + call timer_write_runtimes_file(123, 'runtimes.txt') + ! endif ! call write_log('----------- Closing off SFINCS -----------', 1) diff --git a/source/src/sfincs_meteo.f90 b/source/src/sfincs_meteo.f90 index b71e504eb..024655309 100644 --- a/source/src/sfincs_meteo.f90 +++ b/source/src/sfincs_meteo.f90 @@ -1226,19 +1226,14 @@ subroutine update_ampr_data() end subroutine - subroutine update_meteo_forcing(t, dt, tloop) + subroutine update_meteo_forcing(t, dt) ! ! Update wind stresses and precipitation (this happens every time step) ! use sfincs_data + use sfincs_timers ! implicit none - ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop ! real*8 :: t real*4 :: dt @@ -1248,7 +1243,7 @@ subroutine update_meteo_forcing(t, dt, tloop) real*4 :: oneminsmfac integer :: nm, ib ! - call system_clock(count0, count_rate, count_max) + call timer_start('Meteo forcing') ! if (meteo3d) then ! @@ -1419,9 +1414,8 @@ subroutine update_meteo_forcing(t, dt, tloop) ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0 * (count1 - count0) / count_rate - ! + call timer_stop('Meteo forcing') + ! end subroutine @@ -1541,25 +1535,20 @@ subroutine update_precipitation_from_timeseries(t, dt) end subroutine - subroutine update_meteo_fields(t, tloop) + subroutine update_meteo_fields(t) ! ! Update values at boundary points ! use sfincs_data + use sfincs_timers ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! integer :: nm ! real*8 :: t ! - call system_clock(count0, count_rate, count_max) + call timer_start('Meteo fields') ! if (amufile(1:4) /= 'none' .or. netamuamvfile(1:4) /= 'none') then ! @@ -1601,9 +1590,8 @@ subroutine update_meteo_fields(t, tloop) ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate - ! - end subroutine + call timer_stop('Meteo fields') + ! + end subroutine end module diff --git a/source/src/sfincs_momentum.f90 b/source/src/sfincs_momentum.f90 index 4e19f72fa..949138096 100644 --- a/source/src/sfincs_momentum.f90 +++ b/source/src/sfincs_momentum.f90 @@ -1,21 +1,16 @@ module sfincs_momentum ! use sfincs_data + use sfincs_timers ! implicit none ! contains ! - subroutine compute_fluxes(dt, tloop) + subroutine compute_fluxes(dt) ! ! Computes fluxes over subgrid u and v points ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*4 :: dt ! integer :: ip @@ -94,7 +89,7 @@ subroutine compute_fluxes(dt, tloop) ! logical :: iok ! - call system_clock(count0, count_rate, count_max) + call timer_start('Momentum') ! min_dt = dtmax ! @@ -774,10 +769,9 @@ subroutine compute_fluxes(dt, tloop) ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + call timer_stop('Momentum') ! - end subroutine + end subroutine ! ! function power7over3(hu) result(hu73) diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index e3a1895e1..da8429a7a 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -3733,13 +3733,14 @@ subroutine ncoutput_update_quadtree_max(t,ntmaxout) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - subroutine ncoutput_map_finalize() + subroutine ncoutput_map_finalize() ! ! Add total runtime, dtavg to file and close ! use sfincs_data - ! - implicit none + use sfincs_timers, only: timer_elapsed + ! + implicit none ! if (store_tsunami_arrival_time) then ! @@ -3751,9 +3752,9 @@ subroutine ncoutput_map_finalize() ! call ncoutput_write_timestep_analysis() ! - endif + endif ! - NF90(nf90_put_var(map_file%ncid, map_file%total_runtime_varid, tfinish_all - tstart_all)) + NF90(nf90_put_var(map_file%ncid, map_file%total_runtime_varid, real(timer_elapsed('Simulation loop'), 4))) NF90(nf90_put_var(map_file%ncid, map_file%average_dt_varid, dtavg)) NF90(nf90_put_var(map_file%ncid, map_file%status_varid, error)) ! @@ -3891,14 +3892,15 @@ subroutine ncoutput_his_finalize() ! Add total runtime, dtavg to file and close ! use sfincs_data - ! - implicit none - ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. ndrn==0) then ! If no observation points, cross-sections, structures 9weir or thin dam), or drains; hisfile + use sfincs_timers, only: timer_elapsed + ! + implicit none + ! + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. ndrn==0) then ! If no observation points, cross-sections, structures 9weir or thin dam), or drains; hisfile return - endif + endif ! - NF90(nf90_put_var(his_file%ncid, his_file%total_runtime_varid, tfinish_all - tstart_all)) + NF90(nf90_put_var(his_file%ncid, his_file%total_runtime_varid, real(timer_elapsed('Simulation loop'), 4))) NF90(nf90_put_var(his_file%ncid, his_file%average_dt_varid, dtavg)) NF90(nf90_put_var(his_file%ncid, his_file%status_varid, error)) ! diff --git a/source/src/sfincs_nonhydrostatic.f90 b/source/src/sfincs_nonhydrostatic.f90 index 6200a1b5b..03b68b4da 100644 --- a/source/src/sfincs_nonhydrostatic.f90 +++ b/source/src/sfincs_nonhydrostatic.f90 @@ -388,21 +388,16 @@ subroutine initialize_nonhydrostatic() end subroutine - subroutine compute_nonhydrostatic(dt, tloop) + subroutine compute_nonhydrostatic(dt) ! - ! Non-hydrostatic pressure correction on fluxes and velocities + ! Non-hydrostatic pressure correction on fluxes and velocities ! use sfincs_data + use sfincs_timers use bicgstab_solver_ilu ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*4 :: dt ! integer :: ip @@ -439,7 +434,7 @@ subroutine compute_nonhydrostatic(dt, tloop) real*4, dimension(:), allocatable :: AA real*4 :: relres ! - call system_clock(count0, count_rate, count_max) + call timer_start('Non-hydrostatic') ! allocate(QQ(nrows)) allocate(AA(nr_vals_in_matrix)) @@ -738,9 +733,8 @@ subroutine compute_nonhydrostatic(dt, tloop) !$omp end do !$omp end parallel ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + call timer_stop('Non-hydrostatic') ! - end subroutine + end subroutine end module diff --git a/source/src/sfincs_output.f90 b/source/src/sfincs_output.f90 index f130bdd29..aea9dbae9 100644 --- a/source/src/sfincs_output.f90 +++ b/source/src/sfincs_output.f90 @@ -81,30 +81,25 @@ subroutine initialize_output(tmapout,tmaxout,thisout, trstout) end subroutine - subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmaxout,nthisout,tloop) + subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmaxout,nthisout) ! use sfincs_data + use sfincs_timers ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! - logical :: write_map + logical :: write_map logical :: write_max - logical :: write_his - logical :: write_rst + logical :: write_his + logical :: write_rst ! - integer :: ntmapout + integer :: ntmapout integer :: ntmaxout - integer :: nthisout + integer :: nthisout ! real*8 :: t ! - call system_clock(count0, count_rate, count_max) + call timer_start('Output') ! ! Time-varying water level output maps ! @@ -260,12 +255,11 @@ subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmax ! endif ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate - ! + call timer_stop('Output') + ! end subroutine - - subroutine finalize_output(t, ntmaxout, tloopoutput, tmaxout) + + subroutine finalize_output(t, ntmaxout, tmaxout) ! use sfincs_data ! @@ -273,17 +267,16 @@ subroutine finalize_output(t, ntmaxout, tloopoutput, tmaxout) ! integer :: ntmaxout real*8 :: t, t2 - real :: tloopoutput - real*8 :: tmaxout - ! - if (dtmaxout>1.e-6 .and. ntmaxout == 0) then - !write dtmax output if 1) value for dtmaxout wasn't achieved yet, + real*8 :: tmaxout + ! + if (dtmaxout>1.e-6 .and. ntmaxout == 0) then + !write dtmax output if 1) value for dtmaxout wasn't achieved yet, !or 2) in the last timeinterval, the full 'dtmaxout' wasn't achieved yet, but we still want the max over this interval - ! + ! call write_log('', 1) call write_log('Info : Write maximum values at final timestep since t=dtmaxout was not reached yet...', 1) ntmaxout = 1 - call write_output(t,.false.,.false.,.true.,.false.,0,ntmaxout,0,tloopoutput) + call write_output(t,.false.,.false.,.true.,.false.,0,ntmaxout,0) ! elseif (dtmaxout>1.e-6 .and. ntmaxout>0 .and. t < tmaxout) then ! @@ -294,7 +287,7 @@ subroutine finalize_output(t, ntmaxout, tloopoutput, tmaxout) ! Write 'tstop' as timemax instead of actual (unrounded) 't' t2 = t1 ! - call write_output(t2,.false.,.false.,.true.,.false.,0,ntmaxout,0,tloopoutput) + call write_output(t2,.false.,.false.,.true.,.false.,0,ntmaxout,0) ! endif ! diff --git a/source/src/sfincs_snapwave.f90 b/source/src/sfincs_snapwave.f90 index 81d5015e0..ef6259809 100644 --- a/source/src/sfincs_snapwave.f90 +++ b/source/src/sfincs_snapwave.f90 @@ -285,18 +285,13 @@ subroutine find_matching_cells(index_quadtree_in_snapwave, index_snapwave_in_qua end subroutine - subroutine update_wave_field(t, tloop) + subroutine update_wave_field(t) ! use sfincs_data + use sfincs_timers ! implicit none ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*4 :: u10, u10dir ! real*4, dimension(:), allocatable :: fwx0 @@ -313,7 +308,7 @@ subroutine update_wave_field(t, tloop) integer :: ip, nm, nmu, idir real*8 :: t ! - call system_clock(count0, count_rate, count_max) + call timer_start('SnapWave') ! allocate(fwx0(np)) allocate(fwy0(np)) @@ -512,8 +507,7 @@ subroutine update_wave_field(t, tloop) ! !$acc update device(fwuv) ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + call timer_stop('SnapWave') ! end subroutine diff --git a/source/src/sfincs_structures.f90 b/source/src/sfincs_structures.f90 index bc51ffa1b..d25db14fc 100644 --- a/source/src/sfincs_structures.f90 +++ b/source/src/sfincs_structures.f90 @@ -589,11 +589,12 @@ subroutine give_thindam_information(struc_info) end subroutine - subroutine compute_fluxes_over_structures(tloop) + subroutine compute_fluxes_over_structures() ! ! Computes fluxes over structures (THIS HAS TO BE SERIOUSLY IMPROVED!!!) ! use sfincs_data + use sfincs_timers ! use quadtree ! implicit none @@ -614,13 +615,7 @@ subroutine compute_fluxes_over_structures(tloop) real*4 :: h2 real*4 :: qstruc ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! - call system_clock(count0, count_rate, count_max) + call timer_start('Structures') ! !$acc parallel, present(zs, q, uv, structure_uv_index, uv_index_z_nm, uv_index_z_nmu, structure_parameters, structure_type, structure_length) !$acc loop independent gang vector @@ -691,9 +686,8 @@ subroutine compute_fluxes_over_structures(tloop) enddo !$acc end parallel ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate - ! + call timer_stop('Structures') + ! end subroutine diff --git a/source/src/sfincs_timers.f90 b/source/src/sfincs_timers.f90 new file mode 100644 index 000000000..5e3f43757 --- /dev/null +++ b/source/src/sfincs_timers.f90 @@ -0,0 +1,385 @@ +module sfincs_timers + ! + ! Named wall-clock timers for SFINCS. + ! + ! Lightweight replacement for the scattered tloop*/tstart_*/tend_* + ! bookkeeping that used to live in each module. Timers are registered + ! lazily: the first timer_start('name') with a new name creates it; + ! subsequent calls find the existing record and accumulate. + ! + ! All timing is done via system_clock with integer*8 counts, so 64-bit + ! counters (typical on modern systems) do not wrap within any realistic + ! SFINCS run. + ! + ! Thread safety: timer_start / timer_stop are intended to be called + ! from the serial driver, outside of !$omp parallel regions. They are + ! NOT thread-safe. + ! + use sfincs_log + ! + implicit none + ! + private + ! + public :: timer_start + public :: timer_stop + public :: timer_reset + public :: timer_elapsed + public :: timer_count + public :: timer_total_wall + public :: timer_write_summary + public :: timer_write_headers + public :: timer_write_runtimes_file + ! + integer, parameter :: name_len = 32 + integer, parameter :: max_timers = 64 + ! + type :: timer_record + character(len=name_len) :: name = '' + real(8) :: accumulated = 0.0_8 + integer(8) :: last_start = 0_8 + integer :: n_calls = 0 + logical :: running = .false. + logical :: warned_start = .false. + logical :: warned_stop = .false. + end type timer_record + ! + type(timer_record), save :: timers(max_timers) + integer, save :: n_timers = 0 + logical, save :: warned_full = .false. + ! +contains + ! + !-----------------------------------------------------------------------------------------------------! + ! + integer function timer_find(name) result(idx) + ! + ! Return the index of the timer with the given name, or 0 if not present. + ! + character(len=*), intent(in) :: name + integer :: i + ! + idx = 0 + ! + do i = 1, n_timers + ! + if (trim(timers(i)%name) == trim(name)) then + idx = i + return + endif + ! + enddo + ! + end function timer_find + ! + !-----------------------------------------------------------------------------------------------------! + ! + integer function timer_find_or_register(name) result(idx) + ! + ! Return the index of the timer with the given name, creating a new + ! record if it did not yet exist. Returns 0 if the table is full. + ! + character(len=*), intent(in) :: name + ! + idx = timer_find(name) + ! + if (idx > 0) return + ! + if (n_timers >= max_timers) then + ! + if (.not. warned_full) then + ! + call write_log(' Warning: sfincs_timers table full, timer ignored: '//trim(name), 1) + warned_full = .true. + ! + endif + ! + idx = 0 + return + ! + endif + ! + n_timers = n_timers + 1 + idx = n_timers + ! + timers(idx)%name = name + timers(idx)%accumulated = 0.0_8 + timers(idx)%last_start = 0_8 + timers(idx)%n_calls = 0 + timers(idx)%running = .false. + timers(idx)%warned_start = .false. + timers(idx)%warned_stop = .false. + ! + end function timer_find_or_register + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_start(name) + ! + ! Start (or resume-and-accumulate-on-stop) the timer with the given name. + ! Lazily registers a new timer on first call. + ! + character(len=*), intent(in) :: name + integer :: idx + integer(8) :: c, rate + ! + idx = timer_find_or_register(name) + ! + if (idx == 0) return + ! + if (timers(idx)%running) then + ! + if (.not. timers(idx)%warned_start) then + ! + call write_log(' Warning: timer_start on already-running timer: '//trim(name), 1) + timers(idx)%warned_start = .true. + ! + endif + ! + return + ! + endif + ! + call system_clock(c, rate) + ! + timers(idx)%last_start = c + timers(idx)%running = .true. + ! + end subroutine timer_start + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_stop(name) + ! + ! Stop the timer and add the elapsed interval to its accumulated total. + ! + character(len=*), intent(in) :: name + integer :: idx + integer(8) :: c, rate + ! + idx = timer_find(name) + ! + if (idx == 0) then + ! + call write_log(' Warning: timer_stop on unknown timer: '//trim(name), 1) + return + ! + endif + ! + if (.not. timers(idx)%running) then + ! + if (.not. timers(idx)%warned_stop) then + ! + call write_log(' Warning: timer_stop on non-running timer: '//trim(name), 1) + timers(idx)%warned_stop = .true. + ! + endif + ! + return + ! + endif + ! + call system_clock(c, rate) + ! + timers(idx)%accumulated = timers(idx)%accumulated + real(c - timers(idx)%last_start, 8) / real(rate, 8) + timers(idx)%n_calls = timers(idx)%n_calls + 1 + timers(idx)%running = .false. + ! + end subroutine timer_stop + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_reset(name) + ! + ! Reset a single timer's accumulated time and call count to zero. + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find(name) + ! + if (idx == 0) return + ! + timers(idx)%accumulated = 0.0_8 + timers(idx)%n_calls = 0 + timers(idx)%running = .false. + ! + end subroutine timer_reset + ! + !-----------------------------------------------------------------------------------------------------! + ! + real(8) function timer_elapsed(name) result(elapsed) + ! + ! Accumulated wall time (in seconds) for the named timer. + ! Returns 0 if the timer is unknown. If the timer is currently running, + ! the interval since the most recent timer_start is included (without + ! modifying the stored accumulated value). + ! + character(len=*), intent(in) :: name + integer :: idx + integer(8) :: c, rate + ! + idx = timer_find(name) + ! + if (idx == 0) then + elapsed = 0.0_8 + return + endif + ! + elapsed = timers(idx)%accumulated + ! + if (timers(idx)%running) then + ! + call system_clock(c, rate) + ! + elapsed = elapsed + real(c - timers(idx)%last_start, 8) / real(rate, 8) + ! + endif + ! + end function timer_elapsed + ! + !-----------------------------------------------------------------------------------------------------! + ! + integer function timer_count(name) result(n) + ! + ! Number of completed start/stop cycles for the named timer. + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find(name) + ! + if (idx == 0) then + n = 0 + return + endif + ! + n = timers(idx)%n_calls + ! + end function timer_count + ! + !-----------------------------------------------------------------------------------------------------! + ! + real(8) function timer_total_wall() result(total) + ! + ! Sum of accumulated wall time across all registered timers. + ! + integer :: i + ! + total = 0.0_8 + ! + do i = 1, n_timers + total = total + timers(i)%accumulated + enddo + ! + end function timer_total_wall + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_write_summary(to_screen, total_wall, min_elapsed) + ! + ! Pretty-print a summary of all registered timers via write_log. + ! + ! to_screen : passed to write_log (1 = also echo to stdout). + ! total_wall : reference total wall time used for the '%' column. + ! If <= 0, the sum across all timers is used instead. + ! min_elapsed : timers with accumulated time below this threshold (in s) + ! are skipped. Pass a negative value to print every timer. + ! + integer, intent(in) :: to_screen + real(8), intent(in) :: total_wall + real(8), intent(in) :: min_elapsed + ! + real(8) :: denom + real(8) :: t_el + real(8) :: pct + integer :: i + character(32) :: call_label + character(256) :: line + ! + if (total_wall > 0.0_8) then + denom = total_wall + else + denom = max(timer_total_wall(), 1.0e-12_8) + endif + ! + do i = 1, n_timers + ! + t_el = timers(i)%accumulated + ! + if (t_el < min_elapsed) cycle + ! + pct = 100.0_8 * t_el / denom + ! + if (timers(i)%n_calls == 1) then + write(call_label, '(i0,a)') timers(i)%n_calls, ' call' + else + write(call_label, '(i0,a)') timers(i)%n_calls, ' calls' + endif + ! + write(line, '(1x,a,t25,a,f10.3,a,f5.1,a,a,a)') & + trim(timers(i)%name), ': ', t_el, ' (', pct, '%, ', trim(call_label), ')' + ! + call write_log(trim(line), to_screen) + ! + enddo + ! + end subroutine timer_write_summary + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_write_headers(to_screen) + ! + ! Write the three 'Total time / Total simulation time / Time in input' header + ! lines to the log, using the 'Input' and 'Simulation loop' named timers. + ! + integer, intent(in) :: to_screen + ! + real(8) :: t_input + real(8) :: t_loop + ! + t_input = timer_elapsed('Input') + t_loop = timer_elapsed('Simulation loop') + ! + write(logstr, '(a,f10.3)') ' Total time : ', t_input + t_loop + call write_log(trim(logstr), to_screen) + ! + write(logstr, '(a,f10.3)') ' Total simulation time : ', t_loop + call write_log(trim(logstr), to_screen) + ! + write(logstr, '(a,f10.3)') ' Time in input : ', t_input + call write_log(trim(logstr), to_screen) + ! + end subroutine timer_write_headers + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine timer_write_runtimes_file(unit, filename) + ! + ! Write the runtimes.txt payload: simulation-loop wall time, input wall time, + ! and each phase timer, in the same order and with the same keys as the + ! previous inline implementation in sfincs_lib.f90. + ! + integer, intent(in) :: unit + character(len=*), intent(in) :: filename + ! + open(unit, file=filename) + ! + write(unit, '(f10.3,a)') real(timer_elapsed('Simulation loop'), 4), ' % total' + write(unit, '(f10.3,a)') real(timer_elapsed('Input'), 4), ' % input' + write(unit, '(f10.3,a)') real(timer_elapsed('Boundaries'), 4), ' % boundaries' + write(unit, '(f10.3,a)') real(timer_elapsed('Discharges'), 4), ' % discharges' + write(unit, '(f10.3,a)') real(timer_elapsed('Drainage structures'), 4), ' % drainage_structures' + write(unit, '(f10.3,a)') real(timer_elapsed('Meteo fields'), 4), ' % meteo1' + write(unit, '(f10.3,a)') real(timer_elapsed('Meteo forcing'), 4), ' % meteo2' + write(unit, '(f10.3,a)') real(timer_elapsed('Infiltration'), 4), ' % infiltration' + write(unit, '(f10.3,a)') real(timer_elapsed('Momentum'), 4), ' % momentum' + write(unit, '(f10.3,a)') real(timer_elapsed('Structures'), 4), ' % structures' + write(unit, '(f10.3,a)') real(timer_elapsed('Continuity'), 4), ' % continuity' + write(unit, '(f10.3,a)') real(timer_elapsed('Output'), 4), ' % output' + ! + close(unit) + ! + end subroutine timer_write_runtimes_file + ! +end module sfincs_timers diff --git a/source/src/sfincs_wavemaker.f90 b/source/src/sfincs_wavemaker.f90 index 4595f0096..4660bdfad 100644 --- a/source/src/sfincs_wavemaker.f90 +++ b/source/src/sfincs_wavemaker.f90 @@ -1343,12 +1343,13 @@ subroutine initialize_wavemakers() end subroutine - subroutine update_wavemaker_fluxes(t, dt, tloop) + subroutine update_wavemaker_fluxes(t, dt) ! ! Update fluxes qx and qy at wave maker points ! use sfincs_data use sfincs_snapwave + use sfincs_timers ! implicit none ! @@ -1360,17 +1361,11 @@ subroutine update_wavemaker_fluxes(t, dt, tloop) real*4 :: wave_steepness, betas, zinc, zig, dwvm, ztot, hm0_inc real*4 :: ui, ub, dzuv, facint, zsuv, depthuv, uvm0 ! - integer :: count0 - integer :: count1 - integer :: count_rate - integer :: count_max - real :: tloop - ! real*4, dimension(:), allocatable :: wavemaker_forcing_hm0_ig_t real*4, dimension(:), allocatable :: wavemaker_forcing_tp_ig_t - real*4, dimension(:), allocatable :: wavemaker_forcing_setup_t + real*4, dimension(:), allocatable :: wavemaker_forcing_setup_t ! - call system_clock(count0, count_rate, count_max) + call timer_start('Wavemaker') ! ! Factors for double-exponential filtering ! @@ -1687,9 +1682,8 @@ subroutine update_wavemaker_fluxes(t, dt, tloop) enddo !$acc end parallel ! - call system_clock(count1, count_rate, count_max) - tloop = tloop + 1.0*(count1 - count0)/count_rate + call timer_stop('Wavemaker') ! end subroutine - + end module From 3352f36ea861dc7783dad96e7c7b963afd3af6d4 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 08:32:10 +0200 Subject: [PATCH 31/65] Extract screen output into sfincs_screendump Refactor: move startup banner and "Processes" summary out of sfincs_lib into a new module (source/src/sfincs_screendump.f90). Replace the large inline write_log blocks in sfincs_lib.f90 with calls to screendump_startup() and screendump_processes(), and add the new source to the build (Makefile.am and sfincs_lib.vfproj). This separates UI/logging concerns from core initialization logic and reduces clutter in sfincs_lib. --- source/sfincs_lib/sfincs_lib.vfproj | 1 + source/src/Makefile.am | 1 + source/src/sfincs_lib.f90 | 110 +----------------- source/src/sfincs_screendump.f90 | 171 ++++++++++++++++++++++++++++ 4 files changed, 176 insertions(+), 107 deletions(-) create mode 100644 source/src/sfincs_screendump.f90 diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 34bf8f520..feb35408f 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -105,6 +105,7 @@ + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index 891652f08..c8f0199be 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -58,6 +58,7 @@ libsfincs_la_SOURCES = \ sfincs_wavemaker.f90 \ sfincs_bathtub.f90 \ sfincs_openacc.f90 \ + sfincs_screendump.f90 \ sfincs_lib.f90 \ sfincs_bmi.f90 diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index ca3441bf4..adf534488 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -27,6 +27,7 @@ module sfincs_lib use sfincs_openacc use sfincs_log use sfincs_timestep_analysis + use sfincs_screendump ! implicit none ! @@ -97,42 +98,7 @@ function sfincs_initialize() result(ierr) build_revision = "$Rev: v2.3.2 mt. Faber+branch:318" build_date = "$Date: 2025-04-13" ! - call write_log('', 1) - call write_log('------------ Welcome to SFINCS ------------', 1) - call write_log('', 1) - call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) - call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) - call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) - call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) - call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) - call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) - call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) - call write_log('', 1) - call write_log(' .............. ', 1) - call write_log(' ......:@@@@@@@@:...... ', 1) - call write_log(' ..::::..@@........@@.:::::.. ', 1) - call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) - call write_log(' .::::::..@@............@@.:::::::. ', 1) - call write_log(' .::::::..@@..............@@.:::::::. ', 1) - call write_log(' .::::::::..@@............@@..::::::::. ', 1) - call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) - call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) - call write_log(' ............@@.@@..@@..@@.@@............ ', 1) - call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) - call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) - call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) - call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) - call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) - call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) - call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) - call write_log(' ...................... ', 1) - call write_log(' .............. ', 1) - call write_log('', 1) - call write_log('------------------------------------------', 1) - call write_log('', 1) - call write_log('Build-Revision: '//trim(build_revision), 1) - call write_log('Build-Date: '//trim(build_date), 1) - call write_log('', 1) + call screendump_startup() ! call system_clock(count0, count_rate, count_max) ! @@ -191,77 +157,7 @@ function sfincs_initialize() result(ierr) ! endif ! - call write_log('', 1) - call write_log('------------------------------------------', 1) - call write_log('Processes', 1) - call write_log('------------------------------------------', 1) - if (subgrid) then - call write_log('Subgrid topography : yes', 1) - else - call write_log('Subgrid topography : no', 1) - endif - if (use_quadtree) then - call write_log('Quadtree refinement : yes', 1) - else - call write_log('Quadtree refinement : no', 1) - endif - if (advection) then - call write_log('Advection : yes', 1) - else - call write_log('Advection : no', 1) - endif - if (viscosity) then - call write_log('Viscosity : yes', 1) - else - call write_log('Viscosity : no', 1) - endif - if (coriolis) then - call write_log('Coriolis : yes', 1) - else - call write_log('Coriolis : no', 1) - endif - if (wind) then - call write_log('Wind : yes', 1) - else - call write_log('Wind : no', 1) - endif - if (patmos) then - call write_log('Atmospheric pressure : yes', 1) - else - call write_log('Atmospheric pressure : no', 1) - endif - if (precip) then - call write_log('Precipitation : yes', 1) - else - call write_log('Precipitation : no', 1) - endif - if (infiltration) then - call write_log('Infiltration : yes', 1) - else - call write_log('Infiltration : no', 1) - endif - if (snapwave) then - call write_log('SnapWave : yes', 1) - else - call write_log('SnapWave : no', 1) - endif - if (wavemaker) then - call write_log('Wave paddles : yes', 1) - else - call write_log('Wave paddles : no', 1) - endif - if (nonhydrostatic) then - call write_log('Non-hydrostatic : yes', 1) - else - ! call write_log('Non-hydrostatic : no', 1) - endif - if (bathtub) then - call write_log('Bathtub : yes', 1) - else - ! call write_log('Bathtub : no', 1) - endif - call write_log('------------------------------------------', 1) - call write_log('', 1) + call screendump_processes() ! if (snapwave) then ! diff --git a/source/src/sfincs_screendump.f90 b/source/src/sfincs_screendump.f90 new file mode 100644 index 000000000..d0b631763 --- /dev/null +++ b/source/src/sfincs_screendump.f90 @@ -0,0 +1,171 @@ +module sfincs_screendump + ! + ! User-facing screen / log output for SFINCS. + ! + ! Two large formatted blocks live here: + ! - screendump_startup : welcome banner + ASCII art + build info + ! - screendump_processes : yes/no "Processes" summary + ! + ! The per-timestep progress reporter stays inline in sfincs_lib.f90. + ! + use sfincs_log + use sfincs_data + ! + implicit none + ! + private + ! + public :: screendump_startup + public :: screendump_processes + ! +contains + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine screendump_startup() + ! + ! Welcome banner, ASCII logo and build-revision / build-date lines. + ! Called once at the start of sfincs_initialize, after build_revision + ! and build_date have been set in sfincs_data. + ! + implicit none + ! + call write_log('', 1) + call write_log('------------ Welcome to SFINCS ------------', 1) + call write_log('', 1) + call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) + call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) + call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) + call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) + call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) + call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) + call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) + call write_log('', 1) + call write_log(' .............. ', 1) + call write_log(' ......:@@@@@@@@:...... ', 1) + call write_log(' ..::::..@@........@@.:::::.. ', 1) + call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) + call write_log(' .::::::..@@............@@.:::::::. ', 1) + call write_log(' .::::::..@@..............@@.:::::::. ', 1) + call write_log(' .::::::::..@@............@@..::::::::. ', 1) + call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) + call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) + call write_log(' ............@@.@@..@@..@@.@@............ ', 1) + call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) + call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) + call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) + call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) + call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) + call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) + call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) + call write_log(' ...................... ', 1) + call write_log(' .............. ', 1) + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('', 1) + call write_log('Build-Revision: '//trim(build_revision), 1) + call write_log('Build-Date: '//trim(build_date), 1) + call write_log('', 1) + ! + end subroutine screendump_startup + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine screendump_processes() + ! + ! "Processes" summary block listing which physical processes are + ! enabled for this run. Reads the process flags from sfincs_data. + ! + implicit none + ! + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('Processes', 1) + call write_log('------------------------------------------', 1) + ! + if (subgrid) then + call write_log('Subgrid topography : yes', 1) + else + call write_log('Subgrid topography : no', 1) + endif + ! + if (use_quadtree) then + call write_log('Quadtree refinement : yes', 1) + else + call write_log('Quadtree refinement : no', 1) + endif + ! + if (advection) then + call write_log('Advection : yes', 1) + else + call write_log('Advection : no', 1) + endif + ! + if (viscosity) then + call write_log('Viscosity : yes', 1) + else + call write_log('Viscosity : no', 1) + endif + ! + if (coriolis) then + call write_log('Coriolis : yes', 1) + else + call write_log('Coriolis : no', 1) + endif + ! + if (wind) then + call write_log('Wind : yes', 1) + else + call write_log('Wind : no', 1) + endif + ! + if (patmos) then + call write_log('Atmospheric pressure : yes', 1) + else + call write_log('Atmospheric pressure : no', 1) + endif + ! + if (precip) then + call write_log('Precipitation : yes', 1) + else + call write_log('Precipitation : no', 1) + endif + ! + if (infiltration) then + call write_log('Infiltration : yes', 1) + else + call write_log('Infiltration : no', 1) + endif + ! + if (snapwave) then + call write_log('SnapWave : yes', 1) + else + call write_log('SnapWave : no', 1) + endif + ! + if (wavemaker) then + call write_log('Wave paddles : yes', 1) + else + call write_log('Wave paddles : no', 1) + endif + ! + if (nonhydrostatic) then + call write_log('Non-hydrostatic : yes', 1) + else + ! call write_log('Non-hydrostatic : no', 1) + endif + ! + if (bathtub) then + call write_log('Bathtub : yes', 1) + else + ! call write_log('Bathtub : no', 1) + endif + ! + call write_log('------------------------------------------', 1) + call write_log('', 1) + ! + end subroutine screendump_processes + ! + !-----------------------------------------------------------------------------------------------------! + ! +end module sfincs_screendump From 95cb125c7c67e52b24e30ff6fc9102bb96aaa7d1 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 08:58:12 +0200 Subject: [PATCH 32/65] refactor(screendump): move progress and run-finished blocks to sfincs_screendump With both timers and screendump present on this branch, the per-timestep progress reporter and the end-of-run summary block can now live in sfincs_screendump. Progress depends on timer_elapsed('Simulation loop'); run-finished orchestrates timer_write_headers + timer_write_summary between the "Simulation finished" banner and the "Average time step" line. New entry points in sfincs_screendump: screendump_progress(t, t0, t1) screendump_run_finished(dtavg) percdonenext moves out of sfincs_lib and becomes a saved module- level variable in sfincs_screendump (zero-initialised by default). Co-Authored-By: Claude Opus 4.7 (1M context) --- source/src/sfincs_lib.f90 | 39 +----------- source/src/sfincs_screendump.f90 | 104 +++++++++++++++++++++++++++++-- 2 files changed, 101 insertions(+), 42 deletions(-) diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index fcba2175f..9f6426eea 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -71,7 +71,6 @@ module sfincs_lib logical :: update_waves ! real :: time_per_timestep - real :: percdone,percdonenext,trun,trem ! contains ! @@ -519,25 +518,7 @@ function sfincs_update(dtrange) result(ierr) ! endif ! - percdone = min(100 * (t - t0) / (t1 - t0), 100.0) - ! - if (percdone >= percdonenext) then - ! - ! percdoneval is increment of % to show to log, default=+5% - percdonenext = 1.0 * (int(percdone) + percdoneval) - ! - trun = real(timer_elapsed('Simulation loop'), 4) - trem = trun / max(0.01*percdone, 1.0e-6) - trun - ! - if (int(percdone)>0) then - write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, ',trem,' s remaining ...' - call write_log(logstr, 1) - else - write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, - s remaining ...' - call write_log(logstr, 1) - endif - ! - endif + call screendump_progress(t, t0, t1) ! if (single_time_step) then ! @@ -572,23 +553,7 @@ function sfincs_finalize() result(ierr) ! dtavg = dtavg / (nt - 1) ! - call write_log('', 1) - call write_log('---------- Simulation finished -----------', 1) - call write_log('', 1) - ! - call timer_write_headers(1) - ! - ! Per-phase timing summary. Percentages are relative to the total wall - ! time of the simulation loop. - ! - call timer_write_summary(1, timer_elapsed('Simulation loop'), 0.0005_8) - ! - call write_log('', 1) - ! - write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg - call write_log(logstr, 1) - ! - call write_log('', 1) + call screendump_run_finished(dtavg) ! if (timestep_analysis) then ! diff --git a/source/src/sfincs_screendump.f90 b/source/src/sfincs_screendump.f90 index d0b631763..337688a31 100644 --- a/source/src/sfincs_screendump.f90 +++ b/source/src/sfincs_screendump.f90 @@ -2,11 +2,12 @@ module sfincs_screendump ! ! User-facing screen / log output for SFINCS. ! - ! Two large formatted blocks live here: - ! - screendump_startup : welcome banner + ASCII art + build info - ! - screendump_processes : yes/no "Processes" summary - ! - ! The per-timestep progress reporter stays inline in sfincs_lib.f90. + ! Formatted blocks that live here: + ! - screendump_startup : welcome banner + ASCII art + build info + ! - screendump_processes : yes/no "Processes" summary + ! - screendump_progress : per-timestep progress / ETA line + ! - screendump_run_finished : end-of-run banner + timer summary + + ! average time step ! use sfincs_log use sfincs_data @@ -17,6 +18,15 @@ module sfincs_screendump ! public :: screendump_startup public :: screendump_processes + public :: screendump_progress + public :: screendump_run_finished + ! + ! Next percentage threshold at which the progress reporter prints a + ! line. Incremented in steps of percdoneval (set from the + ! 'percentage_done' input keyword). Zero-initialised so the first + ! call prints at 0%. + ! + real, save :: percdonenext = 0.0 ! contains ! @@ -168,4 +178,88 @@ end subroutine screendump_processes ! !-----------------------------------------------------------------------------------------------------! ! + subroutine screendump_progress(t, t0, t1) + ! + ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s + ! remaining ..." line each time the simulated-time percentage + ! crosses the next percdoneval threshold. Remaining time is + ! estimated from the wall-clock elapsed in the 'Simulation loop' + ! timer. + ! + use sfincs_timers, only: timer_elapsed + ! + implicit none + ! + real*8, intent(in) :: t + real*4, intent(in) :: t0, t1 + ! + real :: percdone, trun, trem + character(len=256) :: logstr + ! + percdone = min(100 * (t - t0) / (t1 - t0), 100.0) + ! + if (percdone >= percdonenext) then + ! + ! percdoneval is increment of % to show to log, default=+5% + ! + percdonenext = 1.0 * (int(percdone) + percdoneval) + ! + trun = real(timer_elapsed('Simulation loop'), 4) + trem = trun / max(0.01*percdone, 1.0e-6) - trun + ! + if (int(percdone)>0) then + ! + write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, ',trem,' s remaining ...' + call write_log(logstr, 1) + ! + else + ! + write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, - s remaining ...' + call write_log(logstr, 1) + ! + endif + ! + endif + ! + end subroutine screendump_progress + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine screendump_run_finished(dtavg) + ! + ! End-of-run log block: "Simulation finished" banner, per-phase + ! timer summary, and the average time step line. Called once from + ! sfincs_finalize, after the simulation loop has stopped and + ! dtavg has been averaged. + ! + use sfincs_timers, only: timer_write_headers, timer_write_summary, timer_elapsed + ! + implicit none + ! + real, intent(in) :: dtavg + ! + character(len=256) :: logstr + ! + call write_log('', 1) + call write_log('---------- Simulation finished -----------', 1) + call write_log('', 1) + ! + call timer_write_headers(1) + ! + ! Per-phase timing summary. Percentages are relative to the total + ! wall time of the simulation loop. + ! + call timer_write_summary(1, timer_elapsed('Simulation loop'), 0.0005_8) + ! + call write_log('', 1) + ! + write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg + call write_log(logstr, 1) + ! + call write_log('', 1) + ! + end subroutine screendump_run_finished + ! + !-----------------------------------------------------------------------------------------------------! + ! end module sfincs_screendump From 5a0dbb651e7723eff303146fa881214421c8d322 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 08:58:17 +0200 Subject: [PATCH 33/65] chore: ignore docs/_build sphinx output The Sphinx builder creates docs/_build/ with generated HTML and doctrees that should not be tracked. Adding it to .gitignore keeps it out of git status noise across branches. Co-Authored-By: Claude Opus 4.7 (1M context) --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index 22752d026..973575fc5 100644 --- a/.gitignore +++ b/.gitignore @@ -65,3 +65,6 @@ 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 + +# Sphinx build output +docs/_build/ From 95dc9b463d6bda4d2272f02a093bc91461b6ae46 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 09:14:37 +0200 Subject: [PATCH 34/65] Relocate SnapWave timing and update build info Move SnapWave timing and logging out of sfincs_lib into sfincs_snapwave: remove global t3/t4 from sfincs_data, add local timer variables and calls (timer(t3)/timer(t4)) and the timing log inside sfincs_snapwave, and import timer via use sfincs_date. Update build_revision and build_date strings in sfincs_lib, and clean up related comments/whitespace. These changes localize SnapWave timing measurement and tidy up obsolete comments. --- source/src/sfincs_data.f90 | 2 -- source/src/sfincs_lib.f90 | 37 +++++++++++----------------------- source/src/sfincs_snapwave.f90 | 25 +++++++++++++++-------- 3 files changed, 29 insertions(+), 35 deletions(-) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index e29b66135..849eeb0a8 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -33,8 +33,6 @@ module sfincs_data real*4 gn2 real*4 t0 real*4 t1 - real*4 t3 - real*4 t4 real*4 dx real*4 dy real*4 dxinv diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 9f6426eea..50d4fa1bf 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -86,8 +86,8 @@ function sfincs_initialize() result(ierr) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - build_revision = "$Rev: v2.3.2 mt. Faber+branch:318" - build_date = "$Date: 2025-04-13" + build_revision = "$Rev: v2.3.2 Mount Faber + screen dump + timers" + build_date = "$Date: 2025-04-19" ! call screendump_startup() ! @@ -107,7 +107,8 @@ function sfincs_initialize() result(ierr) ! endif ! - call write_log('Preparing domain ...', 0) + call write_log('Preparing domain ...', 0) + ! call initialize_domain() ! Reads dep, msk, index files, creates index, flag and depth arrays, initializes hydro quantities ! call read_structures() ! Reads thd files and sets kcuv to zero where necessary @@ -275,11 +276,6 @@ function sfincs_update(dtrange) result(ierr) ! endif ! - ! A bit unclear why this happens, but large jumps in the time step lead to weird oscillations. - ! In the 'original' sfincs v11 version, this behavior was supressed by the use of theta. - ! Avoid this, by not not changing time step dt (used in momentum equation), but only changing dtt, - ! which is used in the time updating and continuity equation. - ! ! Update time ! t = t + dt @@ -304,11 +300,14 @@ function sfincs_update(dtrange) result(ierr) ntmaxout = ntmaxout + 1 ! now also keep track of nr of max output tout = max(tmaxout, t - dt) ! - if (t < t1) then - tmaxout = tmaxout + dtmaxout + if (t < t1) then + ! + tmaxout = tmaxout + dtmaxout + ! ! in case the last 'dt' made us exactly past tstop time 't1', ! then we don't want to flag later another dtmax output timestep in 'finalize_output' check, - ! so if t > t1 don't add 'dtmaxout' again + ! so if t > t1 don't add 'dtmaxout' again + ! endif ! endif @@ -422,23 +421,11 @@ function sfincs_update(dtrange) result(ierr) ! if (snapwave .and. update_waves) then ! - call timer(t3) + ! Update wave fields from SnapWave coupling (this happens at intervals of dtwave) ! call update_wave_field(t) ! - call timer(t4) - write(logstr,'(a,f10.1,a,f6.2,a)')'Computing SnapWave at t = ', t, ' s took ', t4 - t3, ' seconds' - call write_log(logstr, 0) - ! - ! Maybe we'll add moving wave makers back at some point - ! - ! if (wavemaker) then - ! ! - ! call update_wavemaker_points(tloopwavemaker) - ! ! - ! endif - ! - endif + endif ! if (bathtub) then ! diff --git a/source/src/sfincs_snapwave.f90 b/source/src/sfincs_snapwave.f90 index ef6259809..a0178a5a2 100644 --- a/source/src/sfincs_snapwave.f90 +++ b/source/src/sfincs_snapwave.f90 @@ -289,24 +289,28 @@ subroutine update_wave_field(t) ! use sfincs_data use sfincs_timers + use sfincs_date, only: timer ! implicit none ! real*4 :: u10, u10dir - ! + ! real*4, dimension(:), allocatable :: fwx0 real*4, dimension(:), allocatable :: fwy0 real*4, dimension(:), allocatable :: dw0 - real*4, dimension(:), allocatable :: df0 + real*4, dimension(:), allocatable :: df0 real*4, dimension(:), allocatable :: dwig0 - real*4, dimension(:), allocatable :: dfig0 - real*4, dimension(:), allocatable :: cg0 - !real*4, dimension(:), allocatable :: qb0 - real*4, dimension(:), allocatable :: beta0 - real*4, dimension(:), allocatable :: srcig0 - real*4, dimension(:), allocatable :: alphaig0 + real*4, dimension(:), allocatable :: dfig0 + real*4, dimension(:), allocatable :: cg0 + !real*4, dimension(:), allocatable :: qb0 + real*4, dimension(:), allocatable :: beta0 + real*4, dimension(:), allocatable :: srcig0 + real*4, dimension(:), allocatable :: alphaig0 integer :: ip, nm, nmu, idir real*8 :: t + real*4 :: t3, t4 + ! + call timer(t3) ! call timer_start('SnapWave') ! @@ -509,6 +513,11 @@ subroutine update_wave_field(t) ! call timer_stop('SnapWave') ! + call timer(t4) + ! + write(logstr,'(a,f10.1,a,f6.2,a)')'Computing SnapWave at t = ', t, ' s took ', t4 - t3, ' seconds' + call write_log(logstr, 0) + ! end subroutine From c0796203706f0b32569cb0a68165968c10d86059 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 10:14:33 +0200 Subject: [PATCH 35/65] Refactor continuity: accumulate qsrc and add structures Centralize point-source handling in update_continuity: add call to update_src_structures, accumulate external qext into qsrc (with OpenMP/OpenACC loops), and apply qsrc * dt to zs/z_volume instead of applying individual point-term updates inline. Reworked compute_water_levels to call regular/subgrid variants and added timing (timer_start/stop). Adjusted private lists and removed redundant per-term updates (rainfall/infiltration/drainage/qext) in favor of qsrc/dvol handling. In sfincs_lib moved screendump_processes call and commented out duplicated update_discharges/update_src_structures calls in the main loop. Renamed timer labels for src_structures to "Drainage structures". --- source/src/sfincs_continuity.f90 | 208 ++++++++++----------------- source/src/sfincs_lib.f90 | 12 +- source/src/sfincs_src_structures.f90 | 4 +- 3 files changed, 82 insertions(+), 142 deletions(-) diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index 173987eed..633806dd9 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -6,73 +6,85 @@ subroutine update_continuity(t, dt) ! ! Unified continuity update: orchestrates all water balance terms ! - ! A. Discharges, sources and sinks => computed in sfincs_discharges - ! B. Hydrodynamic fluxes (q) => already computed in sfincs_momentum - ! C. Main adjustments: - ! 1. Rainfall (+) => already computed in sfincs_meteo (prcp) - ! 2. Infiltration (-) => computed in sfincs_infiltration (qinfmap) - ! (includes: con, c2d, cna, cnb, gai, hor, bkt flavors) - ! 3. Drainage mimic (-) => drainage rate field (qdrain_rate) - ! 4. External source/sink qext (+/-) => set via BMI coupling - ! 5. Storage volume => depression storage (subgrid only) - ! - ! compute_water_levels then applies all terms to update zs/z_volume: - ! A. Discharges (+/-) => outside main loop - ! B. Hydrodynamic fluxes => div(q) * dt - ! C1. Rainfall (+) => prcp * dt - ! C2. Infiltration (-) => qinfmap * dt - ! C3. Drainage mimic (-) => qdrain_rate * dt - ! C4. External source/sink (+/-) => qext * dt - ! C5. Storage volume => absorbs excess volume + ! A. Point sources and sinks (all accumulated into qsrc): + ! 1. River discharges (+/-) => update_discharges (zeros and accumulates qsrc) + ! 2. Drainage structures (+/-) => update_src_structures (adds to qsrc) + ! 3. External source/sink qext (+/-) => added to qsrc here (BMI coupling) + ! B. Infiltration rate field qinfmap (-) => update_infiltration_map + ! (flavors: con, c2d, cna, cnb, gai, hor, bkt) + ! C. Hydrodynamic fluxes q => already computed in sfincs_momentum + ! + ! compute_water_levels_{regular,subgrid} then updates zs/z_volume using: + ! - qsrc * dt => point source/sink contribution + ! - div(q) * dt => horizontal flux divergence + ! - storage volume => absorbs excess volume (subgrid only) ! use sfincs_data + use sfincs_timers use sfincs_infiltration use sfincs_discharges + use sfincs_src_structures ! implicit none ! real*8 :: t real*4 :: dt ! - ! A. Update discharges, sources and sinks + integer :: nm + ! + ! A1. River discharges => update_discharges (zeros qsrc, then accumulates) ! call update_discharges(t, dt) ! - ! C2. Compute infiltration rates => qinfmap (all flavors including bucket) + ! A2. Drainage structures (pumps/gates/culverts/...) => update_src_structures (adds to qsrc) + ! + call update_src_structures(t, dt) + ! + ! B. Compute infiltration rates => qinfmap (all flavors including bucket) ! if (infiltration) then + ! call update_infiltration_map(dt) + ! endif ! - ! C1, C3, C4, C5: rainfall, drainage mimic, qext, storage_volume - ! => nothing to compute, these are direct rates applied in compute_water_levels - ! - ! B + C: Update water levels (applies all terms) + ! Urban drainage ! - call compute_water_levels(t, dt) + !if (urban_drainage) then + ! ! + ! call update_urban_drainage(t, dt) + ! ! + !endif ! - end subroutine - - - subroutine compute_water_levels(t, dt) + ! A3. External source/sink (+/-) => add qext to qsrc (set via BMI coupling) ! - use sfincs_data - use sfincs_timers + if (use_qext) then + ! + !$omp parallel & + !$omp private ( nm ) + !$omp do + !$acc loop gang vector + do nm = 1, np + ! + qsrc(nm) = qsrc(nm) + qext(nm) + ! + enddo + !$acc end loop + !$omp end parallel + ! + endif ! - implicit none - ! - real*4 :: dt - real*8 :: t + ! Update water levels: applies qsrc * dt and flux divergence to zs/z_volume ! call timer_start('Continuity') ! if (subgrid) then ! - call compute_water_levels_subgrid(dt,t) + call compute_water_levels_subgrid(dt, t) ! else ! - call compute_water_levels_regular(dt,t) + call compute_water_levels_regular(dt, t) ! endif ! @@ -87,9 +99,9 @@ subroutine compute_water_levels(t, dt) call timer_stop('Continuity') ! end subroutine - - - subroutine compute_water_levels_regular(dt,t) + ! + ! + subroutine compute_water_levels_regular(dt, t) ! use sfincs_data ! @@ -99,7 +111,6 @@ subroutine compute_water_levels_regular(dt,t) real*8 :: t ! integer :: nm - integer :: isrc ! integer :: iwm ! @@ -113,7 +124,6 @@ subroutine compute_water_levels_regular(dt,t) real*4 :: qnum real*4 :: qndm real*4 :: factime - real*4 :: dvol ! if (snapwave) then ! need to compute filtered water levels for snapwave ! @@ -128,54 +138,24 @@ subroutine compute_water_levels_regular(dt,t) !$acc qsrc, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num ) ! - ! Apply cell-wise discharges (rivers + src-point structures, accumulated - ! into qsrc by sfincs_discharges and sfincs_src_structures). - ! - !$acc loop - do nm = 1, np - ! - if (qsrc(nm) /= 0.0) then - ! - if (crsgeo) then - zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area_m2(nm), zb(nm)) - else - zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area(z_flags_iref(nm)), zb(nm)) - endif - ! - endif - ! - enddo - ! !$omp parallel & - !$omp private ( nm,dvol,nmd,nmu,ndm,num,qnmd,qnmu,qndm,qnum,iwm) + !$omp private ( nm, nmd, nmu, ndm, num, qnmd, qnmu, qndm, qnum, iwm ) !$omp do schedule ( dynamic, 256 ) !$acc loop gang vector do nm = 1, np ! if (kcs(nm) == 1) then ! Regular point ! - ! C1. Rainfall (+) + ! Apply cell-wise discharges qsrc (rivers, drainage structures, qext) ! - if (precip) then - zs(nm) = zs(nm) + prcp(nm) * dt - endif - ! - ! C2. Infiltration (-) (includes all flavors: con, c2d, cna, cnb, gai, hor, bkt) - ! - if (infiltration) then - zs(nm) = zs(nm) - qinfmap(nm) * dt - endif - ! - ! C3. Drainage mimic (-) - ! - if (drainage) then - zs(nm) = zs(nm) - qdrain_rate(nm) * dt - endif - ! - ! C4. External source/sink (+/-) - ! - if (use_qext) then - zs(nm) = zs(nm) + qext(nm) * dt + if (qsrc(nm) /= 0.0) then + ! + if (crsgeo) then + zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area_m2(nm), zb(nm)) + else + zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area(z_flags_iref(nm)), zb(nm)) + endif + ! endif ! nmd = z_index_uv_md(nm) @@ -323,10 +303,8 @@ subroutine compute_water_levels_subgrid(dt,t) real*8 :: t ! integer :: nm - integer :: isrc ! integer :: iwm - integer :: ind ! integer :: nmu integer :: nmd @@ -334,8 +312,7 @@ subroutine compute_water_levels_subgrid(dt,t) integer :: ndm ! real*4 :: factime - real*4 :: dvol - real*4 :: dzsdt + real*4 :: dvol ! real*4 :: qnmu real*4 :: qnmd @@ -356,28 +333,17 @@ subroutine compute_water_levels_subgrid(dt,t) ! endif ! - ! Apply cell-wise discharges to z_volume (rivers + src-point structures, - ! accumulated into qsrc by sfincs_discharges and sfincs_src_structures). - ! - !$acc parallel loop present( z_volume, qsrc ) - !$omp parallel do schedule ( static ) - do nm = 1, np - if (qsrc(nm) /= 0.0 .and. z_volume(nm) >= 0) then - z_volume(nm) = z_volume(nm) + qsrc(nm) * dt - endif - enddo - !$omp end parallel do - !$acc end parallel loop - ! !$omp parallel & - !$omp private ( dvol,dzsdt,nmd,nmu,ndm,num,a,iuv,facint,dzvol,ind,iwm,qnmd,qnmu,qndm,qnum,dv,zs00,zs11 ) + !$omp private ( dvol, nmd, nmu, ndm, num, a, iuv, facint, dzvol, iwm, & + !$omp qnmd, qnmu, qndm, qnum, dv, zs00, zs11 ) !$omp do schedule ( dynamic, 256 ) !$acc parallel present( kcs, zs, zs0, zb, z_volume, zsmax, zsm, maxzsm, zsderv, & !$acc subgrid_z_zmin, subgrid_z_zmax, subgrid_z_dep, subgrid_z_volmax, & !$acc prcp, q, qext, qinfmap, qdrain_rate, z_flags_iref, uv_flags_iref, & !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & - !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, storage_volume) + !$acc z_index_wavemaker, wavemaker_uvmean, & + !$acc wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, storage_volume) !$acc loop gang vector do nm = 1, np ! @@ -386,6 +352,14 @@ subroutine compute_water_levels_subgrid(dt,t) dvol = 0.0 ! if (kcs(nm) == 1) then + ! + ! Apply cell-wise discharges qsrc (rivers, drainage structures, qext) + ! + if (qsrc(nm) /= 0.0) then + ! + dvol = dvol + qsrc(nm) * dt + ! + endif ! nmd = z_index_uv_md(nm) nmu = z_index_uv_mu(nm) @@ -515,38 +489,6 @@ subroutine compute_water_levels_subgrid(dt,t) ! endif ! - dzsdt = 0.0 - ! - ! C1. Rainfall (+) - ! - if (precip) then - dzsdt = dzsdt + prcp(nm) - endif - ! - ! C2. Infiltration (-) (includes all flavors: con, c2d, cna, cnb, gai, hor, bkt) - ! - if (infiltration) then - dzsdt = dzsdt - qinfmap(nm) - endif - ! - ! C3. Drainage mimic (-) - ! - if (drainage) then - dzsdt = dzsdt - qdrain_rate(nm) - endif - ! - ! C4. External source/sink (+/-) - ! - if (use_qext) then - dzsdt = dzsdt + qext(nm) - endif - ! - ! dzsdt is still in m/s, so multiply with a * dt to get m^3 - ! - if (dzsdt /= 0.0) then - dvol = dvol + dzsdt * a * dt - endif - ! ! C5. Storage volume ! if (use_storage_volume) then diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index d01eeca4f..9edcae23e 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -152,8 +152,6 @@ function sfincs_initialize() result(ierr) ! endif ! - call screendump_processes() - ! if (snapwave) then ! call write_log('Coupling with SnapWave ...', 1) @@ -163,6 +161,8 @@ function sfincs_initialize() result(ierr) ! call timer_stop('Input') ! + call screendump_processes() + ! ! Initialize some parameters ! t = t0 ! start time @@ -410,8 +410,8 @@ function sfincs_update(dtrange) result(ierr) ! ! Update discharges (river sources) and src-point structures (pumps/gates/...) ! - call update_discharges(t, dt) - call update_src_structures(t, dt) + !call update_discharges(t, dt) + !call update_src_structures(t, dt) ! if (snapwave .and. update_waves) then ! @@ -465,9 +465,7 @@ function sfincs_update(dtrange) result(ierr) ! endif ! - ! Update water levels - ! - ! Update continuity (discharges, infiltration, drainage, water levels) + ! Update continuity (discharges, drainage structures, infiltration, urban drainage, water levels) ! call update_continuity(t, dt) ! diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 23452c00a..f684bd6ee 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -788,7 +788,7 @@ subroutine update_src_structures(t, dt) ! if (nr_src_structures <= 0) return ! - call timer_start('Src structures') + call timer_start('Drainage structures') ! !$acc parallel loop present( z_volume, zs, zb, qsrc, q_src_struc, & !$acc src_struc_nm_in, src_struc_nm_out, & @@ -1135,7 +1135,7 @@ subroutine update_src_structures(t, dt) !$omp end parallel do !$acc end parallel loop ! - call timer_stop('Src structures') + call timer_stop('Drainage structures') ! end subroutine ! From 5e9b65a86abe8dc18f6dcced912bae735bc531b5 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 10:27:50 +0200 Subject: [PATCH 36/65] refactor(log): fold sfincs_screendump into sfincs_log Move the four banner/progress entry points from sfincs_screendump into sfincs_log, alongside logstr / write_log / open_log, and delete sfincs_screendump.f90. Renames: screendump_startup -> write_startup_log screendump_processes -> write_processes_log screendump_progress -> write_progress_log screendump_run_finished -> write_finished_log The module-level percdonenext state moves with write_progress_log. Update sfincs_lib.f90 call sites accordingly; remove use sfincs_screendump (sfincs_log was already imported). Remove sfincs_screendump.f90 from source/src/Makefile.am and source/sfincs_lib/sfincs_lib.vfproj. No behaviour change. Build clean, culvert smoke-test bit-identical (crosssection_discharge mean 3.6939 m^3/s; only timings differ in sfincs.log). Co-Authored-By: Claude Opus 4.7 (1M context) --- source/sfincs_lib/sfincs_lib.vfproj | 1 - source/src/Makefile.am | 1 - source/src/sfincs_lib.f90 | 9 +- source/src/sfincs_log.f90 | 264 ++++++++++++++++++++++++++- source/src/sfincs_screendump.f90 | 271 ---------------------------- 5 files changed, 267 insertions(+), 279 deletions(-) delete mode 100644 source/src/sfincs_screendump.f90 diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 197dd79f1..1709272d4 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -144,7 +144,6 @@ - diff --git a/source/src/Makefile.am b/source/src/Makefile.am index d27ad4f0f..f85278d13 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -96,7 +96,6 @@ libsfincs_la_SOURCES = \ sfincs_wavemaker.f90 \ sfincs_bathtub.f90 \ sfincs_openacc.f90 \ - sfincs_screendump.f90 \ sfincs_lib.f90 \ sfincs_bmi.f90 diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 9edcae23e..795500cfc 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -29,7 +29,6 @@ module sfincs_lib use sfincs_log use sfincs_timers use sfincs_timestep_analysis - use sfincs_screendump ! implicit none ! @@ -90,7 +89,7 @@ function sfincs_initialize() result(ierr) build_revision = "$Rev: v2.3.2 Mount Faber + branch-redo-infiltration + urban_drainage + discharges + timers + screendump" build_date = "$Date: 2026-04-19" ! - call screendump_startup() + call write_startup_log() ! call timer_start('Input') ! @@ -161,7 +160,7 @@ function sfincs_initialize() result(ierr) ! call timer_stop('Input') ! - call screendump_processes() + call write_processes_log() ! ! Initialize some parameters ! @@ -499,7 +498,7 @@ function sfincs_update(dtrange) result(ierr) ! endif ! - call screendump_progress(t, t0, t1) + call write_progress_log(t, t0, t1) ! if (single_time_step) then ! @@ -534,7 +533,7 @@ function sfincs_finalize() result(ierr) ! dtavg = dtavg / (nt - 1) ! - call screendump_run_finished(dtavg) + call write_finished_log(dtavg) ! if (timestep_analysis) then ! diff --git a/source/src/sfincs_log.f90 b/source/src/sfincs_log.f90 index b78b7cd83..2432f8c04 100644 --- a/source/src/sfincs_log.f90 +++ b/source/src/sfincs_log.f90 @@ -1,9 +1,28 @@ module sfincs_log + ! + ! User-facing log / screen output for SFINCS. + ! + ! Core: + ! - open_log / close_log / write_log : file handle + line writer + ! + ! Formatted blocks (moved here from the former sfincs_screendump): + ! - write_startup_log : welcome banner + ASCII art + build info + ! - write_processes_log: yes/no "Processes" summary + ! - write_progress_log : per-timestep progress / ETA line + ! - write_finished_log : end-of-run banner + timer summary + + ! average time step ! integer :: fid character(256) :: logstr ! -contains + ! Next percentage threshold at which the progress reporter prints a + ! line. Incremented in steps of percdoneval (set from the + ! 'percentage_done' input keyword). Zero-initialised so the first + ! call prints at 0%. + ! + real, save :: percdonenext = 0.0 + ! +contains subroutine open_log() ! @@ -37,4 +56,247 @@ subroutine close_log() ! end subroutine + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_startup_log() + ! + ! Welcome banner, ASCII logo and build-revision / build-date lines. + ! Called once at the start of sfincs_initialize, after build_revision + ! and build_date have been set in sfincs_data. + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------ Welcome to SFINCS ------------', 1) + call write_log('', 1) + call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) + call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) + call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) + call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) + call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) + call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) + call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) + call write_log('', 1) + call write_log(' .............. ', 1) + call write_log(' ......:@@@@@@@@:...... ', 1) + call write_log(' ..::::..@@........@@.:::::.. ', 1) + call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) + call write_log(' .::::::..@@............@@.:::::::. ', 1) + call write_log(' .::::::..@@..............@@.:::::::. ', 1) + call write_log(' .::::::::..@@............@@..::::::::. ', 1) + call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) + call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) + call write_log(' ............@@.@@..@@..@@.@@............ ', 1) + call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) + call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) + call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) + call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) + call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) + call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) + call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) + call write_log(' ...................... ', 1) + call write_log(' .............. ', 1) + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('', 1) + call write_log('Build-Revision: '//trim(build_revision), 1) + call write_log('Build-Date: '//trim(build_date), 1) + call write_log('', 1) + ! + end subroutine write_startup_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_processes_log() + ! + ! "Processes" summary block listing which physical processes are + ! enabled for this run. Reads the process flags from sfincs_data. + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('Processes', 1) + call write_log('------------------------------------------', 1) + ! + if (subgrid) then + call write_log('Subgrid topography : yes', 1) + else + call write_log('Subgrid topography : no', 1) + endif + ! + if (use_quadtree) then + call write_log('Quadtree refinement : yes', 1) + else + call write_log('Quadtree refinement : no', 1) + endif + ! + if (advection) then + call write_log('Advection : yes', 1) + else + call write_log('Advection : no', 1) + endif + ! + if (viscosity) then + call write_log('Viscosity : yes', 1) + else + call write_log('Viscosity : no', 1) + endif + ! + if (coriolis) then + call write_log('Coriolis : yes', 1) + else + call write_log('Coriolis : no', 1) + endif + ! + if (wind) then + call write_log('Wind : yes', 1) + else + call write_log('Wind : no', 1) + endif + ! + if (patmos) then + call write_log('Atmospheric pressure : yes', 1) + else + call write_log('Atmospheric pressure : no', 1) + endif + ! + if (precip) then + call write_log('Precipitation : yes', 1) + else + call write_log('Precipitation : no', 1) + endif + ! + if (infiltration) then + call write_log('Infiltration : yes', 1) + else + call write_log('Infiltration : no', 1) + endif + ! + if (drainage) then + call write_log('Drainage : yes', 1) + else + call write_log('Drainage : no', 1) + endif + ! + if (snapwave) then + call write_log('SnapWave : yes', 1) + else + call write_log('SnapWave : no', 1) + endif + ! + if (wavemaker) then + call write_log('Wave paddles : yes', 1) + else + call write_log('Wave paddles : no', 1) + endif + ! + if (nonhydrostatic) then + call write_log('Non-hydrostatic : yes', 1) + else + ! call write_log('Non-hydrostatic : no', 1) + endif + ! + if (bathtub) then + call write_log('Bathtub : yes', 1) + else + ! call write_log('Bathtub : no', 1) + endif + ! + call write_log('------------------------------------------', 1) + call write_log('', 1) + ! + end subroutine write_processes_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_progress_log(t, t0, t1) + ! + ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s + ! remaining ..." line each time the simulated-time percentage + ! crosses the next percdoneval threshold. Remaining time is + ! estimated from the wall-clock elapsed in the 'Simulation loop' + ! timer. + ! + use sfincs_data, only: percdoneval + use sfincs_timers, only: timer_elapsed + ! + implicit none + ! + real*8, intent(in) :: t + real*4, intent(in) :: t0, t1 + ! + real :: percdone, trun, trem + character(len=256) :: logstr + ! + percdone = min(100 * (t - t0) / (t1 - t0), 100.0) + ! + if (percdone >= percdonenext) then + ! + ! percdoneval is increment of % to show to log, default=+5% + ! + percdonenext = 1.0 * (int(percdone) + percdoneval) + ! + trun = real(timer_elapsed('Simulation loop'), 4) + trem = trun / max(0.01*percdone, 1.0e-6) - trun + ! + if (int(percdone)>0) then + ! + write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, ',trem,' s remaining ...' + call write_log(logstr, 1) + ! + else + ! + write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, - s remaining ...' + call write_log(logstr, 1) + ! + endif + ! + endif + ! + end subroutine write_progress_log + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_finished_log(dtavg) + ! + ! End-of-run log block: "Simulation finished" banner, per-phase + ! timer summary, and the average time step line. Called once from + ! sfincs_finalize, after the simulation loop has stopped and + ! dtavg has been averaged. + ! + use sfincs_timers, only: timer_write_headers, timer_write_summary, timer_elapsed + ! + implicit none + ! + real, intent(in) :: dtavg + ! + character(len=256) :: logstr + ! + call write_log('', 1) + call write_log('---------- Simulation finished -----------', 1) + call write_log('', 1) + ! + call timer_write_headers(1) + ! + ! Per-phase timing summary. Percentages are relative to the total + ! wall time of the simulation loop. + ! + call timer_write_summary(1, timer_elapsed('Simulation loop'), 0.0005_8) + ! + call write_log('', 1) + ! + write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg + call write_log(logstr, 1) + ! + call write_log('', 1) + ! + end subroutine write_finished_log + ! + !-----------------------------------------------------------------------------------------------------! + ! end module diff --git a/source/src/sfincs_screendump.f90 b/source/src/sfincs_screendump.f90 deleted file mode 100644 index 4b382eec4..000000000 --- a/source/src/sfincs_screendump.f90 +++ /dev/null @@ -1,271 +0,0 @@ -module sfincs_screendump - ! - ! User-facing screen / log output for SFINCS. - ! - ! Formatted blocks that live here: - ! - screendump_startup : welcome banner + ASCII art + build info - ! - screendump_processes : yes/no "Processes" summary - ! - screendump_progress : per-timestep progress / ETA line - ! - screendump_run_finished : end-of-run banner + timer summary + - ! average time step - ! - use sfincs_log - use sfincs_data - ! - implicit none - ! - private - ! - public :: screendump_startup - public :: screendump_processes - public :: screendump_progress - public :: screendump_run_finished - ! - ! Next percentage threshold at which the progress reporter prints a - ! line. Incremented in steps of percdoneval (set from the - ! 'percentage_done' input keyword). Zero-initialised so the first - ! call prints at 0%. - ! - real, save :: percdonenext = 0.0 - ! -contains - ! - !-----------------------------------------------------------------------------------------------------! - ! - subroutine screendump_startup() - ! - ! Welcome banner, ASCII logo and build-revision / build-date lines. - ! Called once at the start of sfincs_initialize, after build_revision - ! and build_date have been set in sfincs_data. - ! - implicit none - ! - call write_log('', 1) - call write_log('------------ Welcome to SFINCS ------------', 1) - call write_log('', 1) - call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) - call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) - call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) - call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) - call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) - call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) - call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) - call write_log('', 1) - call write_log(' .............. ', 1) - call write_log(' ......:@@@@@@@@:...... ', 1) - call write_log(' ..::::..@@........@@.:::::.. ', 1) - call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) - call write_log(' .::::::..@@............@@.:::::::. ', 1) - call write_log(' .::::::..@@..............@@.:::::::. ', 1) - call write_log(' .::::::::..@@............@@..::::::::. ', 1) - call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) - call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) - call write_log(' ............@@.@@..@@..@@.@@............ ', 1) - call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) - call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) - call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) - call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) - call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) - call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) - call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) - call write_log(' ...................... ', 1) - call write_log(' .............. ', 1) - call write_log('', 1) - call write_log('------------------------------------------', 1) - call write_log('', 1) - call write_log('Build-Revision: '//trim(build_revision), 1) - call write_log('Build-Date: '//trim(build_date), 1) - call write_log('', 1) - ! - end subroutine screendump_startup - ! - !-----------------------------------------------------------------------------------------------------! - ! - subroutine screendump_processes() - ! - ! "Processes" summary block listing which physical processes are - ! enabled for this run. Reads the process flags from sfincs_data. - ! - implicit none - ! - call write_log('', 1) - call write_log('------------------------------------------', 1) - call write_log('Processes', 1) - call write_log('------------------------------------------', 1) - ! - if (subgrid) then - call write_log('Subgrid topography : yes', 1) - else - call write_log('Subgrid topography : no', 1) - endif - ! - if (use_quadtree) then - call write_log('Quadtree refinement : yes', 1) - else - call write_log('Quadtree refinement : no', 1) - endif - ! - if (advection) then - call write_log('Advection : yes', 1) - else - call write_log('Advection : no', 1) - endif - ! - if (viscosity) then - call write_log('Viscosity : yes', 1) - else - call write_log('Viscosity : no', 1) - endif - ! - if (coriolis) then - call write_log('Coriolis : yes', 1) - else - call write_log('Coriolis : no', 1) - endif - ! - if (wind) then - call write_log('Wind : yes', 1) - else - call write_log('Wind : no', 1) - endif - ! - if (patmos) then - call write_log('Atmospheric pressure : yes', 1) - else - call write_log('Atmospheric pressure : no', 1) - endif - ! - if (precip) then - call write_log('Precipitation : yes', 1) - else - call write_log('Precipitation : no', 1) - endif - ! - if (infiltration) then - call write_log('Infiltration : yes', 1) - else - call write_log('Infiltration : no', 1) - endif - ! - if (drainage) then - call write_log('Drainage : yes', 1) - else - call write_log('Drainage : no', 1) - endif - ! - if (snapwave) then - call write_log('SnapWave : yes', 1) - else - call write_log('SnapWave : no', 1) - endif - ! - if (wavemaker) then - call write_log('Wave paddles : yes', 1) - else - call write_log('Wave paddles : no', 1) - endif - ! - if (nonhydrostatic) then - call write_log('Non-hydrostatic : yes', 1) - else - ! call write_log('Non-hydrostatic : no', 1) - endif - ! - if (bathtub) then - call write_log('Bathtub : yes', 1) - else - ! call write_log('Bathtub : no', 1) - endif - ! - call write_log('------------------------------------------', 1) - call write_log('', 1) - ! - end subroutine screendump_processes - ! - !-----------------------------------------------------------------------------------------------------! - ! - subroutine screendump_progress(t, t0, t1) - ! - ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s - ! remaining ..." line each time the simulated-time percentage - ! crosses the next percdoneval threshold. Remaining time is - ! estimated from the wall-clock elapsed in the 'Simulation loop' - ! timer. - ! - use sfincs_timers, only: timer_elapsed - ! - implicit none - ! - real*8, intent(in) :: t - real*4, intent(in) :: t0, t1 - ! - real :: percdone, trun, trem - character(len=256) :: logstr - ! - percdone = min(100 * (t - t0) / (t1 - t0), 100.0) - ! - if (percdone >= percdonenext) then - ! - ! percdoneval is increment of % to show to log, default=+5% - ! - percdonenext = 1.0 * (int(percdone) + percdoneval) - ! - trun = real(timer_elapsed('Simulation loop'), 4) - trem = trun / max(0.01*percdone, 1.0e-6) - trun - ! - if (int(percdone)>0) then - ! - write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, ',trem,' s remaining ...' - call write_log(logstr, 1) - ! - else - ! - write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, - s remaining ...' - call write_log(logstr, 1) - ! - endif - ! - endif - ! - end subroutine screendump_progress - ! - !-----------------------------------------------------------------------------------------------------! - ! - subroutine screendump_run_finished(dtavg) - ! - ! End-of-run log block: "Simulation finished" banner, per-phase - ! timer summary, and the average time step line. Called once from - ! sfincs_finalize, after the simulation loop has stopped and - ! dtavg has been averaged. - ! - use sfincs_timers, only: timer_write_headers, timer_write_summary, timer_elapsed - ! - implicit none - ! - real, intent(in) :: dtavg - ! - character(len=256) :: logstr - ! - call write_log('', 1) - call write_log('---------- Simulation finished -----------', 1) - call write_log('', 1) - ! - call timer_write_headers(1) - ! - ! Per-phase timing summary. Percentages are relative to the total - ! wall time of the simulation loop. - ! - call timer_write_summary(1, timer_elapsed('Simulation loop'), 0.0005_8) - ! - call write_log('', 1) - ! - write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg - call write_log(logstr, 1) - ! - call write_log('', 1) - ! - end subroutine screendump_run_finished - ! - !-----------------------------------------------------------------------------------------------------! - ! -end module sfincs_screendump From 5151a694b47f25019cc5a14e709c43a636cd0885 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 12:03:31 +0200 Subject: [PATCH 37/65] refactor(log,timers): break circular dep + earlier session formatting/snapwave-move Move timer_write_summary / timer_write_headers / timer_write_runtimes_file out of sfincs_timers and into sfincs_log (renamed write_timer_summary_log, write_timer_headers_log, write_runtimes_file). sfincs_timers becomes a pure data module with no outgoing dependency on sfincs_log. Small new iteration API on sfincs_timers (timer_num_registered, timer_name_by_index, timer_elapsed_by_index, timer_count_by_index) is all the rendering routines need to walk the timer list. Also folds in this-session unstaged work on the same files: - sfincs_log.f90 reformatted to the new SFINCS Fortran rules; REAL(8)->REAL(4) fix in write_progress_log. - sfincs_lib.f90 SnapWave per-call "took X s" timing line moved into update_wave_field in sfincs_snapwave.f90. No behaviour change. Build clean (0 error(s)); culvert baseline crosssection_discharge mean 3.6939 m^3/s bit-identical; sfincs.log end-of-run block byte-identical aside from numeric timings. Co-Authored-By: Claude Opus 4.7 (1M context) --- source/src/sfincs_lib.f90 | 9 +- source/src/sfincs_log.f90 | 659 ++++++++++++++++++++++------------- source/src/sfincs_timers.f90 | 533 ++++++++++++++-------------- 3 files changed, 700 insertions(+), 501 deletions(-) diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 795500cfc..4a3b2d066 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -407,10 +407,7 @@ function sfincs_update(dtrange) result(ierr) ! call update_boundaries(t, dt) ! - ! Update discharges (river sources) and src-point structures (pumps/gates/...) - ! - !call update_discharges(t, dt) - !call update_src_structures(t, dt) + ! Update SnapWave ! if (snapwave .and. update_waves) then ! @@ -464,7 +461,7 @@ function sfincs_update(dtrange) result(ierr) ! endif ! - ! Update continuity (discharges, drainage structures, infiltration, urban drainage, water levels) + ! Update continuity (discharges, drainage structures, infiltration, urban drainage, qext, water levels) ! call update_continuity(t, dt) ! @@ -543,7 +540,7 @@ function sfincs_finalize() result(ierr) ! if (write_time_output) then ! - call timer_write_runtimes_file(123, 'runtimes.txt') + call write_runtimes_file(123, 'runtimes.txt') ! endif ! diff --git a/source/src/sfincs_log.f90 b/source/src/sfincs_log.f90 index 2432f8c04..5f50ab23c 100644 --- a/source/src/sfincs_log.f90 +++ b/source/src/sfincs_log.f90 @@ -2,15 +2,51 @@ module sfincs_log ! ! User-facing log / screen output for SFINCS. ! - ! Core: - ! - open_log / close_log / write_log : file handle + line writer + ! Owns sfincs.log (fid, open_log/close_log/write_log) and all the + ! formatted blocks that the driver writes to it. ! - ! Formatted blocks (moved here from the former sfincs_screendump): - ! - write_startup_log : welcome banner + ASCII art + build info - ! - write_processes_log: yes/no "Processes" summary - ! - write_progress_log : per-timestep progress / ETA line - ! - write_finished_log : end-of-run banner + timer summary + - ! average time step + ! Rendering of named-timer data (headers, per-phase summary, the + ! runtimes.txt payload) also lives here, so that sfincs_timers can + ! remain a pure data module with no dependency on sfincs_log. This + ! breaks what used to be a circular dependency between the two. + ! + ! Subroutines: + ! + ! open_log() / close_log() / write_log(str, to_screen) + ! File handle management and the single-line writer. Called from + ! every SFINCS module that emits user-facing output. + ! + ! write_startup_log() + ! Welcome banner + ASCII logo + build-revision / build-date lines. + ! Called once from sfincs_initialize (sfincs_lib). + ! + ! write_processes_log() + ! "Processes" yes/no summary. Called once from sfincs_initialize. + ! + ! write_progress_log(t, t0, t1) + ! Per-timestep progress / ETA line. Called every time step from + ! the main loop in sfincs_lib. Uses timer_elapsed('Simulation loop'). + ! + ! write_finished_log(dtavg) + ! End-of-run banner + per-phase timer summary + average time step. + ! Called once from sfincs_finalize (sfincs_lib). + ! + ! write_timer_headers_log(to_screen) + ! Three-line "Total / Total simulation / Input" header block. + ! Called from write_finished_log. + ! + ! write_timer_summary_log(to_screen, total_wall, min_elapsed) + ! Per-timer summary table (name, seconds, % of total, #calls). + ! Walks the timer list via the iteration API on sfincs_timers. + ! Called from write_finished_log. + ! + ! write_runtimes_file(unit, filename) + ! Writes the runtimes.txt payload (simulation-loop wall time, + ! input wall time, and each phase timer) in the format the + ! original inline code in sfincs_lib produced. Called from + ! sfincs_finalize (sfincs_lib) when write_time_output is set. + ! + use sfincs_timers ! integer :: fid character(256) :: logstr @@ -23,280 +59,419 @@ module sfincs_log real, save :: percdonenext = 0.0 ! contains - - subroutine open_log() ! - implicit none - ! - fid = 777 - open(unit = fid, file = 'sfincs.log') - ! - end subroutine - - subroutine write_log(str, to_screen) + !-----------------------------------------------------------------------------------------------------! ! - implicit none + subroutine open_log() + ! + ! Open sfincs.log on the module-local unit fid=777. Called once + ! at the very start of sfincs_initialize (sfincs_lib). + ! + implicit none + ! + fid = 777 + open(unit = fid, file = 'sfincs.log') + ! + end subroutine open_log ! - character(*), intent(in) :: str - integer, intent(in) :: to_screen + !-----------------------------------------------------------------------------------------------------! ! - write(fid,'(a)')trim(str) + subroutine write_log(str, to_screen) + ! + ! Write one line to sfincs.log, optionally echoed to stdout. + ! Called from every SFINCS module that emits user-facing output. + ! + implicit none + ! + character(*), intent(in) :: str + integer, intent(in) :: to_screen + ! + write(fid,'(a)') trim(str) + ! + if (to_screen == 1) then + write(*,'(a)') trim(str) + endif + ! + end subroutine write_log ! - if (to_screen==1) then - write(*,'(a)')trim(str) - endif + !-----------------------------------------------------------------------------------------------------! ! - end subroutine - subroutine close_log() + ! + ! Close the sfincs.log file handle. Called once at the end of + ! sfincs_finalize (sfincs_lib). + ! + implicit none + ! + close(fid) + ! + end subroutine close_log ! - implicit none - ! - close(fid) - ! - end subroutine - !-----------------------------------------------------------------------------------------------------! ! subroutine write_startup_log() - ! - ! Welcome banner, ASCII logo and build-revision / build-date lines. - ! Called once at the start of sfincs_initialize, after build_revision - ! and build_date have been set in sfincs_data. - ! - use sfincs_data - ! - implicit none - ! - call write_log('', 1) - call write_log('------------ Welcome to SFINCS ------------', 1) - call write_log('', 1) - call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) - call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) - call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) - call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) - call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) - call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) - call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) - call write_log('', 1) - call write_log(' .............. ', 1) - call write_log(' ......:@@@@@@@@:...... ', 1) - call write_log(' ..::::..@@........@@.:::::.. ', 1) - call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) - call write_log(' .::::::..@@............@@.:::::::. ', 1) - call write_log(' .::::::..@@..............@@.:::::::. ', 1) - call write_log(' .::::::::..@@............@@..::::::::. ', 1) - call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) - call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) - call write_log(' ............@@.@@..@@..@@.@@............ ', 1) - call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) - call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) - call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) - call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) - call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) - call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) - call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) - call write_log(' ...................... ', 1) - call write_log(' .............. ', 1) - call write_log('', 1) - call write_log('------------------------------------------', 1) - call write_log('', 1) - call write_log('Build-Revision: '//trim(build_revision), 1) - call write_log('Build-Date: '//trim(build_date), 1) - call write_log('', 1) - ! + ! + ! Welcome banner, ASCII logo and build-revision / build-date lines. + ! Called once at the start of sfincs_initialize (sfincs_lib), + ! after build_revision and build_date have been set in sfincs_data. + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------ Welcome to SFINCS ------------', 1) + call write_log('', 1) + call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) + call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) + call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) + call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) + call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) + call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) + call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) + call write_log('', 1) + call write_log(' .............. ', 1) + call write_log(' ......:@@@@@@@@:...... ', 1) + call write_log(' ..::::..@@........@@.:::::.. ', 1) + call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) + call write_log(' .::::::..@@............@@.:::::::. ', 1) + call write_log(' .::::::..@@..............@@.:::::::. ', 1) + call write_log(' .::::::::..@@............@@..::::::::. ', 1) + call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) + call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) + call write_log(' ............@@.@@..@@..@@.@@............ ', 1) + call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) + call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) + call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) + call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) + call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) + call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) + call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) + call write_log(' ...................... ', 1) + call write_log(' .............. ', 1) + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('', 1) + call write_log('Build-Revision: '//trim(build_revision), 1) + call write_log('Build-Date: '//trim(build_date), 1) + call write_log('', 1) + ! end subroutine write_startup_log ! !-----------------------------------------------------------------------------------------------------! ! subroutine write_processes_log() - ! - ! "Processes" summary block listing which physical processes are - ! enabled for this run. Reads the process flags from sfincs_data. - ! - use sfincs_data - ! - implicit none - ! - call write_log('', 1) - call write_log('------------------------------------------', 1) - call write_log('Processes', 1) - call write_log('------------------------------------------', 1) - ! - if (subgrid) then - call write_log('Subgrid topography : yes', 1) - else - call write_log('Subgrid topography : no', 1) - endif - ! - if (use_quadtree) then - call write_log('Quadtree refinement : yes', 1) - else - call write_log('Quadtree refinement : no', 1) - endif - ! - if (advection) then - call write_log('Advection : yes', 1) - else - call write_log('Advection : no', 1) - endif - ! - if (viscosity) then - call write_log('Viscosity : yes', 1) - else - call write_log('Viscosity : no', 1) - endif - ! - if (coriolis) then - call write_log('Coriolis : yes', 1) - else - call write_log('Coriolis : no', 1) - endif - ! - if (wind) then - call write_log('Wind : yes', 1) - else - call write_log('Wind : no', 1) - endif - ! - if (patmos) then - call write_log('Atmospheric pressure : yes', 1) - else - call write_log('Atmospheric pressure : no', 1) - endif - ! - if (precip) then - call write_log('Precipitation : yes', 1) - else - call write_log('Precipitation : no', 1) - endif - ! - if (infiltration) then - call write_log('Infiltration : yes', 1) - else - call write_log('Infiltration : no', 1) - endif - ! - if (drainage) then - call write_log('Drainage : yes', 1) - else - call write_log('Drainage : no', 1) - endif - ! - if (snapwave) then - call write_log('SnapWave : yes', 1) - else - call write_log('SnapWave : no', 1) - endif - ! - if (wavemaker) then - call write_log('Wave paddles : yes', 1) - else - call write_log('Wave paddles : no', 1) - endif - ! - if (nonhydrostatic) then - call write_log('Non-hydrostatic : yes', 1) - else - ! call write_log('Non-hydrostatic : no', 1) - endif - ! - if (bathtub) then - call write_log('Bathtub : yes', 1) - else - ! call write_log('Bathtub : no', 1) - endif - ! - call write_log('------------------------------------------', 1) - call write_log('', 1) - ! + ! + ! "Processes" summary block listing which physical processes are + ! enabled for this run. Reads the process flags from sfincs_data. + ! Called once from sfincs_initialize (sfincs_lib). + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('Processes', 1) + call write_log('------------------------------------------', 1) + ! + if (subgrid) then + call write_log('Subgrid topography : yes', 1) + else + call write_log('Subgrid topography : no', 1) + endif + ! + if (use_quadtree) then + call write_log('Quadtree refinement : yes', 1) + else + call write_log('Quadtree refinement : no', 1) + endif + ! + if (advection) then + call write_log('Advection : yes', 1) + else + call write_log('Advection : no', 1) + endif + ! + if (viscosity) then + call write_log('Viscosity : yes', 1) + else + call write_log('Viscosity : no', 1) + endif + ! + if (coriolis) then + call write_log('Coriolis : yes', 1) + else + call write_log('Coriolis : no', 1) + endif + ! + if (wind) then + call write_log('Wind : yes', 1) + else + call write_log('Wind : no', 1) + endif + ! + if (patmos) then + call write_log('Atmospheric pressure : yes', 1) + else + call write_log('Atmospheric pressure : no', 1) + endif + ! + if (precip) then + call write_log('Precipitation : yes', 1) + else + call write_log('Precipitation : no', 1) + endif + ! + if (infiltration) then + call write_log('Infiltration : yes', 1) + else + call write_log('Infiltration : no', 1) + endif + ! + if (drainage) then + call write_log('Drainage : yes', 1) + else + call write_log('Drainage : no', 1) + endif + ! + if (snapwave) then + call write_log('SnapWave : yes', 1) + else + call write_log('SnapWave : no', 1) + endif + ! + if (wavemaker) then + call write_log('Wave paddles : yes', 1) + else + call write_log('Wave paddles : no', 1) + endif + ! + if (nonhydrostatic) then + call write_log('Non-hydrostatic : yes', 1) + else + ! call write_log('Non-hydrostatic : no', 1) + endif + ! + if (bathtub) then + call write_log('Bathtub : yes', 1) + else + ! call write_log('Bathtub : no', 1) + endif + ! + call write_log('------------------------------------------', 1) + call write_log('', 1) + ! end subroutine write_processes_log ! !-----------------------------------------------------------------------------------------------------! ! subroutine write_progress_log(t, t0, t1) - ! - ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s - ! remaining ..." line each time the simulated-time percentage - ! crosses the next percdoneval threshold. Remaining time is - ! estimated from the wall-clock elapsed in the 'Simulation loop' - ! timer. - ! - use sfincs_data, only: percdoneval - use sfincs_timers, only: timer_elapsed - ! - implicit none - ! - real*8, intent(in) :: t - real*4, intent(in) :: t0, t1 - ! - real :: percdone, trun, trem - character(len=256) :: logstr - ! - percdone = min(100 * (t - t0) / (t1 - t0), 100.0) - ! - if (percdone >= percdonenext) then ! - ! percdoneval is increment of % to show to log, default=+5% + ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s + ! remaining ..." line each time the simulated-time percentage + ! crosses the next percdoneval threshold. Remaining time is + ! estimated from the wall-clock elapsed in the 'Simulation loop' + ! timer. ! - percdonenext = 1.0 * (int(percdone) + percdoneval) + ! Called every time step from the main loop in sfincs_lib. ! - trun = real(timer_elapsed('Simulation loop'), 4) - trem = trun / max(0.01*percdone, 1.0e-6) - trun + use sfincs_data, only: percdoneval ! - if (int(percdone)>0) then + implicit none + ! + real*8, intent(in) :: t + real*4, intent(in) :: t0, t1 + ! + real :: percdone, trun, trem + character(len=256) :: logstr + ! + percdone = min(100.0 * (real(t, 4) - t0) / (t1 - t0), 100.0) + ! + if (percdone >= percdonenext) then ! - write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, ',trem,' s remaining ...' - call write_log(logstr, 1) + ! percdoneval is increment of % to show to log, default=+5% ! - else + percdonenext = 1.0 * (int(percdone) + percdoneval) ! - write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, - s remaining ...' - call write_log(logstr, 1) + trun = real(timer_elapsed('Simulation loop'), 4) + trem = trun / max(0.01*percdone, 1.0e-6) - trun + ! + if (int(percdone) > 0) then + ! + write(logstr,'(i4,a,f7.1,a)') int(percdone),'% complete, ',trem,' s remaining ...' + call write_log(logstr, 1) + ! + else + ! + write(logstr,'(i4,a,f7.1,a)') int(percdone),'% complete, - s remaining ...' + call write_log(logstr, 1) + ! + endif ! endif ! - endif - ! end subroutine write_progress_log ! !-----------------------------------------------------------------------------------------------------! ! subroutine write_finished_log(dtavg) + ! + ! End-of-run log block: "Simulation finished" banner, per-phase + ! timer summary, and the average time step line. Called once from + ! sfincs_finalize (sfincs_lib), after the simulation loop has + ! stopped and dtavg has been averaged. + ! + implicit none + ! + real, intent(in) :: dtavg + ! + character(len=256) :: logstr + ! + call write_log('', 1) + call write_log('---------- Simulation finished -----------', 1) + call write_log('', 1) + ! + call write_timer_headers_log(1) + ! + ! Per-phase timing summary. Percentages are relative to the total + ! wall time of the simulation loop. + ! + call write_timer_summary_log(1, timer_elapsed('Simulation loop'), 0.0005_8) + ! + call write_log('', 1) + ! + write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg + call write_log(logstr, 1) + ! + call write_log('', 1) + ! + end subroutine write_finished_log ! - ! End-of-run log block: "Simulation finished" banner, per-phase - ! timer summary, and the average time step line. Called once from - ! sfincs_finalize, after the simulation loop has stopped and - ! dtavg has been averaged. - ! - use sfincs_timers, only: timer_write_headers, timer_write_summary, timer_elapsed - ! - implicit none - ! - real, intent(in) :: dtavg - ! - character(len=256) :: logstr - ! - call write_log('', 1) - call write_log('---------- Simulation finished -----------', 1) - call write_log('', 1) - ! - call timer_write_headers(1) - ! - ! Per-phase timing summary. Percentages are relative to the total - ! wall time of the simulation loop. - ! - call timer_write_summary(1, timer_elapsed('Simulation loop'), 0.0005_8) - ! - call write_log('', 1) + !-----------------------------------------------------------------------------------------------------! ! - write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg - call write_log(logstr, 1) + subroutine write_timer_headers_log(to_screen) + ! + ! Write the three 'Total time / Total simulation time / Time in input' header + ! lines to the log, using the 'Input' and 'Simulation loop' named timers. + ! + ! Called from: write_finished_log. + ! + integer, intent(in) :: to_screen + ! + real(8) :: t_input + real(8) :: t_loop + ! + t_input = timer_elapsed('Input') + t_loop = timer_elapsed('Simulation loop') + ! + write(logstr, '(a,f10.3)') ' Total time : ', t_input + t_loop + call write_log(trim(logstr), to_screen) + ! + write(logstr, '(a,f10.3)') ' Total simulation time : ', t_loop + call write_log(trim(logstr), to_screen) + ! + write(logstr, '(a,f10.3)') ' Time in input : ', t_input + call write_log(trim(logstr), to_screen) + ! + end subroutine write_timer_headers_log ! - call write_log('', 1) + !-----------------------------------------------------------------------------------------------------! ! - end subroutine write_finished_log + subroutine write_timer_summary_log(to_screen, total_wall, min_elapsed) + ! + ! Pretty-print a summary of all registered timers via write_log. + ! Walks the timer list via the iteration API on sfincs_timers + ! (timer_num_registered, timer_name_by_index, timer_elapsed_by_index, + ! timer_count_by_index) so this module does not need to know about + ! the internal storage of sfincs_timers. + ! + ! to_screen : passed to write_log (1 = also echo to stdout). + ! total_wall : reference total wall time used for the '%' column. + ! If <= 0, the sum across all timers is used instead. + ! min_elapsed : timers with accumulated time below this threshold (in s) + ! are skipped. Pass a negative value to print every timer. + ! + ! Called from: write_finished_log. + ! + integer, intent(in) :: to_screen + real(8), intent(in) :: total_wall + real(8), intent(in) :: min_elapsed + ! + real(8) :: denom + real(8) :: t_el + real(8) :: pct + integer :: i + integer :: n + integer :: ncalls + character(32) :: call_label + character(32) :: tname + character(256) :: line + ! + if (total_wall > 0.0_8) then + denom = total_wall + else + denom = max(timer_total_wall(), 1.0e-12_8) + endif + ! + n = timer_num_registered() + ! + do i = 1, n + ! + t_el = timer_elapsed_by_index(i) + ! + if (t_el < min_elapsed) cycle + ! + pct = 100.0_8 * t_el / denom + ncalls = timer_count_by_index(i) + tname = timer_name_by_index(i) + ! + if (ncalls == 1) then + write(call_label, '(i0,a)') ncalls, ' call' + else + write(call_label, '(i0,a)') ncalls, ' calls' + endif + ! + write(line, '(1x,a,t25,a,f10.3,a,f5.1,a,a,a)') & + trim(tname), ': ', t_el, ' (', pct, '%, ', trim(call_label), ')' + ! + call write_log(trim(line), to_screen) + ! + enddo + ! + end subroutine write_timer_summary_log ! !-----------------------------------------------------------------------------------------------------! ! -end module + subroutine write_runtimes_file(unit, filename) + ! + ! Write the runtimes.txt payload: simulation-loop wall time, input wall time, + ! and each phase timer, in the same order and with the same keys as the + ! previous inline implementation in sfincs_lib.f90. + ! + ! Called from: sfincs_finalize (sfincs_lib) when write_time_output + ! is set. + ! + integer, intent(in) :: unit + character(len=*), intent(in) :: filename + ! + open(unit, file=filename) + ! + write(unit, '(f10.3,a)') real(timer_elapsed('Simulation loop'), 4), ' % total' + write(unit, '(f10.3,a)') real(timer_elapsed('Input'), 4), ' % input' + write(unit, '(f10.3,a)') real(timer_elapsed('Boundaries'), 4), ' % boundaries' + write(unit, '(f10.3,a)') real(timer_elapsed('Discharges'), 4), ' % discharges' + write(unit, '(f10.3,a)') real(timer_elapsed('Drainage structures'), 4), ' % drainage_structures' + write(unit, '(f10.3,a)') real(timer_elapsed('Meteo fields'), 4), ' % meteo1' + write(unit, '(f10.3,a)') real(timer_elapsed('Meteo forcing'), 4), ' % meteo2' + write(unit, '(f10.3,a)') real(timer_elapsed('Infiltration'), 4), ' % infiltration' + write(unit, '(f10.3,a)') real(timer_elapsed('Momentum'), 4), ' % momentum' + write(unit, '(f10.3,a)') real(timer_elapsed('Structures'), 4), ' % structures' + write(unit, '(f10.3,a)') real(timer_elapsed('Continuity'), 4), ' % continuity' + write(unit, '(f10.3,a)') real(timer_elapsed('Output'), 4), ' % output' + ! + close(unit) + ! + end subroutine write_runtimes_file + ! +end module sfincs_log diff --git a/source/src/sfincs_timers.f90 b/source/src/sfincs_timers.f90 index 5e3f43757..8cdf90950 100644 --- a/source/src/sfincs_timers.f90 +++ b/source/src/sfincs_timers.f90 @@ -15,7 +15,44 @@ module sfincs_timers ! from the serial driver, outside of !$omp parallel regions. They are ! NOT thread-safe. ! - use sfincs_log + ! This module is a pure data module and deliberately has NO dependency + ! on sfincs_log: rendering/pretty-printing of timer data lives in + ! sfincs_log (write_timer_headers_log, write_timer_summary_log, + ! write_runtimes_file), which walks the timer list via the iteration + ! API below. Keeping the two modules separated avoids a circular + ! dependency (sfincs_log already uses timer_elapsed internally). + ! + ! Subroutines / functions: + ! + ! timer_start(name) / timer_stop(name) + ! Start / stop a named timer. Lazily registers on first start. + ! Called from every phase in sfincs_lib (Input, Simulation loop, + ! Boundaries, Momentum, Continuity, Output, ...) and from + ! update_wave_field in sfincs_snapwave. + ! + ! timer_reset(name) + ! Zero a single timer. Currently unused by the main driver but + ! kept as part of the public API. + ! + ! timer_elapsed(name) / timer_count(name) + ! Read accumulated wall time / call count for a named timer. + ! Called from sfincs_log (write_progress_log, + ! write_finished_log, write_timer_headers_log, + ! write_runtimes_file). + ! + ! timer_total_wall() + ! Sum of accumulated wall time across all registered timers. + ! Called from write_timer_summary_log in sfincs_log. + ! + ! timer_num_registered() + ! Number of timers currently registered. Called from + ! write_timer_summary_log in sfincs_log. + ! + ! timer_name_by_index(i) / timer_elapsed_by_index(i) / + ! timer_count_by_index(i) + ! Iteration API: read a timer's stored name / accumulated wall + ! time / call count by index. Indices run 1 .. timer_num_registered(). + ! Called from write_timer_summary_log in sfincs_log. ! implicit none ! @@ -27,9 +64,10 @@ module sfincs_timers public :: timer_elapsed public :: timer_count public :: timer_total_wall - public :: timer_write_summary - public :: timer_write_headers - public :: timer_write_runtimes_file + public :: timer_num_registered + public :: timer_name_by_index + public :: timer_elapsed_by_index + public :: timer_count_by_index ! integer, parameter :: name_len = 32 integer, parameter :: max_timers = 64 @@ -53,333 +91,322 @@ module sfincs_timers !-----------------------------------------------------------------------------------------------------! ! integer function timer_find(name) result(idx) - ! - ! Return the index of the timer with the given name, or 0 if not present. - ! - character(len=*), intent(in) :: name - integer :: i - ! - idx = 0 - ! - do i = 1, n_timers ! - if (trim(timers(i)%name) == trim(name)) then - idx = i - return - endif + ! Return the index of the timer with the given name, or 0 if not present. + ! + ! Called from: timer_find_or_register, timer_stop, timer_reset, + ! timer_elapsed, timer_count (all within this module). + ! + character(len=*), intent(in) :: name + integer :: i + ! + idx = 0 + ! + do i = 1, n_timers + ! + if (trim(timers(i)%name) == trim(name)) then + idx = i + return + endif + ! + enddo ! - enddo - ! end function timer_find ! !-----------------------------------------------------------------------------------------------------! ! integer function timer_find_or_register(name) result(idx) - ! - ! Return the index of the timer with the given name, creating a new - ! record if it did not yet exist. Returns 0 if the table is full. - ! - character(len=*), intent(in) :: name - ! - idx = timer_find(name) - ! - if (idx > 0) return - ! - if (n_timers >= max_timers) then ! - if (.not. warned_full) then + ! Return the index of the timer with the given name, creating a new + ! record if it did not yet exist. Returns 0 if the table is full. + ! + ! Called from: timer_start (within this module). + ! + character(len=*), intent(in) :: name + ! + idx = timer_find(name) + ! + if (idx > 0) return + ! + if (n_timers >= max_timers) then ! - call write_log(' Warning: sfincs_timers table full, timer ignored: '//trim(name), 1) - warned_full = .true. + if (.not. warned_full) then + ! + write(*, '(a)') ' Warning: sfincs_timers table full, timer ignored: '//trim(name) + warned_full = .true. + ! + endif + ! + idx = 0 + return ! endif ! - idx = 0 - return + n_timers = n_timers + 1 + idx = n_timers + ! + timers(idx)%name = name + timers(idx)%accumulated = 0.0_8 + timers(idx)%last_start = 0_8 + timers(idx)%n_calls = 0 + timers(idx)%running = .false. + timers(idx)%warned_start = .false. + timers(idx)%warned_stop = .false. ! - endif - ! - n_timers = n_timers + 1 - idx = n_timers - ! - timers(idx)%name = name - timers(idx)%accumulated = 0.0_8 - timers(idx)%last_start = 0_8 - timers(idx)%n_calls = 0 - timers(idx)%running = .false. - timers(idx)%warned_start = .false. - timers(idx)%warned_stop = .false. - ! end function timer_find_or_register ! !-----------------------------------------------------------------------------------------------------! ! subroutine timer_start(name) - ! - ! Start (or resume-and-accumulate-on-stop) the timer with the given name. - ! Lazily registers a new timer on first call. - ! - character(len=*), intent(in) :: name - integer :: idx - integer(8) :: c, rate - ! - idx = timer_find_or_register(name) - ! - if (idx == 0) return - ! - if (timers(idx)%running) then ! - if (.not. timers(idx)%warned_start) then + ! Start (or resume-and-accumulate-on-stop) the timer with the given name. + ! Lazily registers a new timer on first call. + ! + ! Called from: sfincs_lib (main driver, every phase) and + ! update_wave_field in sfincs_snapwave. + ! + character(len=*), intent(in) :: name + integer :: idx + integer(8) :: c, rate + ! + idx = timer_find_or_register(name) + ! + if (idx == 0) return + ! + if (timers(idx)%running) then + ! + if (.not. timers(idx)%warned_start) then + ! + write(*, '(a)') ' Warning: timer_start on already-running timer: '//trim(name) + timers(idx)%warned_start = .true. + ! + endif ! - call write_log(' Warning: timer_start on already-running timer: '//trim(name), 1) - timers(idx)%warned_start = .true. + return ! endif ! - return + call system_clock(c, rate) + ! + timers(idx)%last_start = c + timers(idx)%running = .true. ! - endif - ! - call system_clock(c, rate) - ! - timers(idx)%last_start = c - timers(idx)%running = .true. - ! end subroutine timer_start ! !-----------------------------------------------------------------------------------------------------! ! subroutine timer_stop(name) - ! - ! Stop the timer and add the elapsed interval to its accumulated total. - ! - character(len=*), intent(in) :: name - integer :: idx - integer(8) :: c, rate - ! - idx = timer_find(name) - ! - if (idx == 0) then ! - call write_log(' Warning: timer_stop on unknown timer: '//trim(name), 1) - return + ! Stop the timer and add the elapsed interval to its accumulated total. ! - endif - ! - if (.not. timers(idx)%running) then + ! Called from: sfincs_lib (main driver, every phase) and + ! update_wave_field in sfincs_snapwave. ! - if (.not. timers(idx)%warned_stop) then + character(len=*), intent(in) :: name + integer :: idx + integer(8) :: c, rate + ! + idx = timer_find(name) + ! + if (idx == 0) then ! - call write_log(' Warning: timer_stop on non-running timer: '//trim(name), 1) - timers(idx)%warned_stop = .true. + write(*, '(a)') ' Warning: timer_stop on unknown timer: '//trim(name) + return ! endif ! - return + if (.not. timers(idx)%running) then + ! + if (.not. timers(idx)%warned_stop) then + ! + write(*, '(a)') ' Warning: timer_stop on non-running timer: '//trim(name) + timers(idx)%warned_stop = .true. + ! + endif + ! + return + ! + endif + ! + call system_clock(c, rate) + ! + timers(idx)%accumulated = timers(idx)%accumulated + real(c - timers(idx)%last_start, 8) / real(rate, 8) + timers(idx)%n_calls = timers(idx)%n_calls + 1 + timers(idx)%running = .false. ! - endif - ! - call system_clock(c, rate) - ! - timers(idx)%accumulated = timers(idx)%accumulated + real(c - timers(idx)%last_start, 8) / real(rate, 8) - timers(idx)%n_calls = timers(idx)%n_calls + 1 - timers(idx)%running = .false. - ! end subroutine timer_stop ! !-----------------------------------------------------------------------------------------------------! ! subroutine timer_reset(name) - ! - ! Reset a single timer's accumulated time and call count to zero. - ! - character(len=*), intent(in) :: name - integer :: idx - ! - idx = timer_find(name) - ! - if (idx == 0) return - ! - timers(idx)%accumulated = 0.0_8 - timers(idx)%n_calls = 0 - timers(idx)%running = .false. - ! + ! + ! Reset a single timer's accumulated time and call count to zero. + ! + ! Called from: (currently no live callers; part of the public API.) + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find(name) + ! + if (idx == 0) return + ! + timers(idx)%accumulated = 0.0_8 + timers(idx)%n_calls = 0 + timers(idx)%running = .false. + ! end subroutine timer_reset ! !-----------------------------------------------------------------------------------------------------! ! real(8) function timer_elapsed(name) result(elapsed) - ! - ! Accumulated wall time (in seconds) for the named timer. - ! Returns 0 if the timer is unknown. If the timer is currently running, - ! the interval since the most recent timer_start is included (without - ! modifying the stored accumulated value). - ! - character(len=*), intent(in) :: name - integer :: idx - integer(8) :: c, rate - ! - idx = timer_find(name) - ! - if (idx == 0) then - elapsed = 0.0_8 - return - endif - ! - elapsed = timers(idx)%accumulated - ! - if (timers(idx)%running) then ! - call system_clock(c, rate) + ! Accumulated wall time (in seconds) for the named timer. + ! Returns 0 if the timer is unknown. If the timer is currently running, + ! the interval since the most recent timer_start is included (without + ! modifying the stored accumulated value). ! - elapsed = elapsed + real(c - timers(idx)%last_start, 8) / real(rate, 8) + ! Called from: sfincs_log (write_progress_log, write_finished_log, + ! write_timer_headers_log, write_runtimes_file). + ! + character(len=*), intent(in) :: name + integer :: idx + integer(8) :: c, rate + ! + idx = timer_find(name) + ! + if (idx == 0) then + elapsed = 0.0_8 + return + endif + ! + elapsed = timers(idx)%accumulated + ! + if (timers(idx)%running) then + ! + call system_clock(c, rate) + ! + elapsed = elapsed + real(c - timers(idx)%last_start, 8) / real(rate, 8) + ! + endif ! - endif - ! end function timer_elapsed ! !-----------------------------------------------------------------------------------------------------! ! integer function timer_count(name) result(n) - ! - ! Number of completed start/stop cycles for the named timer. - ! - character(len=*), intent(in) :: name - integer :: idx - ! - idx = timer_find(name) - ! - if (idx == 0) then - n = 0 - return - endif - ! - n = timers(idx)%n_calls - ! + ! + ! Number of completed start/stop cycles for the named timer. + ! + ! Called from: (currently no live callers; part of the public API.) + ! + character(len=*), intent(in) :: name + integer :: idx + ! + idx = timer_find(name) + ! + if (idx == 0) then + n = 0 + return + endif + ! + n = timers(idx)%n_calls + ! end function timer_count ! !-----------------------------------------------------------------------------------------------------! ! real(8) function timer_total_wall() result(total) - ! - ! Sum of accumulated wall time across all registered timers. - ! - integer :: i - ! - total = 0.0_8 - ! - do i = 1, n_timers - total = total + timers(i)%accumulated - enddo - ! + ! + ! Sum of accumulated wall time across all registered timers. + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + integer :: i + ! + total = 0.0_8 + ! + do i = 1, n_timers + total = total + timers(i)%accumulated + enddo + ! end function timer_total_wall ! !-----------------------------------------------------------------------------------------------------! ! - subroutine timer_write_summary(to_screen, total_wall, min_elapsed) - ! - ! Pretty-print a summary of all registered timers via write_log. - ! - ! to_screen : passed to write_log (1 = also echo to stdout). - ! total_wall : reference total wall time used for the '%' column. - ! If <= 0, the sum across all timers is used instead. - ! min_elapsed : timers with accumulated time below this threshold (in s) - ! are skipped. Pass a negative value to print every timer. - ! - integer, intent(in) :: to_screen - real(8), intent(in) :: total_wall - real(8), intent(in) :: min_elapsed - ! - real(8) :: denom - real(8) :: t_el - real(8) :: pct - integer :: i - character(32) :: call_label - character(256) :: line + integer function timer_num_registered() result(n) + ! + ! Number of timers currently registered. Used by the rendering + ! routines in sfincs_log to iterate over every timer without + ! touching module-private state. + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + n = n_timers + ! + end function timer_num_registered ! - if (total_wall > 0.0_8) then - denom = total_wall - else - denom = max(timer_total_wall(), 1.0e-12_8) - endif + !-----------------------------------------------------------------------------------------------------! ! - do i = 1, n_timers + function timer_name_by_index(i) result(name) ! - t_el = timers(i)%accumulated + ! Return the stored name of the i-th registered timer, or an empty + ! string for out-of-range i. Indices run 1 .. timer_num_registered(). ! - if (t_el < min_elapsed) cycle + ! Called from: write_timer_summary_log in sfincs_log. ! - pct = 100.0_8 * t_el / denom + integer, intent(in) :: i + character(len=name_len) :: name ! - if (timers(i)%n_calls == 1) then - write(call_label, '(i0,a)') timers(i)%n_calls, ' call' - else - write(call_label, '(i0,a)') timers(i)%n_calls, ' calls' + if (i < 1 .or. i > n_timers) then + name = '' + return endif ! - write(line, '(1x,a,t25,a,f10.3,a,f5.1,a,a,a)') & - trim(timers(i)%name), ': ', t_el, ' (', pct, '%, ', trim(call_label), ')' + name = timers(i)%name ! - call write_log(trim(line), to_screen) - ! - enddo - ! - end subroutine timer_write_summary + end function timer_name_by_index ! !-----------------------------------------------------------------------------------------------------! ! - subroutine timer_write_headers(to_screen) - ! - ! Write the three 'Total time / Total simulation time / Time in input' header - ! lines to the log, using the 'Input' and 'Simulation loop' named timers. - ! - integer, intent(in) :: to_screen - ! - real(8) :: t_input - real(8) :: t_loop - ! - t_input = timer_elapsed('Input') - t_loop = timer_elapsed('Simulation loop') - ! - write(logstr, '(a,f10.3)') ' Total time : ', t_input + t_loop - call write_log(trim(logstr), to_screen) - ! - write(logstr, '(a,f10.3)') ' Total simulation time : ', t_loop - call write_log(trim(logstr), to_screen) - ! - write(logstr, '(a,f10.3)') ' Time in input : ', t_input - call write_log(trim(logstr), to_screen) - ! - end subroutine timer_write_headers + real(8) function timer_elapsed_by_index(i) result(elapsed) + ! + ! Accumulated wall time of the i-th registered timer. Returns 0 for + ! out-of-range i. Does NOT include a running-interval contribution + ! (use timer_elapsed(name) if you need that — the rendering code + ! runs after the simulation loop has stopped all timers). + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + integer, intent(in) :: i + ! + if (i < 1 .or. i > n_timers) then + elapsed = 0.0_8 + return + endif + ! + elapsed = timers(i)%accumulated + ! + end function timer_elapsed_by_index ! !-----------------------------------------------------------------------------------------------------! ! - subroutine timer_write_runtimes_file(unit, filename) - ! - ! Write the runtimes.txt payload: simulation-loop wall time, input wall time, - ! and each phase timer, in the same order and with the same keys as the - ! previous inline implementation in sfincs_lib.f90. - ! - integer, intent(in) :: unit - character(len=*), intent(in) :: filename - ! - open(unit, file=filename) - ! - write(unit, '(f10.3,a)') real(timer_elapsed('Simulation loop'), 4), ' % total' - write(unit, '(f10.3,a)') real(timer_elapsed('Input'), 4), ' % input' - write(unit, '(f10.3,a)') real(timer_elapsed('Boundaries'), 4), ' % boundaries' - write(unit, '(f10.3,a)') real(timer_elapsed('Discharges'), 4), ' % discharges' - write(unit, '(f10.3,a)') real(timer_elapsed('Drainage structures'), 4), ' % drainage_structures' - write(unit, '(f10.3,a)') real(timer_elapsed('Meteo fields'), 4), ' % meteo1' - write(unit, '(f10.3,a)') real(timer_elapsed('Meteo forcing'), 4), ' % meteo2' - write(unit, '(f10.3,a)') real(timer_elapsed('Infiltration'), 4), ' % infiltration' - write(unit, '(f10.3,a)') real(timer_elapsed('Momentum'), 4), ' % momentum' - write(unit, '(f10.3,a)') real(timer_elapsed('Structures'), 4), ' % structures' - write(unit, '(f10.3,a)') real(timer_elapsed('Continuity'), 4), ' % continuity' - write(unit, '(f10.3,a)') real(timer_elapsed('Output'), 4), ' % output' - ! - close(unit) - ! - end subroutine timer_write_runtimes_file + integer function timer_count_by_index(i) result(n) + ! + ! Number of completed start/stop cycles of the i-th registered + ! timer. Returns 0 for out-of-range i. + ! + ! Called from: write_timer_summary_log in sfincs_log. + ! + integer, intent(in) :: i + ! + if (i < 1 .or. i > n_timers) then + n = 0 + return + endif + ! + n = timers(i)%n_calls + ! + end function timer_count_by_index ! end module sfincs_timers From 3b2c040c3dbe7fd2a84c95b04a744803bfb38625 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 12:54:18 +0200 Subject: [PATCH 38/65] fix(timers): adopt omp_get_wtime(); widen legacy 32-bit timer helpers Two related timing bugs reported by an upstream PR (OceanLedger team / Claude-anthropic): - Bug 1 (integer overflow): 32-bit count / count_rate / count_max locals with nanosecond clocks roll over every ~2.15 s, producing silent negative elapsed times and the "Time in momentum: 335%" symptom. The recent sfincs_timers refactor already fixed this in the main timer machinery; the two legacy timer(t) helpers in sfincs_date.f90 and snapwave/snapwave_solver.f90 still had integer*4 locals and are widened here. - Bug 2 (CPU time vs wall time): system_clock under nvfortran + OpenACC GPU offload can return CPU time, not wall time, making a 6-hour GPU run report as ~10 minutes and causing time-remaining estimates to reset every ~10%. sfincs_timers.f90 now uses omp_get_wtime() (real*8 wall seconds, OpenMP-guaranteed monotonic) instead of system_clock. No behavior change on CPU builds (wall clocks match within jitter). No public signature changes. Culvert baseline unchanged at crosssection_discharge mean 3.6939 m^3/s. Credit: OceanLedger team for the diagnosis. Co-Authored-By: Claude Opus 4.7 (1M context) --- source/src/sfincs_date.f90 | 2 +- source/src/sfincs_timers.f90 | 29 ++++++++++--------------- source/src/snapwave/snapwave_solver.f90 | 2 +- 3 files changed, 14 insertions(+), 19 deletions(-) diff --git a/source/src/sfincs_date.f90 b/source/src/sfincs_date.f90 index ec732196d..6988958d1 100644 --- a/source/src/sfincs_date.f90 +++ b/source/src/sfincs_date.f90 @@ -365,7 +365,7 @@ function time_to_vector(t_sec, tref_string) result (date_time_vector) ! subroutine timer(t) real*4,intent(out) :: t - integer*4 :: count,count_rate,count_max + integer*8 :: count,count_rate,count_max call system_clock (count,count_rate,count_max) t = dble(count)/count_rate end subroutine timer diff --git a/source/src/sfincs_timers.f90 b/source/src/sfincs_timers.f90 index 8cdf90950..77d91d13b 100644 --- a/source/src/sfincs_timers.f90 +++ b/source/src/sfincs_timers.f90 @@ -7,9 +7,11 @@ module sfincs_timers ! lazily: the first timer_start('name') with a new name creates it; ! subsequent calls find the existing record and accumulate. ! - ! All timing is done via system_clock with integer*8 counts, so 64-bit - ! counters (typical on modern systems) do not wrap within any realistic - ! SFINCS run. + ! All timing is done via omp_get_wtime(), which returns real(8) wall + ! seconds and is guaranteed monotonic by OpenMP. This avoids two + ! pitfalls of system_clock: 32-bit count overflow on nanosecond clocks + ! (rolls over every ~2.15 s) and, under nvfortran + OpenACC GPU + ! offload, system_clock can return CPU time rather than wall time. ! ! Thread safety: timer_start / timer_stop are intended to be called ! from the serial driver, outside of !$omp parallel regions. They are @@ -54,6 +56,8 @@ module sfincs_timers ! time / call count by index. Indices run 1 .. timer_num_registered(). ! Called from write_timer_summary_log in sfincs_log. ! + use omp_lib + ! implicit none ! private @@ -75,7 +79,7 @@ module sfincs_timers type :: timer_record character(len=name_len) :: name = '' real(8) :: accumulated = 0.0_8 - integer(8) :: last_start = 0_8 + real(8) :: last_start = 0.0_8 integer :: n_calls = 0 logical :: running = .false. logical :: warned_start = .false. @@ -147,7 +151,7 @@ integer function timer_find_or_register(name) result(idx) ! timers(idx)%name = name timers(idx)%accumulated = 0.0_8 - timers(idx)%last_start = 0_8 + timers(idx)%last_start = 0.0_8 timers(idx)%n_calls = 0 timers(idx)%running = .false. timers(idx)%warned_start = .false. @@ -167,7 +171,6 @@ subroutine timer_start(name) ! character(len=*), intent(in) :: name integer :: idx - integer(8) :: c, rate ! idx = timer_find_or_register(name) ! @@ -186,9 +189,7 @@ subroutine timer_start(name) ! endif ! - call system_clock(c, rate) - ! - timers(idx)%last_start = c + timers(idx)%last_start = omp_get_wtime() timers(idx)%running = .true. ! end subroutine timer_start @@ -204,7 +205,6 @@ subroutine timer_stop(name) ! character(len=*), intent(in) :: name integer :: idx - integer(8) :: c, rate ! idx = timer_find(name) ! @@ -228,9 +228,7 @@ subroutine timer_stop(name) ! endif ! - call system_clock(c, rate) - ! - timers(idx)%accumulated = timers(idx)%accumulated + real(c - timers(idx)%last_start, 8) / real(rate, 8) + timers(idx)%accumulated = timers(idx)%accumulated + (omp_get_wtime() - timers(idx)%last_start) timers(idx)%n_calls = timers(idx)%n_calls + 1 timers(idx)%running = .false. ! @@ -271,7 +269,6 @@ real(8) function timer_elapsed(name) result(elapsed) ! character(len=*), intent(in) :: name integer :: idx - integer(8) :: c, rate ! idx = timer_find(name) ! @@ -284,9 +281,7 @@ real(8) function timer_elapsed(name) result(elapsed) ! if (timers(idx)%running) then ! - call system_clock(c, rate) - ! - elapsed = elapsed + real(c - timers(idx)%last_start, 8) / real(rate, 8) + elapsed = elapsed + (omp_get_wtime() - timers(idx)%last_start) ! endif ! diff --git a/source/src/snapwave/snapwave_solver.f90 b/source/src/snapwave/snapwave_solver.f90 index 53cc31d77..d310014a8 100644 --- a/source/src/snapwave/snapwave_solver.f90 +++ b/source/src/snapwave/snapwave_solver.f90 @@ -1351,7 +1351,7 @@ end subroutine hpsort_eps_epw subroutine timer(t) real*4,intent(out) :: t - integer*4 :: count,count_rate,count_max + integer*8 :: count,count_rate,count_max call system_clock (count,count_rate,count_max) t = real(count)/count_rate end subroutine timer From e11f6c011008df517dd3d082a16d05840182f938 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 12:56:35 +0200 Subject: [PATCH 39/65] Refactor sfincs_continuity; improved timers (thanks Ocean Ledger!) Major refactor of the continuity stage: reorganized update_continuity, split logic into clear subroutines (compute_water_levels_regular, compute_water_levels_subgrid, compute_store_variables), and cleaned up data/use/implicit blocks. Continuity now explicitly sequences discharges, drainage structures, infiltration, precipitation, urban drainage, BMI qext, flux divergence and storage-volume handling; added improved wavemaker/snapwave handling, subgrid interpolation, storage_volume logic, wiggle suppression and per-cell diagnostics (vmax/qmax/twet). Added sfincs_timers source to the vfproj and included a reformatted sfincs_log file; updated comments and documentation in sfincs_discharges. Small related tidy-ups in module use/order and OpenMP/OpenACC loops to better encapsulate work. --- source/sfincs_lib/sfincs_lib.vfproj | 2 +- source/src/sfincs_continuity.f90 | 1210 +++++----- source/src/sfincs_discharges.f90 | 513 +++-- source/src/sfincs_log.f90 | 18 +- source/src/sfincs_log.f90.reformatted | 298 +++ source/src/sfincs_momentum.f90 | 1 + source/src/sfincs_src_structures.f90 | 3058 +++++++++++++------------ 7 files changed, 2752 insertions(+), 2348 deletions(-) create mode 100644 source/src/sfincs_log.f90.reformatted diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 1709272d4..66d32851e 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -97,6 +97,7 @@ + @@ -155,7 +156,6 @@ - diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index 633806dd9..d31eb6703 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -1,196 +1,483 @@ module sfincs_continuity - -contains - - subroutine update_continuity(t, dt) - ! - ! Unified continuity update: orchestrates all water balance terms - ! - ! A. Point sources and sinks (all accumulated into qsrc): - ! 1. River discharges (+/-) => update_discharges (zeros and accumulates qsrc) - ! 2. Drainage structures (+/-) => update_src_structures (adds to qsrc) - ! 3. External source/sink qext (+/-) => added to qsrc here (BMI coupling) - ! B. Infiltration rate field qinfmap (-) => update_infiltration_map - ! (flavors: con, c2d, cna, cnb, gai, hor, bkt) - ! C. Hydrodynamic fluxes q => already computed in sfincs_momentum ! - ! compute_water_levels_{regular,subgrid} then updates zs/z_volume using: - ! - qsrc * dt => point source/sink contribution - ! - div(q) * dt => horizontal flux divergence - ! - storage volume => absorbs excess volume (subgrid only) + ! Water-level / volume update stage of the SFINCS time step. Runs after + ! sfincs_momentum has produced the face fluxes q on each cell edge and + ! is responsible for closing the volume balance on every active cell. ! - use sfincs_data - use sfincs_timers - use sfincs_infiltration - use sfincs_discharges - use sfincs_src_structures + ! See the breakdown at the top of update_continuity for exactly + ! which terms are accumulated into qsrc, which operate on qinfmap, and + ! which come from the hydrodynamic fluxes q already computed upstream. ! - implicit none + ! Data flow per step: + ! input : q(nuv), qext(np) (optional BMI), river/structure state, + ! qinfmap, storage_volume (subgrid), zs/z_volume at t + ! output : zs (all paths) and z_volume (subgrid path) advanced to + ! t+dt; optional zsmax, vmax, qmax, twet accumulators ! - real*8 :: t - real*4 :: dt + ! Subroutines: ! - integer :: nm + ! update_continuity(t, dt) + ! Main per-timestep entry. Orchestrates river discharges, drainage + ! structures, optional BMI qext, infiltration, and dispatches the + ! water-level update. Called from sfincs_lib (main time-stepping + ! loop). ! - ! A1. River discharges => update_discharges (zeros qsrc, then accumulates) + ! compute_water_levels_regular(dt, t) + ! Non-subgrid (bathtub / simple bathy) water-level update. Called + ! from update_continuity. ! - call update_discharges(t, dt) + ! compute_water_levels_subgrid(dt, t) + ! Subgrid-tables water-level update with storage-volume + ! bookkeeping. Called from update_continuity. ! - ! A2. Drainage structures (pumps/gates/culverts/...) => update_src_structures (adds to qsrc) + ! compute_store_variables(dt) + ! Update optional per-cell vmax / qmax / twet diagnostics. Called + ! from update_continuity only when any of store_maximum_velocity, + ! store_maximum_flux or store_twet is enabled. ! - call update_src_structures(t, dt) +contains ! - ! B. Compute infiltration rates => qinfmap (all flavors including bucket) + !-----------------------------------------------------------------------------------------------------! ! - if (infiltration) then + subroutine update_continuity(t, dt) ! - call update_infiltration_map(dt) + ! Unified continuity update: orchestrates all water balance terms + ! for one time step. Modifies qsrc in place (zeroed and + ! re-accumulated), advances zs (and z_volume on the subgrid path), + ! and optionally updates the store_* running maxima. ! - endif - ! - ! Urban drainage - ! - !if (urban_drainage) then - ! ! - ! call update_urban_drainage(t, dt) - ! ! - !endif - ! - ! A3. External source/sink (+/-) => add qext to qsrc (set via BMI coupling) - ! - if (use_qext) then + ! Called from: sfincs_lib (main time-stepping loop). ! - !$omp parallel & - !$omp private ( nm ) - !$omp do - !$acc loop gang vector - do nm = 1, np + ! Sources and sinks (all accumulated into qsrc, in m3/s): + ! 1. River discharges (+/-) => update_discharges (zeros and accumulates qsrc) + ! 2. Drainage structures (+/-) => update_src_structures (adds to qsrc) + ! 3. Precipitation (+) => update_meteo_forcing (precip * cell area) + ! 4. Infiltration rate field qinfmap (-) => update_infiltration_map (infiltration * cell area) + ! (flavors: con, c2d, cna, cnb, gai, hor, bkt) + ! 5. Urban drainage => update_urban_drainage (adds to qsrc) + ! 6. External source/sink qext (+/-) => added to qsrc here (BMI coupling) + ! + ! Hydrodynamic fluxes q => computed in sfincs_momentum + ! + ! compute_water_levels_{regular,subgrid} then updates zs/z_volume using: + ! - qsrc * dt => point source/sink contribution + ! - div(q) * dt => horizontal flux divergence + ! - storage volume => absorbs excess volume (subgrid only) + ! + use sfincs_data + use sfincs_timers + use sfincs_infiltration + use sfincs_discharges + use sfincs_src_structures + ! + implicit none + ! + real*8 :: t + real*4 :: dt + ! + integer :: nm + ! + ! 1. River discharges => update_discharges (adds to qsrc) + ! + call update_discharges(t, dt) + ! + ! 2. Drainage structures (pumps/gates/culverts/...) => update_src_structures (adds to qsrc) + ! + call update_src_structures(t, dt) + ! + ! 3. Precipitation => update_meteo_forcing (adds to qsrc) + ! + ! 4. Compute infiltration rates => qinfmap(adds to qsrc) + ! + if (infiltration) then ! - qsrc(nm) = qsrc(nm) + qext(nm) + call update_infiltration_map(dt) ! - enddo - !$acc end loop - !$omp end parallel + endif ! - endif - ! - ! Update water levels: applies qsrc * dt and flux divergence to zs/z_volume - ! - call timer_start('Continuity') - ! - if (subgrid) then + ! 5. Urban drainage ! - call compute_water_levels_subgrid(dt, t) + !if (urban_drainage) then + ! ! + ! call update_urban_drainage(t, dt) + ! ! + !endif ! - else + ! 6. External source/sink (+/-) => add qext to qsrc (set via BMI coupling) ! - call compute_water_levels_regular(dt, t) + if (use_qext) then + ! + !$omp parallel & + !$omp private ( nm ) + !$omp do + !$acc loop gang vector + do nm = 1, np + ! + qsrc(nm) = qsrc(nm) + qext(nm) + ! + enddo + !$acc end loop + !$omp end parallel + ! + endif ! - endif - ! - ! Put non-default store options in a separate subroutine (all but zsmax) to save computation time when not used (both regular and subgrid): - ! - if ((store_maximum_velocity .eqv. .true.) .or. (store_maximum_flux .eqv. .true.) .or. (store_twet .eqv. .true.)) then + ! Update water levels: applies qsrc * dt and flux divergence to zs/z_volume ! - call compute_store_variables(dt) + call timer_start('Continuity') + ! + if (subgrid) then + ! + call compute_water_levels_subgrid(dt, t) + ! + else + ! + call compute_water_levels_regular(dt, t) + ! + endif + ! + ! Put non-default store options in a separate subroutine (all but zsmax) to save computation time when not used (both regular and subgrid): + ! + if ((store_maximum_velocity .eqv. .true.) .or. (store_maximum_flux .eqv. .true.) .or. (store_twet .eqv. .true.)) then + ! + call compute_store_variables(dt) + ! + endif + ! + call timer_stop('Continuity') ! - endif - ! - call timer_stop('Continuity') - ! end subroutine ! + !-----------------------------------------------------------------------------------------------------! ! subroutine compute_water_levels_regular(dt, t) - ! - use sfincs_data - ! - implicit none - ! - real*4 :: dt - real*8 :: t - ! - integer :: nm - ! - integer :: iwm - ! - integer :: nmu - integer :: nmd - integer :: num - integer :: ndm - ! - real*4 :: qnmu - real*4 :: qnmd - real*4 :: qnum - real*4 :: qndm - real*4 :: factime - ! - if (snapwave) then ! need to compute filtered water levels for snapwave ! - factime = min(dt / wavemaker_filter_time, 1.0) + ! Advance zs(np) by dt on the non-subgrid (bathtub / simple bathy) + ! path. Applies cell-wise qsrc contributions and the horizontal + ! flux divergence, handles the optional wavemaker cells (kcs == 4), + ! updates the snapwave-filtered water level zsm, and accumulates + ! zsmax / t_zsmax when requested. ! - endif - ! - !$acc parallel present( kcs, zs, zb, prcp, q, qext, qinfmap, qdrain_rate, zsmax, zsm, maxzsm, & - !$acc z_flags_iref, uv_flags_iref, & - !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & - !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & - !$acc qsrc, & - !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num ) - ! - !$omp parallel & - !$omp private ( nm, nmd, nmu, ndm, num, qnmd, qnmu, qndm, qnum, iwm ) - !$omp do schedule ( dynamic, 256 ) - !$acc loop gang vector - do nm = 1, np + ! Called from: update_continuity (when subgrid is false). ! - if (kcs(nm) == 1) then ! Regular point + use sfincs_data + ! + implicit none + ! + real*4 :: dt + real*8 :: t + ! + integer :: nm + ! + integer :: iwm + ! + integer :: nmu + integer :: nmd + integer :: num + integer :: ndm + ! + real*4 :: qnmu + real*4 :: qnmd + real*4 :: qnum + real*4 :: qndm + real*4 :: factime + ! + if (snapwave) then ! need to compute filtered water levels for snapwave + ! + factime = min(dt / wavemaker_filter_time, 1.0) ! - ! Apply cell-wise discharges qsrc (rivers, drainage structures, qext) + endif + ! + !$acc parallel present( kcs, zs, zb, prcp, q, qext, qinfmap, qdrain_rate, zsmax, zsm, maxzsm, & + !$acc z_flags_iref, uv_flags_iref, & + !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & + !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & + !$acc qsrc, & + !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num ) + ! + !$omp parallel & + !$omp private ( nm, nmd, nmu, ndm, num, qnmd, qnmu, qndm, qnum, iwm ) + !$omp do schedule ( dynamic, 256 ) + !$acc loop gang vector + do nm = 1, np ! - if (qsrc(nm) /= 0.0) then + if (kcs(nm) == 1) then ! Regular point + ! + ! Apply cell-wise discharges qsrc (rivers, drainage structures, qext) + ! + if (qsrc(nm) /= 0.0) then + ! + if (crsgeo) then + zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area_m2(nm), zb(nm)) + else + zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area(z_flags_iref(nm)), zb(nm)) + endif + ! + endif + ! + nmd = z_index_uv_md(nm) + nmu = z_index_uv_mu(nm) + ndm = z_index_uv_nd(nm) + num = z_index_uv_nu(nm) ! if (crsgeo) then - zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area_m2(nm), zb(nm)) + ! + ! Use cell width dxm (which varies with latitude) + ! + zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) / dxm(nm) + (q(ndm) - q(num)) * dyrinv(z_flags_iref(nm)) ) * dt + ! + ! Should really be: + ! + ! zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) / dxm(nm) + (q(ndm) * f - q(num) / f) * dyrinv(z_flags_iref(nm)) ) * dt + ! + ! Where f if a correction factor for the ratio between cell width at cell centre and cell bottom: + ! + ! f = cos(y - 0.5*dy) / cos(y) (this holds both in northern and southern hemisphere) + ! else - zs(nm) = max(zs(nm) + qsrc(nm) * dt / cell_area(z_flags_iref(nm)), zb(nm)) + ! + zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) * dxrinv(z_flags_iref(nm)) + (q(ndm) - q(num)) * dyrinv(z_flags_iref(nm)) ) * dt + ! endif ! endif ! - nmd = z_index_uv_md(nm) - nmu = z_index_uv_mu(nm) - ndm = z_index_uv_nd(nm) - num = z_index_uv_nu(nm) + if (wavemaker) then + ! + if (kcs(nm) == 4) then + ! + ! Wave maker point (seaward of wave maker) + ! Here we use the mean flux at the location of the wave maker + ! + iwm = z_index_wavemaker(nm) + ! + if (wavemaker_nmd(iwm) > 0) then + ! + ! Wave paddle on the left + ! + qnmd = wavemaker_uvmean(wavemaker_nmd(iwm)) + ! + else + ! + qnmd = q(z_index_uv_md(nm)) + ! + endif + ! + if (wavemaker_nmu(iwm) > 0) then + ! + ! Wave paddle on the right + ! + qnmu = wavemaker_uvmean(wavemaker_nmu(iwm)) + ! + else + ! + qnmu = q(z_index_uv_mu(nm)) + ! + endif + ! + if (wavemaker_ndm(iwm) > 0) then + ! + ! Wave paddle below + ! + qndm = wavemaker_uvmean(wavemaker_ndm(iwm)) + ! + else + ! + qndm = q(z_index_uv_nd(nm)) + ! + endif + ! + if (wavemaker_num(iwm) > 0) then + ! + ! Wave paddle above + ! + qnum = wavemaker_uvmean(wavemaker_num(iwm)) + ! + else + ! + qnum = q(z_index_uv_nu(nm)) + ! + endif + ! + zs(nm) = zs(nm) + (((qnmd - qnmu) * dxrinv(z_flags_iref(nm)) + (qndm - qnum) * dyrinv(z_flags_iref(nm)))) * dt + ! + endif + ! + endif ! - if (crsgeo) then + if (snapwave) then ! - ! Use cell width dxm (which varies with latitude) + ! Time-averaged water level used for SnapWave using exponential filter ! - zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) / dxm(nm) + (q(ndm) - q(num)) * dyrinv(z_flags_iref(nm)) ) * dt + ! Would double exponential filtering be better? ! - ! Should really be: + zsm(nm) = factime * zs(nm) + (1.0 - factime) * zsm(nm) ! - ! zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) / dxm(nm) + (q(ndm) * f - q(num) / f) * dyrinv(z_flags_iref(nm)) ) * dt + if (store_maximum_waterlevel) then + ! + maxzsm(nm) = max(maxzsm(nm), zsm(nm)) + ! + endif ! - ! Where f if a correction factor for the ratio between cell width at cell centre and cell bottom: + endif + ! + ! No continuity update but keeping track of variables + ! zsmax used by default, therefore keep in standard continuity loop: + ! + if (store_maximum_waterlevel) then + ! + ! Store when the maximum water level changed + ! + if (store_t_zsmax) then + if (zs(nm) > zsmax(nm)) then + if ( (zs(nm) - zb(nm)) > huthresh) then + t_zsmax(nm) = t + endif + endif + endif ! - ! f = cos(y - 0.5*dy) / cos(y) (this holds both in northern and southern hemisphere) - ! - else + ! Store the maximum water level itself ! - zs(nm) = zs(nm) + ( (q(nmd) - q(nmu)) * dxrinv(z_flags_iref(nm)) + (q(ndm) - q(num)) * dyrinv(z_flags_iref(nm)) ) * dt + zsmax(nm) = max(zsmax(nm), zs(nm)) ! endif ! - endif + ! Reset qsrc to zero for the next time step + ! + qsrc(nm) = 0.0 + ! + enddo + !$omp end do + !$omp end parallel + !$acc end parallel + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine compute_water_levels_subgrid(dt,t) + ! + ! Advance z_volume(np) and zs(np) by dt on the subgrid-tables path. + ! Accumulates the cell volume change dvol from qsrc and the + ! horizontal flux divergence, routes excess volume through + ! storage_volume (when use_storage_volume is set), updates + ! z_volume, and recovers the new water level via subgrid table + ! interpolation. Also handles wavemaker cells (kcs == 4), the + ! snapwave-filtered zsm, and zsmax / t_zsmax accumulation. + ! + ! Called from: update_continuity (when subgrid is true). + ! + use sfincs_data + ! + implicit none + ! + real*4 :: dt + real*8 :: t + ! + integer :: nm + ! + integer :: iwm + ! + integer :: nmu + integer :: nmd + integer :: num + integer :: ndm + ! + real*4 :: factime + real*4 :: dvol + ! + real*4 :: qnmu + real*4 :: qnmd + real*4 :: qnum + real*4 :: qndm + ! + integer :: iuv + real*4 :: dzvol + real*4 :: facint + real*4 :: a + real*4 :: dv + real*4 :: zs00 + real*4 :: zs11 ! if (wavemaker) then - ! - if (kcs(nm) == 4) then + ! + factime = min(dt / wavemaker_filter_time, 1.0) + ! + endif + ! + !$omp parallel & + !$omp private ( dvol, nmd, nmu, ndm, num, a, iuv, facint, dzvol, iwm, & + !$omp qnmd, qnmu, qndm, qnum, dv, zs00, zs11 ) + !$omp do schedule ( dynamic, 256 ) + !$acc parallel present( kcs, zs, zs0, zb, z_volume, zsmax, zsm, maxzsm, zsderv, & + !$acc subgrid_z_zmin, subgrid_z_zmax, subgrid_z_dep, subgrid_z_volmax, & + !$acc prcp, q, qext, qinfmap, qdrain_rate, z_flags_iref, uv_flags_iref, & + !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & + !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & + !$acc z_index_wavemaker, wavemaker_uvmean, & + !$acc wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, storage_volume) + !$acc loop gang vector + do nm = 1, np + ! + ! And now water level changes due to horizontal fluxes + ! + dvol = 0.0 + ! + if (kcs(nm) == 1) then + ! + ! Apply cell-wise discharges qsrc (rivers, drainage structures, qext) + ! + if (qsrc(nm) /= 0.0) then + ! + dvol = dvol + qsrc(nm) * dt + ! + endif + ! + nmd = z_index_uv_md(nm) + nmu = z_index_uv_mu(nm) + ndm = z_index_uv_nd(nm) + num = z_index_uv_nu(nm) + ! + if (crsgeo) then + ! + ! dxm = size of cell in x - direction (it varies for all cells) + ! dyrm = size of cell in y - direction (it varies for all zoom levels) + ! + dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) - q(num)) * dxm(nm) ) * dt + ! + ! Should really be: + ! + ! dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) * f - q(num) / f) * dxm(nm) ) * dt + ! + ! where f if a correction factor for the ratio between cell width at cell centre and cell bottom: + ! + ! f = cos(y - 0.5*dy) / cos(y) (this holds both in northern and southern hemisphere) + ! + ! This assumes that we can use the same factor f for q(ndm) and q(num), i.e.: + ! + ! cos(y - 0.5*dy) / cos(y) ~= cos(y + 0.5*dy) / cos(y) or: cos(y - 0.5*dy) ~= cos(y + 0.5*dy) which is pretty much true for dy < 1.0 degree + ! + else + ! + if (use_quadtree) then + ! + ! dxrm = size of cell in x - direction (it varies for all zoom levels) + ! dyrm = size of cell in y - direction (it varies for all zoom levels) + ! + dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) - q(num)) * dxrm(z_flags_iref(nm)) ) * dt + ! + else + ! + dvol = dvol + ( (q(nmd) - q(nmu)) * dy + (q(ndm) - q(num)) * dx ) * dt + ! + endif + ! + endif + endif ! kcs==1 + ! + if (wavemaker .and. kcs(nm) == 4) then ! ! Wave maker point (seaward of wave maker) - ! Here we use the mean flux at the location of the wave maker + ! Here we use the mean flux at the location of the wave maker ! iwm = z_index_wavemaker(nm) ! @@ -204,7 +491,7 @@ subroutine compute_water_levels_regular(dt, t) ! qnmd = q(z_index_uv_md(nm)) ! - endif + endif ! if (wavemaker_nmu(iwm) > 0) then ! @@ -216,7 +503,7 @@ subroutine compute_water_levels_regular(dt, t) ! qnmu = q(z_index_uv_mu(nm)) ! - endif + endif ! if (wavemaker_ndm(iwm) > 0) then ! @@ -228,7 +515,7 @@ subroutine compute_water_levels_regular(dt, t) ! qndm = q(z_index_uv_nd(nm)) ! - endif + endif ! if (wavemaker_num(iwm) > 0) then ! @@ -240,478 +527,279 @@ subroutine compute_water_levels_regular(dt, t) ! qnum = q(z_index_uv_nu(nm)) ! - endif - ! - zs(nm) = zs(nm) + (((qnmd - qnmu) * dxrinv(z_flags_iref(nm)) + (qndm - qnum) * dyrinv(z_flags_iref(nm)))) * dt - ! - endif - ! - endif - ! - if (snapwave) then - ! - ! Time-averaged water level used for SnapWave using exponential filter - ! - ! Would double exponential filtering be better? - ! - zsm(nm) = factime * zs(nm) + (1.0 - factime) * zsm(nm) - ! - if (store_maximum_waterlevel) then - ! - maxzsm(nm) = max(maxzsm(nm), zsm(nm)) - ! - endif - ! - endif - ! - ! No continuity update but keeping track of variables - ! zsmax used by default, therefore keep in standard continuity loop: - ! - if (store_maximum_waterlevel) then - ! - ! Store when the maximum water level changed - ! - if (store_t_zsmax) then - if (zs(nm) > zsmax(nm)) then - if ( (zs(nm) - zb(nm)) > huthresh) then - t_zsmax(nm) = t - endif - endif - endif - ! - ! Store the maximum water level itself - ! - zsmax(nm) = max(zsmax(nm), zs(nm)) - ! - endif - ! - enddo - !$omp end do - !$omp end parallel - !$acc end parallel - ! - end subroutine - - - subroutine compute_water_levels_subgrid(dt,t) - ! - use sfincs_data - ! - implicit none - ! - real*4 :: dt - real*8 :: t - ! - integer :: nm - ! - integer :: iwm - ! - integer :: nmu - integer :: nmd - integer :: num - integer :: ndm - ! - real*4 :: factime - real*4 :: dvol - ! - real*4 :: qnmu - real*4 :: qnmd - real*4 :: qnum - real*4 :: qndm - ! - integer :: iuv - real*4 :: dzvol - real*4 :: facint - real*4 :: a - real*4 :: dv - real*4 :: zs00 - real*4 :: zs11 - ! - if (wavemaker) then - ! - factime = min(dt / wavemaker_filter_time, 1.0) - ! - endif - ! - !$omp parallel & - !$omp private ( dvol, nmd, nmu, ndm, num, a, iuv, facint, dzvol, iwm, & - !$omp qnmd, qnmu, qndm, qnum, dv, zs00, zs11 ) - !$omp do schedule ( dynamic, 256 ) - !$acc parallel present( kcs, zs, zs0, zb, z_volume, zsmax, zsm, maxzsm, zsderv, & - !$acc subgrid_z_zmin, subgrid_z_zmax, subgrid_z_dep, subgrid_z_volmax, & - !$acc prcp, q, qext, qinfmap, qdrain_rate, z_flags_iref, uv_flags_iref, & - !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & - !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & - !$acc z_index_wavemaker, wavemaker_uvmean, & - !$acc wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, storage_volume) - !$acc loop gang vector - do nm = 1, np - ! - ! And now water level changes due to horizontal fluxes - ! - dvol = 0.0 - ! - if (kcs(nm) == 1) then - ! - ! Apply cell-wise discharges qsrc (rivers, drainage structures, qext) - ! - if (qsrc(nm) /= 0.0) then + endif ! - dvol = dvol + qsrc(nm) * dt + if (use_quadtree) then + ! + dvol = dvol + ( (qnmd - qnmu) * dyrm(z_flags_iref(nm)) + (qndm - qnum) * dxrm(z_flags_iref(nm)) ) * dt + ! + else + ! + dvol = dvol + ( (qnmd - qnmu) * dy + (qndm - qnum) * dx ) * dt + ! + endif ! endif ! - nmd = z_index_uv_md(nm) - nmu = z_index_uv_mu(nm) - ndm = z_index_uv_nd(nm) - num = z_index_uv_nu(nm) + ! We got the volume change dvol in each active cell from fluxes + ! Now first add precip and qext + ! Then adjust for storage volume + ! Then update the volume and compute new water level ! - if (crsgeo) then - ! - ! dxm = size of cell in x - direction (it varies for all cells) - ! dyrm = size of cell in y - direction (it varies for all zoom levels) + if (kcs(nm) == 1 .or. kcs(nm) == 4) then ! - dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) - q(num)) * dxm(nm) ) * dt + ! Obtain cell area ! - ! Should really be: + if (crsgeo) then + ! + a = cell_area_m2(nm) + ! + else + ! + a = cell_area(z_flags_iref(nm)) + ! + endif ! - ! dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) * f - q(num) / f) * dxm(nm) ) * dt + ! C5. Storage volume ! - ! where f if a correction factor for the ratio between cell width at cell centre and cell bottom: + if (use_storage_volume) then + ! + ! If water enters the cell through a point discharge, it will NOT end up in storage volume ! + ! + if (storage_volume(nm) > 1.0e-6 .and. dvol > 0.0) then + ! + ! There is still some storage left, and water is entering the cell + ! + ! Compute remaining storage volume + ! + dv = storage_volume(nm) - dvol + ! + ! Update storage volume (it cannot become negative)) + ! + storage_volume(nm) = max(dv, 0.0) + ! + if (dv < 0.0) then + ! + ! Overshoot, so add remaining volume to z_volume + ! + dvol = - dv + ! + else + ! + ! Everything went into storage + ! + dvol = 0.0 + ! + endif + ! + endif + ! + endif ! - ! f = cos(y - 0.5*dy) / cos(y) (this holds both in northern and southern hemisphere) + ! Update volume ! - ! This assumes that we can use the same factor f for q(ndm) and q(num), i.e.: + z_volume(nm) = z_volume(nm) + dvol ! - ! cos(y - 0.5*dy) / cos(y) ~= cos(y + 0.5*dy) / cos(y) or: cos(y - 0.5*dy) ~= cos(y + 0.5*dy) which is pretty much true for dy < 1.0 degree + if (wiggle_suppression) then + ! + ! Store previous water level to determine gradient + ! + zs00 = zs0(nm) ! previous time step + zs11 = zs(nm) ! current time step before updating + zs0(nm) = zs11 ! next previous time step + ! + endif ! - else + ! Obtain new water level from subgrid tables ! - if (use_quadtree) then + if (z_volume(nm) >= subgrid_z_volmax(nm) * 0.999) then + ! + ! Entire cell is wet, no interpolation needed + ! + zs(nm) = max(subgrid_z_zmax(nm), -20.0) + (z_volume(nm) - subgrid_z_volmax(nm)) / a + ! + elseif (z_volume(nm) <= 1.0e-6) then + ! + ! No water in this cell. Set zs to z_zmin. + ! + zs(nm) = max(subgrid_z_zmin(nm), -20.0) ! - ! dxrm = size of cell in x - direction (it varies for all zoom levels) - ! dyrm = size of cell in y - direction (it varies for all zoom levels) - ! - dvol = dvol + ( (q(nmd) - q(nmu)) * dyrm(z_flags_iref(nm)) + (q(ndm) - q(num)) * dxrm(z_flags_iref(nm)) ) * dt - ! else - ! - dvol = dvol + ( (q(nmd) - q(nmu)) * dy + (q(ndm) - q(num)) * dx ) * dt - ! - endif - ! - endif - endif ! kcs==1 - ! - if (wavemaker .and. kcs(nm) == 4) then - ! - ! Wave maker point (seaward of wave maker) - ! Here we use the mean flux at the location of the wave maker - ! - iwm = z_index_wavemaker(nm) - ! - if (wavemaker_nmd(iwm) > 0) then - ! - ! Wave paddle on the left - ! - qnmd = wavemaker_uvmean(wavemaker_nmd(iwm)) + ! + ! Interpolation from subgrid tables needed. + ! + dzvol = subgrid_z_volmax(nm) / (subgrid_nlevels - 1) + iuv = int(z_volume(nm) / dzvol) + 1 + facint = (z_volume(nm) - (iuv - 1) * dzvol ) / dzvol + zs(nm) = subgrid_z_dep(iuv, nm) + (subgrid_z_dep(iuv + 1, nm) - subgrid_z_dep(iuv, nm)) * facint + ! + endif ! - else ! - qnmd = q(z_index_uv_md(nm)) + if (wiggle_suppression) then + ! + zsderv(nm) = zs(nm) - 2 * zs11 + zs00 + ! + endif ! - endif + endif ! - if (wavemaker_nmu(iwm) > 0) then + if (snapwave) then ! - ! Wave paddle on the right + ! Time-averaged water level used for SnapWave using exponential filter ! - qnmu = wavemaker_uvmean(wavemaker_nmu(iwm)) + ! Would double exponential filtering be better? ! - else + zsm(nm) = factime * zs(nm) + (1.0 - factime) * zsm(nm) ! - qnmu = q(z_index_uv_mu(nm)) + if (store_maximum_waterlevel) then + ! + maxzsm(nm) = max(maxzsm(nm), zsm(nm)) + ! + endif ! - endif + endif ! - if (wavemaker_ndm(iwm) > 0) then - ! - ! Wave paddle below - ! - qndm = wavemaker_uvmean(wavemaker_ndm(iwm)) - ! - else - ! - qndm = q(z_index_uv_nd(nm)) - ! - endif + ! No continuity update but keeping track of variables + ! zsmax used by default, therefore keep in standard continuity loop: ! - if (wavemaker_num(iwm) > 0) then + if (store_maximum_waterlevel) then ! - ! Wave paddle above + ! Store when the maximum water level changed ! - qnum = wavemaker_uvmean(wavemaker_num(iwm)) + if (store_t_zsmax) then + if (zs(nm) > zsmax(nm)) then + if ( (zs(nm) - subgrid_z_zmin(nm)) > huthresh) then + t_zsmax(nm) = t + endif + endif + endif ! - else + ! Store the maximum water level itself ! - qnum = q(z_index_uv_nu(nm)) + zsmax(nm) = max(zsmax(nm), zs(nm)) ! - endif + endif ! - if (use_quadtree) then - ! - dvol = dvol + ( (qnmd - qnmu) * dyrm(z_flags_iref(nm)) + (qndm - qnum) * dxrm(z_flags_iref(nm)) ) * dt - ! - else - ! - dvol = dvol + ( (qnmd - qnmu) * dy + (qndm - qnum) * dx ) * dt - ! - endif + ! Reset qsrc to zero for the next time step ! - endif + qsrc(nm) = 0.0 + ! + enddo + !$omp end do + !$omp end parallel ! - ! We got the volume change dvol in each active cell from fluxes - ! Now first add precip and qext - ! Then adjust for storage volume - ! Then update the volume and compute new water level + !$acc end parallel ! - if (kcs(nm) == 1 .or. kcs(nm) == 4) then + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine compute_store_variables(dt) + ! + ! Update the optional per-cell running diagnostics vmax, qmax and + ! twet from the edge-centred uv / q fields at the current step. + ! Cell-centred vmax / qmax are reconstructed as the 2D magnitude + ! of the mean of the four surrounding edge values. twet is the + ! cumulative time a cell has been wet above twet_threshold. Kept + ! in a separate routine to avoid the overhead when unused. + ! + ! Called from: update_continuity (only when any of + ! store_maximum_velocity, store_maximum_flux or store_twet is + ! enabled). + ! + use sfincs_data + ! + implicit none + ! + real*4 :: dt + ! + integer :: nm + ! + integer :: nmu + integer :: nmd + integer :: num + integer :: ndm + ! + real*4 :: quz + real*4 :: qvz + real*4 :: qz + real*4 :: uvz + ! + !$omp parallel & + !$omp private ( nmd, nmu, ndm, num, quz, qvz, qz, uvz ) + !$omp do schedule ( dynamic, 256 ) + !$acc parallel present( kcs, zs, zb, subgrid_z_zmin, q, uv, vmax, qmax, twet, & + !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu ) + !$acc loop gang vector + do nm = 1, np + ! + ! And now water level changes due to horizontal fluxes ! - ! Obtain cell area + qz = 0.0 + uvz = 0.0 ! - if (crsgeo) then + if (kcs(nm) == 1 .or. kcs(nm) == 4) then ! TL: kcs(nm)==4 also correct for regular? ! - a = cell_area_m2(nm) + ! Regular point with four surrounding cells of the same size ! - else + nmd = z_index_uv_md(nm) + nmu = z_index_uv_mu(nm) + ndm = z_index_uv_nd(nm) + num = z_index_uv_nu(nm) ! - a = cell_area(z_flags_iref(nm)) + if (store_maximum_velocity) then + quz = (uv(nmd) + uv(nmu)) / 2 + qvz = (uv(ndm) + uv(num)) / 2 + uvz = sqrt(quz**2 + qvz**2) + endif ! - endif - ! - ! C5. Storage volume - ! - if (use_storage_volume) then + if (store_maximum_flux) then + quz = (q(nmd) + q(nmu)) / 2 + qvz = (q(ndm) + q(num)) / 2 + qz = sqrt(quz**2 + qvz**2) + endif ! - ! If water enters the cell through a point discharge, it will NOT end up in storage volume ! - ! - if (storage_volume(nm) > 1.0e-6 .and. dvol > 0.0) then + ! No continuity update but keeping track of variables + ! 1. store vmax + if (store_maximum_velocity) then ! - ! There is still some storage left, and water is entering the cell + vmax(nm) = max(vmax(nm), uvz) ! - ! Compute remaining storage volume - ! - dv = storage_volume(nm) - dvol + endif + ! + ! 2. store qmax + if (store_maximum_flux) then ! - ! Update storage volume (it cannot become negative)) - ! - storage_volume(nm) = max(dv, 0.0) - ! - if (dv < 0.0) then - ! - ! Overshoot, so add remaining volume to z_volume - ! - dvol = - dv - ! - else - ! - ! Everything went into storage - ! - dvol = 0.0 - ! - endif + qmax(nm) = max(qmax(nm), qz) ! endif ! - endif - ! - ! Update volume - ! - z_volume(nm) = z_volume(nm) + dvol - ! - if (wiggle_suppression) then - ! - ! Store previous water level to determine gradient - ! - zs00 = zs0(nm) ! previous time step - zs11 = zs(nm) ! current time step before updating - zs0(nm) = zs11 ! next previous time step - ! - endif - ! - ! Obtain new water level from subgrid tables - ! - if (z_volume(nm) >= subgrid_z_volmax(nm) * 0.999) then - ! - ! Entire cell is wet, no interpolation needed - ! - zs(nm) = max(subgrid_z_zmax(nm), -20.0) + (z_volume(nm) - subgrid_z_volmax(nm)) / a - ! - elseif (z_volume(nm) <= 1.0e-6) then - ! - ! No water in this cell. Set zs to z_zmin. - ! - zs(nm) = max(subgrid_z_zmin(nm), -20.0) - ! - else - ! - ! Interpolation from subgrid tables needed. - ! - dzvol = subgrid_z_volmax(nm) / (subgrid_nlevels - 1) - iuv = int(z_volume(nm) / dzvol) + 1 - facint = (z_volume(nm) - (iuv - 1) * dzvol ) / dzvol - zs(nm) = subgrid_z_dep(iuv, nm) + (subgrid_z_dep(iuv + 1, nm) - subgrid_z_dep(iuv, nm)) * facint - ! - endif - ! - ! - if (wiggle_suppression) then - ! - zsderv(nm) = zs(nm) - 2 * zs11 + zs00 - ! - endif - ! - endif - ! - if (snapwave) then - ! - ! Time-averaged water level used for SnapWave using exponential filter - ! - ! Would double exponential filtering be better? - ! - zsm(nm) = factime * zs(nm) + (1.0 - factime) * zsm(nm) - ! - if (store_maximum_waterlevel) then - ! - maxzsm(nm) = max(maxzsm(nm), zsm(nm)) - ! - endif - ! - endif - ! - ! No continuity update but keeping track of variables - ! zsmax used by default, therefore keep in standard continuity loop: - ! - if (store_maximum_waterlevel) then - ! - ! Store when the maximum water level changed - ! - if (store_t_zsmax) then - if (zs(nm) > zsmax(nm)) then - if ( (zs(nm) - subgrid_z_zmin(nm)) > huthresh) then - t_zsmax(nm) = t + ! 3. store Twet + if (store_twet) then + if (subgrid) then + ! + if ( (zs(nm) - subgrid_z_zmin(nm)) > twet_threshold) then + twet(nm) = twet(nm) + dt + endif + ! + else + ! + if ( (zs(nm) - zb(nm)) > twet_threshold) then + ! + twet(nm) = twet(nm) + dt + ! endif - endif + ! + endif + endif + ! endif - ! - ! Store the maximum water level itself - ! - zsmax(nm) = max(zsmax(nm), zs(nm)) - ! - endif + enddo + !$omp end do + !$omp end parallel + !$acc end parallel ! - enddo - !$omp end do - !$omp end parallel - ! - !$acc end parallel - ! end subroutine - - subroutine compute_store_variables(dt) ! - use sfincs_data - ! - implicit none - ! - real*4 :: dt - ! - integer :: nm - ! - integer :: nmu - integer :: nmd - integer :: num - integer :: ndm - ! - real*4 :: quz - real*4 :: qvz - real*4 :: qz - real*4 :: uvz - ! - !$omp parallel & - !$omp private ( nmd, nmu, ndm, num, quz, qvz, qz, uvz ) - !$omp do schedule ( dynamic, 256 ) - !$acc parallel present( kcs, zs, zb, subgrid_z_zmin, q, uv, vmax, qmax, twet, & - !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu ) - !$acc loop gang vector - do nm = 1, np - ! - ! And now water level changes due to horizontal fluxes - ! - qz = 0.0 - uvz = 0.0 - ! - if (kcs(nm) == 1 .or. kcs(nm) == 4) then ! TL: kcs(nm)==4 also correct for regular? - ! - ! Regular point with four surrounding cells of the same size - ! - nmd = z_index_uv_md(nm) - nmu = z_index_uv_mu(nm) - ndm = z_index_uv_nd(nm) - num = z_index_uv_nu(nm) - ! - if (store_maximum_velocity) then - quz = (uv(nmd) + uv(nmu)) / 2 - qvz = (uv(ndm) + uv(num)) / 2 - uvz = sqrt(quz**2 + qvz**2) - endif - ! - if (store_maximum_flux) then - quz = (q(nmd) + q(nmu)) / 2 - qvz = (q(ndm) + q(num)) / 2 - qz = sqrt(quz**2 + qvz**2) - endif - ! - ! No continuity update but keeping track of variables - ! 1. store vmax - if (store_maximum_velocity) then - ! - vmax(nm) = max(vmax(nm), uvz) - ! - endif - ! - ! 2. store qmax - if (store_maximum_flux) then - ! - qmax(nm) = max(qmax(nm), qz) - ! - endif - ! - ! 3. store Twet - if (store_twet) then - if (subgrid) then - ! - if ( (zs(nm) - subgrid_z_zmin(nm)) > twet_threshold) then - twet(nm) = twet(nm) + dt - endif - ! - else - ! - if ( (zs(nm) - zb(nm)) > twet_threshold) then - ! - twet(nm) = twet(nm) + dt - ! - endif - ! - endif - endif - ! - endif - enddo - !$omp end do - !$omp end parallel - !$acc end parallel - ! - end subroutine - end module diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index 776802c51..d70398635 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -11,28 +11,29 @@ module sfincs_discharges ! live in sfincs_src_structures. The two modules no longer share any ! arrays -- they cooperate only by both writing into qsrc(np). ! - ! ----------------------------------------------------------------- - ! Subroutines in this module: + ! Subroutines: ! - ! initialize_discharges + ! initialize_discharges() ! Read srcfile/disfile (ascii) or netsrcdisfile (netcdf), resolve ! each source to its quadtree cell, and allocate runtime state. + ! Called from sfincs_lib at init time. ! - ! update_discharges + ! update_discharges(t, dt) ! Zero qsrc(np), interpolate the river discharge time series to the ! current time, and accumulate into qsrc at each source cell. + ! Called from update_continuity (sfincs_continuity) once per + ! time step, before update_src_structures. ! - ! count_tokens + ! count_tokens(line, ntok) ! Count whitespace-separated tokens in a string; used to decide ! between the 2-column (x y) and 3-column (x y name) src formats. - ! ----------------------------------------------------------------- + ! Called from initialize_discharges (this module). ! use sfincs_log use sfincs_error ! implicit none ! - ! ------------------------------------------------------------------ ! Module-level runtime state for river point discharges (moved from ! sfincs_data). The count, coordinate arrays, file-path strings, and ! qsrc_ts / tsrc / ntsrc stay in sfincs_data because they are also @@ -41,7 +42,6 @@ module sfincs_discharges ! ! Public so downstream output modules (sfincs_output, sfincs_ncoutput) ! and the openacc bookkeeping module can reference them. - ! ------------------------------------------------------------------ ! ! Name length (matches src_struc_name_len from sfincs_src_structures). ! @@ -59,331 +59,342 @@ module sfincs_discharges ! contains ! - subroutine initialize_discharges() - ! - ! Read the river-point-discharge input and wire each source up to a grid - ! cell. Two mutually-exclusive input paths: - ! - srcfile (+ disfile): ascii, 2-column (x y) or 3-column (x y name) - ! location file plus a separate time-series file. - ! - netsrcdisfile: FEWS-style netcdf with locations and time series - ! in one file (no per-point names; auto-generated). - ! Allocates nmindsrc(nr_discharge_points) and qtsrc(nr_discharge_points), - ! and populates shared tsrc/qsrc_ts arrays in sfincs_data. - ! Called once at init time. - ! - use sfincs_data - use sfincs_ncinput - use quadtree - ! - implicit none + !-----------------------------------------------------------------------------------------------------! ! - real*4 :: dummy - integer :: isrc, itsrc, nmq, n, stat, ntok - logical :: ok - character(len=1024) :: line, line_trim - character(len=src_name_len) :: name_tmp - ! - nr_discharge_points = 0 - ntsrc = 0 - itsrclast = 1 - ! - if (srcfile(1:4) /= 'none') then - ! - write(logstr,'(a)') 'Info : reading discharges' - call write_log(logstr, 0) - ! - ok = check_file_exists(srcfile, 'River input locations src file', .true.) - ! - open(500, file=trim(srcfile)) + subroutine initialize_discharges() ! - do while (.true.) - ! - read(500, *, iostat=stat) dummy - if (stat < 0) exit - nr_discharge_points = nr_discharge_points + 1 - ! - enddo + ! Read the river-point-discharge input and wire each source up to a grid + ! cell. Two mutually-exclusive input paths: + ! - srcfile (+ disfile): ascii, 2-column (x y) or 3-column (x y name) + ! location file plus a separate time-series file. + ! - netsrcdisfile: FEWS-style netcdf with locations and time series + ! in one file (no per-point names; auto-generated). + ! Allocates nmindsrc(nr_discharge_points) and qtsrc(nr_discharge_points), + ! and populates shared tsrc/qsrc_ts arrays in sfincs_data. ! - rewind(500) + ! Called from: sfincs_lib (once, at init time). ! - elseif (netsrcdisfile(1:4) /= 'none') then ! FEWS-compatible NetCDF discharge time series + use sfincs_data + use sfincs_ncinput + use quadtree ! - ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) + implicit none ! - call read_netcdf_discharge_data() ! sets nr_discharge_points, ntsrc, xsrc, ysrc, qsrc_ts, tsrc + real*4 :: dummy + integer :: isrc, itsrc, nmq, n, stat, ntok + logical :: ok + character(len=1024) :: line, line_trim + character(len=src_name_len) :: name_tmp ! - ! The netcdf discharge file does not carry per-point names; auto-generate - ! the same way as the 2-column srcfile path. + nr_discharge_points = 0 + ntsrc = 0 + itsrclast = 1 ! - if (nr_discharge_points > 0) then + if (srcfile(1:4) /= 'none') then ! - allocate(src_name(nr_discharge_points)) + write(logstr,'(a)') 'Info : reading discharges' + call write_log(logstr, 0) ! - src_name = ' ' + ok = check_file_exists(srcfile, 'River input locations src file', .true.) ! - do n = 1, nr_discharge_points + open(500, file=trim(srcfile)) + ! + do while (.true.) ! - write(src_name(n), '(a,i4.4)') 'discharge_', n + read(500, *, iostat=stat) dummy + if (stat < 0) exit + nr_discharge_points = nr_discharge_points + 1 ! enddo ! - endif - ! - if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then + rewind(500) ! - write(logstr,'(a)') ' WARNING! Times in discharge file do not cover entire simulation period!' - call write_log(logstr, 1) + elseif (netsrcdisfile(1:4) /= 'none') then ! FEWS-compatible NetCDF discharge time series ! - endif - ! - endif - ! - if (nr_discharge_points <= 0) return - ! - allocate(nmindsrc(nr_discharge_points)) - allocate(qtsrc(nr_discharge_points)) - ! - nmindsrc = 0 - qtsrc = 0.0 - ! - ! --- Read src/dis contents for the srcfile case --------------------- - ! - if (srcfile(1:4) /= 'none') then - ! - allocate(xsrc(nr_discharge_points)) - allocate(ysrc(nr_discharge_points)) - allocate(src_name(nr_discharge_points)) - ! - src_name = ' ' - ! - do n = 1, nr_discharge_points + ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) ! - read(500, '(a)') line - line_trim = adjustl(line) + call read_netcdf_discharge_data() ! sets nr_discharge_points, ntsrc, xsrc, ysrc, qsrc_ts, tsrc ! - ! Count whitespace-separated tokens on the line. + ! The netcdf discharge file does not carry per-point names; auto-generate + ! the same way as the 2-column srcfile path. ! - call count_tokens(line_trim, ntok) - ! - if (ntok == 2) then + if (nr_discharge_points > 0) then ! - read(line_trim, *) xsrc(n), ysrc(n) - write(src_name(n), '(a,i4.4)') 'discharge_', n + allocate(src_name(nr_discharge_points)) ! - elseif (ntok == 3) then + src_name = ' ' ! - read(line_trim, *) xsrc(n), ysrc(n), name_tmp - src_name(n) = adjustl(trim(name_tmp)) + do n = 1, nr_discharge_points + ! + write(src_name(n), '(a,i4.4)') 'discharge_', n + ! + enddo ! - else + endif + ! + if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then ! - write(logstr,'(a,i0,a,i0,a)') ' Error ! src file line ', n, ' has ', ntok, & - ' tokens -- expected 2 (x y) or 3 (x y name) !' + write(logstr,'(a)') ' WARNING! Times in discharge file do not cover entire simulation period!' call write_log(logstr, 1) - error = 1 - return ! endif ! - enddo + endif ! - close(500) + if (nr_discharge_points <= 0) return ! - ! Read discharge time series + allocate(nmindsrc(nr_discharge_points)) + allocate(qtsrc(nr_discharge_points)) ! - ok = check_file_exists(disfile, 'River discharge timeseries dis file', .true.) + nmindsrc = 0 + qtsrc = 0.0 ! - open(502, file=trim(disfile)) + ! Read src/dis contents for the srcfile case ! - do while (.true.) + if (srcfile(1:4) /= 'none') then ! - read(502, *, iostat=stat) dummy - if (stat < 0) exit - ntsrc = ntsrc + 1 + allocate(xsrc(nr_discharge_points)) + allocate(ysrc(nr_discharge_points)) + allocate(src_name(nr_discharge_points)) ! - enddo - ! - rewind(502) - allocate(tsrc(ntsrc)) - allocate(qsrc_ts(nr_discharge_points, ntsrc)) - ! - do itsrc = 1, ntsrc + src_name = ' ' ! - read(502, *) tsrc(itsrc), (qsrc_ts(isrc, itsrc), isrc = 1, nr_discharge_points) + do n = 1, nr_discharge_points + ! + read(500, '(a)') line + line_trim = adjustl(line) + ! + ! Count whitespace-separated tokens on the line. + ! + call count_tokens(line_trim, ntok) + ! + if (ntok == 2) then + ! + read(line_trim, *) xsrc(n), ysrc(n) + write(src_name(n), '(a,i4.4)') 'discharge_', n + ! + elseif (ntok == 3) then + ! + read(line_trim, *) xsrc(n), ysrc(n), name_tmp + src_name(n) = adjustl(trim(name_tmp)) + ! + else + ! + write(logstr,'(a,i0,a,i0,a)') ' Error ! src file line ', n, ' has ', ntok, & + ' tokens -- expected 2 (x y) or 3 (x y name) !' + call write_log(logstr, 1) + error = 1 + return + ! + endif + ! + enddo ! - enddo - ! - close(502) - ! - if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then + close(500) ! - write(logstr,'(a)') 'Warning! Times in discharge file do not cover entire simulation period !' - call write_log(logstr, 1) + ! Read discharge time series ! - if (tsrc(1) > (t0 + 1.0)) then + ok = check_file_exists(disfile, 'River discharge timeseries dis file', .true.) + ! + open(502, file=trim(disfile)) + ! + do while (.true.) ! - write(logstr,'(a)') 'Warning! Adjusting first time in discharge time series !' - call write_log(logstr, 1) - tsrc(1) = t0 - 1.0 + read(502, *, iostat=stat) dummy + if (stat < 0) exit + ntsrc = ntsrc + 1 ! - else + enddo + ! + rewind(502) + allocate(tsrc(ntsrc)) + allocate(qsrc_ts(nr_discharge_points, ntsrc)) + ! + do itsrc = 1, ntsrc ! - write(logstr,'(a)') 'Warning! Adjusting last time in discharge time series !' + read(502, *) tsrc(itsrc), (qsrc_ts(isrc, itsrc), isrc = 1, nr_discharge_points) + ! + enddo + ! + close(502) + ! + if ((tsrc(1) > (t0 + 1.0)) .or. (tsrc(ntsrc) < (t1 - 1.0))) then + ! + write(logstr,'(a)') 'Warning! Times in discharge file do not cover entire simulation period !' call write_log(logstr, 1) - tsrc(ntsrc) = t1 + 1.0 + ! + if (tsrc(1) > (t0 + 1.0)) then + ! + write(logstr,'(a)') 'Warning! Adjusting first time in discharge time series !' + call write_log(logstr, 1) + tsrc(1) = t0 - 1.0 + ! + else + ! + write(logstr,'(a)') 'Warning! Adjusting last time in discharge time series !' + call write_log(logstr, 1) + tsrc(ntsrc) = t1 + 1.0 + ! + endif ! endif ! endif ! - endif - ! - ! --- Map river sources to grid cells -------------------------------- - ! - do isrc = 1, nr_discharge_points + ! Map river sources to grid cells ! - nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) - ! - if (nmq > 0) then + do isrc = 1, nr_discharge_points ! - nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) + nmq = find_quadtree_cell(xsrc(isrc), ysrc(isrc)) ! - endif + if (nmq > 0) then + ! + nmindsrc(isrc) = index_sfincs_in_quadtree(nmq) + ! + endif + ! + enddo + ! + deallocate(xsrc) + deallocate(ysrc) ! - enddo - ! - deallocate(xsrc) - deallocate(ysrc) - ! end subroutine ! + !-----------------------------------------------------------------------------------------------------! ! subroutine update_discharges(t, dt) - ! - ! Zero qsrc(np); interpolate the river discharge time series to t, - ! store in qtsrc(1..nr_discharge_points), and accumulate into qsrc(nmindsrc(:)). - ! - ! update_discharges is called BEFORE update_src_structures -- that is - ! why it owns the qsrc zeroing. Both routines then additively write - ! their contributions. - ! - use sfincs_data - use sfincs_timers - ! - implicit none - ! - real*8 :: t - real*4 :: dt - ! - integer :: isrc, itsrc, nm, it_prev, it_next - real*4 :: wt - ! - call timer_start('Discharges') - ! - ! Zero qsrc for this step. sfincs_src_structures will add to it next. - ! - !$acc kernels present( qsrc ) - qsrc = 0.0 - !$acc end kernels - ! - if (nr_discharge_points > 0) then ! - ! Locate the bracketing interval in tsrc and compute the interpolation - ! weight once. Then run a single parallel loop that both interpolates - ! qtsrc and accumulates it into qsrc. + ! Zero qsrc(np); interpolate the river discharge time series to t, + ! store in qtsrc(1..nr_discharge_points), and accumulate into qsrc(nmindsrc(:)). ! - it_prev = itsrclast - it_next = itsrclast + 1 + ! update_discharges is called BEFORE update_src_structures -- that is + ! why it owns the qsrc zeroing. Both routines then additively write + ! their contributions. ! - do itsrc = itsrclast, ntsrc - ! - if (tsrc(itsrc) > t) then - ! - it_prev = itsrc - 1 - it_next = itsrc - itsrclast = it_prev - exit - ! - endif - ! - enddo + ! Called from: update_continuity (sfincs_continuity), once per time step. ! - ! Clamp to valid bracket. If t is outside [tsrc(1), tsrc(ntsrc)] (which - ! can happen on the netcdf path, where the srcfile pre-padding is not - ! applied), hold the endpoint value rather than read out of bounds. + use sfincs_data + use sfincs_timers ! - it_prev = min(max(it_prev, 1), ntsrc - 1) - it_next = it_prev + 1 + implicit none ! - wt = (t - tsrc(it_prev)) / (tsrc(it_next) - tsrc(it_prev)) + real*8 :: t + real*4 :: dt ! - ! Atomic accumulation because two river sources (or a river and a - ! structure) can share a cell. + integer :: isrc, itsrc, nm, it_prev, it_next + real*4 :: wt ! - !$acc parallel loop present( qsrc, qtsrc, nmindsrc, qsrc_ts ) private( nm ) - !$omp parallel do private( nm ) schedule ( static ) - do isrc = 1, nr_discharge_points + call timer_start('Discharges') + ! + ! Zero qsrc for this step. sfincs_src_structures will add to it next. + ! + !$acc kernels present( qsrc ) + qsrc = 0.0 + !$acc end kernels + ! + if (nr_discharge_points > 0) then ! - qtsrc(isrc) = qsrc_ts(isrc, it_prev) + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt - nm = nmindsrc(isrc) + ! Locate the bracketing interval in tsrc and compute the interpolation + ! weight once. Then run a single parallel loop that both interpolates + ! qtsrc and accumulates it into qsrc. ! - if (nm > 0) then + it_prev = itsrclast + it_next = itsrclast + 1 + ! + do itsrc = itsrclast, ntsrc ! - !$acc atomic update - !$omp atomic - qsrc(nm) = qsrc(nm) + qtsrc(isrc) + if (tsrc(itsrc) > t) then + ! + it_prev = itsrc - 1 + it_next = itsrc + itsrclast = it_prev + exit + ! + endif ! - endif + enddo ! - enddo - !$omp end parallel do - !$acc end parallel loop + ! Clamp to valid bracket. If t is outside [tsrc(1), tsrc(ntsrc)] (which + ! can happen on the netcdf path, where the srcfile pre-padding is not + ! applied), hold the endpoint value rather than read out of bounds. + ! + it_prev = min(max(it_prev, 1), ntsrc - 1) + it_next = it_prev + 1 + ! + wt = (t - tsrc(it_prev)) / (tsrc(it_next) - tsrc(it_prev)) + ! + ! Atomic accumulation because two river sources (or a river and a + ! structure) can share a cell. + ! + !$acc parallel loop present( qsrc, qtsrc, nmindsrc, qsrc_ts ) private( nm ) + !$omp parallel do private( nm ) schedule ( static ) + do isrc = 1, nr_discharge_points + ! + qtsrc(isrc) = qsrc_ts(isrc, it_prev) + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt + nm = nmindsrc(isrc) + ! + if (nm > 0) then + ! + !$acc atomic update + !$omp atomic + qsrc(nm) = qsrc(nm) + qtsrc(isrc) + ! + endif + ! + enddo + !$omp end parallel do + !$acc end parallel loop + ! + endif + ! + call timer_stop('Discharges') ! - endif - ! - call timer_stop('Discharges') - ! end subroutine ! - subroutine count_tokens(line, ntok) - ! - ! Count the number of whitespace-separated tokens in a string. - ! Whitespace = spaces and tabs. Empty string returns 0. - ! - implicit none - ! - character(len=*), intent(in) :: line - integer, intent(out) :: ntok - ! - integer :: i, n - logical :: in_tok - character(len=1) :: c - ! - ntok = 0 - in_tok = .false. - n = len_trim(line) + !-----------------------------------------------------------------------------------------------------! ! - do i = 1, n + subroutine count_tokens(line, ntok) ! - c = line(i:i) + ! Count the number of whitespace-separated tokens in a string. + ! Whitespace = spaces and tabs. Empty string returns 0. ! - if (c == ' ' .or. c == char(9)) then - ! - in_tok = .false. + ! Called from: initialize_discharges (this module) to disambiguate the + ! 2-column vs 3-column srcfile layout. + ! + implicit none + ! + character(len=*), intent(in) :: line + integer, intent(out) :: ntok + ! + integer :: i, n + logical :: in_tok + character(len=1) :: c + ! + ntok = 0 + in_tok = .false. + n = len_trim(line) + ! + do i = 1, n ! - else + c = line(i:i) ! - if (.not. in_tok) then + if (c == ' ' .or. c == char(9)) then + ! + in_tok = .false. + ! + else ! - ntok = ntok + 1 - in_tok = .true. + if (.not. in_tok) then + ! + ntok = ntok + 1 + in_tok = .true. + ! + endif ! endif ! - endif + enddo ! - enddo - ! end subroutine - + ! end module diff --git a/source/src/sfincs_log.f90 b/source/src/sfincs_log.f90 index 5f50ab23c..1ddc61dd7 100644 --- a/source/src/sfincs_log.f90 +++ b/source/src/sfincs_log.f90 @@ -368,8 +368,8 @@ subroutine write_timer_headers_log(to_screen) write(logstr, '(a,f10.3)') ' Total time : ', t_input + t_loop call write_log(trim(logstr), to_screen) ! - write(logstr, '(a,f10.3)') ' Total simulation time : ', t_loop - call write_log(trim(logstr), to_screen) +! write(logstr, '(a,f10.3)') ' Total simulation time : ', t_loop +! call write_log(trim(logstr), to_screen) ! write(logstr, '(a,f10.3)') ' Time in input : ', t_input call write_log(trim(logstr), to_screen) @@ -404,7 +404,6 @@ subroutine write_timer_summary_log(to_screen, total_wall, min_elapsed) integer :: i integer :: n integer :: ncalls - character(32) :: call_label character(32) :: tname character(256) :: line ! @@ -422,18 +421,15 @@ subroutine write_timer_summary_log(to_screen, total_wall, min_elapsed) ! if (t_el < min_elapsed) cycle ! + ! Skip input (was already added in header) + ! + if (trim(timer_name_by_index(i)) == 'Input') cycle + ! pct = 100.0_8 * t_el / denom - ncalls = timer_count_by_index(i) tname = timer_name_by_index(i) ! - if (ncalls == 1) then - write(call_label, '(i0,a)') ncalls, ' call' - else - write(call_label, '(i0,a)') ncalls, ' calls' - endif - ! write(line, '(1x,a,t25,a,f10.3,a,f5.1,a,a,a)') & - trim(tname), ': ', t_el, ' (', pct, '%, ', trim(call_label), ')' + trim(tname), ': ', t_el, ' (', pct, '%)' ! call write_log(trim(line), to_screen) ! diff --git a/source/src/sfincs_log.f90.reformatted b/source/src/sfincs_log.f90.reformatted new file mode 100644 index 000000000..b9052fec2 --- /dev/null +++ b/source/src/sfincs_log.f90.reformatted @@ -0,0 +1,298 @@ +module sfincs_log + ! + ! User-facing log / screen output for SFINCS. + ! + ! Core: + ! - open_log / close_log / write_log : file handle + line writer + ! + ! Formatted blocks (moved here from the former sfincs_screendump): + ! - write_startup_log : welcome banner + ASCII art + build info + ! - write_processes_log: yes/no "Processes" summary + ! - write_progress_log : per-timestep progress / ETA line + ! - write_finished_log : end-of-run banner + timer summary + + ! average time step + ! + integer :: fid + character(256) :: logstr + ! + ! Next percentage threshold at which the progress reporter prints a + ! line. Incremented in steps of percdoneval (set from the + ! 'percentage_done' input keyword). Zero-initialised so the first + ! call prints at 0%. + ! + real, save :: percdonenext = 0.0 + ! +contains + ! + subroutine open_log() + ! + implicit none + ! + fid = 777 + open(unit = fid, file = 'sfincs.log') + ! + end subroutine + ! + ! + subroutine write_log(str, to_screen) + ! + implicit none + ! + character(*), intent(in) :: str + integer, intent(in) :: to_screen + ! + write(fid,'(a)')trim(str) + ! + if (to_screen==1) then + write(*,'(a)')trim(str) + endif + ! + end subroutine + ! + ! + subroutine close_log() + ! + implicit none + ! + close(fid) + ! + end subroutine + ! + ! + subroutine write_startup_log() + ! + ! Welcome banner, ASCII logo and build-revision / build-date lines. + ! Called once at the start of sfincs_initialize, after build_revision + ! and build_date have been set in sfincs_data. + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------ Welcome to SFINCS ------------', 1) + call write_log('', 1) + call write_log(' @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ ', 1) + call write_log(' @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@', 1) + call write_log(' @@@ @@ @@ @@@ @@ @@ @@ @@@ ', 1) + call write_log(' @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ ', 1) + call write_log(' @@@ @@ @@ @@ @@@ @@ @@ @@@', 1) + call write_log(' @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@', 1) + call write_log(' @@@@@ @@ @@ @@ @ @@@@ @@@@@ ', 1) + call write_log('', 1) + call write_log(' .............. ', 1) + call write_log(' ......:@@@@@@@@:...... ', 1) + call write_log(' ..::::..@@........@@.:::::.. ', 1) + call write_log(' ..:::::..@@..::..::..@@.::::::.. ', 1) + call write_log(' .::::::..@@............@@.:::::::. ', 1) + call write_log(' .::::::..@@..............@@.:::::::. ', 1) + call write_log(' .::::::::..@@............@@..::::::::. ', 1) + call write_log(' .:::::::::...@@.@..@@..@.@@..::::::::::. ', 1) + call write_log(' .:::::::::...:@@@..@@..@@@:..:::::::::.. ', 1) + call write_log(' ............@@.@@..@@..@@.@@............ ', 1) + call write_log(' ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ ', 1) + call write_log(' .::::::::::@@..............@@.:::::::::. ', 1) + call write_log(' .......:.@@.....@.....@....@@.:....... ', 1) + call write_log(' .::....@@......@.@@@.@....@@.....::. ', 1) + call write_log(' .:::~@@.:...:.@@...@@.:.:.@@~::::. ', 1) + call write_log(' .::~@@@@@@@@@@.....@@@@@@@@@~::. ', 1) + call write_log(' ..:~~~~~~~:.......:~~~~~~~:.. ', 1) + call write_log(' ...................... ', 1) + call write_log(' .............. ', 1) + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('', 1) + call write_log('Build-Revision: '//trim(build_revision), 1) + call write_log('Build-Date: '//trim(build_date), 1) + call write_log('', 1) + ! + end subroutine write_startup_log + ! + ! + subroutine write_processes_log() + ! + ! "Processes" summary block listing which physical processes are + ! enabled for this run. Reads the process flags from sfincs_data. + ! + use sfincs_data + ! + implicit none + ! + call write_log('', 1) + call write_log('------------------------------------------', 1) + call write_log('Processes', 1) + call write_log('------------------------------------------', 1) + ! + if (subgrid) then + call write_log('Subgrid topography : yes', 1) + else + call write_log('Subgrid topography : no', 1) + endif + ! + if (use_quadtree) then + call write_log('Quadtree refinement : yes', 1) + else + call write_log('Quadtree refinement : no', 1) + endif + ! + if (advection) then + call write_log('Advection : yes', 1) + else + call write_log('Advection : no', 1) + endif + ! + if (viscosity) then + call write_log('Viscosity : yes', 1) + else + call write_log('Viscosity : no', 1) + endif + ! + if (coriolis) then + call write_log('Coriolis : yes', 1) + else + call write_log('Coriolis : no', 1) + endif + ! + if (wind) then + call write_log('Wind : yes', 1) + else + call write_log('Wind : no', 1) + endif + ! + if (patmos) then + call write_log('Atmospheric pressure : yes', 1) + else + call write_log('Atmospheric pressure : no', 1) + endif + ! + if (precip) then + call write_log('Precipitation : yes', 1) + else + call write_log('Precipitation : no', 1) + endif + ! + if (infiltration) then + call write_log('Infiltration : yes', 1) + else + call write_log('Infiltration : no', 1) + endif + ! + if (drainage) then + call write_log('Drainage : yes', 1) + else + call write_log('Drainage : no', 1) + endif + ! + if (snapwave) then + call write_log('SnapWave : yes', 1) + else + call write_log('SnapWave : no', 1) + endif + ! + if (wavemaker) then + call write_log('Wave paddles : yes', 1) + else + call write_log('Wave paddles : no', 1) + endif + ! + if (nonhydrostatic) then + call write_log('Non-hydrostatic : yes', 1) + else + ! call write_log('Non-hydrostatic : no', 1) + endif + ! + if (bathtub) then + call write_log('Bathtub : yes', 1) + else + ! call write_log('Bathtub : no', 1) + endif + ! + call write_log('------------------------------------------', 1) + call write_log('', 1) + ! + end subroutine write_processes_log + ! + ! + subroutine write_progress_log(t, t0, t1) + ! + ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s + ! remaining ..." line each time the simulated-time percentage + ! crosses the next percdoneval threshold. Remaining time is + ! estimated from the wall-clock elapsed in the 'Simulation loop' + ! timer. + ! + use sfincs_data, only: percdoneval + use sfincs_timers, only: timer_elapsed + ! + implicit none + ! + real*8, intent(in) :: t + real*4, intent(in) :: t0, t1 + ! + real :: percdone, trun, trem + character(len=256) :: logstr + ! + percdone = min(100.0 * (real(t, 4) - t0) / (t1 - t0), 100.0) + ! + if (percdone >= percdonenext) then + ! + ! percdoneval is increment of % to show to log, default=+5% + ! + percdonenext = 1.0 * (int(percdone) + percdoneval) + ! + trun = real(timer_elapsed('Simulation loop'), 4) + trem = trun / max(0.01*percdone, 1.0e-6) - trun + ! + if (int(percdone)>0) then + ! + write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, ',trem,' s remaining ...' + call write_log(logstr, 1) + ! + else + ! + write(logstr,'(i4,a,f7.1,a)')int(percdone),'% complete, - s remaining ...' + call write_log(logstr, 1) + ! + endif + ! + endif + ! + end subroutine write_progress_log + ! + ! + subroutine write_finished_log(dtavg) + ! + ! End-of-run log block: "Simulation finished" banner, per-phase + ! timer summary, and the average time step line. Called once from + ! sfincs_finalize, after the simulation loop has stopped and + ! dtavg has been averaged. + ! + use sfincs_timers, only: timer_write_headers, timer_write_summary, timer_elapsed + ! + implicit none + ! + real, intent(in) :: dtavg + ! + character(len=256) :: logstr + ! + call write_log('', 1) + call write_log('---------- Simulation finished -----------', 1) + call write_log('', 1) + ! + call timer_write_headers(1) + ! + ! Per-phase timing summary. Percentages are relative to the total + ! wall time of the simulation loop. + ! + call timer_write_summary(1, timer_elapsed('Simulation loop'), 0.0005_8) + ! + call write_log('', 1) + ! + write(logstr,'(a,20f10.3)') ' Average time step (s) : ', dtavg + call write_log(logstr, 1) + ! + call write_log('', 1) + ! + end subroutine write_finished_log + +end module diff --git a/source/src/sfincs_momentum.f90 b/source/src/sfincs_momentum.f90 index 949138096..f0f89f60b 100644 --- a/source/src/sfincs_momentum.f90 +++ b/source/src/sfincs_momentum.f90 @@ -729,6 +729,7 @@ subroutine compute_fluxes(dt) ! timestep_analysis_required_timestep(ip) = min_dt_ip ! + endif ! else diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index f684bd6ee..41d369dc0 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -24,44 +24,53 @@ module sfincs_src_structures ! Concurrency: qsrc updates use atomic because two structures (or a river ! source and a structure) can land in the same cell. ! - ! ----------------------------------------------------------------- - ! Subroutines in this module: + ! Subroutines: ! - ! initialize_src_structures + ! initialize_src_structures() ! Main entry point. Detects legacy vs TOML, dispatches through the ! TOML reader, flattens into src_struc_* arrays, resolves grid-cell ! indices, and seeds rule-driven gate statuses from the initial zs. + ! Called from sfincs_lib at init time. ! - ! update_src_structures - ! Called per time step. Advances the open/close state machine for - ! rule-driven structures, evaluates the per-type flux formula, and - ! accumulates signed discharges into qsrc and q_src_struc. + ! update_src_structures(t, dt) + ! Advances the open/close state machine for rule-driven structures, + ! evaluates the per-type flux formula, and accumulates signed + ! discharges into qsrc and q_src_struc. Called from update_continuity + ! (sfincs_continuity) once per time step, after update_discharges. ! - ! read_toml_src_structures + ! read_toml_src_structures(filename, structures, ierr) ! Parse a TOML drn file into an allocatable t_src_structure(:) array. ! Validates required per-type keys; returns ierr /= 0 on failure. + ! Called from initialize_src_structures (this module). ! - ! check_required + ! check_required(table, keys, seq_index, ierr) ! Helper for read_toml_src_structures: verifies that every key in a - ! required-key list is present in a given TOML table. + ! required-key list is present in a given TOML table. Called from + ! read_toml_src_structures (this module). ! - ! parse_structure_type + ! parse_structure_type(str, code, ierr) ! Translate a TOML "type" string to one of the structure_* codes. + ! Called from read_toml_src_structures (this module). ! - ! parse_direction + ! parse_direction(str, code, ierr) ! Translate a TOML "direction" string to one of the direction_* codes. + ! Called from read_toml_src_structures (this module). ! - ! to_lower - ! Return a lowercase copy of a string (ASCII). + ! to_lower(str) result(lower) + ! Return a lowercase copy of a string (ASCII). Called from + ! parse_structure_type, parse_direction, and convert_legacy_to_toml + ! (all in this module). ! - ! write_src_structures_log_summary + ! write_src_structures_log_summary() ! Emit a one-block-per-structure human-readable description to the - ! log file; called once at init time after marshalling. + ! log file; called from initialize_src_structures (this module) once + ! at init time after marshalling. ! - ! convert_legacy_to_toml + ! convert_legacy_to_toml(legacy_path, toml_path, ierr) ! Transcribe a legacy fixed-column .drn file into a TOML sibling so - ! the downstream code only has to consume the TOML schema. - ! ----------------------------------------------------------------- + ! the downstream code only has to consume the TOML schema. Called + ! from initialize_src_structures (this module) when the drn file + ! fails TOML probing. ! use sfincs_log use sfincs_error @@ -71,9 +80,7 @@ module sfincs_src_structures private :: convert_legacy_to_toml private :: write_src_structures_log_summary ! - ! ------------------------------------------------------------------ ! Structure type codes - ! ------------------------------------------------------------------ ! integer, parameter :: structure_pump = 1 integer, parameter :: structure_culvert_simple = 3 @@ -87,15 +94,12 @@ module sfincs_src_structures integer, parameter :: direction_positive = 2 integer, parameter :: direction_negative = 3 ! - ! ------------------------------------------------------------------ ! Pump reduction curve depth (m). Pump discharge is scaled by ! min(1, h_up/reduction_depth) so the pump cannot pump the intake ! cell dry. Fixed constant, not user-tunable. - ! ------------------------------------------------------------------ ! real*4, parameter :: reduction_depth = 0.1 ! - ! ------------------------------------------------------------------ ! Derived type for the TOML-based src structure input. ! ! Gate open/close triggers are described by small boolean expressions @@ -103,7 +107,6 @@ module sfincs_src_structures ! live here as raw characters on the derived type; the parser runs ! during marshalling and emits bytecode into the shared rule_* ! streams owned by the sfincs_rule_expression module. - ! ------------------------------------------------------------------ ! type :: t_src_structure ! @@ -170,21 +173,17 @@ module sfincs_src_structures ! end type t_src_structure ! - ! ------------------------------------------------------------------ ! Module-level storage for structures parsed from a TOML input file. ! Populated by the dispatcher and flattened into the flat arrays below ! by the marshal. - ! ------------------------------------------------------------------ ! type(t_src_structure), allocatable :: src_structures(:) ! intermediate derived-type array; flattened + deallocated by marshal_src_structures_to_flat_arrays on the toml path (gpu deep-copy avoidance). ! - ! ------------------------------------------------------------------ ! Module-level runtime state for src structures (moved from sfincs_data). ! Populated by the legacy reader or by marshal_src_structures_to_flat_arrays ! from the TOML path; consumed by update_src_structures and the his output. ! Public so downstream modules (sfincs_openacc, sfincs_output, sfincs_ncoutput, ! sfincs_lib) can reference them. - ! ------------------------------------------------------------------ ! ! Meta / name ! @@ -243,13 +242,11 @@ module sfincs_src_structures ! real*4, dimension(:), allocatable, public :: q_src_struc ! (nr_src_structures) signed discharge per structure, mirrors the qsrc pattern ! - ! ------------------------------------------------------------------ ! Per-structure rule ids into the registry owned by sfincs_rule_expression. ! A rule_id of 0 means "no rule; never fires". ! ! src_struc_rule_open_src / src_struc_rule_close_src hold the raw source strings ! (for log emission only); these do not need to travel to GPU. - ! ------------------------------------------------------------------ ! integer, dimension(:), allocatable, public :: src_struc_rule_open ! (nr_src_structures) rule_id for open action, 0 = no rule integer, dimension(:), allocatable, public :: src_struc_rule_close ! (nr_src_structures) rule_id for close action, 0 = no rule @@ -260,1168 +257,1026 @@ module sfincs_src_structures ! contains ! - subroutine initialize_src_structures() - ! - ! Dispatcher for the src_structures / drainage input file. - ! - ! Probes the file with toml-f. If it parses as TOML, the TOML reader - ! populates the module-level src_structures(:) array. If toml-f rejects - ! it, the file is assumed to be in the legacy fixed-column format and - ! is transcribed on-the-fly into a TOML sibling file, which is then - ! read via the same TOML path. This keeps only one parser alive in the - ! source tree. - ! - ! If a file parses as TOML but fails semantic validation (e.g. a - ! missing required field), that is treated as a hard error. - ! - ! After parsing, the derived-type src_structures(:) array is flattened - ! into the src_struc_* 1D arrays (the runtime's sole state representation), - ! grid-cell indices and distances are resolved, a descriptive block is - ! written to the log, and gate statuses are seeded from the initial - ! water-level field. - ! - use sfincs_data - use quadtree - use tomlf, only : toml_table, toml_error, toml_load - ! - implicit none - ! - ! Dispatcher locals - ! - type(toml_table), allocatable :: probe_top - type(toml_error), allocatable :: probe_err - integer :: ierr_toml, ierr_conv - logical :: ok, is_toml - character(len=512) :: toml_path - ! - ! Marshal locals - ! - integer :: i, ierr_parse - character(len=256) :: errmsg - ! - ! Cell-index / distance locals - ! - integer :: istruc, nmq - real*4 :: xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp - ! - ! Gate-status seeding locals - ! - integer :: nm1, nm2 - real :: z1, z2 - logical :: open_fires, close_fires - character(len=16) :: status_str - ! - if (drnfile(1:4) == 'none') return + !-----------------------------------------------------------------------------------------------------! ! - ! ------------------------------------------------------------------ - ! Existence check - ! ------------------------------------------------------------------ - ! - ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) - ! - ! ------------------------------------------------------------------ - ! Probe TOML / convert legacy / re-read TOML - ! - ! Probe: try to parse as TOML. This is a cheap check; on success we - ! discard the probe table and let read_toml_src_structures re-parse, - ! which keeps the two code paths decoupled. - ! ------------------------------------------------------------------ - ! - call toml_load(probe_top, drnfile, error=probe_err) - ! - is_toml = .not. allocated(probe_err) - ! - if (allocated(probe_err)) deallocate(probe_err) - if (allocated(probe_top)) deallocate(probe_top) - ! - if (is_toml) then + subroutine initialize_src_structures() ! - ! TOML path: read drnfile directly. + ! Dispatcher for the src_structures / drainage input file. ! - toml_path = drnfile + ! Probes the file with toml-f. If it parses as TOML, the TOML reader + ! populates the module-level src_structures(:) array. If toml-f rejects + ! it, the file is assumed to be in the legacy fixed-column format and + ! is transcribed on-the-fly into a TOML sibling file, which is then + ! read via the same TOML path. This keeps only one parser alive in the + ! source tree. ! - else + ! If a file parses as TOML but fails semantic validation (e.g. a + ! missing required field), that is treated as a hard error. ! - ! Legacy path: transcribe to a TOML sibling file, then fall through - ! to the TOML reader. The converter derives its own output path from - ! drnfile. + ! After parsing, the derived-type src_structures(:) array is flattened + ! into the src_struc_* 1D arrays (the runtime's sole state representation), + ! grid-cell indices and distances are resolved, a descriptive block is + ! written to the log, and gate statuses are seeded from the initial + ! water-level field. ! - call convert_legacy_to_toml(drnfile, toml_path, ierr_conv) + ! Called from: sfincs_lib (once, at init time). ! - if (ierr_conv /= 0) then - ! - write(logstr,'(a,a,a)')' Error ! Failed to convert legacy drn file "', trim(drnfile), & - '" to TOML; see preceding log entries for the reason' - call stop_sfincs(trim(logstr), -1) - ! - endif + use sfincs_data + use quadtree + use tomlf, only : toml_table, toml_error, toml_load ! - endif - ! - call read_toml_src_structures(trim(toml_path), src_structures, ierr_toml) - ! - if (ierr_toml /= 0) then + implicit none ! - write(logstr,'(a,a,a)')' Error ! Failed to load TOML src_structures file ', trim(toml_path), ' !' - call stop_sfincs(trim(logstr), -1) + ! Dispatcher locals ! - endif - ! - ! ------------------------------------------------------------------ - ! Marshal src_structures(:) -> src_struc_* flat arrays. - ! - ! The runtime reads all src-structure state from flat per-struct - ! arrays (the src_struc_* family: src_struc_type, src_struc_q, src_struc_flow_coef, ...). - ! The TOML reader, however, naturally produces a derived-type array - ! src_structures(:) of t_src_structure, which carries allocatable - ! components: character(len=:), allocatable :: name, plus the rule - ! expression strings. - ! - ! nvfortran's openacc implicit deep-copy of derived types that - ! contain allocatable components has been unreliable in practice: - ! pushing a type(...), allocatable :: arr(:) with nested allocatables - ! to the device tends to produce runtime issues. Flat arrays of - ! primitive types (real, integer, fixed-length character) copy - ! cleanly across !$acc enter data copyin(...), so we keep the live - ! runtime state in those. - ! - ! The marshal is the one-shot bridge: toml -> src_structures(:) - ! -> src_struc_* flat arrays -> deallocate(src_structures). After it - ! runs, nothing of the derived-type array survives, so no gpu - ! region ever sees a problematic allocatable-in-derived-type. - ! ------------------------------------------------------------------ - ! - if (.not. allocated(src_structures)) then + type(toml_table), allocatable :: probe_top + type(toml_error), allocatable :: probe_err + integer :: ierr_toml, ierr_conv + logical :: ok, is_toml + character(len=512) :: toml_path ! - nr_src_structures = 0 + ! Marshal locals ! - call write_src_structures_log_summary() + integer :: i, ierr_parse + character(len=256) :: errmsg ! - return + ! Cell-index / distance locals ! - endif - ! - nr_src_structures = size(src_structures) - ! - if (nr_src_structures <= 0) then + integer :: istruc, nmq + real*4 :: xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp ! - deallocate(src_structures) + ! Gate-status seeding locals ! - call write_src_structures_log_summary() + integer :: nm1, nm2 + real :: z1, z2 + logical :: open_fires, close_fires + character(len=16) :: status_str ! - return - ! - endif - ! - ! ------------------------------------------------------------------ - ! Allocate flat arrays to size nr_src_structures and seed defaults. - ! ------------------------------------------------------------------ - ! - allocate(src_struc_nm_in(nr_src_structures)) - allocate(src_struc_nm_out(nr_src_structures)) - allocate(src_struc_nm_obs_1(nr_src_structures)) - allocate(src_struc_nm_obs_2(nr_src_structures)) - allocate(q_src_struc(nr_src_structures)) - allocate(src_struc_type(nr_src_structures)) - allocate(src_struc_direction(nr_src_structures)) - allocate(src_struc_distance(nr_src_structures)) - allocate(src_struc_status(nr_src_structures)) - allocate(src_struc_fraction_open(nr_src_structures)) - allocate(src_struc_t_state(nr_src_structures)) - allocate(src_struc_name(nr_src_structures)) - allocate(src_struc_src_1_x(nr_src_structures)) - allocate(src_struc_src_1_y(nr_src_structures)) - allocate(src_struc_src_2_x(nr_src_structures)) - allocate(src_struc_src_2_y(nr_src_structures)) - allocate(src_struc_obs_1_x(nr_src_structures)) - allocate(src_struc_obs_1_y(nr_src_structures)) - allocate(src_struc_obs_2_x(nr_src_structures)) - allocate(src_struc_obs_2_y(nr_src_structures)) - allocate(src_struc_q(nr_src_structures)) - allocate(src_struc_flow_coef(nr_src_structures)) - allocate(src_struc_width(nr_src_structures)) - allocate(src_struc_sill_elevation(nr_src_structures)) - allocate(src_struc_mannings_n(nr_src_structures)) - allocate(src_struc_opening_duration(nr_src_structures)) - allocate(src_struc_closing_duration(nr_src_structures)) - allocate(src_struc_height(nr_src_structures)) - allocate(src_struc_invert_1(nr_src_structures)) - allocate(src_struc_invert_2(nr_src_structures)) - allocate(src_struc_submergence_ratio(nr_src_structures)) - allocate(src_struc_rule_open(nr_src_structures)) - allocate(src_struc_rule_close(nr_src_structures)) - allocate(src_struc_rule_open_src(nr_src_structures)) - allocate(src_struc_rule_close_src(nr_src_structures)) - ! - src_struc_rule_open = 0 - src_struc_rule_close = 0 - src_struc_rule_open_src = ' ' - src_struc_rule_close_src = ' ' - ! - src_struc_nm_in = 0 - src_struc_nm_out = 0 - src_struc_nm_obs_1 = 0 - src_struc_nm_obs_2 = 0 - q_src_struc = 0.0 - src_struc_type = 0 - src_struc_direction = direction_both - src_struc_distance = 0.0 - src_struc_fraction_open = 1.0 ! default "fully open": structures without rules bypass the state machine and use this as a no-op multiplier in the common-tail scaling - src_struc_status = 1 ! 0=closed, 1=open, 2=opening, 3=closing; default open (see above). Rule-driven structures overwrite this in the init-time seeding below. - src_struc_t_state = 0.0 - src_struc_name = ' ' - src_struc_src_1_x = 0.0 - src_struc_src_1_y = 0.0 - src_struc_src_2_x = 0.0 - src_struc_src_2_y = 0.0 - src_struc_obs_1_x = 0.0 - src_struc_obs_1_y = 0.0 - src_struc_obs_2_x = 0.0 - src_struc_obs_2_y = 0.0 - src_struc_q = 0.0 - src_struc_flow_coef = 1.0 - src_struc_width = 0.0 - src_struc_sill_elevation = 0.0 - src_struc_mannings_n = 0.024 - src_struc_opening_duration = 600.0 - src_struc_closing_duration = 600.0 - src_struc_height = 0.0 - src_struc_invert_1 = 0.0 - src_struc_invert_2 = 0.0 - src_struc_submergence_ratio = 0.667 - ! - ! ------------------------------------------------------------------ - ! Copy scalar / coord / string / parameter fields from src_structures(:) - ! into the flat arrays, and parse rule source strings via add_rule. - ! ------------------------------------------------------------------ - ! - do i = 1, nr_src_structures - ! - ! String fields: truncation warning if longer than src_struc_name_len. - ! - if (allocated(src_structures(i)%name)) then - ! - if (len(src_structures(i)%name) > src_struc_name_len) then - ! - write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure name length > ', src_struc_name_len, & - ' at entry ', i, '; truncating' - call write_log(logstr, 0) + if (drnfile(1:4) == 'none') return + ! + ! Existence check + ! + ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) + ! + ! Probe TOML / convert legacy / re-read TOML + ! + ! Probe: try to parse as TOML. This is a cheap check; on success we + ! discard the probe table and let read_toml_src_structures re-parse, + ! which keeps the two code paths decoupled. + ! + call toml_load(probe_top, drnfile, error=probe_err) + ! + is_toml = .not. allocated(probe_err) + ! + if (allocated(probe_err)) deallocate(probe_err) + if (allocated(probe_top)) deallocate(probe_top) + ! + if (is_toml) then + ! + ! TOML path: read drnfile directly. + ! + toml_path = drnfile + ! + else + ! + ! Legacy path: transcribe to a TOML sibling file, then fall through + ! to the TOML reader. The converter derives its own output path from + ! drnfile. + ! + call convert_legacy_to_toml(drnfile, toml_path, ierr_conv) + ! + if (ierr_conv /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Failed to convert legacy drn file "', trim(drnfile), & + '" to TOML; see preceding log entries for the reason' + call stop_sfincs(trim(logstr), -1) ! endif ! - src_struc_name(i) = src_structures(i)%name + endif + ! + call read_toml_src_structures(trim(toml_path), src_structures, ierr_toml) + ! + if (ierr_toml /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Failed to load TOML src_structures file ', trim(toml_path), ' !' + call stop_sfincs(trim(logstr), -1) ! endif ! - src_struc_type(i) = int(src_structures(i)%structure_type, 1) - src_struc_direction(i) = src_structures(i)%direction + ! Marshal src_structures(:) -> src_struc_* flat arrays. ! - ! src_struc_status is runtime-only (not on the TOML type); leave it at - ! the default of 0 (closed) set above. + ! The runtime reads all src-structure state from flat per-struct + ! arrays (the src_struc_* family: src_struc_type, src_struc_q, src_struc_flow_coef, ...). + ! The TOML reader, however, naturally produces a derived-type array + ! src_structures(:) of t_src_structure, which carries allocatable + ! components: character(len=:), allocatable :: name, plus the rule + ! expression strings. ! - src_struc_src_1_x(i) = src_structures(i)%src_1_x - src_struc_src_1_y(i) = src_structures(i)%src_1_y - src_struc_src_2_x(i) = src_structures(i)%src_2_x - src_struc_src_2_y(i) = src_structures(i)%src_2_y + ! nvfortran's openacc implicit deep-copy of derived types that + ! contain allocatable components has been unreliable in practice: + ! pushing a type(...), allocatable :: arr(:) with nested allocatables + ! to the device tends to produce runtime issues. Flat arrays of + ! primitive types (real, integer, fixed-length character) copy + ! cleanly across !$acc enter data copyin(...), so we keep the live + ! runtime state in those. ! - ! obs_1 / obs_2 default to the corresponding src_* when the TOML - ! reader did not see the key (tracked via has_obs_1 / has_obs_2). - ! This lets 0.0 remain a legal coordinate value. + ! The marshal is the one-shot bridge: toml -> src_structures(:) + ! -> src_struc_* flat arrays -> deallocate(src_structures). After it + ! runs, nothing of the derived-type array survives, so no gpu + ! region ever sees a problematic allocatable-in-derived-type. ! - if (src_structures(i)%has_obs_1) then + if (.not. allocated(src_structures)) then ! - src_struc_obs_1_x(i) = src_structures(i)%obs_1_x - src_struc_obs_1_y(i) = src_structures(i)%obs_1_y + nr_src_structures = 0 ! - else + call write_src_structures_log_summary() ! - src_struc_obs_1_x(i) = src_structures(i)%src_1_x - src_struc_obs_1_y(i) = src_structures(i)%src_1_y + return ! endif ! - if (src_structures(i)%has_obs_2) then + nr_src_structures = size(src_structures) + ! + if (nr_src_structures <= 0) then ! - src_struc_obs_2_x(i) = src_structures(i)%obs_2_x - src_struc_obs_2_y(i) = src_structures(i)%obs_2_y + deallocate(src_structures) ! - else + call write_src_structures_log_summary() ! - src_struc_obs_2_x(i) = src_structures(i)%src_2_x - src_struc_obs_2_y(i) = src_structures(i)%src_2_y + return ! endif ! - src_struc_q(i) = src_structures(i)%q - src_struc_flow_coef(i) = src_structures(i)%flow_coef - src_struc_width(i) = src_structures(i)%width - src_struc_sill_elevation(i) = src_structures(i)%sill_elevation - src_struc_mannings_n(i) = src_structures(i)%mannings_n - src_struc_opening_duration(i) = src_structures(i)%opening_duration - src_struc_closing_duration(i) = src_structures(i)%closing_duration - src_struc_height(i) = src_structures(i)%height - src_struc_invert_1(i) = src_structures(i)%invert_1 - src_struc_invert_2(i) = src_structures(i)%invert_2 - src_struc_submergence_ratio(i) = src_structures(i)%submergence_ratio - ! - ! Parse rule expressions. Missing / empty strings leave the - ! rule_id at 0, which the evaluator interprets as "never fires". - ! Stash the source string for the init-time log summary. - ! - if (allocated(src_structures(i)%rule_open)) then + ! Allocate flat arrays to size nr_src_structures and seed defaults. + ! + allocate(src_struc_nm_in(nr_src_structures)) + allocate(src_struc_nm_out(nr_src_structures)) + allocate(src_struc_nm_obs_1(nr_src_structures)) + allocate(src_struc_nm_obs_2(nr_src_structures)) + allocate(q_src_struc(nr_src_structures)) + allocate(src_struc_type(nr_src_structures)) + allocate(src_struc_direction(nr_src_structures)) + allocate(src_struc_distance(nr_src_structures)) + allocate(src_struc_status(nr_src_structures)) + allocate(src_struc_fraction_open(nr_src_structures)) + allocate(src_struc_t_state(nr_src_structures)) + allocate(src_struc_name(nr_src_structures)) + allocate(src_struc_src_1_x(nr_src_structures)) + allocate(src_struc_src_1_y(nr_src_structures)) + allocate(src_struc_src_2_x(nr_src_structures)) + allocate(src_struc_src_2_y(nr_src_structures)) + allocate(src_struc_obs_1_x(nr_src_structures)) + allocate(src_struc_obs_1_y(nr_src_structures)) + allocate(src_struc_obs_2_x(nr_src_structures)) + allocate(src_struc_obs_2_y(nr_src_structures)) + allocate(src_struc_q(nr_src_structures)) + allocate(src_struc_flow_coef(nr_src_structures)) + allocate(src_struc_width(nr_src_structures)) + allocate(src_struc_sill_elevation(nr_src_structures)) + allocate(src_struc_mannings_n(nr_src_structures)) + allocate(src_struc_opening_duration(nr_src_structures)) + allocate(src_struc_closing_duration(nr_src_structures)) + allocate(src_struc_height(nr_src_structures)) + allocate(src_struc_invert_1(nr_src_structures)) + allocate(src_struc_invert_2(nr_src_structures)) + allocate(src_struc_submergence_ratio(nr_src_structures)) + allocate(src_struc_rule_open(nr_src_structures)) + allocate(src_struc_rule_close(nr_src_structures)) + allocate(src_struc_rule_open_src(nr_src_structures)) + allocate(src_struc_rule_close_src(nr_src_structures)) + ! + src_struc_rule_open = 0 + src_struc_rule_close = 0 + src_struc_rule_open_src = ' ' + src_struc_rule_close_src = ' ' + ! + src_struc_nm_in = 0 + src_struc_nm_out = 0 + src_struc_nm_obs_1 = 0 + src_struc_nm_obs_2 = 0 + q_src_struc = 0.0 + src_struc_type = 0 + src_struc_direction = direction_both + src_struc_distance = 0.0 + src_struc_fraction_open = 1.0 ! default "fully open": structures without rules bypass the state machine and use this as a no-op multiplier in the common-tail scaling + src_struc_status = 1 ! 0=closed, 1=open, 2=opening, 3=closing; default open (see above). Rule-driven structures overwrite this in the init-time seeding below. + src_struc_t_state = 0.0 + src_struc_name = ' ' + src_struc_src_1_x = 0.0 + src_struc_src_1_y = 0.0 + src_struc_src_2_x = 0.0 + src_struc_src_2_y = 0.0 + src_struc_obs_1_x = 0.0 + src_struc_obs_1_y = 0.0 + src_struc_obs_2_x = 0.0 + src_struc_obs_2_y = 0.0 + src_struc_q = 0.0 + src_struc_flow_coef = 1.0 + src_struc_width = 0.0 + src_struc_sill_elevation = 0.0 + src_struc_mannings_n = 0.024 + src_struc_opening_duration = 600.0 + src_struc_closing_duration = 600.0 + src_struc_height = 0.0 + src_struc_invert_1 = 0.0 + src_struc_invert_2 = 0.0 + src_struc_submergence_ratio = 0.667 + ! + ! Copy scalar / coord / string / parameter fields from src_structures(:) + ! into the flat arrays, and parse rule source strings via add_rule. + ! + do i = 1, nr_src_structures + ! + ! String fields: truncation warning if longer than src_struc_name_len. + ! + if (allocated(src_structures(i)%name)) then + ! + if (len(src_structures(i)%name) > src_struc_name_len) then + ! + write(logstr,'(a,i0,a,i0,a)')' Warning ! src_structure name length > ', src_struc_name_len, & + ' at entry ', i, '; truncating' + call write_log(logstr, 0) + ! + endif + ! + src_struc_name(i) = src_structures(i)%name + ! + endif ! - call add_rule(src_structures(i)%rule_open, & - src_struc_rule_open(i), ierr_parse, errmsg) + src_struc_type(i) = int(src_structures(i)%structure_type, 1) + src_struc_direction(i) = src_structures(i)%direction ! - if (ierr_parse /= 0) then + ! src_struc_status is runtime-only (not on the TOML type); leave it at + ! the default of 0 (closed) set above. + ! + src_struc_src_1_x(i) = src_structures(i)%src_1_x + src_struc_src_1_y(i) = src_structures(i)%src_1_y + src_struc_src_2_x(i) = src_structures(i)%src_2_x + src_struc_src_2_y(i) = src_structures(i)%src_2_y + ! + ! obs_1 / obs_2 default to the corresponding src_* when the TOML + ! reader did not see the key (tracked via has_obs_1 / has_obs_2). + ! This lets 0.0 remain a legal coordinate value. + ! + if (src_structures(i)%has_obs_1) then ! - write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & - '" rules_open parse failed: ', trim(errmsg) - call write_log(logstr, 1) - call stop_sfincs(trim(logstr), -1) + src_struc_obs_1_x(i) = src_structures(i)%obs_1_x + src_struc_obs_1_y(i) = src_structures(i)%obs_1_y + ! + else + ! + src_struc_obs_1_x(i) = src_structures(i)%src_1_x + src_struc_obs_1_y(i) = src_structures(i)%src_1_y ! endif ! - src_struc_rule_open_src(i) = src_structures(i)%rule_open + if (src_structures(i)%has_obs_2) then + ! + src_struc_obs_2_x(i) = src_structures(i)%obs_2_x + src_struc_obs_2_y(i) = src_structures(i)%obs_2_y + ! + else + ! + src_struc_obs_2_x(i) = src_structures(i)%src_2_x + src_struc_obs_2_y(i) = src_structures(i)%src_2_y + ! + endif ! - endif - ! - if (allocated(src_structures(i)%rule_close)) then + src_struc_q(i) = src_structures(i)%q + src_struc_flow_coef(i) = src_structures(i)%flow_coef + src_struc_width(i) = src_structures(i)%width + src_struc_sill_elevation(i) = src_structures(i)%sill_elevation + src_struc_mannings_n(i) = src_structures(i)%mannings_n + src_struc_opening_duration(i) = src_structures(i)%opening_duration + src_struc_closing_duration(i) = src_structures(i)%closing_duration + src_struc_height(i) = src_structures(i)%height + src_struc_invert_1(i) = src_structures(i)%invert_1 + src_struc_invert_2(i) = src_structures(i)%invert_2 + src_struc_submergence_ratio(i) = src_structures(i)%submergence_ratio ! - call add_rule(src_structures(i)%rule_close, & - src_struc_rule_close(i), ierr_parse, errmsg) + ! Parse rule expressions. Missing / empty strings leave the + ! rule_id at 0, which the evaluator interprets as "never fires". + ! Stash the source string for the init-time log summary. ! - if (ierr_parse /= 0) then + if (allocated(src_structures(i)%rule_open)) then ! - write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & - '" rules_close parse failed: ', trim(errmsg) - call write_log(logstr, 1) - call stop_sfincs(trim(logstr), -1) + call add_rule(src_structures(i)%rule_open, & + src_struc_rule_open(i), ierr_parse, errmsg) + ! + if (ierr_parse /= 0) then + ! + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & + '" rules_open parse failed: ', trim(errmsg) + call write_log(logstr, 1) + call stop_sfincs(trim(logstr), -1) + ! + endif + ! + src_struc_rule_open_src(i) = src_structures(i)%rule_open ! endif ! - src_struc_rule_close_src(i) = src_structures(i)%rule_close + if (allocated(src_structures(i)%rule_close)) then + ! + call add_rule(src_structures(i)%rule_close, & + src_struc_rule_close(i), ierr_parse, errmsg) + ! + if (ierr_parse /= 0) then + ! + write(logstr,'(a,a,a,a)')' Error ! src_structure "', trim(src_struc_name(i)), & + '" rules_close parse failed: ', trim(errmsg) + call write_log(logstr, 1) + call stop_sfincs(trim(logstr), -1) + ! + endif + ! + src_struc_rule_close_src(i) = src_structures(i)%rule_close + ! + endif ! - endif + enddo ! - enddo - ! - ! ------------------------------------------------------------------ - ! Shrink the shared rule bytecode stream to exactly the concatenated - ! length (also allocates zero-length arrays when no rules were seen). - ! ------------------------------------------------------------------ - ! - call finalize_rule_storage() - ! - ! ------------------------------------------------------------------ - ! Drop the derived-type array; flat arrays carry all runtime state now. - ! ------------------------------------------------------------------ - ! - deallocate(src_structures) - ! - ! ------------------------------------------------------------------ - ! Resolve cell-index lookups (src_struc_nm_in / _out / _obs_1 / _obs_2) - ! and centre-to-centre distance from coordinate pairs. - ! ------------------------------------------------------------------ - ! - do istruc = 1, nr_src_structures + ! Shrink the shared rule bytecode stream to exactly the concatenated + ! length (also allocates zero-length arrays when no rules were seen). ! - nmq = find_quadtree_cell(src_struc_src_1_x(istruc), src_struc_src_1_y(istruc)) - if (nmq > 0) src_struc_nm_in(istruc) = index_sfincs_in_quadtree(nmq) + call finalize_rule_storage() ! - nmq = find_quadtree_cell(src_struc_src_2_x(istruc), src_struc_src_2_y(istruc)) - if (nmq > 0) src_struc_nm_out(istruc) = index_sfincs_in_quadtree(nmq) + ! Drop the derived-type array; flat arrays carry all runtime state now. ! - ! obs cell indices feed the gate rule evaluator. The marshal has - ! already defaulted obs_*_x/y to src_*_x/y when the TOML reader - ! did not see the keys, so this lookup gives us obs_1 == src_1 - ! and obs_2 == src_2 for those cases without extra branching. + deallocate(src_structures) ! - nmq = find_quadtree_cell(src_struc_obs_1_x(istruc), src_struc_obs_1_y(istruc)) - if (nmq > 0) src_struc_nm_obs_1(istruc) = index_sfincs_in_quadtree(nmq) + ! Resolve cell-index lookups (src_struc_nm_in / _out / _obs_1 / _obs_2) + ! and centre-to-centre distance from coordinate pairs. ! - nmq = find_quadtree_cell(src_struc_obs_2_x(istruc), src_struc_obs_2_y(istruc)) - if (nmq > 0) src_struc_nm_obs_2(istruc) = index_sfincs_in_quadtree(nmq) + do istruc = 1, nr_src_structures + ! + nmq = find_quadtree_cell(src_struc_src_1_x(istruc), src_struc_src_1_y(istruc)) + if (nmq > 0) src_struc_nm_in(istruc) = index_sfincs_in_quadtree(nmq) + ! + nmq = find_quadtree_cell(src_struc_src_2_x(istruc), src_struc_src_2_y(istruc)) + if (nmq > 0) src_struc_nm_out(istruc) = index_sfincs_in_quadtree(nmq) + ! + ! obs cell indices feed the gate rule evaluator. The marshal has + ! already defaulted obs_*_x/y to src_*_x/y when the TOML reader + ! did not see the keys, so this lookup gives us obs_1 == src_1 + ! and obs_2 == src_2 for those cases without extra branching. + ! + nmq = find_quadtree_cell(src_struc_obs_1_x(istruc), src_struc_obs_1_y(istruc)) + if (nmq > 0) src_struc_nm_obs_1(istruc) = index_sfincs_in_quadtree(nmq) + ! + nmq = find_quadtree_cell(src_struc_obs_2_x(istruc), src_struc_obs_2_y(istruc)) + if (nmq > 0) src_struc_nm_obs_2(istruc) = index_sfincs_in_quadtree(nmq) + ! + if (src_struc_nm_in(istruc) > 0 .and. src_struc_nm_out(istruc) > 0) then + ! + xsnk_tmp = z_xz(src_struc_nm_in(istruc)) + ysnk_tmp = z_yz(src_struc_nm_in(istruc)) + xsrc_tmp = z_xz(src_struc_nm_out(istruc)) + ysrc_tmp = z_yz(src_struc_nm_out(istruc)) + src_struc_distance(istruc) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + ! + endif + ! + enddo ! - if (src_struc_nm_in(istruc) > 0 .and. src_struc_nm_out(istruc) > 0) then + if (any(src_struc_nm_in == 0) .or. any(src_struc_nm_out == 0)) then ! - xsnk_tmp = z_xz(src_struc_nm_in(istruc)) - ysnk_tmp = z_yz(src_struc_nm_in(istruc)) - xsrc_tmp = z_xz(src_struc_nm_out(istruc)) - ysrc_tmp = z_yz(src_struc_nm_out(istruc)) - src_struc_distance(istruc) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + write(logstr,'(a)') 'Warning ! For some sink/source drainage points no matching active grid cell was found!' + call write_log(logstr, 0) + write(logstr,'(a)') 'Warning ! These points will be skipped, please check your input!' + call write_log(logstr, 0) ! endif ! - enddo - ! - if (any(src_struc_nm_in == 0) .or. any(src_struc_nm_out == 0)) then - ! - write(logstr,'(a)') 'Warning ! For some sink/source drainage points no matching active grid cell was found!' - call write_log(logstr, 0) - write(logstr,'(a)') 'Warning ! These points will be skipped, please check your input!' - call write_log(logstr, 0) + ! Write the per-structure descriptive block to the log file. + ! Emitted before the gate-status seeding so the per-gate init status + ! lines trail the structure block they annotate. ! - endif - ! - ! ------------------------------------------------------------------ - ! Write the per-structure descriptive block to the log file. - ! Emitted before the gate-status seeding so the per-gate init status - ! lines trail the structure block they annotate. - ! ------------------------------------------------------------------ - ! - call write_src_structures_log_summary() - ! - ! ------------------------------------------------------------------ - ! Initial-status seeding for rule-driven structures. - ! - ! zs(:) has already been populated by initialize_domain -> initialize_hydro - ! -> set_initial_conditions by the time we get here, so obs-point lookups - ! against zs are valid. For structures with no rule expressions the defaults - ! assigned above (status=1=open, fraction_open=1.0) already encode "no-op": - ! the state machine is skipped at runtime and the common-tail scaling by - ! fraction_open is a 1.0 multiply. - ! - ! Status encoding: 0=closed, 1=open, 2=opening, 3=closing. - ! ------------------------------------------------------------------ - ! - do istruc = 1, nr_src_structures + call write_src_structures_log_summary() ! - ! Skip structures without rules - keep the "always open" defaults. + ! Initial-status seeding for rule-driven structures. ! - if (src_struc_rule_open(istruc) <= 0 .and. src_struc_rule_close(istruc) <= 0) cycle + ! zs(:) has already been populated by initialize_domain -> initialize_hydro + ! -> set_initial_conditions by the time we get here, so obs-point lookups + ! against zs are valid. For structures with no rule expressions the defaults + ! assigned above (status=1=open, fraction_open=1.0) already encode "no-op": + ! the state machine is skipped at runtime and the common-tail scaling by + ! fraction_open is a 1.0 multiply. ! - nm1 = src_struc_nm_obs_1(istruc) - nm2 = src_struc_nm_obs_2(istruc) + ! Status encoding: 0=closed, 1=open, 2=opening, 3=closing. ! - if (nm1 > 0) then - ! - z1 = real(zs(nm1), 4) + do istruc = 1, nr_src_structures ! - else - ! - z1 = 0.0 - ! - endif - ! - if (nm2 > 0) then + ! Skip structures without rules - keep the "always open" defaults. ! - z2 = real(zs(nm2), 4) + if (src_struc_rule_open(istruc) <= 0 .and. src_struc_rule_close(istruc) <= 0) cycle ! - else + nm1 = src_struc_nm_obs_1(istruc) + nm2 = src_struc_nm_obs_2(istruc) ! - z2 = 0.0 + if (nm1 > 0) then + ! + z1 = real(zs(nm1), 4) + ! + else + ! + z1 = 0.0 + ! + endif ! - endif - ! - open_fires = evaluate_rule(src_struc_rule_open(istruc), z1, z2) - close_fires = evaluate_rule(src_struc_rule_close(istruc), z1, z2) - ! - if (open_fires .and. .not. close_fires) then + if (nm2 > 0) then + ! + z2 = real(zs(nm2), 4) + ! + else + ! + z2 = 0.0 + ! + endif ! - src_struc_status(istruc) = 1 - src_struc_fraction_open(istruc) = 1.0 - status_str = 'open' + open_fires = evaluate_rule(src_struc_rule_open(istruc), z1, z2) + close_fires = evaluate_rule(src_struc_rule_close(istruc), z1, z2) ! - elseif (.not. open_fires .and. close_fires) then + if (open_fires .and. .not. close_fires) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + status_str = 'open' + ! + elseif (.not. open_fires .and. close_fires) then + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + elseif (open_fires .and. close_fires) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + status_str = 'open' + write(logstr,'(a,a,a,a)')'Warning ! structure ', trim(src_struc_name(istruc)), & + ': both open and close rules fire at init; keeping structure open' + call write_log(logstr, 0) + ! + else + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + status_str = 'closed' + ! + endif ! - src_struc_status(istruc) = 0 - src_struc_fraction_open(istruc) = 0.0 - status_str = 'closed' + ! Transition timer is only consulted after a transition triggers; + ! seed with t0 so the first rule-driven transition has a sane baseline. ! - elseif (open_fires .and. close_fires) then + src_struc_t_state(istruc) = t0 ! - src_struc_status(istruc) = 1 - src_struc_fraction_open(istruc) = 1.0 - status_str = 'open' - write(logstr,'(a,a,a,a)')'Warning ! structure ', trim(src_struc_name(istruc)), & - ': both open and close rules fire at init; keeping structure open' + write(logstr,'(a,a,a,a)')'structure ', trim(src_struc_name(istruc)), & + ' initialised status=', trim(status_str) call write_log(logstr, 0) ! - else - ! - src_struc_status(istruc) = 0 - src_struc_fraction_open(istruc) = 0.0 - status_str = 'closed' - ! - endif - ! - ! Transition timer is only consulted after a transition triggers; - ! seed with t0 so the first rule-driven transition has a sane baseline. - ! - src_struc_t_state(istruc) = t0 - ! - write(logstr,'(a,a,a,a)')'structure ', trim(src_struc_name(istruc)), & - ' initialised status=', trim(status_str) - call write_log(logstr, 0) + enddo ! - enddo - ! end subroutine ! + !-----------------------------------------------------------------------------------------------------! ! subroutine update_src_structures(t, dt) - ! - ! Compute discharges through each drainage structure, accumulate them - ! into qsrc(np) (intake: -qq, outfall: +qq), and store per-structure - ! signed discharge in q_src_struc(nr_src_structures) for his output. - ! - ! Called AFTER update_discharges, which zeros qsrc first. - ! - ! Atomic updates on qsrc(nm) guard against two structures (or a river - ! and a structure) writing to the same cell under parallel execution. - ! - use sfincs_data - use sfincs_timers - ! - implicit none - ! - real*8 :: t - real*4 :: dt - ! - integer :: istruc, nmin, nmout, nm_o1, nm_o2 - real*4 :: qq, elapsed, z1r, z2r - real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha - real*4 :: dh, a_eff - real*4 :: h_up, h_dn, qq_sign - logical :: open_fires, close_fires - ! - if (nr_src_structures <= 0) return - ! - call timer_start('Drainage structures') - ! - !$acc parallel loop present( z_volume, zs, zb, qsrc, q_src_struc, & - !$acc src_struc_nm_in, src_struc_nm_out, & - !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & - !$acc src_struc_type, src_struc_direction, & - !$acc src_struc_q, src_struc_flow_coef, & - !$acc src_struc_width, src_struc_sill_elevation, & - !$acc src_struc_mannings_n, & - !$acc src_struc_opening_duration, src_struc_closing_duration, & - !$acc src_struc_height, & - !$acc src_struc_invert_1, src_struc_invert_2, & - !$acc src_struc_submergence_ratio, & - !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, & - !$acc src_struc_t_state, & - !$acc src_struc_rule_open, src_struc_rule_close, & - !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, & - !$acc rule_start, rule_length ) & - !$acc private( nmin, nmout, nm_o1, nm_o2, qq, elapsed, & - !$acc z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & - !$acc dh, a_eff, & - !$acc h_up, h_dn, qq_sign, & - !$acc open_fires, close_fires ) - !$omp parallel do & - !$omp private( nmin, nmout, nm_o1, nm_o2, qq, elapsed, & - !$omp z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & - !$omp dh, a_eff, & - !$omp h_up, h_dn, qq_sign, & - !$omp open_fires, close_fires ) & - !$omp schedule ( static ) - do istruc = 1, nr_src_structures - ! - nmin = src_struc_nm_in(istruc) - nmout = src_struc_nm_out(istruc) - ! - if (nmin > 0 .and. nmout > 0) then - ! - ! --------------------------------------------------------------- - ! Open/close rule state machine (any structure type, any status). - ! - ! Only runs if the user provided at least one of rules_open / - ! rules_close. Structures without rules stay at the init-time - ! defaults (status=1=open, fraction_open=1.0), which turns the - ! common-tail scaling below into a no-op. - ! - ! Status codes: 0=closed, 1=open, 2=opening, 3=closing. - ! Transient states 2 and 3 advance purely on elapsed time so the - ! state machine cannot thrash; rule evaluation happens in the - ! terminal states 0 and 1 only. Obs points feed the rule inputs - ! and default to the src pair in the marshal. - ! --------------------------------------------------------------- - ! - if (src_struc_rule_open(istruc) > 0 .or. src_struc_rule_close(istruc) > 0) then - ! - nm_o1 = src_struc_nm_obs_1(istruc) - nm_o2 = src_struc_nm_obs_2(istruc) - ! - if (nm_o1 > 0) then - ! - z1r = real(zs(nm_o1), 4) - ! - else - ! - z1r = 0.0 + ! + ! Compute discharges through each drainage structure, accumulate them + ! into qsrc(np) (intake: -qq, outfall: +qq), and store per-structure + ! signed discharge in q_src_struc(nr_src_structures) for his output. + ! + ! Called AFTER update_discharges, which zeros qsrc first. + ! + ! Atomic updates on qsrc(nm) guard against two structures (or a river + ! and a structure) writing to the same cell under parallel execution. + ! + ! Called from: update_continuity (sfincs_continuity), once per time step. + ! + use sfincs_data + use sfincs_timers + ! + implicit none + ! + real*8 :: t + real*4 :: dt + ! + integer :: istruc, nmin, nmout, nm_o1, nm_o2 + real*4 :: qq, elapsed, z1r, z2r + real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha + real*4 :: dh, a_eff + real*4 :: h_up, h_dn, qq_sign + logical :: open_fires, close_fires + ! + if (nr_src_structures <= 0) return + ! + call timer_start('Drainage structures') + ! + !$acc parallel loop present( z_volume, zs, zb, qsrc, q_src_struc, & + !$acc src_struc_nm_in, src_struc_nm_out, & + !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & + !$acc src_struc_type, src_struc_direction, & + !$acc src_struc_q, src_struc_flow_coef, & + !$acc src_struc_width, src_struc_sill_elevation, & + !$acc src_struc_mannings_n, & + !$acc src_struc_opening_duration, src_struc_closing_duration, & + !$acc src_struc_height, & + !$acc src_struc_invert_1, src_struc_invert_2, & + !$acc src_struc_submergence_ratio, & + !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, & + !$acc src_struc_t_state, & + !$acc src_struc_rule_open, src_struc_rule_close, & + !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, & + !$acc rule_start, rule_length ) & + !$acc private( nmin, nmout, nm_o1, nm_o2, qq, elapsed, & + !$acc z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & + !$acc dh, a_eff, & + !$acc h_up, h_dn, qq_sign, & + !$acc open_fires, close_fires ) + !$omp parallel do & + !$omp private( nmin, nmout, nm_o1, nm_o2, qq, elapsed, & + !$omp z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & + !$omp dh, a_eff, & + !$omp h_up, h_dn, qq_sign, & + !$omp open_fires, close_fires ) & + !$omp schedule ( static ) + do istruc = 1, nr_src_structures + ! + nmin = src_struc_nm_in(istruc) + nmout = src_struc_nm_out(istruc) + ! + if (nmin > 0 .and. nmout > 0) then + ! + ! Open/close rule state machine (any structure type, any status). + ! + ! Only runs if the user provided at least one of rules_open / + ! rules_close. Structures without rules stay at the init-time + ! defaults (status=1=open, fraction_open=1.0), which turns the + ! common-tail scaling below into a no-op. + ! + ! Status codes: 0=closed, 1=open, 2=opening, 3=closing. + ! Transient states 2 and 3 advance purely on elapsed time so the + ! state machine cannot thrash; rule evaluation happens in the + ! terminal states 0 and 1 only. Obs points feed the rule inputs + ! and default to the src pair in the marshal. + ! + if (src_struc_rule_open(istruc) > 0 .or. src_struc_rule_close(istruc) > 0) then ! - endif - ! - if (nm_o2 > 0) then + nm_o1 = src_struc_nm_obs_1(istruc) + nm_o2 = src_struc_nm_obs_2(istruc) ! - z2r = real(zs(nm_o2), 4) + if (nm_o1 > 0) then + ! + z1r = real(zs(nm_o1), 4) + ! + else + ! + z1r = 0.0 + ! + endif ! - else + if (nm_o2 > 0) then + ! + z2r = real(zs(nm_o2), 4) + ! + else + ! + z2r = 0.0 + ! + endif ! - z2r = 0.0 + select case (int(src_struc_status(istruc))) + ! + case (0) + ! + ! closed - look for an open trigger + ! + open_fires = evaluate_rule(src_struc_rule_open(istruc), z1r, z2r) + ! + if (open_fires) then + ! + src_struc_status(istruc) = 2 + src_struc_t_state(istruc) = real(t, 4) + ! + endif + ! + case (1) + ! + ! open - look for a close trigger + ! + close_fires = evaluate_rule(src_struc_rule_close(istruc), z1r, z2r) + ! + if (close_fires) then + ! + src_struc_status(istruc) = 3 + src_struc_t_state(istruc) = real(t, 4) + ! + endif + ! + case (2) + ! + ! opening - advance on elapsed time; do not re-check rules + ! + elapsed = real(t, 4) - src_struc_t_state(istruc) + ! + if (src_struc_opening_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_opening_duration(istruc)) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + ! + else + ! + src_struc_fraction_open(istruc) = elapsed / src_struc_opening_duration(istruc) + ! + endif + ! + case (3) + ! + ! closing - advance on elapsed time; do not re-check rules + ! + elapsed = real(t, 4) - src_struc_t_state(istruc) + ! + if (src_struc_closing_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_closing_duration(istruc)) then + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + ! + else + ! + src_struc_fraction_open(istruc) = 1.0 - elapsed / src_struc_closing_duration(istruc) + ! + endif + ! + end select ! endif ! - select case (int(src_struc_status(istruc))) + ! Per-type flux formula. Produces a raw signed discharge qq in + ! m^3/s, before the common-tail scaling by fraction_open and + ! direction filter. + ! + select case(src_struc_type(istruc)) ! - case (0) + case(structure_pump) ! - ! closed - look for an open trigger + qq = src_struc_q(istruc) ! - open_fires = evaluate_rule(src_struc_rule_open(istruc), z1r, z2r) + ! Reduction curve: scale by upstream depth so the pump cannot + ! pump the intake cell dry. reduction_depth is a module-level + ! constant (see top of module); not user-tunable. ! - if (open_fires) then - ! - src_struc_status(istruc) = 2 - src_struc_t_state(istruc) = real(t, 4) - ! - endif + ! Turn this off for now. Does not work with subgrid. ! - case (1) + !h_up = max(real(zs(nmin), 4) - zb(nmin), 0.0) + !qq = qq * min(1.0, h_up / reduction_depth) ! - ! open - look for a close trigger + case(structure_culvert_simple) ! - close_fires = evaluate_rule(src_struc_rule_close(istruc), z1r, z2r) + ! Bidirectional: Q = flow_coef * sign(dh) * sqrt(|dh|). + ! The legacy "check_valve" alias maps to direction_positive + ! in the parser; the direction filter in the common tail + ! below restricts the allowed sign when requested. ! - if (close_fires) then + if (zs(nmin) > zs(nmout)) then + ! + qq = src_struc_flow_coef(istruc) * sqrt(zs(nmin) - zs(nmout)) + ! + else ! - src_struc_status(istruc) = 3 - src_struc_t_state(istruc) = real(t, 4) + qq = -src_struc_flow_coef(istruc) * sqrt(zs(nmout) - zs(nmin)) ! endif ! - case (2) + case(structure_gate) + ! + ! Bidirectional culvert-style flow. Flow uses the src pair + ! (nmin/nmout), not the obs pair. Bates et al. (2010) + ! inertial formulation, per unit width: + ! q^{n+1} = (q^n - g*h*(dzs/ds)*dt) / + ! (1 + g*n^2*dt*|q^n| / h^{7/3}) + ! with h = max(max(zs_in, zs_out) - zsill, 0). + ! Multiply by width to get the full structure discharge; + ! scaling by fraction_open happens in the common tail. + ! q_src_struc(istruc) holds the previous step's discharge + ! after the full common-tail scaling (width*fraction_open), + ! so unscale by (width*fraction_open) to recover qq0 in + ! per-unit-width form. Sign convention: qq > 0 means flow + ! nmin -> nmout, matching dzds = (zs_out - zs_in)/dist. ! - ! opening - advance on elapsed time; do not re-check rules + frac = src_struc_fraction_open(istruc) + wdt = src_struc_width(istruc) + mng = src_struc_mannings_n(istruc) + zsill = src_struc_sill_elevation(istruc) + dist = src_struc_distance(istruc) ! - elapsed = real(t, 4) - src_struc_t_state(istruc) + dzds = (real(zs(nmout), 4) - real(zs(nmin), 4)) / dist + hgate = max(max(real(zs(nmin), 4), real(zs(nmout), 4)) - zsill, 0.0) ! - if (src_struc_opening_duration(istruc) <= 0.0 .or. & - elapsed >= src_struc_opening_duration(istruc)) then + if (hgate > 0.0 .and. frac > 0.0) then ! - src_struc_status(istruc) = 1 - src_struc_fraction_open(istruc) = 1.0 + qq0 = q_src_struc(istruc) / (wdt * max(frac, 0.001)) + qq = (qq0 - g * hgate * dzds * dt) / & + (1.0 + g * mng * mng * dt * abs(qq0) / hgate**(7.0/3.0)) + qq = qq * wdt + qq = src_struc_flow_coef(istruc) * qq ! else ! - src_struc_fraction_open(istruc) = elapsed / src_struc_opening_duration(istruc) + qq = 0.0 ! endif ! - case (3) + case(structure_culvert) + ! + ! Regime-aware culvert. The controlling sill is the higher + ! of the two inverts (flow cannot pass until the upstream + ! water level reaches it). Upstream / downstream are picked + ! by the water-level difference, so the structure is + ! bidirectional and the direction filter in the common tail + ! below restricts the sign when requested. + ! + ! Two regimes, selected by h_dn/h_up against the user-set + ! submergence_ratio threshold (default 2/3 = 0.667, the + ! standard broad-crested-weir / Villemonte value): ! - ! closing - advance on elapsed time; do not re-check rules + ! submerged (h_dn/h_up >= threshold): + ! qq = flow_coef * a_eff * sqrt(2 g |dh|) + ! free / inlet-controlled (h_dn/h_up < threshold): + ! qq = flow_coef * a_eff * sqrt(2 g h_up) ! - elapsed = real(t, 4) - src_struc_t_state(istruc) + ! The flow area a_eff = width * min(h_up, height) caps at + ! the barrel height, so a deeply-submerged inlet can't + ! give unbounded discharge. + ! + zsill = max(src_struc_invert_1(istruc), src_struc_invert_2(istruc)) + ! + dh = real(zs(nmin), 4) - real(zs(nmout), 4) + ! + if (dh >= 0.0) then + ! + h_up = max(real(zs(nmin), 4) - zsill, 0.0) + h_dn = max(real(zs(nmout), 4) - zsill, 0.0) + qq_sign = 1.0 + ! + else + ! + h_up = max(real(zs(nmout), 4) - zsill, 0.0) + h_dn = max(real(zs(nmin), 4) - zsill, 0.0) + qq_sign = -1.0 + ! + endif ! - if (src_struc_closing_duration(istruc) <= 0.0 .or. & - elapsed >= src_struc_closing_duration(istruc)) then + if (h_up <= 0.0) then ! - src_struc_status(istruc) = 0 - src_struc_fraction_open(istruc) = 0.0 + qq = 0.0 ! else ! - src_struc_fraction_open(istruc) = 1.0 - elapsed / src_struc_closing_duration(istruc) + a_eff = src_struc_width(istruc) * min(h_up, src_struc_height(istruc)) + ! + if (h_dn / h_up >= src_struc_submergence_ratio(istruc)) then + ! + qq = qq_sign * src_struc_flow_coef(istruc) * a_eff * sqrt(2.0 * g * abs(dh)) + ! + else + ! + qq = qq_sign * src_struc_flow_coef(istruc) * a_eff * sqrt(2.0 * g * h_up) + ! + endif ! endif ! end select ! - endif - ! - ! --------------------------------------------------------------- - ! Per-type flux formula. Produces a raw signed discharge qq in - ! m^3/s, before the common-tail scaling by fraction_open and - ! direction filter. - ! --------------------------------------------------------------- - ! - select case(src_struc_type(istruc)) + ! Common tail: scale by fraction_open (state-machine output) and + ! apply the direction filter. Structures without rules sit at + ! fraction_open=1.0 so the scaling is a no-op; structures with + ! direction_both (the default) see the filter as a no-op too. ! - case(structure_pump) - ! - qq = src_struc_q(istruc) - ! - ! Reduction curve: scale by upstream depth so the pump cannot - ! pump the intake cell dry. reduction_depth is a module-level - ! constant (see top of module); not user-tunable. - ! - h_up = max(real(zs(nmin), 4) - zb(nmin), 0.0) - qq = qq * min(1.0, h_up / reduction_depth) - ! - case(structure_culvert_simple) - ! - ! Bidirectional: Q = flow_coef * sign(dh) * sqrt(|dh|). - ! The legacy "check_valve" alias maps to direction_positive - ! in the parser; the direction filter in the common tail - ! below restricts the allowed sign when requested. + qq = qq * src_struc_fraction_open(istruc) + ! + if (src_struc_direction(istruc) == direction_positive .and. qq < 0.0) qq = 0.0 + if (src_struc_direction(istruc) == direction_negative .and. qq > 0.0) qq = 0.0 + ! + ! Relaxation: blend new and previous discharge to damp oscillations. + ! structure_relax is a dimensionless step count: alpha = 1/N damps + ! the discharge response over roughly N time steps. Typical 1-10. + ! + alpha = 1.0 / structure_relax + qq = alpha * qq + (1.0 - alpha) * q_src_struc(istruc) + ! + ! Limit discharge by available volume in the intake / outfall cell. + ! + if (subgrid) then ! - if (zs(nmin) > zs(nmout)) then + if (qq > 0.0) then ! - qq = src_struc_flow_coef(istruc) * sqrt(zs(nmin) - zs(nmout)) + qq = min(qq, max(z_volume(nmin), 0.0) / dt) ! else ! - qq = -src_struc_flow_coef(istruc) * sqrt(zs(nmout) - zs(nmin)) + qq = max(qq, -max(z_volume(nmout), 0.0) / dt) ! endif ! - case(structure_gate) - ! - ! Bidirectional culvert-style flow. Flow uses the src pair - ! (nmin/nmout), not the obs pair. Bates et al. (2010) - ! inertial formulation, per unit width: - ! q^{n+1} = (q^n - g*h*(dzs/ds)*dt) / - ! (1 + g*n^2*dt*|q^n| / h^{7/3}) - ! with h = max(max(zs_in, zs_out) - zsill, 0). - ! Multiply by width to get the full structure discharge; - ! scaling by fraction_open happens in the common tail. - ! q_src_struc(istruc) holds the previous step's discharge - ! after the full common-tail scaling (width*fraction_open), - ! so unscale by (width*fraction_open) to recover qq0 in - ! per-unit-width form. Sign convention: qq > 0 means flow - ! nmin -> nmout, matching dzds = (zs_out - zs_in)/dist. - ! - frac = src_struc_fraction_open(istruc) - wdt = src_struc_width(istruc) - mng = src_struc_mannings_n(istruc) - zsill = src_struc_sill_elevation(istruc) - dist = src_struc_distance(istruc) - ! - dzds = (real(zs(nmout), 4) - real(zs(nmin), 4)) / dist - hgate = max(max(real(zs(nmin), 4), real(zs(nmout), 4)) - zsill, 0.0) - ! - if (hgate > 0.0 .and. frac > 0.0) then - ! - qq0 = q_src_struc(istruc) / (wdt * max(frac, 0.001)) - qq = (qq0 - g * hgate * dzds * dt) / & - (1.0 + g * mng * mng * dt * abs(qq0) / hgate**(7.0/3.0)) - qq = qq * wdt - qq = src_struc_flow_coef(istruc) * qq - ! - else - ! - qq = 0.0 - ! - endif - ! - case(structure_culvert) - ! - ! Regime-aware culvert. The controlling sill is the higher - ! of the two inverts (flow cannot pass until the upstream - ! water level reaches it). Upstream / downstream are picked - ! by the water-level difference, so the structure is - ! bidirectional and the direction filter in the common tail - ! below restricts the sign when requested. - ! - ! Two regimes, selected by h_dn/h_up against the user-set - ! submergence_ratio threshold (default 2/3 = 0.667, the - ! standard broad-crested-weir / Villemonte value): - ! - ! submerged (h_dn/h_up >= threshold): - ! qq = flow_coef * a_eff * sqrt(2 g |dh|) - ! free / inlet-controlled (h_dn/h_up < threshold): - ! qq = flow_coef * a_eff * sqrt(2 g h_up) - ! - ! The flow area a_eff = width * min(h_up, height) caps at - ! the barrel height, so a deeply-submerged inlet can't - ! give unbounded discharge. - ! - zsill = max(src_struc_invert_1(istruc), src_struc_invert_2(istruc)) - ! - dh = real(zs(nmin), 4) - real(zs(nmout), 4) - ! - if (dh >= 0.0) then - ! - h_up = max(real(zs(nmin), 4) - zsill, 0.0) - h_dn = max(real(zs(nmout), 4) - zsill, 0.0) - qq_sign = 1.0 - ! - else - ! - h_up = max(real(zs(nmout), 4) - zsill, 0.0) - h_dn = max(real(zs(nmin), 4) - zsill, 0.0) - qq_sign = -1.0 - ! - endif + else ! - if (h_up <= 0.0) then + if (qq > 0.0) then ! - qq = 0.0 + qq = min(qq, max((zs(nmin) - zb(nmin)) * cell_area(z_flags_iref(nmin)), 0.0) / dt) ! else ! - a_eff = src_struc_width(istruc) * min(h_up, src_struc_height(istruc)) - ! - if (h_dn / h_up >= src_struc_submergence_ratio(istruc)) then - ! - qq = qq_sign * src_struc_flow_coef(istruc) * a_eff * sqrt(2.0 * g * abs(dh)) - ! - else - ! - qq = qq_sign * src_struc_flow_coef(istruc) * a_eff * sqrt(2.0 * g * h_up) - ! - endif + qq = max(qq, -max((zs(nmout) - zb(nmout)) * cell_area(z_flags_iref(nmout)), 0.0) / dt) ! endif ! - end select - ! - ! --------------------------------------------------------------- - ! Common tail: scale by fraction_open (state-machine output) and - ! apply the direction filter. Structures without rules sit at - ! fraction_open=1.0 so the scaling is a no-op; structures with - ! direction_both (the default) see the filter as a no-op too. - ! --------------------------------------------------------------- - ! - qq = qq * src_struc_fraction_open(istruc) - ! - if (src_struc_direction(istruc) == direction_positive .and. qq < 0.0) qq = 0.0 - if (src_struc_direction(istruc) == direction_negative .and. qq > 0.0) qq = 0.0 - ! - ! Relaxation: blend new and previous discharge to damp oscillations. - ! structure_relax is a dimensionless step count: alpha = 1/N damps - ! the discharge response over roughly N time steps. Typical 1-10. - ! - alpha = 1.0 / structure_relax - qq = alpha * qq + (1.0 - alpha) * q_src_struc(istruc) - ! - ! Limit discharge by available volume in the intake / outfall cell. - ! - if (subgrid) then - ! - if (qq > 0.0) then - ! - qq = min(qq, max(z_volume(nmin), 0.0) / dt) - ! - else - ! - qq = max(qq, -max(z_volume(nmout), 0.0) / dt) - ! endif ! - else + q_src_struc(istruc) = qq ! - if (qq > 0.0) then - ! - qq = min(qq, max((zs(nmin) - zb(nmin)) * cell_area(z_flags_iref(nmin)), 0.0) / dt) - ! - else - ! - qq = max(qq, -max((zs(nmout) - zb(nmout)) * cell_area(z_flags_iref(nmout)), 0.0) / dt) - ! - endif + ! Accumulate into cell-wise qsrc. Atomic guards against multiple + ! structures (or a river and a structure) in the same cell. + ! + !$acc atomic update + !$omp atomic + qsrc(nmin) = qsrc(nmin) - qq + !$acc atomic update + !$omp atomic + qsrc(nmout) = qsrc(nmout) + qq ! endif ! - q_src_struc(istruc) = qq - ! - ! Accumulate into cell-wise qsrc. Atomic guards against multiple - ! structures (or a river and a structure) in the same cell. - ! - !$acc atomic update - !$omp atomic - qsrc(nmin) = qsrc(nmin) - qq - !$acc atomic update - !$omp atomic - qsrc(nmout) = qsrc(nmout) + qq - ! - endif + enddo + !$omp end parallel do + !$acc end parallel loop + ! + call timer_stop('Drainage structures') ! - enddo - !$omp end parallel do - !$acc end parallel loop - ! - call timer_stop('Drainage structures') - ! end subroutine ! + !-----------------------------------------------------------------------------------------------------! ! subroutine read_toml_src_structures(filename, structures, ierr) - ! - ! Parse a TOML input file describing point source structures into an - ! allocatable array of t_src_structure. - ! - ! The TOML schema is an array of tables under the key "src_structure": - ! - ! [[src_structure]] - ! name = "south_tide_gate" ! required, string (sole identifier) - ! type = "gate" ! required, one of pump/culvert_simple/gate/culvert - ! ! legacy alias: "check_valve" -> culvert_simple + direction="positive" - ! ! note: "culvert" now resolves to the detailed-culvert physics type; - ! ! users wanting the lumped one-coefficient form must say - ! ! "culvert_simple" explicitly. Orifice behaviour is recoverable - ! ! as "culvert" with submergence_ratio = 0.0. - ! direction = "both" ! optional, culvert_simple/culvert only - ! ! one of "both" (default), "positive", "negative" - ! ! positive: allow flow src_1 -> src_2 only - ! ! negative: allow flow src_2 -> src_1 only - ! src_1_x = ... ; src_1_y = ... ; src_2_x = ... ; src_2_y = ... - ! obs_1_x = ... ; obs_1_y = ... ; obs_2_x = ... ; obs_2_y = ... - ! q = ... ! pump discharge - ! width = ... ; sill_elevation = ... ; mannings_n = ... - ! opening_duration = ... ; closing_duration = ... - ! flow_coef = ... ! culvert_simple / culvert flow coefficient - ! height = ... ! culvert pipe height (m) - ! invert_1 = ... ; invert_2 = ... ! culvert invert elevations at src_1/src_2 ends - ! submergence_ratio = ... ! culvert submergence threshold h_dn/h_up (-) - ! rules_open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr - ! rules_close = "z2>2.0" ! optional trigger expr - ! - ! Per-type required keys (enforced on parse): - ! pump : name, src_1_x, src_1_y, src_2_x, src_2_y, q - ! culvert_simple : name, src_1_x, src_1_y, src_2_x, src_2_y, flow_coef - ! gate : name, src_1_x, src_1_y, src_2_x, src_2_y, width, sill_elevation - ! culvert : name, src_1_x, src_1_y, src_2_x, src_2_y, - ! width, height, invert_1, invert_2 - ! (optional: flow_coef=0.6, submergence_ratio=0.667) - ! - ! On success, structures is allocated to the exact number of entries - ! (can be 0). On any I/O or parse failure, structures is left - ! unallocated and ierr is non-zero. - ! - ! This routine does not modify module state; it is the caller's job to - ! decide what to do with the parsed array. - ! - use tomlf - ! - implicit none - ! - character(len=*), intent(in) :: filename - type(t_src_structure), allocatable, intent(out) :: structures(:) - integer, intent(out) :: ierr - ! - type(toml_table), allocatable :: top - type(toml_error), allocatable :: err - type(toml_array), pointer :: arr_structs - type(toml_table), pointer :: tbl_struct - character(len=:), allocatable :: name_str, type_str, rule_str, dir_str, type_str_lc - integer :: n_struct, i, stat, ierr_parse - ! - ierr = 0 - ! - ! Parse the file. toml_load returns an allocatable table; on failure the - ! table is not allocated and err carries the diagnostic. - ! - call toml_load(top, filename, error=err) - ! - if (allocated(err)) then - ! - write(logstr,'(a,a,a,a)')' Error ! Failed to parse TOML file ', trim(filename), ': ', trim(err%message) - call write_log(logstr, 1) - ierr = 1 - return - ! - endif - ! - if (.not. allocated(top)) then - ! - write(logstr,'(a,a)')' Error ! Could not load TOML file ', trim(filename) - call write_log(logstr, 1) - ierr = 1 - return - ! - endif - ! - ! Look for the top-level array of tables "src_structure". If it is not - ! present at all, treat that as "zero entries" (empty but valid). - ! - nullify(arr_structs) - call get_value(top, 'src_structure', arr_structs, requested=.false., stat=stat) - ! - if (.not. associated(arr_structs)) then - ! - allocate(structures(0)) - return - ! - endif - ! - if (.not. is_array_of_tables(arr_structs)) then - ! - write(logstr,'(a,a)')' Error ! Key "src_structure" must be an array of tables in ', trim(filename) - call write_log(logstr, 1) - ierr = 1 - return ! - endif - ! - n_struct = len(arr_structs) - allocate(structures(n_struct)) - ! - do i = 1, n_struct - ! - nullify(tbl_struct) - call get_value(arr_structs, i, tbl_struct, stat=stat) - ! - if (.not. associated(tbl_struct)) then - ! - write(logstr,'(a,i0,a)')' Error ! src_structure entry ', i, ' is not a table' + ! Parse a TOML input file describing point source structures into an + ! allocatable array of t_src_structure. + ! + ! The TOML schema is an array of tables under the key "src_structure": + ! + ! [[src_structure]] + ! name = "south_tide_gate" ! required, string (sole identifier) + ! type = "gate" ! required, one of pump/culvert_simple/gate/culvert + ! ! legacy alias: "check_valve" -> culvert_simple + direction="positive" + ! ! note: "culvert" now resolves to the detailed-culvert physics type; + ! ! users wanting the lumped one-coefficient form must say + ! ! "culvert_simple" explicitly. Orifice behaviour is recoverable + ! ! as "culvert" with submergence_ratio = 0.0. + ! direction = "both" ! optional, culvert_simple/culvert only + ! ! one of "both" (default), "positive", "negative" + ! ! positive: allow flow src_1 -> src_2 only + ! ! negative: allow flow src_2 -> src_1 only + ! src_1_x = ... ; src_1_y = ... ; src_2_x = ... ; src_2_y = ... + ! obs_1_x = ... ; obs_1_y = ... ; obs_2_x = ... ; obs_2_y = ... + ! q = ... ! pump discharge + ! width = ... ; sill_elevation = ... ; mannings_n = ... + ! opening_duration = ... ; closing_duration = ... + ! flow_coef = ... ! culvert_simple / culvert flow coefficient + ! height = ... ! culvert pipe height (m) + ! invert_1 = ... ; invert_2 = ... ! culvert invert elevations at src_1/src_2 ends + ! submergence_ratio = ... ! culvert submergence threshold h_dn/h_up (-) + ! rules_open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr + ! rules_close = "z2>2.0" ! optional trigger expr + ! + ! Per-type required keys (enforced on parse): + ! pump : name, src_1_x, src_1_y, src_2_x, src_2_y, q + ! culvert_simple : name, src_1_x, src_1_y, src_2_x, src_2_y, flow_coef + ! gate : name, src_1_x, src_1_y, src_2_x, src_2_y, width, sill_elevation + ! culvert : name, src_1_x, src_1_y, src_2_x, src_2_y, + ! width, height, invert_1, invert_2 + ! (optional: flow_coef=0.6, submergence_ratio=0.667) + ! + ! On success, structures is allocated to the exact number of entries + ! (can be 0). On any I/O or parse failure, structures is left + ! unallocated and ierr is non-zero. + ! + ! This routine does not modify module state; it is the caller's job to + ! decide what to do with the parsed array. + ! + ! Called from: initialize_src_structures (this module). + ! + use tomlf + ! + implicit none + ! + character(len=*), intent(in) :: filename + type(t_src_structure), allocatable, intent(out) :: structures(:) + integer, intent(out) :: ierr + ! + type(toml_table), allocatable :: top + type(toml_error), allocatable :: err + type(toml_array), pointer :: arr_structs + type(toml_table), pointer :: tbl_struct + character(len=:), allocatable :: name_str, type_str, rule_str, dir_str, type_str_lc + integer :: n_struct, i, stat, ierr_parse + ! + ierr = 0 + ! + ! Parse the file. toml_load returns an allocatable table; on failure the + ! table is not allocated and err carries the diagnostic. + ! + call toml_load(top, filename, error=err) + ! + if (allocated(err)) then + ! + write(logstr,'(a,a,a,a)')' Error ! Failed to parse TOML file ', trim(filename), ': ', trim(err%message) call write_log(logstr, 1) - call cleanup_on_error() + ierr = 1 return ! endif ! - ! Required name string (presence enforced by check_required below, - ! so that the missing-key error path flows through a single place). - ! - if (allocated(name_str)) deallocate(name_str) - call get_value(tbl_struct, 'name', name_str, stat=stat) - if (allocated(name_str)) structures(i)%name = name_str - ! - ! Required type string, mapped to structure_* code - ! - if (allocated(type_str)) deallocate(type_str) - call get_value(tbl_struct, 'type', type_str, stat=stat) - ! - if (.not. allocated(type_str)) then + if (.not. allocated(top)) then ! - write(logstr,'(a,i0,a,a)')' Error ! Missing required "type" in src_structure entry ', i, & - ' of ', trim(filename) + write(logstr,'(a,a)')' Error ! Could not load TOML file ', trim(filename) call write_log(logstr, 1) ierr = 1 - call cleanup_on_error() return ! endif ! - call parse_structure_type(type_str, structures(i)%structure_type, ierr_parse) + ! Look for the top-level array of tables "src_structure". If it is not + ! present at all, treat that as "zero entries" (empty but valid). + ! + nullify(arr_structs) + call get_value(top, 'src_structure', arr_structs, requested=.false., stat=stat) ! - if (ierr_parse /= 0) then + if (.not. associated(arr_structs)) then ! - ierr = ierr_parse - write(logstr,'(a,a,a,i0)')' Error ! Unknown structure type "', trim(type_str), & - '" in src_structure entry ', i - call write_log(logstr, 1) - call cleanup_on_error() + allocate(structures(0)) return ! endif ! - ! Per-type required-field validation. Checked by key presence - ! (has_key) so that 0.0 remains a legal input value. - ! - select case (structures(i)%structure_type) - ! - case (structure_pump) - ! - call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'q' ], i, ierr) - ! - case (structure_culvert_simple) - ! - call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'flow_coef' ], i, ierr) - ! - case (structure_gate) - ! - call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & - 'width', 'sill_elevation' ], i, ierr) - ! - case (structure_culvert) - ! - call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & - 'width', 'height', 'invert_1', 'invert_2' ], i, ierr) - ! - end select - ! - if (ierr /= 0) then + if (.not. is_array_of_tables(arr_structs)) then ! - call cleanup_on_error() + write(logstr,'(a,a)')' Error ! Key "src_structure" must be an array of tables in ', trim(filename) + call write_log(logstr, 1) + ierr = 1 return ! endif ! - ! Coordinates - src pair is required (enforced above). obs pair - ! defaults to src in the marshal when the key is absent; track - ! presence here so the marshal can distinguish "user gave (0,0)" - ! from "user gave nothing". - ! - call get_value(tbl_struct, 'src_1_x', structures(i)%src_1_x, 0.0, stat=stat) - call get_value(tbl_struct, 'src_1_y', structures(i)%src_1_y, 0.0, stat=stat) - call get_value(tbl_struct, 'src_2_x', structures(i)%src_2_x, 0.0, stat=stat) - call get_value(tbl_struct, 'src_2_y', structures(i)%src_2_y, 0.0, stat=stat) - ! - structures(i)%has_obs_1 = tbl_struct%has_key('obs_1_x') .or. tbl_struct%has_key('obs_1_y') - structures(i)%has_obs_2 = tbl_struct%has_key('obs_2_x') .or. tbl_struct%has_key('obs_2_y') + n_struct = len(arr_structs) + allocate(structures(n_struct)) ! - call get_value(tbl_struct, 'obs_1_x', structures(i)%obs_1_x, 0.0, stat=stat) - call get_value(tbl_struct, 'obs_1_y', structures(i)%obs_1_y, 0.0, stat=stat) - call get_value(tbl_struct, 'obs_2_x', structures(i)%obs_2_x, 0.0, stat=stat) - call get_value(tbl_struct, 'obs_2_y', structures(i)%obs_2_y, 0.0, stat=stat) - ! - ! Named physical parameters. Defaults are picked to avoid NaN in - ! arithmetic and to match the legacy-reader fallbacks. - ! - call get_value(tbl_struct, 'q', structures(i)%q, 0.0, stat=stat) - call get_value(tbl_struct, 'width', structures(i)%width, 0.0, stat=stat) - call get_value(tbl_struct, 'sill_elevation', structures(i)%sill_elevation, 0.0, stat=stat) - ! - ! opening_duration / closing_duration default depends on type: gate keeps - ! its historical 600 s (legacy "dtype 4" gates always had finite ramp - ! durations), pump / culvert_simple / culvert default to 0 s (instant - ! open/close when a rule fires; skips the transient states 2 and 3). - ! - if (structures(i)%structure_type == structure_gate) then - ! - call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 600.0, stat=stat) - call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 600.0, stat=stat) + do i = 1, n_struct ! - else + nullify(tbl_struct) + call get_value(arr_structs, i, tbl_struct, stat=stat) ! - call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 0.0, stat=stat) - call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 0.0, stat=stat) + if (.not. associated(tbl_struct)) then + ! + write(logstr,'(a,i0,a)')' Error ! src_structure entry ', i, ' is not a table' + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif ! - endif - ! - ! flow_coef default differs by type: 1.0 for culvert_simple (legacy - ! lumped one-coefficient form), 0.6 for the detailed culvert - ! (standard orifice discharge coefficient). - ! - if (structures(i)%structure_type == structure_culvert) then + ! Required name string (presence enforced by check_required below, + ! so that the missing-key error path flows through a single place). ! - call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 0.6, stat=stat) + if (allocated(name_str)) deallocate(name_str) + call get_value(tbl_struct, 'name', name_str, stat=stat) + if (allocated(name_str)) structures(i)%name = name_str ! - else + ! Required type string, mapped to structure_* code ! - call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 1.0, stat=stat) + if (allocated(type_str)) deallocate(type_str) + call get_value(tbl_struct, 'type', type_str, stat=stat) ! - endif - ! - ! mannings_n (gate only). Default 0.024 for concrete-lined gate sill. - ! - call get_value(tbl_struct, 'mannings_n', structures(i)%mannings_n, 0.024, stat=stat) - ! - ! Detailed-culvert geometry + submergence threshold. Geometry keys - ! are required (enforced above); submergence_ratio defaults to 2/3 - ! (0.667), the standard broad-crested-weir / Villemonte value. - ! - call get_value(tbl_struct, 'height', structures(i)%height, 0.0, stat=stat) - call get_value(tbl_struct, 'invert_1', structures(i)%invert_1, 0.0, stat=stat) - call get_value(tbl_struct, 'invert_2', structures(i)%invert_2, 0.0, stat=stat) - call get_value(tbl_struct, 'submergence_ratio', structures(i)%submergence_ratio, 0.667, stat=stat) - ! - ! Optional direction filter (culvert_simple / culvert). Default is - ! direction_both. Unknown strings are a hard error. - ! - structures(i)%direction = direction_both - ! - if (allocated(dir_str)) deallocate(dir_str) - call get_value(tbl_struct, 'direction', dir_str, stat=stat) - ! - if (allocated(dir_str)) then + if (.not. allocated(type_str)) then + ! + write(logstr,'(a,i0,a,a)')' Error ! Missing required "type" in src_structure entry ', i, & + ' of ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + call cleanup_on_error() + return + ! + endif ! - call parse_direction(dir_str, structures(i)%direction, ierr_parse) + call parse_structure_type(type_str, structures(i)%structure_type, ierr_parse) ! if (ierr_parse /= 0) then ! ierr = ierr_parse - write(logstr,'(a,a,a,i0)')' Error ! Unknown direction "', trim(dir_str), & + write(logstr,'(a,a,a,i0)')' Error ! Unknown structure type "', trim(type_str), & '" in src_structure entry ', i call write_log(logstr, 1) call cleanup_on_error() @@ -1429,403 +1284,505 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! endif ! - endif - ! - ! Legacy alias side-effect: "check_valve" always pins direction_positive - ! regardless of any explicit direction key. Detect on the lowered type - ! string so "Check_Valve" etc. are handled identically. - ! - type_str_lc = to_lower(type_str) - ! - if (type_str_lc == 'check_valve') then + ! Per-type required-field validation. Checked by key presence + ! (has_key) so that 0.0 remains a legal input value. ! - structures(i)%direction = direction_positive + select case (structures(i)%structure_type) + ! + case (structure_pump) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'q' ], i, ierr) + ! + case (structure_culvert_simple) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'flow_coef' ], i, ierr) + ! + case (structure_gate) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & + 'width', 'sill_elevation' ], i, ierr) + ! + case (structure_culvert) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & + 'width', 'height', 'invert_1', 'invert_2' ], i, ierr) + ! + end select ! - endif - ! - ! Optional rules_open / rules_close string expressions. Absent keys - ! leave the rule strings unallocated on the derived type; marshal - ! treats that as "no trigger". - ! - if (allocated(rule_str)) deallocate(rule_str) - call get_value(tbl_struct, 'rules_open', rule_str, stat=stat) - if (allocated(rule_str)) structures(i)%rule_open = rule_str - ! - if (allocated(rule_str)) deallocate(rule_str) - call get_value(tbl_struct, 'rules_close', rule_str, stat=stat) - if (allocated(rule_str)) structures(i)%rule_close = rule_str - ! - enddo - ! - contains - ! - subroutine cleanup_on_error() - ! - ! Internal helper for the parse loop: drop the partially-filled - ! structures(:) array so the caller always sees it unallocated on - ! error exit. Trivial deallocator. - ! - if (allocated(structures)) deallocate(structures) - ! - end subroutine - ! - end subroutine - ! - ! - subroutine check_required(table, keys, seq_index, ierr) - ! - ! Verify that every key in "keys" is present in the TOML table. Missing - ! keys are reported to the log (naming the structure by its 1-based - ! sequence index, since "name" itself may be the missing key) and ierr - ! is set non-zero. Presence is checked via has_key so that a legal - ! value of 0.0 is not mistaken for "missing". - ! - use tomlf - ! - implicit none - ! - type(toml_table), pointer, intent(in) :: table - character(len=*), intent(in) :: keys(:) - integer, intent(in) :: seq_index - integer, intent(inout) :: ierr - ! - integer :: k - ! - do k = 1, size(keys) - ! - if (.not. table%has_key(trim(keys(k)))) then + if (ierr /= 0) then + ! + call cleanup_on_error() + return + ! + endif ! - write(logstr,'(a,i0,a,a,a)')' Error ! Structure #', seq_index, & - ' is missing required key "', trim(keys(k)), '"' - call write_log(logstr, 1) - ierr = 1 + ! Coordinates - src pair is required (enforced above). obs pair + ! defaults to src in the marshal when the key is absent; track + ! presence here so the marshal can distinguish "user gave (0,0)" + ! from "user gave nothing". ! - endif - ! - enddo - ! - end subroutine - ! - ! - subroutine parse_structure_type(str, code, ierr) - ! - ! Translate a TOML "type" string to one of the structure_* codes. - ! - ! Legacy alias accepted (quietly, no warning): - ! "check_valve" -> structure_culvert_simple - ! (caller is responsible for pinning direction_positive) - ! - ! Note: "culvert" now resolves to structure_culvert (the detailed - ! physics-based pipe-flow type). Users wanting the lumped one-coefficient - ! form must say "culvert_simple" explicitly. - ! - implicit none - ! - character(len=*), intent(in) :: str - integer, intent(out) :: code - integer, intent(out) :: ierr - ! - character(len=:), allocatable :: s - ! - ierr = 0 - code = 0 - s = to_lower(str) - ! - select case (s) - ! - case ('pump') + call get_value(tbl_struct, 'src_1_x', structures(i)%src_1_x, 0.0, stat=stat) + call get_value(tbl_struct, 'src_1_y', structures(i)%src_1_y, 0.0, stat=stat) + call get_value(tbl_struct, 'src_2_x', structures(i)%src_2_x, 0.0, stat=stat) + call get_value(tbl_struct, 'src_2_y', structures(i)%src_2_y, 0.0, stat=stat) ! - code = structure_pump + structures(i)%has_obs_1 = tbl_struct%has_key('obs_1_x') .or. tbl_struct%has_key('obs_1_y') + structures(i)%has_obs_2 = tbl_struct%has_key('obs_2_x') .or. tbl_struct%has_key('obs_2_y') ! - case ('culvert_simple', 'check_valve') + call get_value(tbl_struct, 'obs_1_x', structures(i)%obs_1_x, 0.0, stat=stat) + call get_value(tbl_struct, 'obs_1_y', structures(i)%obs_1_y, 0.0, stat=stat) + call get_value(tbl_struct, 'obs_2_x', structures(i)%obs_2_x, 0.0, stat=stat) + call get_value(tbl_struct, 'obs_2_y', structures(i)%obs_2_y, 0.0, stat=stat) ! - code = structure_culvert_simple + ! Named physical parameters. Defaults are picked to avoid NaN in + ! arithmetic and to match the legacy-reader fallbacks. ! - case ('gate') + call get_value(tbl_struct, 'q', structures(i)%q, 0.0, stat=stat) + call get_value(tbl_struct, 'width', structures(i)%width, 0.0, stat=stat) + call get_value(tbl_struct, 'sill_elevation', structures(i)%sill_elevation, 0.0, stat=stat) ! - code = structure_gate + ! opening_duration / closing_duration default depends on type: gate keeps + ! its historical 600 s (legacy "dtype 4" gates always had finite ramp + ! durations), pump / culvert_simple / culvert default to 0 s (instant + ! open/close when a rule fires; skips the transient states 2 and 3). ! - case ('culvert') + if (structures(i)%structure_type == structure_gate) then + ! + call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 600.0, stat=stat) + call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 600.0, stat=stat) + ! + else + ! + call get_value(tbl_struct, 'opening_duration', structures(i)%opening_duration, 0.0, stat=stat) + call get_value(tbl_struct, 'closing_duration', structures(i)%closing_duration, 0.0, stat=stat) + ! + endif ! - code = structure_culvert + ! flow_coef default differs by type: 1.0 for culvert_simple (legacy + ! lumped one-coefficient form), 0.6 for the detailed culvert + ! (standard orifice discharge coefficient). ! - case default + if (structures(i)%structure_type == structure_culvert) then + ! + call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 0.6, stat=stat) + ! + else + ! + call get_value(tbl_struct, 'flow_coef', structures(i)%flow_coef, 1.0, stat=stat) + ! + endif ! - ierr = 1 + ! mannings_n (gate only). Default 0.024 for concrete-lined gate sill. ! - end select - ! - end subroutine - ! - ! - subroutine parse_direction(str, code, ierr) - ! - ! Translate a TOML "direction" string to one of the direction_* codes. - ! Accepts "both" / "positive" / "negative" case-insensitively. - ! - implicit none - ! - character(len=*), intent(in) :: str - integer, intent(out) :: code - integer, intent(out) :: ierr - ! - character(len=:), allocatable :: s - ! - ierr = 0 - code = 0 - s = to_lower(str) - ! - select case (s) - ! - case ('both') + call get_value(tbl_struct, 'mannings_n', structures(i)%mannings_n, 0.024, stat=stat) ! - code = direction_both + ! Detailed-culvert geometry + submergence threshold. Geometry keys + ! are required (enforced above); submergence_ratio defaults to 2/3 + ! (0.667), the standard broad-crested-weir / Villemonte value. ! - case ('positive') + call get_value(tbl_struct, 'height', structures(i)%height, 0.0, stat=stat) + call get_value(tbl_struct, 'invert_1', structures(i)%invert_1, 0.0, stat=stat) + call get_value(tbl_struct, 'invert_2', structures(i)%invert_2, 0.0, stat=stat) + call get_value(tbl_struct, 'submergence_ratio', structures(i)%submergence_ratio, 0.667, stat=stat) ! - code = direction_positive + ! Optional direction filter (culvert_simple / culvert). Default is + ! direction_both. Unknown strings are a hard error. ! - case ('negative') + structures(i)%direction = direction_both + ! + if (allocated(dir_str)) deallocate(dir_str) + call get_value(tbl_struct, 'direction', dir_str, stat=stat) + ! + if (allocated(dir_str)) then + ! + call parse_direction(dir_str, structures(i)%direction, ierr_parse) + ! + if (ierr_parse /= 0) then + ! + ierr = ierr_parse + write(logstr,'(a,a,a,i0)')' Error ! Unknown direction "', trim(dir_str), & + '" in src_structure entry ', i + call write_log(logstr, 1) + call cleanup_on_error() + return + ! + endif + ! + endif ! - code = direction_negative + ! Legacy alias side-effect: "check_valve" always pins direction_positive + ! regardless of any explicit direction key. Detect on the lowered type + ! string so "Check_Valve" etc. are handled identically. ! - case default + type_str_lc = to_lower(type_str) ! - ierr = 1 + if (type_str_lc == 'check_valve') then + ! + structures(i)%direction = direction_positive + ! + endif + ! + ! Optional rules_open / rules_close string expressions. Absent keys + ! leave the rule strings unallocated on the derived type; marshal + ! treats that as "no trigger". + ! + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_struct, 'rules_open', rule_str, stat=stat) + if (allocated(rule_str)) structures(i)%rule_open = rule_str + ! + if (allocated(rule_str)) deallocate(rule_str) + call get_value(tbl_struct, 'rules_close', rule_str, stat=stat) + if (allocated(rule_str)) structures(i)%rule_close = rule_str + ! + enddo + ! + contains + ! + subroutine cleanup_on_error() + ! + ! Internal helper for the parse loop: drop the partially-filled + ! structures(:) array so the caller always sees it unallocated on + ! error exit. Trivial deallocator. + ! + ! Called from: read_toml_src_structures (host routine) on every + ! error bail-out path. + ! + if (allocated(structures)) deallocate(structures) + ! + end subroutine ! - end select - ! end subroutine ! + !-----------------------------------------------------------------------------------------------------! ! - function to_lower(str) result(lower) - ! - ! Return a lowercase copy of str (ASCII only). - ! - implicit none - ! - character(len=*), intent(in) :: str - character(len=:), allocatable :: lower - ! - integer :: k, ic - ! - lower = str - ! - do k = 1, len(lower) + subroutine check_required(table, keys, seq_index, ierr) + ! + ! Verify that every key in "keys" is present in the TOML table. Missing + ! keys are reported to the log (naming the structure by its 1-based + ! sequence index, since "name" itself may be the missing key) and ierr + ! is set non-zero. Presence is checked via has_key so that a legal + ! value of 0.0 is not mistaken for "missing". + ! + ! Called from: read_toml_src_structures (this module), once per + ! structure entry in the per-type required-field validation block. + ! + use tomlf + ! + implicit none ! - ic = iachar(lower(k:k)) + type(toml_table), pointer, intent(in) :: table + character(len=*), intent(in) :: keys(:) + integer, intent(in) :: seq_index + integer, intent(inout) :: ierr ! - if (ic >= iachar('A') .and. ic <= iachar('Z')) then + integer :: k + ! + do k = 1, size(keys) ! - lower(k:k) = achar(ic + 32) + if (.not. table%has_key(trim(keys(k)))) then + ! + write(logstr,'(a,i0,a,a,a)')' Error ! Structure #', seq_index, & + ' is missing required key "', trim(keys(k)), '"' + call write_log(logstr, 1) + ierr = 1 + ! + endif ! - endif + enddo ! - enddo - ! - end function - ! - ! - subroutine write_src_structures_log_summary() - ! - ! Emit a one-block-per-structure description of every parsed src - ! structure to the log file. Intended for operator review at init - ! time; not printed to stdout. - ! - implicit none - ! - integer :: i - character(len=32) :: type_str, dir_str - ! - if (nr_src_structures <= 0) return - ! - call write_log('------------------------------------------', 0) - call write_log('Flow control structures', 0) - call write_log('------------------------------------------', 0) + end subroutine ! - write(logstr,'(a,i0,a)')'Added ', nr_src_structures, ' flow control structures' - call write_log(logstr, 0) - call write_log('', 0) + !-----------------------------------------------------------------------------------------------------! ! - do i = 1, nr_src_structures + subroutine parse_structure_type(str, code, ierr) + ! + ! Translate a TOML "type" string to one of the structure_* codes. + ! + ! Legacy alias accepted (quietly, no warning): + ! "check_valve" -> structure_culvert_simple + ! (caller is responsible for pinning direction_positive) + ! + ! Note: "culvert" now resolves to structure_culvert (the detailed + ! physics-based pipe-flow type). Users wanting the lumped one-coefficient + ! form must say "culvert_simple" explicitly. ! - select case (int(src_struc_type(i))) + ! Called from: read_toml_src_structures (this module), once per entry + ! to resolve the required "type" key. + ! + implicit none + ! + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr + ! + character(len=:), allocatable :: s + ! + ierr = 0 + code = 0 + s = to_lower(str) + ! + select case (s) ! - case (structure_pump) + case ('pump') ! - type_str = 'pump' + code = structure_pump ! - case (structure_culvert_simple) + case ('culvert_simple', 'check_valve') ! - type_str = 'culvert_simple' + code = structure_culvert_simple ! - case (structure_gate) + case ('gate') ! - type_str = 'gate' + code = structure_gate ! - case (structure_culvert) + case ('culvert') ! - type_str = 'culvert' + code = structure_culvert ! case default ! - type_str = 'unknown' + ierr = 1 ! end select ! - write(logstr,'(a,i0,a)')'Structure ', i, ':' - call write_log(logstr, 0) + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine parse_direction(str, code, ierr) ! - write(logstr,'(a,a)')' name: ', trim(src_struc_name(i)) - call write_log(logstr, 0) + ! Translate a TOML "direction" string to one of the direction_* codes. + ! Accepts "both" / "positive" / "negative" case-insensitively. ! - write(logstr,'(a,a)')' type: ', trim(type_str) - call write_log(logstr, 0) + ! Called from: read_toml_src_structures (this module) when an optional + ! "direction" key is present on a structure entry. ! - write(logstr,'(a,f0.3,a,f0.3,a)')' src_1: (', src_struc_src_1_x(i), ', ', src_struc_src_1_y(i), ')' - call write_log(logstr, 0) + implicit none ! - write(logstr,'(a,f0.3,a,f0.3,a)')' src_2: (', src_struc_src_2_x(i), ', ', src_struc_src_2_y(i), ')' - call write_log(logstr, 0) + character(len=*), intent(in) :: str + integer, intent(out) :: code + integer, intent(out) :: ierr ! - ! obs coords are meaningful for culvert_simple / gate. + character(len=:), allocatable :: s ! - if (src_struc_type(i) == structure_culvert_simple .or. & - src_struc_type(i) == structure_gate) then - ! - write(logstr,'(a,f0.3,a,f0.3,a)')' obs_1: (', src_struc_obs_1_x(i), ', ', src_struc_obs_1_y(i), ')' - call write_log(logstr, 0) - ! - write(logstr,'(a,f0.3,a,f0.3,a)')' obs_2: (', src_struc_obs_2_x(i), ', ', src_struc_obs_2_y(i), ')' - call write_log(logstr, 0) - ! - endif + ierr = 0 + code = 0 + s = to_lower(str) ! - if (src_struc_type(i) == structure_pump) then + select case (s) ! - write(logstr,'(a,f0.4,a)')' discharge: ', src_struc_q(i), ' (m3/s)' - call write_log(logstr, 0) - ! - endif + case ('both') + ! + code = direction_both + ! + case ('positive') + ! + code = direction_positive + ! + case ('negative') + ! + code = direction_negative + ! + case default + ! + ierr = 1 + ! + end select + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + function to_lower(str) result(lower) + ! + ! Return a lowercase copy of str (ASCII only). + ! + ! Called from: parse_structure_type, parse_direction, and + ! convert_legacy_to_toml (all in this module). + ! + implicit none + ! + character(len=*), intent(in) :: str + character(len=:), allocatable :: lower ! - if (src_struc_type(i) == structure_culvert_simple) then + integer :: k, ic + ! + lower = str + ! + do k = 1, len(lower) ! - write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) - call write_log(logstr, 0) + ic = iachar(lower(k:k)) ! - endif + if (ic >= iachar('A') .and. ic <= iachar('Z')) then + ! + lower(k:k) = achar(ic + 32) + ! + endif + ! + enddo ! - ! Direction filter (culvert_simple / culvert) + end function + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_src_structures_log_summary() + ! + ! Emit a one-block-per-structure description of every parsed src + ! structure to the log file. Intended for operator review at init + ! time; not printed to stdout. + ! + ! Called from: initialize_src_structures (this module), once after + ! the marshal runs and cell indices have been resolved. + ! + implicit none + ! + integer :: i + character(len=32) :: type_str, dir_str + ! + if (nr_src_structures <= 0) return + ! + call write_log('------------------------------------------', 0) + call write_log('Flow control structures', 0) + call write_log('------------------------------------------', 0) + ! + write(logstr,'(a,i0,a)')'Added ', nr_src_structures, ' flow control structures' + call write_log(logstr, 0) + call write_log('', 0) ! - if (src_struc_type(i) == structure_culvert_simple .or. & - src_struc_type(i) == structure_culvert) then + do i = 1, nr_src_structures ! - select case (src_struc_direction(i)) + select case (int(src_struc_type(i))) ! - case (direction_both) + case (structure_pump) ! - dir_str = 'both' + type_str = 'pump' ! - case (direction_positive) + case (structure_culvert_simple) ! - dir_str = 'positive' + type_str = 'culvert_simple' ! - case (direction_negative) + case (structure_gate) ! - dir_str = 'negative' + type_str = 'gate' + ! + case (structure_culvert) + ! + type_str = 'culvert' ! case default ! - dir_str = 'unknown' + type_str = 'unknown' ! end select ! - write(logstr,'(a,a)')' direction: ', trim(dir_str) - call write_log(logstr, 0) - ! - endif - ! - if (src_struc_type(i) == structure_culvert) then - ! - write(logstr,'(a,f0.4,a)')' width: ', src_struc_width(i), ' (m)' - call write_log(logstr, 0) - ! - write(logstr,'(a,f0.4,a)')' height: ', src_struc_height(i), ' (m)' - call write_log(logstr, 0) - ! - write(logstr,'(a,f0.4,a)')' invert_1: ', src_struc_invert_1(i), ' (m)' - call write_log(logstr, 0) - ! - write(logstr,'(a,f0.4,a)')' invert_2: ', src_struc_invert_2(i), ' (m)' - call write_log(logstr, 0) - ! - write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) - call write_log(logstr, 0) - ! - write(logstr,'(a,f0.4)')' submerg_r: ', src_struc_submergence_ratio(i) + write(logstr,'(a,i0,a)')'Structure ', i, ':' call write_log(logstr, 0) ! - endif - ! - if (src_struc_type(i) == structure_gate) then - ! - write(logstr,'(a,f0.4,a)')' width: ', src_struc_width(i), ' (m)' + write(logstr,'(a,a)')' name: ', trim(src_struc_name(i)) call write_log(logstr, 0) ! - write(logstr,'(a,f0.4,a)')' sill_elev.: ', src_struc_sill_elevation(i), ' (m)' + write(logstr,'(a,a)')' type: ', trim(type_str) call write_log(logstr, 0) ! - write(logstr,'(a,f0.4)')' mannings_n: ', src_struc_mannings_n(i) + write(logstr,'(a,f0.3,a,f0.3,a)')' src_1: (', src_struc_src_1_x(i), ', ', src_struc_src_1_y(i), ')' call write_log(logstr, 0) ! - write(logstr,'(a,f0.2,a)')' opening: ', src_struc_opening_duration(i), ' (s)' + write(logstr,'(a,f0.3,a,f0.3,a)')' src_2: (', src_struc_src_2_x(i), ', ', src_struc_src_2_y(i), ')' call write_log(logstr, 0) ! - write(logstr,'(a,f0.2,a)')' closing: ', src_struc_closing_duration(i), ' (s)' - call write_log(logstr, 0) + ! obs coords are meaningful for culvert_simple / gate. ! - endif - ! - if (src_struc_rule_open(i) > 0) then + if (src_struc_type(i) == structure_culvert_simple .or. & + src_struc_type(i) == structure_gate) then + ! + write(logstr,'(a,f0.3,a,f0.3,a)')' obs_1: (', src_struc_obs_1_x(i), ', ', src_struc_obs_1_y(i), ')' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.3,a,f0.3,a)')' obs_2: (', src_struc_obs_2_x(i), ', ', src_struc_obs_2_y(i), ')' + call write_log(logstr, 0) + ! + endif ! - if (len_trim(src_struc_rule_open_src(i)) > 0) then + if (src_struc_type(i) == structure_pump) then ! - write(logstr,'(a,a,a)')' rules_open: "', trim(src_struc_rule_open_src(i)), '"' + write(logstr,'(a,f0.4,a)')' discharge: ', src_struc_q(i), ' (m3/s)' + call write_log(logstr, 0) ! - else + endif + ! + if (src_struc_type(i) == structure_culvert_simple) then ! - write(logstr,'(a)')' rules_open: (set)' + write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) + call write_log(logstr, 0) ! endif ! - call write_log(logstr, 0) + ! Direction filter (culvert_simple / culvert) ! - endif - ! - if (src_struc_rule_close(i) > 0) then + if (src_struc_type(i) == structure_culvert_simple .or. & + src_struc_type(i) == structure_culvert) then + ! + select case (src_struc_direction(i)) + ! + case (direction_both) + ! + dir_str = 'both' + ! + case (direction_positive) + ! + dir_str = 'positive' + ! + case (direction_negative) + ! + dir_str = 'negative' + ! + case default + ! + dir_str = 'unknown' + ! + end select + ! + write(logstr,'(a,a)')' direction: ', trim(dir_str) + call write_log(logstr, 0) + ! + endif ! - if (len_trim(src_struc_rule_close_src(i)) > 0) then + if (src_struc_type(i) == structure_culvert) then ! - write(logstr,'(a,a,a)')' rules_close: "', trim(src_struc_rule_close_src(i)), '"' + write(logstr,'(a,f0.4,a)')' width: ', src_struc_width(i), ' (m)' + call write_log(logstr, 0) ! - else + write(logstr,'(a,f0.4,a)')' height: ', src_struc_height(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4,a)')' invert_1: ', src_struc_invert_1(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4,a)')' invert_2: ', src_struc_invert_2(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) + call write_log(logstr, 0) ! - write(logstr,'(a)')' rules_close: (set)' + write(logstr,'(a,f0.4)')' submerg_r: ', src_struc_submergence_ratio(i) + call write_log(logstr, 0) ! endif ! - call write_log(logstr, 0) - ! - endif - ! - ! Opening/closing durations. For gate structures these are always - ! printed (above); for other types only print if rules are set and - ! the duration is non-zero (non-default). - ! - if (src_struc_type(i) /= structure_gate) then - ! - if ((src_struc_rule_open(i) > 0 .or. src_struc_rule_close(i) > 0) .and. & - (src_struc_opening_duration(i) > 0.0 .or. src_struc_closing_duration(i) > 0.0)) then + if (src_struc_type(i) == structure_gate) then + ! + write(logstr,'(a,f0.4,a)')' width: ', src_struc_width(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4,a)')' sill_elev.: ', src_struc_sill_elevation(i), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4)')' mannings_n: ', src_struc_mannings_n(i) + call write_log(logstr, 0) ! write(logstr,'(a,f0.2,a)')' opening: ', src_struc_opening_duration(i), ' (s)' call write_log(logstr, 0) @@ -1835,279 +1792,332 @@ subroutine write_src_structures_log_summary() ! endif ! - endif - ! - call write_log('', 0) + if (src_struc_rule_open(i) > 0) then + ! + if (len_trim(src_struc_rule_open_src(i)) > 0) then + ! + write(logstr,'(a,a,a)')' rules_open: "', trim(src_struc_rule_open_src(i)), '"' + ! + else + ! + write(logstr,'(a)')' rules_open: (set)' + ! + endif + ! + call write_log(logstr, 0) + ! + endif + ! + if (src_struc_rule_close(i) > 0) then + ! + if (len_trim(src_struc_rule_close_src(i)) > 0) then + ! + write(logstr,'(a,a,a)')' rules_close: "', trim(src_struc_rule_close_src(i)), '"' + ! + else + ! + write(logstr,'(a)')' rules_close: (set)' + ! + endif + ! + call write_log(logstr, 0) + ! + endif + ! + ! Opening/closing durations. For gate structures these are always + ! printed (above); for other types only print if rules are set and + ! the duration is non-zero (non-default). + ! + if (src_struc_type(i) /= structure_gate) then + ! + if ((src_struc_rule_open(i) > 0 .or. src_struc_rule_close(i) > 0) .and. & + (src_struc_opening_duration(i) > 0.0 .or. src_struc_closing_duration(i) > 0.0)) then + ! + write(logstr,'(a,f0.2,a)')' opening: ', src_struc_opening_duration(i), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.2,a)')' closing: ', src_struc_closing_duration(i), ' (s)' + call write_log(logstr, 0) + ! + endif + ! + endif + ! + call write_log('', 0) + ! + enddo ! - enddo - ! end subroutine ! + !-----------------------------------------------------------------------------------------------------! ! subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) - ! - ! Transcribe a legacy fixed-column drn file into a TOML sibling file, - ! so that downstream code only has to consume the TOML schema. One - ! [[src_structure]] block is emitted per non-blank, non-comment line - ! of the legacy file. Water-level-triggered gates (legacy dtype 4) are - ! converted to TOML gate blocks with synthesised rule expressions. - ! Schedule-triggered gates (legacy dtype 5) are refused; the new rule - ! grammar is water-level-only and has no time atom. - ! - ! The output path is derived from legacy_path: if it ends in ".drn" - ! (case-insensitive) the suffix ".toml" is inserted before the ".drn", - ! otherwise ".toml" is appended. The resolved path is returned in - ! toml_path for the caller to feed into the TOML reader. - ! - ! The converter is deliberately minimal: no coord sanity checks, no - ! duplicate-name detection, no preservation of comments. It exists only - ! to remove the parallel legacy parsing machinery that used to live - ! in this module. - ! - implicit none - ! - character(len=*), intent(in) :: legacy_path - character(len=*), intent(out) :: toml_path - integer, intent(out) :: ierr - ! - integer :: u_in, u_out, stat, n_struct, dtype - integer :: len_in, ext_pos - real*4 :: x2, y2, x1, y1, par - real*4 :: g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls - character(len=512) :: line, trimmed - character(len=32) :: name_str - character(len=16) :: type_name, par_name, dir_name - character(len=13) :: zmin_str, zmax_str - character(len=128) :: rule_open_str, rule_close_str - ! - ierr = 0 - n_struct = 0 - u_in = 501 - u_out = 502 - ! - ! Derive the TOML sibling path from legacy_path. If legacy_path ends - ! in ".drn" (case-insensitive), insert ".toml" before the extension; - ! else append ".toml". - ! - len_in = len_trim(legacy_path) - ext_pos = 0 - ! - if (len_in >= 4) then - ! - if (to_lower(legacy_path(len_in-3:len_in)) == '.drn') then - ! - ext_pos = len_in - 3 - ! - endif ! - endif - ! - if (ext_pos > 0) then - ! - toml_path = legacy_path(1:ext_pos-1) // '.toml' // legacy_path(ext_pos:len_in) - ! - else - ! - toml_path = legacy_path(1:len_in) // '.toml' + ! Transcribe a legacy fixed-column drn file into a TOML sibling file, + ! so that downstream code only has to consume the TOML schema. One + ! [[src_structure]] block is emitted per non-blank, non-comment line + ! of the legacy file. Water-level-triggered gates (legacy dtype 4) are + ! converted to TOML gate blocks with synthesised rule expressions. + ! Schedule-triggered gates (legacy dtype 5) are refused; the new rule + ! grammar is water-level-only and has no time atom. ! - endif - ! - open(u_in, file=trim(legacy_path), status='old', action='read', iostat=stat) - ! - if (stat /= 0) then + ! The output path is derived from legacy_path: if it ends in ".drn" + ! (case-insensitive) the suffix ".toml" is inserted before the ".drn", + ! otherwise ".toml" is appended. The resolved path is returned in + ! toml_path for the caller to feed into the TOML reader. ! - write(logstr,'(a,a,a)')' Error ! Could not open legacy drn file "', trim(legacy_path), '" for reading' - call write_log(logstr, 1) - ierr = 1 - return + ! The converter is deliberately minimal: no coord sanity checks, no + ! duplicate-name detection, no preservation of comments. It exists only + ! to remove the parallel legacy parsing machinery that used to live + ! in this module. ! - endif - ! - open(u_out, file=trim(toml_path), status='replace', action='write', iostat=stat) - ! - if (stat /= 0) then + ! Called from: initialize_src_structures (this module) when toml-f + ! rejects the drn file on the initial probe. ! - write(logstr,'(a,a,a)')' Error ! Could not open TOML output file "', trim(toml_path), '" for writing' - close(u_in) - call write_log(logstr, 1) - ierr = 1 - return + implicit none ! - endif - ! - write(u_out,'(a)') '# Auto-generated from legacy drn file by SFINCS.' - write(u_out,'(a)') '# Do not edit; edit the legacy source or rewrite as TOML directly.' - write(u_out,'(a)') '' - ! - do while (.true.) + character(len=*), intent(in) :: legacy_path + character(len=*), intent(out) :: toml_path + integer, intent(out) :: ierr ! - read(u_in,'(a)', iostat=stat) line + integer :: u_in, u_out, stat, n_struct, dtype + integer :: len_in, ext_pos + real*4 :: x2, y2, x1, y1, par + real*4 :: g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls + character(len=512) :: line, trimmed + character(len=32) :: name_str + character(len=16) :: type_name, par_name, dir_name + character(len=13) :: zmin_str, zmax_str + character(len=128) :: rule_open_str, rule_close_str ! - if (stat /= 0) exit + ierr = 0 + n_struct = 0 + u_in = 501 + u_out = 502 ! - ! Skip blank / comment lines. + ! Derive the TOML sibling path from legacy_path. If legacy_path ends + ! in ".drn" (case-insensitive), insert ".toml" before the extension; + ! else append ".toml". ! - trimmed = adjustl(line) + len_in = len_trim(legacy_path) + ext_pos = 0 ! - if (len_trim(trimmed) == 0) cycle - if (trimmed(1:1) == '#' .or. trimmed(1:1) == '!') cycle + if (len_in >= 4) then + ! + if (to_lower(legacy_path(len_in-3:len_in)) == '.drn') then + ! + ext_pos = len_in - 3 + ! + endif + ! + endif ! - ! Columns: x1, y1, x2, y2, dtype, par. - ! (legacy xsnk=intake -> src_1; legacy xsrc=outfall -> src_2). + if (ext_pos > 0) then + ! + toml_path = legacy_path(1:ext_pos-1) // '.toml' // legacy_path(ext_pos:len_in) + ! + else + ! + toml_path = legacy_path(1:len_in) // '.toml' + ! + endif ! - read(line, *, iostat=stat) x1, y1, x2, y2, dtype, par + open(u_in, file=trim(legacy_path), status='old', action='read', iostat=stat) ! if (stat /= 0) then ! - write(logstr,'(a,a,a)')' Error ! Could not parse legacy drn line in "', trim(legacy_path), '"' - call write_log(logstr, 1) - write(logstr,'(a,a)')' line: ', trim(line) + write(logstr,'(a,a,a)')' Error ! Could not open legacy drn file "', trim(legacy_path), '" for reading' call write_log(logstr, 1) - close(u_in) - close(u_out) ierr = 1 return ! endif ! - ! Branch on dtype. Gates (4, 5) and unknown codes set ierr and bail. + open(u_out, file=trim(toml_path), status='replace', action='write', iostat=stat) ! - ! dir_name is left blank unless dtype pins a direction filter; a blank - ! dir_name causes the emitter below to skip the direction key entirely, - ! which reads back as direction_both (the default). + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not open TOML output file "', trim(toml_path), '" for writing' + close(u_in) + call write_log(logstr, 1) + ierr = 1 + return + ! + endif ! - dir_name = '' + write(u_out,'(a)') '# Auto-generated from legacy drn file by SFINCS.' + write(u_out,'(a)') '# Do not edit; edit the legacy source or rewrite as TOML directly.' + write(u_out,'(a)') '' ! - select case (dtype) + do while (.true.) ! - case (1) - ! - type_name = 'pump' - par_name = 'q' - ! - case (2) - ! - ! legacy culvert -> bidirectional culvert_simple - ! - type_name = 'culvert_simple' - par_name = 'flow_coef' - ! - case (3) - ! - ! legacy check_valve -> culvert_simple with direction = "positive" - ! - type_name = 'culvert_simple' - par_name = 'flow_coef' - dir_name = 'positive' - ! - case (4) + read(u_in,'(a)', iostat=stat) line + ! + if (stat /= 0) exit + ! + ! Skip blank / comment lines. + ! + trimmed = adjustl(line) + ! + if (len_trim(trimmed) == 0) cycle + if (trimmed(1:1) == '#' .or. trimmed(1:1) == '!') cycle + ! + ! Columns: x1, y1, x2, y2, dtype, par. + ! (legacy xsnk=intake -> src_1; legacy xsrc=outfall -> src_2). + ! + read(line, *, iostat=stat) x1, y1, x2, y2, dtype, par + ! + if (stat /= 0) then ! - ! Water-level-triggered gate. Legacy columns past dtype: - ! width, sill_elevation, mannings_n, zmin, zmax, t_close. - ! Re-read the whole line to pull those extra columns. + write(logstr,'(a,a,a)')' Error ! Could not parse legacy drn line in "', trim(legacy_path), '"' + call write_log(logstr, 1) + write(logstr,'(a,a)')' line: ', trim(line) + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return ! - read(line, *, iostat=stat) x1, y1, x2, y2, dtype, & - g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls + endif + ! + ! Branch on dtype. Gates (4, 5) and unknown codes set ierr and bail. + ! + ! dir_name is left blank unless dtype pins a direction filter; a blank + ! dir_name causes the emitter below to skip the direction key entirely, + ! which reads back as direction_both (the default). + ! + dir_name = '' + ! + select case (dtype) ! - if (stat /= 0) then + case (1) ! - write(logstr,'(a,a,a)')' Error ! Could not parse legacy dtype-4 gate line in "', trim(legacy_path), '"' - call write_log(logstr, 1) - write(logstr,'(a,a)')' line: ', trim(line) + type_name = 'pump' + par_name = 'q' + ! + case (2) + ! + ! legacy culvert -> bidirectional culvert_simple + ! + type_name = 'culvert_simple' + par_name = 'flow_coef' + ! + case (3) + ! + ! legacy check_valve -> culvert_simple with direction = "positive" + ! + type_name = 'culvert_simple' + par_name = 'flow_coef' + dir_name = 'positive' + ! + case (4) + ! + ! Water-level-triggered gate. Legacy columns past dtype: + ! width, sill_elevation, mannings_n, zmin, zmax, t_close. + ! Re-read the whole line to pull those extra columns. + ! + read(line, *, iostat=stat) x1, y1, x2, y2, dtype, & + g_width, g_sill, g_mann, g_zmin, g_zmax, g_tcls + ! + if (stat /= 0) then + ! + write(logstr,'(a,a,a)')' Error ! Could not parse legacy dtype-4 gate line in "', trim(legacy_path), '"' + call write_log(logstr, 1) + write(logstr,'(a,a)')' line: ', trim(line) + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return + ! + endif + ! + ! Synthesise rule strings with the legacy numeric values baked in. + ! Grammar accepts '<', '>', '&', '|' only (no '<=' / '>='). + ! + write(zmin_str,'(es13.6)') g_zmin + write(zmax_str,'(es13.6)') g_zmax + write(rule_open_str, '(a,a,a,a)') 'z1>', trim(adjustl(zmin_str)), ' & z1<', trim(adjustl(zmax_str)) + write(rule_close_str,'(a,a,a,a)') 'z1<', trim(adjustl(zmin_str)), ' | z1>', trim(adjustl(zmax_str)) + ! + n_struct = n_struct + 1 + ! + if (g_zmin >= g_zmax) then + ! + write(logstr,'(a,i0,a)')' Warning ! legacy gate entry ', n_struct, ': zmin >= zmax, open rule will never fire' + call write_log(logstr, 0) + ! + endif + ! + write(name_str,'(a,i0)') 'legacy_', n_struct + ! + write(u_out,'(a)') '[[src_structure]]' + write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' + write(u_out,'(a)') 'type = "gate"' + write(u_out,'(a,es14.6)') 'src_1_x = ', x1 + write(u_out,'(a,es14.6)') 'src_1_y = ', y1 + write(u_out,'(a,es14.6)') 'src_2_x = ', x2 + write(u_out,'(a,es14.6)') 'src_2_y = ', y2 + write(u_out,'(a,es14.6)') 'width = ', g_width + write(u_out,'(a,es14.6)') 'sill_elevation = ', g_sill + write(u_out,'(a,es14.6)') 'mannings_n = ', g_mann + write(u_out,'(a,es14.6)') 'opening_duration = ', g_tcls + write(u_out,'(a,es14.6)') 'closing_duration = ', g_tcls + write(u_out,'(a,a,a)') 'rules_open = "', trim(rule_open_str), '"' + write(u_out,'(a,a,a)') 'rules_close = "', trim(rule_close_str), '"' + write(u_out,'(a)') '' + ! + cycle + ! + case (5) + ! + write(logstr,'(a)')' Error ! legacy schedule-triggered gate (dtype 5) not supported - rewrite as TOML with rule-based triggers or file an issue to add a time atom to the rule grammar' call write_log(logstr, 1) close(u_in) close(u_out) ierr = 1 return ! - endif - ! - ! Synthesise rule strings with the legacy numeric values baked in. - ! Grammar accepts '<', '>', '&', '|' only (no '<=' / '>='). - ! - write(zmin_str,'(es13.6)') g_zmin - write(zmax_str,'(es13.6)') g_zmax - write(rule_open_str, '(a,a,a,a)') 'z1>', trim(adjustl(zmin_str)), ' & z1<', trim(adjustl(zmax_str)) - write(rule_close_str,'(a,a,a,a)') 'z1<', trim(adjustl(zmin_str)), ' | z1>', trim(adjustl(zmax_str)) - ! - n_struct = n_struct + 1 - ! - if (g_zmin >= g_zmax) then + case default ! - write(logstr,'(a,i0,a)')' Warning ! legacy gate entry ', n_struct, ': zmin >= zmax, open rule will never fire' - call write_log(logstr, 0) + write(logstr,'(a,i0,a)')' Error ! unknown drainage_type ', dtype, ' in legacy drn file' + call write_log(logstr, 1) + close(u_in) + close(u_out) + ierr = 1 + return ! - endif - ! - write(name_str,'(a,i0)') 'legacy_', n_struct - ! - write(u_out,'(a)') '[[src_structure]]' - write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' - write(u_out,'(a)') 'type = "gate"' - write(u_out,'(a,es14.6)') 'src_1_x = ', x1 - write(u_out,'(a,es14.6)') 'src_1_y = ', y1 - write(u_out,'(a,es14.6)') 'src_2_x = ', x2 - write(u_out,'(a,es14.6)') 'src_2_y = ', y2 - write(u_out,'(a,es14.6)') 'width = ', g_width - write(u_out,'(a,es14.6)') 'sill_elevation = ', g_sill - write(u_out,'(a,es14.6)') 'mannings_n = ', g_mann - write(u_out,'(a,es14.6)') 'opening_duration = ', g_tcls - write(u_out,'(a,es14.6)') 'closing_duration = ', g_tcls - write(u_out,'(a,a,a)') 'rules_open = "', trim(rule_open_str), '"' - write(u_out,'(a,a,a)') 'rules_close = "', trim(rule_close_str), '"' - write(u_out,'(a)') '' - ! - cycle - ! - case (5) - ! - write(logstr,'(a)')' Error ! legacy schedule-triggered gate (dtype 5) not supported - rewrite as TOML with rule-based triggers or file an issue to add a time atom to the rule grammar' - call write_log(logstr, 1) - close(u_in) - close(u_out) - ierr = 1 - return - ! - case default + end select + ! + n_struct = n_struct + 1 + write(name_str,'(a,i0)') 'legacy_', n_struct + ! + write(u_out,'(a)') '[[src_structure]]' + write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' + write(u_out,'(a,a,a)') 'type = "', trim(type_name),'"' + ! + if (len_trim(dir_name) > 0) then ! - write(logstr,'(a,i0,a)')' Error ! unknown drainage_type ', dtype, ' in legacy drn file' - call write_log(logstr, 1) - close(u_in) - close(u_out) - ierr = 1 - return + write(u_out,'(a,a,a)') 'direction = "', trim(dir_name), '"' ! - end select - ! - n_struct = n_struct + 1 - write(name_str,'(a,i0)') 'legacy_', n_struct - ! - write(u_out,'(a)') '[[src_structure]]' - write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' - write(u_out,'(a,a,a)') 'type = "', trim(type_name),'"' - ! - if (len_trim(dir_name) > 0) then + endif ! - write(u_out,'(a,a,a)') 'direction = "', trim(dir_name), '"' + write(u_out,'(a,es14.6)') 'src_1_x = ', x1 + write(u_out,'(a,es14.6)') 'src_1_y = ', y1 + write(u_out,'(a,es14.6)') 'src_2_x = ', x2 + write(u_out,'(a,es14.6)') 'src_2_y = ', y2 + write(u_out,'(a,a,a,es14.6)') trim(par_name), repeat(' ', max(1, 7 - len_trim(par_name))), '= ', par + write(u_out,'(a)') '' ! - endif + enddo ! - write(u_out,'(a,es14.6)') 'src_1_x = ', x1 - write(u_out,'(a,es14.6)') 'src_1_y = ', y1 - write(u_out,'(a,es14.6)') 'src_2_x = ', x2 - write(u_out,'(a,es14.6)') 'src_2_y = ', y2 - write(u_out,'(a,a,a,es14.6)') trim(par_name), repeat(' ', max(1, 7 - len_trim(par_name))), '= ', par - write(u_out,'(a)') '' + close(u_in) + close(u_out) + ! + write(logstr,'(a,a,a,a,a)')' Converted legacy drn file "', trim(legacy_path), & + '" to TOML "', trim(toml_path), '"' + call write_log(logstr, 0) ! - enddo - ! - close(u_in) - close(u_out) - ! - write(logstr,'(a,a,a,a,a)')' Converted legacy drn file "', trim(legacy_path), & - '" to TOML "', trim(toml_path), '"' - call write_log(logstr, 0) - ! end subroutine - + ! end module From d3c57232ae30d120ca9714abb9a0f8c29fdd8326 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 14:53:28 +0200 Subject: [PATCH 40/65] Add urban drainage module and integrate Introduce a new sfincs_urban_drainage module (zone polygons draining to outfalls) and supporting polygon utility, and integrate it across the codebase. Changes include: add new sources to project/Makefile, parse urbfile input and new config flags, add data variables for urban drainage state, call initialize_urban_drainage at startup and update_urban_drainage during continuity, extend OpenACC present lists, and add NetCDF variables/His-file support for per-zone outfall discharge and cumulative urban drainage depth. Also include logging summary and per-cell qmax/backflow logic. This enables urban drainage zoning, snapping outfalls to cells, per-step accumulation and outputting results. --- source/sfincs_lib/sfincs_lib.vfproj | 2 + source/src/Makefile.am | 2 + source/src/sfincs_continuity.f90 | 13 +- source/src/sfincs_data.f90 | 4 + source/src/sfincs_input.f90 | 3 + source/src/sfincs_lib.f90 | 3 + source/src/sfincs_ncoutput.F90 | 152 +++++- source/src/sfincs_openacc.f90 | 19 +- source/src/sfincs_urban_drainage.f90 | 762 +++++++++++++++++++++++++++ source/src/utils/sfincs_polygons.f90 | 233 ++++++++ 10 files changed, 1165 insertions(+), 28 deletions(-) create mode 100644 source/src/sfincs_urban_drainage.f90 create mode 100644 source/src/utils/sfincs_polygons.f90 diff --git a/source/sfincs_lib/sfincs_lib.vfproj b/source/sfincs_lib/sfincs_lib.vfproj index 66d32851e..1815f49e4 100644 --- a/source/sfincs_lib/sfincs_lib.vfproj +++ b/source/sfincs_lib/sfincs_lib.vfproj @@ -158,6 +158,8 @@ + + diff --git a/source/src/Makefile.am b/source/src/Makefile.am index f85278d13..342fa81b0 100644 --- a/source/src/Makefile.am +++ b/source/src/Makefile.am @@ -77,6 +77,8 @@ libsfincs_la_SOURCES = \ sfincs_discharges.f90 \ sfincs_rule_expression.f90 \ sfincs_src_structures.f90 \ + utils/sfincs_polygons.f90 \ + sfincs_urban_drainage.f90 \ sfincs_subgrid.F90 \ sfincs_timestep_analysis.f90 \ sfincs_infiltration.f90 \ diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index d31eb6703..73667ff7b 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -69,6 +69,7 @@ subroutine update_continuity(t, dt) use sfincs_infiltration use sfincs_discharges use sfincs_src_structures + use sfincs_urban_drainage ! implicit none ! @@ -95,13 +96,13 @@ subroutine update_continuity(t, dt) ! endif ! - ! 5. Urban drainage + ! 5. Urban drainage => update_urban_drainage (adds to qsrc) ! - !if (urban_drainage) then - ! ! - ! call update_urban_drainage(t, dt) - ! ! - !endif + if (urban_drainage) then + ! + call update_urban_drainage(t, dt) + ! + endif ! ! 6. External source/sink (+/-) => add qext to qsrc (set via BMI coupling) ! diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 6a0b2890e..2feec8583 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -125,6 +125,7 @@ module sfincs_data character*256 :: srcfile character*256 :: disfile character*256 :: drnfile + character*256 :: urbfile character*256 :: zsinifile character*256 :: rstfile character*256 :: indexfile @@ -216,6 +217,9 @@ module sfincs_data logical :: write_time_output logical :: bziwaves logical :: infiltration + logical :: urban_drainage + logical :: store_urban_drainage_discharge + logical :: store_cumulative_urban_drainage LOGICAL :: netcdf_infiltration logical :: debug logical :: radstr diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 0d284de49..c5e723dc2 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -220,6 +220,7 @@ subroutine read_sfincs_input() call read_char_input(500,'weirfile',weirfile,'none') call read_char_input(500,'manningfile',manningfile,'none') call read_char_input(500,'drnfile',drnfile,'none') + call read_char_input(500,'urbfile',urbfile,'none') call read_char_input(500,'volfile',volfile,'none') ! ! Forcing @@ -305,6 +306,8 @@ subroutine read_sfincs_input() call read_logical_input(500,'timestep_analysis',timestep_analysis,.false.) call read_int_input(500,'storeqdrain',storeqdrain,1) call read_logical_input(500,'store_river_discharge',store_river_discharge,.false.) + call read_logical_input(500,'store_urban_drainage_discharge',store_urban_drainage_discharge,.false.) + call read_logical_input(500,'store_cumulative_urban_drainage',store_cumulative_urban_drainage,.false.) call read_int_input(500,'storezvolume',storezvolume,0) call read_int_input(500,'storestoragevolume',storestoragevolume,0) call read_int_input(500,'writeruntime',wrttimeoutput,0) diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 4a3b2d066..965f71f70 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -12,6 +12,7 @@ module sfincs_lib use sfincs_runup_gauges use sfincs_discharges use sfincs_src_structures + use sfincs_urban_drainage use sfincs_meteo use sfincs_infiltration use sfincs_data @@ -127,6 +128,8 @@ function sfincs_initialize() result(ierr) ! call initialize_src_structures() ! Reads drn file (pumps / culverts / check valves / gates) ! + call initialize_urban_drainage() ! Reads urb file (per-zone polygon drainage + outfall) + ! if (nonhydrostatic) then ! ! Initialize non-hydrostatic solver diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 012affb6b..33ebfa82a 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -18,6 +18,7 @@ module sfincs_ncoutput integer :: zs_varid, zsmax_varid, h_varid, u_varid, v_varid, tmax_varid, Seff_varid, t_zsmax_varid integer :: zvolume_varid, storagevolume_varid integer :: hmax_varid, vmax_varid, qmax_varid, cumprcp_varid, cuminf_varid, windmax_varid + integer :: cumulative_urbdrain_varid integer :: patm_varid, wind_u_varid, wind_v_varid, precip_varid integer :: hm0_varid, hm0ig_varid, snapwavemsk_varid, tp_varid, tpig_varid, wavdir_varid, dirspr_varid integer :: fwx_varid, fwy_varid, beta_varid, snapwavedepth_varid @@ -42,6 +43,7 @@ module sfincs_ncoutput integer :: time_dimid integer :: points_dimid, pointnamelength_dimid integer :: crosssections_dimid, structures_dimid, thindams_dimid, drain_dimid, runup_gauges_dimid, river_dimid + integer :: urbdrain_dimid integer :: runtime_dimid integer :: point_x_varid, point_y_varid, station_x_varid, station_y_varid, crs_varid, qinf_varid, S_varid integer :: station_id_varid, station_name_varid @@ -50,6 +52,7 @@ module sfincs_ncoutput integer :: thindam_x_varid, thindam_y_varid integer :: drain_varid, drain_name_varid integer :: river_varid, river_name_varid + integer :: urbdrain_varid, urbdrain_name_varid integer :: zb_varid integer :: time_varid integer :: zs_varid, h_varid, u_varid, v_varid, prcp_varid, cumprcp_varid, discharge_varid, uvmag_varid, uvdir_varid @@ -419,14 +422,24 @@ subroutine ncoutput_regular_map_init() if (store_cumulative_precipitation) then NF90(nf90_def_var(map_file%ncid, 'cumprcp', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%timemax_dimid/), map_file%cumprcp_varid)) ! time-varying maximum water level map NF90(nf90_def_var_deflate(map_file%ncid, map_file%cumprcp_varid, 1, 1, nc_deflate_level)) ! deflate - NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'units', 'm')) - NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'long_name', 'cumulative_precipitation_depth')) - NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'standard_name', 'cumulative_precipitation_depth')) - NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'cell_methods', 'time: sum')) + NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'long_name', 'cumulative_precipitation_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'standard_name', 'cumulative_precipitation_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'cell_methods', 'time: sum')) NF90(nf90_put_att(map_file%ncid, map_file%cumprcp_varid, 'coordinates', 'x y')) endif ! + if (store_cumulative_urban_drainage .and. urban_drainage) then + NF90(nf90_def_var(map_file%ncid, 'urban_drainage_cumulative_depth', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%timemax_dimid/), map_file%cumulative_urbdrain_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%cumulative_urbdrain_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'long_name', 'cumulative_urban_drainage_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'cell_methods', 'time: sum')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'coordinates', 'x y')) + endif + ! if (store_twet) then NF90(nf90_def_var(map_file%ncid, 'tmax', NF90_FLOAT, (/map_file%m_dimid, map_file%n_dimid, map_file%timemax_dimid/), map_file%tmax_varid)) ! time-varying duration wet cell NF90(nf90_def_var_deflate(map_file%ncid, map_file%tmax_varid, 1, 1, nc_deflate_level)) ! deflate @@ -1261,10 +1274,21 @@ subroutine ncoutput_quadtree_map_init() ! NF90(nf90_def_var(map_file%ncid, 'cuminf', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%timemax_dimid/), map_file%cuminf_varid)) ! cumulative infiltration map NF90(nf90_def_var_deflate(map_file%ncid, map_file%cuminf_varid, 1, 1, nc_deflate_level)) - NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'units', 'm')) - NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'long_name', 'cumulative_infiltration_depth')) - NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'cell_methods', 'time: sum')) + NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'long_name', 'cumulative_infiltration_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%cuminf_varid, 'cell_methods', 'time: sum')) + ! + endif + ! + if (store_cumulative_urban_drainage .and. urban_drainage) then + ! + NF90(nf90_def_var(map_file%ncid, 'urban_drainage_cumulative_depth', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%timemax_dimid/), map_file%cumulative_urbdrain_varid)) + NF90(nf90_def_var_deflate(map_file%ncid, map_file%cumulative_urbdrain_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'long_name', 'cumulative_urban_drainage_depth')) + NF90(nf90_put_att(map_file%ncid, map_file%cumulative_urbdrain_varid, 'cell_methods', 'time: sum')) ! endif ! @@ -1669,6 +1693,7 @@ subroutine ncoutput_his_init() use sfincs_structures use sfincs_src_structures, only: nr_src_structures, src_struc_name use sfincs_discharges, only: src_name + use sfincs_urban_drainage, only: nr_urban_drainage_zones, urb_zone_name ! implicit none ! @@ -1685,8 +1710,9 @@ subroutine ncoutput_his_init() ! character*256, dimension(:), allocatable :: drain_name_buf character*256, dimension(:), allocatable :: river_name_buf + character*256, dimension(:), allocatable :: urbdrain_name_buf ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nr_src_structures==0 .and. .not. (nr_discharge_points>0 .and. store_river_discharge) .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources (when store_river_discharge) or run-up gauges; his file is not created + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nr_src_structures==0 .and. .not. (nr_discharge_points>0 .and. store_river_discharge) .and. .not. (nr_urban_drainage_zones>0 .and. store_urban_drainage_discharge) .and. nr_runup_gauges==0) then ! If no observation points, cross-sections, structures, drains, river sources, urban drainage zones or run-up gauges; his file is not created return endif ! @@ -1714,7 +1740,11 @@ subroutine ncoutput_his_init() NF90(nf90_def_dim(his_file%ncid, 'rivers', nr_discharge_points, his_file%river_dimid)) ! nr of river point sources endif ! - if (nrstructures>0) then + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + NF90(nf90_def_dim(his_file%ncid, 'urban_drainage_zones', nr_urban_drainage_zones, his_file%urbdrain_dimid)) ! nr of urban drainage zones + endif + ! + if (nrstructures>0) then NF90(nf90_def_dim(his_file%ncid, 'structures', nrstructures, his_file%structures_dimid)) ! nr of structures (weir) endif ! @@ -1764,6 +1794,10 @@ subroutine ncoutput_his_init() NF90(nf90_def_var(his_file%ncid, 'river_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%river_dimid/), his_file%river_name_varid)) endif ! + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + NF90(nf90_def_var(his_file%ncid, 'urban_drainage_zone_name', NF90_CHAR, (/his_file%pointnamelength_dimid, his_file%urbdrain_dimid/), his_file%urbdrain_name_varid)) + endif + ! !NF90(nf90_put_att(his_file%ncid, his_file%station_name_varid, 'units', '-')) !not wanted in fews ! ! Domain @@ -2152,6 +2186,16 @@ subroutine ncoutput_his_init() NF90(nf90_put_att(his_file%ncid, his_file%river_varid, 'coordinates', 'river_name')) ! endif + ! + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + ! + NF90(nf90_def_var(his_file%ncid, 'urban_drainage_discharge', NF90_FLOAT, (/his_file%urbdrain_dimid, his_file%time_dimid/), his_file%urbdrain_varid)) ! per-zone outfall discharge + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'units', 'm3 s-1')) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'long_name', 'urban drainage zone net outfall discharge')) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'coordinates', 'urban_drainage_zone_name')) + ! + endif ! if (nr_runup_gauges > 0) then ! @@ -2232,6 +2276,22 @@ subroutine ncoutput_his_init() ! endif ! + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + ! + allocate(urbdrain_name_buf(nr_urban_drainage_zones)) + ! + do istruc = 1, nr_urban_drainage_zones + ! + urbdrain_name_buf(istruc) = urb_zone_name(istruc) + ! + enddo + ! + NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_name_varid, urbdrain_name_buf)) ! write urban_drainage_zone_name + ! + deallocate(urbdrain_name_buf) + ! + endif + ! if (nrstructures>0) then ! ! Allocate structure @@ -3161,6 +3221,7 @@ subroutine ncoutput_update_his(t,nthisout) use sfincs_snapwave use sfincs_src_structures, only: nr_src_structures, q_src_struc use sfincs_discharges, only: qtsrc + use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_outfall ! implicit none ! @@ -3468,6 +3529,12 @@ subroutine ncoutput_update_his(t,nthisout) ! endif ! + if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then + ! + NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_varid, urban_drainage_q_outfall, (/1, nthisout/))) ! write per-zone outfall discharge + ! + endif + ! if (store_velocity) then ! NF90(nf90_put_var(his_file%ncid, his_file%u_varid, uobs, (/1, nthisout/))) @@ -3487,9 +3554,10 @@ subroutine ncoutput_update_max(t,ntmaxout) ! ! write zsmax per dtmaxout ! - use sfincs_data + use sfincs_data + use sfincs_urban_drainage, only: urban_drainage_cumulative_volume ! - implicit none + implicit none ! integer :: nm, n, m ! @@ -3611,7 +3679,30 @@ subroutine ncoutput_update_max(t,ntmaxout) zstmp(m, n) = cuminf(nm) enddo ! - NF90(nf90_put_var(map_file%ncid, map_file%cuminf_varid, zstmp, (/1, 1, ntmaxout/))) ! write cuminf + NF90(nf90_put_var(map_file%ncid, map_file%cuminf_varid, zstmp, (/1, 1, ntmaxout/))) ! write cuminf + ! + endif + ! + ! Cumulative urban drainage depth (volume / cell_area) + ! + if (store_cumulative_urban_drainage .and. urban_drainage) then + ! + zstmp = FILL_VALUE + ! + do nm = 1, np + ! + n = z_index_z_n(nm) + m = z_index_z_m(nm) + ! + if (crsgeo) then + zstmp(m, n) = urban_drainage_cumulative_volume(nm) / cell_area_m2(nm) + else + zstmp(m, n) = urban_drainage_cumulative_volume(nm) / cell_area(z_flags_iref(nm)) + endif + ! + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%cumulative_urbdrain_varid, zstmp, (/1, 1, ntmaxout/))) ! write cumulative urban drainage depth ! endif ! @@ -3684,11 +3775,12 @@ subroutine ncoutput_update_quadtree_max(t,ntmaxout) ! ! write zsmax per dtmaxout ! - use sfincs_data + use sfincs_data !use sfincs_snapwave use quadtree + use sfincs_urban_drainage, only: urban_drainage_cumulative_volume ! - implicit none + implicit none ! integer :: nmq, nm, ntmaxout real*8 :: t @@ -3812,9 +3904,32 @@ subroutine ncoutput_update_quadtree_max(t,ntmaxout) endif endif enddo - NF90(nf90_put_var(map_file%ncid, map_file%cuminf_varid, zstmp, (/1, ntmaxout/))) ! write cuminf - ! - endif + NF90(nf90_put_var(map_file%ncid, map_file%cuminf_varid, zstmp, (/1, ntmaxout/))) ! write cuminf + ! + endif + ! + ! Cumulative urban drainage depth (volume / cell_area) + ! + if (store_cumulative_urban_drainage .and. urban_drainage) then + ! + zstmp = FILL_VALUE + ! + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm > 0) then + if (kcs(nm) > 0) then + if (crsgeo) then + zstmp(nmq) = urban_drainage_cumulative_volume(nm) / cell_area_m2(nm) + else + zstmp(nmq) = urban_drainage_cumulative_volume(nm) / cell_area(z_flags_iref(nm)) + endif + endif + endif + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%cumulative_urbdrain_varid, zstmp, (/1, ntmaxout/))) ! write cumulative urban drainage depth + ! + endif ! ! Maximum flow velocity if (store_maximum_velocity) then @@ -4051,10 +4166,11 @@ subroutine ncoutput_his_finalize() use sfincs_data use sfincs_src_structures, only: nr_src_structures use sfincs_timers, only: timer_elapsed + use sfincs_urban_drainage, only: nr_urban_drainage_zones ! implicit none ! - if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. nr_src_structures==0 .and. .not. (nr_discharge_points>0 .and. store_river_discharge)) then ! If no observation points, cross-sections, structures (weir or thin dam), drains or river sources (when store_river_discharge); hisfile + if (nobs==0 .and. nrcrosssections==0 .and. nrstructures==0 .and. nrthindams==0 .and. nr_src_structures==0 .and. .not. (nr_discharge_points>0 .and. store_river_discharge) .and. .not. (nr_urban_drainage_zones>0 .and. store_urban_drainage_discharge)) then ! If no observation points, cross-sections, structures (weir or thin dam), drains, river sources or urban drainage zones; hisfile return endif ! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 24096fe7d..1bad3e94c 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -5,6 +5,11 @@ module sfincs_openacc use sfincs_discharges, only: qtsrc, nmindsrc use sfincs_rule_expression, only: rule_opcode, rule_atom, rule_cmp, rule_threshold, & rule_start, rule_length + use sfincs_urban_drainage, only: urban_drainage_zone_indices, urban_drainage_outfall_index, & + urban_drainage_qmax, urban_drainage_backflow_coef, & + urban_drainage_q_outfall, urban_drainage_cumulative_volume, & + urb_zone_h_threshold, urb_zone_check_valve, & + urb_zone_dh_design_min ! implicit none ! @@ -52,8 +57,11 @@ subroutine initialize_openacc() !$acc timestep_analysis_required_timestep, timestep_analysis_average_required_timestep, timestep_analysis_times_wet, timestep_analysis_times_limiting, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & - !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff ) - ! + !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & + !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, urban_drainage_qmax, urban_drainage_backflow_coef, & + !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & + !$acc urb_zone_h_threshold, urb_zone_check_valve, urb_zone_dh_design_min ) + ! end subroutine ! subroutine finalize_openacc() @@ -94,8 +102,11 @@ subroutine finalize_openacc() !$acc timestep_analysis_required_timestep, timestep_analysis_average_required_timestep, timestep_analysis_times_wet, timestep_analysis_times_limiting, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & - !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff ) - ! + !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & + !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, urban_drainage_qmax, urban_drainage_backflow_coef, & + !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & + !$acc urb_zone_h_threshold, urb_zone_check_valve, urb_zone_dh_design_min ) + ! end ! end module diff --git a/source/src/sfincs_urban_drainage.f90 b/source/src/sfincs_urban_drainage.f90 new file mode 100644 index 000000000..df78c25d5 --- /dev/null +++ b/source/src/sfincs_urban_drainage.f90 @@ -0,0 +1,762 @@ +module sfincs_urban_drainage + ! + ! Simple urban-drainage sink/source model for SFINCS. + ! + ! Each zone is a polygon in horizontal plane. Cells inside the polygon + ! drain at a design rate capped by available water; flow is bidirectional + ! so the outfall cell can push water back into the cells (tide / surge) + ! unless a check valve is specified. All flow for a zone is collected at a + ! single outfall cell, so the per-zone net flux is added as a point + ! source / sink there. + ! + ! Per-cell discharge (drain from cell to outfall, positive sign): + ! + ! dzs = zs(nm) - zs(outfall) + ! if dzs > 0: + ! q = min( qmax(nm), max(zs(nm)-zb(nm),0) * cell_area(nm) / dt ) + ! gated further by h_threshold on cell water depth + ! else: + ! q = -backflow_coef(nm) * sqrt(-dzs), capped at -qmax(nm) + ! suppressed if the zone has a check valve + ! + ! Per-cell design-head: + ! + ! dh_design(nm) = max( zb(nm) - zb(outfall), dh_design_min ) + ! backflow_coef(nm) = qmax(nm) / sqrt(dh_design(nm)) + ! + ! qmax from the design precipitation rate: + ! + ! qmax(nm) = design_precip_mm_hr * 1e-3 / 3600 * cell_area(nm) [m3/s] + ! + ! Alternatively the user may supply max_outfall_rate [m3/s] for the + ! whole zone (exclusive with design_precip per zone); design_precip is + ! then derived as + ! + ! design_precip_mm_hr = max_outfall_rate / zone_area * 1000 * 3600 + ! + ! which distributes the capacity proportionally to cell area. + ! + ! Subroutines: + ! + ! initialize_urban_drainage() + ! Top-level driver. Calls read_urban_drainage, loads polygons, marks + ! cells per zone (last zone wins on overlap), snaps outfall coords to + ! the nearest active cell, precomputes per-cell qmax and + ! backflow_coef. Called from sfincs_lib (once at init time). + ! + ! read_urban_drainage(filename, ierr) + ! Parses the *.urb TOML file into the per-zone arrays. Called from + ! initialize_urban_drainage (this module). + ! + ! update_urban_drainage(t, dt) + ! Per-time-step entry: accumulates signed discharges into qsrc, and + ! adds the outfall contribution at each zone's outfall cell. Called + ! from update_continuity (sfincs_continuity). + ! + ! write_urban_drainage_log_summary() + ! Prints a one-block-per-zone summary (name, polygon file, cell + ! count, total area, design precip, total qmax, thresholds, outfall) + ! to the log. Called from initialize_urban_drainage (this module). + ! + use sfincs_log + use sfincs_error + use sfincs_polygons + ! + implicit none + ! + private + ! + public :: initialize_urban_drainage + public :: update_urban_drainage + ! + ! Per-zone runtime state. Sized nr_urban_drainage_zones. + ! + integer, public :: nr_urban_drainage_zones = 0 + ! + character(len=64), dimension(:), allocatable, public :: urb_zone_name + character(len=64), dimension(:), allocatable, public :: urb_zone_type + character(len=256), dimension(:), allocatable :: urb_zone_polygon_file + ! + real*4, dimension(:), allocatable, public :: urb_zone_outfall_x + real*4, dimension(:), allocatable, public :: urb_zone_outfall_y + real*4, dimension(:), allocatable, public :: urb_zone_design_precip ! mm/hr (either given directly or derived from max_outfall_rate) + real*4, dimension(:), allocatable, public :: urb_zone_max_outfall_rate ! m3/s; 0.0 if input was design_precip instead + real*4, dimension(:), allocatable, public :: urb_zone_h_threshold ! m ponding threshold + real*4, dimension(:), allocatable, public :: urb_zone_dh_design_min ! m floor on design head + logical, dimension(:), allocatable, public :: urb_zone_include_outfall + logical, dimension(:), allocatable, public :: urb_zone_check_valve + ! + integer, dimension(:), allocatable, public :: urban_drainage_outfall_index ! cell index, 0 if none + real*4, dimension(:), allocatable, public :: urban_drainage_q_outfall ! m3/s per zone, per step + real*4, dimension(:), allocatable, public :: urb_zone_area ! m2, sum of cell areas in zone + integer, dimension(:), allocatable, public :: urb_zone_n_cells ! number of cells in zone + real*4, dimension(:), allocatable, public :: urb_zone_qmax_total ! m3/s, sum of per-cell qmax + ! + ! Per-cell runtime state. Sized np. + ! + integer, dimension(:), allocatable, public :: urban_drainage_zone_indices ! 0 if not in any zone + real*4, dimension(:), allocatable, public :: urban_drainage_qmax ! m3/s cap per cell + real*4, dimension(:), allocatable, public :: urban_drainage_backflow_coef ! qmax / sqrt(dh_design) + real*4, dimension(:), allocatable, public :: urban_drainage_cumulative_volume ! m3 accumulated (optional) + ! +contains + ! + subroutine initialize_urban_drainage() + ! + ! Top-level initializer for urban drainage. Parses *.urb TOML file, + ! loads polygons, stamps cells per zone (last-wins on overlap), snaps + ! outfall coords to the nearest active cell, and precomputes per-cell + ! qmax and backflow coefficients. + ! + ! Sets sfincs_data::urban_drainage = .true. when at least one zone is + ! loaded and has at least one participating cell. Otherwise leaves it + ! .false. and returns early. + ! + ! Called from: sfincs_lib (once, at init time, after + ! initialize_src_structures). + ! + use sfincs_data + use quadtree + ! + implicit none + ! + integer :: ierr, ipoly, iz, nm, io + integer :: n_cells_in_zones, n_outfalls, nmq + real*4 :: area_nm, dzb, dh_min + type(t_polygon), allocatable :: polygons(:) + logical, allocatable :: inside(:) + character(len=256) :: last_file + integer :: ip + ! + urban_drainage = .false. + ! + if (urbfile(1:4) == 'none') return + ! + call write_log('Info : reading urban drainage file ...', 0) + ! + call read_urban_drainage(trim(urbfile), ierr) + ! + if (ierr /= 0) then + call stop_sfincs('Error ! Failed to read urban drainage TOML file.', -1) + return + endif + ! + if (nr_urban_drainage_zones <= 0) then + call write_log('Info : urban drainage file contains no zones; feature disabled', 0) + return + endif + ! + ! Allocate per-zone snapped outfall index and per-step accumulator. + ! + allocate(urban_drainage_outfall_index(nr_urban_drainage_zones)) + allocate(urban_drainage_q_outfall(nr_urban_drainage_zones)) + allocate(urb_zone_area(nr_urban_drainage_zones)) + allocate(urb_zone_n_cells(nr_urban_drainage_zones)) + allocate(urb_zone_qmax_total(nr_urban_drainage_zones)) + urban_drainage_outfall_index = 0 + urban_drainage_q_outfall = 0.0 + urb_zone_area = 0.0 + urb_zone_n_cells = 0 + urb_zone_qmax_total = 0.0 + ! + ! Allocate per-cell state. + ! + allocate(urban_drainage_zone_indices(np)) + allocate(urban_drainage_qmax(np)) + allocate(urban_drainage_backflow_coef(np)) + allocate(urban_drainage_cumulative_volume(np)) + urban_drainage_zone_indices = 0 + urban_drainage_qmax = 0.0 + urban_drainage_backflow_coef = 0.0 + urban_drainage_cumulative_volume = 0.0 + ! + ! Stamp cells per zone. Polygons are cached per unique file so that + ! multiple zones sharing a polygon file only trigger one file read. + ! Within a file each polygon name is matched against urb_zone_name. + ! + allocate(inside(np)) + last_file = '' + ! + do iz = 1, nr_urban_drainage_zones + ! + if (trim(urb_zone_polygon_file(iz)) == '') then + write(logstr,'(a,a,a)')' Error ! Urban drainage zone "', trim(urb_zone_name(iz)), & + '" has no polygon_file' + call stop_sfincs(trim(logstr), -1) + endif + ! + if (trim(urb_zone_polygon_file(iz)) /= trim(last_file)) then + if (allocated(polygons)) then + do ip = 1, size(polygons) + if (allocated(polygons(ip)%x)) deallocate(polygons(ip)%x) + if (allocated(polygons(ip)%y)) deallocate(polygons(ip)%y) + enddo + deallocate(polygons) + endif + call read_tek_polygons(trim(urb_zone_polygon_file(iz)), polygons, ierr) + if (ierr /= 0) then + write(logstr,'(a,a)')' Error ! Failed to read urban drainage polygon file ', & + trim(urb_zone_polygon_file(iz)) + call stop_sfincs(trim(logstr), -1) + endif + last_file = urb_zone_polygon_file(iz) + endif + ! + ! Find a polygon in this file whose name matches this zone's name. + ! + ipoly = 0 + do ip = 1, size(polygons) + if (trim(polygons(ip)%name) == trim(urb_zone_name(iz))) then + ipoly = ip + exit + endif + enddo + ! + if (ipoly == 0) then + write(logstr,'(a,a,a,a)')' Error ! No polygon named "', trim(urb_zone_name(iz)), & + '" found in file ', trim(urb_zone_polygon_file(iz)) + call stop_sfincs(trim(logstr), -1) + endif + ! + ! Test all active cell centers against this polygon. + ! + inside = .false. + call points_in_polygon_omp(z_xz, z_yz, np, polygons(ipoly), inside) + ! + ! Last-zone-wins: overwrite zone_indices wherever inside is true. + ! + do nm = 1, np + if (inside(nm)) urban_drainage_zone_indices(nm) = iz + enddo + ! + enddo + ! + if (allocated(polygons)) then + do ip = 1, size(polygons) + if (allocated(polygons(ip)%x)) deallocate(polygons(ip)%x) + if (allocated(polygons(ip)%y)) deallocate(polygons(ip)%y) + enddo + deallocate(polygons) + endif + deallocate(inside) + ! + ! Snap outfall coordinates to nearest active cell. + ! + n_outfalls = 0 + ! + do iz = 1, nr_urban_drainage_zones + ! + if (.not. urb_zone_include_outfall(iz)) cycle + ! + nmq = find_quadtree_cell(urb_zone_outfall_x(iz), urb_zone_outfall_y(iz)) + if (nmq > 0) urban_drainage_outfall_index(iz) = index_sfincs_in_quadtree(nmq) + ! + if (urban_drainage_outfall_index(iz) <= 0) then + write(logstr,'(a,a,a)')' Warning : outfall for zone "', trim(urb_zone_name(iz)), & + '" could not be snapped to an active cell; zone contributions will be discarded' + call write_log(logstr, 0) + else + n_outfalls = n_outfalls + 1 + endif + ! + enddo + ! + ! Precompute per-cell qmax and backflow coef. Done in two passes so + ! that zones specified via max_outfall_rate can derive their + ! design_precip from the now-known total zone area. This keeps the + ! per-cell qmax formula uniform across both input styles. + ! + ! Pass 1: accumulate area and cell count per zone. + ! + n_cells_in_zones = 0 + ! + do nm = 1, np + ! + iz = urban_drainage_zone_indices(nm) + if (iz == 0) cycle + ! + if (crsgeo) then + area_nm = cell_area_m2(nm) + else + area_nm = cell_area(z_flags_iref(nm)) + endif + ! + urb_zone_area(iz) = urb_zone_area(iz) + area_nm + urb_zone_n_cells(iz) = urb_zone_n_cells(iz) + 1 + n_cells_in_zones = n_cells_in_zones + 1 + ! + enddo + ! + ! Derive design_precip for zones that were given max_outfall_rate. + ! design_precip [mm/hr] = max_outfall_rate / area * 1000 * 3600. + ! + do iz = 1, nr_urban_drainage_zones + ! + if (urb_zone_max_outfall_rate(iz) > 0.0) then + ! + if (urb_zone_area(iz) <= 0.0) then + write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(iz)), & + '" has max_outfall_rate set but zero participating cells; cannot derive design_precip' + call stop_sfincs(trim(logstr), -1) + endif + ! + urb_zone_design_precip(iz) = urb_zone_max_outfall_rate(iz) / urb_zone_area(iz) * 1000.0 * 3600.0 + ! + endif + ! + enddo + ! + ! Pass 2: compute per-cell qmax and backflow coefficient. + ! + do nm = 1, np + ! + iz = urban_drainage_zone_indices(nm) + if (iz == 0) cycle + ! + if (crsgeo) then + area_nm = cell_area_m2(nm) + else + area_nm = cell_area(z_flags_iref(nm)) + endif + ! + ! mm/hr -> m/s then m3/s + ! + urban_drainage_qmax(nm) = urb_zone_design_precip(iz) * 1.0e-3 / 3600.0 * area_nm + ! + io = urban_drainage_outfall_index(iz) + ! + if (io > 0) then + dh_min = urb_zone_dh_design_min(iz) + dzb = max(zb(nm) - zb(io), dh_min) + urban_drainage_backflow_coef(nm) = urban_drainage_qmax(nm) / sqrt(dzb) + endif + ! + urb_zone_qmax_total(iz) = urb_zone_qmax_total(iz) + urban_drainage_qmax(nm) + ! + enddo + ! + write(logstr,'(a,i0,a,i0,a,i0,a)')' Info : urban drainage: ', nr_urban_drainage_zones, & + ' zone(s), ', n_cells_in_zones, ' cell(s) assigned, ', n_outfalls, ' outfall(s)' + call write_log(logstr, 0) + ! + if (n_cells_in_zones > 0) urban_drainage = .true. + ! + call write_urban_drainage_log_summary() + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine update_urban_drainage(t, dt) + ! + ! Per-time-step entry: accumulate signed discharges into qsrc for + ! cells inside drainage zones, and deposit the summed per-zone flux at + ! each zone's outfall cell. + ! + ! Sign convention: qd > 0 means water leaves the cell (drains to the + ! outfall). qsrc(nm) -= qd subtracts that flux from the cell and the + ! same amount is added back at the outfall. + ! + ! Called from: update_continuity (sfincs_continuity), once per time + ! step, after update_src_structures. + ! + use sfincs_data + ! + implicit none + ! + real*8, intent(in) :: t + real*4, intent(in) :: dt + ! + integer :: nm, iz, io + real*4 :: dzs, qd, area_nm, h_cell + ! + if (nr_urban_drainage_zones <= 0) return + ! + !$acc kernels present(urban_drainage_q_outfall) + urban_drainage_q_outfall = 0.0 + !$acc end kernels + ! + !$acc parallel loop present( qsrc, zs, zb, cell_area, cell_area_m2, z_flags_iref, & + !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, & + !$acc urban_drainage_qmax, urban_drainage_backflow_coef, & + !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & + !$acc urb_zone_h_threshold, urb_zone_check_valve ) + !$omp parallel do default(shared) & + !$omp private(nm, iz, io, dzs, qd, area_nm, h_cell) schedule(static) + do nm = 1, np + ! + iz = urban_drainage_zone_indices(nm) + if (iz == 0) cycle + ! + io = urban_drainage_outfall_index(iz) + if (io <= 0) cycle + ! + dzs = zs(nm) - zs(io) + ! + if (dzs > 0.0) then + ! + ! Drain from cell. Gate on cell ponding depth above grate. + ! + h_cell = zs(nm) - zb(nm) + if (h_cell <= urb_zone_h_threshold(iz)) cycle + ! + if (crsgeo) then + area_nm = cell_area_m2(nm) + else + area_nm = cell_area(z_flags_iref(nm)) + endif + ! + qd = min(urban_drainage_qmax(nm), h_cell * area_nm / dt) + ! + else + ! + ! Backflow from outfall. Blocked by a check valve. + ! + if (urb_zone_check_valve(iz)) cycle + ! + qd = -urban_drainage_backflow_coef(nm) * sqrt(-dzs) + if (qd < -urban_drainage_qmax(nm)) qd = -urban_drainage_qmax(nm) + ! + endif + ! + ! qsrc(nm) is unique per iteration (loop is over nm), no race. + ! The race is on urban_drainage_q_outfall(iz): multiple threads + ! (or gangs on device) may process cells belonging to the same + ! zone, so guard the zone-accumulator with atomic. + ! + qsrc(nm) = qsrc(nm) - qd + ! + !$acc atomic update + !$omp atomic + urban_drainage_q_outfall(iz) = urban_drainage_q_outfall(iz) + qd + ! + urban_drainage_cumulative_volume(nm) = urban_drainage_cumulative_volume(nm) + qd * dt + ! + enddo + !$omp end parallel do + ! + ! Second pass: add each zone's net flux back at the outfall cell. + ! Atomic guards against multiple zones snapping to the same outfall + ! cell (rare but possible). + ! + !$acc parallel loop present( qsrc, urban_drainage_outfall_index, urban_drainage_q_outfall ) + do iz = 1, nr_urban_drainage_zones + ! + io = urban_drainage_outfall_index(iz) + if (io <= 0) cycle + ! + !$acc atomic update + qsrc(io) = qsrc(io) + urban_drainage_q_outfall(iz) + ! + enddo + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine write_urban_drainage_log_summary() + ! + ! Emit a one-block-per-zone description of every parsed urban drainage + ! zone to the log file. Intended for operator review at init time. + ! + ! Called from: initialize_urban_drainage (this module), once after + ! cells have been stamped and per-zone totals have been accumulated. + ! + implicit none + ! + integer :: iz + ! + if (nr_urban_drainage_zones <= 0) return + ! + call write_log('------------------------------------------', 0) + call write_log('Urban drainage zones', 0) + call write_log('------------------------------------------', 0) + ! + write(logstr,'(a,i0,a)')'Added ', nr_urban_drainage_zones, ' urban drainage zone(s)' + call write_log(logstr, 0) + call write_log('', 0) + ! + do iz = 1, nr_urban_drainage_zones + ! + write(logstr,'(a,i0,a)')'Zone ', iz, ':' + call write_log(logstr, 0) + ! + write(logstr,'(a,a)') ' name: ', trim(urb_zone_name(iz)) + call write_log(logstr, 0) + ! + if (len_trim(urb_zone_type(iz)) > 0) then + write(logstr,'(a,a)') ' type: ', trim(urb_zone_type(iz)) + call write_log(logstr, 0) + endif + ! + write(logstr,'(a,a)') ' polygon_file: ', trim(urb_zone_polygon_file(iz)) + call write_log(logstr, 0) + ! + write(logstr,'(a,i0)') ' cells_assigned: ', urb_zone_n_cells(iz) + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.1,a)') ' area: ', urb_zone_area(iz), ' (m2)' + call write_log(logstr, 0) + ! + if (urb_zone_max_outfall_rate(iz) > 0.0) then + write(logstr,'(a,f0.4,a)') ' max_outfall_rate:', urb_zone_max_outfall_rate(iz), ' (m3/s)' + call write_log(logstr, 0) + write(logstr,'(a,f0.2,a)') ' design_precip: ', urb_zone_design_precip(iz), & + ' (mm/hr, derived from max_outfall_rate)' + call write_log(logstr, 0) + else + write(logstr,'(a,f0.2,a)') ' design_precip: ', urb_zone_design_precip(iz), ' (mm/hr)' + call write_log(logstr, 0) + endif + ! + write(logstr,'(a,f0.4,a)') ' qmax_total: ', urb_zone_qmax_total(iz), ' (m3/s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.3,a)') ' h_threshold: ', urb_zone_h_threshold(iz), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.3,a)') ' dh_design_min: ', urb_zone_dh_design_min(iz), ' (m)' + call write_log(logstr, 0) + ! + if (urb_zone_include_outfall(iz)) then + write(logstr,'(a,f0.3,a,f0.3,a)')' outfall: (', urb_zone_outfall_x(iz), ', ', & + urb_zone_outfall_y(iz), ')' + call write_log(logstr, 0) + ! + if (urban_drainage_outfall_index(iz) > 0) then + write(logstr,'(a,i0)') ' outfall_index: ', urban_drainage_outfall_index(iz) + call write_log(logstr, 0) + else + call write_log(' outfall_index: (no active cell snapped)', 0) + endif + else + call write_log(' outfall: (disabled)', 0) + endif + ! + if (urb_zone_check_valve(iz)) then + call write_log(' check_valve: true', 0) + else + call write_log(' check_valve: false', 0) + endif + ! + call write_log('', 0) + ! + enddo + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine read_urban_drainage(filename, ierr) + ! + ! Parse the *.urb TOML file into the per-zone arrays. + ! + ! Schema: + ! + ! [[urban_drainage_zone]] + ! name = "area 1" ! required, string (matches polygon name) + ! type = "drainage" ! optional, free-form tag (reserved) + ! polygon_file = "zones.tek" ! required + ! outfall_x = 950.0 ! required if include_outfall = true + ! outfall_y = 150.0 ! required if include_outfall = true + ! design_precip = 20.0 ! required if max_outfall_rate absent, mm/hr + ! max_outfall_rate = 6.0 ! alternative to design_precip, m3/s total zone capacity + ! ! exactly one of {design_precip, max_outfall_rate} must be given + ! h_threshold = 0.0 ! optional, m (default 0.0) + ! dh_design_min = 0.1 ! optional, m (default 0.1) + ! include_outfall = true ! optional (default true) + ! check_valve = true ! optional (default false) + ! + ! Called from: initialize_urban_drainage (this module). + ! + use tomlf + ! + implicit none + ! + character(len=*), intent(in) :: filename + integer, intent(out) :: ierr + ! + type(toml_table), allocatable :: top + type(toml_error), allocatable :: err + type(toml_array), pointer :: arr_zones + type(toml_table), pointer :: tbl_zone + character(len=:), allocatable :: name_str, type_str, poly_str + integer :: nz, i, stat + real*4 :: r4_tmp + real(kind=8) :: r8_tmp + logical :: l_tmp, found + ! + ierr = 0 + ! + call toml_load(top, filename, error=err) + if (allocated(err)) then + write(logstr,'(a,a,a,a)')' Error ! Failed to parse TOML file ', trim(filename), ': ', & + trim(err%message) + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + if (.not. allocated(top)) then + write(logstr,'(a,a)')' Error ! Could not load TOML file ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + nullify(arr_zones) + call get_value(top, 'urban_drainage_zone', arr_zones, requested=.false., stat=stat) + ! + if (.not. associated(arr_zones)) then + nr_urban_drainage_zones = 0 + return + endif + ! + if (.not. is_array_of_tables(arr_zones)) then + write(logstr,'(a,a)')' Error ! Key "urban_drainage_zone" must be an array of tables in ', & + trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + nz = len(arr_zones) + nr_urban_drainage_zones = nz + ! + if (nz == 0) return + ! + allocate(urb_zone_name(nz)) + allocate(urb_zone_type(nz)) + allocate(urb_zone_polygon_file(nz)) + allocate(urb_zone_outfall_x(nz)) + allocate(urb_zone_outfall_y(nz)) + allocate(urb_zone_design_precip(nz)) + allocate(urb_zone_max_outfall_rate(nz)) + allocate(urb_zone_h_threshold(nz)) + allocate(urb_zone_dh_design_min(nz)) + allocate(urb_zone_include_outfall(nz)) + allocate(urb_zone_check_valve(nz)) + ! + urb_zone_name = '' + urb_zone_type = '' + urb_zone_polygon_file = '' + urb_zone_outfall_x = 0.0 + urb_zone_outfall_y = 0.0 + urb_zone_design_precip = 0.0 + urb_zone_max_outfall_rate = 0.0 + urb_zone_h_threshold = 0.0 + urb_zone_dh_design_min = 0.1 + urb_zone_include_outfall = .true. + urb_zone_check_valve = .false. + ! + do i = 1, nz + ! + nullify(tbl_zone) + call get_value(arr_zones, i, tbl_zone, stat=stat) + if (.not. associated(tbl_zone)) then + write(logstr,'(a,i0,a)')' Error ! urban_drainage_zone entry ', i, ' is not a table' + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + if (allocated(name_str)) deallocate(name_str) + call get_value(tbl_zone, 'name', name_str, stat=stat) + if (.not. allocated(name_str)) then + write(logstr,'(a,i0)')' Error ! Missing required "name" in urban_drainage_zone entry ', i + call write_log(logstr, 1) + ierr = 1 + return + endif + urb_zone_name(i) = name_str + ! + if (allocated(type_str)) deallocate(type_str) + call get_value(tbl_zone, 'type', type_str, stat=stat) + if (allocated(type_str)) urb_zone_type(i) = type_str + ! + if (allocated(poly_str)) deallocate(poly_str) + call get_value(tbl_zone, 'polygon_file', poly_str, stat=stat) + if (.not. allocated(poly_str)) then + write(logstr,'(a,a,a)')' Error ! Missing required "polygon_file" in urban_drainage_zone "', & + trim(urb_zone_name(i)), '"' + call write_log(logstr, 1) + ierr = 1 + return + endif + urb_zone_polygon_file(i) = poly_str + ! + call get_value(tbl_zone, 'outfall_x', r8_tmp, stat=stat) + if (stat == 0) urb_zone_outfall_x(i) = real(r8_tmp, 4) + ! + call get_value(tbl_zone, 'outfall_y', r8_tmp, stat=stat) + if (stat == 0) urb_zone_outfall_y(i) = real(r8_tmp, 4) + ! + ! Exactly one of design_precip / max_outfall_rate must be given. + ! has_key distinguishes "absent" from "present but 0.0", so a user + ! who really wants a zero-capacity zone can still write it. + ! + block + logical :: has_precip, has_rate + has_precip = tbl_zone%has_key('design_precip') + has_rate = tbl_zone%has_key('max_outfall_rate') + if (has_precip .and. has_rate) then + write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(i)), & + '" has both "design_precip" and "max_outfall_rate"; specify only one' + call write_log(logstr, 1) + ierr = 1 + return + endif + if (.not. has_precip .and. .not. has_rate) then + write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(i)), & + '" needs "design_precip" (mm/hr) or "max_outfall_rate" (m3/s)' + call write_log(logstr, 1) + ierr = 1 + return + endif + if (has_precip) then + call get_value(tbl_zone, 'design_precip', r8_tmp, stat=stat) + urb_zone_design_precip(i) = real(r8_tmp, 4) + else + call get_value(tbl_zone, 'max_outfall_rate', r8_tmp, stat=stat) + urb_zone_max_outfall_rate(i) = real(r8_tmp, 4) + endif + end block + ! + call get_value(tbl_zone, 'h_threshold', r8_tmp, stat=stat) + if (stat == 0) urb_zone_h_threshold(i) = real(r8_tmp, 4) + ! + call get_value(tbl_zone, 'dh_design_min', r8_tmp, stat=stat) + if (stat == 0) urb_zone_dh_design_min(i) = real(r8_tmp, 4) + ! + call get_value(tbl_zone, 'include_outfall', l_tmp, stat=stat) + if (stat == 0) urb_zone_include_outfall(i) = l_tmp + ! + call get_value(tbl_zone, 'check_valve', l_tmp, stat=stat) + if (stat == 0) urb_zone_check_valve(i) = l_tmp + ! + ! Minimal sanity check on outfall: if include_outfall is true, outfall + ! coords must be specified (non-zero default is a weak check; keep it + ! simple by warning rather than failing — snap will catch bad values). + ! + if (urb_zone_include_outfall(i)) then + found = (urb_zone_outfall_x(i) /= 0.0 .or. urb_zone_outfall_y(i) /= 0.0) + if (.not. found) then + write(logstr,'(a,a,a)')' Warning : urban_drainage_zone "', trim(urb_zone_name(i)), & + '" has include_outfall = true but outfall_x, outfall_y both 0.0' + call write_log(logstr, 0) + endif + endif + ! + if (urb_zone_dh_design_min(i) <= 0.0) urb_zone_dh_design_min(i) = 0.1 + ! + enddo + ! + ! Keep the compiler from warning about unused variables in case get_value + ! signatures drift; r4_tmp is reserved for future per-zone scalars. + ! + r4_tmp = 0.0 + if (r4_tmp < 0.0) continue + ! + end subroutine + ! +end module sfincs_urban_drainage diff --git a/source/src/utils/sfincs_polygons.f90 b/source/src/utils/sfincs_polygons.f90 new file mode 100644 index 000000000..a0fcae5ac --- /dev/null +++ b/source/src/utils/sfincs_polygons.f90 @@ -0,0 +1,233 @@ +module sfincs_polygons + ! + ! Minimal polygon helper module for SFINCS. + ! + ! Provides: + ! t_polygon Derived type: one named polygon with vertex arrays. + ! read_tek_polygons Read a Delft3D "tek" polyline/polygon file + ! (name line + "nrows ncols" + rows of x y) and + ! return an array of t_polygon, each closed so + ! that the last vertex equals the first. Called + ! from initialize_urban_drainage (sfincs_urban_drainage). + ! point_in_polygon Scalar ray-casting test for a single point. + ! Called from points_in_polygon_omp. + ! points_in_polygon_omp OMP-parallel sweep of a point array against one + ! polygon, writing a logical mask. Called from + ! initialize_urban_drainage (sfincs_urban_drainage). + ! + use sfincs_log + use sfincs_error + ! + implicit none + ! + private + public :: t_polygon, read_tek_polygons, point_in_polygon, points_in_polygon_omp + ! + type :: t_polygon + character(len=64) :: name = '' + integer :: n = 0 + real*4, dimension(:), allocatable :: x + real*4, dimension(:), allocatable :: y + end type t_polygon + ! +contains + ! + subroutine read_tek_polygons(filename, polygons, ierr) + ! + ! Read a Delft3D "tek" polyline file into an array of t_polygon. + ! + ! File format (one or more blocks): + ! + ! + ! + ! ... + ! + ! + ! The file is swept twice: first to count blocks, then to read them. + ! Each polygon is auto-closed: if the last vertex is not equal to the + ! first, a copy of the first vertex is appended so downstream + ! point-in-polygon tests can treat the last-to-first edge uniformly. + ! + ! Called from: initialize_urban_drainage (sfincs_urban_drainage). + ! + implicit none + ! + character(len=*), intent(in) :: filename + type(t_polygon), allocatable, intent(out) :: polygons(:) + integer, intent(out) :: ierr + ! + integer :: unit, stat, npoly, nrows, ncols, irow, ipoly + character(len=256) :: name_line + real*4 :: dummy + logical :: ok + ! + ierr = 0 + ! + ok = check_file_exists(filename, 'Urban drainage polygon file', .true.) + ! + ! First pass: count polygons. + ! + unit = 501 + open(unit, file=trim(filename), status='old', action='read', iostat=stat) + if (stat /= 0) then + write(logstr,'(a,a)')' Error ! Could not open polygon file ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + npoly = 0 + do + read(unit, '(a)', iostat=stat) name_line + if (stat /= 0) exit + if (len_trim(name_line) == 0) cycle + read(unit, *, iostat=stat) nrows, ncols + if (stat /= 0) exit + npoly = npoly + 1 + do irow = 1, nrows + read(unit, *, iostat=stat) dummy + if (stat /= 0) exit + enddo + enddo + rewind(unit) + ! + if (npoly == 0) then + close(unit) + allocate(polygons(0)) + return + endif + ! + allocate(polygons(npoly)) + ! + ! Second pass: read each polygon. + ! + do ipoly = 1, npoly + ! + read(unit, '(a)', iostat=stat) name_line + if (stat /= 0) exit + do while (len_trim(name_line) == 0) + read(unit, '(a)', iostat=stat) name_line + if (stat /= 0) exit + enddo + ! + read(unit, *, iostat=stat) nrows, ncols + if (stat /= 0) then + write(logstr,'(a,i0,a,a)')' Error ! Missing shape line for polygon ', ipoly, & + ' in ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + close(unit) + return + endif + ! + ! Reserve one extra slot so we can auto-close the ring if needed. + ! + allocate(polygons(ipoly)%x(nrows + 1)) + allocate(polygons(ipoly)%y(nrows + 1)) + polygons(ipoly)%name = trim(adjustl(name_line)) + ! + do irow = 1, nrows + read(unit, *, iostat=stat) polygons(ipoly)%x(irow), polygons(ipoly)%y(irow) + if (stat /= 0) then + write(logstr,'(a,i0,a,i0,a,a)')' Error ! Failed reading vertex ', irow, & + ' of polygon ', ipoly, ' in ', trim(filename) + call write_log(logstr, 1) + ierr = 1 + close(unit) + return + endif + enddo + ! + ! Close the ring if the user omitted it. + ! + if (polygons(ipoly)%x(nrows) /= polygons(ipoly)%x(1) .or. & + polygons(ipoly)%y(nrows) /= polygons(ipoly)%y(1)) then + polygons(ipoly)%x(nrows + 1) = polygons(ipoly)%x(1) + polygons(ipoly)%y(nrows + 1) = polygons(ipoly)%y(1) + polygons(ipoly)%n = nrows + 1 + else + polygons(ipoly)%n = nrows + endif + ! + enddo + ! + close(unit) + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + pure function point_in_polygon(xp, yp, xv, yv, nv) result(inside) + ! + ! Classic even-odd ray-casting point-in-polygon test. + ! + ! Returns .true. if (xp, yp) lies inside the closed polygon defined by + ! the first nv vertices of (xv, yv). The polygon is assumed closed by + ! the caller (last vertex == first vertex). + ! + ! Called from: points_in_polygon_omp (this module). + ! + implicit none + ! + real*4, intent(in) :: xp, yp + integer, intent(in) :: nv + real*4, intent(in) :: xv(nv), yv(nv) + logical :: inside + ! + integer :: i, j + ! + inside = .false. + j = nv - 1 + if (j < 1) j = nv + do i = 1, nv + if (((yv(i) > yp) .neqv. (yv(j) > yp)) .and. & + (xp < (xv(j) - xv(i)) * (yp - yv(i)) / (yv(j) - yv(i) + tiny(1.0)) + xv(i))) then + inside = .not. inside + endif + j = i + enddo + ! + end function + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine points_in_polygon_omp(xp, yp, np_pts, poly, inside) + ! + ! OMP-parallel sweep of an (xp, yp) point array against a single polygon. + ! inside(:) must be allocated by the caller with size np_pts. Points + ! already flagged .true. on entry are preserved (so the caller can + ! accumulate hits across multiple polygons if desired); this routine + ! only flips .false. to .true.. + ! + ! Called from: initialize_urban_drainage (sfincs_urban_drainage). + ! + implicit none + ! + integer, intent(in) :: np_pts + real*4, intent(in) :: xp(np_pts), yp(np_pts) + type(t_polygon), intent(in) :: poly + logical, intent(inout) :: inside(np_pts) + ! + integer :: i + real*4 :: xmin, xmax, ymin, ymax + ! + if (poly%n < 3) return + ! + xmin = minval(poly%x(1:poly%n)) + xmax = maxval(poly%x(1:poly%n)) + ymin = minval(poly%y(1:poly%n)) + ymax = maxval(poly%y(1:poly%n)) + ! + !$omp parallel do default(shared) private(i) schedule(static) + do i = 1, np_pts + if (inside(i)) cycle + if (xp(i) < xmin .or. xp(i) > xmax .or. yp(i) < ymin .or. yp(i) > ymax) cycle + if (point_in_polygon(xp(i), yp(i), poly%x, poly%y, poly%n)) then + inside(i) = .true. + endif + enddo + !$omp end parallel do + ! + end subroutine + ! +end module sfincs_polygons From 10cf0099696dd0e598e6617ac7d80b9c1070e942 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 15:20:08 +0200 Subject: [PATCH 41/65] Add urban drainage docs and docs cleanup Introduce a new Urban Drainage user manual (docs/input_urban_drainage.rst) describing zone/polygon format, flow formulas, inputs/outputs and examples. Update docs index to include the new page and fix minor TOC/whitespace issues. Rename/standardize several input pages (input.rst, input_forcing.rst, input_structures.rst) headers for consistency. Add citation guidance to overview.rst. Extend parameters.rst with urbfile and two output flags (store_urban_drainage_discharge, store_cumulative_urban_drainage) and related descriptions. --- docs/index.rst | 5 +- docs/input.rst | 4 +- docs/input_forcing.rst | 2 +- docs/input_structures.rst | 4 +- docs/input_urban_drainage.rst | 152 ++++++++++++++++++++++++++++++++++ docs/overview.rst | 18 ++++ docs/parameters.rst | 23 ++++- 7 files changed, 198 insertions(+), 10 deletions(-) create mode 100644 docs/input_urban_drainage.rst diff --git a/docs/index.rst b/docs/index.rst index 8002b8252..93bec05aa 100644 --- a/docs/index.rst +++ b/docs/index.rst @@ -103,10 +103,11 @@ The SFINCS team also includes Koen van Asselt, Tycho Bovenschen, Ap van Dongeren :maxdepth: 3 :hidden: :caption: User manual: - + input input_forcing - input_structures + input_structures + input_urban_drainage .. toctree:: :maxdepth: 3 diff --git a/docs/input.rst b/docs/input.rst index b48c97ed7..05fab9d18 100644 --- a/docs/input.rst +++ b/docs/input.rst @@ -1,5 +1,5 @@ -User manual - general -===== +General +======= Overview ----- diff --git a/docs/input_forcing.rst b/docs/input_forcing.rst index 666853b54..b442c1839 100644 --- a/docs/input_forcing.rst +++ b/docs/input_forcing.rst @@ -1,4 +1,4 @@ -User manual - forcing +Forcing ======= Overview diff --git a/docs/input_structures.rst b/docs/input_structures.rst index 249abd265..42095f947 100644 --- a/docs/input_structures.rst +++ b/docs/input_structures.rst @@ -1,5 +1,5 @@ -User manual - structures -===== +Structures +========== Overview ----- diff --git a/docs/input_urban_drainage.rst b/docs/input_urban_drainage.rst new file mode 100644 index 000000000..1d98a9c46 --- /dev/null +++ b/docs/input_urban_drainage.rst @@ -0,0 +1,152 @@ +Urban Drainage +============== + +Overview +-------- + +Urban drainage mimics a buried pipe network as a simple bulk sink/source. Each **drainage zone** is a polygon in the horizontal plane. Cells inside the polygon drain at a design rate, capped by the water actually available in the cell. All flow for a zone is collected at a single **outfall** cell (typically in a receiving water body), where the net per-zone flux appears as a point source or sink. Flow is bidirectional — when the outfall water level rises above the cells (tide or surge) the pipes push water back into the zone, unless a **check valve** is configured. + +The approach is deliberately coarse: there is no pipe network, no hydraulic routing, no pressure head other than the difference between cell water level and outfall water level. It is intended for compound-flood applications where pipe geometry is unknown but municipal design standards (rainfall intensity, or the outfall pipe capacity) are available. For a discussion of the underlying assumptions and typical parameter values, see the Developments section. + +**IMPORTANT** — urban drainage does not represent any physical pipe. It is a mass-balance trick: water disappears from urban cells, reappears (summed) at the outfall cell. It does not block or route flow between cells. + +Inputs +------ + +The feature is activated by the ``urbfile`` keyword in ``sfincs.inp``: + +.. code-block:: text + + urbfile = sfincs.urb + store_urban_drainage_discharge = 1 + store_cumulative_urban_drainage = 1 + +``store_urban_drainage_discharge`` writes per-zone outfall discharge time series to ``sfincs_his.nc``. ``store_cumulative_urban_drainage`` writes the cumulative drained depth (m) per cell to ``sfincs_map.nc``. + +The ``.urb`` file is a TOML document with one or more ``[[urban_drainage_zone]]`` entries. + +Zone definition +--------------- + +Each zone is declared as an array-of-tables entry. A minimal example: + +.. code-block:: toml + + [[urban_drainage_zone]] + name = "downtown" + polygon_file = "zones.tek" + outfall_x = 950.0 + outfall_y = 150.0 + design_precip = 20.0 + check_valve = true + + [[urban_drainage_zone]] + name = "harbor_district" + polygon_file = "zones.tek" + outfall_x = 1020.0 + outfall_y = 180.0 + max_outfall_rate = 6.0 + +The supported keys are: + +``name`` (required, string) + Zone name. Must match a polygon name in ``polygon_file``. Used as the station identifier in ``sfincs_his.nc`` when discharge output is enabled. + +``polygon_file`` (required, string) + Path to a Delft3D-style ``.tek`` polygon file. Multiple zones can share the same file — each zone's ``name`` is matched against polygon names inside the file. See "Polygon file format" below. + +``design_precip`` (conditional, mm/hr) + Design rainfall intensity the zone's drainage is sized for. Per-cell capacity is ``qmax = design_precip * cell_area / 3.6e6`` [m³/s]. Typical municipal values: 10–20 mm/hr for suburban residential, 20–40 mm/hr for dense city centre. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided.** + +``max_outfall_rate`` (conditional, m³/s) + Total zone outfall capacity. Useful when you know what the outfall pipe can deliver but not the design storm it was sized for. SFINCS derives ``design_precip = max_outfall_rate / zone_area * 3.6e6`` from the zone's total polygon-covered area, so per-cell capacity is distributed proportionally to cell area. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided.** + +``outfall_x``, ``outfall_y`` (required when ``include_outfall = true``) + Coordinates of the single point where all zone discharge is summed and deposited. Snapped to the nearest active cell. If no active cell can be found, zone contributions are silently discarded and a warning is logged. + +``include_outfall`` (optional, bool, default ``true``) + Set to ``false`` to disable the outfall deposit step. Flow still leaves (or enters) cells, but does not reappear anywhere — treats the zone as an unconnected sink. Mostly useful for sensitivity tests. + +``check_valve`` (optional, bool, default ``false``) + When ``true``, the zone only drains outward. Backflow from the outfall into the cells (bay flooding through the pipe) is suppressed. Represents a flap valve / tide gate at the outfall. + +``h_threshold`` (optional, m, default ``0.0``) + Minimum cell ponding depth required before the drain activates. Physically represents water needing to reach the inlet grate. Only applies to the outflow direction (cell to outfall); backflow is unaffected. Typical values: 0.02–0.05 m. + +``dh_design_min`` (optional, m, default ``0.1``) + Floor on the per-cell design head used to compute the backflow coefficient. Per-cell backflow discharge is + + .. math:: + Q_{back}(nm) = \frac{q_{max}(nm)}{\sqrt{\max(z_b(nm) - z_b(outfall),\,\Delta h_{design,min})}} \cdot \sqrt{z_s(outfall) - z_s(nm)} + + so that a cell at the outfall bed elevation, or below it, doesn't produce an infinite backflow coefficient. + +``type`` (optional, string, free-form) + Reserved for future variants (e.g. injection wells). Currently parsed and logged but not used by the physics. + +Polygon file format +------------------- + +Zones are defined in a Delft3D-style ``.tek`` file — one or more named polygon blocks: + +.. code-block:: text + + downtown + 6 2 + 900.0 100.0 + 900.0 200.0 + 1000.0 200.0 + 1000.0 100.0 + 950.0 80.0 + 900.0 100.0 + harbor_district + 5 2 + 1000.0 150.0 + 1000.0 250.0 + 1100.0 250.0 + 1100.0 150.0 + 1000.0 150.0 + +Each block has a name line, a ``nrows ncols`` line, and ``nrows`` vertex lines. If the last vertex does not equal the first, SFINCS closes the ring automatically at read time. A cell center falling inside multiple polygons is assigned to the **last** zone encountered — overlap warnings are not emitted, so order your zones with intent. + +Flow formulas +------------- + +Per time step, for each active cell ``nm`` inside a zone ``iz`` with outfall cell ``io``: + +.. math:: + \Delta z_s = z_s(nm) - z_s(io) + +**Outflow** (``Δz_s > 0`` and cell depth above ``h_threshold``): + +.. math:: + q = \min\left(q_{max}(nm), \frac{(z_s(nm) - z_b(nm)) \cdot A(nm)}{\Delta t}\right) + +The ``min`` cap prevents draining more than is in the cell over one time step. + +**Backflow** (``Δz_s < 0`` and check valve off): + +.. math:: + q = -\frac{q_{max}(nm)}{\sqrt{\Delta h_{design}(nm)}} \cdot \sqrt{-\Delta z_s} + +capped at ``-q_{max}(nm)``. With a check valve (``check_valve = true``) backflow is skipped entirely. + +The zone's per-step net flux ``sum(q)`` is deposited at the outfall cell, so mass is conserved (up to the outfall-snap warning above). + +Outputs +------- + +**``sfincs_his.nc``** — when ``store_urban_drainage_discharge = 1``: + +``urban_drainage_discharge(urban_drainage_zones, time)`` + Net per-zone outfall discharge in m³/s. Positive means net outflow (drainage from the zone); negative means net inflow (backflow from the outfall). + +``urban_drainage_zone_name(urban_drainage_zones)`` + Zone names, in the order they appear in the ``.urb`` file. + +**``sfincs_map.nc``** — when ``store_cumulative_urban_drainage = 1``: + +``urban_drainage_cumulative_depth(m, n, timemax)`` (regular) or ``(nmesh2d_face, timemax)`` (quadtree) + Cumulative drained volume divided by cell area (m), written at the ``dtmaxout`` interval. Positive means net outflow from the cell over the simulation; negative means net inflow. + +At init time a per-zone summary block is written to the SFINCS log listing zone name, polygon file, number of cells assigned, total area, design precipitation (or max outfall rate + derived design precipitation), total ``qmax``, thresholds, outfall coords, snapped outfall cell index, and check-valve state. diff --git a/docs/overview.rst b/docs/overview.rst index e1470b001..d0952f118 100644 --- a/docs/overview.rst +++ b/docs/overview.rst @@ -35,6 +35,24 @@ Compound flooding? Compound flooding is described as events occurring in coastal areas where the interaction of high sea levels, large river discharges and local precipitation causes (extreme) flooding (Wahl et al., 2015). To simulate compound flooding events, a model needs to be able to model all these types of forcings. Therefore, SFINCS includes fluvial, pluvial, tidal, wind- and wave-driven processes! +How to cite? +^^^^^^^^^^^^ +When using SFINCS in academic work, please cite the following references as appropriate: + +* **For any reference to SFINCS** (introduction and validation of the base model): + + Leijnse, T., van Ormondt, M., Nederhoff, C.M., van Dongeren, A. (2021). Modeling compound flooding in coastal systems using a computationally efficient reduced-physics solver: including fluvial, pluvial, tidal, wind- and wave-driven processes. *Coastal Engineering*, 165, 103852. https://doi.org/10.1016/j.coastaleng.2021.103852 + +* **When using subgrid features**: + + van Ormondt, M., Leijnse, T., de Goede, R., Nederhoff, K., and van Dongeren, A. (2025). Subgrid corrections for the linear inertial equations of a compound flood model – a case study using SFINCS 2.1.1 Dollerup release. *Geoscientific Model Development*, 18, 843–861. https://doi.org/10.5194/gmd-18-843-2025 + +* **When referring to a specific SFINCS executable / release**, cite the Zenodo archive for that version. For the current 2.3.0 Mt Faber release: + + van Ormondt, M., Leijnse, T., Nederhoff, K., de Goede, R., van Dongeren, A., Bovenschen, T., van Asselt, K., Roelvink, D., Reyns, J., & van der Lugt, M. (2025). *SFINCS: Super-Fast INundation of CoastS model (2.3.0 mt Faber Release 2025.02)*. Zenodo. https://doi.org/10.5281/zenodo.17651112 + +For a broader list of SFINCS-related publications, see the "Publications" section at the end of this page. + Application areas ----------------- diff --git a/docs/parameters.rst b/docs/parameters.rst index d1b9f7f91..71683a31e 100644 --- a/docs/parameters.rst +++ b/docs/parameters.rst @@ -396,7 +396,15 @@ Parameters for model output storeqdrain :description: Flag to turn on writing away drainage discharge during simulation (storeqdrain = 1) :units: - - :default: 0 + :default: 0 + store_urban_drainage_discharge + :description: Flag to turn on writing away per-zone outfall discharge to 'sfincs_his.nc' on 'dthisout' interval (only effective when 'urbfile' is specified). + :units: - + :default: 0 + store_cumulative_urban_drainage + :description: Flag to turn on writing away cumulative urban drainage depth (drained volume / cell area, in m) per cell to 'sfincs_map.nc' on 'dtmaxout' interval (only effective when 'urbfile' is specified). + :units: - + :default: 0 storezvolume :description: Flag to turn on writing away water volumes for the subgrid mode during simulation (storezvolume = 1) :units: - @@ -690,5 +698,14 @@ Structures :description: Drainage pumps, culverts and check valves are both specified using the same format file, put with a different indication of the type (type=1 is drainage pump, type=2 is culvert and type=3 is check valve). :units: coordinates: m in projected UTM zone, discharges in m^3/s. :required: no - :format: asc - + :format: asc + +Urban drainage +----- + + urbfile = sfincs.urb + :description: TOML file declaring one or more urban-drainage zones. Each zone is a polygon mapped to a single outfall cell; zone cells drain to the outfall at a design rate (specified either as design_precip in mm/hr or max_outfall_rate in m^3/s), and the outfall can push water back into the cells unless a check valve is set. See 'Urban Drainage' in the user manual for the full schema. + :units: coordinates: m in projected UTM zone; design rate in mm/hr or m^3/s; thresholds in m. + :required: no + :format: toml + From 7304f49d4769ef2e1a2d83598ebdb78bdde13e6a Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 19:13:43 +0200 Subject: [PATCH 42/65] Refactor discharges/drainage and normalize timers Large cleanup and refactor: normalize timer names to lowercase across modules; move river-discharge state and input paths into sfincs_discharges (srcfile, disfile, netsrcdisfile, nr_discharge_points) and update the netCDF discharge reader signature. Remove legacy spatial drainage-mimic (qdrain_rate / initialize_drainage_mimic) and related inputs, and add logical flags (discharges, drainage_structures) to sfincs_data. Ensure precipitation and infiltration now directly accumulate into qsrc (m3/s) within their modules (meteo/infiltration), and make discharge update atomic and early-return when no points. Update input handling for bathtub mode to force input paths to 'none'. Adjust OpenACC kernels/present lists and netCDF output/logging to use the new timer names and new discharge/structure counters. Misc: small API/glue changes (sfincs_src_structures exposes drnfile; sfincs_input imports discharge/drn names; various callers updated). Overall aims: simplify I/O ownership, remove obsolete drainage mimic, and make source-sink accumulation more explicit and consistent. --- docs/input_urban_drainage.rst | 9 ++- source/src/sfincs_bathtub.f90 | 4 +- source/src/sfincs_boundaries.f90 | 4 +- source/src/sfincs_continuity.f90 | 44 +++++----- source/src/sfincs_data.f90 | 14 +--- source/src/sfincs_discharges.f90 | 116 +++++++++++++++------------ source/src/sfincs_domain.f90 | 74 ----------------- source/src/sfincs_infiltration.f90 | 23 +++++- source/src/sfincs_input.f90 | 41 +++++----- source/src/sfincs_lib.f90 | 10 ++- source/src/sfincs_log.f90 | 69 +++++++++------- source/src/sfincs_meteo.f90 | 32 ++++++-- source/src/sfincs_momentum.f90 | 4 +- source/src/sfincs_ncinput.F90 | 16 +++- source/src/sfincs_ncoutput.F90 | 14 ++-- source/src/sfincs_nonhydrostatic.f90 | 4 +- source/src/sfincs_openacc.f90 | 4 +- source/src/sfincs_output.f90 | 7 +- source/src/sfincs_src_structures.f90 | 13 ++- source/src/sfincs_structures.f90 | 4 +- source/src/sfincs_urban_drainage.f90 | 72 ++++++++++++----- source/src/sfincs_wavemaker.f90 | 4 +- 22 files changed, 315 insertions(+), 267 deletions(-) diff --git a/docs/input_urban_drainage.rst b/docs/input_urban_drainage.rst index 1d98a9c46..a5bab261f 100644 --- a/docs/input_urban_drainage.rst +++ b/docs/input_urban_drainage.rst @@ -71,7 +71,7 @@ The supported keys are: When ``true``, the zone only drains outward. Backflow from the outfall into the cells (bay flooding through the pipe) is suppressed. Represents a flap valve / tide gate at the outfall. ``h_threshold`` (optional, m, default ``0.0``) - Minimum cell ponding depth required before the drain activates. Physically represents water needing to reach the inlet grate. Only applies to the outflow direction (cell to outfall); backflow is unaffected. Typical values: 0.02–0.05 m. + Depth over which the drainage rate ramps linearly from zero to ``q_max``. At cell ponding depth ``h_cell = 0`` the drainage is zero; at ``h_cell >= h_threshold`` it is at full ``q_max``; in between it is ``(h_cell / h_threshold) * q_max``. Physically represents water gradually reaching the inlet grate and also smooths the discharge time series compared to a hard on/off gate. Only applies to the outflow direction (cell to outfall); backflow is unaffected. Typical values: 0.02–0.05 m. Set to ``0.0`` to reproduce the hard-cap behaviour (full ``q_max`` for any ``h_cell > 0``). ``dh_design_min`` (optional, m, default ``0.1``) Floor on the per-cell design head used to compute the backflow coefficient. Per-cell backflow discharge is @@ -117,12 +117,13 @@ Per time step, for each active cell ``nm`` inside a zone ``iz`` with outfall cel .. math:: \Delta z_s = z_s(nm) - z_s(io) -**Outflow** (``Δz_s > 0`` and cell depth above ``h_threshold``): +**Outflow** (``Δz_s > 0`` and ``h_cell > 0``): .. math:: - q = \min\left(q_{max}(nm), \frac{(z_s(nm) - z_b(nm)) \cdot A(nm)}{\Delta t}\right) + r &= \min(h_{cell} / h_{threshold},\; 1) \quad \text{if } h_{threshold} > 0, \text{ else } 1 \\ + q &= \min\left(r \cdot q_{max}(nm),\; \frac{h_{cell} \cdot A(nm)}{\Delta t}\right) -The ``min`` cap prevents draining more than is in the cell over one time step. +where ``h_cell`` is ``zs - subgrid_z_zmin`` in subgrid mode, or ``zs - zb`` otherwise. The ramp factor ``r`` smooths the discharge near the grate; the ``min`` cap prevents draining more than is in the cell over one time step. **Backflow** (``Δz_s < 0`` and check valve off): diff --git a/source/src/sfincs_bathtub.f90 b/source/src/sfincs_bathtub.f90 index c63a29e88..4f67e2b61 100644 --- a/source/src/sfincs_bathtub.f90 +++ b/source/src/sfincs_bathtub.f90 @@ -125,7 +125,7 @@ subroutine bathtub_compute_water_levels() integer :: nm, i1, i2 real*4 :: zbt, w1, w2 ! - call timer_start('Continuity') + call timer_start('continuity') ! !$omp parallel & !$omp private ( nm, i1, i2, w1, w2 ) @@ -163,7 +163,7 @@ subroutine bathtub_compute_water_levels() ! !$acc update device( zs, zsmax ) ! - call timer_stop('Continuity') + call timer_stop('continuity') ! end subroutine diff --git a/source/src/sfincs_boundaries.f90 b/source/src/sfincs_boundaries.f90 index 80f84c645..578210a43 100644 --- a/source/src/sfincs_boundaries.f90 +++ b/source/src/sfincs_boundaries.f90 @@ -1139,7 +1139,7 @@ subroutine update_boundaries(t, dt) ! if (boundaries_in_mask) then ! - call timer_start('Boundaries') + call timer_start('boundaries') ! if (nbnd > 0) then ! @@ -1164,7 +1164,7 @@ subroutine update_boundaries(t, dt) ! endif ! - call timer_stop('Boundaries') + call timer_stop('boundaries') ! endif ! diff --git a/source/src/sfincs_continuity.f90 b/source/src/sfincs_continuity.f90 index 73667ff7b..f3fa94ae7 100644 --- a/source/src/sfincs_continuity.f90 +++ b/source/src/sfincs_continuity.f90 @@ -42,25 +42,29 @@ module sfincs_continuity subroutine update_continuity(t, dt) ! ! Unified continuity update: orchestrates all water balance terms - ! for one time step. Modifies qsrc in place (zeroed and - ! re-accumulated), advances zs (and z_volume on the subgrid path), + ! for one time step. Advances zs (and z_volume on the subgrid path), ! and optionally updates the store_* running maxima. ! ! Called from: sfincs_lib (main time-stepping loop). ! ! Sources and sinks (all accumulated into qsrc, in m3/s): - ! 1. River discharges (+/-) => update_discharges (zeros and accumulates qsrc) - ! 2. Drainage structures (+/-) => update_src_structures (adds to qsrc) - ! 3. Precipitation (+) => update_meteo_forcing (precip * cell area) - ! 4. Infiltration rate field qinfmap (-) => update_infiltration_map (infiltration * cell area) - ! (flavors: con, c2d, cna, cnb, gai, hor, bkt) - ! 5. Urban drainage => update_urban_drainage (adds to qsrc) - ! 6. External source/sink qext (+/-) => added to qsrc here (BMI coupling) + ! 1. Precipitation (+) => update_meteo_forcing (prcp * cell area), + ! already done before entering this routine + ! 2. River discharges (+/-) => update_discharges (adds to qsrc) + ! 3. Drainage structures (+/-) => update_src_structures (adds to qsrc) + ! 4. Infiltration rate field qinfmap (-) => update_infiltration_map (-qinfmap * cell area, + ! flavors: con, c2d, cna, cnb, gai, hor, bkt) + ! 5. Urban drainage (+/-) => update_urban_drainage + ! 6. External source/sink qext (+/-) => added to qsrc here (BMI coupling) + ! + ! qsrc itself is cleared at the end of compute_water_levels_{regular, + ! subgrid} (per active cell), so steps 1-6 above start from zero every + ! step without an explicit reset here. ! ! Hydrodynamic fluxes q => computed in sfincs_momentum ! ! compute_water_levels_{regular,subgrid} then updates zs/z_volume using: - ! - qsrc * dt => point source/sink contribution + ! - qsrc * dt => all sources/sinks above ! - div(q) * dt => horizontal flux divergence ! - storage volume => absorbs excess volume (subgrid only) ! @@ -78,17 +82,19 @@ subroutine update_continuity(t, dt) ! integer :: nm ! - ! 1. River discharges => update_discharges (adds to qsrc) + ! 1. Precipitation was already accumulated into qsrc by + ! update_meteo_forcing (called from sfincs_lib before this routine). + ! + ! 2. River discharges => update_discharges (adds to qsrc) ! call update_discharges(t, dt) ! - ! 2. Drainage structures (pumps/gates/culverts/...) => update_src_structures (adds to qsrc) + ! 3. Drainage structures (pumps/gates/culverts/...) => update_src_structures (adds to qsrc) ! call update_src_structures(t, dt) ! - ! 3. Precipitation => update_meteo_forcing (adds to qsrc) - ! - ! 4. Compute infiltration rates => qinfmap(adds to qsrc) + ! 4. Compute infiltration rates; update_infiltration_map also subtracts + ! qinfmap * cell_area from qsrc. ! if (infiltration) then ! @@ -124,7 +130,7 @@ subroutine update_continuity(t, dt) ! ! Update water levels: applies qsrc * dt and flux divergence to zs/z_volume ! - call timer_start('Continuity') + call timer_start('continuity') ! if (subgrid) then ! @@ -144,7 +150,7 @@ subroutine update_continuity(t, dt) ! endif ! - call timer_stop('Continuity') + call timer_stop('continuity') ! end subroutine ! @@ -188,7 +194,7 @@ subroutine compute_water_levels_regular(dt, t) ! endif ! - !$acc parallel present( kcs, zs, zb, prcp, q, qext, qinfmap, qdrain_rate, zsmax, zsm, maxzsm, & + !$acc parallel present( kcs, zs, zb, q, qext, zsmax, zsm, maxzsm, & !$acc z_flags_iref, uv_flags_iref, & !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & @@ -411,7 +417,7 @@ subroutine compute_water_levels_subgrid(dt,t) !$omp do schedule ( dynamic, 256 ) !$acc parallel present( kcs, zs, zs0, zb, z_volume, zsmax, zsm, maxzsm, zsderv, & !$acc subgrid_z_zmin, subgrid_z_zmax, subgrid_z_dep, subgrid_z_volmax, & - !$acc prcp, q, qext, qinfmap, qdrain_rate, z_flags_iref, uv_flags_iref, & + !$acc q, qext, z_flags_iref, uv_flags_iref, & !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc dxm, dxrm, dyrm, dxminv, dxrinv, dyrinv, cell_area_m2, cell_area, & !$acc z_index_wavemaker, wavemaker_uvmean, & diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 2feec8583..0f5747028 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -122,9 +122,6 @@ module sfincs_data character*256 :: obsfile character*256 :: crsfile character*256 :: rugfile - character*256 :: srcfile - character*256 :: disfile - character*256 :: drnfile character*256 :: urbfile character*256 :: zsinifile character*256 :: rstfile @@ -145,7 +142,6 @@ module sfincs_data character*256 :: weirfile character*256 :: qinffile character*256 :: netbndbzsbzifile - character*256 :: netsrcdisfile character*256 :: netamuamvfile character*256 :: netampfile character*256 :: netamprfile @@ -160,7 +156,6 @@ module sfincs_data character*256 :: f0file character*256 :: fcfile character*256 :: kdfile - character*256 :: drainagefile character*256 :: z0lfile character*256 :: qtrfile character*256 :: volfile @@ -217,6 +212,8 @@ module sfincs_data logical :: write_time_output logical :: bziwaves logical :: infiltration + logical :: discharges + logical :: drainage_structures logical :: urban_drainage logical :: store_urban_drainage_discharge logical :: store_cumulative_urban_drainage @@ -402,11 +399,6 @@ module sfincs_data ! real*4, dimension(:), allocatable :: storage_volume ! Storage volume green infra ! - ! Drainage - constant removal rate representing subsurface drainage - ! - logical :: drainage = .false. - real*4, dimension(:), allocatable :: qdrain_rate ! drainage rate per cell (m/s) - ! ! Bucket model - finite capacity reservoir with linear drainage ! logical :: use_bucket_model = .false. @@ -802,7 +794,6 @@ module sfincs_data ! the pure discharge-module-only state (itsrclast, nmindsrc, qtsrc, ! src_name, src_name_len) has been moved into sfincs_discharges. ! - integer :: nr_discharge_points integer :: ntsrc real*4, dimension(:), allocatable :: tsrc ! (ntsrc) time stamps of river discharge time series real*4, dimension(:,:), allocatable :: qsrc_ts ! (nr_discharge_points, ntsrc) river discharge time series matrix @@ -978,7 +969,6 @@ subroutine finalize_parameters() if(allocated(qinffield)) deallocate(qinffield) if(allocated(ksfield)) deallocate(ksfield) if(allocated(scs_Se)) deallocate(scs_Se) - if(allocated(qdrain_rate)) deallocate(qdrain_rate) if(allocated(bucket_volume)) deallocate(bucket_volume) if(allocated(bucket_capacity)) deallocate(bucket_capacity) if(allocated(bucket_k)) deallocate(bucket_k) diff --git a/source/src/sfincs_discharges.f90 b/source/src/sfincs_discharges.f90 index d70398635..7efce042a 100644 --- a/source/src/sfincs_discharges.f90 +++ b/source/src/sfincs_discharges.f90 @@ -43,6 +43,17 @@ module sfincs_discharges ! Public so downstream output modules (sfincs_output, sfincs_ncoutput) ! and the openacc bookkeeping module can reference them. ! + ! Input file paths (sfincs.inp keywords 'srcfile' / 'disfile' / + ! 'netsrcdisfile'); 'none' when the corresponding input is not supplied. + ! + character(len=256), public :: srcfile + character(len=256), public :: disfile + character(len=256), public :: netsrcdisfile + ! + ! Number of river discharge points resolved from the input files. + ! + integer, public :: nr_discharge_points + ! ! Name length (matches src_struc_name_len from sfincs_src_structures). ! integer, parameter, public :: src_name_len = 128 @@ -86,6 +97,7 @@ subroutine initialize_discharges() character(len=1024) :: line, line_trim character(len=src_name_len) :: name_tmp ! + discharges = .false. nr_discharge_points = 0 ntsrc = 0 itsrclast = 1 @@ -113,7 +125,7 @@ subroutine initialize_discharges() ! ok = check_file_exists(netsrcdisfile, 'Netcdf river input netsrcdis file', .true.) ! - call read_netcdf_discharge_data() ! sets nr_discharge_points, ntsrc, xsrc, ysrc, qsrc_ts, tsrc + call read_netcdf_discharge_data(netsrcdisfile, nr_discharge_points) ! also sets ntsrc, xsrc, ysrc, qsrc_ts, tsrc (in sfincs_data) ! ! The netcdf discharge file does not carry per-point names; auto-generate ! the same way as the 2-column srcfile path. @@ -143,6 +155,8 @@ subroutine initialize_discharges() ! if (nr_discharge_points <= 0) return ! + discharges = .true. + ! allocate(nmindsrc(nr_discharge_points)) allocate(qtsrc(nr_discharge_points)) ! @@ -284,70 +298,68 @@ subroutine update_discharges(t, dt) integer :: isrc, itsrc, nm, it_prev, it_next real*4 :: wt ! - call timer_start('Discharges') + ! qsrc is not zeroed here. The water-level update at the end of the + ! previous step clears qsrc(nm) for every active cell, and + ! update_meteo_forcing has by now accumulated prcp*area into it for + ! the current step. update_discharges and the remaining continuity + ! steps just keep adding on top. ! - ! Zero qsrc for this step. sfincs_src_structures will add to it next. + if (nr_discharge_points <= 0) return ! - !$acc kernels present( qsrc ) - qsrc = 0.0 - !$acc end kernels + call timer_start('discharges') ! - if (nr_discharge_points > 0) then - ! - ! Locate the bracketing interval in tsrc and compute the interpolation - ! weight once. Then run a single parallel loop that both interpolates - ! qtsrc and accumulates it into qsrc. - ! - it_prev = itsrclast - it_next = itsrclast + 1 + ! Locate the bracketing interval in tsrc and compute the interpolation + ! weight once. Then run a single parallel loop that both interpolates + ! qtsrc and accumulates it into qsrc. + ! + it_prev = itsrclast + it_next = itsrclast + 1 + ! + do itsrc = itsrclast, ntsrc ! - do itsrc = itsrclast, ntsrc + if (tsrc(itsrc) > t) then ! - if (tsrc(itsrc) > t) then - ! - it_prev = itsrc - 1 - it_next = itsrc - itsrclast = it_prev - exit - ! - endif + it_prev = itsrc - 1 + it_next = itsrc + itsrclast = it_prev + exit ! - enddo - ! - ! Clamp to valid bracket. If t is outside [tsrc(1), tsrc(ntsrc)] (which - ! can happen on the netcdf path, where the srcfile pre-padding is not - ! applied), hold the endpoint value rather than read out of bounds. - ! - it_prev = min(max(it_prev, 1), ntsrc - 1) - it_next = it_prev + 1 + endif ! - wt = (t - tsrc(it_prev)) / (tsrc(it_next) - tsrc(it_prev)) + enddo + ! + ! Clamp to valid bracket. If t is outside [tsrc(1), tsrc(ntsrc)] (which + ! can happen on the netcdf path, where the srcfile pre-padding is not + ! applied), hold the endpoint value rather than read out of bounds. + ! + it_prev = min(max(it_prev, 1), ntsrc - 1) + it_next = it_prev + 1 + ! + wt = (t - tsrc(it_prev)) / (tsrc(it_next) - tsrc(it_prev)) + ! + ! Atomic accumulation because two river sources (or a river and a + ! structure) can share a cell. + ! + !$acc parallel loop present( qsrc, qtsrc, nmindsrc, qsrc_ts ) private( nm ) + !$omp parallel do private( nm ) schedule ( static ) + do isrc = 1, nr_discharge_points ! - ! Atomic accumulation because two river sources (or a river and a - ! structure) can share a cell. + qtsrc(isrc) = qsrc_ts(isrc, it_prev) + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt + nm = nmindsrc(isrc) ! - !$acc parallel loop present( qsrc, qtsrc, nmindsrc, qsrc_ts ) private( nm ) - !$omp parallel do private( nm ) schedule ( static ) - do isrc = 1, nr_discharge_points + if (nm > 0) then ! - qtsrc(isrc) = qsrc_ts(isrc, it_prev) + (qsrc_ts(isrc, it_next) - qsrc_ts(isrc, it_prev)) * wt - nm = nmindsrc(isrc) + !$acc atomic update + !$omp atomic + qsrc(nm) = qsrc(nm) + qtsrc(isrc) ! - if (nm > 0) then - ! - !$acc atomic update - !$omp atomic - qsrc(nm) = qsrc(nm) + qtsrc(isrc) - ! - endif - ! - enddo - !$omp end parallel do - !$acc end parallel loop + endif ! - endif + enddo + !$omp end parallel do + !$acc end parallel loop ! - call timer_stop('Discharges') + call timer_stop('discharges') ! end subroutine ! diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 0fc1a219d..582efe572 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -24,10 +24,6 @@ subroutine initialize_domain() ! call initialize_roughness() ! - call initialize_infiltration() ! see: sfincs_infiltration.f90 (includes bucket model if infiltrationtype='bkt') - ! - call initialize_drainage_mimic() - ! call initialize_storage_volume() ! call initialize_hydro() @@ -2060,76 +2056,6 @@ subroutine initialize_roughness() end subroutine - subroutine initialize_drainage_mimic() - ! - use sfincs_data - use sfincs_ncinput - ! - implicit none - ! - integer :: nm - integer :: nchar - logical :: ok - character*256 :: varname - ! - ! Check if drainage is enabled - ! - if (drainagefile /= 'none') then - ! - drainage = .true. - ! - allocate(qdrain_rate(np)) - ! - ! - ! Spatially-varying drainage rate - ! - write(logstr,'(a)')'Info : turning on drainage mimic (spatially-varying)' - call write_log(logstr, 0) - ! - nchar = len_trim(drainagefile) - ok = check_file_exists(drainagefile, 'Drainage file', .true.) - ! - if (drainagefile(nchar - 1 : nchar) == 'nc') then - ! - varname = 'drainage_rate' - call read_netcdf_quadtree_to_sfincs(drainagefile, varname, qdrain_rate) - ! - ! Convert from mm/hr to m/s - ! - qdrain_rate = qdrain_rate / 3600.0 / 1000.0 - ! - else - ! - ! Read from binary file (assumed to be in mm/hr) - ! - open(unit = 500, file = trim(drainagefile), form = 'unformatted', access = 'stream') - read(500)qdrain_rate - close(500) - ! - ! Convert from mm/hr to m/s - ! - qdrain_rate = qdrain_rate / 3600.0 / 1000.0 - ! - endif - ! - else - ! - ! Allocate minimal arrays for OpenACC compatibility - ! - allocate(qdrain_rate(1)) - qdrain_rate = 0.0 - ! - if (manningfile(1:4) /= 'none') then - ! - call write_log('Warning : manningfile input will be ignored because SFINCS will use the friction information from sbgfile!', 1) - ! - endif - ! - endif - ! - end subroutine - - subroutine initialize_storage_volume() ! use sfincs_data diff --git a/source/src/sfincs_infiltration.f90 b/source/src/sfincs_infiltration.f90 index bc655efca..b3b4d21b7 100644 --- a/source/src/sfincs_infiltration.f90 +++ b/source/src/sfincs_infiltration.f90 @@ -633,7 +633,7 @@ subroutine update_infiltration_map(dt) real*4 :: hh_local, a real*4 :: dt ! - call timer_start('Infiltration') + call timer_start('infiltration') ! if (inftype == 'con' .or. inftype == 'c2d') then ! @@ -1029,7 +1029,26 @@ subroutine update_infiltration_map(dt) ! endif ! - call timer_stop('Infiltration') + ! Apply the resulting infiltration-rate field to the point-source field + ! qsrc (m3/s). qinfmap is m/s, so multiply by cell area and subtract. + ! qsrc already holds this step's prcp*area contribution (from + ! update_meteo_forcing) plus any discharges / src-structures updates + ! done earlier in update_continuity. + ! + !$acc parallel loop present( qsrc, qinfmap, cell_area, cell_area_m2, z_flags_iref ) + !$omp parallel do default(shared) private(nm) schedule(static) + do nm = 1, np + ! + if (crsgeo) then + qsrc(nm) = qsrc(nm) - qinfmap(nm) * cell_area_m2(nm) + else + qsrc(nm) = qsrc(nm) - qinfmap(nm) * cell_area(z_flags_iref(nm)) + endif + ! + enddo + !$omp end parallel do + ! + call timer_stop('infiltration') ! end subroutine diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index c5e723dc2..768793412 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -10,7 +10,8 @@ subroutine read_sfincs_input() use sfincs_date use sfincs_log use sfincs_error - use sfincs_src_structures, only: nr_src_structures + use sfincs_src_structures, only: nr_src_structures, drnfile + use sfincs_discharges, only: srcfile, disfile, netsrcdisfile, nr_discharge_points ! implicit none ! @@ -166,14 +167,14 @@ subroutine read_sfincs_input() call read_real_input(500, 'wavemaker_freqmax_ig', wavemaker_freqmax_ig, wavemaker_freqmax_ig) ! New variables that have no backward compatibility version ! - call read_real_input(500, 'wavemaker_tinc2ig', wavemaker_tinc2ig, -1.0) ! wavemaker ig/inc wave period ratio (set <= 0.0 to use Herbers) - call read_real_input(500, 'wavemaker_surfslope', wavemaker_surfslope, -1.0) ! wavemaker surf zone slope to compute Tp_ig with empirical run-up equation (van Ormondt et al., 2021)) - call read_real_input(500, 'wavemaker_hm0_ig_factor', wavemaker_hm0_ig_factor, 1.0) ! wavemaker Hm0 IG wave factor - call read_real_input(500, 'wavemaker_hm0_inc_factor', wavemaker_hm0_inc_factor, 1.0) ! wavemaker Hm0 inc wave factor - call read_real_input(500, 'wavemaker_gammax', wavemaker_gammax, 1.0) ! wavemaker gammax - call read_real_input(500, 'wavemaker_tpmin', wavemaker_tpmin, 1.0) ! wavemaker tpmin - call read_logical_input(500, 'wavemaker_hig', wavemaker_hig, .true.) ! wavemaker include IG waves - call read_logical_input(500, 'wavemaker_hinc', wavemaker_hinc, .false.) ! wavemaker include incident waves + call read_real_input(500, 'wavemaker_tinc2ig', wavemaker_tinc2ig, -1.0) ! wavemaker ig/inc wave period ratio (set <= 0.0 to use Herbers) + call read_real_input(500, 'wavemaker_surfslope', wavemaker_surfslope, -1.0) ! wavemaker surf zone slope to compute Tp_ig with empirical run-up equation (van Ormondt et al., 2021)) + call read_real_input(500, 'wavemaker_hm0_ig_factor', wavemaker_hm0_ig_factor, 1.0) ! wavemaker Hm0 IG wave factor + call read_real_input(500, 'wavemaker_hm0_inc_factor', wavemaker_hm0_inc_factor, 1.0) ! wavemaker Hm0 inc wave factor + call read_real_input(500, 'wavemaker_gammax', wavemaker_gammax, 1.0) ! wavemaker gammax + call read_real_input(500, 'wavemaker_tpmin', wavemaker_tpmin, 1.0) ! wavemaker tpmin + call read_logical_input(500, 'wavemaker_hig', wavemaker_hig, .true.) ! wavemaker include IG waves + call read_logical_input(500, 'wavemaker_hinc', wavemaker_hinc, .false.) ! wavemaker include incident waves ! ! Numerical parameters call read_char_input(500,'advection_scheme',advstr,'upw1') @@ -255,7 +256,6 @@ subroutine read_sfincs_input() ! Infiltration and losses call read_char_input(500,'infiltrationfile',infiltrationfile,'none') call read_char_input(500,'infiltrationtype',inftype,'none') - call read_char_input(500,'drainagefile',drainagefile,'none') ! spatially-varying drainage rates call read_char_input(500,'bucketfile',removed_input,'__removed_keyword_not_present__') if (trim(removed_input) /= '__removed_keyword_not_present__') then write(logstr,'(a)') 'Error : keyword bucketfile has been removed. Use infiltrationfile together with infiltrationtype = bkt.' @@ -266,11 +266,6 @@ subroutine read_sfincs_input() write(logstr,'(a)') 'Error : keyword bucket_loss_frac has been removed. Add bucket_loss to infiltrationfile instead.' call stop_sfincs(trim(logstr), 1) endif - call read_char_input(500,'qdrain',removed_input,'__removed_keyword_not_present__') - if (trim(removed_input) /= '__removed_keyword_not_present__') then - write(logstr,'(a)') 'Error : keyword qdrain has been removed. Use drainagefile for drainage mimic input.' - call stop_sfincs(trim(logstr), 1) - endif ! ! Legacy binary infiltration input (backward compatibility only; remove in a future cleanup) call read_char_input(500,'qinffile',qinffile,'none') @@ -732,10 +727,18 @@ subroutine read_sfincs_input() ! dthisout = bathtub_dt ! - ! Turn off some processes not needed for bathtub flooding - ! - nr_discharge_points = 0 - nr_src_structures = 0 + ! Turn off some processes not needed for bathtub flooding. + ! Forcing the input file paths to 'none' makes each initialize_* + ! routine take its standard early-return path; that way the counters + ! (nr_discharge_points, nr_src_structures, nr_urban_drainage_zones) + ! and derived logicals (discharges, drainage_structures, + ! urban_drainage) stay consistent with the "no input" state. + ! + srcfile = 'none' + disfile = 'none' + netsrcdisfile = 'none' + drnfile = 'none' + urbfile = 'none' ! meteo3d = .false. wind = .false. diff --git a/source/src/sfincs_lib.f90 b/source/src/sfincs_lib.f90 index 965f71f70..9b4449d0e 100644 --- a/source/src/sfincs_lib.f90 +++ b/source/src/sfincs_lib.f90 @@ -92,7 +92,7 @@ function sfincs_initialize() result(ierr) ! call write_startup_log() ! - call timer_start('Input') + call timer_start('input') ! call write_log('------ Preparing model simulation --------', 1) call write_log('', 1) @@ -124,6 +124,8 @@ function sfincs_initialize() result(ierr) ! call read_rug_file() ! Read runup gauge file ! + call initialize_infiltration() ! Reads qinf / scs / gai / horton / bucket infiltration inputs + ! call initialize_discharges() ! Reads dis and src file (river point discharges) ! call initialize_src_structures() ! Reads drn file (pumps / culverts / check valves / gates) @@ -161,7 +163,7 @@ function sfincs_initialize() result(ierr) ! endif ! - call timer_stop('Input') + call timer_stop('input') ! call write_processes_log() ! @@ -207,7 +209,7 @@ function sfincs_initialize() result(ierr) call write_log(logstr, 1) call write_log('', 1) ! - call timer_start('Simulation loop') + call timer_start('simulation') ! end function sfincs_initialize ! @@ -519,7 +521,7 @@ function sfincs_finalize() result(ierr) ! integer :: ierr ! - call timer_stop('Simulation loop') + call timer_stop('simulation') ! if (timestep_analysis) then ! diff --git a/source/src/sfincs_log.f90 b/source/src/sfincs_log.f90 index 1ddc61dd7..0c02c4f28 100644 --- a/source/src/sfincs_log.f90 +++ b/source/src/sfincs_log.f90 @@ -25,7 +25,7 @@ module sfincs_log ! ! write_progress_log(t, t0, t1) ! Per-timestep progress / ETA line. Called every time step from - ! the main loop in sfincs_lib. Uses timer_elapsed('Simulation loop'). + ! the main loop in sfincs_lib. Uses timer_elapsed('simulation'). ! ! write_finished_log(dtavg) ! End-of-run banner + per-phase timer summary + average time step. @@ -229,10 +229,22 @@ subroutine write_processes_log() call write_log('Infiltration : no', 1) endif ! - if (drainage) then - call write_log('Drainage : yes', 1) + if (discharges) then + call write_log('Discharges : yes', 1) else - call write_log('Drainage : no', 1) + call write_log('Discharges : no', 1) + endif + ! + if (drainage_structures) then + call write_log('Drainage structures : yes', 1) + else + call write_log('Drainage structures : no', 1) + endif + ! + if (urban_drainage) then + call write_log('Urban drainage : yes', 1) + else + call write_log('Urban drainage : no', 1) endif ! if (snapwave) then @@ -271,7 +283,7 @@ subroutine write_progress_log(t, t0, t1) ! Per-timestep progress reporter. Prints a "NN% complete, TT.T s ! remaining ..." line each time the simulated-time percentage ! crosses the next percdoneval threshold. Remaining time is - ! estimated from the wall-clock elapsed in the 'Simulation loop' + ! estimated from the wall-clock elapsed in the 'simulation' ! timer. ! ! Called every time step from the main loop in sfincs_lib. @@ -294,7 +306,7 @@ subroutine write_progress_log(t, t0, t1) ! percdonenext = 1.0 * (int(percdone) + percdoneval) ! - trun = real(timer_elapsed('Simulation loop'), 4) + trun = real(timer_elapsed('simulation'), 4) trem = trun / max(0.01*percdone, 1.0e-6) - trun ! if (int(percdone) > 0) then @@ -337,7 +349,7 @@ subroutine write_finished_log(dtavg) ! Per-phase timing summary. Percentages are relative to the total ! wall time of the simulation loop. ! - call write_timer_summary_log(1, timer_elapsed('Simulation loop'), 0.0005_8) + call write_timer_summary_log(1, timer_elapsed('simulation'), 0.0005_8) ! call write_log('', 1) ! @@ -353,7 +365,7 @@ end subroutine write_finished_log subroutine write_timer_headers_log(to_screen) ! ! Write the three 'Total time / Total simulation time / Time in input' header - ! lines to the log, using the 'Input' and 'Simulation loop' named timers. + ! lines to the log, using the 'input' and 'simulation' named timers. ! ! Called from: write_finished_log. ! @@ -362,16 +374,16 @@ subroutine write_timer_headers_log(to_screen) real(8) :: t_input real(8) :: t_loop ! - t_input = timer_elapsed('Input') - t_loop = timer_elapsed('Simulation loop') + t_input = timer_elapsed('input') + t_loop = timer_elapsed('simulation') ! - write(logstr, '(a,f10.3)') ' Total time : ', t_input + t_loop + write(logstr, '(a,f10.3)') ' Total time : ', t_input + t_loop call write_log(trim(logstr), to_screen) ! -! write(logstr, '(a,f10.3)') ' Total simulation time : ', t_loop +! write(logstr, '(a,f10.3)') ' Total simulation time : ', t_loop ! call write_log(trim(logstr), to_screen) ! - write(logstr, '(a,f10.3)') ' Time in input : ', t_input + write(logstr, '(a,f10.3)') ' Time in input : ', t_input call write_log(trim(logstr), to_screen) ! end subroutine write_timer_headers_log @@ -423,13 +435,13 @@ subroutine write_timer_summary_log(to_screen, total_wall, min_elapsed) ! ! Skip input (was already added in header) ! - if (trim(timer_name_by_index(i)) == 'Input') cycle + if (trim(timer_name_by_index(i)) == 'input') cycle ! pct = 100.0_8 * t_el / denom tname = timer_name_by_index(i) ! - write(line, '(1x,a,t25,a,f10.3,a,f5.1,a,a,a)') & - trim(tname), ': ', t_el, ' (', pct, '%)' + write(line, '(1x,a,1x,a,t31,a,f10.3,a,f5.1,a,a,a)') & + 'Time in', trim(tname), ': ', t_el, ' (', pct, '%)' ! call write_log(trim(line), to_screen) ! @@ -453,18 +465,19 @@ subroutine write_runtimes_file(unit, filename) ! open(unit, file=filename) ! - write(unit, '(f10.3,a)') real(timer_elapsed('Simulation loop'), 4), ' % total' - write(unit, '(f10.3,a)') real(timer_elapsed('Input'), 4), ' % input' - write(unit, '(f10.3,a)') real(timer_elapsed('Boundaries'), 4), ' % boundaries' - write(unit, '(f10.3,a)') real(timer_elapsed('Discharges'), 4), ' % discharges' - write(unit, '(f10.3,a)') real(timer_elapsed('Drainage structures'), 4), ' % drainage_structures' - write(unit, '(f10.3,a)') real(timer_elapsed('Meteo fields'), 4), ' % meteo1' - write(unit, '(f10.3,a)') real(timer_elapsed('Meteo forcing'), 4), ' % meteo2' - write(unit, '(f10.3,a)') real(timer_elapsed('Infiltration'), 4), ' % infiltration' - write(unit, '(f10.3,a)') real(timer_elapsed('Momentum'), 4), ' % momentum' - write(unit, '(f10.3,a)') real(timer_elapsed('Structures'), 4), ' % structures' - write(unit, '(f10.3,a)') real(timer_elapsed('Continuity'), 4), ' % continuity' - write(unit, '(f10.3,a)') real(timer_elapsed('Output'), 4), ' % output' + write(unit, '(f10.3,a)') real(timer_elapsed('simulation'), 4), ' % total' + write(unit, '(f10.3,a)') real(timer_elapsed('input'), 4), ' % input' + write(unit, '(f10.3,a)') real(timer_elapsed('boundaries'), 4), ' % boundaries' + write(unit, '(f10.3,a)') real(timer_elapsed('discharges'), 4), ' % discharges' + write(unit, '(f10.3,a)') real(timer_elapsed('drainage structures'), 4), ' % drainage_structures' + write(unit, '(f10.3,a)') real(timer_elapsed('urban drainage'), 4), ' % urban_drainage' + write(unit, '(f10.3,a)') real(timer_elapsed('meteo fields'), 4), ' % meteo1' + write(unit, '(f10.3,a)') real(timer_elapsed('meteo forcing'), 4), ' % meteo2' + write(unit, '(f10.3,a)') real(timer_elapsed('infiltration'), 4), ' % infiltration' + write(unit, '(f10.3,a)') real(timer_elapsed('momentum'), 4), ' % momentum' + write(unit, '(f10.3,a)') real(timer_elapsed('structures'), 4), ' % structures' + write(unit, '(f10.3,a)') real(timer_elapsed('continuity'), 4), ' % continuity' + write(unit, '(f10.3,a)') real(timer_elapsed('output'), 4), ' % output' ! close(unit) ! diff --git a/source/src/sfincs_meteo.f90 b/source/src/sfincs_meteo.f90 index 08de9105f..0d99d11f6 100644 --- a/source/src/sfincs_meteo.f90 +++ b/source/src/sfincs_meteo.f90 @@ -1243,7 +1243,7 @@ subroutine update_meteo_forcing(t, dt) real*4 :: oneminsmfac integer :: nm, ib ! - call timer_start('Meteo forcing') + call timer_start('meteo forcing') ! if (meteo3d) then ! @@ -1408,11 +1408,33 @@ subroutine update_meteo_forcing(t, dt) ! if (prcpfile(1:4) /= 'none') then ! - call update_precipitation_from_timeseries(t, dt) + call update_precipitation_from_timeseries(t, dt) ! endif ! - call timer_stop('Meteo forcing') + ! Apply rainfall to the point-source field qsrc (m3/s). prcp is m/s, + ! so multiply by cell area. qsrc was zeroed at the end of the previous + ! step inside the water-level update loops, so this is the first + ! accumulation into qsrc for the current step. + ! + if (precip) then + ! + !$acc parallel loop present( qsrc, prcp, cell_area, cell_area_m2, z_flags_iref ) + !$omp parallel do default(shared) private(nm) schedule(static) + do nm = 1, np + ! + if (crsgeo) then + qsrc(nm) = qsrc(nm) + prcp(nm) * cell_area_m2(nm) + else + qsrc(nm) = qsrc(nm) + prcp(nm) * cell_area(z_flags_iref(nm)) + endif + ! + enddo + !$omp end parallel do + ! + endif + ! + call timer_stop('meteo forcing') ! end subroutine @@ -1545,7 +1567,7 @@ subroutine update_meteo_fields(t) ! real*8 :: t ! - call timer_start('Meteo fields') + call timer_start('meteo fields') ! if (amufile(1:4) /= 'none' .or. netamuamvfile(1:4) /= 'none') then ! @@ -1587,7 +1609,7 @@ subroutine update_meteo_fields(t) ! endif ! - call timer_stop('Meteo fields') + call timer_stop('meteo fields') ! end subroutine diff --git a/source/src/sfincs_momentum.f90 b/source/src/sfincs_momentum.f90 index f0f89f60b..4f713056f 100644 --- a/source/src/sfincs_momentum.f90 +++ b/source/src/sfincs_momentum.f90 @@ -89,7 +89,7 @@ subroutine compute_fluxes(dt) ! logical :: iok ! - call timer_start('Momentum') + call timer_start('momentum') ! min_dt = dtmax ! @@ -770,7 +770,7 @@ subroutine compute_fluxes(dt) ! endif ! - call timer_stop('Momentum') + call timer_stop('momentum') ! end subroutine ! diff --git a/source/src/sfincs_ncinput.F90 b/source/src/sfincs_ncinput.F90 index 5b48f7870..7591b8d63 100644 --- a/source/src/sfincs_ncinput.F90 +++ b/source/src/sfincs_ncinput.F90 @@ -170,13 +170,21 @@ subroutine read_netcdf_boundary_data() - subroutine read_netcdf_discharge_data() + subroutine read_netcdf_discharge_data(netsrcdisfile, nr_discharge_points) ! - use sfincs_date + ! Read FEWS-compatible netCDF river-discharge input. netsrcdisfile is + ! passed in rather than pulled from a module to avoid a circular + ! dependency (the owning module sfincs_discharges `use`s this module + ! for the procedure). + ! + use sfincs_date use netcdf - use sfincs_data + use sfincs_data ! - implicit none + implicit none + ! + character(len=*), intent(in) :: netsrcdisfile + integer, intent(out) :: nr_discharge_points ! ! Variable names for Fews compatible netcdf input ! diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 33ebfa82a..5b560e4db 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -1692,7 +1692,7 @@ subroutine ncoutput_his_init() use sfincs_data use sfincs_structures use sfincs_src_structures, only: nr_src_structures, src_struc_name - use sfincs_discharges, only: src_name + use sfincs_discharges, only: src_name, nr_discharge_points use sfincs_urban_drainage, only: nr_urban_drainage_zones, urb_zone_name ! implicit none @@ -3220,7 +3220,7 @@ subroutine ncoutput_update_his(t,nthisout) use sfincs_runup_gauges use sfincs_snapwave use sfincs_src_structures, only: nr_src_structures, q_src_struc - use sfincs_discharges, only: qtsrc + use sfincs_discharges, only: qtsrc, nr_discharge_points use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_outfall ! implicit none @@ -4026,7 +4026,7 @@ subroutine ncoutput_map_finalize() ! endif ! - NF90(nf90_put_var(map_file%ncid, map_file%total_runtime_varid, real(timer_elapsed('Simulation loop'), 4))) + NF90(nf90_put_var(map_file%ncid, map_file%total_runtime_varid, real(timer_elapsed('simulation'), 4))) NF90(nf90_put_var(map_file%ncid, map_file%average_dt_varid, dtavg)) NF90(nf90_put_var(map_file%ncid, map_file%status_varid, error)) ! @@ -4165,6 +4165,7 @@ subroutine ncoutput_his_finalize() ! use sfincs_data use sfincs_src_structures, only: nr_src_structures + use sfincs_discharges, only: nr_discharge_points use sfincs_timers, only: timer_elapsed use sfincs_urban_drainage, only: nr_urban_drainage_zones ! @@ -4174,7 +4175,7 @@ subroutine ncoutput_his_finalize() return endif ! - NF90(nf90_put_var(his_file%ncid, his_file%total_runtime_varid, real(timer_elapsed('Simulation loop'), 4))) + NF90(nf90_put_var(his_file%ncid, his_file%total_runtime_varid, real(timer_elapsed('simulation'), 4))) NF90(nf90_put_var(his_file%ncid, his_file%average_dt_varid, dtavg)) NF90(nf90_put_var(his_file%ncid, his_file%status_varid, error)) ! @@ -4187,6 +4188,8 @@ subroutine ncoutput_his_finalize() subroutine ncoutput_add_params(ncid, varid) ! Add user params to netcdf file (both map & his) use sfincs_data + use sfincs_src_structures, only: drnfile + use sfincs_discharges, only: srcfile, disfile, netsrcdisfile ! ! Because of overlapping names, only important specific values from snapwave_data use snapwave_data, only: gamma, gammax, alpha, hmin, fw0, fw0_ig, dt, tol, dtheta, crit, nr_sweeps, baldock_opt, baldock_ratio, & @@ -4324,8 +4327,7 @@ subroutine ncoutput_add_params(ncid, varid) NF90(nf90_put_att(ncid, varid, 'amprfile',amprfile)) NF90(nf90_put_att(ncid, varid, 'infiltrationfile',infiltrationfile)) NF90(nf90_put_att(ncid, varid, 'infiltrationtype',inftype)) - NF90(nf90_put_att(ncid, varid, 'drainagefile',drainagefile)) - NF90(nf90_put_att(ncid, varid, 'qinffile',qinffile)) + NF90(nf90_put_att(ncid, varid, 'qinffile',qinffile)) NF90(nf90_put_att(ncid, varid, 'scsfile',scsfile)) NF90(nf90_put_att(ncid, varid, 'smaxfile',smaxfile)) NF90(nf90_put_att(ncid, varid, 'sefffile',sefffile)) diff --git a/source/src/sfincs_nonhydrostatic.f90 b/source/src/sfincs_nonhydrostatic.f90 index 03b68b4da..e8214f830 100644 --- a/source/src/sfincs_nonhydrostatic.f90 +++ b/source/src/sfincs_nonhydrostatic.f90 @@ -434,7 +434,7 @@ subroutine compute_nonhydrostatic(dt) real*4, dimension(:), allocatable :: AA real*4 :: relres ! - call timer_start('Non-hydrostatic') + call timer_start('non-hydrostatic') ! allocate(QQ(nrows)) allocate(AA(nr_vals_in_matrix)) @@ -733,7 +733,7 @@ subroutine compute_nonhydrostatic(dt) !$omp end do !$omp end parallel ! - call timer_stop('Non-hydrostatic') + call timer_stop('non-hydrostatic') ! end subroutine diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 1bad3e94c..c88b29433 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -57,7 +57,7 @@ subroutine initialize_openacc() !$acc timestep_analysis_required_timestep, timestep_analysis_average_required_timestep, timestep_analysis_times_wet, timestep_analysis_times_limiting, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & - !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & + !$acc bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, urban_drainage_qmax, urban_drainage_backflow_coef, & !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & !$acc urb_zone_h_threshold, urb_zone_check_valve, urb_zone_dh_design_min ) @@ -102,7 +102,7 @@ subroutine finalize_openacc() !$acc timestep_analysis_required_timestep, timestep_analysis_average_required_timestep, timestep_analysis_times_wet, timestep_analysis_times_limiting, & !$acc qinffield, qinfmap, cuminf, scs_rain, scs_Se, scs_P1, scs_F1, scs_S1, rain_T1, & !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & - !$acc qdrain_rate, bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & + !$acc bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, urban_drainage_qmax, urban_drainage_backflow_coef, & !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & !$acc urb_zone_h_threshold, urb_zone_check_valve, urb_zone_dh_design_min ) diff --git a/source/src/sfincs_output.f90 b/source/src/sfincs_output.f90 index de7c2d3e9..583c0fa3e 100644 --- a/source/src/sfincs_output.f90 +++ b/source/src/sfincs_output.f90 @@ -100,7 +100,7 @@ subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmax ! real*8 :: t ! - call timer_start('Output') + call timer_start('output') ! ! Time-varying water level output maps ! @@ -256,7 +256,7 @@ subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmax ! endif ! - call timer_stop('Output') + call timer_stop('output') ! end subroutine @@ -570,6 +570,7 @@ subroutine open_his_output() ! use sfincs_data use sfincs_src_structures, only: nr_src_structures + use sfincs_discharges, only: nr_discharge_points ! implicit none ! @@ -602,7 +603,7 @@ subroutine write_his_output(t) use sfincs_data use sfincs_crosssections use sfincs_src_structures, only: nr_src_structures, q_src_struc - use sfincs_discharges, only: qtsrc + use sfincs_discharges, only: qtsrc, nr_discharge_points ! implicit none ! diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 41d369dc0..19f1810be 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -198,6 +198,11 @@ module sfincs_src_structures real*4, dimension(:), allocatable, public :: src_struc_distance real*4, dimension(:), allocatable, public :: src_struc_fraction_open ! + ! Input file path (sfincs.inp keyword 'drnfile'); 'none' when no drainage + ! structures file is supplied. + ! + character(len=256), public :: drnfile + ! ! Cell mapping ! integer, public :: nr_src_structures @@ -312,6 +317,8 @@ subroutine initialize_src_structures() logical :: open_fires, close_fires character(len=16) :: status_str ! + drainage_structures = .false. + ! if (drnfile(1:4) == 'none') return ! ! Existence check @@ -408,6 +415,8 @@ subroutine initialize_src_structures() ! endif ! + drainage_structures = .true. + ! ! Allocate flat arrays to size nr_src_structures and seed defaults. ! allocate(src_struc_nm_in(nr_src_structures)) @@ -772,7 +781,7 @@ subroutine update_src_structures(t, dt) ! if (nr_src_structures <= 0) return ! - call timer_start('Drainage structures') + call timer_start('drainage structures') ! !$acc parallel loop present( z_volume, zs, zb, qsrc, q_src_struc, & !$acc src_struc_nm_in, src_struc_nm_out, & @@ -1115,7 +1124,7 @@ subroutine update_src_structures(t, dt) !$omp end parallel do !$acc end parallel loop ! - call timer_stop('Drainage structures') + call timer_stop('drainage structures') ! end subroutine ! diff --git a/source/src/sfincs_structures.f90 b/source/src/sfincs_structures.f90 index d25db14fc..e4a2ffb9e 100644 --- a/source/src/sfincs_structures.f90 +++ b/source/src/sfincs_structures.f90 @@ -615,7 +615,7 @@ subroutine compute_fluxes_over_structures() real*4 :: h2 real*4 :: qstruc ! - call timer_start('Structures') + call timer_start('structures') ! !$acc parallel, present(zs, q, uv, structure_uv_index, uv_index_z_nm, uv_index_z_nmu, structure_parameters, structure_type, structure_length) !$acc loop independent gang vector @@ -686,7 +686,7 @@ subroutine compute_fluxes_over_structures() enddo !$acc end parallel ! - call timer_stop('Structures') + call timer_stop('structures') ! end subroutine diff --git a/source/src/sfincs_urban_drainage.f90 b/source/src/sfincs_urban_drainage.f90 index df78c25d5..927c7f8d2 100644 --- a/source/src/sfincs_urban_drainage.f90 +++ b/source/src/sfincs_urban_drainage.f90 @@ -9,19 +9,27 @@ module sfincs_urban_drainage ! single outfall cell, so the per-zone net flux is added as a point ! source / sink there. ! - ! Per-cell discharge (drain from cell to outfall, positive sign): + ! Per-cell discharge (drain from cell to outfall, positive sign). + ! In subgrid mode the effective bed elevation is subgrid_z_zmin(nm) + ! instead of zb(nm) — this affects both the ponding-depth gate and + ! the design-head floor. ! ! dzs = zs(nm) - zs(outfall) ! if dzs > 0: - ! q = min( qmax(nm), max(zs(nm)-zb(nm),0) * cell_area(nm) / dt ) - ! gated further by h_threshold on cell water depth + ! h_cell = zs(nm) - (subgrid ? subgrid_z_zmin(nm) : zb(nm)) + ! if h_cell <= 0: skip + ! ramp = min(h_cell / h_threshold, 1) if h_threshold > 0, else 1 + ! q = min( ramp * qmax(nm), h_cell * cell_area(nm) / dt ) + ! so q ramps linearly from 0 to qmax as depth goes from 0 to + ! h_threshold, then caps at qmax. ! else: ! q = -backflow_coef(nm) * sqrt(-dzs), capped at -qmax(nm) ! suppressed if the zone has a check valve ! - ! Per-cell design-head: + ! Per-cell design-head (bed_elev is subgrid_z_zmin in subgrid mode, + ! zb otherwise): ! - ! dh_design(nm) = max( zb(nm) - zb(outfall), dh_design_min ) + ! dh_design(nm) = max( bed_elev(nm) - bed_elev(outfall), dh_design_min ) ! backflow_coef(nm) = qmax(nm) / sqrt(dh_design(nm)) ! ! qmax from the design precipitation rate: @@ -61,6 +69,7 @@ module sfincs_urban_drainage use sfincs_log use sfincs_error use sfincs_polygons + use sfincs_timers ! implicit none ! @@ -327,7 +336,11 @@ subroutine initialize_urban_drainage() ! if (io > 0) then dh_min = urb_zone_dh_design_min(iz) - dzb = max(zb(nm) - zb(io), dh_min) + if (subgrid) then + dzb = max(subgrid_z_zmin(nm) - subgrid_z_zmin(io), dh_min) + else + dzb = max(zb(nm) - zb(io), dh_min) + endif urban_drainage_backflow_coef(nm) = urban_drainage_qmax(nm) / sqrt(dzb) endif ! @@ -368,21 +381,25 @@ subroutine update_urban_drainage(t, dt) real*4, intent(in) :: dt ! integer :: nm, iz, io - real*4 :: dzs, qd, area_nm, h_cell + real*4 :: dzs, qd, area_nm, h_cell, ramp ! if (nr_urban_drainage_zones <= 0) return ! + call timer_start('urban drainage') + ! !$acc kernels present(urban_drainage_q_outfall) urban_drainage_q_outfall = 0.0 !$acc end kernels ! - !$acc parallel loop present( qsrc, zs, zb, cell_area, cell_area_m2, z_flags_iref, & + !$acc parallel loop present( qsrc, zs, zb, subgrid_z_zmin, cell_area, cell_area_m2, z_flags_iref, & !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, & !$acc urban_drainage_qmax, urban_drainage_backflow_coef, & !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & - !$acc urb_zone_h_threshold, urb_zone_check_valve ) + !$acc urb_zone_h_threshold, urb_zone_check_valve ) & + !$acc reduction(+:urban_drainage_q_outfall) !$omp parallel do default(shared) & - !$omp private(nm, iz, io, dzs, qd, area_nm, h_cell) schedule(static) + !$omp private(nm, iz, io, dzs, qd, area_nm, h_cell, ramp) & + !$omp reduction(+:urban_drainage_q_outfall) schedule(static) do nm = 1, np ! iz = urban_drainage_zone_indices(nm) @@ -395,10 +412,26 @@ subroutine update_urban_drainage(t, dt) ! if (dzs > 0.0) then ! - ! Drain from cell. Gate on cell ponding depth above grate. + ! Drain from cell. In subgrid mode the effective bed is the + ! subgrid minimum, not the cell-center zb. + ! + if (subgrid) then + h_cell = zs(nm) - subgrid_z_zmin(nm) + else + h_cell = zs(nm) - zb(nm) + endif + if (h_cell <= 0.0) cycle ! - h_cell = zs(nm) - zb(nm) - if (h_cell <= urb_zone_h_threshold(iz)) cycle + ! Linear ramp on the design-rate cap: zero discharge at h = 0, + ! full qmax at h >= h_threshold. Removes the wiggle that the + ! hard on/off gate produced near the threshold. Reduces to the + ! hard cap when h_threshold = 0 (default). + ! + if (urb_zone_h_threshold(iz) > 0.0) then + ramp = min(h_cell / urb_zone_h_threshold(iz), 1.0) + else + ramp = 1.0 + endif ! if (crsgeo) then area_nm = cell_area_m2(nm) @@ -406,7 +439,7 @@ subroutine update_urban_drainage(t, dt) area_nm = cell_area(z_flags_iref(nm)) endif ! - qd = min(urban_drainage_qmax(nm), h_cell * area_nm / dt) + qd = min(ramp * urban_drainage_qmax(nm), h_cell * area_nm / dt) ! else ! @@ -420,14 +453,13 @@ subroutine update_urban_drainage(t, dt) endif ! ! qsrc(nm) is unique per iteration (loop is over nm), no race. - ! The race is on urban_drainage_q_outfall(iz): multiple threads - ! (or gangs on device) may process cells belonging to the same - ! zone, so guard the zone-accumulator with atomic. + ! The zone accumulator urban_drainage_q_outfall(iz) is summed via + ! the reduction(+) clause on the parent directive, so each thread + ! / gang gets a private copy that is combined at loop end — no + ! serializing atomic needed in the common hot path. ! qsrc(nm) = qsrc(nm) - qd ! - !$acc atomic update - !$omp atomic urban_drainage_q_outfall(iz) = urban_drainage_q_outfall(iz) + qd ! urban_drainage_cumulative_volume(nm) = urban_drainage_cumulative_volume(nm) + qd * dt @@ -450,6 +482,8 @@ subroutine update_urban_drainage(t, dt) ! enddo ! + call timer_stop('urban drainage') + ! end subroutine ! !-----------------------------------------------------------------------------------------------------! diff --git a/source/src/sfincs_wavemaker.f90 b/source/src/sfincs_wavemaker.f90 index 4660bdfad..65ffc3c86 100644 --- a/source/src/sfincs_wavemaker.f90 +++ b/source/src/sfincs_wavemaker.f90 @@ -1365,7 +1365,7 @@ subroutine update_wavemaker_fluxes(t, dt) real*4, dimension(:), allocatable :: wavemaker_forcing_tp_ig_t real*4, dimension(:), allocatable :: wavemaker_forcing_setup_t ! - call timer_start('Wavemaker') + call timer_start('wavemaker') ! ! Factors for double-exponential filtering ! @@ -1682,7 +1682,7 @@ subroutine update_wavemaker_fluxes(t, dt) enddo !$acc end parallel ! - call timer_stop('Wavemaker') + call timer_stop('wavemaker') ! end subroutine From 04edc98fe63d4856484fbbe40a34c5f3ee74eec4 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 19:45:35 +0200 Subject: [PATCH 43/65] Refactor sfincs_input parser and docs Rework the sfincs_input module: reorganized and documented the read_sfincs_input driver, clarified behavior of the flat keyword/value parser, and added detailed comments for the per-type read_* helpers. Modernized keyword handling and defaults, preserved backward-compatible legacy keywords (with new wavemaker_<...> overrides), and replaced several integer switch keywords with logical flags/clearer variable names. Removed obsolete switch declarations from sfincs_data.f90 and improved ordering/clarity of domain, forcing, infiltration and output option reads. Overall this is a refactor to improve readability, maintainability and keyword semantics without changing external file formats. --- source/src/sfincs_data.f90 | 14 - source/src/sfincs_input.f90 | 1802 +++++++++++++++----------------- source/src/sfincs_ncoutput.F90 | 28 +- 3 files changed, 877 insertions(+), 967 deletions(-) diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 0f5747028..82ed79cf4 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -256,20 +256,6 @@ module sfincs_data logical :: bathtub logical :: bathtub_snapwave !!! - !!! sfincs_input.f90 switches - integer storevelmax - integer storefluxmax - integer storevel - integer storecumprcp - integer storetwet - integer storetzsmax - integer storeqdrain - integer storezvolume - integer storestoragevolume - integer storemeteo - integer storehsubgrid - integer wrttimeoutput - !!! !!! Static data !!! integer*4 :: np diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 768793412..3d7829e51 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -1,1064 +1,988 @@ module sfincs_input - -contains - - subroutine read_sfincs_input() - ! - ! Reads sfincs.inp - ! - use sfincs_data - use sfincs_date - use sfincs_log - use sfincs_error - use sfincs_src_structures, only: nr_src_structures, drnfile - use sfincs_discharges, only: srcfile, disfile, netsrcdisfile, nr_discharge_points - ! - implicit none - ! - integer*8 dtsec - ! - ! Temporary variables - ! - integer iradstr - integer igeo - integer icoriolis - integer iamprblock - integer iglobal - integer itsunamitime - integer ispinupmeteo - integer isnapwave - integer iwindmax - integer iwind - integer ioutfixed - integer iadvection - integer istorefw - integer istorewavdir - integer imanning2d - integer isubgrid - integer iwavemaker - integer iwavemaker_spectrum - integer ispwprecip - logical iviscosity - logical ok - ! - character*256 wmsigstr - character*256 advstr - character*256 removed_input - ! - ok = check_file_exists('sfincs.inp', 'SFINCS input file', .true.) - ! - open(500, file='sfincs.inp') - ! - call read_int_input(500,'mmax',mmax,0) - call read_int_input(500,'nmax',nmax,0) - call read_real_input(500,'dx',dx,0.0) - call read_real_input(500,'dy',dy,0.0) - call read_real_input(500,'x0',x0,0.0) - call read_real_input(500,'y0',y0,0.0) - call read_real_input(500,'rotation',rotation,0.0) - call read_char_input(500,'tref',trefstr,'none') - call read_char_input(500,'tstart',tstartstr,'20000101 000000') - call read_char_input(500,'tstop',tstopstr,'20000101 000000') - call read_real_input(500,'tspinup',tspinup,0.0) - call read_real_input(500,'t0out',t0out,-999.0) - call read_real_input(500,'t1out',t1out,-999.0) - call read_real_input(500,'dtout',dtmapout,0.0) - call read_real_input(500,'dtmaxout',dtmaxout,9999999.0) - call read_real_input(500,'dtrstout',dtrstout,0.0) - call read_real_input(500,'trstout',trst,-999.0) - call read_real_input(500,'dthisout',dthisout,600.0) - call read_real_input(500,'dtwave',dtwave,3600.0) - call read_real_input(500,'dtwnd',dtwindupd,1800.0) - call read_real_input(500,'alpha',alfa,0.50) - call read_real_input(500,'theta',theta,1.0) - call read_real_input(500,'hmin_cfl',hmin_cfl,0.1) - call read_real_input(500,'manning',manning,0.04) - call read_real_input(500,'manning_land',manning_land,-999.0) - call read_real_input(500,'manning_sea',manning_sea,-999.0) - call read_real_input(500,'rgh_lev_land',rghlevland,0.0) - call read_real_input(500,'zsini',zini,0.0) - call read_real_input(500,'qinf',qinf,0.0) - call read_real_input(500,'dtmax',dtmax,60.0) - call read_real_input(500,'huthresh',huthresh,0.05) - call read_real_input(500,'huvmin', huvmin, 0.0) ! Minimum depth for calculating velocity (uv = q / max(hu, huvmin) used for output and advection) - call read_real_input(500,'rhoa',rhoa,1.25) - call read_real_input(500,'rhow',rhow,1024.0) - call read_char_input(500,'inputformat',inputtype,'bin') - call read_char_input(500,'outputformat',outputtype,'net') - call read_char_input(500,'outputtype_map',outputtype_map,'nil') - call read_char_input(500,'outputtype_his',outputtype_his,'nil') - call read_int_input(500,'nc_deflate_level',nc_deflate_level,2) - call read_int_input(500,'bndtype',bndtype,1) - call read_int_input(500,'advection',iadvection,1) - call read_real_input(500,'latitude',latitude,0.0) - call read_real_input(500,'pavbnd',pavbnd,0.0) - call read_real_input(500,'gapres',gapres,101200.0) - call read_int_input(500,'baro',baro,1) - call read_char_input(500,'utmzone',utmzone,'nil') - call read_int_input(500,'epsg',epsg,0) - call read_char_input(500,'epsg',epsg_code,'nil') - call read_real_input(500, 'advlim', advlim, 1.0) - call read_real_input(500,'slopelim',slopelim,9999.9) - call read_real_input(500,'qinf_zmin',qinf_zmin,0.0) - call read_real_input(500,'btfilter',btfilter,60.0) - call read_real_input(500,'sfacinf',sfacinf,0.2) - call read_int_input(500,'radstr',iradstr,0) - call read_int_input(500,'crsgeo',igeo,0) - call read_logical_input(500, 'coriolis', coriolis, .true.) - call read_int_input(500,'amprblock',iamprblock,1) - call read_real_input(500,'spwmergefrac',spw_merge_frac,0.5) - call read_int_input(500,'usespwprecip',ispwprecip,1) - call read_int_input(500,'global',iglobal,0) - call read_real_input(500,'nuvisc',nuviscdim,0.01) - call read_logical_input(500,'viscosity',iviscosity,.false.) - call read_int_input(500,'spinup_meteo', ispinupmeteo, 0) - call read_real_input(500,'waveage',waveage,-999.0) - call read_int_input(500,'snapwave', isnapwave, 0) - call read_int_input(500,'dtoutfixed', ioutfixed, 1) - ! - ! Wave maker parameters - ! - ! First read some deprecated keywords for backward compatibility (to be removed later) - ! - call read_char_input(500, 'wavemaker_wvmfile', wavemaker_wvmfile, 'none') ! wavemaker polyline file - if (wavemaker_wvmfile(1:4) == 'none') call read_char_input(500, 'wvmfile', wavemaker_wvmfile, 'none') ! old keyword - ! - call read_char_input(500, 'wavemaker_wfpfile', wavemaker_wfpfile, 'none') ! wavemaker forcing points file - if (wavemaker_wfpfile(1:4) == 'none') call read_char_input(500, 'wfpfile', wavemaker_wfpfile, 'none') - ! - call read_char_input(500, 'wavemaker_whifile', wavemaker_whifile, 'none') ! wavemaker wave height time series file - if (wavemaker_whifile(1:4) == 'none') call read_char_input(500, 'whifile', wavemaker_whifile, 'none') - ! - call read_char_input(500, 'wavemaker_wtifile', wavemaker_wtifile, 'none') ! wavemaker wave period time series file - if (wavemaker_wtifile(1:4) == 'none') call read_char_input(500, 'wtifile', wavemaker_wtifile, 'none') - ! - call read_char_input(500, 'wavemaker_wstfile', wavemaker_wstfile, 'none') ! wavemaker wave set-up time series file - if (wavemaker_wstfile(1:4) == 'none') call read_char_input(500, 'wstfile', wavemaker_wstfile, 'none') - ! - ! Overwrite with new keywords, if provided by user (for backward compatibility, to be removed later) - call read_real_input(500, 'wmtfilter', wavemaker_filter_time, 600.0) ! time scale for wavemaker filter (in seconds) - call read_real_input(500, 'wavemaker_filter_time', wavemaker_filter_time, wavemaker_filter_time) - ! - call read_real_input(500, 'wmfred', wavemaker_filter_fred, 0.99) ! fred for wavemaker filter (reduces chance of jets) - call read_real_input(500, 'wavemaker_filter_fred', wavemaker_filter_fred, wavemaker_filter_fred) - ! - call read_char_input(500, 'wmsignal', wmsigstr, 'spectrum') ! wavemaker signal type (spectrum or monochromatic) - call read_char_input(500, 'wavemaker_signal', wmsigstr, trim(wmsigstr)) - ! - call read_real_input(500, 'wmhmin', wavemaker_hmin, 0.1) ! minimum water depth for wave generation (in m) - call read_real_input(500, 'wavemaker_hmin', wavemaker_hmin, wavemaker_hmin) ! - call read_int_input(500, 'nfreqsinc', wavemaker_nfreqs_inc, 100) ! wavemaker number of frequencies for incident wave spectrum - call read_int_input(500, 'wavemaker_nfreqs_inc', wavemaker_nfreqs_inc, wavemaker_nfreqs_inc) + ! Parser for the SFINCS main input file `sfincs.inp` plus the small set + ! of primitive helpers that read one keyword at a time from that file. ! - call read_real_input(500, 'freqmininc', wavemaker_freqmin_inc, 0.04) ! wavemaker minimum frequency for incident wave spectrum (in Hz) - call read_real_input(500, 'wavemaker_freqmin_inc', wavemaker_freqmin_inc, wavemaker_freqmin_inc) + ! `sfincs.inp` is a flat keyword / value text file (one `key = value` + ! pair per line, comment lines start with `#`, `!`, or `@`). A read is + ! performed by rewinding the file, scanning until the matching key is + ! found, and extracting the value string. When the key is absent, the + ! caller's supplied default is returned. ! - call read_real_input(500, 'freqmaxinc', wavemaker_freqmax_inc, 1.0) ! wavemaker maximum frequency for incident wave spectrum (in Hz) - call read_real_input(500, 'wavemaker_freqmax_inc', wavemaker_freqmax_inc, wavemaker_freqmax_inc) + ! The module does not own the variables it fills — it writes directly + ! into module-level state declared in sfincs_data, sfincs_src_structures, + ! sfincs_discharges, etc. ! - call read_int_input(500, 'nfreqsig', wavemaker_nfreqs_ig, 100) ! wavemaker number of frequencies for IG wave spectrum - call read_int_input(500, 'wavemaker_nfreqs_ig', wavemaker_nfreqs_ig, wavemaker_nfreqs_ig) + ! Subroutines: ! - call read_real_input(500, 'freqminig', wavemaker_freqmin_ig, 0.0) ! wavemaker minimum frequency for IG wave spectrum (in Hz) - call read_real_input(500, 'wavemaker_freqmin_ig', wavemaker_freqmin_ig, wavemaker_freqmin_ig) + ! read_sfincs_input() + ! Main driver. Opens sfincs.inp, calls the per-type helpers below + ! once per keyword, then derives secondary flags (e.g. crsgeo vs. + ! Coriolis, subgrid vs. regular, bathtub overrides). Called once + ! from sfincs_initialize (sfincs_lib). ! - call read_real_input(500, 'freqmaxig', wavemaker_freqmax_ig, 0.1) ! wavemaker maximum frequency for IG wave spectrum (in Hz) - call read_real_input(500, 'wavemaker_freqmax_ig', wavemaker_freqmax_ig, wavemaker_freqmax_ig) - ! New variables that have no backward compatibility version + ! read_real_input(fileid, keyword, value, default) + ! Read one real*4 keyword. Called from read_sfincs_input. ! - call read_real_input(500, 'wavemaker_tinc2ig', wavemaker_tinc2ig, -1.0) ! wavemaker ig/inc wave period ratio (set <= 0.0 to use Herbers) - call read_real_input(500, 'wavemaker_surfslope', wavemaker_surfslope, -1.0) ! wavemaker surf zone slope to compute Tp_ig with empirical run-up equation (van Ormondt et al., 2021)) - call read_real_input(500, 'wavemaker_hm0_ig_factor', wavemaker_hm0_ig_factor, 1.0) ! wavemaker Hm0 IG wave factor - call read_real_input(500, 'wavemaker_hm0_inc_factor', wavemaker_hm0_inc_factor, 1.0) ! wavemaker Hm0 inc wave factor - call read_real_input(500, 'wavemaker_gammax', wavemaker_gammax, 1.0) ! wavemaker gammax - call read_real_input(500, 'wavemaker_tpmin', wavemaker_tpmin, 1.0) ! wavemaker tpmin - call read_logical_input(500, 'wavemaker_hig', wavemaker_hig, .true.) ! wavemaker include IG waves - call read_logical_input(500, 'wavemaker_hinc', wavemaker_hinc, .false.) ! wavemaker include incident waves + ! read_real_array_input(fileid, keyword, value, default, nr) + ! Read one space-separated real*4 array keyword. Called from + ! read_sfincs_input. ! - ! Numerical parameters - call read_char_input(500,'advection_scheme',advstr,'upw1') - call read_real_input(500,'btrelax',btrelax,3600.0) - call read_logical_input(500,'wiggle_suppression', wiggle_suppression, .true.) - call read_real_input(500, 'structure_relax', structure_relax, 4.0) - call read_real_input(500,'wiggle_factor',wiggle_factor,0.1) - call read_real_input(500,'wiggle_threshold',wiggle_threshold,0.1) - call read_real_input(500, 'uvlim', uvlim, 10.0) - call read_real_input(500, 'uvmax', uvmax, 1000.0) - call read_logical_input(500,'friction2d',friction2d,.true.) - call read_logical_input(500,'advection_mask',advection_mask,.true.) - ! call read_real_input(500, 'dzdsbnd', dzdsbnd, 0.0001) - ! call read_real_input(500, 'manningbnd', manningbnd, 0.024) - call read_real_input(500, 'nuviscfac', nuviscfac, 100.0) - call read_logical_input(500, 'nonh', nonhydrostatic, .false.) - call read_real_input(500, 'nh_fnudge', nh_fnudge, 0.9) - call read_real_input(500, 'nh_tstop', nh_tstop, -999.0) - call read_real_input(500, 'nh_tol', nh_tol, 0.001) - call read_int_input(500, 'nh_itermax', nh_itermax, 100) - call read_logical_input(500, 'h73table', h73table, .false.) - call read_real_input(500, 'rugdepth', runup_gauge_depth, 0.05) - call read_logical_input(500, 'wave_enhanced_roughness', wave_enhanced_roughness, .false.) - call read_logical_input(500, 'use_bcafile', use_bcafile, .true.) - call read_real_input(500, 'factor_wind', factor_wind, 1.0) - call read_real_input(500, 'factor_pres', factor_pres, 1.0) - call read_real_input(500, 'factor_prcp', factor_prcp, 1.0) - call read_real_input(500, 'factor_spw_size', factor_spw_size, 1.0) - call read_logical_input(500, 'bathtub', bathtub, .false.) - call read_real_input(500, 'bathtub_fachs', bathtub_fac_hs, 0.2) - call read_real_input(500, 'bathtub_dt', bathtub_dt, -999.0) + ! read_int_input(fileid, keyword, value, default) + ! Read one integer keyword. Called from read_sfincs_input. ! - ! Domain + ! read_char_input(fileid, keyword, value, default) + ! Read one character-string keyword. Called from read_sfincs_input. ! - call read_char_input(500,'qtrfile',qtrfile,'none') - call read_char_input(500,'depfile',depfile,'none') - call read_char_input(500,'inifile',zsinifile,'none') - call read_char_input(500,'rstfile',rstfile,'none') - call read_char_input(500,'mskfile',mskfile,'none') - call read_char_input(500,'indexfile',indexfile,'none') - call read_char_input(500,'cstfile',cstfile,'none') - call read_char_input(500,'sbgfile',sbgfile,'none') - call read_char_input(500,'thdfile',thdfile,'none') - call read_char_input(500,'weirfile',weirfile,'none') - call read_char_input(500,'manningfile',manningfile,'none') - call read_char_input(500,'drnfile',drnfile,'none') - call read_char_input(500,'urbfile',urbfile,'none') - call read_char_input(500,'volfile',volfile,'none') + ! read_logical_input(fileid, keyword, value, default) + ! Read one logical keyword. Accepts `1/0`, `y/n`, `t/f` (upper or + ! lower) as true/false. Called from read_sfincs_input. ! - ! Forcing + ! read_line(line0, keystr, valstr) + ! Strip tab/line-ending noise, split `key = value` on the first `=`, + ! strip any trailing `# ...` inline comment. Called from each of + ! the read_*_input helpers. ! - call read_char_input(500,'bndfile',bndfile,'none') - call read_char_input(500,'bzsfile',bzsfile,'none') - call read_char_input(500,'bcafile',bcafile,'none') - call read_char_input(500,'bzifile',bzifile,'none') - call read_char_input(500, 'bdrfile', bdrfile, 'none') - call read_char_input(500,'srcfile',srcfile,'none') - call read_char_input(500,'disfile',disfile,'none') - call read_char_input(500,'spwfile',spwfile,'none') - call read_char_input(500,'wndfile',wndfile,'none') - call read_char_input(500,'prcfile',prcpfile,'none') - if (prcpfile(1:4) == 'none') then - ! Try with old keyword - call read_char_input(500,'precipfile',prcpfile,'none') - endif - call read_char_input(500,'amufile',amufile,'none') - call read_char_input(500,'amvfile',amvfile,'none') - call read_char_input(500,'ampfile',ampfile,'none') - call read_char_input(500,'amprfile',amprfile,'none') - call read_char_input(500,'z0lfile',z0lfile,'none') - ! Netcdf input - call read_char_input(500,'netbndbzsbzifile',netbndbzsbzifile,'none') - call read_char_input(500,'netsrcdisfile',netsrcdisfile,'none') - call read_char_input(500,'netamuamvfile',netamuamvfile,'none') - call read_char_input(500,'netamprfile',netamprfile,'none') - call read_char_input(500,'netampfile',netampfile,'none') - call read_char_input(500,'netspwfile',netspwfile,'none') + ! notabs(instr, outstr, ilen) + ! Expand embedded tab characters into spaces preserving 8-column + ! tab stops. Called from read_line. ! - ! Infiltration and losses - call read_char_input(500,'infiltrationfile',infiltrationfile,'none') - call read_char_input(500,'infiltrationtype',inftype,'none') - call read_char_input(500,'bucketfile',removed_input,'__removed_keyword_not_present__') - if (trim(removed_input) /= '__removed_keyword_not_present__') then - write(logstr,'(a)') 'Error : keyword bucketfile has been removed. Use infiltrationfile together with infiltrationtype = bkt.' - call stop_sfincs(trim(logstr), 1) - endif - call read_char_input(500,'bucket_loss_frac',removed_input,'__removed_keyword_not_present__') - if (trim(removed_input) /= '__removed_keyword_not_present__') then - write(logstr,'(a)') 'Error : keyword bucket_loss_frac has been removed. Add bucket_loss to infiltrationfile instead.' - call stop_sfincs(trim(logstr), 1) - endif - ! - ! Legacy binary infiltration input (backward compatibility only; remove in a future cleanup) - call read_char_input(500,'qinffile',qinffile,'none') - ! Curve Number files (legacy binary support) - call read_char_input(500,'scsfile',scsfile,'none') - call read_char_input(500,'smaxfile',smaxfile,'none') - call read_char_input(500,'sefffile',sefffile,'none') - ! Green and Ampt files (legacy binary support) - call read_char_input(500,'psifile',psifile,'none') ! suction head [mm] - call read_char_input(500,'sigmafile',sigmafile,'none') ! maximum moisture deficit theta_dmax [-] - call read_char_input(500,'ksfile',ksfile,'none') ! saturated hydraulic conductivity [mm/hr] - ! Horton files (legacy binary support) - call read_char_input(500,'f0file',f0file,'none') ! Maximum (Initial) Infiltration Capacity, F0 - call read_char_input(500,'fcfile',fcfile,'none') ! Minimum (Asymptotic) Infiltration Rate, Fc - call read_char_input(500,'kdfile',kdfile,'none') ! k = empirical constant (hr-1) of decay - call read_real_input(500,'horton_kr_kd',horton_kr_kd,10.0) ! recovery goes 10 times as SLOW as decay - ! - ! Output - call read_char_input(500,'obsfile',obsfile,'none') - call read_char_input(500,'crsfile',crsfile,'none') - call read_char_input(500, 'rugfile', rugfile, 'none') - call read_int_input(500,'storevelmax',storevelmax,0) - call read_int_input(500,'storefluxmax',storefluxmax,0) - call read_int_input(500,'storevel',storevel,0) - call read_int_input(500,'storecumprcp',storecumprcp,0) - call read_int_input(500,'storetwet',storetwet,0) - call read_int_input(500,'storetzsmax',storetzsmax,0) - call read_int_input(500,'storehsubgrid',storehsubgrid,0) - call read_logical_input(500, 'storehmean', store_hmean, .false.) - call read_real_input(500,'twet_threshold',twet_threshold,0.01) - call read_int_input(500,'store_tsunami_arrival_time',itsunamitime,0) - call read_real_input(500,'tsunami_arrival_threshold',tsunami_arrival_threshold,0.01) - call read_logical_input(500,'timestep_analysis',timestep_analysis,.false.) - call read_int_input(500,'storeqdrain',storeqdrain,1) - call read_logical_input(500,'store_river_discharge',store_river_discharge,.false.) - call read_logical_input(500,'store_urban_drainage_discharge',store_urban_drainage_discharge,.false.) - call read_logical_input(500,'store_cumulative_urban_drainage',store_cumulative_urban_drainage,.false.) - call read_int_input(500,'storezvolume',storezvolume,0) - call read_int_input(500,'storestoragevolume',storestoragevolume,0) - call read_int_input(500,'writeruntime',wrttimeoutput,0) - call read_logical_input(500,'debug',debug,.false.) - call read_int_input(500,'storemeteo',storemeteo,0) - call read_int_input(500,'storemaxwind',iwindmax,0) - call read_int_input(500,'storefw', istorefw, 0) - call read_int_input(500,'storewavdir', istorewavdir, 0) - call read_logical_input(500,'regular_output_on_mesh',use_quadtree_output,.false.) - call read_logical_input(500, 'store_dynamic_bed_level', store_dynamic_bed_level, .false.) - call read_logical_input(500,'snapwave_use_nearest',snapwave_use_nearest,.true.) - call read_int_input(500,'percentage_done',percdoneval,5) - ! Limit to range (0,100) - percdoneval = max(min(percdoneval,100), 0) - ! - ! Coupled SnapWave solver related - call read_int_input(500,'snapwave_wind',iwind,0) - call read_real_input(500,'snapwave_waveforces_factor',waveforces_factor,1.0) - ! - ! Wind drag + +contains ! - call read_int_input(500,'cdnrb',cd_nr,0) + !-----------------------------------------------------------------------------------------------------! ! - if (cd_nr==0) then + subroutine read_sfincs_input() ! - ! Use defaults + ! Top-level driver: open sfincs.inp, pull every keyword the solver + ! knows about into the appropriate module-level variable, then + ! compute derived flags (CRS / Coriolis, subgrid vs. regular, + ! wavemaker modes, bathtub overrides, advection scheme). + ! + ! Called from: sfincs_initialize (sfincs_lib). + ! + use sfincs_data + use sfincs_date + use sfincs_log + use sfincs_error + use sfincs_src_structures, only: drnfile + use sfincs_discharges, only: srcfile, disfile, netsrcdisfile + ! + implicit none + ! + integer*8 :: dtsec + logical :: ok + character(len=256) :: wmsigstr + character(len=256) :: advstr + character(len=256) :: removed_input + ! + ok = check_file_exists('sfincs.inp', 'SFINCS input file', .true.) + ! + open(500, file='sfincs.inp') + ! + ! Grid geometry and time window + ! + call read_int_input(500, 'mmax', mmax, 0) ! number of grid cells in m-direction + call read_int_input(500, 'nmax', nmax, 0) ! number of grid cells in n-direction + call read_real_input(500, 'dx', dx, 0.0) ! cell size in m-direction (m) + call read_real_input(500, 'dy', dy, 0.0) ! cell size in n-direction (m) + call read_real_input(500, 'x0', x0, 0.0) ! grid origin x (m or deg) + call read_real_input(500, 'y0', y0, 0.0) ! grid origin y (m or deg) + call read_real_input(500, 'rotation', rotation, 0.0) ! grid rotation (deg, counter-clockwise from east) + call read_char_input(500, 'tref', trefstr, 'none') ! reference time (yyyymmdd HHMMSS); defaults to tstart + call read_char_input(500, 'tstart', tstartstr, '20000101 000000') ! simulation start time + call read_char_input(500, 'tstop', tstopstr, '20000101 000000') ! simulation stop time + call read_real_input(500, 'tspinup', tspinup, 0.0) ! spin-up interval after t0 (s) + call read_real_input(500, 't0out', t0out, -999.0) ! output start time (s rel. tref); -999 = t0 + call read_real_input(500, 't1out', t1out, -999.0) ! output stop time (s rel. tref); -999 = t1 + call read_real_input(500, 'dtout', dtmapout, 0.0) ! map output interval (s); 0 = no map output + call read_real_input(500, 'dtmaxout', dtmaxout, 9999999.0) ! zsmax etc. interval (s); 0 = end-of-run only + call read_real_input(500, 'dtrstout', dtrstout, 0.0) ! restart interval (s); 0 = no periodic restart + call read_real_input(500, 'trstout', trst, -999.0) ! single restart time (s rel. tref); -999 = unused + call read_real_input(500, 'dthisout', dthisout, 600.0) ! his output interval (s) + call read_real_input(500, 'dtwave', dtwave, 3600.0) ! SnapWave update interval (s) + call read_real_input(500, 'dtwnd', dtwindupd, 1800.0) ! 2D meteo update interval (s) + ! + ! Solver and physical constants + ! + call read_real_input(500, 'alpha', alfa, 0.50) ! CFL Courant factor + call read_real_input(500, 'theta', theta, 1.0) ! semi-implicit theta; <1 adds smoothing + call read_real_input(500, 'hmin_cfl', hmin_cfl, 0.1) ! minimum depth used in CFL check (m) + call read_real_input(500, 'manning', manning, 0.04) ! uniform Manning n (s/m^(1/3)) + call read_real_input(500, 'manning_land', manning_land, -999.0) ! Manning n above rghlevland (s/m^(1/3)) + call read_real_input(500, 'manning_sea', manning_sea, -999.0) ! Manning n below rghlevland (s/m^(1/3)) + call read_real_input(500, 'rgh_lev_land', rghlevland, 0.0) ! bed level separating land/sea friction (m) + call read_real_input(500, 'zsini', zini, 0.0) ! initial water level (m) + call read_real_input(500, 'qinf', qinf, 0.0) ! uniform infiltration rate (mm/hr); converted below + call read_real_input(500, 'dtmax', dtmax, 60.0) ! upper bound on computational dt (s) + call read_real_input(500, 'huthresh', huthresh, 0.05) ! wet/dry depth threshold (m) + call read_real_input(500, 'huvmin', huvmin, 0.0) ! minimum depth for uv = q / max(hu, huvmin) (output + advection) + call read_real_input(500, 'rhoa', rhoa, 1.25) ! air density (kg/m3) + call read_real_input(500, 'rhow', rhow, 1024.0) ! water density (kg/m3) + call read_char_input(500, 'inputformat', inputtype, 'bin') ! legacy bin/asc toggle for binary inputs + call read_char_input(500, 'outputformat', outputtype, 'net') ! global output format (bin/asc/net) + call read_char_input(500, 'outputtype_map', outputtype_map, 'nil') ! map-file output format (nil = follow outputformat) + call read_char_input(500, 'outputtype_his', outputtype_his, 'nil') ! his-file output format (nil = follow outputformat) + call read_int_input(500, 'nc_deflate_level', nc_deflate_level, 2) ! netCDF deflate level (0-9) + call read_int_input(500, 'bndtype', bndtype, 1) ! boundary condition type + call read_logical_input(500, 'advection', advection, .true.) ! enable momentum advection terms + call read_real_input(500, 'latitude', latitude, 0.0) ! reference latitude for projected Coriolis (deg) + call read_real_input(500, 'pavbnd', pavbnd, 0.0) ! atmospheric pressure applied at boundary (Pa) + call read_real_input(500, 'gapres', gapres, 101200.0) ! atmospheric reference pressure (Pa) + call read_int_input(500, 'baro', baro, 1) ! include atmospheric-pressure gradient (1=on, 0=off) + call read_char_input(500, 'utmzone', utmzone, 'nil') ! UTM zone string (e.g. '17N') + call read_int_input(500, 'epsg', epsg, 0) ! EPSG integer code for the grid + call read_char_input(500, 'epsg', epsg_code, 'nil') ! EPSG as string (fallback) + call read_real_input(500, 'advlim', advlim, 1.0) ! cap on advection term + call read_real_input(500, 'slopelim', slopelim, 9999.9) ! cap on bed-slope water-level gradient + call read_real_input(500, 'qinf_zmin', qinf_zmin, 0.0) ! minimum bed level for infiltration to apply (m) + call read_real_input(500, 'btfilter', btfilter, 60.0) ! bathtub filter time scale (s) + call read_real_input(500, 'sfacinf', sfacinf, 0.2) ! SCS initial-abstraction fraction (0.2S) + call read_logical_input(500, 'radstr', radstr, .false.) ! radiation-stress forcing from SnapWave + call read_logical_input(500, 'crsgeo', crsgeo, .false.) ! interpret grid coords as geographic (WGS84) + call read_logical_input(500, 'coriolis', coriolis, .true.) ! include Coriolis force + call read_logical_input(500, 'amprblock', ampr_block, .true.) ! treat 2D rainfall as block (true) or linearly interpolated (false) + call read_real_input(500, 'spwmergefrac', spw_merge_frac, 0.5) ! merge factor for spiderweb wind composite + call read_logical_input(500, 'usespwprecip', use_spw_precip, .true.) ! use precipitation field from spiderweb file + call read_logical_input(500, 'global', global, .false.) ! treat grid as global (wrap in x) + call read_real_input(500, 'nuvisc', nuviscdim, 0.01) ! viscosity coefficient (m2/s) + call read_logical_input(500, 'viscosity', viscosity, .false.) ! enable horizontal viscosity term + call read_logical_input(500, 'spinup_meteo', spinup_meteo, .false.) ! ramp wind/pressure from zero during tspinup + call read_real_input(500, 'waveage', waveage, -999.0) ! wave age (for SnapWave wind growth) + call read_logical_input(500, 'snapwave', snapwave, .false.) ! enable coupled SnapWave wave solver + call read_logical_input(500, 'dtoutfixed', fixed_output_intervals, .true.) ! snap map/his to exact intervals (true) or let them drift with dt (false) + ! + ! Wave maker parameters. Old 3-letter keywords (wvmfile, wfpfile, + ! whifile, wtifile, wstfile, wmtfilter, wmfred, wmsignal, wmhmin, + ! nfreqsinc/ig, freq*min/max*inc/ig) are retained for backward + ! compatibility; the wavemaker_ keywords below override them + ! when supplied. + ! + call read_char_input(500, 'wavemaker_wvmfile', wavemaker_wvmfile, 'none') ! wavemaker polyline file + if (wavemaker_wvmfile(1:4) == 'none') & + call read_char_input(500, 'wvmfile', wavemaker_wvmfile, 'none') ! legacy keyword + call read_char_input(500, 'wavemaker_wfpfile', wavemaker_wfpfile, 'none') ! wavemaker forcing points file + if (wavemaker_wfpfile(1:4) == 'none') & + call read_char_input(500, 'wfpfile', wavemaker_wfpfile, 'none') ! legacy keyword + call read_char_input(500, 'wavemaker_whifile', wavemaker_whifile, 'none') ! wavemaker wave-height time series file + if (wavemaker_whifile(1:4) == 'none') & + call read_char_input(500, 'whifile', wavemaker_whifile, 'none') ! legacy keyword + call read_char_input(500, 'wavemaker_wtifile', wavemaker_wtifile, 'none') ! wavemaker wave-period time series file + if (wavemaker_wtifile(1:4) == 'none') & + call read_char_input(500, 'wtifile', wavemaker_wtifile, 'none') ! legacy keyword + call read_char_input(500, 'wavemaker_wstfile', wavemaker_wstfile, 'none') ! wavemaker wave set-up time series file + if (wavemaker_wstfile(1:4) == 'none') & + call read_char_input(500, 'wstfile', wavemaker_wstfile, 'none') ! legacy keyword + ! + call read_real_input(500, 'wmtfilter', wavemaker_filter_time, 600.0) ! wavemaker filter time scale (s, legacy keyword) + call read_real_input(500, 'wavemaker_filter_time', wavemaker_filter_time, wavemaker_filter_time) ! override with new keyword if present + call read_real_input(500, 'wmfred', wavemaker_filter_fred, 0.99) ! wavemaker filter fred (legacy keyword) + call read_real_input(500, 'wavemaker_filter_fred', wavemaker_filter_fred, wavemaker_filter_fred) ! override with new keyword if present + call read_char_input(500, 'wmsignal', wmsigstr, 'spectrum') ! wavemaker signal type (legacy keyword) + call read_char_input(500, 'wavemaker_signal', wmsigstr, trim(wmsigstr)) ! override with new keyword if present + call read_real_input(500, 'wmhmin', wavemaker_hmin, 0.1) ! wavemaker minimum depth for wave generation (legacy keyword) + call read_real_input(500, 'wavemaker_hmin', wavemaker_hmin, wavemaker_hmin) ! override with new keyword if present + call read_int_input(500, 'nfreqsinc', wavemaker_nfreqs_inc, 100) ! wavemaker number of incident-wave frequencies (legacy) + call read_int_input(500, 'wavemaker_nfreqs_inc', wavemaker_nfreqs_inc, wavemaker_nfreqs_inc) ! override + call read_real_input(500, 'freqmininc', wavemaker_freqmin_inc, 0.04) ! wavemaker incident-wave min frequency (Hz, legacy) + call read_real_input(500, 'wavemaker_freqmin_inc', wavemaker_freqmin_inc, wavemaker_freqmin_inc) ! override + call read_real_input(500, 'freqmaxinc', wavemaker_freqmax_inc, 1.0) ! wavemaker incident-wave max frequency (Hz, legacy) + call read_real_input(500, 'wavemaker_freqmax_inc', wavemaker_freqmax_inc, wavemaker_freqmax_inc) ! override + call read_int_input(500, 'nfreqsig', wavemaker_nfreqs_ig, 100) ! wavemaker number of IG-wave frequencies (legacy) + call read_int_input(500, 'wavemaker_nfreqs_ig', wavemaker_nfreqs_ig, wavemaker_nfreqs_ig) ! override + call read_real_input(500, 'freqminig', wavemaker_freqmin_ig, 0.0) ! wavemaker IG-wave min frequency (Hz, legacy) + call read_real_input(500, 'wavemaker_freqmin_ig', wavemaker_freqmin_ig, wavemaker_freqmin_ig) ! override + call read_real_input(500, 'freqmaxig', wavemaker_freqmax_ig, 0.1) ! wavemaker IG-wave max frequency (Hz, legacy) + call read_real_input(500, 'wavemaker_freqmax_ig', wavemaker_freqmax_ig, wavemaker_freqmax_ig) ! override + ! + call read_real_input(500, 'wavemaker_tinc2ig', wavemaker_tinc2ig, -1.0) ! wavemaker ig/inc period ratio (<=0 uses Herbers) + call read_real_input(500, 'wavemaker_surfslope', wavemaker_surfslope, -1.0) ! wavemaker surf-zone slope for empirical Tp_ig (van Ormondt et al., 2021) + call read_real_input(500, 'wavemaker_hm0_ig_factor', wavemaker_hm0_ig_factor, 1.0) ! wavemaker IG Hm0 scaling factor + call read_real_input(500, 'wavemaker_hm0_inc_factor', wavemaker_hm0_inc_factor, 1.0) ! wavemaker incident Hm0 scaling factor + call read_real_input(500, 'wavemaker_gammax', wavemaker_gammax, 1.0) ! wavemaker maximum Hrms/h + call read_real_input(500, 'wavemaker_tpmin', wavemaker_tpmin, 1.0) ! wavemaker minimum Tp (s) + call read_logical_input(500, 'wavemaker_hig', wavemaker_hig, .true.) ! wavemaker include IG waves + call read_logical_input(500, 'wavemaker_hinc', wavemaker_hinc, .false.) ! wavemaker include incident waves + ! + ! Numerical parameters + ! + call read_char_input(500, 'advection_scheme', advstr, 'upw1') ! advection scheme label ('upw1' = 1st-order upwind, 'original' = legacy) + call read_real_input(500, 'btrelax', btrelax, 3600.0) ! bathtub relaxation time (s) + call read_logical_input(500, 'wiggle_suppression', wiggle_suppression, .true.) ! suppress spurious free-surface oscillations + call read_real_input(500, 'structure_relax', structure_relax, 4.0) ! drainage-structure state-machine smoothing steps + call read_real_input(500, 'wiggle_factor', wiggle_factor, 0.1) ! wiggle-suppression amplitude factor + call read_real_input(500, 'wiggle_threshold', wiggle_threshold, 0.1) ! wiggle-suppression trigger threshold + call read_real_input(500, 'uvlim', uvlim, 10.0) ! clipping velocity for momentum (m/s) + call read_real_input(500, 'uvmax', uvmax, 1000.0) ! error-trigger velocity for momentum (m/s) + call read_logical_input(500, 'friction2d', friction2d, .true.) ! apply friction at every UV point (true) or cell-wise (false) + call read_logical_input(500, 'advection_mask', advection_mask, .true.) ! mask advection near dry cells + call read_real_input(500, 'nuviscfac', nuviscfac, 100.0) ! multiplier on nuvisc near "difficult" points + call read_logical_input(500, 'nonh', nonhydrostatic, .false.) ! enable non-hydrostatic pressure corrector + call read_real_input(500, 'nh_fnudge', nh_fnudge, 0.9) ! non-hydrostatic nudging factor + call read_real_input(500, 'nh_tstop', nh_tstop, -999.0) ! non-hydrostatic stop time (s rel. tref); -999 = t1+999 + call read_real_input(500, 'nh_tol', nh_tol, 0.001) ! non-hydrostatic solver tolerance + call read_int_input(500, 'nh_itermax', nh_itermax, 100) ! non-hydrostatic solver max iterations + call read_logical_input(500, 'h73table', h73table, .false.) ! tabulate h^(7/3) for friction + call read_real_input(500, 'rugdepth', runup_gauge_depth, 0.05) ! runup gauge trigger depth (m) + call read_logical_input(500, 'wave_enhanced_roughness', wave_enhanced_roughness, .false.) ! augment bed roughness with wave orbital velocity + call read_logical_input(500, 'use_bcafile', use_bcafile, .true.) ! use tidal components from bca file + call read_real_input(500, 'factor_wind', factor_wind, 1.0) ! scaling factor on wind forcing + call read_real_input(500, 'factor_pres', factor_pres, 1.0) ! scaling factor on atmospheric pressure + call read_real_input(500, 'factor_prcp', factor_prcp, 1.0) ! scaling factor on precipitation + call read_real_input(500, 'factor_spw_size', factor_spw_size, 1.0) ! scaling factor on spiderweb radius + call read_logical_input(500, 'bathtub', bathtub, .false.) ! run in bathtub (no momentum) mode + call read_real_input(500, 'bathtub_fachs', bathtub_fac_hs, 0.2) ! bathtub Hs multiplier + call read_real_input(500, 'bathtub_dt', bathtub_dt, -999.0) ! bathtub time step (s); -999 = use dtmapout + ! + ! Domain files + ! + call read_char_input(500, 'qtrfile', qtrfile, 'none') ! quadtree netCDF file + call read_char_input(500, 'depfile', depfile, 'none') ! bed-level (depth) file + call read_char_input(500, 'inifile', zsinifile, 'none') ! initial water-level file + call read_char_input(500, 'rstfile', rstfile, 'none') ! restart input file + call read_char_input(500, 'mskfile', mskfile, 'none') ! active-cell mask file + call read_char_input(500, 'indexfile', indexfile, 'none') ! index-to-active-cell mapping file + call read_char_input(500, 'cstfile', cstfile, 'none') ! coastline polyline file + call read_char_input(500, 'sbgfile', sbgfile, 'none') ! subgrid tables netCDF file + call read_char_input(500, 'thdfile', thdfile, 'none') ! thin dams polyline file + call read_char_input(500, 'weirfile', weirfile, 'none') ! weirs polyline file + call read_char_input(500, 'manningfile', manningfile, 'none') ! spatially-varying Manning n file + call read_char_input(500, 'drnfile', drnfile, 'none') ! drainage-structures (pumps/gates/culverts) TOML file + call read_char_input(500, 'urbfile', urbfile, 'none') ! urban drainage zones TOML file + call read_char_input(500, 'volfile', volfile, 'none') ! depression-storage volume file + ! + ! Forcing files (ascii / binary) + ! + call read_char_input(500, 'bndfile', bndfile, 'none') ! water-level boundary points + call read_char_input(500, 'bzsfile', bzsfile, 'none') ! water-level boundary time series + call read_char_input(500, 'bcafile', bcafile, 'none') ! tidal components per boundary point + call read_char_input(500, 'bzifile', bzifile, 'none') ! IG wave boundary time series + call read_char_input(500, 'bdrfile', bdrfile, 'none') ! downstream river boundary file + call read_char_input(500, 'srcfile', srcfile, 'none') ! river-point source locations + call read_char_input(500, 'disfile', disfile, 'none') ! river-point discharge time series + call read_char_input(500, 'spwfile', spwfile, 'none') ! spiderweb tropical-cyclone file + call read_char_input(500, 'wndfile', wndfile, 'none') ! uniform wind time series + call read_char_input(500, 'prcfile', prcpfile, 'none') ! uniform precipitation time series + if (prcpfile(1:4) == 'none') then + ! + call read_char_input(500, 'precipfile', prcpfile, 'none') ! legacy keyword for prcfile + ! + endif + call read_char_input(500, 'amufile', amufile, 'none') ! 2D wind u-component file + call read_char_input(500, 'amvfile', amvfile, 'none') ! 2D wind v-component file + call read_char_input(500, 'ampfile', ampfile, 'none') ! 2D atmospheric pressure file + call read_char_input(500, 'amprfile', amprfile, 'none') ! 2D precipitation rate file + call read_char_input(500, 'z0lfile', z0lfile, 'none') ! 2D land roughness (z0) file + ! + ! NetCDF-format forcing files (FEWS-style) + ! + call read_char_input(500, 'netbndbzsbzifile', netbndbzsbzifile, 'none') ! combined bnd/bzs/bzi netCDF file + call read_char_input(500, 'netsrcdisfile', netsrcdisfile, 'none') ! combined src/dis netCDF file + call read_char_input(500, 'netamuamvfile', netamuamvfile, 'none') ! combined amu/amv netCDF file + call read_char_input(500, 'netamprfile', netamprfile, 'none') ! 2D precipitation netCDF file + call read_char_input(500, 'netampfile', netampfile, 'none') ! 2D pressure netCDF file + call read_char_input(500, 'netspwfile', netspwfile, 'none') ! netCDF spiderweb file + ! + ! Infiltration and losses + ! + call read_char_input(500, 'infiltrationfile', infiltrationfile, 'none') ! infiltration parameters TOML file + call read_char_input(500, 'infiltrationtype', inftype, 'none') ! infiltration flavor (con, c2d, cna, cnb, gai, hor, bkt) + call read_char_input(500, 'bucketfile', removed_input, '__removed_keyword_not_present__') + if (trim(removed_input) /= '__removed_keyword_not_present__') then + ! + write(logstr,'(a)') 'Error : keyword bucketfile has been removed. Use infiltrationfile together with infiltrationtype = bkt.' + call stop_sfincs(trim(logstr), 1) + ! + endif + call read_char_input(500, 'bucket_loss_frac', removed_input, '__removed_keyword_not_present__') + if (trim(removed_input) /= '__removed_keyword_not_present__') then + ! + write(logstr,'(a)') 'Error : keyword bucket_loss_frac has been removed. Add bucket_loss to infiltrationfile instead.' + call stop_sfincs(trim(logstr), 1) + ! + endif ! - cd_nr = 3 + ! Legacy binary infiltration inputs (kept for backward compatibility). + ! + call read_char_input(500, 'qinffile', qinffile, 'none') ! binary spatially-varying infiltration field + call read_char_input(500, 'scsfile', scsfile, 'none') ! SCS curve-number S field (legacy binary) + call read_char_input(500, 'smaxfile', smaxfile, 'none') ! SCS max storage S field (legacy binary) + call read_char_input(500, 'sefffile', sefffile, 'none') ! SCS effective storage S_e field (legacy binary) + call read_char_input(500, 'psifile', psifile, 'none') ! Green-Ampt suction head (legacy binary, mm) + call read_char_input(500, 'sigmafile', sigmafile, 'none') ! Green-Ampt maximum moisture deficit (legacy binary) + call read_char_input(500, 'ksfile', ksfile, 'none') ! Green-Ampt saturated hydraulic conductivity (legacy binary, mm/hr) + call read_char_input(500, 'f0file', f0file, 'none') ! Horton initial infiltration capacity F0 (legacy binary) + call read_char_input(500, 'fcfile', fcfile, 'none') ! Horton asymptotic infiltration rate Fc (legacy binary) + call read_char_input(500, 'kdfile', kdfile, 'none') ! Horton decay constant k (legacy binary, 1/hr) + call read_real_input(500, 'horton_kr_kd', horton_kr_kd, 10.0) ! Horton recovery/decay ratio (recovery is kr_kd times slower than decay) + ! + ! Output files + ! + call read_char_input(500, 'obsfile', obsfile, 'none') ! observation-point locations file + call read_char_input(500, 'crsfile', crsfile, 'none') ! cross-section polyline file + call read_char_input(500, 'rugfile', rugfile, 'none') ! runup-gauge locations file + call read_logical_input(500, 'storevelmax', store_maximum_velocity, .false.) ! store maximum flow velocity on dtmaxout interval (only if dtmaxout > 0) + call read_logical_input(500, 'storefluxmax', store_maximum_flux, .false.) ! store maximum flux on dtmaxout interval (only if dtmaxout > 0) + call read_logical_input(500, 'storevel', store_velocity, .false.) ! store velocity on dtout interval + call read_logical_input(500, 'storecumprcp', store_cumulative_precipitation, .false.) ! store cumulative precipitation + infiltration on dtmaxout interval + call read_logical_input(500, 'storetwet', store_twet, .false.) ! store per-cell wet duration + call read_logical_input(500, 'storetzsmax', store_t_zsmax, .false.) ! store time stamp of zsmax occurrence + call read_logical_input(500, 'storehsubgrid', store_hsubgrid, .false.) ! store hmax in subgrid mode (zsmax - subgrid_z_zmin) + call read_logical_input(500, 'storehmean', store_hmean, .false.) ! store hmax as subgrid-mean depth instead of max (requires storehsubgrid) + call read_real_input(500, 'twet_threshold', twet_threshold, 0.01) ! water-depth threshold counting a cell as wet (storetwet) + call read_logical_input(500, 'store_tsunami_arrival_time', store_tsunami_arrival_time, .false.) ! store tsunami arrival time per cell + call read_real_input(500, 'tsunami_arrival_threshold', tsunami_arrival_threshold, 0.01) ! water-depth threshold for tsunami arrival + call read_logical_input(500, 'timestep_analysis', timestep_analysis, .false.) ! write per-cell timestep limiter diagnostics + call read_logical_input(500, 'storeqdrain', store_qdrain, .true.) ! store per-drainage-structure discharge in his file + call read_logical_input(500, 'store_river_discharge', store_river_discharge, .false.) ! store per-river-point discharge in his file + call read_logical_input(500, 'store_urban_drainage_discharge', store_urban_drainage_discharge, .false.) ! store per-urban-zone outfall discharge in his file + call read_logical_input(500, 'store_cumulative_urban_drainage', store_cumulative_urban_drainage, .false.) ! store cumulative urban drainage depth per cell in map file + call read_logical_input(500, 'storezvolume', store_zvolume, .false.) ! store subgrid cell volume (requires subgrid) + call read_logical_input(500, 'storestoragevolume', store_storagevolume, .false.) ! store remaining storage volume (requires subgrid + volfile) + call read_logical_input(500, 'writeruntime', write_time_output, .false.) ! write runtimes.txt at end of simulation + call read_logical_input(500, 'debug', debug, .false.) ! debug output at every time step + call read_logical_input(500, 'storemeteo', store_meteo, .false.) ! store 2D meteo forcing fields in map file + call read_logical_input(500, 'storemaxwind', store_wind_max, .false.) ! store maximum wind speed (requires storemeteo) + call read_logical_input(500, 'storefw', store_wave_forces, .false.) ! store wave-radiation forces + call read_logical_input(500, 'storewavdir', store_wave_direction, .false.) ! store wave direction + call read_logical_input(500, 'regular_output_on_mesh', use_quadtree_output, .false.) ! write quadtree output on regular m/n mesh + call read_logical_input(500, 'store_dynamic_bed_level', store_dynamic_bed_level, .false.) ! store time-varying bed level (subgrid) + call read_logical_input(500, 'snapwave_use_nearest', snapwave_use_nearest, .true.) ! use nearest-neighbour lookup for SnapWave boundary points + call read_int_input(500, 'percentage_done', percdoneval, 5) ! progress-reporter interval (% complete) + ! + ! Limit progress reporter to (0, 100]% + ! + percdoneval = max(min(percdoneval, 100), 0) + ! + ! Coupled SnapWave solver parameters + ! + call read_logical_input(500, 'snapwave_wind', snapwavewind, .false.) ! feed wind into SnapWave (implies storing wind speed/direction) + call read_real_input(500, 'snapwave_waveforces_factor', waveforces_factor, 1.0) ! multiplier on SnapWave wave forces + ! + ! Wind drag coefficient table + ! + call read_int_input(500, 'cdnrb', cd_nr, 0) ! number of wind-drag breakpoints (0 = use defaults) + ! + if (cd_nr == 0) then + ! + ! Standard Smith & Banke-style Cd curve: constant at low wind, + ! linear rise, then plateau at high wind. + ! + cd_nr = 3 + ! + allocate(cd_wnd(cd_nr)) + allocate(cd_val(cd_nr)) + ! + cd_wnd(1) = 0.0 + cd_wnd(2) = 28.0 + cd_wnd(3) = 50.0 + cd_val(1) = 0.0010 + cd_val(2) = 0.0025 + cd_val(3) = 0.0025 + ! + else + ! + call read_real_array_input(500, 'cdwnd', cd_wnd, 0.0, cd_nr) + call read_real_array_input(500, 'cdval', cd_val, 0.0, cd_nr) + ! + endif ! - allocate(cd_wnd(cd_nr)) - allocate(cd_val(cd_nr)) + ! Late retry of dtmapout for older sfincs.inp files that put it after + ! keywords which could have shifted its position. ! - cd_wnd(1) = 0.0 - cd_wnd(2) = 28.0 - cd_wnd(3) = 50.0 - cd_val(1) = 0.0010 - cd_val(2) = 0.0025 - cd_val(3) = 0.0025 + if (dtmapout == 0.0) then + ! + call read_real_input(500, 'dtmapout', dtmapout, 0.0) + ! + endif ! - else + close(500) ! - ! Use defaults + if (epsg == 0) then + ! + call write_log('Warning : no EPSG code defined', 0) + ! + endif ! - call read_real_array_input(500,'cdwnd',cd_wnd,0.0,cd_nr) - call read_real_array_input(500,'cdval',cd_val,0.0,cd_nr) + ! If tref not provided, assume tref = tstart. ! - endif - ! - ! Try new keywords for sfincs.inp file (ensure backward compatibility) - ! - if (dtmapout==0.0) then - call read_real_input(500,'dtmapout',dtmapout,0.0) - endif - ! - close(500) - ! - ! Check whether epsg code has been specified: - if (epsg == 0) then - call write_log('Warning : no EPSG code defined', 0) - endif - ! - ! If tref not provided, assume tref=tstart - ! - if (trefstr(1:4) == 'none') then - ! - trefstr = tstartstr - ! - write(logstr,*)'Warning : no tref provided, set to tstart: ',trefstr - call write_log(logstr, 1) - ! - endif - ! - ! Compute simulation time - ! - call time_difference(trefstr,tstartstr,dtsec) ! time difference in seconds between tstart and tref - t0 = dtsec*1.0 ! time difference in seconds between tstop and tstart - call time_difference(trefstr,tstopstr,dtsec) - t1 = dtsec*1.0 ! time difference in seconds between tstop and tstart - tspinup = t0 + tspinup - ! - ! Set constants - g = 9.81 - pi = 3.14159 - gn2 = 9.81*0.02*0.02 ! Only to be used in subgrid - ! - qinf = qinf/(3600*1000) - ! - rotation = rotation*pi/180 - cosrot = cos(rotation) - sinrot = sin(rotation) - ! - area = dx*dy - ! - dxy = min(dx, dy) - dxinv = 1.0/dx - dyinv = 1.0/dy - ! - manning2d = .false. - imanning2d = 0 - if (manningfile/='none') then - manning2d = .true. - imanning2d = 1 - endif - ! - ! CRS and Coriolis parameter - ! - fcorio = 0.0 - ! - if (igeo == 0) then + if (trefstr(1:4) == 'none') then + ! + trefstr = tstartstr + ! + write(logstr, *) 'Warning : no tref provided, set to tstart: ', trefstr + call write_log(logstr, 1) + ! + endif + ! + ! Compute simulation time span in seconds, relative to tref. + ! + call time_difference(trefstr, tstartstr, dtsec) + t0 = dtsec * 1.0 + call time_difference(trefstr, tstopstr, dtsec) + t1 = dtsec * 1.0 + tspinup = t0 + tspinup + ! + g = 9.81 + pi = 3.14159 + gn2 = 9.81 * 0.02 * 0.02 ! only used in subgrid mode + ! + qinf = qinf / (3600 * 1000) ! mm/hr -> m/s ! - ! Projected (default with coriolis, unless latitude is 0.0) + rotation = rotation * pi / 180 + cosrot = cos(rotation) + sinrot = sin(rotation) ! - crsgeo = .false. - fcorio = 2 * 7.2921e-05 * sin(latitude * pi / 180) + area = dx * dy + dxy = min(dx, dy) + dxinv = 1.0 / dx + dyinv = 1.0 / dy ! - if (latitude < 0.01 .and. latitude > -0.01) then + manning2d = .false. + if (manningfile /= 'none') manning2d = .true. + ! + ! CRS and Coriolis parameter + ! + fcorio = 0.0 + ! + if (.not. crsgeo) then + ! + ! Projected: compute fcorio from latitude; zero it out at the + ! equator or if the user did not set a latitude at all. + ! + fcorio = 2 * 7.2921e-05 * sin(latitude * pi / 180) + ! + if (latitude < 0.01 .and. latitude > -0.01) coriolis = .false. + ! + else + ! + ! Geographic: fcorio2d is filled in later by sfincs_domain. ! - ! No Coriolis force - ! - coriolis = .false. - ! endif ! - else + if (crsgeo) then + call write_log('Info : input grid interpreted as geographic coordinates', 0) + else + call write_log('Info : input grid interpreted as projected coordinates', 0) + endif ! - ! Geographic (default included coriolis, unless coriolis is turned off in input file) - ! fcorio2d will be determined in sfincs_domain.f90 + if (coriolis) then + call write_log('Info : turning on Coriolis', 0) + else + call write_log('Info : turning off Coriolis', 0) + endif ! - crsgeo = .true. + if (.not. crsgeo .and. .not. coriolis) then + call write_log('Info : no Coriolis, as latitude is not specified in sfincs.inp', 0) + endif ! - endif - ! - if (crsgeo) then - call write_log('Info : input grid interpreted as geographic coordinates', 0) - else - call write_log('Info : input grid interpreted as projected coordinates', 0) - endif - ! - if (coriolis) then - call write_log('Info : turning on Coriolis', 0) - else - call write_log('Info : turning off Coriolis', 0) - endif - ! - if (.not. crsgeo .AND. .NOT. coriolis) then - call write_log('Info : no Coriolis, as latitude is not specified in sfincs.inp', 0) - endif - ! - ! Output - ! - if (t0out<-900.0) then - t0out = t0 - endif - t0out = max(t0out, t0) - if (t1out<-900.0) then - t1out = t1 - endif - ! - store_maximum_waterlevel = .false. - if (dtmaxout>0.0) then - store_maximum_waterlevel = .true. - endif - ! - store_maximum_velocity = .false. - if (storevelmax==1 .and. dtmaxout>0.0) then - store_maximum_velocity = .true. - endif - ! - store_maximum_flux = .false. - if (storefluxmax==1 .and. dtmaxout>0.0) then - store_maximum_flux = .true. - endif - ! - store_velocity = .false. - if (storevel==1) then - store_velocity = .true. - endif - ! - store_meteo = .false. - store_wind = .false. - store_wind_max = .false. - if (storemeteo==1) then - store_meteo = .true. - store_wind = .true. - if (iwindmax==1) then - store_wind_max = .true. + ! Map/his output window: default to tstart..tstop. + ! + if (t0out < -900.0) t0out = t0 + t0out = max(t0out, t0) + if (t1out < -900.0) t1out = t1 + ! + store_maximum_waterlevel = .false. + if (dtmaxout > 0.0) store_maximum_waterlevel = .true. + ! + ! Apply gates to the flags now that the full set of inputs has been read. + ! + if (dtmaxout <= 0.0) then + store_maximum_velocity = .false. + store_maximum_flux = .false. endif - endif - ! - snapwave = .false. - snapwavewind = .false. - if (isnapwave==1) then - snapwave = .true. - ! - if (iwind==1) then - store_wind = .true. - snapwavewind = .true. - ! For running SnapWave with wind growth, we need to store the wind speed & direction to be able to pass it from SFINCS to SnapWave. - ! Independent from wndfile or 2D meteo input, handled by store_wind. - endif - endif - ! - store_twet = .false. - if (storetwet==1) then - store_twet = .true. - endif - ! - store_t_zsmax = .false. - if (storetzsmax==1) then - store_t_zsmax = .true. - endif - ! - store_cumulative_precipitation = .false. - if (storecumprcp==1) then - store_cumulative_precipitation = .true. - endif - ! - if (storeqdrain==0) then - store_qdrain = .false. - else - store_qdrain = .true. - endif - ! - write_time_output = .false. - if (wrttimeoutput==1) then - write_time_output = .true. - endif - ! - radstr = .false. - if (iradstr==1) then - radstr = .true. - endif - ! - if ((outputtype_map == 'nil') .OR. (outputtype_his == 'nil')) then - outputtype_map = outputtype - outputtype_his = outputtype - endif - ! - ampr_block = .true. ! Default use data in ampr file as block rather than linear interpolation - if (iamprblock==0) then - ampr_block = .false. - endif - ! - global = .false. ! Default use data in ampr file as block rather than linear interpolation - if (iglobal==1) then - global = .true. - endif - ! - if (sbgfile(1:4) /= 'none') then ! - subgrid = .true. - isubgrid = 1 - call write_log('Info : running SFINCS with subgrid bathymetry', 0) + ! storemeteo implies store_wind (SFINCS needs 2D wind to feed the + ! meteo map output); storemaxwind is only meaningful if we are + ! storing the wind in the first place. ! - else + if (store_meteo) store_wind = .true. + if (.not. store_wind) store_wind_max = .false. ! - subgrid = .false. - isubgrid = 0 - call write_log('Info : running SFINCS with regular bathymetry', 0) + ! SnapWave with wind-growth needs wind stored and a dedicated + ! snapwavewind flag; snapwavewind is ignored when SnapWave is off. ! - endif - ! - ! - store_hsubgrid = .false. - if (storehsubgrid==1) then - store_hsubgrid = .true. - endif - ! - if (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .false.) then - ! - call write_log('Info : storing maximum depth in subgrid cell for hmax output', 0) + if (.not. snapwave) snapwavewind = .false. + if (snapwavewind) store_wind = .true. ! - elseif (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .true.) then + if (viscosity) call write_log('Info : turning on process: Viscosity', 0) ! - call write_log('Info : storing mean depth in subgrid cell for hmax output', 0) - ! - endif - ! - store_zvolume = .false. - ! - if (subgrid) then - if (storezvolume==1) then - store_zvolume = .true. - endif - endif - ! - store_tsunami_arrival_time = .false. - if (itsunamitime==1) then - store_tsunami_arrival_time = .true. - endif - ! - viscosity = .false. - if (iviscosity) then - viscosity = .true. - call write_log('Info : turning on process: Viscosity', 0) - endif - ! - spinup_meteo = .true. - if (ispinupmeteo==0) then - spinup_meteo = .false. - endif - ! - use_spw_precip = .true. - if (ispwprecip==0) then - use_spw_precip = .false. - endif - ! - fixed_output_intervals = .true. - if (ioutfixed==0) then - fixed_output_intervals = .false. - endif - ! - advection = .false. - if (iadvection>0) then - advection = .true. - endif - ! - thetasmoothing = .false. - if (theta<0.9999) then ! Note, for reliability in terms of precision, is written as 0.9999 - thetasmoothing = .true. - endif - ! - store_wave_forces = .false. - if (istorefw==1) then - store_wave_forces = .true. - endif - ! - wavemaker = .false. - wavemaker_spectrum = .true. - ! - if (wavemaker_wvmfile(1:4) /= 'none') then + ! Map/his format fallback: inherit the global outputformat when either + ! per-file format was left at 'nil'. ! - wavemaker = .true. - iwavemaker = 1 + if ((outputtype_map == 'nil') .or. (outputtype_his == 'nil')) then + outputtype_map = outputtype + outputtype_his = outputtype + endif ! - call write_log('Info : turning on process: Dynamic waves', 0) + if (sbgfile(1:4) /= 'none') then + subgrid = .true. + call write_log('Info : running SFINCS with subgrid bathymetry', 0) + else + subgrid = .false. + call write_log('Info : running SFINCS with regular bathymetry', 0) + endif ! - if (wmsigstr(1:3) == 'mon') then - ! - ! Monochromatic - ! - wavemaker_spectrum = .false. + if (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .false.) then ! - call write_log('Info : use monochromatic wave spectrum', 0) + call write_log('Info : storing maximum depth in subgrid cell for hmax output', 0) + ! + elseif (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .true.) then + ! + call write_log('Info : storing mean depth in subgrid cell for hmax output', 0) ! - endif - endif - ! - store_wave_direction = .false. - if (istorewavdir==1) then - store_wave_direction = .true. - endif - ! - use_storage_volume = .false. - store_storagevolume = .false. - ! - if (volfile(1:4) /= 'none') then - if (subgrid) then - use_storage_volume = .true. - ! - if (storestoragevolume==1) then - store_storagevolume = .true. - endif - ! - else - call write_log('Warning : storage volume only supported for subgrid topographies!', 1) - endif - endif - ! - if (advection) then - ! - ! Make 1st order upwind the default scheme - ! - advection_scheme = 1 - ! - call write_log('Info : turning on advection', 0) - ! - if (trim(advstr) == 'original') then - advection_scheme = 0 - call write_log('Info : advection scheme : Original', 0) - elseif (trim(advstr) == 'upw1') then - advection_scheme = 1 - call write_log('Info : advection scheme : first-order upwind', 0) - else - write(logstr,*)'Warning : advection scheme ', trim(advstr), ' not recognized! Using default upw1 instead!' - call write_log(logstr, 1) endif ! - endif - ! - if (nonhydrostatic) then + ! store_zvolume / store_storagevolume are subgrid-only. ! - if (nh_tstop > 0.0) then - ! - ! tstopnonh is provided so set it with respect to model reference time + if (.not. subgrid) store_zvolume = .false. + ! + thetasmoothing = .false. + if (theta < 0.9999) thetasmoothing = .true. ! use 0.9999 instead of 1.0 for numerical robustness + ! + wavemaker = .false. + wavemaker_spectrum = .true. + ! + if (wavemaker_wvmfile(1:4) /= 'none') then ! - nh_tstop = t0 + nh_tstop + wavemaker = .true. ! - else + call write_log('Info : turning on process: Dynamic waves', 0) ! - ! tstopnonh is not provided so set it to tstop time + 999.0 s + if (wmsigstr(1:3) == 'mon') then + ! + wavemaker_spectrum = .false. + ! + call write_log('Info : use monochromatic wave spectrum', 0) + ! + endif ! - nh_tstop = t1 + 999.0 - ! - endif - ! - endif - ! - if (bathtub) then + endif ! - call write_log('Info : turning on process: Bathtub flooding', 0) + use_storage_volume = .false. ! - ! Set time step + if (volfile(1:4) /= 'none') then + if (subgrid) then + use_storage_volume = .true. + else + call write_log('Warning : storage volume only supported for subgrid topographies!', 1) + store_storagevolume = .false. + endif + else + store_storagevolume = .false. + endif ! - if (bathtub_dt < 0.0) then + if (advection) then + ! + ! Default scheme is 1st-order upwind; 'original' keeps the legacy form. + ! + advection_scheme = 1 ! - ! Time step for simulation not defined so use same as map output + call write_log('Info : turning on advection', 0) ! - bathtub_dt = dtmapout + if (trim(advstr) == 'original') then + advection_scheme = 0 + call write_log('Info : advection scheme : Original', 0) + elseif (trim(advstr) == 'upw1') then + advection_scheme = 1 + call write_log('Info : advection scheme : first-order upwind', 0) + else + write(logstr, *) 'Warning : advection scheme ', trim(advstr), ' not recognized! Using default upw1 instead!' + call write_log(logstr, 1) + endif ! endif ! - dthisout = bathtub_dt - ! - ! Turn off some processes not needed for bathtub flooding. - ! Forcing the input file paths to 'none' makes each initialize_* - ! routine take its standard early-return path; that way the counters - ! (nr_discharge_points, nr_src_structures, nr_urban_drainage_zones) - ! and derived logicals (discharges, drainage_structures, - ! urban_drainage) stay consistent with the "no input" state. - ! - srcfile = 'none' - disfile = 'none' - netsrcdisfile = 'none' - drnfile = 'none' - urbfile = 'none' - ! - meteo3d = .false. - wind = .false. - store_meteo = .false. - store_wind = .false. - store_wind_max = .false. - precip = .false. - patmos = .false. - if (snapwave) then - bathtub_snapwave = .true. + if (nonhydrostatic) then + ! + if (nh_tstop > 0.0) then + nh_tstop = t0 + nh_tstop + else + nh_tstop = t1 + 999.0 + endif + ! + endif + ! + if (bathtub) then + ! + call write_log('Info : turning on process: Bathtub flooding', 0) + ! + ! Time step defaults to dtmapout when the user does not set it. + ! + if (bathtub_dt < 0.0) bathtub_dt = dtmapout + ! + dthisout = bathtub_dt + ! + ! Turn off processes not needed for bathtub flooding. Forcing the + ! input file paths to 'none' makes each initialize_* routine take + ! its standard early-return path; that way the counters + ! (nr_discharge_points, nr_src_structures, nr_urban_drainage_zones) + ! and derived logicals (discharges, drainage_structures, + ! urban_drainage) stay consistent with the "no input" state. + ! + srcfile = 'none' + disfile = 'none' + netsrcdisfile = 'none' + drnfile = 'none' + urbfile = 'none' + ! + meteo3d = .false. + wind = .false. + store_meteo = .false. + store_wind = .false. + store_wind_max = .false. + precip = .false. + patmos = .false. + if (snapwave) bathtub_snapwave = .true. + snapwave = .false. + infiltration = .false. + store_velocity = .false. + store_maximum_velocity = .false. + ! endif - snapwave = .false. - infiltration = .false. - store_velocity = .false. - store_maximum_velocity = .false. ! - endif - ! - ! normbnd = sqrt(dzdsbnd) / manningbnd - ! end subroutine - - - - subroutine read_real_input(fileid,keyword,value,default) - ! - character(*), intent(in) :: keyword - character(len=256) :: keystr - character(len=256) :: valstr - character(len=256) :: line - integer, intent(in) :: fileid - real*4, intent(out) :: value - real*4, intent(in) :: default - integer j,stat,ilen ! - value = default + !-----------------------------------------------------------------------------------------------------! ! - rewind(fileid) - ! - do while(.true.) + subroutine read_real_input(fileid, keyword, value, default) + ! + ! Read a single real*4 keyword from an already-open sfincs.inp. The + ! file is rewound on each call; scanning is linear. If the keyword + ! is not found, `value` is set to `default`. + ! + ! Called from: read_sfincs_input (this module). + ! + implicit none + ! + character(*), intent(in) :: keyword + integer, intent(in) :: fileid + real*4, intent(out) :: value + real*4, intent(in) :: default ! - read(fileid,'(a)',iostat = stat)line + character(len=256) :: keystr + character(len=256) :: valstr + character(len=256) :: line + integer :: stat ! - if (stat==-1) exit + value = default ! - call read_line(line, keystr, valstr) + rewind(fileid) ! - if (trim(keystr)==trim(keyword)) then + do while (.true.) ! - read(valstr,*)value + read(fileid, '(a)', iostat=stat) line + if (stat == -1) exit ! - exit + call read_line(line, keystr, valstr) ! - endif + if (trim(keystr) == trim(keyword)) then + ! + read(valstr, *) value + exit + ! + endif + ! + enddo ! - 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 + end subroutine ! - rewind(fileid) + !-----------------------------------------------------------------------------------------------------! ! - do while(.true.) + subroutine read_real_array_input(fileid, keyword, value, default, nr) + ! + ! Read one whitespace-separated real*4 array keyword. Allocates + ! `value(nr)` on the way in and fills it from the matching line; if + ! the keyword is absent, every slot is left at `default`. + ! + ! Called from: read_sfincs_input (this module). + ! + implicit none + ! + character(*), intent(in) :: keyword + integer, intent(in) :: fileid + integer, intent(in) :: nr + real*4, intent(in) :: default + real*4, dimension(:), intent(out), allocatable :: value ! - read(fileid,'(a)',iostat = stat)line + character(len=256) :: keystr + character(len=256) :: valstr + character(len=256) :: line + integer :: m, stat ! - if (stat==-1) exit + allocate(value(nr)) ! - call read_line(line, keystr, valstr) + value = default ! - if (trim(keystr)==trim(keyword)) then + rewind(fileid) + ! + do while (.true.) ! - read(valstr,*)(value(m), m = 1, nr) + read(fileid, '(a)', iostat=stat) line + if (stat == -1) exit ! - exit + call read_line(line, keystr, valstr) ! - endif + if (trim(keystr) == trim(keyword)) then + ! + read(valstr, *) (value(m), m = 1, nr) + exit + ! + endif + ! + enddo ! - 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 + end subroutine ! - rewind(fileid) + !-----------------------------------------------------------------------------------------------------! ! - do while(.true.) + subroutine read_int_input(fileid, keyword, value, default) + ! + ! Read a single integer keyword. Same scanning contract as + ! read_real_input. + ! + ! Called from: read_sfincs_input (this module). + ! + implicit none + ! + character(*), intent(in) :: keyword + integer, intent(in) :: fileid + integer, intent(out) :: value + integer, intent(in) :: default ! - read(fileid,'(a)',iostat = stat)line + character(len=256) :: keystr + character(len=256) :: valstr + character(len=256) :: line + integer :: stat ! - if (stat==-1) exit + value = default ! - call read_line(line, keystr, valstr) + rewind(fileid) ! - if (trim(keystr)==trim(keyword)) then + do while (.true.) ! - read(valstr,*)value + read(fileid, '(a)', iostat=stat) line + if (stat == -1) exit ! - exit + call read_line(line, keystr, valstr) ! - endif + if (trim(keystr) == trim(keyword)) then + ! + read(valstr, *) value + exit + ! + endif + ! + enddo ! - 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.) + subroutine read_char_input(fileid, keyword, value, default) + ! + ! Read a single character-string keyword. The entire right-hand side + ! (after stripping any trailing `# ...` comment) becomes `value`. + ! + ! Called from: read_sfincs_input (this module). ! - read(fileid,'(a)',iostat = stat)line + implicit none ! - if (stat==-1) exit + character(*), intent(in) :: keyword + integer, intent(in) :: fileid + character(*), intent(in) :: default + character(*), intent(out) :: value ! - call read_line(line, keystr, valstr) + character(len=256) :: keystr + character(len=256) :: valstr + character(len=256) :: line + integer :: stat ! - if (trim(keystr)==trim(keyword)) then + value = default + ! + rewind(fileid) + ! + do while (.true.) ! - value = valstr + read(fileid, '(a)', iostat=stat) line + if (stat == -1) exit ! - exit + call read_line(line, keystr, valstr) ! - endif + if (trim(keystr) == trim(keyword)) then + ! + value = valstr + exit + ! + endif + ! + enddo ! - 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 + end subroutine ! - rewind(fileid) + !-----------------------------------------------------------------------------------------------------! ! - do while(.true.) + subroutine read_logical_input(fileid, keyword, value, default) + ! + ! Read a single logical keyword. Accepts `1`, `y`, `Y`, `t`, `T` as + ! true; anything else (including absence plus fallback to `default`, + ! `0`, `n`, `N`, `f`, `F`) as false. + ! + ! Called from: read_sfincs_input (this module). ! - read(fileid,'(a)',iostat = stat)line + implicit none ! - if (stat==-1) exit + character(*), intent(in) :: keyword + integer, intent(in) :: fileid + logical, intent(in) :: default + logical, intent(out) :: value ! - call read_line(line, keystr, valstr) + character(len=256) :: keystr + character(len=256) :: valstr + character(len=256) :: line + integer :: stat ! - if (trim(keystr)==trim(keyword)) then + value = default + ! + rewind(fileid) + ! + do while (.true.) ! - 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 + read(fileid, '(a)', iostat=stat) line + if (stat == -1) exit ! - exit + call read_line(line, keystr, valstr) ! - endif + 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 ! - 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. + end subroutine ! - jn = index(line, '\r') + !-----------------------------------------------------------------------------------------------------! ! - if (jn > 0) then + subroutine read_line(line0, keystr, valstr) ! - ! New line character detected (probably sfincs.inp with windows line endings, running in linux) + ! Split one `key = value` line into key and value substrings. + ! Strips leading/trailing whitespace, any tab characters (replaced + ! by spaces via notabs), and a trailing `#`-delimited inline + ! comment. Blank lines and lines starting with `#`, `!`, or `@` + ! return empty strings. ! - 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 + ! Called from: read_real_input / read_real_array_input / + ! read_int_input / read_char_input / read_logical_input. ! - 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) + implicit none + ! + character(*), intent(in) :: line0 + character(*), intent(out) :: keystr + character(*), intent(out) :: valstr + ! + character(len=256) :: line + integer :: j, ilen, jn + ! + keystr = '' + valstr = '' + ! + ! Expand tabs to spaces in-place. + ! + call notabs(line0, line, ilen) + ! + ! Remove Windows-style `\r` line ending if present. + ! + jn = index(line, '\r') + if (jn > 0) line = line(1:jn - 1) + ! + line = trim(line) + ! + if (line(1:1) == '#' .or. line(1:1) == '!' .or. line(1:1) == '@') return + ! + j = index(line, '=') + if (j == 0) return + ! + keystr = trim(line(1:j - 1)) + valstr = trim(line(j + 1:)) + ! + ! Strip inline comment after `#`. + ! + jn = index(valstr, '#') + if (jn > 0) valstr = trim(valstr(1:jn - 1)) + ! + valstr = adjustl(trim(valstr)) + ! + end subroutine ! - use ISO_FORTRAN_ENV, only : ERROR_UNIT ! get unit for standard error. if not supported yet, define ERROR_UNIT for your system (typically 0) - character(len=*),intent(in) :: INSTR ! input line to scan for tab characters - character(len=*),intent(out) :: OUTSTR ! tab-expanded version of INSTR produced - integer,intent(out) :: ILEN ! column position of last character put into output string - - integer,parameter :: TABSIZE=8 ! assume a tab stop is set every 8th column - character(len=1) :: c ! character read from stdin - integer :: ipos ! position in OUTSTR to put next character of INSTR - integer :: lenin ! length of input string trimmed of trailing spaces - integer :: lenout ! number of characters output string can hold - integer :: i10 ! counter that advances thru input string INSTR one character at a time - ! - IPOS=1 ! where to put next character in output string OUTSTR - lenin=len(INSTR) ! length of character variable INSTR - lenin=len_trim(INSTR(1:lenin)) ! length of INSTR trimmed of trailing spaces - lenout=len(OUTSTR) ! number of characters output string OUTSTR can hold - OUTSTR=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters + !-----------------------------------------------------------------------------------------------------! ! - do i10=1,lenin ! look through input string one character at a time - c=INSTR(i10:i10) - if(ichar(c) == 9)then ! test if character is a tab (ADE (ASCII Decimal Equivalent) of tab character is 9) - IPOS = IPOS + (TABSIZE - (mod(IPOS-1,TABSIZE))) - else ! c is anything else other than a tab insert it in output string - if(IPOS > lenout)then - write(ERROR_UNIT,*)"*notabs* output string overflow" - exit + subroutine notabs(instr, outstr, ilen) + ! + ! Expand embedded tab characters into spaces while keeping columns + ! aligned (tab stops every 8 characters). Lets downstream tokenizers + ! treat `key=value` and `key = value` identically. + ! + ! Author: John S. Urban. See also GNU/Unix commands expand(1) / + ! unexpand(1). + ! + ! Called from: read_line (this module). + ! + use iso_fortran_env, only : error_unit + ! + implicit none + ! + character(len=*), intent(in) :: instr ! input line (may contain tab characters) + character(len=*), intent(out) :: outstr ! tab-expanded output + integer, intent(out) :: ilen ! column position of last character written + ! + integer, parameter :: tabsize = 8 ! tab stops every 8th column + character(len=1) :: c + integer :: ipos ! position in outstr for next character + integer :: lenin ! length of instr (trailing blanks trimmed) + integer :: lenout ! capacity of outstr + integer :: i10 ! cursor through instr + ! + ipos = 1 + lenin = len(instr) + lenin = len_trim(instr(1:lenin)) + lenout = len(outstr) + outstr = ' ' + ! + do i10 = 1, lenin + ! + c = instr(i10:i10) + ! + if (ichar(c) == 9) then + ! + ! Tab character: advance ipos to the next tab stop. + ! + ipos = ipos + (tabsize - (mod(ipos - 1, tabsize))) + ! else - OUTSTR(IPOS:IPOS)=c - IPOS=IPOS+1 + ! + if (ipos > lenout) then + write(error_unit, *) '*notabs* output string overflow' + exit + else + outstr(ipos:ipos) = c + ipos = ipos + 1 + endif + ! endif - endif - enddo - ! - ILEN=len_trim(OUTSTR(:IPOS)) ! trim trailing spaces - return + ! + enddo + ! + ilen = len_trim(outstr(:ipos)) + ! + end subroutine ! - end subroutine notabs - - end module diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 5b560e4db..1ca7a220d 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -4354,20 +4354,20 @@ subroutine ncoutput_add_params(ncid, varid) NF90(nf90_put_att(ncid, varid, 'nobs',nobs)) NF90(nf90_put_att(ncid, varid, 'crsfile',crsfile)) ! - NF90(nf90_put_att(ncid, varid, 'storevelmax',storevelmax)) - NF90(nf90_put_att(ncid, varid, 'storefluxmax',storefluxmax)) - NF90(nf90_put_att(ncid, varid, 'storevel',storevel)) - NF90(nf90_put_att(ncid, varid, 'storecumprcp',storecumprcp)) - NF90(nf90_put_att(ncid, varid, 'storetwet',storetwet)) - NF90(nf90_put_att(ncid, varid, 'storehsubgrid',storehsubgrid)) - NF90(nf90_put_att(ncid, varid, 'twet_threshold',twet_threshold)) - NF90(nf90_put_att(ncid, varid, 'store_tsunami_arrival_time',logical2int(store_tsunami_arrival_time))) - NF90(nf90_put_att(ncid, varid, 'tsunami_arrival_threshold',tsunami_arrival_threshold)) - NF90(nf90_put_att(ncid, varid, 'storeqdrain',storeqdrain)) - NF90(nf90_put_att(ncid, varid, 'storezvolume',storezvolume)) - NF90(nf90_put_att(ncid, varid, 'writeruntime',wrttimeoutput)) - NF90(nf90_put_att(ncid, varid, 'debug',logical2int(debug))) - NF90(nf90_put_att(ncid, varid, 'storemeteo',storemeteo)) + NF90(nf90_put_att(ncid, varid, 'storevelmax',logical2int(store_maximum_velocity))) + NF90(nf90_put_att(ncid, varid, 'storefluxmax',logical2int(store_maximum_flux))) + NF90(nf90_put_att(ncid, varid, 'storevel',logical2int(store_velocity))) + NF90(nf90_put_att(ncid, varid, 'storecumprcp',logical2int(store_cumulative_precipitation))) + NF90(nf90_put_att(ncid, varid, 'storetwet',logical2int(store_twet))) + NF90(nf90_put_att(ncid, varid, 'storehsubgrid',logical2int(store_hsubgrid))) + NF90(nf90_put_att(ncid, varid, 'twet_threshold',twet_threshold)) + NF90(nf90_put_att(ncid, varid, 'store_tsunami_arrival_time',logical2int(store_tsunami_arrival_time))) + NF90(nf90_put_att(ncid, varid, 'tsunami_arrival_threshold',tsunami_arrival_threshold)) + NF90(nf90_put_att(ncid, varid, 'storeqdrain',logical2int(store_qdrain))) + NF90(nf90_put_att(ncid, varid, 'storezvolume',logical2int(store_zvolume))) + NF90(nf90_put_att(ncid, varid, 'writeruntime',logical2int(write_time_output))) + NF90(nf90_put_att(ncid, varid, 'debug',logical2int(debug))) + NF90(nf90_put_att(ncid, varid, 'storemeteo',logical2int(store_meteo))) NF90(nf90_put_att(ncid, varid, 'storemaxwind',logical2int(store_wind_max))) NF90(nf90_put_att(ncid, varid, 'storefw',logical2int(store_wave_forces))) NF90(nf90_put_att(ncid, varid, 'storewavdir', logical2int(store_wave_direction))) From 56b59f710cb58da81656aca6f37970cbd8a5dc2f Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 20:12:42 +0200 Subject: [PATCH 44/65] Add generic get_keyword API and legacy aliases Refactor sfincs_input to introduce a generic get_keyword interface (with type-specific module procedures) and get_keyword_real_array. Replace numerous legacy read_* calls with get_keyword, add support for optional legacy alias arrays and per-alias deprecation warnings, and centralize value parsing via find_value/read_line. Add use of sfincs_log, explicit implicit none, and module visibility (private/public + interface). Update wavemaker and forcing keyword handling to try modern names first and fall back to short legacy names. Remove old removed-keyword error checks for bucketfile/bucket_loss_frac and tidy comments/formatting. --- source/src/sfincs_input.f90 | 911 +++++++++++++++++++----------------- 1 file changed, 488 insertions(+), 423 deletions(-) diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 3d7829e51..f291333d7 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -1,13 +1,16 @@ module sfincs_input ! - ! Parser for the SFINCS main input file `sfincs.inp` plus the small set + ! Parser for the SFINCS main input file `sfincs.inp` plus a small set ! of primitive helpers that read one keyword at a time from that file. ! ! `sfincs.inp` is a flat keyword / value text file (one `key = value` - ! pair per line, comment lines start with `#`, `!`, or `@`). A read is - ! performed by rewinding the file, scanning until the matching key is - ! found, and extracting the value string. When the key is absent, the - ! caller's supplied default is returned. + ! pair per line, comment lines start with `#`, `!`, or `@`). Reads go + ! through the generic `get_keyword(...)` interface below. Every call + ! accepts an optional array of deprecated keyword aliases — the new + ! key is tried first, then each legacy alias in order, then the + ! caller's supplied default. A one-line warning is written to the log + ! the first time an alias is matched, so users see that their .inp is + ! using a deprecated name. ! ! The module does not own the variables it fills — it writes directly ! into module-level state declared in sfincs_data, sfincs_src_structures, @@ -16,37 +19,57 @@ module sfincs_input ! Subroutines: ! ! read_sfincs_input() - ! Main driver. Opens sfincs.inp, calls the per-type helpers below - ! once per keyword, then derives secondary flags (e.g. crsgeo vs. + ! Main driver. Opens sfincs.inp, pulls every keyword it knows + ! about via get_keyword(), then derives secondary flags (CRS / ! Coriolis, subgrid vs. regular, bathtub overrides). Called once ! from sfincs_initialize (sfincs_lib). ! - ! read_real_input(fileid, keyword, value, default) - ! Read one real*4 keyword. Called from read_sfincs_input. + ! get_keyword(fileid, keyword, value, default [, legacy]) + ! Generic interface; resolves by the type of `value`. Type- + ! specific module procedures do the actual scan: + ! get_keyword_real (real*4 scalar) + ! get_keyword_int (integer scalar) + ! get_keyword_char (character*(*) scalar) + ! get_keyword_logical (logical scalar) + ! Called from read_sfincs_input. ! - ! read_real_array_input(fileid, keyword, value, default, nr) - ! Read one space-separated real*4 array keyword. Called from - ! read_sfincs_input. + ! get_keyword_real_array(fileid, keyword, value, default, nr [, legacy]) + ! Variant for whitespace-separated real arrays (sized nr). + ! Called from read_sfincs_input. ! - ! read_int_input(fileid, keyword, value, default) - ! Read one integer keyword. Called from read_sfincs_input. + ! find_value(fileid, keyword, valstr, found) + ! Scan the file once for a single keyword; return the raw value + ! string and whether it was found. Called from each + ! get_keyword_* procedure. ! - ! read_char_input(fileid, keyword, value, default) - ! Read one character-string keyword. Called from read_sfincs_input. - ! - ! read_logical_input(fileid, keyword, value, default) - ! Read one logical keyword. Accepts `1/0`, `y/n`, `t/f` (upper or - ! lower) as true/false. Called from read_sfincs_input. + ! warn_legacy(legacy_key, new_key) + ! Emit a deprecation warning to the log. Called from each + ! get_keyword_* procedure when a legacy alias has been resolved. ! ! read_line(line0, keystr, valstr) - ! Strip tab/line-ending noise, split `key = value` on the first `=`, - ! strip any trailing `# ...` inline comment. Called from each of - ! the read_*_input helpers. + ! Strip tab/line-ending noise, split `key = value` on the first + ! `=`, strip any trailing `# ...` inline comment. Called from + ! find_value. ! ! notabs(instr, outstr, ilen) ! Expand embedded tab characters into spaces preserving 8-column ! tab stops. Called from read_line. ! + use sfincs_log, only: write_log, logstr + ! + implicit none + ! + private + public :: read_sfincs_input + public :: get_keyword, get_keyword_real_array + ! + interface get_keyword + module procedure get_keyword_real + module procedure get_keyword_int + module procedure get_keyword_char + module procedure get_keyword_logical + end interface + ! contains ! @@ -63,18 +86,17 @@ subroutine read_sfincs_input() ! use sfincs_data use sfincs_date - use sfincs_log use sfincs_error use sfincs_src_structures, only: drnfile use sfincs_discharges, only: srcfile, disfile, netsrcdisfile ! implicit none ! - integer*8 :: dtsec - logical :: ok - character(len=256) :: wmsigstr - character(len=256) :: advstr - character(len=256) :: removed_input + integer*8 :: dtsec + logical :: ok + character(len=256) :: wmsigstr + character(len=256) :: advstr + character(len=256) :: removed_input ! ok = check_file_exists('sfincs.inp', 'SFINCS input file', .true.) ! @@ -82,286 +104,240 @@ subroutine read_sfincs_input() ! ! Grid geometry and time window ! - call read_int_input(500, 'mmax', mmax, 0) ! number of grid cells in m-direction - call read_int_input(500, 'nmax', nmax, 0) ! number of grid cells in n-direction - call read_real_input(500, 'dx', dx, 0.0) ! cell size in m-direction (m) - call read_real_input(500, 'dy', dy, 0.0) ! cell size in n-direction (m) - call read_real_input(500, 'x0', x0, 0.0) ! grid origin x (m or deg) - call read_real_input(500, 'y0', y0, 0.0) ! grid origin y (m or deg) - call read_real_input(500, 'rotation', rotation, 0.0) ! grid rotation (deg, counter-clockwise from east) - call read_char_input(500, 'tref', trefstr, 'none') ! reference time (yyyymmdd HHMMSS); defaults to tstart - call read_char_input(500, 'tstart', tstartstr, '20000101 000000') ! simulation start time - call read_char_input(500, 'tstop', tstopstr, '20000101 000000') ! simulation stop time - call read_real_input(500, 'tspinup', tspinup, 0.0) ! spin-up interval after t0 (s) - call read_real_input(500, 't0out', t0out, -999.0) ! output start time (s rel. tref); -999 = t0 - call read_real_input(500, 't1out', t1out, -999.0) ! output stop time (s rel. tref); -999 = t1 - call read_real_input(500, 'dtout', dtmapout, 0.0) ! map output interval (s); 0 = no map output - call read_real_input(500, 'dtmaxout', dtmaxout, 9999999.0) ! zsmax etc. interval (s); 0 = end-of-run only - call read_real_input(500, 'dtrstout', dtrstout, 0.0) ! restart interval (s); 0 = no periodic restart - call read_real_input(500, 'trstout', trst, -999.0) ! single restart time (s rel. tref); -999 = unused - call read_real_input(500, 'dthisout', dthisout, 600.0) ! his output interval (s) - call read_real_input(500, 'dtwave', dtwave, 3600.0) ! SnapWave update interval (s) - call read_real_input(500, 'dtwnd', dtwindupd, 1800.0) ! 2D meteo update interval (s) + call get_keyword(500, 'mmax', mmax, 0) ! number of grid cells in m-direction + call get_keyword(500, 'nmax', nmax, 0) ! number of grid cells in n-direction + call get_keyword(500, 'dx', dx, 0.0) ! cell size in m-direction (m) + call get_keyword(500, 'dy', dy, 0.0) ! cell size in n-direction (m) + call get_keyword(500, 'x0', x0, 0.0) ! grid origin x (m or deg) + call get_keyword(500, 'y0', y0, 0.0) ! grid origin y (m or deg) + call get_keyword(500, 'rotation', rotation, 0.0) ! grid rotation (deg, counter-clockwise from east) + call get_keyword(500, 'tref', trefstr, 'none') ! reference time (yyyymmdd HHMMSS); defaults to tstart + call get_keyword(500, 'tstart', tstartstr, '20000101 000000') ! simulation start time + call get_keyword(500, 'tstop', tstopstr, '20000101 000000') ! simulation stop time + call get_keyword(500, 'tspinup', tspinup, 0.0) ! spin-up interval after t0 (s) + call get_keyword(500, 't0out', t0out, -999.0) ! output start time (s rel. tref); -999 = t0 + call get_keyword(500, 't1out', t1out, -999.0) ! output stop time (s rel. tref); -999 = t1 + call get_keyword(500, 'dtout', dtmapout, 0.0) ! map output interval (s); 0 = no map output + call get_keyword(500, 'dtmaxout', dtmaxout, 9999999.0) ! zsmax etc. interval (s); 0 = end-of-run only + call get_keyword(500, 'dtrstout', dtrstout, 0.0) ! restart interval (s); 0 = no periodic restart + call get_keyword(500, 'trstout', trst, -999.0) ! single restart time (s rel. tref); -999 = unused + call get_keyword(500, 'dthisout', dthisout, 600.0) ! his output interval (s) + call get_keyword(500, 'dtwave', dtwave, 3600.0) ! SnapWave update interval (s) + call get_keyword(500, 'dtwnd', dtwindupd, 1800.0) ! 2D meteo update interval (s) ! ! Solver and physical constants ! - call read_real_input(500, 'alpha', alfa, 0.50) ! CFL Courant factor - call read_real_input(500, 'theta', theta, 1.0) ! semi-implicit theta; <1 adds smoothing - call read_real_input(500, 'hmin_cfl', hmin_cfl, 0.1) ! minimum depth used in CFL check (m) - call read_real_input(500, 'manning', manning, 0.04) ! uniform Manning n (s/m^(1/3)) - call read_real_input(500, 'manning_land', manning_land, -999.0) ! Manning n above rghlevland (s/m^(1/3)) - call read_real_input(500, 'manning_sea', manning_sea, -999.0) ! Manning n below rghlevland (s/m^(1/3)) - call read_real_input(500, 'rgh_lev_land', rghlevland, 0.0) ! bed level separating land/sea friction (m) - call read_real_input(500, 'zsini', zini, 0.0) ! initial water level (m) - call read_real_input(500, 'qinf', qinf, 0.0) ! uniform infiltration rate (mm/hr); converted below - call read_real_input(500, 'dtmax', dtmax, 60.0) ! upper bound on computational dt (s) - call read_real_input(500, 'huthresh', huthresh, 0.05) ! wet/dry depth threshold (m) - call read_real_input(500, 'huvmin', huvmin, 0.0) ! minimum depth for uv = q / max(hu, huvmin) (output + advection) - call read_real_input(500, 'rhoa', rhoa, 1.25) ! air density (kg/m3) - call read_real_input(500, 'rhow', rhow, 1024.0) ! water density (kg/m3) - call read_char_input(500, 'inputformat', inputtype, 'bin') ! legacy bin/asc toggle for binary inputs - call read_char_input(500, 'outputformat', outputtype, 'net') ! global output format (bin/asc/net) - call read_char_input(500, 'outputtype_map', outputtype_map, 'nil') ! map-file output format (nil = follow outputformat) - call read_char_input(500, 'outputtype_his', outputtype_his, 'nil') ! his-file output format (nil = follow outputformat) - call read_int_input(500, 'nc_deflate_level', nc_deflate_level, 2) ! netCDF deflate level (0-9) - call read_int_input(500, 'bndtype', bndtype, 1) ! boundary condition type - call read_logical_input(500, 'advection', advection, .true.) ! enable momentum advection terms - call read_real_input(500, 'latitude', latitude, 0.0) ! reference latitude for projected Coriolis (deg) - call read_real_input(500, 'pavbnd', pavbnd, 0.0) ! atmospheric pressure applied at boundary (Pa) - call read_real_input(500, 'gapres', gapres, 101200.0) ! atmospheric reference pressure (Pa) - call read_int_input(500, 'baro', baro, 1) ! include atmospheric-pressure gradient (1=on, 0=off) - call read_char_input(500, 'utmzone', utmzone, 'nil') ! UTM zone string (e.g. '17N') - call read_int_input(500, 'epsg', epsg, 0) ! EPSG integer code for the grid - call read_char_input(500, 'epsg', epsg_code, 'nil') ! EPSG as string (fallback) - call read_real_input(500, 'advlim', advlim, 1.0) ! cap on advection term - call read_real_input(500, 'slopelim', slopelim, 9999.9) ! cap on bed-slope water-level gradient - call read_real_input(500, 'qinf_zmin', qinf_zmin, 0.0) ! minimum bed level for infiltration to apply (m) - call read_real_input(500, 'btfilter', btfilter, 60.0) ! bathtub filter time scale (s) - call read_real_input(500, 'sfacinf', sfacinf, 0.2) ! SCS initial-abstraction fraction (0.2S) - call read_logical_input(500, 'radstr', radstr, .false.) ! radiation-stress forcing from SnapWave - call read_logical_input(500, 'crsgeo', crsgeo, .false.) ! interpret grid coords as geographic (WGS84) - call read_logical_input(500, 'coriolis', coriolis, .true.) ! include Coriolis force - call read_logical_input(500, 'amprblock', ampr_block, .true.) ! treat 2D rainfall as block (true) or linearly interpolated (false) - call read_real_input(500, 'spwmergefrac', spw_merge_frac, 0.5) ! merge factor for spiderweb wind composite - call read_logical_input(500, 'usespwprecip', use_spw_precip, .true.) ! use precipitation field from spiderweb file - call read_logical_input(500, 'global', global, .false.) ! treat grid as global (wrap in x) - call read_real_input(500, 'nuvisc', nuviscdim, 0.01) ! viscosity coefficient (m2/s) - call read_logical_input(500, 'viscosity', viscosity, .false.) ! enable horizontal viscosity term - call read_logical_input(500, 'spinup_meteo', spinup_meteo, .false.) ! ramp wind/pressure from zero during tspinup - call read_real_input(500, 'waveage', waveage, -999.0) ! wave age (for SnapWave wind growth) - call read_logical_input(500, 'snapwave', snapwave, .false.) ! enable coupled SnapWave wave solver - call read_logical_input(500, 'dtoutfixed', fixed_output_intervals, .true.) ! snap map/his to exact intervals (true) or let them drift with dt (false) - ! - ! Wave maker parameters. Old 3-letter keywords (wvmfile, wfpfile, - ! whifile, wtifile, wstfile, wmtfilter, wmfred, wmsignal, wmhmin, - ! nfreqsinc/ig, freq*min/max*inc/ig) are retained for backward - ! compatibility; the wavemaker_ keywords below override them - ! when supplied. - ! - call read_char_input(500, 'wavemaker_wvmfile', wavemaker_wvmfile, 'none') ! wavemaker polyline file - if (wavemaker_wvmfile(1:4) == 'none') & - call read_char_input(500, 'wvmfile', wavemaker_wvmfile, 'none') ! legacy keyword - call read_char_input(500, 'wavemaker_wfpfile', wavemaker_wfpfile, 'none') ! wavemaker forcing points file - if (wavemaker_wfpfile(1:4) == 'none') & - call read_char_input(500, 'wfpfile', wavemaker_wfpfile, 'none') ! legacy keyword - call read_char_input(500, 'wavemaker_whifile', wavemaker_whifile, 'none') ! wavemaker wave-height time series file - if (wavemaker_whifile(1:4) == 'none') & - call read_char_input(500, 'whifile', wavemaker_whifile, 'none') ! legacy keyword - call read_char_input(500, 'wavemaker_wtifile', wavemaker_wtifile, 'none') ! wavemaker wave-period time series file - if (wavemaker_wtifile(1:4) == 'none') & - call read_char_input(500, 'wtifile', wavemaker_wtifile, 'none') ! legacy keyword - call read_char_input(500, 'wavemaker_wstfile', wavemaker_wstfile, 'none') ! wavemaker wave set-up time series file - if (wavemaker_wstfile(1:4) == 'none') & - call read_char_input(500, 'wstfile', wavemaker_wstfile, 'none') ! legacy keyword - ! - call read_real_input(500, 'wmtfilter', wavemaker_filter_time, 600.0) ! wavemaker filter time scale (s, legacy keyword) - call read_real_input(500, 'wavemaker_filter_time', wavemaker_filter_time, wavemaker_filter_time) ! override with new keyword if present - call read_real_input(500, 'wmfred', wavemaker_filter_fred, 0.99) ! wavemaker filter fred (legacy keyword) - call read_real_input(500, 'wavemaker_filter_fred', wavemaker_filter_fred, wavemaker_filter_fred) ! override with new keyword if present - call read_char_input(500, 'wmsignal', wmsigstr, 'spectrum') ! wavemaker signal type (legacy keyword) - call read_char_input(500, 'wavemaker_signal', wmsigstr, trim(wmsigstr)) ! override with new keyword if present - call read_real_input(500, 'wmhmin', wavemaker_hmin, 0.1) ! wavemaker minimum depth for wave generation (legacy keyword) - call read_real_input(500, 'wavemaker_hmin', wavemaker_hmin, wavemaker_hmin) ! override with new keyword if present - call read_int_input(500, 'nfreqsinc', wavemaker_nfreqs_inc, 100) ! wavemaker number of incident-wave frequencies (legacy) - call read_int_input(500, 'wavemaker_nfreqs_inc', wavemaker_nfreqs_inc, wavemaker_nfreqs_inc) ! override - call read_real_input(500, 'freqmininc', wavemaker_freqmin_inc, 0.04) ! wavemaker incident-wave min frequency (Hz, legacy) - call read_real_input(500, 'wavemaker_freqmin_inc', wavemaker_freqmin_inc, wavemaker_freqmin_inc) ! override - call read_real_input(500, 'freqmaxinc', wavemaker_freqmax_inc, 1.0) ! wavemaker incident-wave max frequency (Hz, legacy) - call read_real_input(500, 'wavemaker_freqmax_inc', wavemaker_freqmax_inc, wavemaker_freqmax_inc) ! override - call read_int_input(500, 'nfreqsig', wavemaker_nfreqs_ig, 100) ! wavemaker number of IG-wave frequencies (legacy) - call read_int_input(500, 'wavemaker_nfreqs_ig', wavemaker_nfreqs_ig, wavemaker_nfreqs_ig) ! override - call read_real_input(500, 'freqminig', wavemaker_freqmin_ig, 0.0) ! wavemaker IG-wave min frequency (Hz, legacy) - call read_real_input(500, 'wavemaker_freqmin_ig', wavemaker_freqmin_ig, wavemaker_freqmin_ig) ! override - call read_real_input(500, 'freqmaxig', wavemaker_freqmax_ig, 0.1) ! wavemaker IG-wave max frequency (Hz, legacy) - call read_real_input(500, 'wavemaker_freqmax_ig', wavemaker_freqmax_ig, wavemaker_freqmax_ig) ! override - ! - call read_real_input(500, 'wavemaker_tinc2ig', wavemaker_tinc2ig, -1.0) ! wavemaker ig/inc period ratio (<=0 uses Herbers) - call read_real_input(500, 'wavemaker_surfslope', wavemaker_surfslope, -1.0) ! wavemaker surf-zone slope for empirical Tp_ig (van Ormondt et al., 2021) - call read_real_input(500, 'wavemaker_hm0_ig_factor', wavemaker_hm0_ig_factor, 1.0) ! wavemaker IG Hm0 scaling factor - call read_real_input(500, 'wavemaker_hm0_inc_factor', wavemaker_hm0_inc_factor, 1.0) ! wavemaker incident Hm0 scaling factor - call read_real_input(500, 'wavemaker_gammax', wavemaker_gammax, 1.0) ! wavemaker maximum Hrms/h - call read_real_input(500, 'wavemaker_tpmin', wavemaker_tpmin, 1.0) ! wavemaker minimum Tp (s) - call read_logical_input(500, 'wavemaker_hig', wavemaker_hig, .true.) ! wavemaker include IG waves - call read_logical_input(500, 'wavemaker_hinc', wavemaker_hinc, .false.) ! wavemaker include incident waves + call get_keyword(500, 'alpha', alfa, 0.50) ! CFL Courant factor + call get_keyword(500, 'theta', theta, 1.0) ! semi-implicit theta; <1 adds smoothing + call get_keyword(500, 'hmin_cfl', hmin_cfl, 0.1) ! minimum depth used in CFL check (m) + call get_keyword(500, 'manning', manning, 0.04) ! uniform Manning n (s/m^(1/3)) + call get_keyword(500, 'manning_land', manning_land, -999.0) ! Manning n above rghlevland (s/m^(1/3)) + call get_keyword(500, 'manning_sea', manning_sea, -999.0) ! Manning n below rghlevland (s/m^(1/3)) + call get_keyword(500, 'rgh_lev_land', rghlevland, 0.0) ! bed level separating land/sea friction (m) + call get_keyword(500, 'zsini', zini, 0.0) ! initial water level (m) + call get_keyword(500, 'qinf', qinf, 0.0) ! uniform infiltration rate (mm/hr); converted below + call get_keyword(500, 'dtmax', dtmax, 60.0) ! upper bound on computational dt (s) + call get_keyword(500, 'huthresh', huthresh, 0.05) ! wet/dry depth threshold (m) + call get_keyword(500, 'huvmin', huvmin, 0.0) ! minimum depth for uv = q / max(hu, huvmin) + call get_keyword(500, 'rhoa', rhoa, 1.25) ! air density (kg/m3) + call get_keyword(500, 'rhow', rhow, 1024.0) ! water density (kg/m3) + call get_keyword(500, 'inputformat', inputtype, 'bin') ! legacy bin/asc toggle for binary inputs + call get_keyword(500, 'outputformat', outputtype, 'net') ! global output format (bin/asc/net) + call get_keyword(500, 'outputtype_map', outputtype_map, 'nil') ! map-file output format (nil = follow outputformat) + call get_keyword(500, 'outputtype_his', outputtype_his, 'nil') ! his-file output format (nil = follow outputformat) + call get_keyword(500, 'nc_deflate_level', nc_deflate_level, 2) ! netCDF deflate level (0-9) + call get_keyword(500, 'bndtype', bndtype, 1) ! boundary condition type + call get_keyword(500, 'advection', advection, .true.) ! enable momentum advection terms + call get_keyword(500, 'latitude', latitude, 0.0) ! reference latitude for projected Coriolis (deg) + call get_keyword(500, 'pavbnd', pavbnd, 0.0) ! atmospheric pressure applied at boundary (Pa) + call get_keyword(500, 'gapres', gapres, 101200.0) ! atmospheric reference pressure (Pa) + call get_keyword(500, 'baro', baro, 1) ! include atmospheric-pressure gradient (1=on, 0=off) + call get_keyword(500, 'utmzone', utmzone, 'nil') ! UTM zone string (e.g. '17N') + call get_keyword(500, 'epsg', epsg, 0) ! EPSG integer code for the grid + call get_keyword(500, 'epsg', epsg_code, 'nil') ! EPSG as string (fallback) + call get_keyword(500, 'advlim', advlim, 1.0) ! cap on advection term + call get_keyword(500, 'slopelim', slopelim, 9999.9) ! cap on bed-slope water-level gradient + call get_keyword(500, 'qinf_zmin', qinf_zmin, 0.0) ! minimum bed level for infiltration to apply (m) + call get_keyword(500, 'btfilter', btfilter, 60.0) ! bathtub filter time scale (s) + call get_keyword(500, 'sfacinf', sfacinf, 0.2) ! SCS initial-abstraction fraction (0.2S) + call get_keyword(500, 'radstr', radstr, .false.) ! radiation-stress forcing from SnapWave + call get_keyword(500, 'crsgeo', crsgeo, .false.) ! interpret grid coords as geographic (WGS84) + call get_keyword(500, 'coriolis', coriolis, .true.) ! include Coriolis force + call get_keyword(500, 'amprblock', ampr_block, .true.) ! treat 2D rainfall as block (true) or linearly interpolated (false) + call get_keyword(500, 'spwmergefrac', spw_merge_frac, 0.5) ! merge factor for spiderweb wind composite + call get_keyword(500, 'usespwprecip', use_spw_precip, .true.) ! use precipitation field from spiderweb file + call get_keyword(500, 'global', global, .false.) ! treat grid as global (wrap in x) + call get_keyword(500, 'nuvisc', nuviscdim, 0.01) ! viscosity coefficient (m2/s) + call get_keyword(500, 'viscosity', viscosity, .false.) ! enable horizontal viscosity term + call get_keyword(500, 'spinup_meteo', spinup_meteo, .false.) ! ramp wind/pressure from zero during tspinup + call get_keyword(500, 'waveage', waveage, -999.0) ! wave age (for SnapWave wind growth) + call get_keyword(500, 'snapwave', snapwave, .false.) ! enable coupled SnapWave wave solver + call get_keyword(500, 'dtoutfixed', fixed_output_intervals, .true.) ! snap map/his to exact intervals (true) or let them drift with dt (false) + ! + ! Wave maker parameters. Each call tries the modern `wavemaker_*` + ! keyword first and falls back to the legacy shortname in the + ! trailing array; a deprecation warning is emitted per legacy + ! match. + ! + call get_keyword(500, 'wavemaker_wvmfile', wavemaker_wvmfile, 'none', ['wvmfile']) ! wavemaker polyline file + call get_keyword(500, 'wavemaker_wfpfile', wavemaker_wfpfile, 'none', ['wfpfile']) ! wavemaker forcing points file + call get_keyword(500, 'wavemaker_whifile', wavemaker_whifile, 'none', ['whifile']) ! wavemaker wave-height time series file + call get_keyword(500, 'wavemaker_wtifile', wavemaker_wtifile, 'none', ['wtifile']) ! wavemaker wave-period time series file + call get_keyword(500, 'wavemaker_wstfile', wavemaker_wstfile, 'none', ['wstfile']) ! wavemaker wave set-up time series file + call get_keyword(500, 'wavemaker_filter_time', wavemaker_filter_time, 600.0, ['wmtfilter']) ! wavemaker filter time scale (s) + call get_keyword(500, 'wavemaker_filter_fred', wavemaker_filter_fred, 0.99, ['wmfred']) ! wavemaker filter fred + call get_keyword(500, 'wavemaker_signal', wmsigstr, 'spectrum',['wmsignal']) ! wavemaker signal type (spectrum or monochromatic) + call get_keyword(500, 'wavemaker_hmin', wavemaker_hmin, 0.1, ['wmhmin']) ! wavemaker minimum depth for wave generation (m) + call get_keyword(500, 'wavemaker_nfreqs_inc', wavemaker_nfreqs_inc, 100, ['nfreqsinc']) ! wavemaker number of incident-wave frequencies + call get_keyword(500, 'wavemaker_freqmin_inc', wavemaker_freqmin_inc, 0.04, ['freqmininc']) ! wavemaker incident-wave min frequency (Hz) + call get_keyword(500, 'wavemaker_freqmax_inc', wavemaker_freqmax_inc, 1.0, ['freqmaxinc']) ! wavemaker incident-wave max frequency (Hz) + call get_keyword(500, 'wavemaker_nfreqs_ig', wavemaker_nfreqs_ig, 100, ['nfreqsig']) ! wavemaker number of IG-wave frequencies + call get_keyword(500, 'wavemaker_freqmin_ig', wavemaker_freqmin_ig, 0.0, ['freqminig']) ! wavemaker IG-wave min frequency (Hz) + call get_keyword(500, 'wavemaker_freqmax_ig', wavemaker_freqmax_ig, 0.1, ['freqmaxig']) ! wavemaker IG-wave max frequency (Hz) + call get_keyword(500, 'wavemaker_tinc2ig', wavemaker_tinc2ig, -1.0) ! wavemaker ig/inc period ratio (<=0 uses Herbers) + call get_keyword(500, 'wavemaker_surfslope', wavemaker_surfslope, -1.0) ! wavemaker surf-zone slope for empirical Tp_ig (van Ormondt et al., 2021) + call get_keyword(500, 'wavemaker_hm0_ig_factor', wavemaker_hm0_ig_factor, 1.0) ! wavemaker IG Hm0 scaling factor + call get_keyword(500, 'wavemaker_hm0_inc_factor', wavemaker_hm0_inc_factor, 1.0) ! wavemaker incident Hm0 scaling factor + call get_keyword(500, 'wavemaker_gammax', wavemaker_gammax, 1.0) ! wavemaker maximum Hrms/h + call get_keyword(500, 'wavemaker_tpmin', wavemaker_tpmin, 1.0) ! wavemaker minimum Tp (s) + call get_keyword(500, 'wavemaker_hig', wavemaker_hig, .true.) ! wavemaker include IG waves + call get_keyword(500, 'wavemaker_hinc', wavemaker_hinc, .false.) ! wavemaker include incident waves ! ! Numerical parameters ! - call read_char_input(500, 'advection_scheme', advstr, 'upw1') ! advection scheme label ('upw1' = 1st-order upwind, 'original' = legacy) - call read_real_input(500, 'btrelax', btrelax, 3600.0) ! bathtub relaxation time (s) - call read_logical_input(500, 'wiggle_suppression', wiggle_suppression, .true.) ! suppress spurious free-surface oscillations - call read_real_input(500, 'structure_relax', structure_relax, 4.0) ! drainage-structure state-machine smoothing steps - call read_real_input(500, 'wiggle_factor', wiggle_factor, 0.1) ! wiggle-suppression amplitude factor - call read_real_input(500, 'wiggle_threshold', wiggle_threshold, 0.1) ! wiggle-suppression trigger threshold - call read_real_input(500, 'uvlim', uvlim, 10.0) ! clipping velocity for momentum (m/s) - call read_real_input(500, 'uvmax', uvmax, 1000.0) ! error-trigger velocity for momentum (m/s) - call read_logical_input(500, 'friction2d', friction2d, .true.) ! apply friction at every UV point (true) or cell-wise (false) - call read_logical_input(500, 'advection_mask', advection_mask, .true.) ! mask advection near dry cells - call read_real_input(500, 'nuviscfac', nuviscfac, 100.0) ! multiplier on nuvisc near "difficult" points - call read_logical_input(500, 'nonh', nonhydrostatic, .false.) ! enable non-hydrostatic pressure corrector - call read_real_input(500, 'nh_fnudge', nh_fnudge, 0.9) ! non-hydrostatic nudging factor - call read_real_input(500, 'nh_tstop', nh_tstop, -999.0) ! non-hydrostatic stop time (s rel. tref); -999 = t1+999 - call read_real_input(500, 'nh_tol', nh_tol, 0.001) ! non-hydrostatic solver tolerance - call read_int_input(500, 'nh_itermax', nh_itermax, 100) ! non-hydrostatic solver max iterations - call read_logical_input(500, 'h73table', h73table, .false.) ! tabulate h^(7/3) for friction - call read_real_input(500, 'rugdepth', runup_gauge_depth, 0.05) ! runup gauge trigger depth (m) - call read_logical_input(500, 'wave_enhanced_roughness', wave_enhanced_roughness, .false.) ! augment bed roughness with wave orbital velocity - call read_logical_input(500, 'use_bcafile', use_bcafile, .true.) ! use tidal components from bca file - call read_real_input(500, 'factor_wind', factor_wind, 1.0) ! scaling factor on wind forcing - call read_real_input(500, 'factor_pres', factor_pres, 1.0) ! scaling factor on atmospheric pressure - call read_real_input(500, 'factor_prcp', factor_prcp, 1.0) ! scaling factor on precipitation - call read_real_input(500, 'factor_spw_size', factor_spw_size, 1.0) ! scaling factor on spiderweb radius - call read_logical_input(500, 'bathtub', bathtub, .false.) ! run in bathtub (no momentum) mode - call read_real_input(500, 'bathtub_fachs', bathtub_fac_hs, 0.2) ! bathtub Hs multiplier - call read_real_input(500, 'bathtub_dt', bathtub_dt, -999.0) ! bathtub time step (s); -999 = use dtmapout + call get_keyword(500, 'advection_scheme', advstr, 'upw1') ! advection scheme label ('upw1' = 1st-order upwind, 'original' = legacy) + call get_keyword(500, 'btrelax', btrelax, 3600.0) ! bathtub relaxation time (s) + call get_keyword(500, 'wiggle_suppression', wiggle_suppression, .true.) ! suppress spurious free-surface oscillations + call get_keyword(500, 'structure_relax', structure_relax, 4.0) ! drainage-structure state-machine smoothing steps + call get_keyword(500, 'wiggle_factor', wiggle_factor, 0.1) ! wiggle-suppression amplitude factor + call get_keyword(500, 'wiggle_threshold', wiggle_threshold, 0.1) ! wiggle-suppression trigger threshold + call get_keyword(500, 'uvlim', uvlim, 10.0) ! clipping velocity for momentum (m/s) + call get_keyword(500, 'uvmax', uvmax, 1000.0) ! error-trigger velocity for momentum (m/s) + call get_keyword(500, 'friction2d', friction2d, .true.) ! apply friction at every UV point (true) or cell-wise (false) + call get_keyword(500, 'advection_mask', advection_mask, .true.) ! mask advection near dry cells + call get_keyword(500, 'nuviscfac', nuviscfac, 100.0) ! multiplier on nuvisc near "difficult" points + call get_keyword(500, 'nonh', nonhydrostatic, .false.) ! enable non-hydrostatic pressure corrector + call get_keyword(500, 'nh_fnudge', nh_fnudge, 0.9) ! non-hydrostatic nudging factor + call get_keyword(500, 'nh_tstop', nh_tstop, -999.0) ! non-hydrostatic stop time (s rel. tref); -999 = t1+999 + call get_keyword(500, 'nh_tol', nh_tol, 0.001) ! non-hydrostatic solver tolerance + call get_keyword(500, 'nh_itermax', nh_itermax, 100) ! non-hydrostatic solver max iterations + call get_keyword(500, 'h73table', h73table, .false.) ! tabulate h^(7/3) for friction + call get_keyword(500, 'rugdepth', runup_gauge_depth, 0.05) ! runup gauge trigger depth (m) + call get_keyword(500, 'wave_enhanced_roughness', wave_enhanced_roughness, .false.) ! augment bed roughness with wave orbital velocity + call get_keyword(500, 'use_bcafile', use_bcafile, .true.) ! use tidal components from bca file + call get_keyword(500, 'factor_wind', factor_wind, 1.0) ! scaling factor on wind forcing + call get_keyword(500, 'factor_pres', factor_pres, 1.0) ! scaling factor on atmospheric pressure + call get_keyword(500, 'factor_prcp', factor_prcp, 1.0) ! scaling factor on precipitation + call get_keyword(500, 'factor_spw_size', factor_spw_size, 1.0) ! scaling factor on spiderweb radius + call get_keyword(500, 'bathtub', bathtub, .false.) ! run in bathtub (no momentum) mode + call get_keyword(500, 'bathtub_fachs', bathtub_fac_hs, 0.2) ! bathtub Hs multiplier + call get_keyword(500, 'bathtub_dt', bathtub_dt, -999.0) ! bathtub time step (s); -999 = use dtmapout ! ! Domain files ! - call read_char_input(500, 'qtrfile', qtrfile, 'none') ! quadtree netCDF file - call read_char_input(500, 'depfile', depfile, 'none') ! bed-level (depth) file - call read_char_input(500, 'inifile', zsinifile, 'none') ! initial water-level file - call read_char_input(500, 'rstfile', rstfile, 'none') ! restart input file - call read_char_input(500, 'mskfile', mskfile, 'none') ! active-cell mask file - call read_char_input(500, 'indexfile', indexfile, 'none') ! index-to-active-cell mapping file - call read_char_input(500, 'cstfile', cstfile, 'none') ! coastline polyline file - call read_char_input(500, 'sbgfile', sbgfile, 'none') ! subgrid tables netCDF file - call read_char_input(500, 'thdfile', thdfile, 'none') ! thin dams polyline file - call read_char_input(500, 'weirfile', weirfile, 'none') ! weirs polyline file - call read_char_input(500, 'manningfile', manningfile, 'none') ! spatially-varying Manning n file - call read_char_input(500, 'drnfile', drnfile, 'none') ! drainage-structures (pumps/gates/culverts) TOML file - call read_char_input(500, 'urbfile', urbfile, 'none') ! urban drainage zones TOML file - call read_char_input(500, 'volfile', volfile, 'none') ! depression-storage volume file + call get_keyword(500, 'qtrfile', qtrfile, 'none') ! quadtree netCDF file + call get_keyword(500, 'depfile', depfile, 'none') ! bed-level (depth) file + call get_keyword(500, 'inifile', zsinifile, 'none') ! initial water-level file + call get_keyword(500, 'rstfile', rstfile, 'none') ! restart input file + call get_keyword(500, 'mskfile', mskfile, 'none') ! active-cell mask file + call get_keyword(500, 'indexfile', indexfile, 'none') ! index-to-active-cell mapping file + call get_keyword(500, 'cstfile', cstfile, 'none') ! coastline polyline file + call get_keyword(500, 'sbgfile', sbgfile, 'none') ! subgrid tables netCDF file + call get_keyword(500, 'thdfile', thdfile, 'none') ! thin dams polyline file + call get_keyword(500, 'weirfile', weirfile, 'none') ! weirs polyline file + call get_keyword(500, 'manningfile', manningfile, 'none') ! spatially-varying Manning n file + call get_keyword(500, 'drnfile', drnfile, 'none') ! drainage-structures (pumps/gates/culverts) TOML file + call get_keyword(500, 'urbfile', urbfile, 'none') ! urban drainage zones TOML file + call get_keyword(500, 'volfile', volfile, 'none') ! depression-storage volume file ! ! Forcing files (ascii / binary) ! - call read_char_input(500, 'bndfile', bndfile, 'none') ! water-level boundary points - call read_char_input(500, 'bzsfile', bzsfile, 'none') ! water-level boundary time series - call read_char_input(500, 'bcafile', bcafile, 'none') ! tidal components per boundary point - call read_char_input(500, 'bzifile', bzifile, 'none') ! IG wave boundary time series - call read_char_input(500, 'bdrfile', bdrfile, 'none') ! downstream river boundary file - call read_char_input(500, 'srcfile', srcfile, 'none') ! river-point source locations - call read_char_input(500, 'disfile', disfile, 'none') ! river-point discharge time series - call read_char_input(500, 'spwfile', spwfile, 'none') ! spiderweb tropical-cyclone file - call read_char_input(500, 'wndfile', wndfile, 'none') ! uniform wind time series - call read_char_input(500, 'prcfile', prcpfile, 'none') ! uniform precipitation time series - if (prcpfile(1:4) == 'none') then - ! - call read_char_input(500, 'precipfile', prcpfile, 'none') ! legacy keyword for prcfile - ! - endif - call read_char_input(500, 'amufile', amufile, 'none') ! 2D wind u-component file - call read_char_input(500, 'amvfile', amvfile, 'none') ! 2D wind v-component file - call read_char_input(500, 'ampfile', ampfile, 'none') ! 2D atmospheric pressure file - call read_char_input(500, 'amprfile', amprfile, 'none') ! 2D precipitation rate file - call read_char_input(500, 'z0lfile', z0lfile, 'none') ! 2D land roughness (z0) file + call get_keyword(500, 'bndfile', bndfile, 'none') ! water-level boundary points + call get_keyword(500, 'bzsfile', bzsfile, 'none') ! water-level boundary time series + call get_keyword(500, 'bcafile', bcafile, 'none') ! tidal components per boundary point + call get_keyword(500, 'bzifile', bzifile, 'none') ! IG wave boundary time series + call get_keyword(500, 'bdrfile', bdrfile, 'none') ! downstream river boundary file + call get_keyword(500, 'srcfile', srcfile, 'none') ! river-point source locations + call get_keyword(500, 'disfile', disfile, 'none') ! river-point discharge time series + call get_keyword(500, 'spwfile', spwfile, 'none') ! spiderweb tropical-cyclone file + call get_keyword(500, 'wndfile', wndfile, 'none') ! uniform wind time series + call get_keyword(500, 'prcfile', prcpfile, 'none', ['precipfile']) ! uniform precipitation time series + call get_keyword(500, 'amufile', amufile, 'none') ! 2D wind u-component file + call get_keyword(500, 'amvfile', amvfile, 'none') ! 2D wind v-component file + call get_keyword(500, 'ampfile', ampfile, 'none') ! 2D atmospheric pressure file + call get_keyword(500, 'amrfile', amprfile, 'none', ['amprfile']) ! 2D precipitation rate file + call get_keyword(500, 'z0lfile', z0lfile, 'none') ! 2D land roughness (z0) file ! ! NetCDF-format forcing files (FEWS-style) ! - call read_char_input(500, 'netbndbzsbzifile', netbndbzsbzifile, 'none') ! combined bnd/bzs/bzi netCDF file - call read_char_input(500, 'netsrcdisfile', netsrcdisfile, 'none') ! combined src/dis netCDF file - call read_char_input(500, 'netamuamvfile', netamuamvfile, 'none') ! combined amu/amv netCDF file - call read_char_input(500, 'netamprfile', netamprfile, 'none') ! 2D precipitation netCDF file - call read_char_input(500, 'netampfile', netampfile, 'none') ! 2D pressure netCDF file - call read_char_input(500, 'netspwfile', netspwfile, 'none') ! netCDF spiderweb file + call get_keyword(500, 'netbndbzsbzifile', netbndbzsbzifile, 'none') ! combined bnd/bzs/bzi netCDF file + call get_keyword(500, 'netsrcdisfile', netsrcdisfile, 'none') ! combined src/dis netCDF file + call get_keyword(500, 'netamuamvfile', netamuamvfile, 'none') ! combined amu/amv netCDF file + call get_keyword(500, 'netamprfile', netamprfile, 'none') ! 2D precipitation netCDF file + call get_keyword(500, 'netampfile', netampfile, 'none') ! 2D pressure netCDF file + call get_keyword(500, 'netspwfile', netspwfile, 'none') ! netCDF spiderweb file ! ! Infiltration and losses ! - call read_char_input(500, 'infiltrationfile', infiltrationfile, 'none') ! infiltration parameters TOML file - call read_char_input(500, 'infiltrationtype', inftype, 'none') ! infiltration flavor (con, c2d, cna, cnb, gai, hor, bkt) - call read_char_input(500, 'bucketfile', removed_input, '__removed_keyword_not_present__') - if (trim(removed_input) /= '__removed_keyword_not_present__') then - ! - write(logstr,'(a)') 'Error : keyword bucketfile has been removed. Use infiltrationfile together with infiltrationtype = bkt.' - call stop_sfincs(trim(logstr), 1) - ! - endif - call read_char_input(500, 'bucket_loss_frac', removed_input, '__removed_keyword_not_present__') - if (trim(removed_input) /= '__removed_keyword_not_present__') then - ! - write(logstr,'(a)') 'Error : keyword bucket_loss_frac has been removed. Add bucket_loss to infiltrationfile instead.' - call stop_sfincs(trim(logstr), 1) - ! - endif + call get_keyword(500, 'infiltrationfile', infiltrationfile, 'none') ! infiltration parameters TOML file + call get_keyword(500, 'infiltrationtype', inftype, 'none') ! infiltration flavor (con, c2d, cna, cnb, gai, hor, bkt) ! ! Legacy binary infiltration inputs (kept for backward compatibility). ! - call read_char_input(500, 'qinffile', qinffile, 'none') ! binary spatially-varying infiltration field - call read_char_input(500, 'scsfile', scsfile, 'none') ! SCS curve-number S field (legacy binary) - call read_char_input(500, 'smaxfile', smaxfile, 'none') ! SCS max storage S field (legacy binary) - call read_char_input(500, 'sefffile', sefffile, 'none') ! SCS effective storage S_e field (legacy binary) - call read_char_input(500, 'psifile', psifile, 'none') ! Green-Ampt suction head (legacy binary, mm) - call read_char_input(500, 'sigmafile', sigmafile, 'none') ! Green-Ampt maximum moisture deficit (legacy binary) - call read_char_input(500, 'ksfile', ksfile, 'none') ! Green-Ampt saturated hydraulic conductivity (legacy binary, mm/hr) - call read_char_input(500, 'f0file', f0file, 'none') ! Horton initial infiltration capacity F0 (legacy binary) - call read_char_input(500, 'fcfile', fcfile, 'none') ! Horton asymptotic infiltration rate Fc (legacy binary) - call read_char_input(500, 'kdfile', kdfile, 'none') ! Horton decay constant k (legacy binary, 1/hr) - call read_real_input(500, 'horton_kr_kd', horton_kr_kd, 10.0) ! Horton recovery/decay ratio (recovery is kr_kd times slower than decay) + call get_keyword(500, 'qinffile', qinffile, 'none') ! binary spatially-varying infiltration field + call get_keyword(500, 'scsfile', scsfile, 'none') ! SCS curve-number S field (legacy binary) + call get_keyword(500, 'smaxfile', smaxfile, 'none') ! SCS max storage S field (legacy binary) + call get_keyword(500, 'sefffile', sefffile, 'none') ! SCS effective storage S_e field (legacy binary) + call get_keyword(500, 'psifile', psifile, 'none') ! Green-Ampt suction head (legacy binary, mm) + call get_keyword(500, 'sigmafile', sigmafile, 'none') ! Green-Ampt maximum moisture deficit (legacy binary) + call get_keyword(500, 'ksfile', ksfile, 'none') ! Green-Ampt saturated hydraulic conductivity (legacy binary, mm/hr) + call get_keyword(500, 'f0file', f0file, 'none') ! Horton initial infiltration capacity F0 (legacy binary) + call get_keyword(500, 'fcfile', fcfile, 'none') ! Horton asymptotic infiltration rate Fc (legacy binary) + call get_keyword(500, 'kdfile', kdfile, 'none') ! Horton decay constant k (legacy binary, 1/hr) + call get_keyword(500, 'horton_kr_kd', horton_kr_kd, 10.0) ! Horton recovery/decay ratio ! ! Output files ! - call read_char_input(500, 'obsfile', obsfile, 'none') ! observation-point locations file - call read_char_input(500, 'crsfile', crsfile, 'none') ! cross-section polyline file - call read_char_input(500, 'rugfile', rugfile, 'none') ! runup-gauge locations file - call read_logical_input(500, 'storevelmax', store_maximum_velocity, .false.) ! store maximum flow velocity on dtmaxout interval (only if dtmaxout > 0) - call read_logical_input(500, 'storefluxmax', store_maximum_flux, .false.) ! store maximum flux on dtmaxout interval (only if dtmaxout > 0) - call read_logical_input(500, 'storevel', store_velocity, .false.) ! store velocity on dtout interval - call read_logical_input(500, 'storecumprcp', store_cumulative_precipitation, .false.) ! store cumulative precipitation + infiltration on dtmaxout interval - call read_logical_input(500, 'storetwet', store_twet, .false.) ! store per-cell wet duration - call read_logical_input(500, 'storetzsmax', store_t_zsmax, .false.) ! store time stamp of zsmax occurrence - call read_logical_input(500, 'storehsubgrid', store_hsubgrid, .false.) ! store hmax in subgrid mode (zsmax - subgrid_z_zmin) - call read_logical_input(500, 'storehmean', store_hmean, .false.) ! store hmax as subgrid-mean depth instead of max (requires storehsubgrid) - call read_real_input(500, 'twet_threshold', twet_threshold, 0.01) ! water-depth threshold counting a cell as wet (storetwet) - call read_logical_input(500, 'store_tsunami_arrival_time', store_tsunami_arrival_time, .false.) ! store tsunami arrival time per cell - call read_real_input(500, 'tsunami_arrival_threshold', tsunami_arrival_threshold, 0.01) ! water-depth threshold for tsunami arrival - call read_logical_input(500, 'timestep_analysis', timestep_analysis, .false.) ! write per-cell timestep limiter diagnostics - call read_logical_input(500, 'storeqdrain', store_qdrain, .true.) ! store per-drainage-structure discharge in his file - call read_logical_input(500, 'store_river_discharge', store_river_discharge, .false.) ! store per-river-point discharge in his file - call read_logical_input(500, 'store_urban_drainage_discharge', store_urban_drainage_discharge, .false.) ! store per-urban-zone outfall discharge in his file - call read_logical_input(500, 'store_cumulative_urban_drainage', store_cumulative_urban_drainage, .false.) ! store cumulative urban drainage depth per cell in map file - call read_logical_input(500, 'storezvolume', store_zvolume, .false.) ! store subgrid cell volume (requires subgrid) - call read_logical_input(500, 'storestoragevolume', store_storagevolume, .false.) ! store remaining storage volume (requires subgrid + volfile) - call read_logical_input(500, 'writeruntime', write_time_output, .false.) ! write runtimes.txt at end of simulation - call read_logical_input(500, 'debug', debug, .false.) ! debug output at every time step - call read_logical_input(500, 'storemeteo', store_meteo, .false.) ! store 2D meteo forcing fields in map file - call read_logical_input(500, 'storemaxwind', store_wind_max, .false.) ! store maximum wind speed (requires storemeteo) - call read_logical_input(500, 'storefw', store_wave_forces, .false.) ! store wave-radiation forces - call read_logical_input(500, 'storewavdir', store_wave_direction, .false.) ! store wave direction - call read_logical_input(500, 'regular_output_on_mesh', use_quadtree_output, .false.) ! write quadtree output on regular m/n mesh - call read_logical_input(500, 'store_dynamic_bed_level', store_dynamic_bed_level, .false.) ! store time-varying bed level (subgrid) - call read_logical_input(500, 'snapwave_use_nearest', snapwave_use_nearest, .true.) ! use nearest-neighbour lookup for SnapWave boundary points - call read_int_input(500, 'percentage_done', percdoneval, 5) ! progress-reporter interval (% complete) - ! - ! Limit progress reporter to (0, 100]% - ! - percdoneval = max(min(percdoneval, 100), 0) + call get_keyword(500, 'obsfile', obsfile, 'none') ! observation-point locations file + call get_keyword(500, 'crsfile', crsfile, 'none') ! cross-section polyline file + call get_keyword(500, 'rugfile', rugfile, 'none') ! runup-gauge locations file + call get_keyword(500, 'storevelmax', store_maximum_velocity, .false.) ! store maximum flow velocity on dtmaxout interval (only if dtmaxout > 0) + call get_keyword(500, 'storefluxmax', store_maximum_flux, .false.) ! store maximum flux on dtmaxout interval (only if dtmaxout > 0) + call get_keyword(500, 'storevel', store_velocity, .false.) ! store velocity on dtout interval + call get_keyword(500, 'storecumprcp', store_cumulative_precipitation, .false.) ! store cumulative precipitation + infiltration on dtmaxout interval + call get_keyword(500, 'storetwet', store_twet, .false.) ! store per-cell wet duration + call get_keyword(500, 'storetzsmax', store_t_zsmax, .false.) ! store time stamp of zsmax occurrence + call get_keyword(500, 'storehsubgrid', store_hsubgrid, .false.) ! store hmax in subgrid mode (zsmax - subgrid_z_zmin) + call get_keyword(500, 'storehmean', store_hmean, .false.) ! store hmax as subgrid-mean depth instead of max (requires storehsubgrid) + call get_keyword(500, 'twet_threshold', twet_threshold, 0.01) ! water-depth threshold counting a cell as wet (storetwet) + call get_keyword(500, 'store_tsunami_arrival_time', store_tsunami_arrival_time, .false.) ! store tsunami arrival time per cell + call get_keyword(500, 'tsunami_arrival_threshold', tsunami_arrival_threshold, 0.01) ! water-depth threshold for tsunami arrival + call get_keyword(500, 'timestep_analysis', timestep_analysis, .false.) ! write per-cell timestep limiter diagnostics + call get_keyword(500, 'storeqdrain', store_qdrain, .true.) ! store per-drainage-structure discharge in his file + call get_keyword(500, 'store_river_discharge', store_river_discharge, .false.) ! store per-river-point discharge in his file + call get_keyword(500, 'store_urban_drainage_discharge', store_urban_drainage_discharge, .false.) ! store per-urban-zone outfall discharge in his file + call get_keyword(500, 'store_cumulative_urban_drainage', store_cumulative_urban_drainage, .false.) ! store cumulative urban drainage depth per cell in map file + call get_keyword(500, 'storezvolume', store_zvolume, .false.) ! store subgrid cell volume (requires subgrid) + call get_keyword(500, 'storestoragevolume', store_storagevolume, .false.) ! store remaining storage volume (requires subgrid + volfile) + call get_keyword(500, 'writeruntime', write_time_output, .false.) ! write runtimes.txt at end of simulation + call get_keyword(500, 'debug', debug, .false.) ! debug output at every time step + call get_keyword(500, 'storemeteo', store_meteo, .false.) ! store 2D meteo forcing fields in map file + call get_keyword(500, 'storemaxwind', store_wind_max, .false.) ! store maximum wind speed (requires storemeteo) + call get_keyword(500, 'storefw', store_wave_forces, .false.) ! store wave-radiation forces + call get_keyword(500, 'storewavdir', store_wave_direction, .false.) ! store wave direction + call get_keyword(500, 'regular_output_on_mesh', use_quadtree_output, .false.) ! write quadtree output on regular m/n mesh + call get_keyword(500, 'store_dynamic_bed_level', store_dynamic_bed_level, .false.) ! store time-varying bed level (subgrid) + call get_keyword(500, 'snapwave_use_nearest', snapwave_use_nearest, .true.) ! use nearest-neighbour lookup for SnapWave boundary points + call get_keyword(500, 'percentage_done', percdoneval, 5) ! progress-reporter interval (% complete) ! ! Coupled SnapWave solver parameters ! - call read_logical_input(500, 'snapwave_wind', snapwavewind, .false.) ! feed wind into SnapWave (implies storing wind speed/direction) - call read_real_input(500, 'snapwave_waveforces_factor', waveforces_factor, 1.0) ! multiplier on SnapWave wave forces + call get_keyword(500, 'snapwave_wind', snapwavewind, .false.) ! feed wind into SnapWave (implies storing wind speed/direction) + call get_keyword(500, 'snapwave_waveforces_factor', waveforces_factor, 1.0) ! multiplier on SnapWave wave forces ! ! Wind drag coefficient table ! - call read_int_input(500, 'cdnrb', cd_nr, 0) ! number of wind-drag breakpoints (0 = use defaults) + call get_keyword(500, 'cdnrb', cd_nr, 0) ! number of wind-drag breakpoints (0 = use defaults) ! if (cd_nr == 0) then ! @@ -382,21 +358,20 @@ subroutine read_sfincs_input() ! else ! - call read_real_array_input(500, 'cdwnd', cd_wnd, 0.0, cd_nr) - call read_real_array_input(500, 'cdval', cd_val, 0.0, cd_nr) + call get_keyword_real_array(500, 'cdwnd', cd_wnd, 0.0, cd_nr) + call get_keyword_real_array(500, 'cdval', cd_val, 0.0, cd_nr) ! endif ! - ! Late retry of dtmapout for older sfincs.inp files that put it after - ! keywords which could have shifted its position. + close(500) ! - if (dtmapout == 0.0) then - ! - call read_real_input(500, 'dtmapout', dtmapout, 0.0) - ! - endif + ! Done with reading input ! - close(500) + ! Now do some post-processing and consistency checks on the inputs, and emit + ! + ! Limit progress reporter to (0, 100]% + ! + percdoneval = max(min(percdoneval, 100), 0) ! if (epsg == 0) then ! @@ -466,12 +441,6 @@ subroutine read_sfincs_input() call write_log('Info : input grid interpreted as projected coordinates', 0) endif ! - if (coriolis) then - call write_log('Info : turning on Coriolis', 0) - else - call write_log('Info : turning off Coriolis', 0) - endif - ! if (.not. crsgeo .and. .not. coriolis) then call write_log('Info : no Coriolis, as latitude is not specified in sfincs.inp', 0) endif @@ -505,8 +474,6 @@ subroutine read_sfincs_input() if (.not. snapwave) snapwavewind = .false. if (snapwavewind) store_wind = .true. ! - if (viscosity) call write_log('Info : turning on process: Viscosity', 0) - ! ! Map/his format fallback: inherit the global outputformat when either ! per-file format was left at 'nil'. ! @@ -516,11 +483,13 @@ subroutine read_sfincs_input() endif ! if (sbgfile(1:4) /= 'none') then + ! subgrid = .true. - call write_log('Info : running SFINCS with subgrid bathymetry', 0) + ! else + ! subgrid = .false. - call write_log('Info : running SFINCS with regular bathymetry', 0) + ! endif ! if (subgrid .eqv. .true. .and. store_hsubgrid .eqv. .true. .and. store_hmean .eqv. .false.) then @@ -547,13 +516,11 @@ subroutine read_sfincs_input() ! wavemaker = .true. ! - call write_log('Info : turning on process: Dynamic waves', 0) - ! if (wmsigstr(1:3) == 'mon') then ! wavemaker_spectrum = .false. ! - call write_log('Info : use monochromatic wave spectrum', 0) + call write_log('Info : use monochromatic wave spectrum for wave makers', 0) ! endif ! @@ -578,8 +545,6 @@ subroutine read_sfincs_input() ! advection_scheme = 1 ! - call write_log('Info : turning on advection', 0) - ! if (trim(advstr) == 'original') then advection_scheme = 0 call write_log('Info : advection scheme : Original', 0) @@ -645,204 +610,270 @@ subroutine read_sfincs_input() ! !-----------------------------------------------------------------------------------------------------! ! - subroutine read_real_input(fileid, keyword, value, default) + subroutine get_keyword_real(fileid, keyword, value, default, legacy) ! - ! Read a single real*4 keyword from an already-open sfincs.inp. The - ! file is rewound on each call; scanning is linear. If the keyword - ! is not found, `value` is set to `default`. + ! Read one real*4 keyword. Tries `keyword` first; if absent, walks + ! the optional `legacy` list of deprecated aliases and emits a + ! one-line deprecation warning per matched alias. Falls back to + ! `default` when nothing matches. ! ! Called from: read_sfincs_input (this module). ! implicit none ! - character(*), intent(in) :: keyword - integer, intent(in) :: fileid - real*4, intent(out) :: value - real*4, intent(in) :: default + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + real*4, intent(out) :: value + real*4, intent(in) :: default + character(len=*), dimension(:), intent(in), optional :: legacy ! - character(len=256) :: keystr character(len=256) :: valstr - character(len=256) :: line - integer :: stat - ! - value = default + logical :: found + integer :: i ! - rewind(fileid) + call find_value(fileid, keyword, valstr, found) + if (found) then + read(valstr, *) value + return + endif ! - do while (.true.) - ! - read(fileid, '(a)', iostat=stat) line - if (stat == -1) exit - ! - call read_line(line, keystr, valstr) + if (present(legacy)) then ! - if (trim(keystr) == trim(keyword)) then + do i = 1, size(legacy) ! - read(valstr, *) value - exit + call find_value(fileid, trim(legacy(i)), valstr, found) ! - endif + if (found) then + read(valstr, *) value + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo ! - enddo + endif + ! + value = default ! end subroutine ! !-----------------------------------------------------------------------------------------------------! ! - subroutine read_real_array_input(fileid, keyword, value, default, nr) + subroutine get_keyword_int(fileid, keyword, value, default, legacy) ! - ! Read one whitespace-separated real*4 array keyword. Allocates - ! `value(nr)` on the way in and fills it from the matching line; if - ! the keyword is absent, every slot is left at `default`. + ! Read one integer keyword. See get_keyword_real for the semantics. ! ! Called from: read_sfincs_input (this module). ! implicit none ! - character(*), intent(in) :: keyword - integer, intent(in) :: fileid - integer, intent(in) :: nr - real*4, intent(in) :: default - real*4, dimension(:), intent(out), allocatable :: value + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + integer, intent(out) :: value + integer, intent(in) :: default + character(len=*), dimension(:), intent(in), optional :: legacy ! - character(len=256) :: keystr character(len=256) :: valstr - character(len=256) :: line - integer :: m, stat + logical :: found + integer :: i ! - allocate(value(nr)) + call find_value(fileid, keyword, valstr, found) + if (found) then + read(valstr, *) value + return + endif + ! + if (present(legacy)) then + ! + do i = 1, size(legacy) + ! + call find_value(fileid, trim(legacy(i)), valstr, found) + ! + if (found) then + read(valstr, *) value + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo + ! + endif ! value = default ! - rewind(fileid) + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine get_keyword_char(fileid, keyword, value, default, legacy) ! - do while (.true.) - ! - read(fileid, '(a)', iostat=stat) line - if (stat == -1) exit - ! - call read_line(line, keystr, valstr) + ! Read one character-string keyword. See get_keyword_real for the + ! semantics. The entire right-hand side (after trailing comments + ! are stripped) becomes `value`. + ! + ! Called from: read_sfincs_input (this module). + ! + implicit none + ! + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + character(*), intent(out) :: value + character(*), intent(in) :: default + character(len=*), dimension(:), intent(in), optional :: legacy + ! + character(len=256) :: valstr + logical :: found + integer :: i + ! + call find_value(fileid, keyword, valstr, found) + if (found) then + value = valstr + return + endif + ! + if (present(legacy)) then ! - if (trim(keystr) == trim(keyword)) then + do i = 1, size(legacy) ! - read(valstr, *) (value(m), m = 1, nr) - exit + call find_value(fileid, trim(legacy(i)), valstr, found) ! - endif + if (found) then + value = valstr + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo ! - enddo + endif + ! + value = default ! end subroutine ! !-----------------------------------------------------------------------------------------------------! ! - subroutine read_int_input(fileid, keyword, value, default) + subroutine get_keyword_logical(fileid, keyword, value, default, legacy) ! - ! Read a single integer keyword. Same scanning contract as - ! read_real_input. + ! Read one logical keyword. Accepts `1`, `y`, `Y`, `t`, `T` as true; + ! anything else (including absence → `default`, and `0`, `n`, `N`, + ! `f`, `F`) as false. ! ! Called from: read_sfincs_input (this module). ! implicit none ! - character(*), intent(in) :: keyword - integer, intent(in) :: fileid - integer, intent(out) :: value - integer, intent(in) :: default + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + logical, intent(out) :: value + logical, intent(in) :: default + character(len=*), dimension(:), intent(in), optional :: legacy ! - character(len=256) :: keystr character(len=256) :: valstr - character(len=256) :: line - integer :: stat + logical :: found + integer :: i ! - value = default - ! - rewind(fileid) + call find_value(fileid, keyword, valstr, found) + if (found) then + value = parse_logical(valstr) + return + endif ! - do while (.true.) - ! - read(fileid, '(a)', iostat=stat) line - if (stat == -1) exit + if (present(legacy)) then ! - call read_line(line, keystr, valstr) - ! - if (trim(keystr) == trim(keyword)) then + do i = 1, size(legacy) ! - read(valstr, *) value - exit + call find_value(fileid, trim(legacy(i)), valstr, found) ! - endif + if (found) then + value = parse_logical(valstr) + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo ! - enddo + endif + ! + value = default ! end subroutine ! !-----------------------------------------------------------------------------------------------------! ! - subroutine read_char_input(fileid, keyword, value, default) + subroutine get_keyword_real_array(fileid, keyword, value, default, nr, legacy) ! - ! Read a single character-string keyword. The entire right-hand side - ! (after stripping any trailing `# ...` comment) becomes `value`. + ! Read one whitespace-separated real*4 array keyword. Allocates + ! `value(nr)` on the way in and fills it from the matching line. + ! Same fallback semantics as get_keyword_real. ! ! Called from: read_sfincs_input (this module). ! implicit none ! - character(*), intent(in) :: keyword - integer, intent(in) :: fileid - character(*), intent(in) :: default - character(*), intent(out) :: value + integer, intent(in) :: fileid + character(*), intent(in) :: keyword + integer, intent(in) :: nr + real*4, intent(in) :: default + real*4, dimension(:), intent(out), allocatable :: value + character(len=*), dimension(:), intent(in), optional :: legacy ! - character(len=256) :: keystr character(len=256) :: valstr - character(len=256) :: line - integer :: stat + logical :: found + integer :: i, m ! - value = default + allocate(value(nr)) ! - rewind(fileid) + call find_value(fileid, keyword, valstr, found) + if (found) then + read(valstr, *) (value(m), m = 1, nr) + return + endif ! - do while (.true.) + if (present(legacy)) then ! - read(fileid, '(a)', iostat=stat) line - if (stat == -1) exit - ! - call read_line(line, keystr, valstr) - ! - if (trim(keystr) == trim(keyword)) then + do i = 1, size(legacy) ! - value = valstr - exit + call find_value(fileid, trim(legacy(i)), valstr, found) ! - endif + if (found) then + read(valstr, *) (value(m), m = 1, nr) + call warn_legacy(trim(legacy(i)), keyword) + return + endif + ! + enddo ! - enddo + endif + ! + value = default ! end subroutine ! !-----------------------------------------------------------------------------------------------------! ! - subroutine read_logical_input(fileid, keyword, value, default) + subroutine find_value(fileid, keyword, valstr, found) ! - ! Read a single logical keyword. Accepts `1`, `y`, `Y`, `t`, `T` as - ! true; anything else (including absence plus fallback to `default`, - ! `0`, `n`, `N`, `f`, `F`) as false. + ! Scan an already-open sfincs.inp once for the given `keyword`. + ! Returns the raw right-hand-side value string and whether the key + ! was matched. ! - ! Called from: read_sfincs_input (this module). + ! Called from: get_keyword_real / get_keyword_int / get_keyword_char / + ! get_keyword_logical / get_keyword_real_array. ! implicit none ! - character(*), intent(in) :: keyword integer, intent(in) :: fileid - logical, intent(in) :: default - logical, intent(out) :: value + character(*), intent(in) :: keyword + character(*), intent(out) :: valstr + logical, intent(out) :: found ! character(len=256) :: keystr - character(len=256) :: valstr character(len=256) :: line integer :: stat ! - value = default + found = .false. + valstr = '' ! rewind(fileid) ! @@ -854,16 +885,8 @@ subroutine read_logical_input(fileid, keyword, value, default) 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 - ! + found = .true. + return endif ! enddo @@ -872,6 +895,49 @@ subroutine read_logical_input(fileid, keyword, value, default) ! !-----------------------------------------------------------------------------------------------------! ! + subroutine warn_legacy(legacy_key, new_key) + ! + ! Emit a one-line deprecation warning to the log. Called whenever + ! a legacy keyword alias was matched; the user can silence this + ! by migrating the keyword in their sfincs.inp. + ! + ! Called from: get_keyword_real / get_keyword_int / get_keyword_char / + ! get_keyword_logical / get_keyword_real_array. + ! + implicit none + ! + character(*), intent(in) :: legacy_key + character(*), intent(in) :: new_key + ! + character(len=512) :: msg + ! + write(msg, '(a,a,a,a,a)') ' Warning : sfincs.inp keyword "', trim(legacy_key), & + '" is deprecated, use "', trim(new_key), '" instead' + call write_log(trim(msg), 1) + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + function parse_logical(valstr) result(value) + ! + ! Map an sfincs.inp value string to a logical. `1`, `y`, `Y`, `t`, + ! `T` at position 1 are true; everything else is false. + ! + ! Called from: get_keyword_logical (this module). + ! + implicit none + ! + character(*), intent(in) :: valstr + logical :: value + ! + value = (valstr(1:1) == '1' .or. valstr(1:1) == 'y' .or. valstr(1:1) == 'Y' .or. & + valstr(1:1) == 't' .or. valstr(1:1) == 'T') + ! + end function + ! + !-----------------------------------------------------------------------------------------------------! + ! subroutine read_line(line0, keystr, valstr) ! ! Split one `key = value` line into key and value substrings. @@ -880,8 +946,7 @@ subroutine read_line(line0, keystr, valstr) ! comment. Blank lines and lines starting with `#`, `!`, or `@` ! return empty strings. ! - ! Called from: read_real_input / read_real_array_input / - ! read_int_input / read_char_input / read_logical_input. + ! Called from: find_value. ! implicit none ! From 0bf44f2f1b316a68f3cb2dc65117c0f1a780b126 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 20:17:49 +0200 Subject: [PATCH 45/65] Add store_maximum_waterlevel keyword Introduce a new input keyword 'store_maximum_waterlevel' (default .true.) to control storing the maximum water level on the dtmaxout interval. Adjust initialization so the flag is no longer unconditionally reset earlier; it is now disabled only when dtmaxout <= 0 alongside store_maximum_velocity and store_maximum_flux. Also minor comment cleanup and placeholder notes in the output section. --- source/src/sfincs_input.f90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index f291333d7..ae926238f 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -296,11 +296,12 @@ subroutine read_sfincs_input() call get_keyword(500, 'kdfile', kdfile, 'none') ! Horton decay constant k (legacy binary, 1/hr) call get_keyword(500, 'horton_kr_kd', horton_kr_kd, 10.0) ! Horton recovery/decay ratio ! - ! Output files + ! Output ! call get_keyword(500, 'obsfile', obsfile, 'none') ! observation-point locations file call get_keyword(500, 'crsfile', crsfile, 'none') ! cross-section polyline file call get_keyword(500, 'rugfile', rugfile, 'none') ! runup-gauge locations file + call get_keyword(500, 'store_maximum_waterlevel', store_maximum_waterlevel, .true.) ! store maximum water level on dtmaxout interval (only if dtmaxout > 0) call get_keyword(500, 'storevelmax', store_maximum_velocity, .false.) ! store maximum flow velocity on dtmaxout interval (only if dtmaxout > 0) call get_keyword(500, 'storefluxmax', store_maximum_flux, .false.) ! store maximum flux on dtmaxout interval (only if dtmaxout > 0) call get_keyword(500, 'storevel', store_velocity, .false.) ! store velocity on dtout interval @@ -451,14 +452,18 @@ subroutine read_sfincs_input() t0out = max(t0out, t0) if (t1out < -900.0) t1out = t1 ! - store_maximum_waterlevel = .false. if (dtmaxout > 0.0) store_maximum_waterlevel = .true. ! ! Apply gates to the flags now that the full set of inputs has been read. ! if (dtmaxout <= 0.0) then - store_maximum_velocity = .false. - store_maximum_flux = .false. + ! + ! Are there more to be added here? + ! + store_maximum_waterlevel = .false. + store_maximum_velocity = .false. + store_maximum_flux = .false. + ! endif ! ! storemeteo implies store_wind (SFINCS needs 2D wind to feed the From 0b7b94e320885ff69b09541f044bdb0057ebe56f Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Sun, 19 Apr 2026 22:20:15 +0200 Subject: [PATCH 46/65] Add injection-well support to urban drainage Introduce a second urban-drainage zone type (injection_well) and extend piped_drainage semantics. Docs (input_urban_drainage.rst) expanded to describe two types, examples, new/changed TOML keys (type, injection_rate, maximum_capacity, h_threshold semantics), and updated outputs. Code changes: sfincs_urban_drainage now tracks zone type IDs, per-zone injection rate/maximum capacity, per-zone cumulative injection, and per-cell qmax/backflow handling for each type; update_urban_drainage implements separate logic for piped_drainage (outfall deposit + backflow) and injection_well (area-weighted pumping, cumulative-cap stop). API/variable renames and additions: urban_drainage_q_outfall -> urban_drainage_q_total, urbdrain_cuminj added to NetCDF output with long_name 'urban drainage zone cumulative injection volume', and nc variable long_name updated for total discharge. OpenACC/OpenMP present lists and kernels updated to include new arrays. Log summary and initialization updated to snap outfalls only for piped zones, derive design_precip from max_outfall_rate for piped zones, and error on invalid zone configs. Overall: adds injection-well functionality and necessary I/O, data structures, and runtime behavior while preserving piped drainage behavior. --- docs/input_urban_drainage.rst | 98 +++- source/src/sfincs_input.f90 | 5 +- source/src/sfincs_ncoutput.F90 | 18 +- source/src/sfincs_openacc.f90 | 12 +- source/src/sfincs_urban_drainage.f90 | 720 +++++++++++++++++---------- 5 files changed, 546 insertions(+), 307 deletions(-) diff --git a/docs/input_urban_drainage.rst b/docs/input_urban_drainage.rst index a5bab261f..41f0d387c 100644 --- a/docs/input_urban_drainage.rst +++ b/docs/input_urban_drainage.rst @@ -4,11 +4,14 @@ Urban Drainage Overview -------- -Urban drainage mimics a buried pipe network as a simple bulk sink/source. Each **drainage zone** is a polygon in the horizontal plane. Cells inside the polygon drain at a design rate, capped by the water actually available in the cell. All flow for a zone is collected at a single **outfall** cell (typically in a receiving water body), where the net per-zone flux appears as a point source or sink. Flow is bidirectional — when the outfall water level rises above the cells (tide or surge) the pipes push water back into the zone, unless a **check valve** is configured. +Urban drainage is a simple bulk sink/source model for two kinds of lumped drainage infrastructure: buried pipe networks that discharge to a receiving water body (**piped drainage**) and pumps that remove water from the model and store it underground (**injection wells**). Each **drainage zone** is a polygon in the horizontal plane and has exactly one ``type``: -The approach is deliberately coarse: there is no pipe network, no hydraulic routing, no pressure head other than the difference between cell water level and outfall water level. It is intended for compound-flood applications where pipe geometry is unknown but municipal design standards (rainfall intensity, or the outfall pipe capacity) are available. For a discussion of the underlying assumptions and typical parameter values, see the Developments section. +- ``piped_drainage`` — cells inside the polygon drain to a single outfall cell through a conceptual pipe network. Flow is bidirectional: during high water at the outfall (tide or surge), water can push back into the zone cells unless a check valve is configured. The per-zone net flux is deposited as a point source/sink at the outfall cell. +- ``injection_well`` — cells inside the polygon are pumped down at a fixed total rate, split evenly across the cells, and the extracted water is *removed from the model* (it does not reappear at an outfall). Pumping stops when the cumulative injected volume reaches the well's maximum capacity. -**IMPORTANT** — urban drainage does not represent any physical pipe. It is a mass-balance trick: water disappears from urban cells, reappears (summed) at the outfall cell. It does not block or route flow between cells. +The approach is deliberately coarse: there is no pipe network, no hydraulic routing, no pressure head other than the difference between cell water level and outfall water level (piped_drainage) and no subsurface storage model (injection_well beyond the single capacity cap). It is intended for compound-flood applications where detailed geometry is unknown but municipal-scale design parameters (rainfall intensity, outfall pipe capacity, or pump rate + well capacity) are available. + +**IMPORTANT** — urban drainage does not represent physical pipes or wells. It is a mass-balance abstraction: water disappears from urban cells, and for ``piped_drainage`` reappears summed at the outfall cell. It does not block or route flow between cells. Inputs ------ @@ -21,19 +24,23 @@ The feature is activated by the ``urbfile`` keyword in ``sfincs.inp``: store_urban_drainage_discharge = 1 store_cumulative_urban_drainage = 1 -``store_urban_drainage_discharge`` writes per-zone outfall discharge time series to ``sfincs_his.nc``. ``store_cumulative_urban_drainage`` writes the cumulative drained depth (m) per cell to ``sfincs_map.nc``. +``store_urban_drainage_discharge`` writes per-zone time series to ``sfincs_his.nc``: the zone total discharge and (for injection wells) the cumulative injection volume. ``store_cumulative_urban_drainage`` writes the cumulative drained depth (m) per cell to ``sfincs_map.nc``. The ``.urb`` file is a TOML document with one or more ``[[urban_drainage_zone]]`` entries. Zone definition --------------- -Each zone is declared as an array-of-tables entry. A minimal example: +Every zone has three required keys regardless of type: ``name``, ``type``, and ``polygon_file``. The rest depends on the type. + +Piped drainage example +^^^^^^^^^^^^^^^^^^^^^^ .. code-block:: toml [[urban_drainage_zone]] name = "downtown" + type = "piped_drainage" polygon_file = "zones.tek" outfall_x = 950.0 outfall_y = 150.0 @@ -42,24 +49,47 @@ Each zone is declared as an array-of-tables entry. A minimal example: [[urban_drainage_zone]] name = "harbor_district" + type = "piped_drainage" polygon_file = "zones.tek" outfall_x = 1020.0 outfall_y = 180.0 max_outfall_rate = 6.0 -The supported keys are: +Injection well example +^^^^^^^^^^^^^^^^^^^^^^ + +.. code-block:: toml + + [[urban_drainage_zone]] + name = "north_well_field" + type = "injection_well" + polygon_file = "zones.tek" + injection_rate = 0.5 + maximum_capacity = 5000.0 + +Common keys (both types) +^^^^^^^^^^^^^^^^^^^^^^^^ ``name`` (required, string) Zone name. Must match a polygon name in ``polygon_file``. Used as the station identifier in ``sfincs_his.nc`` when discharge output is enabled. +``type`` (required, string) + One of ``"piped_drainage"`` or ``"injection_well"``. Selects the per-zone physics and the set of remaining required keys. + ``polygon_file`` (required, string) Path to a Delft3D-style ``.tek`` polygon file. Multiple zones can share the same file — each zone's ``name`` is matched against polygon names inside the file. See "Polygon file format" below. +``h_threshold`` (optional, m, default ``0.0``) + Depth over which the drainage rate ramps linearly from zero to ``q_max``. At cell ponding depth ``h_cell = 0`` the drainage is zero; at ``h_cell >= h_threshold`` it is at full ``q_max``; in between it is ``(h_cell / h_threshold) * q_max``. Smooths the discharge time series compared to a hard on/off gate. Typical values: 0.02–0.05 m. Set to ``0.0`` to reproduce the hard-cap behaviour (full ``q_max`` for any ``h_cell > 0``). + +Piped drainage keys +^^^^^^^^^^^^^^^^^^^ + ``design_precip`` (conditional, mm/hr) - Design rainfall intensity the zone's drainage is sized for. Per-cell capacity is ``qmax = design_precip * cell_area / 3.6e6`` [m³/s]. Typical municipal values: 10–20 mm/hr for suburban residential, 20–40 mm/hr for dense city centre. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided.** + Design rainfall intensity the zone's drainage is sized for. Per-cell capacity is ``qmax = design_precip * cell_area / 3.6e6`` [m³/s]. Typical municipal values: 10–20 mm/hr for suburban residential, 20–40 mm/hr for dense city centre. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided for piped_drainage zones.** ``max_outfall_rate`` (conditional, m³/s) - Total zone outfall capacity. Useful when you know what the outfall pipe can deliver but not the design storm it was sized for. SFINCS derives ``design_precip = max_outfall_rate / zone_area * 3.6e6`` from the zone's total polygon-covered area, so per-cell capacity is distributed proportionally to cell area. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided.** + Total zone outfall capacity. Useful when you know what the outfall pipe can deliver but not the design storm it was sized for. SFINCS derives ``design_precip = max_outfall_rate / zone_area * 3.6e6`` from the zone's total polygon-covered area, so per-cell capacity is distributed proportionally to cell area. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided for piped_drainage zones.** ``outfall_x``, ``outfall_y`` (required when ``include_outfall = true``) Coordinates of the single point where all zone discharge is summed and deposited. Snapped to the nearest active cell. If no active cell can be found, zone contributions are silently discarded and a warning is logged. @@ -70,9 +100,6 @@ The supported keys are: ``check_valve`` (optional, bool, default ``false``) When ``true``, the zone only drains outward. Backflow from the outfall into the cells (bay flooding through the pipe) is suppressed. Represents a flap valve / tide gate at the outfall. -``h_threshold`` (optional, m, default ``0.0``) - Depth over which the drainage rate ramps linearly from zero to ``q_max``. At cell ponding depth ``h_cell = 0`` the drainage is zero; at ``h_cell >= h_threshold`` it is at full ``q_max``; in between it is ``(h_cell / h_threshold) * q_max``. Physically represents water gradually reaching the inlet grate and also smooths the discharge time series compared to a hard on/off gate. Only applies to the outflow direction (cell to outfall); backflow is unaffected. Typical values: 0.02–0.05 m. Set to ``0.0`` to reproduce the hard-cap behaviour (full ``q_max`` for any ``h_cell > 0``). - ``dh_design_min`` (optional, m, default ``0.1``) Floor on the per-cell design head used to compute the backflow coefficient. Per-cell backflow discharge is @@ -81,8 +108,17 @@ The supported keys are: so that a cell at the outfall bed elevation, or below it, doesn't produce an infinite backflow coefficient. -``type`` (optional, string, free-form) - Reserved for future variants (e.g. injection wells). Currently parsed and logged but not used by the physics. +Injection well keys +^^^^^^^^^^^^^^^^^^^ + +``injection_rate`` (required, m³/s) + Total pumping rate across the zone. Distributed over the zone cells by cell area so the sum across zone cells is exactly ``injection_rate`` and quadtree refinement inside the polygon does not shift the per-cell flux relative to cell area: + + .. math:: + q_{max}(nm) = \text{injection\_rate} \cdot \frac{A(nm)}{A_{zone}} + +``maximum_capacity`` (required, m³) + Total volume the injection well can accept over the simulation. SFINCS tracks ``cumulative_injection_volume`` over time; once it reaches ``maximum_capacity`` pumping is skipped for that zone (flow drops to zero). There is a potential one-time-step overshoot at the transition step (per-cell flux is not scaled to hit the cap exactly). Polygon file format ------------------- @@ -112,27 +148,36 @@ Each block has a name line, a ``nrows ncols`` line, and ``nrows`` vertex lines. Flow formulas ------------- -Per time step, for each active cell ``nm`` inside a zone ``iz`` with outfall cell ``io``: +For each active cell ``nm`` inside zone ``iz``, with ``h_cell`` the cell ponding depth (``zs - subgrid_z_zmin`` in subgrid mode, ``zs - zb`` otherwise) and the rate ramp .. math:: - \Delta z_s = z_s(nm) - z_s(io) + r = \min(h_{cell} / h_{threshold},\; 1) \text{ if } h_{threshold} > 0, \text{ else } 1 -**Outflow** (``Δz_s > 0`` and ``h_cell > 0``): +**Piped drainage** (``outfall cell io``): .. math:: - r &= \min(h_{cell} / h_{threshold},\; 1) \quad \text{if } h_{threshold} > 0, \text{ else } 1 \\ - q &= \min\left(r \cdot q_{max}(nm),\; \frac{h_{cell} \cdot A(nm)}{\Delta t}\right) + \Delta z_s = z_s(nm) - z_s(io) -where ``h_cell`` is ``zs - subgrid_z_zmin`` in subgrid mode, or ``zs - zb`` otherwise. The ramp factor ``r`` smooths the discharge near the grate; the ``min`` cap prevents draining more than is in the cell over one time step. +Outflow (``Δz_s > 0`` and ``h_cell > 0``): -**Backflow** (``Δz_s < 0`` and check valve off): +.. math:: + q = \min\left(r \cdot q_{max}(nm),\; \frac{h_{cell} \cdot A(nm)}{\Delta t}\right) + +Backflow (``Δz_s < 0`` and check valve off): .. math:: - q = -\frac{q_{max}(nm)}{\sqrt{\Delta h_{design}(nm)}} \cdot \sqrt{-\Delta z_s} + q = -\frac{q_{max}(nm)}{\sqrt{\max(z_b(nm) - z_b(io),\,\Delta h_{design,min})}} \cdot \sqrt{-\Delta z_s} + +capped at ``-q_{max}(nm)``. With ``check_valve = true`` backflow is skipped entirely. + +The zone's per-step net flux is deposited at the outfall cell, so mass is conserved (up to the outfall-snap warning above). -capped at ``-q_{max}(nm)``. With a check valve (``check_valve = true``) backflow is skipped entirely. +**Injection well** (no outfall): -The zone's per-step net flux ``sum(q)`` is deposited at the outfall cell, so mass is conserved (up to the outfall-snap warning above). +.. math:: + q = \min\left(r \cdot q_{max}(nm),\; \frac{h_{cell} \cdot A(nm)}{\Delta t}\right) + +where :math:`q_{max}(nm) = \text{injection\_rate} \cdot A(nm) / A_{zone}` (area-weighted split; sums to ``injection_rate`` across the zone). Flow is positive (water leaves cells) only; there is no backflow. Pumping is skipped entirely once :math:`\text{cumulative\_injection\_volume}(iz) \geq \text{maximum\_capacity}(iz)`. Outputs ------- @@ -140,7 +185,10 @@ Outputs **``sfincs_his.nc``** — when ``store_urban_drainage_discharge = 1``: ``urban_drainage_discharge(urban_drainage_zones, time)`` - Net per-zone outfall discharge in m³/s. Positive means net outflow (drainage from the zone); negative means net inflow (backflow from the outfall). + Per-zone total discharge in m³/s. Positive means net outflow from the cells (to outfall or to injection well); negative means net inflow (backflow from the outfall, piped_drainage with check valve off). Named ``urban drainage zone total discharge`` in the long_name attribute. + +``cumulative_injection_volume(urban_drainage_zones, time)`` + Per-zone cumulative injection volume in m³. Tracked for all zones, but only physically meaningful for ``injection_well`` zones; ``piped_drainage`` zones keep this at 0.0 (there is no underground storage). ``urban_drainage_zone_name(urban_drainage_zones)`` Zone names, in the order they appear in the ``.urb`` file. @@ -150,4 +198,4 @@ Outputs ``urban_drainage_cumulative_depth(m, n, timemax)`` (regular) or ``(nmesh2d_face, timemax)`` (quadtree) Cumulative drained volume divided by cell area (m), written at the ``dtmaxout`` interval. Positive means net outflow from the cell over the simulation; negative means net inflow. -At init time a per-zone summary block is written to the SFINCS log listing zone name, polygon file, number of cells assigned, total area, design precipitation (or max outfall rate + derived design precipitation), total ``qmax``, thresholds, outfall coords, snapped outfall cell index, and check-valve state. +At init time a per-zone summary block is written to the SFINCS log listing zone name, type, polygon file, number of cells assigned, total area, design precipitation / max outfall rate / qmax (piped_drainage) or injection rate / maximum capacity (injection_well), thresholds, outfall coords + snapped cell index (piped_drainage), and check-valve state. diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index ae926238f..88b43b62d 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -174,10 +174,7 @@ subroutine read_sfincs_input() call get_keyword(500, 'snapwave', snapwave, .false.) ! enable coupled SnapWave wave solver call get_keyword(500, 'dtoutfixed', fixed_output_intervals, .true.) ! snap map/his to exact intervals (true) or let them drift with dt (false) ! - ! Wave maker parameters. Each call tries the modern `wavemaker_*` - ! keyword first and falls back to the legacy shortname in the - ! trailing array; a deprecation warning is emitted per legacy - ! match. + ! Wave maker parameters ! call get_keyword(500, 'wavemaker_wvmfile', wavemaker_wvmfile, 'none', ['wvmfile']) ! wavemaker polyline file call get_keyword(500, 'wavemaker_wfpfile', wavemaker_wfpfile, 'none', ['wfpfile']) ! wavemaker forcing points file diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 1ca7a220d..082045921 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -52,7 +52,7 @@ module sfincs_ncoutput integer :: thindam_x_varid, thindam_y_varid integer :: drain_varid, drain_name_varid integer :: river_varid, river_name_varid - integer :: urbdrain_varid, urbdrain_name_varid + integer :: urbdrain_varid, urbdrain_name_varid, urbdrain_cuminj_varid integer :: zb_varid integer :: time_varid integer :: zs_varid, h_varid, u_varid, v_varid, prcp_varid, cumprcp_varid, discharge_varid, uvmag_varid, uvdir_varid @@ -2189,12 +2189,18 @@ subroutine ncoutput_his_init() ! if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then ! - NF90(nf90_def_var(his_file%ncid, 'urban_drainage_discharge', NF90_FLOAT, (/his_file%urbdrain_dimid, his_file%time_dimid/), his_file%urbdrain_varid)) ! per-zone outfall discharge + NF90(nf90_def_var(his_file%ncid, 'urban_drainage_discharge', NF90_FLOAT, (/his_file%urbdrain_dimid, his_file%time_dimid/), his_file%urbdrain_varid)) ! per-zone total discharge NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'units', 'm3 s-1')) - NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'long_name', 'urban drainage zone net outfall discharge')) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'long_name', 'urban drainage zone total discharge')) NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'coordinates', 'urban_drainage_zone_name')) ! + NF90(nf90_def_var(his_file%ncid, 'cumulative_injection_volume', NF90_FLOAT, (/his_file%urbdrain_dimid, his_file%time_dimid/), his_file%urbdrain_cuminj_varid)) ! per-zone cumulative injected volume (injection_well) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_cuminj_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_cuminj_varid, 'units', 'm3')) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_cuminj_varid, 'long_name', 'urban drainage zone cumulative injection volume')) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_cuminj_varid, 'coordinates', 'urban_drainage_zone_name')) + ! endif ! if (nr_runup_gauges > 0) then @@ -3221,7 +3227,7 @@ subroutine ncoutput_update_his(t,nthisout) use sfincs_snapwave use sfincs_src_structures, only: nr_src_structures, q_src_struc use sfincs_discharges, only: qtsrc, nr_discharge_points - use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_outfall + use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_total, urb_zone_cumulative_injection ! implicit none ! @@ -3531,7 +3537,9 @@ subroutine ncoutput_update_his(t,nthisout) ! if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then ! - NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_varid, urban_drainage_q_outfall, (/1, nthisout/))) ! write per-zone outfall discharge + NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_varid, urban_drainage_q_total, (/1, nthisout/))) ! write per-zone total discharge + ! + NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_cuminj_varid, urb_zone_cumulative_injection, (/1, nthisout/))) ! write per-zone cumulative injection volume ! endif ! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index c88b29433..9b4531d5b 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -7,7 +7,9 @@ module sfincs_openacc rule_start, rule_length use sfincs_urban_drainage, only: urban_drainage_zone_indices, urban_drainage_outfall_index, & urban_drainage_qmax, urban_drainage_backflow_coef, & - urban_drainage_q_outfall, urban_drainage_cumulative_volume, & + urban_drainage_q_total, urban_drainage_cumulative_volume, & + urb_zone_type_id, urb_zone_injection_rate, urb_zone_maximum_capacity, & + urb_zone_cumulative_injection, & urb_zone_h_threshold, urb_zone_check_valve, & urb_zone_dh_design_min ! @@ -59,7 +61,9 @@ subroutine initialize_openacc() !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & !$acc bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, urban_drainage_qmax, urban_drainage_backflow_coef, & - !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & + !$acc urban_drainage_q_total, urban_drainage_cumulative_volume, & + !$acc urb_zone_type_id, urb_zone_injection_rate, urb_zone_maximum_capacity, & + !$acc urb_zone_cumulative_injection, & !$acc urb_zone_h_threshold, urb_zone_check_valve, urb_zone_dh_design_min ) ! end subroutine @@ -104,7 +108,9 @@ subroutine finalize_openacc() !$acc ksfield, GA_head, GA_sigma, GA_sigma_max, GA_F, GA_Lu, inf_kr, horton_kd, horton_fc, horton_f0, & !$acc bucket_volume, bucket_capacity, bucket_k, bucket_drain_rate, bucket_loss, bucket_runoff, & !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, urban_drainage_qmax, urban_drainage_backflow_coef, & - !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & + !$acc urban_drainage_q_total, urban_drainage_cumulative_volume, & + !$acc urb_zone_type_id, urb_zone_injection_rate, urb_zone_maximum_capacity, & + !$acc urb_zone_cumulative_injection, & !$acc urb_zone_h_threshold, urb_zone_check_valve, urb_zone_dh_design_min ) ! end diff --git a/source/src/sfincs_urban_drainage.f90 b/source/src/sfincs_urban_drainage.f90 index 927c7f8d2..0ccac2460 100644 --- a/source/src/sfincs_urban_drainage.f90 +++ b/source/src/sfincs_urban_drainage.f90 @@ -2,69 +2,81 @@ module sfincs_urban_drainage ! ! Simple urban-drainage sink/source model for SFINCS. ! - ! Each zone is a polygon in horizontal plane. Cells inside the polygon - ! drain at a design rate capped by available water; flow is bidirectional - ! so the outfall cell can push water back into the cells (tide / surge) - ! unless a check valve is specified. All flow for a zone is collected at a - ! single outfall cell, so the per-zone net flux is added as a point - ! source / sink there. - ! - ! Per-cell discharge (drain from cell to outfall, positive sign). - ! In subgrid mode the effective bed elevation is subgrid_z_zmin(nm) - ! instead of zb(nm) — this affects both the ponding-depth gate and - ! the design-head floor. + ! Each zone is a polygon in the horizontal plane and has one of two + ! types: ! - ! dzs = zs(nm) - zs(outfall) - ! if dzs > 0: - ! h_cell = zs(nm) - (subgrid ? subgrid_z_zmin(nm) : zb(nm)) - ! if h_cell <= 0: skip - ! ramp = min(h_cell / h_threshold, 1) if h_threshold > 0, else 1 - ! q = min( ramp * qmax(nm), h_cell * cell_area(nm) / dt ) - ! so q ramps linearly from 0 to qmax as depth goes from 0 to - ! h_threshold, then caps at qmax. - ! else: - ! q = -backflow_coef(nm) * sqrt(-dzs), capped at -qmax(nm) - ! suppressed if the zone has a check valve - ! - ! Per-cell design-head (bed_elev is subgrid_z_zmin in subgrid mode, - ! zb otherwise): + ! piped_drainage — cells inside the polygon drain to a single + ! outfall cell through a conceptual buried pipe + ! network. Flow is bidirectional: during high + ! water at the outfall (tide / surge), water can + ! push back into the zone cells unless a check + ! valve is configured. The per-zone net flux is + ! added as a point source/sink at the outfall. ! - ! dh_design(nm) = max( bed_elev(nm) - bed_elev(outfall), dh_design_min ) - ! backflow_coef(nm) = qmax(nm) / sqrt(dh_design(nm)) + ! injection_well — water is pumped out of the zone cells (evenly + ! split across the cells in the polygon) and + ! disappears from the model underground. There is + ! no outfall and no backflow. Pumping stops when + ! the cumulative injected volume reaches the + ! well's maximum capacity. ! - ! qmax from the design precipitation rate: + ! Common mechanics (both types): ! - ! qmax(nm) = design_precip_mm_hr * 1e-3 / 3600 * cell_area(nm) [m3/s] + ! dt-capped per-cell drain: q = min(ramp * qmax(nm), h_cell * A(nm) / dt) + ! ramp = min(h_cell / h_threshold, 1) if h_threshold > 0, else 1 + ! h_cell = zs(nm) - (subgrid ? subgrid_z_zmin(nm) : zb(nm)) ! - ! Alternatively the user may supply max_outfall_rate [m3/s] for the - ! whole zone (exclusive with design_precip per zone); design_precip is - ! then derived as + ! Piped drainage specifics: ! - ! design_precip_mm_hr = max_outfall_rate / zone_area * 1000 * 3600 - ! - ! which distributes the capacity proportionally to cell area. + ! dzs = zs(nm) - zs(outfall) + ! if dzs > 0: drain as above (positive q, water leaves cell) + ! if dzs < 0: backflow q = -backflow_coef(nm)*sqrt(-dzs), capped at + ! -qmax(nm); suppressed entirely by check_valve + ! Per-cell qmax from the design precipitation rate: + ! qmax(nm) = design_precip_mm_hr * 1e-3 / 3600 * cell_area(nm) + ! Alternatively the user may supply max_outfall_rate [m3/s] for the + ! whole zone (exclusive with design_precip per zone); design_precip + ! is then derived as + ! design_precip_mm_hr = max_outfall_rate / zone_area * 1000 * 3600 + ! which distributes the capacity proportionally to cell area. + ! Per-cell design-head (bed_elev is subgrid_z_zmin in subgrid mode, + ! zb otherwise): + ! dh_design(nm) = max(bed_elev(nm) - bed_elev(outfall), dh_design_min) + ! backflow_coef(nm) = qmax(nm) / sqrt(dh_design(nm)) + ! + ! Injection well specifics: + ! + ! Per-cell qmax is area-weighted, so the sum across zone cells is + ! exactly injection_rate and refinement-level changes inside a + ! zone don't shift the per-cell flux relative to cell area: + ! qmax(nm) = injection_rate * cell_area(nm) / zone_area + ! The zone holds a running cumulative_injection(iz) = sum(qd*dt) + ! across cells and time steps. Once cumulative_injection(iz) + ! reaches urb_zone_maximum_capacity(iz), pumping is skipped for + ! that zone (flow drops to zero). ! ! Subroutines: ! ! initialize_urban_drainage() - ! Top-level driver. Calls read_urban_drainage, loads polygons, marks - ! cells per zone (last zone wins on overlap), snaps outfall coords to - ! the nearest active cell, precomputes per-cell qmax and - ! backflow_coef. Called from sfincs_lib (once at init time). + ! Top-level driver. Calls read_urban_drainage, loads polygons, + ! marks cells per zone (last zone wins on overlap), snaps outfall + ! coords to the nearest active cell (piped_drainage only), + ! precomputes per-cell qmax and backflow_coef. Called from + ! sfincs_lib (once at init time). ! ! read_urban_drainage(filename, ierr) - ! Parses the *.urb TOML file into the per-zone arrays. Called from - ! initialize_urban_drainage (this module). + ! Parses the *.urb TOML file into the per-zone arrays. Called + ! from initialize_urban_drainage (this module). ! ! update_urban_drainage(t, dt) - ! Per-time-step entry: accumulates signed discharges into qsrc, and - ! adds the outfall contribution at each zone's outfall cell. Called - ! from update_continuity (sfincs_continuity). + ! Per-time-step entry: accumulates signed discharges into qsrc + ! and adds the zone contribution at the outfall cell (for + ! piped_drainage zones). Called from update_continuity + ! (sfincs_continuity). ! ! write_urban_drainage_log_summary() - ! Prints a one-block-per-zone summary (name, polygon file, cell - ! count, total area, design precip, total qmax, thresholds, outfall) - ! to the log. Called from initialize_urban_drainage (this module). + ! Prints a one-block-per-zone summary to the log. Called from + ! initialize_urban_drainage (this module). ! use sfincs_log use sfincs_error @@ -78,44 +90,56 @@ module sfincs_urban_drainage public :: initialize_urban_drainage public :: update_urban_drainage ! + ! Zone type identifiers. Kept public so ncoutput can branch on type + ! when writing per-zone output variables. + ! + integer, parameter, public :: urb_type_piped_drainage = 1 + integer, parameter, public :: urb_type_injection_well = 2 + ! ! Per-zone runtime state. Sized nr_urban_drainage_zones. ! integer, public :: nr_urban_drainage_zones = 0 ! - character(len=64), dimension(:), allocatable, public :: urb_zone_name - character(len=64), dimension(:), allocatable, public :: urb_zone_type - character(len=256), dimension(:), allocatable :: urb_zone_polygon_file - ! - real*4, dimension(:), allocatable, public :: urb_zone_outfall_x - real*4, dimension(:), allocatable, public :: urb_zone_outfall_y - real*4, dimension(:), allocatable, public :: urb_zone_design_precip ! mm/hr (either given directly or derived from max_outfall_rate) - real*4, dimension(:), allocatable, public :: urb_zone_max_outfall_rate ! m3/s; 0.0 if input was design_precip instead - real*4, dimension(:), allocatable, public :: urb_zone_h_threshold ! m ponding threshold - real*4, dimension(:), allocatable, public :: urb_zone_dh_design_min ! m floor on design head - logical, dimension(:), allocatable, public :: urb_zone_include_outfall - logical, dimension(:), allocatable, public :: urb_zone_check_valve - ! - integer, dimension(:), allocatable, public :: urban_drainage_outfall_index ! cell index, 0 if none - real*4, dimension(:), allocatable, public :: urban_drainage_q_outfall ! m3/s per zone, per step - real*4, dimension(:), allocatable, public :: urb_zone_area ! m2, sum of cell areas in zone - integer, dimension(:), allocatable, public :: urb_zone_n_cells ! number of cells in zone - real*4, dimension(:), allocatable, public :: urb_zone_qmax_total ! m3/s, sum of per-cell qmax + character(len=64), dimension(:), allocatable, public :: urb_zone_name + character(len=64), dimension(:), allocatable, public :: urb_zone_type ! original TOML type string (for logging) + character(len=256), dimension(:), allocatable :: urb_zone_polygon_file + integer, dimension(:), allocatable, public :: urb_zone_type_id ! one of urb_type_* + ! + real*4, dimension(:), allocatable, public :: urb_zone_outfall_x ! m (piped_drainage) + real*4, dimension(:), allocatable, public :: urb_zone_outfall_y ! m (piped_drainage) + real*4, dimension(:), allocatable, public :: urb_zone_design_precip ! mm/hr (piped_drainage; either direct or derived from max_outfall_rate) + real*4, dimension(:), allocatable, public :: urb_zone_max_outfall_rate ! m3/s (piped_drainage; 0.0 if input was design_precip) + real*4, dimension(:), allocatable, public :: urb_zone_injection_rate ! m3/s (injection_well) + real*4, dimension(:), allocatable, public :: urb_zone_maximum_capacity ! m3 (injection_well) + real*4, dimension(:), allocatable, public :: urb_zone_h_threshold ! m ponding threshold (both types) + real*4, dimension(:), allocatable, public :: urb_zone_dh_design_min ! m floor on design head (piped_drainage) + logical, dimension(:), allocatable, public :: urb_zone_include_outfall ! (piped_drainage) + logical, dimension(:), allocatable, public :: urb_zone_check_valve ! (piped_drainage) + ! + integer, dimension(:), allocatable, public :: urban_drainage_outfall_index ! cell index, 0 if none + real*4, dimension(:), allocatable, public :: urban_drainage_q_total ! m3/s per zone, per step (total discharge leaving zone cells) + real*4, dimension(:), allocatable, public :: urb_zone_cumulative_injection ! m3 accumulated per zone (injection_well) + real*4, dimension(:), allocatable, public :: urb_zone_area ! m2, sum of cell areas in zone + integer, dimension(:), allocatable, public :: urb_zone_n_cells ! number of cells in zone + real*4, dimension(:), allocatable, public :: urb_zone_qmax_total ! m3/s, sum of per-cell qmax ! ! Per-cell runtime state. Sized np. ! - integer, dimension(:), allocatable, public :: urban_drainage_zone_indices ! 0 if not in any zone - real*4, dimension(:), allocatable, public :: urban_drainage_qmax ! m3/s cap per cell - real*4, dimension(:), allocatable, public :: urban_drainage_backflow_coef ! qmax / sqrt(dh_design) - real*4, dimension(:), allocatable, public :: urban_drainage_cumulative_volume ! m3 accumulated (optional) + integer, dimension(:), allocatable, public :: urban_drainage_zone_indices ! 0 if not in any zone + real*4, dimension(:), allocatable, public :: urban_drainage_qmax ! m3/s cap per cell + real*4, dimension(:), allocatable, public :: urban_drainage_backflow_coef ! qmax / sqrt(dh_design), piped_drainage only + real*4, dimension(:), allocatable, public :: urban_drainage_cumulative_volume ! m3 accumulated per cell ! contains + ! + !-----------------------------------------------------------------------------------------------------! ! subroutine initialize_urban_drainage() ! ! Top-level initializer for urban drainage. Parses *.urb TOML file, ! loads polygons, stamps cells per zone (last-wins on overlap), snaps - ! outfall coords to the nearest active cell, and precomputes per-cell - ! qmax and backflow coefficients. + ! outfall coords (piped_drainage zones only) to the nearest active + ! cell, and precomputes per-cell qmax and backflow coefficients. ! ! Sets sfincs_data::urban_drainage = .true. when at least one zone is ! loaded and has at least one participating cell. Otherwise leaves it @@ -155,18 +179,20 @@ subroutine initialize_urban_drainage() return endif ! - ! Allocate per-zone snapped outfall index and per-step accumulator. + ! Allocate per-zone snapped outfall index and per-step accumulators. ! allocate(urban_drainage_outfall_index(nr_urban_drainage_zones)) - allocate(urban_drainage_q_outfall(nr_urban_drainage_zones)) + allocate(urban_drainage_q_total(nr_urban_drainage_zones)) + allocate(urb_zone_cumulative_injection(nr_urban_drainage_zones)) allocate(urb_zone_area(nr_urban_drainage_zones)) allocate(urb_zone_n_cells(nr_urban_drainage_zones)) allocate(urb_zone_qmax_total(nr_urban_drainage_zones)) - urban_drainage_outfall_index = 0 - urban_drainage_q_outfall = 0.0 - urb_zone_area = 0.0 - urb_zone_n_cells = 0 - urb_zone_qmax_total = 0.0 + urban_drainage_outfall_index = 0 + urban_drainage_q_total = 0.0 + urb_zone_cumulative_injection = 0.0 + urb_zone_area = 0.0 + urb_zone_n_cells = 0 + urb_zone_qmax_total = 0.0 ! ! Allocate per-cell state. ! @@ -249,12 +275,13 @@ subroutine initialize_urban_drainage() endif deallocate(inside) ! - ! Snap outfall coordinates to nearest active cell. + ! Snap outfall coordinates to nearest active cell (piped_drainage only). ! n_outfalls = 0 ! do iz = 1, nr_urban_drainage_zones ! + if (urb_zone_type_id(iz) /= urb_type_piped_drainage) cycle if (.not. urb_zone_include_outfall(iz)) cycle ! nmq = find_quadtree_cell(urb_zone_outfall_x(iz), urb_zone_outfall_y(iz)) @@ -270,10 +297,9 @@ subroutine initialize_urban_drainage() ! enddo ! - ! Precompute per-cell qmax and backflow coef. Done in two passes so - ! that zones specified via max_outfall_rate can derive their - ! design_precip from the now-known total zone area. This keeps the - ! per-cell qmax formula uniform across both input styles. + ! Precompute per-cell qmax and backflow coef. Two passes: first + ! accumulate per-zone area and cell count, then derive design_precip + ! where needed and compute per-cell qmax. ! ! Pass 1: accumulate area and cell count per zone. ! @@ -296,26 +322,38 @@ subroutine initialize_urban_drainage() ! enddo ! - ! Derive design_precip for zones that were given max_outfall_rate. - ! design_precip [mm/hr] = max_outfall_rate / area * 1000 * 3600. + ! Derive design_precip for piped_drainage zones that were given + ! max_outfall_rate. Error out on injection_well zones with zero cells. ! do iz = 1, nr_urban_drainage_zones ! - if (urb_zone_max_outfall_rate(iz) > 0.0) then + if (urb_zone_type_id(iz) == urb_type_piped_drainage) then + ! + if (urb_zone_max_outfall_rate(iz) > 0.0) then + ! + if (urb_zone_area(iz) <= 0.0) then + write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(iz)), & + '" has max_outfall_rate set but zero participating cells; cannot derive design_precip' + call stop_sfincs(trim(logstr), -1) + endif + ! + urb_zone_design_precip(iz) = urb_zone_max_outfall_rate(iz) / urb_zone_area(iz) * 1000.0 * 3600.0 + ! + endif ! - if (urb_zone_area(iz) <= 0.0) then + elseif (urb_zone_type_id(iz) == urb_type_injection_well) then + ! + if (urb_zone_n_cells(iz) <= 0) then write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(iz)), & - '" has max_outfall_rate set but zero participating cells; cannot derive design_precip' + '" is an injection_well with zero participating cells' call stop_sfincs(trim(logstr), -1) endif ! - urb_zone_design_precip(iz) = urb_zone_max_outfall_rate(iz) / urb_zone_area(iz) * 1000.0 * 3600.0 - ! endif ! enddo ! - ! Pass 2: compute per-cell qmax and backflow coefficient. + ! Pass 2: compute per-cell qmax and (piped only) backflow coefficient. ! do nm = 1, np ! @@ -328,20 +366,31 @@ subroutine initialize_urban_drainage() area_nm = cell_area(z_flags_iref(nm)) endif ! - ! mm/hr -> m/s then m3/s - ! - urban_drainage_qmax(nm) = urb_zone_design_precip(iz) * 1.0e-3 / 3600.0 * area_nm - ! - io = urban_drainage_outfall_index(iz) - ! - if (io > 0) then - dh_min = urb_zone_dh_design_min(iz) - if (subgrid) then - dzb = max(subgrid_z_zmin(nm) - subgrid_z_zmin(io), dh_min) - else - dzb = max(zb(nm) - zb(io), dh_min) + if (urb_zone_type_id(iz) == urb_type_piped_drainage) then + ! + ! mm/hr -> m/s then m3/s + ! + urban_drainage_qmax(nm) = urb_zone_design_precip(iz) * 1.0e-3 / 3600.0 * area_nm + ! + io = urban_drainage_outfall_index(iz) + ! + if (io > 0) then + dh_min = urb_zone_dh_design_min(iz) + if (subgrid) then + dzb = max(subgrid_z_zmin(nm) - subgrid_z_zmin(io), dh_min) + else + dzb = max(zb(nm) - zb(io), dh_min) + endif + urban_drainage_backflow_coef(nm) = urban_drainage_qmax(nm) / sqrt(dzb) endif - urban_drainage_backflow_coef(nm) = urban_drainage_qmax(nm) / sqrt(dzb) + ! + elseif (urb_zone_type_id(iz) == urb_type_injection_well) then + ! + ! Split pump capacity across the zone by cell area so the sum + ! over zone cells equals injection_rate exactly. + ! + urban_drainage_qmax(nm) = urb_zone_injection_rate(iz) * area_nm / urb_zone_area(iz) + ! endif ! urb_zone_qmax_total(iz) = urb_zone_qmax_total(iz) + urban_drainage_qmax(nm) @@ -363,12 +412,15 @@ subroutine initialize_urban_drainage() subroutine update_urban_drainage(t, dt) ! ! Per-time-step entry: accumulate signed discharges into qsrc for - ! cells inside drainage zones, and deposit the summed per-zone flux at - ! each zone's outfall cell. + ! cells inside drainage zones, add the zone contribution at each + ! piped_drainage outfall cell, and accumulate the per-zone + ! cumulative injection volume for injection_well zones. ! - ! Sign convention: qd > 0 means water leaves the cell (drains to the - ! outfall). qsrc(nm) -= qd subtracts that flux from the cell and the - ! same amount is added back at the outfall. + ! Sign convention: qd > 0 means water leaves the cell (drains to + ! outfall or underground). qsrc(nm) -= qd subtracts that flux from + ! the cell; for piped_drainage zones the same amount is added back + ! at the outfall cell. injection_well zones don't return water to + ! the model. ! ! Called from: update_continuity (sfincs_continuity), once per time ! step, after update_src_structures. @@ -380,52 +432,49 @@ subroutine update_urban_drainage(t, dt) real*8, intent(in) :: t real*4, intent(in) :: dt ! - integer :: nm, iz, io + integer :: nm, iz, io, type_id real*4 :: dzs, qd, area_nm, h_cell, ramp ! if (nr_urban_drainage_zones <= 0) return ! call timer_start('urban drainage') ! - !$acc kernels present(urban_drainage_q_outfall) - urban_drainage_q_outfall = 0.0 + !$acc kernels present(urban_drainage_q_total) + urban_drainage_q_total = 0.0 !$acc end kernels ! - !$acc parallel loop present( qsrc, zs, zb, subgrid_z_zmin, cell_area, cell_area_m2, z_flags_iref, & + !$acc parallel loop present( qsrc, zs, zb, subgrid_z_zmin,z_volume, cell_area, cell_area_m2, z_flags_iref, & !$acc urban_drainage_zone_indices, urban_drainage_outfall_index, & !$acc urban_drainage_qmax, urban_drainage_backflow_coef, & - !$acc urban_drainage_q_outfall, urban_drainage_cumulative_volume, & + !$acc urban_drainage_q_total, urban_drainage_cumulative_volume, & + !$acc urb_zone_type_id, urb_zone_maximum_capacity, urb_zone_cumulative_injection, & !$acc urb_zone_h_threshold, urb_zone_check_valve ) & - !$acc reduction(+:urban_drainage_q_outfall) + !$acc reduction(+:urban_drainage_q_total) !$omp parallel do default(shared) & - !$omp private(nm, iz, io, dzs, qd, area_nm, h_cell, ramp) & - !$omp reduction(+:urban_drainage_q_outfall) schedule(static) + !$omp private(nm, iz, io, type_id, dzs, qd, area_nm, h_cell, ramp) & + !$omp reduction(+:urban_drainage_q_total) schedule(static) do nm = 1, np ! iz = urban_drainage_zone_indices(nm) if (iz == 0) cycle ! - io = urban_drainage_outfall_index(iz) - if (io <= 0) cycle - ! - dzs = zs(nm) - zs(io) + type_id = urb_zone_type_id(iz) ! - if (dzs > 0.0) then + if (type_id == urb_type_injection_well) then ! - ! Drain from cell. In subgrid mode the effective bed is the - ! subgrid minimum, not the cell-center zb. + ! Skip entirely once the well has reached maximum capacity. + ! Small overshoot of one dt is acceptable; we do not scale + ! per-cell flux to hit the cap exactly. + ! + if (urb_zone_cumulative_injection(iz) >= urb_zone_maximum_capacity(iz)) cycle ! if (subgrid) then h_cell = zs(nm) - subgrid_z_zmin(nm) else h_cell = zs(nm) - zb(nm) endif - if (h_cell <= 0.0) cycle ! - ! Linear ramp on the design-rate cap: zero discharge at h = 0, - ! full qmax at h >= h_threshold. Removes the wiggle that the - ! hard on/off gate produced near the threshold. Reduces to the - ! hard cap when h_threshold = 0 (default). + if (h_cell <= 0.0) cycle ! if (urb_zone_h_threshold(iz) > 0.0) then ramp = min(h_cell / urb_zone_h_threshold(iz), 1.0) @@ -439,46 +488,96 @@ subroutine update_urban_drainage(t, dt) area_nm = cell_area(z_flags_iref(nm)) endif ! - qd = min(ramp * urban_drainage_qmax(nm), h_cell * area_nm / dt) + if (subgrid) then + qd = min(ramp * urban_drainage_qmax(nm), z_volume(nm) / dt) + else + qd = min(ramp * urban_drainage_qmax(nm), h_cell * area_nm / dt) + endif ! else ! - ! Backflow from outfall. Blocked by a check valve. + ! piped_drainage ! - if (urb_zone_check_valve(iz)) cycle + io = urban_drainage_outfall_index(iz) + if (io <= 0) cycle ! - qd = -urban_drainage_backflow_coef(nm) * sqrt(-dzs) - if (qd < -urban_drainage_qmax(nm)) qd = -urban_drainage_qmax(nm) + dzs = zs(nm) - zs(io) + ! + if (dzs > 0.0) then + ! + if (subgrid) then + h_cell = zs(nm) - subgrid_z_zmin(nm) + else + h_cell = zs(nm) - zb(nm) + endif + if (h_cell <= 0.0) cycle + ! + if (urb_zone_h_threshold(iz) > 0.0) then + ramp = min(h_cell / urb_zone_h_threshold(iz), 1.0) + else + ramp = 1.0 + endif + ! + if (crsgeo) then + area_nm = cell_area_m2(nm) + else + area_nm = cell_area(z_flags_iref(nm)) + endif + ! + if (subgrid) then + qd = min(ramp * urban_drainage_qmax(nm), z_volume(nm) / dt) + else + qd = min(ramp * urban_drainage_qmax(nm), h_cell * area_nm / dt) + endif + ! + else + ! + if (urb_zone_check_valve(iz)) cycle + ! + qd = -urban_drainage_backflow_coef(nm) * sqrt(-dzs) + if (qd < -urban_drainage_qmax(nm)) qd = -urban_drainage_qmax(nm) + ! + endif ! endif ! ! qsrc(nm) is unique per iteration (loop is over nm), no race. - ! The zone accumulator urban_drainage_q_outfall(iz) is summed via - ! the reduction(+) clause on the parent directive, so each thread - ! / gang gets a private copy that is combined at loop end — no - ! serializing atomic needed in the common hot path. + ! The zone accumulator urban_drainage_q_total(iz) is summed via + ! the reduction(+) clause on the parent directive, so each + ! thread / gang gets a private copy that is combined at loop end. ! qsrc(nm) = qsrc(nm) - qd ! - urban_drainage_q_outfall(iz) = urban_drainage_q_outfall(iz) + qd + urban_drainage_q_total(iz) = urban_drainage_q_total(iz) + qd ! urban_drainage_cumulative_volume(nm) = urban_drainage_cumulative_volume(nm) + qd * dt ! enddo !$omp end parallel do ! - ! Second pass: add each zone's net flux back at the outfall cell. - ! Atomic guards against multiple zones snapping to the same outfall - ! cell (rare but possible). + ! Second pass: for piped_drainage zones, deposit the per-zone flux + ! at the outfall cell; for injection_well zones, accumulate the + ! cumulative injected volume. ! - !$acc parallel loop present( qsrc, urban_drainage_outfall_index, urban_drainage_q_outfall ) + !$acc parallel loop present( qsrc, urban_drainage_outfall_index, urban_drainage_q_total, & + !$acc urb_zone_type_id, urb_zone_cumulative_injection ) do iz = 1, nr_urban_drainage_zones ! - io = urban_drainage_outfall_index(iz) - if (io <= 0) cycle - ! - !$acc atomic update - qsrc(io) = qsrc(io) + urban_drainage_q_outfall(iz) + if (urb_zone_type_id(iz) == urb_type_piped_drainage) then + ! + io = urban_drainage_outfall_index(iz) + if (io <= 0) cycle + ! + !$acc atomic update + qsrc(io) = qsrc(io) + urban_drainage_q_total(iz) + ! + else + ! + ! injection_well + ! + urb_zone_cumulative_injection(iz) = urb_zone_cumulative_injection(iz) + urban_drainage_q_total(iz) * dt + ! + endif ! enddo ! @@ -490,11 +589,13 @@ subroutine update_urban_drainage(t, dt) ! subroutine write_urban_drainage_log_summary() ! - ! Emit a one-block-per-zone description of every parsed urban drainage - ! zone to the log file. Intended for operator review at init time. + ! Emit a one-block-per-zone description of every parsed urban + ! drainage zone to the log file. Intended for operator review at + ! init time. ! ! Called from: initialize_urban_drainage (this module), once after - ! cells have been stamped and per-zone totals have been accumulated. + ! cells have been stamped and per-zone totals have been + ! accumulated. ! implicit none ! @@ -515,62 +616,78 @@ subroutine write_urban_drainage_log_summary() write(logstr,'(a,i0,a)')'Zone ', iz, ':' call write_log(logstr, 0) ! - write(logstr,'(a,a)') ' name: ', trim(urb_zone_name(iz)) + write(logstr,'(a,a)') ' name: ', trim(urb_zone_name(iz)) call write_log(logstr, 0) ! - if (len_trim(urb_zone_type(iz)) > 0) then - write(logstr,'(a,a)') ' type: ', trim(urb_zone_type(iz)) - call write_log(logstr, 0) - endif + write(logstr,'(a,a)') ' type: ', trim(urb_zone_type(iz)) + call write_log(logstr, 0) ! - write(logstr,'(a,a)') ' polygon_file: ', trim(urb_zone_polygon_file(iz)) + write(logstr,'(a,a)') ' polygon_file: ', trim(urb_zone_polygon_file(iz)) call write_log(logstr, 0) ! - write(logstr,'(a,i0)') ' cells_assigned: ', urb_zone_n_cells(iz) + write(logstr,'(a,i0)') ' cells_assigned: ', urb_zone_n_cells(iz) call write_log(logstr, 0) ! - write(logstr,'(a,f0.1,a)') ' area: ', urb_zone_area(iz), ' (m2)' + write(logstr,'(a,f0.1,a)') ' area: ', urb_zone_area(iz), ' (m2)' call write_log(logstr, 0) ! - if (urb_zone_max_outfall_rate(iz) > 0.0) then - write(logstr,'(a,f0.4,a)') ' max_outfall_rate:', urb_zone_max_outfall_rate(iz), ' (m3/s)' - call write_log(logstr, 0) - write(logstr,'(a,f0.2,a)') ' design_precip: ', urb_zone_design_precip(iz), & - ' (mm/hr, derived from max_outfall_rate)' + if (urb_zone_type_id(iz) == urb_type_piped_drainage) then + ! + if (urb_zone_max_outfall_rate(iz) > 0.0) then + write(logstr,'(a,f0.4,a)') ' max_outfall_rate: ', urb_zone_max_outfall_rate(iz), ' (m3/s)' + call write_log(logstr, 0) + write(logstr,'(a,f0.2,a)') ' design_precip: ', urb_zone_design_precip(iz), & + ' (mm/hr, derived from max_outfall_rate)' + call write_log(logstr, 0) + else + write(logstr,'(a,f0.2,a)') ' design_precip: ', urb_zone_design_precip(iz), ' (mm/hr)' + call write_log(logstr, 0) + endif + ! + write(logstr,'(a,f0.4,a)') ' qmax_total: ', urb_zone_qmax_total(iz), ' (m3/s)' call write_log(logstr, 0) - else - write(logstr,'(a,f0.2,a)') ' design_precip: ', urb_zone_design_precip(iz), ' (mm/hr)' + ! + write(logstr,'(a,f0.3,a)') ' h_threshold: ', urb_zone_h_threshold(iz), ' (m)' call write_log(logstr, 0) - endif - ! - write(logstr,'(a,f0.4,a)') ' qmax_total: ', urb_zone_qmax_total(iz), ' (m3/s)' - call write_log(logstr, 0) - ! - write(logstr,'(a,f0.3,a)') ' h_threshold: ', urb_zone_h_threshold(iz), ' (m)' - call write_log(logstr, 0) - ! - write(logstr,'(a,f0.3,a)') ' dh_design_min: ', urb_zone_dh_design_min(iz), ' (m)' - call write_log(logstr, 0) - ! - if (urb_zone_include_outfall(iz)) then - write(logstr,'(a,f0.3,a,f0.3,a)')' outfall: (', urb_zone_outfall_x(iz), ', ', & - urb_zone_outfall_y(iz), ')' + ! + write(logstr,'(a,f0.3,a)') ' dh_design_min: ', urb_zone_dh_design_min(iz), ' (m)' call write_log(logstr, 0) ! - if (urban_drainage_outfall_index(iz) > 0) then - write(logstr,'(a,i0)') ' outfall_index: ', urban_drainage_outfall_index(iz) + if (urb_zone_include_outfall(iz)) then + write(logstr,'(a,f0.3,a,f0.3,a)')' outfall: (', urb_zone_outfall_x(iz), ', ', & + urb_zone_outfall_y(iz), ')' call write_log(logstr, 0) + ! + if (urban_drainage_outfall_index(iz) > 0) then + write(logstr,'(a,i0)') ' outfall_index: ', urban_drainage_outfall_index(iz) + call write_log(logstr, 0) + else + call write_log(' outfall_index: (no active cell snapped)', 0) + endif else - call write_log(' outfall_index: (no active cell snapped)', 0) + call write_log(' outfall: (disabled)', 0) endif - else - call write_log(' outfall: (disabled)', 0) - endif - ! - if (urb_zone_check_valve(iz)) then - call write_log(' check_valve: true', 0) - else - call write_log(' check_valve: false', 0) + ! + if (urb_zone_check_valve(iz)) then + call write_log(' check_valve: true', 0) + else + call write_log(' check_valve: false', 0) + endif + ! + elseif (urb_zone_type_id(iz) == urb_type_injection_well) then + ! + write(logstr,'(a,f0.4,a)') ' injection_rate: ', urb_zone_injection_rate(iz), ' (m3/s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.1,a)') ' maximum_capacity: ', urb_zone_maximum_capacity(iz), ' (m3)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.4,a)') ' qmax_total: ', urb_zone_qmax_total(iz), ' (m3/s)' + call write_log(logstr, 0) + ! + write(logstr,'(a,f0.3,a)') ' h_threshold: ', urb_zone_h_threshold(iz), ' (m)' + call write_log(logstr, 0) + ! endif ! call write_log('', 0) @@ -588,18 +705,26 @@ subroutine read_urban_drainage(filename, ierr) ! Schema: ! ! [[urban_drainage_zone]] - ! name = "area 1" ! required, string (matches polygon name) - ! type = "drainage" ! optional, free-form tag (reserved) - ! polygon_file = "zones.tek" ! required - ! outfall_x = 950.0 ! required if include_outfall = true - ! outfall_y = 150.0 ! required if include_outfall = true - ! design_precip = 20.0 ! required if max_outfall_rate absent, mm/hr - ! max_outfall_rate = 6.0 ! alternative to design_precip, m3/s total zone capacity - ! ! exactly one of {design_precip, max_outfall_rate} must be given - ! h_threshold = 0.0 ! optional, m (default 0.0) - ! dh_design_min = 0.1 ! optional, m (default 0.1) - ! include_outfall = true ! optional (default true) - ! check_valve = true ! optional (default false) + ! name = "area 1" ! required, string (matches polygon name) + ! type = "piped_drainage" ! required, one of: "piped_drainage", "injection_well" + ! polygon_file = "zones.tek" ! required + ! + ! # piped_drainage keys: + ! outfall_x = 950.0 ! required if include_outfall = true + ! outfall_y = 150.0 ! required if include_outfall = true + ! design_precip = 20.0 ! required if max_outfall_rate absent, mm/hr + ! max_outfall_rate = 6.0 ! alternative to design_precip, m3/s total zone capacity + ! ! exactly one of {design_precip, max_outfall_rate} must be given + ! dh_design_min = 0.1 ! optional, m (default 0.1) + ! include_outfall = true ! optional (default true) + ! check_valve = true ! optional (default false) + ! + ! # injection_well keys: + ! injection_rate = 0.5 ! required, m3/s total zone pump rate + ! maximum_capacity = 1000.0 ! required, m3 well total storage capacity + ! + ! # common: + ! h_threshold = 0.0 ! optional, m (default 0.0) ! ! Called from: initialize_urban_drainage (this module). ! @@ -616,7 +741,6 @@ subroutine read_urban_drainage(filename, ierr) type(toml_table), pointer :: tbl_zone character(len=:), allocatable :: name_str, type_str, poly_str integer :: nz, i, stat - real*4 :: r4_tmp real(kind=8) :: r8_tmp logical :: l_tmp, found ! @@ -661,27 +785,33 @@ subroutine read_urban_drainage(filename, ierr) ! allocate(urb_zone_name(nz)) allocate(urb_zone_type(nz)) + allocate(urb_zone_type_id(nz)) allocate(urb_zone_polygon_file(nz)) allocate(urb_zone_outfall_x(nz)) allocate(urb_zone_outfall_y(nz)) allocate(urb_zone_design_precip(nz)) allocate(urb_zone_max_outfall_rate(nz)) + allocate(urb_zone_injection_rate(nz)) + allocate(urb_zone_maximum_capacity(nz)) allocate(urb_zone_h_threshold(nz)) allocate(urb_zone_dh_design_min(nz)) allocate(urb_zone_include_outfall(nz)) allocate(urb_zone_check_valve(nz)) ! - urb_zone_name = '' - urb_zone_type = '' - urb_zone_polygon_file = '' - urb_zone_outfall_x = 0.0 - urb_zone_outfall_y = 0.0 + urb_zone_name = '' + urb_zone_type = '' + urb_zone_type_id = 0 + urb_zone_polygon_file = '' + urb_zone_outfall_x = 0.0 + urb_zone_outfall_y = 0.0 urb_zone_design_precip = 0.0 urb_zone_max_outfall_rate = 0.0 + urb_zone_injection_rate = 0.0 + urb_zone_maximum_capacity = 0.0 urb_zone_h_threshold = 0.0 - urb_zone_dh_design_min = 0.1 - urb_zone_include_outfall = .true. - urb_zone_check_valve = .false. + urb_zone_dh_design_min = 0.1 + urb_zone_include_outfall = .true. + urb_zone_check_valve = .false. ! do i = 1, nz ! @@ -704,9 +834,32 @@ subroutine read_urban_drainage(filename, ierr) endif urb_zone_name(i) = name_str ! + ! type is now required and must resolve to a known type id. + ! if (allocated(type_str)) deallocate(type_str) call get_value(tbl_zone, 'type', type_str, stat=stat) - if (allocated(type_str)) urb_zone_type(i) = type_str + if (.not. allocated(type_str)) then + write(logstr,'(a,a,a)')' Error ! Missing required "type" in urban_drainage_zone "', & + trim(urb_zone_name(i)), '" (expected "piped_drainage" or "injection_well")' + call write_log(logstr, 1) + ierr = 1 + return + endif + urb_zone_type(i) = type_str + ! + select case (trim(type_str)) + case ('piped_drainage') + urb_zone_type_id(i) = urb_type_piped_drainage + case ('injection_well') + urb_zone_type_id(i) = urb_type_injection_well + case default + write(logstr,'(a,a,a,a,a)')' Error ! Unknown type "', trim(type_str), & + '" in urban_drainage_zone "', trim(urb_zone_name(i)), & + '" (expected "piped_drainage" or "injection_well")' + call write_log(logstr, 1) + ierr = 1 + return + end select ! if (allocated(poly_str)) deallocate(poly_str) call get_value(tbl_zone, 'polygon_file', poly_str, stat=stat) @@ -719,78 +872,105 @@ subroutine read_urban_drainage(filename, ierr) endif urb_zone_polygon_file(i) = poly_str ! - call get_value(tbl_zone, 'outfall_x', r8_tmp, stat=stat) - if (stat == 0) urb_zone_outfall_x(i) = real(r8_tmp, 4) + ! h_threshold is common to both types. ! - call get_value(tbl_zone, 'outfall_y', r8_tmp, stat=stat) - if (stat == 0) urb_zone_outfall_y(i) = real(r8_tmp, 4) + call get_value(tbl_zone, 'h_threshold', r8_tmp, stat=stat) + if (stat == 0) urb_zone_h_threshold(i) = real(r8_tmp, 4) ! - ! Exactly one of design_precip / max_outfall_rate must be given. - ! has_key distinguishes "absent" from "present but 0.0", so a user - ! who really wants a zero-capacity zone can still write it. + ! Type-specific fields. ! - block - logical :: has_precip, has_rate - has_precip = tbl_zone%has_key('design_precip') - has_rate = tbl_zone%has_key('max_outfall_rate') - if (has_precip .and. has_rate) then - write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(i)), & - '" has both "design_precip" and "max_outfall_rate"; specify only one' + if (urb_zone_type_id(i) == urb_type_piped_drainage) then + ! + call get_value(tbl_zone, 'outfall_x', r8_tmp, stat=stat) + if (stat == 0) urb_zone_outfall_x(i) = real(r8_tmp, 4) + ! + call get_value(tbl_zone, 'outfall_y', r8_tmp, stat=stat) + if (stat == 0) urb_zone_outfall_y(i) = real(r8_tmp, 4) + ! + ! Exactly one of design_precip / max_outfall_rate must be given. + ! has_key distinguishes "absent" from "present but 0.0". + ! + block + logical :: has_precip, has_rate + has_precip = tbl_zone%has_key('design_precip') + has_rate = tbl_zone%has_key('max_outfall_rate') + if (has_precip .and. has_rate) then + write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(i)), & + '" has both "design_precip" and "max_outfall_rate"; specify only one' + call write_log(logstr, 1) + ierr = 1 + return + endif + if (.not. has_precip .and. .not. has_rate) then + write(logstr,'(a,a,a)')' Error ! piped_drainage zone "', trim(urb_zone_name(i)), & + '" needs "design_precip" (mm/hr) or "max_outfall_rate" (m3/s)' + call write_log(logstr, 1) + ierr = 1 + return + endif + if (has_precip) then + call get_value(tbl_zone, 'design_precip', r8_tmp, stat=stat) + urb_zone_design_precip(i) = real(r8_tmp, 4) + else + call get_value(tbl_zone, 'max_outfall_rate', r8_tmp, stat=stat) + urb_zone_max_outfall_rate(i) = real(r8_tmp, 4) + endif + end block + ! + call get_value(tbl_zone, 'dh_design_min', r8_tmp, stat=stat) + if (stat == 0) urb_zone_dh_design_min(i) = real(r8_tmp, 4) + if (urb_zone_dh_design_min(i) <= 0.0) urb_zone_dh_design_min(i) = 0.1 + ! + call get_value(tbl_zone, 'include_outfall', l_tmp, stat=stat) + if (stat == 0) urb_zone_include_outfall(i) = l_tmp + ! + call get_value(tbl_zone, 'check_valve', l_tmp, stat=stat) + if (stat == 0) urb_zone_check_valve(i) = l_tmp + ! + ! Minimal sanity check on outfall: if include_outfall is true, + ! outfall coords should be specified (warn only; snap will + ! catch bad values). + ! + if (urb_zone_include_outfall(i)) then + found = (urb_zone_outfall_x(i) /= 0.0 .or. urb_zone_outfall_y(i) /= 0.0) + if (.not. found) then + write(logstr,'(a,a,a)')' Warning : piped_drainage zone "', trim(urb_zone_name(i)), & + '" has include_outfall = true but outfall_x, outfall_y both 0.0' + call write_log(logstr, 0) + endif + endif + ! + elseif (urb_zone_type_id(i) == urb_type_injection_well) then + ! + if (.not. tbl_zone%has_key('injection_rate')) then + write(logstr,'(a,a,a)')' Error ! injection_well zone "', trim(urb_zone_name(i)), & + '" needs "injection_rate" (m3/s)' call write_log(logstr, 1) ierr = 1 return endif - if (.not. has_precip .and. .not. has_rate) then - write(logstr,'(a,a,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(i)), & - '" needs "design_precip" (mm/hr) or "max_outfall_rate" (m3/s)' + call get_value(tbl_zone, 'injection_rate', r8_tmp, stat=stat) + urb_zone_injection_rate(i) = real(r8_tmp, 4) + ! + if (.not. tbl_zone%has_key('maximum_capacity')) then + write(logstr,'(a,a,a)')' Error ! injection_well zone "', trim(urb_zone_name(i)), & + '" needs "maximum_capacity" (m3)' call write_log(logstr, 1) ierr = 1 return endif - if (has_precip) then - call get_value(tbl_zone, 'design_precip', r8_tmp, stat=stat) - urb_zone_design_precip(i) = real(r8_tmp, 4) - else - call get_value(tbl_zone, 'max_outfall_rate', r8_tmp, stat=stat) - urb_zone_max_outfall_rate(i) = real(r8_tmp, 4) - endif - end block - ! - call get_value(tbl_zone, 'h_threshold', r8_tmp, stat=stat) - if (stat == 0) urb_zone_h_threshold(i) = real(r8_tmp, 4) - ! - call get_value(tbl_zone, 'dh_design_min', r8_tmp, stat=stat) - if (stat == 0) urb_zone_dh_design_min(i) = real(r8_tmp, 4) - ! - call get_value(tbl_zone, 'include_outfall', l_tmp, stat=stat) - if (stat == 0) urb_zone_include_outfall(i) = l_tmp - ! - call get_value(tbl_zone, 'check_valve', l_tmp, stat=stat) - if (stat == 0) urb_zone_check_valve(i) = l_tmp - ! - ! Minimal sanity check on outfall: if include_outfall is true, outfall - ! coords must be specified (non-zero default is a weak check; keep it - ! simple by warning rather than failing — snap will catch bad values). - ! - if (urb_zone_include_outfall(i)) then - found = (urb_zone_outfall_x(i) /= 0.0 .or. urb_zone_outfall_y(i) /= 0.0) - if (.not. found) then - write(logstr,'(a,a,a)')' Warning : urban_drainage_zone "', trim(urb_zone_name(i)), & - '" has include_outfall = true but outfall_x, outfall_y both 0.0' - call write_log(logstr, 0) - endif + call get_value(tbl_zone, 'maximum_capacity', r8_tmp, stat=stat) + urb_zone_maximum_capacity(i) = real(r8_tmp, 4) + ! + ! injection_well has no outfall or check valve. + ! + urb_zone_include_outfall(i) = .false. + urb_zone_check_valve(i) = .false. + ! endif ! - if (urb_zone_dh_design_min(i) <= 0.0) urb_zone_dh_design_min(i) = 0.1 - ! enddo ! - ! Keep the compiler from warning about unused variables in case get_value - ! signatures drift; r4_tmp is reserved for future per-zone scalars. - ! - r4_tmp = 0.0 - if (r4_tmp < 0.0) continue - ! end subroutine ! end module sfincs_urban_drainage From 68193cf8752cc3dade891e1c6524f09e26313992 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Mon, 20 Apr 2026 02:37:47 +0200 Subject: [PATCH 47/65] Use coordinate-pair arrays for structures Replace separate x/y keys (src_1_x, src_1_y, src_2_x, src_2_y, obs_1_x, ...) with compact coordinate-pair array keys (src_1, src_2, obs_1, obs_2). Update per-type required-key checks to expect the new keys and add check_required_coord_pair and read_coord_pair helpers to validate/read 2-element arrays and emit clear errors for missing/invalid entries. Replace legacy get_value calls and key-presence checks with the new readers, and update TOML writer output to serialize src_1/src_2 as [x, y]. Overall improves input format clarity and validation for structure coordinates. --- source/src/sfincs_src_structures.f90 | 149 +++++++++++++++++++++------ 1 file changed, 119 insertions(+), 30 deletions(-) diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 19f1810be..5d781db7e 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -1149,8 +1149,8 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! ! one of "both" (default), "positive", "negative" ! ! positive: allow flow src_1 -> src_2 only ! ! negative: allow flow src_2 -> src_1 only - ! src_1_x = ... ; src_1_y = ... ; src_2_x = ... ; src_2_y = ... - ! obs_1_x = ... ; obs_1_y = ... ; obs_2_x = ... ; obs_2_y = ... + ! src_1 = [x, y] ; src_2 = [x, y] + ! obs_1 = [x, y] ; obs_2 = [x, y] ! q = ... ! pump discharge ! width = ... ; sill_elevation = ... ; mannings_n = ... ! opening_duration = ... ; closing_duration = ... @@ -1162,10 +1162,10 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! rules_close = "z2>2.0" ! optional trigger expr ! ! Per-type required keys (enforced on parse): - ! pump : name, src_1_x, src_1_y, src_2_x, src_2_y, q - ! culvert_simple : name, src_1_x, src_1_y, src_2_x, src_2_y, flow_coef - ! gate : name, src_1_x, src_1_y, src_2_x, src_2_y, width, sill_elevation - ! culvert : name, src_1_x, src_1_y, src_2_x, src_2_y, + ! pump : name, src_1, src_2, q + ! culvert_simple : name, src_1, src_2, flow_coef + ! gate : name, src_1, src_2, width, sill_elevation + ! culvert : name, src_1, src_2, ! width, height, invert_1, invert_2 ! (optional: flow_coef=0.6, submergence_ratio=0.667) ! @@ -1301,24 +1301,30 @@ subroutine read_toml_src_structures(filename, structures, ierr) case (structure_pump) ! call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'q' ], i, ierr) + 'name', 'q' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) ! case (structure_culvert_simple) ! call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', 'flow_coef' ], i, ierr) + 'name', 'flow_coef' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) ! case (structure_gate) ! call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & - 'width', 'sill_elevation' ], i, ierr) + 'name', 'width', 'sill_elevation' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) ! case (structure_culvert) ! call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'src_1_x', 'src_1_y', 'src_2_x', 'src_2_y', & - 'width', 'height', 'invert_1', 'invert_2' ], i, ierr) + 'name', 'width', 'height', 'invert_1', 'invert_2' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) ! end select ! @@ -1334,18 +1340,14 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! presence here so the marshal can distinguish "user gave (0,0)" ! from "user gave nothing". ! - call get_value(tbl_struct, 'src_1_x', structures(i)%src_1_x, 0.0, stat=stat) - call get_value(tbl_struct, 'src_1_y', structures(i)%src_1_y, 0.0, stat=stat) - call get_value(tbl_struct, 'src_2_x', structures(i)%src_2_x, 0.0, stat=stat) - call get_value(tbl_struct, 'src_2_y', structures(i)%src_2_y, 0.0, stat=stat) + call read_coord_pair(tbl_struct, 'src_1', structures(i)%src_1_x, structures(i)%src_1_y, i, ierr) + call read_coord_pair(tbl_struct, 'src_2', structures(i)%src_2_x, structures(i)%src_2_y, i, ierr) ! - structures(i)%has_obs_1 = tbl_struct%has_key('obs_1_x') .or. tbl_struct%has_key('obs_1_y') - structures(i)%has_obs_2 = tbl_struct%has_key('obs_2_x') .or. tbl_struct%has_key('obs_2_y') + structures(i)%has_obs_1 = tbl_struct%has_key('obs_1') + structures(i)%has_obs_2 = tbl_struct%has_key('obs_2') ! - call get_value(tbl_struct, 'obs_1_x', structures(i)%obs_1_x, 0.0, stat=stat) - call get_value(tbl_struct, 'obs_1_y', structures(i)%obs_1_y, 0.0, stat=stat) - call get_value(tbl_struct, 'obs_2_x', structures(i)%obs_2_x, 0.0, stat=stat) - call get_value(tbl_struct, 'obs_2_y', structures(i)%obs_2_y, 0.0, stat=stat) + call read_coord_pair(tbl_struct, 'obs_1', structures(i)%obs_1_x, structures(i)%obs_1_y, i, ierr) + call read_coord_pair(tbl_struct, 'obs_2', structures(i)%obs_2_x, structures(i)%obs_2_y, i, ierr) ! ! Named physical parameters. Defaults are picked to avoid NaN in ! arithmetic and to match the legacy-reader fallbacks. @@ -1507,6 +1509,97 @@ subroutine check_required(table, keys, seq_index, ierr) ! !-----------------------------------------------------------------------------------------------------! ! + subroutine check_required_coord_pair(table, key_base, seq_index, ierr) + ! + ! Verify that a coordinate pair " = [x, y]" is present in the + ! TOML table. Emits a single missing-key error when absent. + ! + ! Called from: read_toml_src_structures (this module), once per required + ! coordinate pair (src_1, src_2) in the per-type validation block. + ! + use tomlf + ! + implicit none + ! + type(toml_table), pointer, intent(in) :: table + character(len=*), intent(in) :: key_base + integer, intent(in) :: seq_index + integer, intent(inout) :: ierr + ! + if (.not. table%has_key(trim(key_base))) then + ! + write(logstr,'(a,i0,a,a,a)')' Error ! Structure #', seq_index, & + ' is missing required coordinate pair "', trim(key_base), ' = [x, y]"' + call write_log(logstr, 1) + ierr = 1 + ! + endif + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! + subroutine read_coord_pair(table, key_base, x, y, seq_index, ierr) + ! + ! Read a coordinate pair " = [x, y]" from a TOML table. + ! + ! If the key is absent, x and y are left at 0.0 and no error is raised + ! here — presence of required pairs is enforced separately by + ! check_required_coord_pair. + ! + ! Called from: read_toml_src_structures (this module), once per + ! coordinate pair (src_1, src_2, obs_1, obs_2) per structure entry. + ! + use tomlf + ! + implicit none + ! + type(toml_table), pointer, intent(in) :: table + character(len=*), intent(in) :: key_base + real, intent(out) :: x, y + integer, intent(in) :: seq_index + integer, intent(inout) :: ierr + ! + type(toml_array), pointer :: arr + integer :: n, stat + ! + x = 0.0 + y = 0.0 + ! + if (.not. table%has_key(trim(key_base))) return + ! + nullify(arr) + call get_value(table, trim(key_base), arr, requested=.false., stat=stat) + ! + if (.not. associated(arr)) then + ! + write(logstr,'(a,a,a,i0,a)')' Error ! Key "', trim(key_base), & + '" in src_structure #', seq_index, ' must be a 2-element array [x, y]' + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + n = len(arr) + ! + if (n /= 2) then + ! + write(logstr,'(a,a,a,i0,a,i0,a)')' Error ! Key "', trim(key_base), & + '" in src_structure #', seq_index, ' must have exactly 2 elements (got ', n, ')' + call write_log(logstr, 1) + ierr = 1 + return + ! + endif + ! + call get_value(arr, 1, x, stat=stat) + call get_value(arr, 2, y, stat=stat) + ! + end subroutine + ! + !-----------------------------------------------------------------------------------------------------! + ! subroutine parse_structure_type(str, code, ierr) ! ! Translate a TOML "type" string to one of the structure_* codes. @@ -2063,10 +2156,8 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) write(u_out,'(a)') '[[src_structure]]' write(u_out,'(a,a,a)') 'name = "', trim(name_str), '"' write(u_out,'(a)') 'type = "gate"' - write(u_out,'(a,es14.6)') 'src_1_x = ', x1 - write(u_out,'(a,es14.6)') 'src_1_y = ', y1 - write(u_out,'(a,es14.6)') 'src_2_x = ', x2 - write(u_out,'(a,es14.6)') 'src_2_y = ', y2 + write(u_out,'(a,es14.6,a,es14.6,a)') 'src_1 = [', x1, ', ', y1, ']' + write(u_out,'(a,es14.6,a,es14.6,a)') 'src_2 = [', x2, ', ', y2, ']' write(u_out,'(a,es14.6)') 'width = ', g_width write(u_out,'(a,es14.6)') 'sill_elevation = ', g_sill write(u_out,'(a,es14.6)') 'mannings_n = ', g_mann @@ -2111,10 +2202,8 @@ subroutine convert_legacy_to_toml(legacy_path, toml_path, ierr) ! endif ! - write(u_out,'(a,es14.6)') 'src_1_x = ', x1 - write(u_out,'(a,es14.6)') 'src_1_y = ', y1 - write(u_out,'(a,es14.6)') 'src_2_x = ', x2 - write(u_out,'(a,es14.6)') 'src_2_y = ', y2 + write(u_out,'(a,es14.6,a,es14.6,a)') 'src_1 = [', x1, ', ', y1, ']' + write(u_out,'(a,es14.6,a,es14.6,a)') 'src_2 = [', x2, ', ', y2, ']' write(u_out,'(a,a,a,es14.6)') trim(par_name), repeat(' ', max(1, 7 - len_trim(par_name))), '= ', par write(u_out,'(a)') '' ! From db16b66d00a1121dffcf7cdb01fbc8b6b1dea4ee Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Mon, 20 Apr 2026 11:26:22 +0200 Subject: [PATCH 48/65] Support outfall=[x,y] and add fmt_real logging Replace separate outfall_x/outfall_y keys with a single 2-element outfall array (docs and parser). The urban_drainage parser now reads and validates toml arrays for outfall, sets internal outfall_x/y, and updates related warnings. Introduce fmt_real helper to produce consistent, minimal-width real formatting (works around ifx leading-zero quirk) and refactor many log lines to use trim(fmt_real(...)) with aligned labels. Add dtmapout keyword with a backward-compatible alias for dtout. Update NetCDF metadata for urban drainage discharge (clarified long_name) and remove the cumulative injection NetCDF variable/usages. --- docs/input_urban_drainage.rst | 8 ++-- source/src/sfincs_input.f90 | 2 +- source/src/sfincs_log.f90 | 46 ++++++++++++++++++++ source/src/sfincs_ncoutput.F90 | 16 ++----- source/src/sfincs_src_structures.f90 | 52 +++++++++++----------- source/src/sfincs_urban_drainage.f90 | 64 +++++++++++++++++++--------- 6 files changed, 123 insertions(+), 65 deletions(-) diff --git a/docs/input_urban_drainage.rst b/docs/input_urban_drainage.rst index 41f0d387c..874f3640f 100644 --- a/docs/input_urban_drainage.rst +++ b/docs/input_urban_drainage.rst @@ -42,8 +42,7 @@ Piped drainage example name = "downtown" type = "piped_drainage" polygon_file = "zones.tek" - outfall_x = 950.0 - outfall_y = 150.0 + outfall = [950.0, 150.0] design_precip = 20.0 check_valve = true @@ -51,8 +50,7 @@ Piped drainage example name = "harbor_district" type = "piped_drainage" polygon_file = "zones.tek" - outfall_x = 1020.0 - outfall_y = 180.0 + outfall = [1020.0, 180.0] max_outfall_rate = 6.0 Injection well example @@ -91,7 +89,7 @@ Piped drainage keys ``max_outfall_rate`` (conditional, m³/s) Total zone outfall capacity. Useful when you know what the outfall pipe can deliver but not the design storm it was sized for. SFINCS derives ``design_precip = max_outfall_rate / zone_area * 3.6e6`` from the zone's total polygon-covered area, so per-cell capacity is distributed proportionally to cell area. **Exactly one of** ``design_precip`` **or** ``max_outfall_rate`` **must be provided for piped_drainage zones.** -``outfall_x``, ``outfall_y`` (required when ``include_outfall = true``) +``outfall`` (required when ``include_outfall = true``, 2-element array ``[x, y]``) Coordinates of the single point where all zone discharge is summed and deposited. Snapped to the nearest active cell. If no active cell can be found, zone contributions are silently discarded and a warning is logged. ``include_outfall`` (optional, bool, default ``true``) diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 88b43b62d..4af25dc94 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -117,7 +117,7 @@ subroutine read_sfincs_input() call get_keyword(500, 'tspinup', tspinup, 0.0) ! spin-up interval after t0 (s) call get_keyword(500, 't0out', t0out, -999.0) ! output start time (s rel. tref); -999 = t0 call get_keyword(500, 't1out', t1out, -999.0) ! output stop time (s rel. tref); -999 = t1 - call get_keyword(500, 'dtout', dtmapout, 0.0) ! map output interval (s); 0 = no map output + call get_keyword(500, 'dtmapout', dtmapout, 0.0, ['dtout']) ! map output interval (s); 0 = no map output call get_keyword(500, 'dtmaxout', dtmaxout, 9999999.0) ! zsmax etc. interval (s); 0 = end-of-run only call get_keyword(500, 'dtrstout', dtrstout, 0.0) ! restart interval (s); 0 = no periodic restart call get_keyword(500, 'trstout', trst, -999.0) ! single restart time (s rel. tref); -999 = unused diff --git a/source/src/sfincs_log.f90 b/source/src/sfincs_log.f90 index 0c02c4f28..867feb652 100644 --- a/source/src/sfincs_log.f90 +++ b/source/src/sfincs_log.f90 @@ -46,6 +46,13 @@ module sfincs_log ! original inline code in sfincs_lib produced. Called from ! sfincs_finalize (sfincs_lib) when write_time_output is set. ! + ! fmt_real(val, decimals) result(s) + ! Format a real value with the minimum necessary field width and + ! a guaranteed leading zero for |val| < 1. Works around a quirk + ! in ifx that drops the leading zero for the "f0.d" edit + ! descriptor. Returns a 32-char string, left-justified; callers + ! use trim(fmt_real(...)) when embedding it in a larger format. + ! use sfincs_timers ! integer :: fid @@ -96,6 +103,45 @@ end subroutine write_log ! !-----------------------------------------------------------------------------------------------------! ! + function fmt_real(val, decimals) result(s) + ! + ! Format a real with minimum width and a guaranteed leading zero + ! for |val| < 1. ifx's "f0.d" descriptor drops the leading zero in + ! that range, which is not standard-conforming; this helper rewrites + ! the result so the log output always reads "0.6670" rather than + ! ".6670". + ! + ! Called from: write_src_structures_log_summary (sfincs_src_structures), + ! urban_drainage log summary (sfincs_urban_drainage), and anywhere + ! else a real needs to be embedded in a log line with the smallest + ! reasonable field width. + ! + implicit none + ! + real, intent(in) :: val + integer, intent(in) :: decimals + character(len=32) :: s + ! + character(len=16) :: fmt + ! + write(fmt,'(a,i0,a)') '(f0.', decimals, ')' + write(s,fmt) val + s = adjustl(s) + ! + if (s(1:1) == '.') then + ! + s = '0' // s(1:len_trim(s)) + ! + else if (s(1:2) == '-.') then + ! + s = '-0' // trim(s(2:)) + ! + endif + ! + end function fmt_real + ! + !-----------------------------------------------------------------------------------------------------! + ! subroutine close_log() ! ! Close the sfincs.log file handle. Called once at the end of diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 082045921..d8077049f 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -52,7 +52,7 @@ module sfincs_ncoutput integer :: thindam_x_varid, thindam_y_varid integer :: drain_varid, drain_name_varid integer :: river_varid, river_name_varid - integer :: urbdrain_varid, urbdrain_name_varid, urbdrain_cuminj_varid + integer :: urbdrain_varid, urbdrain_name_varid integer :: zb_varid integer :: time_varid integer :: zs_varid, h_varid, u_varid, v_varid, prcp_varid, cumprcp_varid, discharge_varid, uvmag_varid, uvdir_varid @@ -2189,18 +2189,12 @@ subroutine ncoutput_his_init() ! if (nr_urban_drainage_zones > 0 .and. store_urban_drainage_discharge) then ! - NF90(nf90_def_var(his_file%ncid, 'urban_drainage_discharge', NF90_FLOAT, (/his_file%urbdrain_dimid, his_file%time_dimid/), his_file%urbdrain_varid)) ! per-zone total discharge + NF90(nf90_def_var(his_file%ncid, 'urban_drainage_discharge', NF90_FLOAT, (/his_file%urbdrain_dimid, his_file%time_dimid/), his_file%urbdrain_varid)) ! per-zone outfall discharge NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, '_FillValue', FILL_VALUE)) NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'units', 'm3 s-1')) - NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'long_name', 'urban drainage zone total discharge')) + NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'long_name', 'urban drainage zone net outfall discharge')) NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_varid, 'coordinates', 'urban_drainage_zone_name')) ! - NF90(nf90_def_var(his_file%ncid, 'cumulative_injection_volume', NF90_FLOAT, (/his_file%urbdrain_dimid, his_file%time_dimid/), his_file%urbdrain_cuminj_varid)) ! per-zone cumulative injected volume (injection_well) - NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_cuminj_varid, '_FillValue', FILL_VALUE)) - NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_cuminj_varid, 'units', 'm3')) - NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_cuminj_varid, 'long_name', 'urban drainage zone cumulative injection volume')) - NF90(nf90_put_att(his_file%ncid, his_file%urbdrain_cuminj_varid, 'coordinates', 'urban_drainage_zone_name')) - ! endif ! if (nr_runup_gauges > 0) then @@ -3227,7 +3221,7 @@ subroutine ncoutput_update_his(t,nthisout) use sfincs_snapwave use sfincs_src_structures, only: nr_src_structures, q_src_struc use sfincs_discharges, only: qtsrc, nr_discharge_points - use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_total, urb_zone_cumulative_injection + use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_total ! implicit none ! @@ -3539,8 +3533,6 @@ subroutine ncoutput_update_his(t,nthisout) ! NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_varid, urban_drainage_q_total, (/1, nthisout/))) ! write per-zone total discharge ! - NF90(nf90_put_var(his_file%ncid, his_file%urbdrain_cuminj_varid, urb_zone_cumulative_injection, (/1, nthisout/))) ! write per-zone cumulative injection volume - ! endif ! if (store_velocity) then diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 5d781db7e..20f58721f 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -1784,16 +1784,16 @@ subroutine write_src_structures_log_summary() write(logstr,'(a,i0,a)')'Structure ', i, ':' call write_log(logstr, 0) ! - write(logstr,'(a,a)')' name: ', trim(src_struc_name(i)) + write(logstr,'(a22,a)') ' name:', trim(src_struc_name(i)) call write_log(logstr, 0) ! - write(logstr,'(a,a)')' type: ', trim(type_str) + write(logstr,'(a22,a)') ' type:', trim(type_str) call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a,f0.3,a)')' src_1: (', src_struc_src_1_x(i), ', ', src_struc_src_1_y(i), ')' + write(logstr,'(a22,a,a,a,a,a)') ' src_1:', '(', trim(fmt_real(src_struc_src_1_x(i), 3)), ', ', trim(fmt_real(src_struc_src_1_y(i), 3)), ')' call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a,f0.3,a)')' src_2: (', src_struc_src_2_x(i), ', ', src_struc_src_2_y(i), ')' + write(logstr,'(a22,a,a,a,a,a)') ' src_2:', '(', trim(fmt_real(src_struc_src_2_x(i), 3)), ', ', trim(fmt_real(src_struc_src_2_y(i), 3)), ')' call write_log(logstr, 0) ! ! obs coords are meaningful for culvert_simple / gate. @@ -1801,24 +1801,24 @@ subroutine write_src_structures_log_summary() if (src_struc_type(i) == structure_culvert_simple .or. & src_struc_type(i) == structure_gate) then ! - write(logstr,'(a,f0.3,a,f0.3,a)')' obs_1: (', src_struc_obs_1_x(i), ', ', src_struc_obs_1_y(i), ')' + write(logstr,'(a22,a,a,a,a,a)') ' obs_1:', '(', trim(fmt_real(src_struc_obs_1_x(i), 3)), ', ', trim(fmt_real(src_struc_obs_1_y(i), 3)), ')' call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a,f0.3,a)')' obs_2: (', src_struc_obs_2_x(i), ', ', src_struc_obs_2_y(i), ')' + write(logstr,'(a22,a,a,a,a,a)') ' obs_2:', '(', trim(fmt_real(src_struc_obs_2_x(i), 3)), ', ', trim(fmt_real(src_struc_obs_2_y(i), 3)), ')' call write_log(logstr, 0) ! endif ! if (src_struc_type(i) == structure_pump) then ! - write(logstr,'(a,f0.4,a)')' discharge: ', src_struc_q(i), ' (m3/s)' + write(logstr,'(a22,a,a)') ' discharge:', trim(fmt_real(src_struc_q(i), 4)), ' (m3/s)' call write_log(logstr, 0) ! endif ! if (src_struc_type(i) == structure_culvert_simple) then ! - write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) + write(logstr,'(a22,a)') ' flow_coef:', trim(fmt_real(src_struc_flow_coef(i), 4)) call write_log(logstr, 0) ! endif @@ -1848,48 +1848,48 @@ subroutine write_src_structures_log_summary() ! end select ! - write(logstr,'(a,a)')' direction: ', trim(dir_str) + write(logstr,'(a22,a)') ' direction:', trim(dir_str) call write_log(logstr, 0) ! endif ! if (src_struc_type(i) == structure_culvert) then ! - write(logstr,'(a,f0.4,a)')' width: ', src_struc_width(i), ' (m)' + write(logstr,'(a22,a,a)') ' width:', trim(fmt_real(src_struc_width(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4,a)')' height: ', src_struc_height(i), ' (m)' + write(logstr,'(a22,a,a)') ' height:', trim(fmt_real(src_struc_height(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4,a)')' invert_1: ', src_struc_invert_1(i), ' (m)' + write(logstr,'(a22,a,a)') ' invert_1:', trim(fmt_real(src_struc_invert_1(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4,a)')' invert_2: ', src_struc_invert_2(i), ' (m)' + write(logstr,'(a22,a,a)') ' invert_2:', trim(fmt_real(src_struc_invert_2(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4)')' flow_coef: ', src_struc_flow_coef(i) + write(logstr,'(a22,a)') ' flow_coef:', trim(fmt_real(src_struc_flow_coef(i), 4)) call write_log(logstr, 0) ! - write(logstr,'(a,f0.4)')' submerg_r: ', src_struc_submergence_ratio(i) + write(logstr,'(a22,a)') ' submergence_ratio:', trim(fmt_real(src_struc_submergence_ratio(i), 4)) call write_log(logstr, 0) ! endif ! if (src_struc_type(i) == structure_gate) then ! - write(logstr,'(a,f0.4,a)')' width: ', src_struc_width(i), ' (m)' + write(logstr,'(a22,a,a)') ' width:', trim(fmt_real(src_struc_width(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4,a)')' sill_elev.: ', src_struc_sill_elevation(i), ' (m)' + write(logstr,'(a22,a,a)') ' sill_elevation:', trim(fmt_real(src_struc_sill_elevation(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4)')' mannings_n: ', src_struc_mannings_n(i) + write(logstr,'(a22,a)') ' mannings_n:', trim(fmt_real(src_struc_mannings_n(i), 4)) call write_log(logstr, 0) ! - write(logstr,'(a,f0.2,a)')' opening: ', src_struc_opening_duration(i), ' (s)' + write(logstr,'(a22,a,a)') ' opening_duration:', trim(fmt_real(src_struc_opening_duration(i), 2)), ' (s)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.2,a)')' closing: ', src_struc_closing_duration(i), ' (s)' + write(logstr,'(a22,a,a)') ' closing_duration:', trim(fmt_real(src_struc_closing_duration(i), 2)), ' (s)' call write_log(logstr, 0) ! endif @@ -1898,11 +1898,11 @@ subroutine write_src_structures_log_summary() ! if (len_trim(src_struc_rule_open_src(i)) > 0) then ! - write(logstr,'(a,a,a)')' rules_open: "', trim(src_struc_rule_open_src(i)), '"' + write(logstr,'(a22,a,a,a)') ' rules_open:', '"', trim(src_struc_rule_open_src(i)), '"' ! else ! - write(logstr,'(a)')' rules_open: (set)' + write(logstr,'(a22,a)') ' rules_open:', '(set)' ! endif ! @@ -1914,11 +1914,11 @@ subroutine write_src_structures_log_summary() ! if (len_trim(src_struc_rule_close_src(i)) > 0) then ! - write(logstr,'(a,a,a)')' rules_close: "', trim(src_struc_rule_close_src(i)), '"' + write(logstr,'(a22,a,a,a)') ' rules_close:', '"', trim(src_struc_rule_close_src(i)), '"' ! else ! - write(logstr,'(a)')' rules_close: (set)' + write(logstr,'(a22,a)') ' rules_close:', '(set)' ! endif ! @@ -1935,10 +1935,10 @@ subroutine write_src_structures_log_summary() if ((src_struc_rule_open(i) > 0 .or. src_struc_rule_close(i) > 0) .and. & (src_struc_opening_duration(i) > 0.0 .or. src_struc_closing_duration(i) > 0.0)) then ! - write(logstr,'(a,f0.2,a)')' opening: ', src_struc_opening_duration(i), ' (s)' + write(logstr,'(a22,a,a)') ' opening_duration:', trim(fmt_real(src_struc_opening_duration(i), 2)), ' (s)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.2,a)')' closing: ', src_struc_closing_duration(i), ' (s)' + write(logstr,'(a22,a,a)') ' closing_duration:', trim(fmt_real(src_struc_closing_duration(i), 2)), ' (s)' call write_log(logstr, 0) ! endif diff --git a/source/src/sfincs_urban_drainage.f90 b/source/src/sfincs_urban_drainage.f90 index 0ccac2460..fd4550d3f 100644 --- a/source/src/sfincs_urban_drainage.f90 +++ b/source/src/sfincs_urban_drainage.f90 @@ -628,34 +628,34 @@ subroutine write_urban_drainage_log_summary() write(logstr,'(a,i0)') ' cells_assigned: ', urb_zone_n_cells(iz) call write_log(logstr, 0) ! - write(logstr,'(a,f0.1,a)') ' area: ', urb_zone_area(iz), ' (m2)' + write(logstr,'(a,a,a)') ' area: ', trim(fmt_real(urb_zone_area(iz), 1)), ' (m2)' call write_log(logstr, 0) ! if (urb_zone_type_id(iz) == urb_type_piped_drainage) then ! if (urb_zone_max_outfall_rate(iz) > 0.0) then - write(logstr,'(a,f0.4,a)') ' max_outfall_rate: ', urb_zone_max_outfall_rate(iz), ' (m3/s)' + write(logstr,'(a,a,a)') ' max_outfall_rate: ', trim(fmt_real(urb_zone_max_outfall_rate(iz), 4)), ' (m3/s)' call write_log(logstr, 0) - write(logstr,'(a,f0.2,a)') ' design_precip: ', urb_zone_design_precip(iz), & + write(logstr,'(a,a,a)') ' design_precip: ', trim(fmt_real(urb_zone_design_precip(iz), 2)), & ' (mm/hr, derived from max_outfall_rate)' call write_log(logstr, 0) else - write(logstr,'(a,f0.2,a)') ' design_precip: ', urb_zone_design_precip(iz), ' (mm/hr)' + write(logstr,'(a,a,a)') ' design_precip: ', trim(fmt_real(urb_zone_design_precip(iz), 2)), ' (mm/hr)' call write_log(logstr, 0) endif ! - write(logstr,'(a,f0.4,a)') ' qmax_total: ', urb_zone_qmax_total(iz), ' (m3/s)' + write(logstr,'(a,a,a)') ' qmax_total: ', trim(fmt_real(urb_zone_qmax_total(iz), 4)), ' (m3/s)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a)') ' h_threshold: ', urb_zone_h_threshold(iz), ' (m)' + write(logstr,'(a,a,a)') ' h_threshold: ', trim(fmt_real(urb_zone_h_threshold(iz), 3)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a)') ' dh_design_min: ', urb_zone_dh_design_min(iz), ' (m)' + write(logstr,'(a,a,a)') ' dh_design_min: ', trim(fmt_real(urb_zone_dh_design_min(iz), 3)), ' (m)' call write_log(logstr, 0) ! if (urb_zone_include_outfall(iz)) then - write(logstr,'(a,f0.3,a,f0.3,a)')' outfall: (', urb_zone_outfall_x(iz), ', ', & - urb_zone_outfall_y(iz), ')' + write(logstr,'(a,a,a,a,a)') ' outfall: [', trim(fmt_real(urb_zone_outfall_x(iz), 3)), ', ', & + trim(fmt_real(urb_zone_outfall_y(iz), 3)), ']' call write_log(logstr, 0) ! if (urban_drainage_outfall_index(iz) > 0) then @@ -676,16 +676,16 @@ subroutine write_urban_drainage_log_summary() ! elseif (urb_zone_type_id(iz) == urb_type_injection_well) then ! - write(logstr,'(a,f0.4,a)') ' injection_rate: ', urb_zone_injection_rate(iz), ' (m3/s)' + write(logstr,'(a,a,a)') ' injection_rate: ', trim(fmt_real(urb_zone_injection_rate(iz), 4)), ' (m3/s)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.1,a)') ' maximum_capacity: ', urb_zone_maximum_capacity(iz), ' (m3)' + write(logstr,'(a,a,a)') ' maximum_capacity: ', trim(fmt_real(urb_zone_maximum_capacity(iz), 1)), ' (m3)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.4,a)') ' qmax_total: ', urb_zone_qmax_total(iz), ' (m3/s)' + write(logstr,'(a,a,a)') ' qmax_total: ', trim(fmt_real(urb_zone_qmax_total(iz), 4)), ' (m3/s)' call write_log(logstr, 0) ! - write(logstr,'(a,f0.3,a)') ' h_threshold: ', urb_zone_h_threshold(iz), ' (m)' + write(logstr,'(a,a,a)') ' h_threshold: ', trim(fmt_real(urb_zone_h_threshold(iz), 3)), ' (m)' call write_log(logstr, 0) ! endif @@ -710,8 +710,7 @@ subroutine read_urban_drainage(filename, ierr) ! polygon_file = "zones.tek" ! required ! ! # piped_drainage keys: - ! outfall_x = 950.0 ! required if include_outfall = true - ! outfall_y = 150.0 ! required if include_outfall = true + ! outfall = [950.0, 150.0] ! required if include_outfall = true, [x, y] pair ! design_precip = 20.0 ! required if max_outfall_rate absent, mm/hr ! max_outfall_rate = 6.0 ! alternative to design_precip, m3/s total zone capacity ! ! exactly one of {design_precip, max_outfall_rate} must be given @@ -881,11 +880,34 @@ subroutine read_urban_drainage(filename, ierr) ! if (urb_zone_type_id(i) == urb_type_piped_drainage) then ! - call get_value(tbl_zone, 'outfall_x', r8_tmp, stat=stat) - if (stat == 0) urb_zone_outfall_x(i) = real(r8_tmp, 4) - ! - call get_value(tbl_zone, 'outfall_y', r8_tmp, stat=stat) - if (stat == 0) urb_zone_outfall_y(i) = real(r8_tmp, 4) + block + type(toml_array), pointer :: arr_outfall + integer :: n_out, stat_arr + ! + nullify(arr_outfall) + call get_value(tbl_zone, 'outfall', arr_outfall, requested=.false., stat=stat_arr) + ! + if (associated(arr_outfall)) then + ! + n_out = len(arr_outfall) + ! + if (n_out /= 2) then + write(logstr,'(a,a,a,i0,a)')' Error ! urban_drainage_zone "', trim(urb_zone_name(i)), & + '" key "outfall" must have exactly 2 elements (got ', n_out, ')' + call write_log(logstr, 1) + ierr = 1 + return + endif + ! + call get_value(arr_outfall, 1, r8_tmp, stat=stat_arr) + urb_zone_outfall_x(i) = real(r8_tmp, 4) + ! + call get_value(arr_outfall, 2, r8_tmp, stat=stat_arr) + urb_zone_outfall_y(i) = real(r8_tmp, 4) + ! + endif + ! + end block ! ! Exactly one of design_precip / max_outfall_rate must be given. ! has_key distinguishes "absent" from "present but 0.0". @@ -935,7 +957,7 @@ subroutine read_urban_drainage(filename, ierr) found = (urb_zone_outfall_x(i) /= 0.0 .or. urb_zone_outfall_y(i) /= 0.0) if (.not. found) then write(logstr,'(a,a,a)')' Warning : piped_drainage zone "', trim(urb_zone_name(i)), & - '" has include_outfall = true but outfall_x, outfall_y both 0.0' + '" has include_outfall = true but outfall = [0.0, 0.0]' call write_log(logstr, 0) endif endif From d0a8c3e8b5f29a76472ef32e5e2e4696172388d3 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Mon, 20 Apr 2026 20:43:46 +0200 Subject: [PATCH 49/65] Rename input keyword to output_on_quadtree_mesh Change the input keyword in source/src/sfincs_input.f90 from 'regular_output_on_mesh' to 'output_on_quadtree_mesh' and pass the old name as an alias to get_keyword for backward compatibility. Update the inline comment to clarify that this controls writing quadtree output to the quadtree mesh (only relevant for regular meshed grids). --- source/src/sfincs_input.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 4af25dc94..9e7c4a99f 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -323,7 +323,7 @@ subroutine read_sfincs_input() call get_keyword(500, 'storemaxwind', store_wind_max, .false.) ! store maximum wind speed (requires storemeteo) call get_keyword(500, 'storefw', store_wave_forces, .false.) ! store wave-radiation forces call get_keyword(500, 'storewavdir', store_wave_direction, .false.) ! store wave direction - call get_keyword(500, 'regular_output_on_mesh', use_quadtree_output, .false.) ! write quadtree output on regular m/n mesh + call get_keyword(500, 'output_on_quadtree_mesh', use_quadtree_output, .false., ['regular_output_on_mesh']) ! write quadtree output to quadtree mesh (only relevant for regular meshed grids) call get_keyword(500, 'store_dynamic_bed_level', store_dynamic_bed_level, .false.) ! store time-varying bed level (subgrid) call get_keyword(500, 'snapwave_use_nearest', snapwave_use_nearest, .true.) ! use nearest-neighbour lookup for SnapWave boundary points call get_keyword(500, 'percentage_done', percdoneval, 5) ! progress-reporter interval (% complete) From b775dfec9df9226cf83bce0bc56a9899e1d89776 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Tue, 21 Apr 2026 17:08:28 +0200 Subject: [PATCH 50/65] Refactor source-structure names & logic Rename and reorganize source-structure API and implementation for clarity and correct sign semantics. q_src_struc was renamed to src_struc_q_now and all endpoint/observation identifiers were changed from src_1/src_2/obs_1/obs_2 (and nm_in/nm_out/nm_obs_*) to explicit endpoint/obs names (x_s1/y_s1, x_s2/y_s2, x_o1/y_o1, x_o2/y_o2 and src_struc_nm_s1/_s2/_o1/_o2). Adjusted comments to document sign convention (qq > 0 = flow from endpoint 1 -> endpoint 2) and renamed reduction_depth to pump_reduction_depth. Reworked structure type codes (culvert_simple = 2, culvert = 3, gate = 4) and moved/implemented the gate (culvert-style) solver accordingly. Updated all call sites, OpenACC/OpenMP present/private lists, NetCDF and qdrain output writes, and atomic qsrc updates to use the new names and endpoint mapping. This clarifies intent, fixes naming inconsistencies, and readies the module for further fixes to culvert/gate behaviour. --- source/src/sfincs_ncoutput.F90 | 6 +- source/src/sfincs_openacc.f90 | 8 +- source/src/sfincs_output.f90 | 6 +- source/src/sfincs_src_structures.f90 | 439 ++++++++++++++------------- 4 files changed, 240 insertions(+), 219 deletions(-) diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index d8077049f..2eef25f27 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -3219,7 +3219,7 @@ subroutine ncoutput_update_his(t,nthisout) use sfincs_crosssections use sfincs_runup_gauges use sfincs_snapwave - use sfincs_src_structures, only: nr_src_structures, q_src_struc + use sfincs_src_structures, only: nr_src_structures, src_struc_q_now use sfincs_discharges, only: qtsrc, nr_discharge_points use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_total ! @@ -3515,9 +3515,9 @@ subroutine ncoutput_update_his(t,nthisout) ! if (nr_src_structures>0) then ! - !$acc update host(q_src_struc) + !$acc update host(src_struc_q_now) ! - NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, q_src_struc, (/1, nthisout/))) ! write per-structure discharge + NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, src_struc_q_now, (/1, nthisout/))) ! write per-structure discharge ! endif ! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 9b4531d5b..46b67e8f9 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -32,9 +32,9 @@ subroutine initialize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc qsrc, qtsrc, q_src_struc, nmindsrc, src_struc_nm_in, src_struc_nm_out, src_struc_type, & + !$acc qsrc, qtsrc, src_struc_q_now, nmindsrc, src_struc_nm_s1, src_struc_nm_s2, src_struc_type, & !$acc src_struc_direction, & - !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & + !$acc src_struc_nm_o1, src_struc_nm_o2, & !$acc src_struc_q, src_struc_flow_coef, & !$acc src_struc_width, src_struc_sill_elevation, src_struc_mannings_n, & !$acc src_struc_opening_duration, src_struc_closing_duration, & @@ -79,9 +79,9 @@ subroutine finalize_openacc() !$acc z_index_uv_md, z_index_uv_nd, z_index_uv_mu, z_index_uv_nu, & !$acc uv_index_z_nm, uv_index_z_nmu, uv_index_u_nmd, uv_index_u_nmu, uv_index_u_ndm, uv_index_u_num, & !$acc uv_index_v_ndm, uv_index_v_ndmu, uv_index_v_nm, uv_index_v_nmu, & - !$acc qsrc, qtsrc, q_src_struc, nmindsrc, src_struc_nm_in, src_struc_nm_out, src_struc_type, & + !$acc qsrc, qtsrc, src_struc_q_now, nmindsrc, src_struc_nm_s1, src_struc_nm_s2, src_struc_type, & !$acc src_struc_direction, & - !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & + !$acc src_struc_nm_o1, src_struc_nm_o2, & !$acc src_struc_q, src_struc_flow_coef, & !$acc src_struc_width, src_struc_sill_elevation, src_struc_mannings_n, & !$acc src_struc_opening_duration, src_struc_closing_duration, & diff --git a/source/src/sfincs_output.f90 b/source/src/sfincs_output.f90 index 583c0fa3e..854618ec8 100644 --- a/source/src/sfincs_output.f90 +++ b/source/src/sfincs_output.f90 @@ -602,7 +602,7 @@ subroutine write_his_output(t) ! use sfincs_data use sfincs_crosssections - use sfincs_src_structures, only: nr_src_structures, q_src_struc + use sfincs_src_structures, only: nr_src_structures, src_struc_q_now use sfincs_discharges, only: qtsrc, nr_discharge_points ! implicit none @@ -663,9 +663,9 @@ subroutine write_his_output(t) endif ! if (nr_src_structures>0 .and. store_qdrain) then - !$acc update host(q_src_struc) + !$acc update host(src_struc_q_now) open(unit = 970, file = trim('qdrain.txt'), access='append') - write(970,'(f12.1,10000f9.3)')t,(q_src_struc(iobs), iobs = 1, nr_src_structures) + write(970,'(f12.1,10000f9.3)')t,(src_struc_q_now(iobs), iobs = 1, nr_src_structures) close(970) endif ! diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 20f58721f..5d75401dc 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -3,23 +3,33 @@ module sfincs_src_structures ! Point structures that move water between two grid cells by user-specified ! rules rather than by momentum conservation: ! type 1 - pump (fixed discharge) - ! type 3 - culvert_simple (bidirectional, optional direction filter) - ! type 4 - gate (rule-driven state machine, bidirectional) - ! type 6 - culvert (physics-based pipe flow with entrance / + ! type 2 - culvert_simple (bidirectional, optional direction filter) + ! type 3 - culvert (physics-based pipe flow with entrance / ! friction / exit losses, bidirectional, ! optional direction filter) + ! type 4 - gate (rule-driven state machine, bidirectional) ! ! Legacy TOML alias accepted by the parser: ! "check_valve" -> culvert_simple + direction = "positive" ! + ! Orifice behaviour is not a first-class type; use type = "culvert" + ! with submergence_ratio = 0.0 to reproduce it. + ! ! These used to live in sfincs_discharges.f90 alongside the river point ! discharges read from src/dis/netsrcdis. They have been split out so that ! each module has a single responsibility. ! ! Runtime handoff to the continuity module is via the cell-wise qsrc(np) - ! array (in sfincs_data): this module accumulates qq on intake (src_struc_nm_in) - ! and outfall (src_struc_nm_out) cells. Per-structure signed discharge is also - ! stored in q_src_struc(nr_src_structures) for his output. + ! array (in sfincs_data): this module accumulates qq on endpoint-1 + ! (src_struc_nm_s1) and endpoint-2 (src_struc_nm_s2) cells. Per-structure + ! signed discharge is also stored in src_struc_q_now(nr_src_structures) + ! for his output. + ! + ! Sign convention: a positive qq means flow from nm_s1 to nm_s2. + ! No direction is baked into the endpoint names themselves; for pumps, + ! endpoint 1 (nm_s1) is the intake and endpoint 2 (nm_s2) is the discharge, + ! and the pump logic enforces qq >= 0. All other structure types are + ! bidirectional and the sign of qq carries the flow direction. ! ! Concurrency: qsrc updates use atomic because two structures (or a river ! source and a structure) can land in the same cell. @@ -35,7 +45,7 @@ module sfincs_src_structures ! update_src_structures(t, dt) ! Advances the open/close state machine for rule-driven structures, ! evaluates the per-type flux formula, and accumulates signed - ! discharges into qsrc and q_src_struc. Called from update_continuity + ! discharges into qsrc and src_struc_q_now. Called from update_continuity ! (sfincs_continuity) once per time step, after update_discharges. ! ! read_toml_src_structures(filename, structures, ierr) @@ -83,9 +93,9 @@ module sfincs_src_structures ! Structure type codes ! integer, parameter :: structure_pump = 1 - integer, parameter :: structure_culvert_simple = 3 + integer, parameter :: structure_culvert_simple = 2 + integer, parameter :: structure_culvert = 3 integer, parameter :: structure_gate = 4 - integer, parameter :: structure_culvert = 6 ! ! Direction filter codes (culvert_simple / culvert). Controls which sign ! of discharge is allowed through the structure. Default is "both". @@ -95,10 +105,10 @@ module sfincs_src_structures integer, parameter :: direction_negative = 3 ! ! Pump reduction curve depth (m). Pump discharge is scaled by - ! min(1, h_up/reduction_depth) so the pump cannot pump the intake + ! min(1, h_up/pump_reduction_depth) so the pump cannot pump the intake ! cell dry. Fixed constant, not user-tunable. ! - real*4, parameter :: reduction_depth = 0.1 + real*4, parameter :: pump_reduction_depth = 0.1 ! ! Derived type for the TOML-based src structure input. ! @@ -124,17 +134,17 @@ module sfincs_src_structures ! integer :: direction ! - ! Geometry - src_1/src_2 define the intake/outfall cell pair; - ! obs_1/obs_2 are optional and default to src_1/src_2 in the - ! marshal when the TOML reader did not see the keys (tracked via - ! has_obs_1 / has_obs_2). + ! Geometry - x_s1/y_s1 and x_s2/y_s2 define the two endpoint cell + ! coordinates; x_o1/y_o1 and x_o2/y_o2 are optional observation-point + ! coordinates and default to the endpoint coordinates in the marshal + ! when the TOML reader did not see the keys (tracked via has_o1 / has_o2). ! - real :: src_1_x, src_1_y - real :: src_2_x, src_2_y - real :: obs_1_x, obs_1_y - real :: obs_2_x, obs_2_y - logical :: has_obs_1 - logical :: has_obs_2 + real :: x_s1, y_s1 + real :: x_s2, y_s2 + real :: x_o1, y_o1 + real :: x_o2, y_o2 + logical :: has_o1 + logical :: has_o2 ! ! Parameters ! @@ -146,8 +156,8 @@ module sfincs_src_structures ! closing_duration - time (s) to go from open to fully closed ! flow_coef - culvert_simple / check_valve / culvert flow coefficient ! height - culvert pipe height (m, rectangular cross-section) - ! invert_1 - culvert bed elevation at src_1 end (m) - ! invert_2 - culvert bed elevation at src_2 end (m) + ! invert_1 - culvert bed elevation at endpoint 1 (m) + ! invert_2 - culvert bed elevation at endpoint 2 (m) ! submergence_ratio - culvert submergence threshold h_dn/h_up (-) ! real :: q @@ -206,10 +216,10 @@ module sfincs_src_structures ! Cell mapping ! integer, public :: nr_src_structures - integer*4, dimension(:), allocatable, public :: src_struc_nm_in ! (nr_src_structures) intake (sink) cell indices - integer*4, dimension(:), allocatable, public :: src_struc_nm_out ! (nr_src_structures) outfall (source) cell indices - integer*4, dimension(:), allocatable, public :: src_struc_nm_obs_1 ! (nr_src_structures) obs_1 cell indices (gate rule inputs; defaults to src_1 cell) - integer*4, dimension(:), allocatable, public :: src_struc_nm_obs_2 ! (nr_src_structures) obs_2 cell indices (gate rule inputs; defaults to src_2 cell) + integer*4, dimension(:), allocatable, public :: src_struc_nm_s1 ! (nr_src_structures) endpoint-1 cell indices + integer*4, dimension(:), allocatable, public :: src_struc_nm_s2 ! (nr_src_structures) endpoint-2 cell indices + integer*4, dimension(:), allocatable, public :: src_struc_nm_o1 ! (nr_src_structures) obs-1 cell indices (gate rule inputs; defaults to endpoint-1 cell) + integer*4, dimension(:), allocatable, public :: src_struc_nm_o2 ! (nr_src_structures) obs-2 cell indices (gate rule inputs; defaults to endpoint-2 cell) ! ! Gate transition timer (simulation time at which current status was entered). ! Only meaningful for structure_gate; ignored for other types. @@ -218,10 +228,10 @@ module sfincs_src_structures ! ! Coordinates ! - real*4, dimension(:), allocatable, public :: src_struc_src_1_x, src_struc_src_1_y - real*4, dimension(:), allocatable, public :: src_struc_src_2_x, src_struc_src_2_y - real*4, dimension(:), allocatable, public :: src_struc_obs_1_x, src_struc_obs_1_y - real*4, dimension(:), allocatable, public :: src_struc_obs_2_x, src_struc_obs_2_y + real*4, dimension(:), allocatable, public :: src_struc_x_s1, src_struc_y_s1 + real*4, dimension(:), allocatable, public :: src_struc_x_s2, src_struc_y_s2 + real*4, dimension(:), allocatable, public :: src_struc_x_o1, src_struc_y_o1 + real*4, dimension(:), allocatable, public :: src_struc_x_o2, src_struc_y_o2 ! ! Named parameters ! @@ -236,8 +246,8 @@ module sfincs_src_structures ! Detailed-culvert geometry ! real*4, dimension(:), allocatable, public :: src_struc_height ! culvert pipe height (m) - real*4, dimension(:), allocatable, public :: src_struc_invert_1 ! culvert bed elevation at src_1 end (m) - real*4, dimension(:), allocatable, public :: src_struc_invert_2 ! culvert bed elevation at src_2 end (m) + real*4, dimension(:), allocatable, public :: src_struc_invert_1 ! culvert bed elevation at endpoint 1 (m) + real*4, dimension(:), allocatable, public :: src_struc_invert_2 ! culvert bed elevation at endpoint 2 (m) ! ! Detailed-culvert submergence threshold ! @@ -245,7 +255,7 @@ module sfincs_src_structures ! ! Runtime state ! - real*4, dimension(:), allocatable, public :: q_src_struc ! (nr_src_structures) signed discharge per structure, mirrors the qsrc pattern + real*4, dimension(:), allocatable, public :: src_struc_q_now ! (nr_src_structures) signed discharge this step per structure, mirrors the qsrc pattern ! ! Per-structure rule ids into the registry owned by sfincs_rule_expression. ! A rule_id of 0 means "no rule; never fires". @@ -308,12 +318,12 @@ subroutine initialize_src_structures() ! Cell-index / distance locals ! integer :: istruc, nmq - real*4 :: xsnk_tmp, ysnk_tmp, xsrc_tmp, ysrc_tmp + real*4 :: x_s1_tmp, y_s1_tmp, x_s2_tmp, y_s2_tmp ! ! Gate-status seeding locals ! - integer :: nm1, nm2 - real :: z1, z2 + integer :: nm_o1, nm_o2 + real :: zs_o1, zs_o2 logical :: open_fires, close_fires character(len=16) :: status_str ! @@ -419,11 +429,11 @@ subroutine initialize_src_structures() ! ! Allocate flat arrays to size nr_src_structures and seed defaults. ! - allocate(src_struc_nm_in(nr_src_structures)) - allocate(src_struc_nm_out(nr_src_structures)) - allocate(src_struc_nm_obs_1(nr_src_structures)) - allocate(src_struc_nm_obs_2(nr_src_structures)) - allocate(q_src_struc(nr_src_structures)) + allocate(src_struc_nm_s1(nr_src_structures)) + allocate(src_struc_nm_s2(nr_src_structures)) + allocate(src_struc_nm_o1(nr_src_structures)) + allocate(src_struc_nm_o2(nr_src_structures)) + allocate(src_struc_q_now(nr_src_structures)) allocate(src_struc_type(nr_src_structures)) allocate(src_struc_direction(nr_src_structures)) allocate(src_struc_distance(nr_src_structures)) @@ -431,14 +441,14 @@ subroutine initialize_src_structures() allocate(src_struc_fraction_open(nr_src_structures)) allocate(src_struc_t_state(nr_src_structures)) allocate(src_struc_name(nr_src_structures)) - allocate(src_struc_src_1_x(nr_src_structures)) - allocate(src_struc_src_1_y(nr_src_structures)) - allocate(src_struc_src_2_x(nr_src_structures)) - allocate(src_struc_src_2_y(nr_src_structures)) - allocate(src_struc_obs_1_x(nr_src_structures)) - allocate(src_struc_obs_1_y(nr_src_structures)) - allocate(src_struc_obs_2_x(nr_src_structures)) - allocate(src_struc_obs_2_y(nr_src_structures)) + allocate(src_struc_x_s1(nr_src_structures)) + allocate(src_struc_y_s1(nr_src_structures)) + allocate(src_struc_x_s2(nr_src_structures)) + allocate(src_struc_y_s2(nr_src_structures)) + allocate(src_struc_x_o1(nr_src_structures)) + allocate(src_struc_y_o1(nr_src_structures)) + allocate(src_struc_x_o2(nr_src_structures)) + allocate(src_struc_y_o2(nr_src_structures)) allocate(src_struc_q(nr_src_structures)) allocate(src_struc_flow_coef(nr_src_structures)) allocate(src_struc_width(nr_src_structures)) @@ -460,11 +470,11 @@ subroutine initialize_src_structures() src_struc_rule_open_src = ' ' src_struc_rule_close_src = ' ' ! - src_struc_nm_in = 0 - src_struc_nm_out = 0 - src_struc_nm_obs_1 = 0 - src_struc_nm_obs_2 = 0 - q_src_struc = 0.0 + src_struc_nm_s1 = 0 + src_struc_nm_s2 = 0 + src_struc_nm_o1 = 0 + src_struc_nm_o2 = 0 + src_struc_q_now = 0.0 src_struc_type = 0 src_struc_direction = direction_both src_struc_distance = 0.0 @@ -472,14 +482,14 @@ subroutine initialize_src_structures() src_struc_status = 1 ! 0=closed, 1=open, 2=opening, 3=closing; default open (see above). Rule-driven structures overwrite this in the init-time seeding below. src_struc_t_state = 0.0 src_struc_name = ' ' - src_struc_src_1_x = 0.0 - src_struc_src_1_y = 0.0 - src_struc_src_2_x = 0.0 - src_struc_src_2_y = 0.0 - src_struc_obs_1_x = 0.0 - src_struc_obs_1_y = 0.0 - src_struc_obs_2_x = 0.0 - src_struc_obs_2_y = 0.0 + src_struc_x_s1 = 0.0 + src_struc_y_s1 = 0.0 + src_struc_x_s2 = 0.0 + src_struc_y_s2 = 0.0 + src_struc_x_o1 = 0.0 + src_struc_y_o1 = 0.0 + src_struc_x_o2 = 0.0 + src_struc_y_o2 = 0.0 src_struc_q = 0.0 src_struc_flow_coef = 1.0 src_struc_width = 0.0 @@ -519,36 +529,36 @@ subroutine initialize_src_structures() ! src_struc_status is runtime-only (not on the TOML type); leave it at ! the default of 0 (closed) set above. ! - src_struc_src_1_x(i) = src_structures(i)%src_1_x - src_struc_src_1_y(i) = src_structures(i)%src_1_y - src_struc_src_2_x(i) = src_structures(i)%src_2_x - src_struc_src_2_y(i) = src_structures(i)%src_2_y + src_struc_x_s1(i) = src_structures(i)%x_s1 + src_struc_y_s1(i) = src_structures(i)%y_s1 + src_struc_x_s2(i) = src_structures(i)%x_s2 + src_struc_y_s2(i) = src_structures(i)%y_s2 ! - ! obs_1 / obs_2 default to the corresponding src_* when the TOML - ! reader did not see the key (tracked via has_obs_1 / has_obs_2). + ! obs 1 / obs 2 default to the corresponding endpoint when the TOML + ! reader did not see the key (tracked via has_o1 / has_o2). ! This lets 0.0 remain a legal coordinate value. ! - if (src_structures(i)%has_obs_1) then + if (src_structures(i)%has_o1) then ! - src_struc_obs_1_x(i) = src_structures(i)%obs_1_x - src_struc_obs_1_y(i) = src_structures(i)%obs_1_y + src_struc_x_o1(i) = src_structures(i)%x_o1 + src_struc_y_o1(i) = src_structures(i)%y_o1 ! else ! - src_struc_obs_1_x(i) = src_structures(i)%src_1_x - src_struc_obs_1_y(i) = src_structures(i)%src_1_y + src_struc_x_o1(i) = src_structures(i)%x_s1 + src_struc_y_o1(i) = src_structures(i)%y_s1 ! endif ! - if (src_structures(i)%has_obs_2) then + if (src_structures(i)%has_o2) then ! - src_struc_obs_2_x(i) = src_structures(i)%obs_2_x - src_struc_obs_2_y(i) = src_structures(i)%obs_2_y + src_struc_x_o2(i) = src_structures(i)%x_o2 + src_struc_y_o2(i) = src_structures(i)%y_o2 ! else ! - src_struc_obs_2_x(i) = src_structures(i)%src_2_x - src_struc_obs_2_y(i) = src_structures(i)%src_2_y + src_struc_x_o2(i) = src_structures(i)%x_s2 + src_struc_y_o2(i) = src_structures(i)%y_s2 ! endif ! @@ -615,43 +625,44 @@ subroutine initialize_src_structures() ! deallocate(src_structures) ! - ! Resolve cell-index lookups (src_struc_nm_in / _out / _obs_1 / _obs_2) + ! Resolve cell-index lookups (src_struc_nm_s1 / _s2 / _o1 / _o2) ! and centre-to-centre distance from coordinate pairs. ! do istruc = 1, nr_src_structures ! - nmq = find_quadtree_cell(src_struc_src_1_x(istruc), src_struc_src_1_y(istruc)) - if (nmq > 0) src_struc_nm_in(istruc) = index_sfincs_in_quadtree(nmq) + nmq = find_quadtree_cell(src_struc_x_s1(istruc), src_struc_y_s1(istruc)) + if (nmq > 0) src_struc_nm_s1(istruc) = index_sfincs_in_quadtree(nmq) ! - nmq = find_quadtree_cell(src_struc_src_2_x(istruc), src_struc_src_2_y(istruc)) - if (nmq > 0) src_struc_nm_out(istruc) = index_sfincs_in_quadtree(nmq) + nmq = find_quadtree_cell(src_struc_x_s2(istruc), src_struc_y_s2(istruc)) + if (nmq > 0) src_struc_nm_s2(istruc) = index_sfincs_in_quadtree(nmq) ! ! obs cell indices feed the gate rule evaluator. The marshal has - ! already defaulted obs_*_x/y to src_*_x/y when the TOML reader - ! did not see the keys, so this lookup gives us obs_1 == src_1 - ! and obs_2 == src_2 for those cases without extra branching. + ! already defaulted x_o1/y_o1 and x_o2/y_o2 to the endpoint + ! coordinates when the TOML reader did not see the keys, so this + ! lookup gives us obs-1 == endpoint-1 and obs-2 == endpoint-2 for + ! those cases without extra branching. ! - nmq = find_quadtree_cell(src_struc_obs_1_x(istruc), src_struc_obs_1_y(istruc)) - if (nmq > 0) src_struc_nm_obs_1(istruc) = index_sfincs_in_quadtree(nmq) + nmq = find_quadtree_cell(src_struc_x_o1(istruc), src_struc_y_o1(istruc)) + if (nmq > 0) src_struc_nm_o1(istruc) = index_sfincs_in_quadtree(nmq) ! - nmq = find_quadtree_cell(src_struc_obs_2_x(istruc), src_struc_obs_2_y(istruc)) - if (nmq > 0) src_struc_nm_obs_2(istruc) = index_sfincs_in_quadtree(nmq) + nmq = find_quadtree_cell(src_struc_x_o2(istruc), src_struc_y_o2(istruc)) + if (nmq > 0) src_struc_nm_o2(istruc) = index_sfincs_in_quadtree(nmq) ! - if (src_struc_nm_in(istruc) > 0 .and. src_struc_nm_out(istruc) > 0) then + if (src_struc_nm_s1(istruc) > 0 .and. src_struc_nm_s2(istruc) > 0) then ! - xsnk_tmp = z_xz(src_struc_nm_in(istruc)) - ysnk_tmp = z_yz(src_struc_nm_in(istruc)) - xsrc_tmp = z_xz(src_struc_nm_out(istruc)) - ysrc_tmp = z_yz(src_struc_nm_out(istruc)) - src_struc_distance(istruc) = sqrt( (xsrc_tmp - xsnk_tmp)**2 + (ysrc_tmp - ysnk_tmp)**2 ) + x_s1_tmp = z_xz(src_struc_nm_s1(istruc)) + y_s1_tmp = z_yz(src_struc_nm_s1(istruc)) + x_s2_tmp = z_xz(src_struc_nm_s2(istruc)) + y_s2_tmp = z_yz(src_struc_nm_s2(istruc)) + src_struc_distance(istruc) = sqrt( (x_s2_tmp - x_s1_tmp)**2 + (y_s2_tmp - y_s1_tmp)**2 ) ! endif ! enddo ! - if (any(src_struc_nm_in == 0) .or. any(src_struc_nm_out == 0)) then + if (any(src_struc_nm_s1 == 0) .or. any(src_struc_nm_s2 == 0)) then ! - write(logstr,'(a)') 'Warning ! For some sink/source drainage points no matching active grid cell was found!' + write(logstr,'(a)') 'Warning ! For some source-structure endpoints no matching active grid cell was found!' call write_log(logstr, 0) write(logstr,'(a)') 'Warning ! These points will be skipped, please check your input!' call write_log(logstr, 0) @@ -681,31 +692,31 @@ subroutine initialize_src_structures() ! if (src_struc_rule_open(istruc) <= 0 .and. src_struc_rule_close(istruc) <= 0) cycle ! - nm1 = src_struc_nm_obs_1(istruc) - nm2 = src_struc_nm_obs_2(istruc) + nm_o1 = src_struc_nm_o1(istruc) + nm_o2 = src_struc_nm_o2(istruc) ! - if (nm1 > 0) then + if (nm_o1 > 0) then ! - z1 = real(zs(nm1), 4) + zs_o1 = real(zs(nm_o1), 4) ! else ! - z1 = 0.0 + zs_o1 = 0.0 ! endif ! - if (nm2 > 0) then + if (nm_o2 > 0) then ! - z2 = real(zs(nm2), 4) + zs_o2 = real(zs(nm_o2), 4) ! else ! - z2 = 0.0 + zs_o2 = 0.0 ! endif ! - open_fires = evaluate_rule(src_struc_rule_open(istruc), z1, z2) - close_fires = evaluate_rule(src_struc_rule_close(istruc), z1, z2) + open_fires = evaluate_rule(src_struc_rule_open(istruc), zs_o1, zs_o2) + close_fires = evaluate_rule(src_struc_rule_close(istruc), zs_o1, zs_o2) ! if (open_fires .and. .not. close_fires) then ! @@ -754,8 +765,10 @@ subroutine initialize_src_structures() subroutine update_src_structures(t, dt) ! ! Compute discharges through each drainage structure, accumulate them - ! into qsrc(np) (intake: -qq, outfall: +qq), and store per-structure - ! signed discharge in q_src_struc(nr_src_structures) for his output. + ! into qsrc(np) (endpoint 1: -qq, endpoint 2: +qq), and store + ! per-structure signed discharge in src_struc_q_now(nr_src_structures) + ! for his output. Sign convention: qq > 0 means flow from endpoint 1 + ! to endpoint 2. ! ! Called AFTER update_discharges, which zeros qsrc first. ! @@ -772,8 +785,8 @@ subroutine update_src_structures(t, dt) real*8 :: t real*4 :: dt ! - integer :: istruc, nmin, nmout, nm_o1, nm_o2 - real*4 :: qq, elapsed, z1r, z2r + integer :: istruc, nm_s1, nm_s2, nm_o1, nm_o2 + real*4 :: qq, elapsed, zs_o1, zs_o2 real*4 :: frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha real*4 :: dh, a_eff real*4 :: h_up, h_dn, qq_sign @@ -783,9 +796,9 @@ subroutine update_src_structures(t, dt) ! call timer_start('drainage structures') ! - !$acc parallel loop present( z_volume, zs, zb, qsrc, q_src_struc, & - !$acc src_struc_nm_in, src_struc_nm_out, & - !$acc src_struc_nm_obs_1, src_struc_nm_obs_2, & + !$acc parallel loop present( z_volume, zs, zb, qsrc, src_struc_q_now, & + !$acc src_struc_nm_s1, src_struc_nm_s2, & + !$acc src_struc_nm_o1, src_struc_nm_o2, & !$acc src_struc_type, src_struc_direction, & !$acc src_struc_q, src_struc_flow_coef, & !$acc src_struc_width, src_struc_sill_elevation, & @@ -799,24 +812,24 @@ subroutine update_src_structures(t, dt) !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, & !$acc rule_start, rule_length ) & - !$acc private( nmin, nmout, nm_o1, nm_o2, qq, elapsed, & - !$acc z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & + !$acc private( nm_s1, nm_s2, nm_o1, nm_o2, qq, elapsed, & + !$acc zs_o1, zs_o2, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & !$acc dh, a_eff, & !$acc h_up, h_dn, qq_sign, & !$acc open_fires, close_fires ) !$omp parallel do & - !$omp private( nmin, nmout, nm_o1, nm_o2, qq, elapsed, & - !$omp z1r, z2r, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & + !$omp private( nm_s1, nm_s2, nm_o1, nm_o2, qq, elapsed, & + !$omp zs_o1, zs_o2, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & !$omp dh, a_eff, & !$omp h_up, h_dn, qq_sign, & !$omp open_fires, close_fires ) & !$omp schedule ( static ) do istruc = 1, nr_src_structures ! - nmin = src_struc_nm_in(istruc) - nmout = src_struc_nm_out(istruc) + nm_s1 = src_struc_nm_s1(istruc) + nm_s2 = src_struc_nm_s2(istruc) ! - if (nmin > 0 .and. nmout > 0) then + if (nm_s1 > 0 .and. nm_s2 > 0) then ! ! Open/close rule state machine (any structure type, any status). ! @@ -833,26 +846,26 @@ subroutine update_src_structures(t, dt) ! if (src_struc_rule_open(istruc) > 0 .or. src_struc_rule_close(istruc) > 0) then ! - nm_o1 = src_struc_nm_obs_1(istruc) - nm_o2 = src_struc_nm_obs_2(istruc) + nm_o1 = src_struc_nm_o1(istruc) + nm_o2 = src_struc_nm_o2(istruc) ! if (nm_o1 > 0) then ! - z1r = real(zs(nm_o1), 4) + zs_o1 = real(zs(nm_o1), 4) ! else ! - z1r = 0.0 + zs_o1 = 0.0 ! endif ! if (nm_o2 > 0) then ! - z2r = real(zs(nm_o2), 4) + zs_o2 = real(zs(nm_o2), 4) ! else ! - z2r = 0.0 + zs_o2 = 0.0 ! endif ! @@ -862,7 +875,7 @@ subroutine update_src_structures(t, dt) ! ! closed - look for an open trigger ! - open_fires = evaluate_rule(src_struc_rule_open(istruc), z1r, z2r) + open_fires = evaluate_rule(src_struc_rule_open(istruc), zs_o1, zs_o2) ! if (open_fires) then ! @@ -875,7 +888,7 @@ subroutine update_src_structures(t, dt) ! ! open - look for a close trigger ! - close_fires = evaluate_rule(src_struc_rule_close(istruc), z1r, z2r) + close_fires = evaluate_rule(src_struc_rule_close(istruc), zs_o1, zs_o2) ! if (close_fires) then ! @@ -931,17 +944,22 @@ subroutine update_src_structures(t, dt) select case(src_struc_type(istruc)) ! case(structure_pump) + ! + ! Pump endpoint mapping: endpoint 1 (nm_s1) is the intake, + ! endpoint 2 (nm_s2) is the discharge. The pump enforces + ! qq >= 0 (no reverse flow); the sign convention in the + ! common tail below then sends water from nm_s1 to nm_s2. ! qq = src_struc_q(istruc) ! ! Reduction curve: scale by upstream depth so the pump cannot - ! pump the intake cell dry. reduction_depth is a module-level + ! pump the intake cell dry. pump_reduction_depth is a module-level ! constant (see top of module); not user-tunable. ! ! Turn this off for now. Does not work with subgrid. ! - !h_up = max(real(zs(nmin), 4) - zb(nmin), 0.0) - !qq = qq * min(1.0, h_up / reduction_depth) + !h_up = max(real(zs(nm_s1), 4) - zb(nm_s1), 0.0) + !qq = qq * min(1.0, h_up / pump_reduction_depth) ! case(structure_culvert_simple) ! @@ -950,52 +968,13 @@ subroutine update_src_structures(t, dt) ! in the parser; the direction filter in the common tail ! below restricts the allowed sign when requested. ! - if (zs(nmin) > zs(nmout)) then + if (zs(nm_s1) > zs(nm_s2)) then ! - qq = src_struc_flow_coef(istruc) * sqrt(zs(nmin) - zs(nmout)) + qq = src_struc_flow_coef(istruc) * sqrt(zs(nm_s1) - zs(nm_s2)) ! else ! - qq = -src_struc_flow_coef(istruc) * sqrt(zs(nmout) - zs(nmin)) - ! - endif - ! - case(structure_gate) - ! - ! Bidirectional culvert-style flow. Flow uses the src pair - ! (nmin/nmout), not the obs pair. Bates et al. (2010) - ! inertial formulation, per unit width: - ! q^{n+1} = (q^n - g*h*(dzs/ds)*dt) / - ! (1 + g*n^2*dt*|q^n| / h^{7/3}) - ! with h = max(max(zs_in, zs_out) - zsill, 0). - ! Multiply by width to get the full structure discharge; - ! scaling by fraction_open happens in the common tail. - ! q_src_struc(istruc) holds the previous step's discharge - ! after the full common-tail scaling (width*fraction_open), - ! so unscale by (width*fraction_open) to recover qq0 in - ! per-unit-width form. Sign convention: qq > 0 means flow - ! nmin -> nmout, matching dzds = (zs_out - zs_in)/dist. - ! - frac = src_struc_fraction_open(istruc) - wdt = src_struc_width(istruc) - mng = src_struc_mannings_n(istruc) - zsill = src_struc_sill_elevation(istruc) - dist = src_struc_distance(istruc) - ! - dzds = (real(zs(nmout), 4) - real(zs(nmin), 4)) / dist - hgate = max(max(real(zs(nmin), 4), real(zs(nmout), 4)) - zsill, 0.0) - ! - if (hgate > 0.0 .and. frac > 0.0) then - ! - qq0 = q_src_struc(istruc) / (wdt * max(frac, 0.001)) - qq = (qq0 - g * hgate * dzds * dt) / & - (1.0 + g * mng * mng * dt * abs(qq0) / hgate**(7.0/3.0)) - qq = qq * wdt - qq = src_struc_flow_coef(istruc) * qq - ! - else - ! - qq = 0.0 + qq = -src_struc_flow_coef(istruc) * sqrt(zs(nm_s2) - zs(nm_s1)) ! endif ! @@ -1023,18 +1002,18 @@ subroutine update_src_structures(t, dt) ! zsill = max(src_struc_invert_1(istruc), src_struc_invert_2(istruc)) ! - dh = real(zs(nmin), 4) - real(zs(nmout), 4) + dh = real(zs(nm_s1), 4) - real(zs(nm_s2), 4) ! if (dh >= 0.0) then ! - h_up = max(real(zs(nmin), 4) - zsill, 0.0) - h_dn = max(real(zs(nmout), 4) - zsill, 0.0) + h_up = max(real(zs(nm_s1), 4) - zsill, 0.0) + h_dn = max(real(zs(nm_s2), 4) - zsill, 0.0) qq_sign = 1.0 ! else ! - h_up = max(real(zs(nmout), 4) - zsill, 0.0) - h_dn = max(real(zs(nmin), 4) - zsill, 0.0) + h_up = max(real(zs(nm_s2), 4) - zsill, 0.0) + h_dn = max(real(zs(nm_s1), 4) - zsill, 0.0) qq_sign = -1.0 ! endif @@ -1059,6 +1038,45 @@ subroutine update_src_structures(t, dt) ! endif ! + case(structure_gate) + ! + ! Bidirectional culvert-style flow. Flow uses the src pair + ! (nm_s1/nm_s2), not the obs pair. Bates et al. (2010) + ! inertial formulation, per unit width: + ! q^{n+1} = (q^n - g*h*(dzs/ds)*dt) / + ! (1 + g*n^2*dt*|q^n| / h^{7/3}) + ! with h = max(max(zs_s1, zs_s2) - zsill, 0). + ! Multiply by width to get the full structure discharge; + ! scaling by fraction_open happens in the common tail. + ! src_struc_q_now(istruc) holds the previous step's discharge + ! after the full common-tail scaling (width*fraction_open), + ! so unscale by (width*fraction_open) to recover qq0 in + ! per-unit-width form. Sign convention: qq > 0 means flow + ! nm_s1 -> nm_s2, matching dzds = (zs_s2 - zs_s1)/dist. + ! + frac = src_struc_fraction_open(istruc) + wdt = src_struc_width(istruc) + mng = src_struc_mannings_n(istruc) + zsill = src_struc_sill_elevation(istruc) + dist = src_struc_distance(istruc) + ! + dzds = (real(zs(nm_s2), 4) - real(zs(nm_s1), 4)) / dist + hgate = max(max(real(zs(nm_s1), 4), real(zs(nm_s2), 4)) - zsill, 0.0) + ! + if (hgate > 0.0 .and. frac > 0.0) then + ! + qq0 = src_struc_q_now(istruc) / (wdt * max(frac, 0.001)) + qq = (qq0 - g * hgate * dzds * dt) / & + (1.0 + g * mng * mng * dt * abs(qq0) / hgate**(7.0/3.0)) + qq = qq * wdt + qq = src_struc_flow_coef(istruc) * qq + ! + else + ! + qq = 0.0 + ! + endif + ! end select ! ! Common tail: scale by fraction_open (state-machine output) and @@ -1076,19 +1094,20 @@ subroutine update_src_structures(t, dt) ! the discharge response over roughly N time steps. Typical 1-10. ! alpha = 1.0 / structure_relax - qq = alpha * qq + (1.0 - alpha) * q_src_struc(istruc) + qq = alpha * qq + (1.0 - alpha) * src_struc_q_now(istruc) ! - ! Limit discharge by available volume in the intake / outfall cell. + ! Limit discharge by available volume in the donor cell (endpoint 1 + ! for qq > 0, endpoint 2 for qq < 0). ! if (subgrid) then ! if (qq > 0.0) then ! - qq = min(qq, max(z_volume(nmin), 0.0) / dt) + qq = min(qq, max(z_volume(nm_s1), 0.0) / dt) ! else ! - qq = max(qq, -max(z_volume(nmout), 0.0) / dt) + qq = max(qq, -max(z_volume(nm_s2), 0.0) / dt) ! endif ! @@ -1096,27 +1115,29 @@ subroutine update_src_structures(t, dt) ! if (qq > 0.0) then ! - qq = min(qq, max((zs(nmin) - zb(nmin)) * cell_area(z_flags_iref(nmin)), 0.0) / dt) + qq = min(qq, max((zs(nm_s1) - zb(nm_s1)) * cell_area(z_flags_iref(nm_s1)), 0.0) / dt) ! else ! - qq = max(qq, -max((zs(nmout) - zb(nmout)) * cell_area(z_flags_iref(nmout)), 0.0) / dt) + qq = max(qq, -max((zs(nm_s2) - zb(nm_s2)) * cell_area(z_flags_iref(nm_s2)), 0.0) / dt) ! endif ! endif ! - q_src_struc(istruc) = qq + src_struc_q_now(istruc) = qq ! ! Accumulate into cell-wise qsrc. Atomic guards against multiple - ! structures (or a river and a structure) in the same cell. + ! structures (or a river and a structure) in the same cell. Sign + ! convention qq > 0 means flow nm_s1 -> nm_s2, so qq is subtracted + ! at endpoint 1 and added at endpoint 2. ! !$acc atomic update !$omp atomic - qsrc(nmin) = qsrc(nmin) - qq + qsrc(nm_s1) = qsrc(nm_s1) - qq !$acc atomic update !$omp atomic - qsrc(nmout) = qsrc(nmout) + qq + qsrc(nm_s2) = qsrc(nm_s2) + qq ! endif ! @@ -1312,17 +1333,17 @@ subroutine read_toml_src_structures(filename, structures, ierr) call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) ! - case (structure_gate) + case (structure_culvert) ! call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'width', 'sill_elevation' ], i, ierr) + 'name', 'width', 'height', 'invert_1', 'invert_2' ], i, ierr) call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) ! - case (structure_culvert) + case (structure_gate) ! call check_required(tbl_struct, [ character(len=16) :: & - 'name', 'width', 'height', 'invert_1', 'invert_2' ], i, ierr) + 'name', 'width', 'sill_elevation' ], i, ierr) call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) ! @@ -1340,14 +1361,14 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! presence here so the marshal can distinguish "user gave (0,0)" ! from "user gave nothing". ! - call read_coord_pair(tbl_struct, 'src_1', structures(i)%src_1_x, structures(i)%src_1_y, i, ierr) - call read_coord_pair(tbl_struct, 'src_2', structures(i)%src_2_x, structures(i)%src_2_y, i, ierr) + call read_coord_pair(tbl_struct, 'src_1', structures(i)%x_s1, structures(i)%y_s1, i, ierr) + call read_coord_pair(tbl_struct, 'src_2', structures(i)%x_s2, structures(i)%y_s2, i, ierr) ! - structures(i)%has_obs_1 = tbl_struct%has_key('obs_1') - structures(i)%has_obs_2 = tbl_struct%has_key('obs_2') + structures(i)%has_o1 = tbl_struct%has_key('obs_1') + structures(i)%has_o2 = tbl_struct%has_key('obs_2') ! - call read_coord_pair(tbl_struct, 'obs_1', structures(i)%obs_1_x, structures(i)%obs_1_y, i, ierr) - call read_coord_pair(tbl_struct, 'obs_2', structures(i)%obs_2_x, structures(i)%obs_2_y, i, ierr) + call read_coord_pair(tbl_struct, 'obs_1', structures(i)%x_o1, structures(i)%y_o1, i, ierr) + call read_coord_pair(tbl_struct, 'obs_2', structures(i)%x_o2, structures(i)%y_o2, i, ierr) ! ! Named physical parameters. Defaults are picked to avoid NaN in ! arithmetic and to match the legacy-reader fallbacks. @@ -1767,14 +1788,14 @@ subroutine write_src_structures_log_summary() ! type_str = 'culvert_simple' ! - case (structure_gate) - ! - type_str = 'gate' - ! case (structure_culvert) ! type_str = 'culvert' ! + case (structure_gate) + ! + type_str = 'gate' + ! case default ! type_str = 'unknown' @@ -1790,10 +1811,10 @@ subroutine write_src_structures_log_summary() write(logstr,'(a22,a)') ' type:', trim(type_str) call write_log(logstr, 0) ! - write(logstr,'(a22,a,a,a,a,a)') ' src_1:', '(', trim(fmt_real(src_struc_src_1_x(i), 3)), ', ', trim(fmt_real(src_struc_src_1_y(i), 3)), ')' + write(logstr,'(a22,a,a,a,a,a)') ' src_1:', '(', trim(fmt_real(src_struc_x_s1(i), 3)), ', ', trim(fmt_real(src_struc_y_s1(i), 3)), ')' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a,a,a,a)') ' src_2:', '(', trim(fmt_real(src_struc_src_2_x(i), 3)), ', ', trim(fmt_real(src_struc_src_2_y(i), 3)), ')' + write(logstr,'(a22,a,a,a,a,a)') ' src_2:', '(', trim(fmt_real(src_struc_x_s2(i), 3)), ', ', trim(fmt_real(src_struc_y_s2(i), 3)), ')' call write_log(logstr, 0) ! ! obs coords are meaningful for culvert_simple / gate. @@ -1801,10 +1822,10 @@ subroutine write_src_structures_log_summary() if (src_struc_type(i) == structure_culvert_simple .or. & src_struc_type(i) == structure_gate) then ! - write(logstr,'(a22,a,a,a,a,a)') ' obs_1:', '(', trim(fmt_real(src_struc_obs_1_x(i), 3)), ', ', trim(fmt_real(src_struc_obs_1_y(i), 3)), ')' + write(logstr,'(a22,a,a,a,a,a)') ' obs_1:', '(', trim(fmt_real(src_struc_x_o1(i), 3)), ', ', trim(fmt_real(src_struc_y_o1(i), 3)), ')' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a,a,a,a)') ' obs_2:', '(', trim(fmt_real(src_struc_obs_2_x(i), 3)), ', ', trim(fmt_real(src_struc_obs_2_y(i), 3)), ')' + write(logstr,'(a22,a,a,a,a,a)') ' obs_2:', '(', trim(fmt_real(src_struc_x_o2(i), 3)), ', ', trim(fmt_real(src_struc_y_o2(i), 3)), ')' call write_log(logstr, 0) ! endif From 6b5275932b0f49b4c9d2be2aee919390a2f8dd13 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Tue, 21 Apr 2026 17:33:44 +0200 Subject: [PATCH 51/65] Add comparison ops and whitespace handling Add support for <=, >= and = comparisons (new cmp_* and tok_* constants), update tokenizer to recognize '=' and two-character '<=' / '>=' tokens, and extend evaluator to handle the new comparators. Strip all whitespace (space, tab, LF, CR) from rule source prior to parsing so inputs like 'z1 < 0.5' parse correctly. Simplify grammar to use symbolic '&' and '|' only (textual 'and'/'or' handling removed). Remove the in-module test_rule_expression debugging subroutine and refine comparator-related error messages. --- source/src/sfincs_rule_expression.f90 | 315 ++++++++++---------------- 1 file changed, 117 insertions(+), 198 deletions(-) diff --git a/source/src/sfincs_rule_expression.f90 b/source/src/sfincs_rule_expression.f90 index 41fcac154..8cd92bfc1 100644 --- a/source/src/sfincs_rule_expression.f90 +++ b/source/src/sfincs_rule_expression.f90 @@ -4,11 +4,11 @@ module sfincs_rule_expression ! when to open or close. The grammar is: ! ! expr := or_expr - ! or_expr := and_expr ( ('|' | 'or' ) and_expr )* - ! and_expr := comp ( ('&' | 'and') comp )* + ! or_expr := and_expr ( '|' and_expr )* + ! and_expr := comp ( '&' comp )* ! comp := '(' expr ')' | atom cmp_op number ! atom := 'z1' | 'z2' | 'z2-z1' (case-insensitive) - ! cmp_op := '<' | '>' + ! cmp_op := '<' | '>' | '<=' | '>=' | '=' | '==' ! number := real literal ! ! Precedence: paren > comp > '&' > '|'. Left-associative. @@ -43,7 +43,6 @@ module sfincs_rule_expression ! Public API. ! public :: add_rule, evaluate_rule, finalize_rule_storage - public :: test_rule_expression ! ! --------------------------------------------------------------- ! Opcodes. @@ -62,6 +61,9 @@ module sfincs_rule_expression ! integer, parameter :: cmp_lt = 1 integer, parameter :: cmp_gt = 2 + integer, parameter :: cmp_le = 3 + integer, parameter :: cmp_ge = 4 + integer, parameter :: cmp_eq = 5 ! ! Parser / evaluator capacity limits. ! @@ -122,6 +124,9 @@ subroutine add_rule(src, rule_id, ierr, errmsg) integer :: nops, new_start character(len=256):: local_errmsg ! + character(len=len(src)) :: src_nospace + integer :: ic, ip, jp + ! rule_id = 0 ierr = 0 if (present(errmsg)) errmsg = '' @@ -130,7 +135,26 @@ subroutine add_rule(src, rule_id, ierr, errmsg) ! if (len_trim(src) == 0) return ! - call parse_rule_expression(src, ops_buf, atoms_buf, cmps_buf, thr_buf, & + ! Strip all whitespace (space, tab, LF, CR) so callers can write + ! 'z1 < 0.5' or 'z2 - z1 > 0.05' as freely as 'z1<0.5' / 'z2-z1>0.05'. + ! + jp = 0 + do ip = 1, len(src) + ! + ic = iachar(src(ip:ip)) + ! + if (ic /= iachar(' ') .and. ic /= 9 .and. ic /= 10 .and. ic /= 13) then + ! + jp = jp + 1 + src_nospace(jp:jp) = src(ip:ip) + ! + endif + ! + enddo + ! + if (jp == 0) return + ! + call parse_rule_expression(src_nospace(1:jp), ops_buf, atoms_buf, cmps_buf, thr_buf, & nops, ierr, local_errmsg) ! if (ierr /= 0) then @@ -305,15 +329,33 @@ pure function evaluate_rule(rule_id, z1, z2) result(fired) if (sp >= expr_stack_max) return sp = sp + 1 ! - if (rule_cmp(idx) == cmp_lt) then - ! - stack(sp) = zval < rule_threshold(idx) - ! - else - ! - stack(sp) = zval > rule_threshold(idx) + select case (rule_cmp(idx)) ! - endif + case (cmp_lt) + ! + stack(sp) = zval < rule_threshold(idx) + ! + case (cmp_gt) + ! + stack(sp) = zval > rule_threshold(idx) + ! + case (cmp_le) + ! + stack(sp) = zval <= rule_threshold(idx) + ! + case (cmp_ge) + ! + stack(sp) = zval >= rule_threshold(idx) + ! + case (cmp_eq) + ! + stack(sp) = zval == rule_threshold(idx) + ! + case default + ! + stack(sp) = .false. + ! + end select ! case (op_and) ! @@ -338,143 +380,6 @@ pure function evaluate_rule(rule_id, z1, z2) result(fired) end function ! ! - subroutine test_rule_expression() - ! - ! In-binary sanity check for the rule parser and evaluator. Parses a - ! handful of expressions via add_rule, compares evaluate_rule against - ! a hard-coded truth table, and checks that malformed inputs are - ! rejected without corrupting state. On the first failure, calls - ! error stop with a diagnostic. On success, writes a single pass - ! line to stdout. - ! - ! This is a debugging hook, not a permanent test suite. It is cheap - ! (runs in microseconds) and safe to leave in the module. - ! - implicit none - ! - integer :: id_open, id_close, id_bad - integer :: ierr - character(len=256) :: errmsg - logical :: got - integer :: i - ! - ! Truth-table rows for the two live rules. - ! - real, parameter :: z1_tab(5) = [ 0.3, 0.3, 0.8, 0.8, 1.0 ] - real, parameter :: z2_tab(5) = [ 0.4, 1.6, 0.9, 1.0, 2.5 ] - logical, parameter :: open_tab(5) = [ .true., .false., .true., .true., .false. ] - logical, parameter :: close_tab(5) = [ .false., .false., .false., .false., .true. ] - ! - ! 1) Open rule. - ! - call add_rule('(z1<0.5 | z2-z1>0.05) & z2<1.5', id_open, ierr, errmsg) - ! - if (ierr /= 0 .or. id_open <= 0) then - ! - write(*,'(a,a)') 'rule test: failed to parse open rule: ', trim(errmsg) - error stop "rule test: open rule did not parse" - ! - endif - ! - ! 2) Close rule. - ! - call add_rule('z2>2.0', id_close, ierr, errmsg) - ! - if (ierr /= 0 .or. id_close <= 0) then - ! - write(*,'(a,a)') 'rule test: failed to parse close rule: ', trim(errmsg) - error stop "rule test: close rule did not parse" - ! - endif - ! - ! 3) Empty rule must yield rule_id = 0 without error. - ! - call add_rule('', id_bad, ierr, errmsg) - ! - if (ierr /= 0 .or. id_bad /= 0) then - ! - write(*,'(a,i0,a,i0)') 'rule test: empty src gave id=', id_bad, ' ierr=', ierr - error stop "rule test: empty src must return id 0" - ! - endif - ! - ! 4) evaluate_rule(0, ...) must always be .false. - ! - do i = 1, 5 - ! - if (evaluate_rule(0, z1_tab(i), z2_tab(i))) then - ! - error stop "rule test: evaluate_rule(0,...) returned .true." - ! - endif - ! - enddo - ! - ! 5) Truth-table check. - ! - do i = 1, 5 - ! - got = evaluate_rule(id_open, z1_tab(i), z2_tab(i)) - ! - if (got .neqv. open_tab(i)) then - ! - write(*,'(a,i0,a,2(f6.3,1x),a,l1,a,l1)') & - 'rule test: open row ', i, ' z1=z2=', z1_tab(i), z2_tab(i), & - ' got=', got, ' expected=', open_tab(i) - error stop "rule test: open truth-table mismatch" - ! - endif - ! - got = evaluate_rule(id_close, z1_tab(i), z2_tab(i)) - ! - if (got .neqv. close_tab(i)) then - ! - write(*,'(a,i0,a,2(f6.3,1x),a,l1,a,l1)') & - 'rule test: close row ', i, ' z1=z2=', z1_tab(i), z2_tab(i), & - ' got=', got, ' expected=', close_tab(i) - error stop "rule test: close truth-table mismatch" - ! - endif - ! - enddo - ! - ! 6) Malformed inputs must set ierr /= 0 and return rule_id = 0. - ! - call check_malformed('z3 < 1') - call check_malformed('z1 <= 2') - call check_malformed('z1 < 1 &') - call check_malformed('(z1<1') - ! - write(*,'(a,i0,a,i0,a)') & - 'rule test: PASS (n_rules=', n_rules, ', rule_n_ops=', rule_n_ops, ')' - ! - contains - ! - subroutine check_malformed(bad) - ! - character(len=*), intent(in) :: bad - integer :: id_local, ierr_local - character(len=256) :: errmsg_local - ! - call add_rule(bad, id_local, ierr_local, errmsg_local) - ! - if (ierr_local == 0 .or. id_local /= 0) then - ! - write(*,'(a,a,a)') 'rule test: malformed "', trim(bad), '" was accepted' - error stop "rule test: malformed input not rejected" - ! - endif - ! - end subroutine - ! - end subroutine - ! - ! - ! ------------------------------------------------------------------- - ! Private helpers below. - ! ------------------------------------------------------------------- - ! - ! subroutine grow_rule_storage(min_capacity) ! ! Ensure rule_capacity >= min_capacity. On first growth, allocates to @@ -593,6 +498,9 @@ subroutine parse_rule_expression(src, ops, atoms, cmps, thresholds, nops, ierr, ! 6 = or ! 7 = lt ! 8 = gt + ! 9 = le + ! 10 = ge + ! 11 = eq ! integer :: tok_kind(expr_tokens_max) integer :: tok_atom(expr_tokens_max) @@ -659,6 +567,9 @@ subroutine tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ie integer, parameter :: tok_or = 6 integer, parameter :: tok_lt = 7 integer, parameter :: tok_gt = 8 + integer, parameter :: tok_le = 9 + integer, parameter :: tok_ge = 10 + integer, parameter :: tok_eq = 11 ! integer :: pos, slen, start, kstart, ic, atom_code, iostat_read character(len=:), allocatable :: lower @@ -730,16 +641,49 @@ subroutine tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ie case ('<') ! n_tokens = n_tokens + 1 - tok_kind(n_tokens) = tok_lt tok_pos (n_tokens) = start - pos = pos + 1 + if (pos + 1 <= slen .and. lower(min(pos+1,slen):min(pos+1,slen)) == '=') then + ! + tok_kind(n_tokens) = tok_le + pos = pos + 2 + ! + else + ! + tok_kind(n_tokens) = tok_lt + pos = pos + 1 + ! + endif ! case ('>') ! n_tokens = n_tokens + 1 - tok_kind(n_tokens) = tok_gt tok_pos (n_tokens) = start - pos = pos + 1 + if (pos + 1 <= slen .and. lower(min(pos+1,slen):min(pos+1,slen)) == '=') then + ! + tok_kind(n_tokens) = tok_ge + pos = pos + 2 + ! + else + ! + tok_kind(n_tokens) = tok_gt + pos = pos + 1 + ! + endif + ! + case ('=') + ! + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_eq + tok_pos (n_tokens) = start + if (pos + 1 <= slen .and. lower(min(pos+1,slen):min(pos+1,slen)) == '=') then + ! + pos = pos + 2 + ! + else + ! + pos = pos + 1 + ! + endif ! case default ! @@ -864,9 +808,9 @@ subroutine tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ie ! endif ! - ! Identifiers: z1, z2, z2-z1, and / or. The 'z2-z1' atom contains - ! a '-', which would otherwise be eaten by the number path; we - ! match it as a longest-match-first prefix here. + ! Identifiers: z1, z2, z2-z1. The 'z2-z1' atom contains a '-', + ! which would otherwise be eaten by the number path; we match it + ! as a longest-match-first prefix here. ! kstart = pos ! @@ -920,46 +864,6 @@ subroutine tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ie write(errmsg,'(a,i0)') 'unknown z-identifier at position ', pos return ! - case ('a') - ! - if (pos + 2 <= slen) then - ! - if (lower(pos:pos+2) == 'and') then - ! - n_tokens = n_tokens + 1 - tok_kind(n_tokens) = tok_and - tok_pos (n_tokens) = kstart - pos = pos + 3 - cycle - ! - endif - ! - endif - ! - ierr = 1 - write(errmsg,'(a,i0)') 'unknown identifier beginning with "a" at position ', pos - return - ! - case ('o') - ! - if (pos + 1 <= slen) then - ! - if (lower(pos:pos+1) == 'or') then - ! - n_tokens = n_tokens + 1 - tok_kind(n_tokens) = tok_or - tok_pos (n_tokens) = kstart - pos = pos + 2 - cycle - ! - endif - ! - endif - ! - ierr = 1 - write(errmsg,'(a,i0)') 'unknown identifier beginning with "o" at position ', pos - return - ! case default ! ierr = 1 @@ -1105,6 +1009,9 @@ recursive subroutine parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, integer, parameter :: tok_rparen = 4 integer, parameter :: tok_lt = 7 integer, parameter :: tok_gt = 8 + integer, parameter :: tok_le = 9 + integer, parameter :: tok_ge = 10 + integer, parameter :: tok_eq = 11 ! integer :: atom_code, cmp_code ! @@ -1176,10 +1083,22 @@ recursive subroutine parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ! cmp_code = cmp_gt ! + case (tok_le) + ! + cmp_code = cmp_le + ! + case (tok_ge) + ! + cmp_code = cmp_ge + ! + case (tok_eq) + ! + cmp_code = cmp_eq + ! case default ! ierr = 1 - write(errmsg,'(a,i0)') 'expected "<" or ">" at position ', tok_pos(ip) + write(errmsg,'(a,i0)') 'expected comparator ("<", ">", "<=", ">=", "=") at position ', tok_pos(ip) return ! end select From 9750ff0ab043010b9fb9141d1d8b724ea425d9d6 Mon Sep 17 00:00:00 2001 From: vanasseltk <167875592+vanasseltk@users.noreply.github.com> Date: Wed, 22 Apr 2026 15:51:10 +0200 Subject: [PATCH 52/65] make sure his file is updated correctly --- source/src/sfincs_output.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/source/src/sfincs_output.f90 b/source/src/sfincs_output.f90 index 854618ec8..e1a8a8c3d 100644 --- a/source/src/sfincs_output.f90 +++ b/source/src/sfincs_output.f90 @@ -86,6 +86,7 @@ subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmax ! use sfincs_data use sfincs_timers + use sfincs_src_structures, only: nr_src_structures ! implicit none ! @@ -242,7 +243,7 @@ subroutine write_output(t,write_map,write_his,write_max,write_rst,ntmapout,ntmax ! ! Water level time series ! - if (write_his .and. (nobs>0 .or. nrcrosssections>0 .or. nr_runup_gauges>0)) then + if (write_his .and. (nobs>0 .or. nrcrosssections>0 .or. nr_src_structures>0 .or. nr_runup_gauges>0)) then ! if (outputtype_his == 'net') then ! From ea901ab6c08e7f34ee9c40b57cb123ec85c260e1 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Thu, 23 Apr 2026 06:42:59 +0200 Subject: [PATCH 53/65] Align structure log output formatting Adjust formatting of structure log output to align labels and values for improved readability. Updated many WRITE format descriptors in source/src/sfincs_src_structures.f90 to include a 1x separator and lengthened label strings (e.g. ' name :') so columns line up. Also removed an extra blank line in source/src/sfincs_input.f90. --- source/src/sfincs_input.f90 | 1 - source/src/sfincs_src_structures.f90 | 52 ++++++++++++++-------------- 2 files changed, 26 insertions(+), 27 deletions(-) diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 9e7c4a99f..03ed34732 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -70,7 +70,6 @@ module sfincs_input module procedure get_keyword_logical end interface ! - contains ! !-----------------------------------------------------------------------------------------------------! diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 5d75401dc..ea05dcc41 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -1805,16 +1805,16 @@ subroutine write_src_structures_log_summary() write(logstr,'(a,i0,a)')'Structure ', i, ':' call write_log(logstr, 0) ! - write(logstr,'(a22,a)') ' name:', trim(src_struc_name(i)) + write(logstr,'(a22,1x,a)') ' name :', trim(src_struc_name(i)) call write_log(logstr, 0) ! - write(logstr,'(a22,a)') ' type:', trim(type_str) + write(logstr,'(a22,1x,a)') ' type :', trim(type_str) call write_log(logstr, 0) ! - write(logstr,'(a22,a,a,a,a,a)') ' src_1:', '(', trim(fmt_real(src_struc_x_s1(i), 3)), ', ', trim(fmt_real(src_struc_y_s1(i), 3)), ')' + write(logstr,'(a22,1x,a,a,a,a,a)') ' src_1 :', '(', trim(fmt_real(src_struc_x_s1(i), 3)), ', ', trim(fmt_real(src_struc_y_s1(i), 3)), ')' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a,a,a,a)') ' src_2:', '(', trim(fmt_real(src_struc_x_s2(i), 3)), ', ', trim(fmt_real(src_struc_y_s2(i), 3)), ')' + write(logstr,'(a22,1x,a,a,a,a,a)') ' src_2 :', '(', trim(fmt_real(src_struc_x_s2(i), 3)), ', ', trim(fmt_real(src_struc_y_s2(i), 3)), ')' call write_log(logstr, 0) ! ! obs coords are meaningful for culvert_simple / gate. @@ -1822,24 +1822,24 @@ subroutine write_src_structures_log_summary() if (src_struc_type(i) == structure_culvert_simple .or. & src_struc_type(i) == structure_gate) then ! - write(logstr,'(a22,a,a,a,a,a)') ' obs_1:', '(', trim(fmt_real(src_struc_x_o1(i), 3)), ', ', trim(fmt_real(src_struc_y_o1(i), 3)), ')' + write(logstr,'(a22,1x,a,a,a,a,a)') ' obs_1 :', '(', trim(fmt_real(src_struc_x_o1(i), 3)), ', ', trim(fmt_real(src_struc_y_o1(i), 3)), ')' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a,a,a,a)') ' obs_2:', '(', trim(fmt_real(src_struc_x_o2(i), 3)), ', ', trim(fmt_real(src_struc_y_o2(i), 3)), ')' + write(logstr,'(a22,1x,a,a,a,a,a)') ' obs_2 :', '(', trim(fmt_real(src_struc_x_o2(i), 3)), ', ', trim(fmt_real(src_struc_y_o2(i), 3)), ')' call write_log(logstr, 0) ! endif ! if (src_struc_type(i) == structure_pump) then ! - write(logstr,'(a22,a,a)') ' discharge:', trim(fmt_real(src_struc_q(i), 4)), ' (m3/s)' + write(logstr,'(a22,1x,a,a)') ' discharge :', trim(fmt_real(src_struc_q(i), 4)), ' (m3/s)' call write_log(logstr, 0) ! endif ! if (src_struc_type(i) == structure_culvert_simple) then ! - write(logstr,'(a22,a)') ' flow_coef:', trim(fmt_real(src_struc_flow_coef(i), 4)) + write(logstr,'(a22,1x,a)') ' flow_coef :', trim(fmt_real(src_struc_flow_coef(i), 4)) call write_log(logstr, 0) ! endif @@ -1869,48 +1869,48 @@ subroutine write_src_structures_log_summary() ! end select ! - write(logstr,'(a22,a)') ' direction:', trim(dir_str) + write(logstr,'(a22,1x,a)') ' direction :', trim(dir_str) call write_log(logstr, 0) ! endif ! if (src_struc_type(i) == structure_culvert) then ! - write(logstr,'(a22,a,a)') ' width:', trim(fmt_real(src_struc_width(i), 4)), ' (m)' + write(logstr,'(a22,1x,a,a)') ' width :', trim(fmt_real(src_struc_width(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a)') ' height:', trim(fmt_real(src_struc_height(i), 4)), ' (m)' + write(logstr,'(a22,1x,a,a)') ' height :', trim(fmt_real(src_struc_height(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a)') ' invert_1:', trim(fmt_real(src_struc_invert_1(i), 4)), ' (m)' + write(logstr,'(a22,1x,a,a)') ' invert_1 :', trim(fmt_real(src_struc_invert_1(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a)') ' invert_2:', trim(fmt_real(src_struc_invert_2(i), 4)), ' (m)' + write(logstr,'(a22,1x,a,a)') ' invert_2 :', trim(fmt_real(src_struc_invert_2(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a22,a)') ' flow_coef:', trim(fmt_real(src_struc_flow_coef(i), 4)) + write(logstr,'(a22,1x,a)') ' flow_coef :', trim(fmt_real(src_struc_flow_coef(i), 4)) call write_log(logstr, 0) ! - write(logstr,'(a22,a)') ' submergence_ratio:', trim(fmt_real(src_struc_submergence_ratio(i), 4)) + write(logstr,'(a22,1x,a)') ' submergence_ratio :', trim(fmt_real(src_struc_submergence_ratio(i), 4)) call write_log(logstr, 0) ! endif ! if (src_struc_type(i) == structure_gate) then ! - write(logstr,'(a22,a,a)') ' width:', trim(fmt_real(src_struc_width(i), 4)), ' (m)' + write(logstr,'(a22,1x,a,a)') ' width :', trim(fmt_real(src_struc_width(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a)') ' sill_elevation:', trim(fmt_real(src_struc_sill_elevation(i), 4)), ' (m)' + write(logstr,'(a22,1x,a,a)') ' sill_elevation :', trim(fmt_real(src_struc_sill_elevation(i), 4)), ' (m)' call write_log(logstr, 0) ! - write(logstr,'(a22,a)') ' mannings_n:', trim(fmt_real(src_struc_mannings_n(i), 4)) + write(logstr,'(a22,1x,a)') ' mannings_n :', trim(fmt_real(src_struc_mannings_n(i), 4)) call write_log(logstr, 0) ! - write(logstr,'(a22,a,a)') ' opening_duration:', trim(fmt_real(src_struc_opening_duration(i), 2)), ' (s)' + write(logstr,'(a22,1x,a,a)') ' opening_duration :', trim(fmt_real(src_struc_opening_duration(i), 2)), ' (s)' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a)') ' closing_duration:', trim(fmt_real(src_struc_closing_duration(i), 2)), ' (s)' + write(logstr,'(a22,1x,a,a)') ' closing_duration :', trim(fmt_real(src_struc_closing_duration(i), 2)), ' (s)' call write_log(logstr, 0) ! endif @@ -1919,11 +1919,11 @@ subroutine write_src_structures_log_summary() ! if (len_trim(src_struc_rule_open_src(i)) > 0) then ! - write(logstr,'(a22,a,a,a)') ' rules_open:', '"', trim(src_struc_rule_open_src(i)), '"' + write(logstr,'(a22,1x,a,a,a)') ' rules_open :', '"', trim(src_struc_rule_open_src(i)), '"' ! else ! - write(logstr,'(a22,a)') ' rules_open:', '(set)' + write(logstr,'(a22,1x,a)') ' rules_open :', '(set)' ! endif ! @@ -1935,11 +1935,11 @@ subroutine write_src_structures_log_summary() ! if (len_trim(src_struc_rule_close_src(i)) > 0) then ! - write(logstr,'(a22,a,a,a)') ' rules_close:', '"', trim(src_struc_rule_close_src(i)), '"' + write(logstr,'(a22,1x,a,a,a)') ' rules_close :', '"', trim(src_struc_rule_close_src(i)), '"' ! else ! - write(logstr,'(a22,a)') ' rules_close:', '(set)' + write(logstr,'(a22,1x,a)') ' rules_close :', '(set)' ! endif ! @@ -1956,10 +1956,10 @@ subroutine write_src_structures_log_summary() if ((src_struc_rule_open(i) > 0 .or. src_struc_rule_close(i) > 0) .and. & (src_struc_opening_duration(i) > 0.0 .or. src_struc_closing_duration(i) > 0.0)) then ! - write(logstr,'(a22,a,a)') ' opening_duration:', trim(fmt_real(src_struc_opening_duration(i), 2)), ' (s)' + write(logstr,'(a22,1x,a,a)') ' opening_duration :', trim(fmt_real(src_struc_opening_duration(i), 2)), ' (s)' call write_log(logstr, 0) ! - write(logstr,'(a22,a,a)') ' closing_duration:', trim(fmt_real(src_struc_closing_duration(i), 2)), ' (s)' + write(logstr,'(a22,1x,a,a)') ' closing_duration :', trim(fmt_real(src_struc_closing_duration(i), 2)), ' (s)' call write_log(logstr, 0) ! endif From 642b1fcc37eefaf4d3bc0785f343234a207f7676 Mon Sep 17 00:00:00 2001 From: vanasseltk <167875592+vanasseltk@users.noreply.github.com> Date: Tue, 28 Apr 2026 13:28:35 +0200 Subject: [PATCH 54/65] Dike breaching module in urban drainage --- source/sfincs/sfincs.vfproj.asselt.user | 8 + .../sfincs_lib/sfincs_lib.vfproj.asselt.user | 8 + source/src/sfincs_data.f90 | 1 + source/src/sfincs_log.f90 | 6 + source/src/sfincs_ncoutput.F90 | 19 +- source/src/sfincs_openacc.f90 | 8 +- source/src/sfincs_src_structures.f90 | 208 +++++++++++++++++- 7 files changed, 250 insertions(+), 8 deletions(-) create mode 100644 source/sfincs/sfincs.vfproj.asselt.user create mode 100644 source/sfincs_lib/sfincs_lib.vfproj.asselt.user diff --git a/source/sfincs/sfincs.vfproj.asselt.user b/source/sfincs/sfincs.vfproj.asselt.user new file mode 100644 index 000000000..7910296a3 --- /dev/null +++ b/source/sfincs/sfincs.vfproj.asselt.user @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/source/sfincs_lib/sfincs_lib.vfproj.asselt.user b/source/sfincs_lib/sfincs_lib.vfproj.asselt.user new file mode 100644 index 000000000..3bfb867c8 --- /dev/null +++ b/source/sfincs_lib/sfincs_lib.vfproj.asselt.user @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 82ed79cf4..aea300c9f 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -214,6 +214,7 @@ module sfincs_data logical :: infiltration logical :: discharges logical :: drainage_structures + logical :: dike_breaching logical :: urban_drainage logical :: store_urban_drainage_discharge logical :: store_cumulative_urban_drainage diff --git a/source/src/sfincs_log.f90 b/source/src/sfincs_log.f90 index 867feb652..c79d35565 100644 --- a/source/src/sfincs_log.f90 +++ b/source/src/sfincs_log.f90 @@ -287,6 +287,12 @@ subroutine write_processes_log() call write_log('Drainage structures : no', 1) endif ! + if (dike_breaching) then + call write_log('Dike breaching : yes', 1) + else + call write_log('Dike breaching : no', 1) + endif + ! if (urban_drainage) then call write_log('Urban drainage : yes', 1) else diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 2eef25f27..1110d887d 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -50,7 +50,7 @@ module sfincs_ncoutput integer :: crosssection_name_varid integer :: structure_height_varid, structure_x_varid, structure_y_varid integer :: thindam_x_varid, thindam_y_varid - integer :: drain_varid, drain_name_varid + integer :: drain_varid, drain_name_varid, breach_width_varid integer :: river_varid, river_name_varid integer :: urbdrain_varid, urbdrain_name_varid integer :: zb_varid @@ -1691,7 +1691,7 @@ subroutine ncoutput_his_init() use sfincs_date use sfincs_data use sfincs_structures - use sfincs_src_structures, only: nr_src_structures, src_struc_name + use sfincs_src_structures, only: nr_src_structures, src_struc_name, src_struc_type, structure_dike_breach use sfincs_discharges, only: src_name, nr_discharge_points use sfincs_urban_drainage, only: nr_urban_drainage_zones, urb_zone_name ! @@ -2175,6 +2175,14 @@ subroutine ncoutput_his_init() NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'long_name', 'discharge through drainage structure')) NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'coordinates', 'drainage_name')) ! + if (any(src_struc_type == structure_dike_breach)) then + NF90(nf90_def_var(his_file%ncid, 'breach_width', NF90_FLOAT, (/his_file%drain_dimid, his_file%time_dimid/), his_file%breach_width_varid)) + NF90(nf90_put_att(his_file%ncid, his_file%breach_width_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%breach_width_varid, 'units', 'm')) + NF90(nf90_put_att(his_file%ncid, his_file%breach_width_varid, 'long_name', 'dike breach width')) + NF90(nf90_put_att(his_file%ncid, his_file%breach_width_varid, 'coordinates', 'drainage_name')) + endif + ! endif ! if (nr_discharge_points>0 .and. store_river_discharge) then @@ -3219,7 +3227,7 @@ subroutine ncoutput_update_his(t,nthisout) use sfincs_crosssections use sfincs_runup_gauges use sfincs_snapwave - use sfincs_src_structures, only: nr_src_structures, src_struc_q_now + use sfincs_src_structures, only: nr_src_structures, src_struc_q_now, src_struc_breach_width, src_struc_type, structure_dike_breach use sfincs_discharges, only: qtsrc, nr_discharge_points use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_total ! @@ -3519,6 +3527,11 @@ subroutine ncoutput_update_his(t,nthisout) ! NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, src_struc_q_now, (/1, nthisout/))) ! write per-structure discharge ! + if (any(src_struc_type == structure_dike_breach)) then + !$acc update host(src_struc_breach_width) + NF90(nf90_put_var(his_file%ncid, his_file%breach_width_varid, src_struc_breach_width, (/1, nthisout/))) ! write breach width + endif + ! endif ! if (nr_discharge_points>0 .and. store_river_discharge) then diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 46b67e8f9..2a60d9724 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -41,6 +41,9 @@ subroutine initialize_openacc() !$acc src_struc_height, & !$acc src_struc_invert_1, src_struc_invert_2, & !$acc src_struc_submergence_ratio, & + !$acc src_struc_z_crest, src_struc_t_breach, src_struc_z_min, & + !$acc src_struc_B0, src_struc_t0, src_struc_dike_core, & + !$acc src_struc_breach_width, src_struc_breach_level, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, src_struc_t_state, & !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & @@ -88,6 +91,9 @@ subroutine finalize_openacc() !$acc src_struc_height, & !$acc src_struc_invert_1, src_struc_invert_2, & !$acc src_struc_submergence_ratio, & + !$acc src_struc_z_crest, src_struc_t_breach, src_struc_z_min, & + !$acc src_struc_B0, src_struc_t0, src_struc_dike_core, & + !$acc src_struc_breach_width, src_struc_breach_level, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, src_struc_t_state, & !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & @@ -95,7 +101,7 @@ subroutine finalize_openacc() !$acc structure_uv_index, structure_parameters, structure_type, structure_length, & !$acc fwuv, & !$acc tauwu, tauwv, tauwu0, tauwv0, tauwu1, tauwv1, & - !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & + !$acc windu, windv, windu0, windv0, windu1, windv1, windmax, & !$acc patm, patm0, patm1, patmb, nmindbnd, & !$acc prcp, prcp0, prcp1, cumprcp, qext, & !$acc dxminv, dxrinv, dyrinv, dxm2inv, dxr2inv, dyr2inv, dxrinvc, dxm, dxrm, dyrm, cell_area_m2, cell_area, & diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 5d75401dc..a17f85f89 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -96,6 +96,7 @@ module sfincs_src_structures integer, parameter :: structure_culvert_simple = 2 integer, parameter :: structure_culvert = 3 integer, parameter :: structure_gate = 4 + integer, parameter :: structure_dike_breach = 5 ! ! Direction filter codes (culvert_simple / culvert). Controls which sign ! of discharge is allowed through the structure. Default is "both". @@ -175,6 +176,15 @@ module sfincs_src_structures real :: invert_2 real :: submergence_ratio ! + ! Dike breach parameters (structure_dike_breach only) + ! + real :: z_crest ! initial crest elevation (m) + real :: t_breach ! breach start time (s since t=0) + real :: z_min ! minimum breach level (m) + real :: B0 ! initial breach width at start of phase 2 (m) + real :: t0 ! duration of phase 1: crest lowering (s) + integer :: dike_core ! core material: 1=sand, 2=clay + ! ! Gate control rule expressions (raw strings; parsed by marshal). ! Either or both may be unallocated, meaning "no trigger for this action". ! @@ -253,6 +263,20 @@ module sfincs_src_structures ! real*4, dimension(:), allocatable, public :: src_struc_submergence_ratio ! culvert submergence threshold h_dn/h_up (-) ! + ! Dike breach parameters + ! + real*4, dimension(:), allocatable, public :: src_struc_z_crest ! initial crest elevation (m) + real*4, dimension(:), allocatable, public :: src_struc_t_breach ! breach start time (s) + real*4, dimension(:), allocatable, public :: src_struc_z_min ! minimum breach level (m) + real*4, dimension(:), allocatable, public :: src_struc_B0 ! initial breach width (m) + real*4, dimension(:), allocatable, public :: src_struc_t0 ! phase-1 duration (s) + integer, dimension(:), allocatable, public :: src_struc_dike_core ! 1=sand, 2=clay + ! + ! Dike breach runtime state + ! + real*4, dimension(:), allocatable, public :: src_struc_breach_width ! current breach width (m) + real*4, dimension(:), allocatable, public :: src_struc_breach_level ! current breach crest level (m) + ! ! Runtime state ! real*4, dimension(:), allocatable, public :: src_struc_q_now ! (nr_src_structures) signed discharge this step per structure, mirrors the qsrc pattern @@ -460,6 +484,14 @@ subroutine initialize_src_structures() allocate(src_struc_invert_1(nr_src_structures)) allocate(src_struc_invert_2(nr_src_structures)) allocate(src_struc_submergence_ratio(nr_src_structures)) + allocate(src_struc_z_crest(nr_src_structures)) + allocate(src_struc_t_breach(nr_src_structures)) + allocate(src_struc_z_min(nr_src_structures)) + allocate(src_struc_B0(nr_src_structures)) + allocate(src_struc_t0(nr_src_structures)) + allocate(src_struc_dike_core(nr_src_structures)) + allocate(src_struc_breach_width(nr_src_structures)) + allocate(src_struc_breach_level(nr_src_structures)) allocate(src_struc_rule_open(nr_src_structures)) allocate(src_struc_rule_close(nr_src_structures)) allocate(src_struc_rule_open_src(nr_src_structures)) @@ -501,6 +533,14 @@ subroutine initialize_src_structures() src_struc_invert_1 = 0.0 src_struc_invert_2 = 0.0 src_struc_submergence_ratio = 0.667 + src_struc_z_crest = 0.0 + src_struc_t_breach = 0.0 + src_struc_z_min = 0.0 + src_struc_B0 = 0.0 + src_struc_t0 = 0.0 + src_struc_dike_core = 1 + src_struc_breach_width = 0.0 + src_struc_breach_level = 0.0 ! ! Copy scalar / coord / string / parameter fields from src_structures(:) ! into the flat arrays, and parse rule source strings via add_rule. @@ -574,6 +614,17 @@ subroutine initialize_src_structures() src_struc_invert_2(i) = src_structures(i)%invert_2 src_struc_submergence_ratio(i) = src_structures(i)%submergence_ratio ! + if (src_structures(i)%structure_type == structure_dike_breach) then + src_struc_z_crest(i) = src_structures(i)%z_crest + src_struc_t_breach(i) = src_structures(i)%t_breach + src_struc_z_min(i) = src_structures(i)%z_min + src_struc_B0(i) = src_structures(i)%B0 + src_struc_t0(i) = src_structures(i)%t0 + src_struc_dike_core(i) = src_structures(i)%dike_core + src_struc_breach_level(i) = src_structures(i)%z_crest ! starts at crest + src_struc_breach_width(i) = 0.0 + endif + ! ! Parse rule expressions. Missing / empty strings leave the ! rule_id at 0, which the evaluator interprets as "never fires". ! Stash the source string for the init-time log summary. @@ -669,6 +720,8 @@ subroutine initialize_src_structures() ! endif ! + dike_breaching = any(src_struc_type == structure_dike_breach) + ! ! Write the per-structure descriptive block to the log file. ! Emitted before the gate-status seeding so the per-gate init status ! lines trail the structure block they annotate. @@ -792,6 +845,9 @@ subroutine update_src_structures(t, dt) real*4 :: h_up, h_dn, qq_sign logical :: open_fires, close_fires ! + real*4 :: z_breach, B_breach, z_crest_br, z_min_br, t_br, t0_br + real*4 :: f1, f2, uc_mat, t_phase1_br, tau_hr, dt_hr, denom, dBdt_br + ! if (nr_src_structures <= 0) return ! call timer_start('drainage structures') @@ -807,6 +863,9 @@ subroutine update_src_structures(t, dt) !$acc src_struc_height, & !$acc src_struc_invert_1, src_struc_invert_2, & !$acc src_struc_submergence_ratio, & + !$acc src_struc_z_crest, src_struc_t_breach, src_struc_z_min, & + !$acc src_struc_B0, src_struc_t0, src_struc_dike_core, & + !$acc src_struc_breach_width, src_struc_breach_level, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, & !$acc src_struc_t_state, & !$acc src_struc_rule_open, src_struc_rule_close, & @@ -816,13 +875,17 @@ subroutine update_src_structures(t, dt) !$acc zs_o1, zs_o2, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & !$acc dh, a_eff, & !$acc h_up, h_dn, qq_sign, & - !$acc open_fires, close_fires ) + !$acc open_fires, close_fires, & + !$acc z_breach, B_breach, z_crest_br, z_min_br, t_br, t0_br, & + !$acc f1, f2, uc_mat, t_phase1_br, tau_hr, dt_hr, denom, dBdt_br ) !$omp parallel do & !$omp private( nm_s1, nm_s2, nm_o1, nm_o2, qq, elapsed, & !$omp zs_o1, zs_o2, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & !$omp dh, a_eff, & !$omp h_up, h_dn, qq_sign, & - !$omp open_fires, close_fires ) & + !$omp open_fires, close_fires, & + !$omp z_breach, B_breach, z_crest_br, z_min_br, t_br, t0_br, & + !$omp f1, f2, uc_mat, t_phase1_br, tau_hr, dt_hr, denom, dBdt_br ) & !$omp schedule ( static ) do istruc = 1, nr_src_structures ! @@ -1077,6 +1140,92 @@ subroutine update_src_structures(t, dt) ! endif ! + case(structure_dike_breach) + ! + ! Verheij-Knaap (2003): two-phase dike breach. + ! Water levels are read from the obs pair (obs_1 = inside / + ! high-head side; obs_2 = outside / low-head side), which + ! default to the src pair when not user-specified. + ! Flow direction and submergence follow the same pattern + ! as structure_culvert (h_up / h_dn / src_struc_submergence_ratio). + ! + nm_o1 = src_struc_nm_o1(istruc) + nm_o2 = src_struc_nm_o2(istruc) + ! + z_crest_br = src_struc_z_crest(istruc) + z_min_br = src_struc_z_min(istruc) + t_br = src_struc_t_breach(istruc) + t0_br = src_struc_t0(istruc) + t_phase1_br = t_br + t0_br + ! + B_breach = src_struc_breach_width(istruc) + z_breach = src_struc_breach_level(istruc) + ! + if (src_struc_dike_core(istruc) == 1) then + f1 = 1.3; f2 = 0.04; uc_mat = 0.2 ! sand + else + f1 = 1.3; f2 = 0.04; uc_mat = 0.5 ! clay + endif + ! + ! --- Breach geometry update --- + ! + if (real(t, 4) >= t_br) then + ! + if (real(t, 4) < t_phase1_br) then + ! + ! Phase 1: crest lowers linearly to z_min over t0; width = B0 + ! + z_breach = z_crest_br - (z_crest_br - z_min_br) * & + (real(t, 4) - t_br) / t0_br + B_breach = src_struc_B0(istruc) + ! + else + ! + ! Phase 2: crest at z_min, breach widens via Verheij formula. + ! Driving head H = upstream head above z_min minus downstream. + ! + z_breach = z_min_br + h_up = max(max(real(zs(nm_o1),4), real(zs(nm_o2),4)) - z_min_br, 0.0) + h_dn = max(min(real(zs(nm_o1),4), real(zs(nm_o2),4)) - z_min_br, 0.0) + dh = max(h_up - h_dn, 0.0) + tau_hr = (real(t, 4) - t_phase1_br) / 3600.0 + dt_hr = dt / 3600.0 + denom = max(1.0 + (f2 * g / uc_mat) * tau_hr, 1.0e-12) + dBdt_br = (f1 * f2 / log(10.0)) * (g * dh)**1.5 / & + (uc_mat * uc_mat * denom) + B_breach = B_breach + max(dBdt_br, 0.0) * dt_hr + ! + endif + ! + else + z_breach = z_crest_br + B_breach = 0.0 + endif + ! + src_struc_breach_level(istruc) = z_breach + src_struc_breach_width(istruc) = B_breach + ! + ! --- Discharge through breach (culvert-style, obs-point WLs) --- + ! + dh = real(zs(nm_o1), 4) - real(zs(nm_o2), 4) + if (dh >= 0.0) then + h_up = max(real(zs(nm_o1), 4) - z_breach, 0.0) + h_dn = max(real(zs(nm_o2), 4) - z_breach, 0.0) + qq_sign = 1.0 + else + h_up = max(real(zs(nm_o2), 4) - z_breach, 0.0) + h_dn = max(real(zs(nm_o1), 4) - z_breach, 0.0) + qq_sign = -1.0 + endif + ! + if (h_up <= 0.0 .or. B_breach <= 0.0) then + qq = 0.0 + elseif (h_dn / h_up >= src_struc_submergence_ratio(istruc)) then + qq = qq_sign * B_breach * h_up * sqrt(2.0 * g * abs(dh)) + else + qq = qq_sign * 1.71 * B_breach * sqrt(g) * h_up**1.5 + endif + ! end select ! ! Common tail: scale by fraction_open (state-machine output) and @@ -1347,6 +1496,13 @@ subroutine read_toml_src_structures(filename, structures, ierr) call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) ! + case (structure_dike_breach) + ! + call check_required(tbl_struct, [ character(len=16) :: & + 'name', 'z_crest', 't_breach', 'z_min', 'B0', 't0' ], i, ierr) + call check_required_coord_pair(tbl_struct, 'src_1', i, ierr) + call check_required_coord_pair(tbl_struct, 'src_2', i, ierr) + ! end select ! if (ierr /= 0) then @@ -1421,6 +1577,15 @@ subroutine read_toml_src_structures(filename, structures, ierr) call get_value(tbl_struct, 'invert_2', structures(i)%invert_2, 0.0, stat=stat) call get_value(tbl_struct, 'submergence_ratio', structures(i)%submergence_ratio, 0.667, stat=stat) ! + ! Dike breach parameters (ignored for other types) + ! + call get_value(tbl_struct, 'z_crest', structures(i)%z_crest, 0.0, stat=stat) + call get_value(tbl_struct, 't_breach', structures(i)%t_breach, 0.0, stat=stat) + call get_value(tbl_struct, 'z_min', structures(i)%z_min, 0.0, stat=stat) + call get_value(tbl_struct, 'B0', structures(i)%B0, 0.0, stat=stat) + call get_value(tbl_struct, 't0', structures(i)%t0, 0.0, stat=stat) + call get_value(tbl_struct, 'dike_core', structures(i)%dike_core, 1, stat=stat) + ! ! Optional direction filter (culvert_simple / culvert). Default is ! direction_both. Unknown strings are a hard error. ! @@ -1666,6 +1831,10 @@ subroutine parse_structure_type(str, code, ierr) ! code = structure_culvert ! + case ('dike_breach') + ! + code = structure_dike_breach + ! case default ! ierr = 1 @@ -1796,6 +1965,10 @@ subroutine write_src_structures_log_summary() ! type_str = 'gate' ! + case (structure_dike_breach) + ! + type_str = 'dike_breach' + ! case default ! type_str = 'unknown' @@ -1817,10 +1990,11 @@ subroutine write_src_structures_log_summary() write(logstr,'(a22,a,a,a,a,a)') ' src_2:', '(', trim(fmt_real(src_struc_x_s2(i), 3)), ', ', trim(fmt_real(src_struc_y_s2(i), 3)), ')' call write_log(logstr, 0) ! - ! obs coords are meaningful for culvert_simple / gate. + ! obs coords are meaningful for culvert_simple / gate / dike_breach. ! if (src_struc_type(i) == structure_culvert_simple .or. & - src_struc_type(i) == structure_gate) then + src_struc_type(i) == structure_gate .or. & + src_struc_type(i) == structure_dike_breach) then ! write(logstr,'(a22,a,a,a,a,a)') ' obs_1:', '(', trim(fmt_real(src_struc_x_o1(i), 3)), ', ', trim(fmt_real(src_struc_y_o1(i), 3)), ')' call write_log(logstr, 0) @@ -1915,6 +2089,32 @@ subroutine write_src_structures_log_summary() ! endif ! + if (src_struc_type(i) == structure_dike_breach) then + ! + write(logstr,'(a22,a,a)') ' z_crest:', trim(fmt_real(src_struc_z_crest(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,a,a)') ' z_min:', trim(fmt_real(src_struc_z_min(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,a,a)') ' t_breach:', trim(fmt_real(src_struc_t_breach(i), 2)), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,a,a)') ' t0:', trim(fmt_real(src_struc_t0(i), 2)), ' (s)' + call write_log(logstr, 0) + ! + write(logstr,'(a22,a,a)') ' B0:', trim(fmt_real(src_struc_B0(i), 4)), ' (m)' + call write_log(logstr, 0) + ! + if (src_struc_dike_core(i) == 1) then + write(logstr,'(a22,a)') ' dike_core:', 'sand (1)' + else + write(logstr,'(a22,a)') ' dike_core:', 'clay (2)' + endif + call write_log(logstr, 0) + ! + endif + ! if (src_struc_rule_open(i) > 0) then ! if (len_trim(src_struc_rule_open_src(i)) > 0) then From a87a9346f79feddc592f334150f34c03c78fa256 Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Wed, 29 Apr 2026 13:55:11 +0200 Subject: [PATCH 55/65] Support external dzbext and dynamic zb output Add support for an externally-supplied delta bed-level array (dzbext) and optional time-varying bed level output. Changes include: - Introduce logical use_dzbext and allocatable target dzbext in sfincs_data, and deallocate dzbext on shutdown. - Expose dzbext through the BMI getters (shape/type/rank) and lazily allocate/initialize dzbext when the BMI flag is enabled. - Replace the old update_zbuv binding with a BMI-facing bmi_update_bed_level (bound as update_bed_level) that calls a new update_bed_level routine. - Implement update_bed_level to apply dzbext to cell-centre or subgrid bed arrays and rebuild uv-derived quantities (zbuvmx), with separate logic for subgrid and non-subgrid modes. - Add support in NetCDF output to define zb either with or without a time dimension when store_dynamic_bed_level is enabled, and adjust writes so static writes are skipped when the variable is time-varying; per-step writer and map outputs now use subgrid_z_zmin for subgrid runs when writing dynamic bed level. Also includes minor whitespace/cleanup changes. These changes enable external drivers (via BMI) to modify bed level increments and optionally record time-varying bed topography in output files. --- source/src/sfincs.f90 | 3 +- source/src/sfincs_bmi.f90 | 41 +++++++++--- source/src/sfincs_data.f90 | 3 + source/src/sfincs_domain.f90 | 80 ++++++++++++++++++++--- source/src/sfincs_ncoutput.F90 | 115 ++++++++++++++++++++++++--------- 5 files changed, 193 insertions(+), 49 deletions(-) diff --git a/source/src/sfincs.f90 b/source/src/sfincs.f90 index 38fe30bb2..bab831811 100644 --- a/source/src/sfincs.f90 +++ b/source/src/sfincs.f90 @@ -15,8 +15,9 @@ program sfincs ! ! Set BMI flags to false ! - bmi = .false. + bmi = .false. use_qext = .false. + use_dzbext = .false. ! ierr = sfincs_initialize() ! diff --git a/source/src/sfincs_bmi.f90 b/source/src/sfincs_bmi.f90 index 388bcefa2..3ab7e83f3 100644 --- a/source/src/sfincs_bmi.f90 +++ b/source/src/sfincs_bmi.f90 @@ -23,7 +23,7 @@ module sfincs_bmi public :: get_end_time public :: get_time_step public :: get_current_time - public :: update_zbuv + public :: bmi_update_bed_level public :: update_apparent_roughness public :: get_sfincs_cell_index public :: get_sfincs_cell_indices @@ -119,6 +119,8 @@ function get_value_ptr(c_var_name, c_data) result(ierr) & c_data = c_loc(subgrid_z_zmin) case("qext") c_data = c_loc(qext) + case("dzbext") + c_data = c_loc(dzbext) case("uorb") c_data = c_loc(uorb) case default @@ -150,6 +152,8 @@ function get_var_shape(c_var_name, var_shape) result(ierr) & var_shape(1) = size(z_index_z_n) case("qext") var_shape(1) = size(qext) + case("dzbext") + var_shape(1) = size(dzbext) case default ierr = -1 end select @@ -170,7 +174,7 @@ function get_var_type(c_var_name, c_type) result(ierr) & var_name = char_array_to_string(c_var_name, strlen(c_var_name, BMI_LENVARADDRESS)) select case(var_name) - case("z_xz", "z_yz", "zb", "subgrid_z_zmin", "qext", "uorb") + case("z_xz", "z_yz", "zb", "subgrid_z_zmin", "qext", "dzbext", "uorb") type_name = "float" case("zs") type_name = "double" @@ -198,7 +202,7 @@ function get_var_rank(c_var_name, rank) result(ierr) & var_name = char_array_to_string(c_var_name, strlen(c_var_name, BMI_LENVARADDRESS)) select case(var_name) - case("z_xz", "z_yz", "zs", "zb", "subgrid_z_zmin", "qext", "uorb") + case("z_xz", "z_yz", "zs", "zb", "subgrid_z_zmin", "qext", "dzbext", "uorb") rank = 1 case default ierr = -1 @@ -227,7 +231,23 @@ function set_logical(c_flag_name, ival) result(ierr) bind(C, name="set_logical") select case(flag_name) case("qext") use_qext = bval - !write(*,*)'use_qext = ', use_qext + !write(*,*)'use_qext = ', use_qext + case("dzbext") + ! + ! Lazily allocate the external delta-bed-level array on first enable. + ! Once allocated we keep it around; toggling the flag off later just + ! disables the update path without freeing memory (same pattern as + ! qext is handled elsewhere). + ! + if (bval .and. .not. allocated(dzbext)) then + ! + allocate(dzbext(np)) + dzbext = 0.0 + ! + endif + ! + use_dzbext = bval + ! case default ierr = -1 end select @@ -274,14 +294,15 @@ function get_current_time(tcurrent) result(ierr) bind(C, name="get_current_time" end function get_current_time - function update_zbuv() result(ierr) bind(C, name="update_zbuv") - ! Update bed level at uv points - !DEC$ ATTRIBUTES DLLEXPORT :: update_zbuv + function bmi_update_bed_level() result(ierr) bind(C, name="update_bed_level") + ! Apply dzbext to the bed-level arrays (zb or subgrid_z_zmin/zmax and + ! subgrid_uv_zmin/zmax) and rebuild zbuvmx for non-subgrid runs. + !DEC$ ATTRIBUTES DLLEXPORT :: bmi_update_bed_level integer(kind=c_int) :: ierr - call compute_zbuvmx() + call update_bed_level() ierr = 0 - - end function update_zbuv + + end function bmi_update_bed_level function update_apparent_roughness() result(ierr) bind(C, name="update_apparent_roughness") ! Update apparent roughness at uv points diff --git a/source/src/sfincs_data.f90 b/source/src/sfincs_data.f90 index 82ed79cf4..fab6b5ae7 100644 --- a/source/src/sfincs_data.f90 +++ b/source/src/sfincs_data.f90 @@ -15,6 +15,7 @@ module sfincs_data !!! logical :: bmi logical :: use_qext + logical :: use_dzbext !!! !!! Constants !!! @@ -574,6 +575,7 @@ module sfincs_data real*4, dimension(:), allocatable :: zs0 real*4, dimension(:), allocatable :: zsderv real*4, dimension(:), allocatable, target :: qext + real*4, dimension(:), allocatable, target :: dzbext real*4, dimension(:), allocatable, target :: uorb real*4, dimension(:), allocatable :: gnapp2 ! @@ -1019,6 +1021,7 @@ subroutine finalize_parameters() if(allocated(uv0)) deallocate(uv0) if(allocated(twet)) deallocate(twet) if(allocated(qext)) deallocate(qext) + if(allocated(dzbext)) deallocate(dzbext) ! ! if(allocated(huu)) deallocate(huu) ! if(allocated(hvv)) deallocate(hvv) diff --git a/source/src/sfincs_domain.f90 b/source/src/sfincs_domain.f90 index 582efe572..a2a88f52d 100644 --- a/source/src/sfincs_domain.f90 +++ b/source/src/sfincs_domain.f90 @@ -1738,24 +1738,88 @@ subroutine initialize_bathymetry() ! end subroutine - subroutine compute_zbuvmx() + subroutine update_bed_level() + ! + ! Apply the externally-supplied delta bed level (dzbext) to the kernel's + ! bed-level arrays and refresh derived quantities at uv points. + ! + ! Non-subgrid mode: + ! zb = zb + dzbext (cell centres) + ! zbuvmx(ip) = max(zb(nm), zb(nmu)) + huthresh (uv points, rebuilt) + ! + ! Subgrid mode: + ! subgrid_z_zmin/zmax shift rigidly by dzbext at the cell centre. + ! subgrid_uv_zmin/zmax shift rigidly by the average dzbext of the two + ! neighbouring cells, with subgrid_uv_zmin clamped from below by the + ! larger of the two updated cell-centre subgrid_z_zmin values so the uv + ! minimum can never sit below either neighbour's minimum. + ! + ! The caller (Python via BMI) owns the lifecycle of dzbext: this routine + ! does not zero it out after applying. When use_dzbext is .false. the + ! routine still rebuilds zbuvmx in non-subgrid mode (cheap, and matches the + ! historical behaviour of compute_zbuvmx). ! use sfincs_data ! integer :: ip integer :: nm integer :: nmu + real*4 :: avg_dzb ! - do ip = 1, npuv + if (.not. subgrid) then ! - nm = uv_index_z_nm(ip) - nmu = uv_index_z_nmu(ip) + ! Non-subgrid path: shift zb, then rebuild zbuvmx for every uv point. ! - zbuvmx(ip) = max(zb(nm), zb(nmu)) + huthresh - ! - enddo + if (use_dzbext) then + ! + zb(:) = zb(:) + dzbext(:) + ! + endif + ! + do ip = 1, npuv + ! + nm = uv_index_z_nm(ip) + nmu = uv_index_z_nmu(ip) + ! + zbuvmx(ip) = max(zb(nm), zb(nmu)) + huthresh + ! + enddo + ! + else + ! + ! Subgrid path: only do anything when an external delta has been set. + ! + if (use_dzbext) then + ! + ! Cell-centre arrays shift rigidly with dzbext. + ! + subgrid_z_zmin(:) = subgrid_z_zmin(:) + dzbext(:) + subgrid_z_zmax(:) = subgrid_z_zmax(:) + dzbext(:) + ! + ! UV-point arrays shift by the average delta of the two neighbours, + ! then clamp uv_zmin from below by the higher of the two updated + ! cell-centre minima. + ! + do ip = 1, npuv + ! + nm = uv_index_z_nm(ip) + nmu = uv_index_z_nmu(ip) + ! + avg_dzb = 0.5 * (dzbext(nm) + dzbext(nmu)) + ! + subgrid_uv_zmin(ip) = subgrid_uv_zmin(ip) + avg_dzb + subgrid_uv_zmax(ip) = subgrid_uv_zmax(ip) + avg_dzb + ! + subgrid_uv_zmin(ip) = max(subgrid_uv_zmin(ip), & + max(subgrid_z_zmin(nm), subgrid_z_zmin(nmu))) + ! + enddo + ! + endif + ! + endif ! - end subroutine + end subroutine update_bed_level subroutine initialize_boundaries() ! diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index 2eef25f27..f9569aeec 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -1070,12 +1070,29 @@ subroutine ncoutput_quadtree_map_init() NF90(nf90_def_var(map_file%ncid, 'crs', NF90_INT, map_file%crs_varid)) ! For EPSG code NF90(nf90_put_att(map_file%ncid, map_file%crs_varid, 'EPSG', '-')) ! - NF90(nf90_def_var(map_file%ncid, 'zb', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%zb_varid)) ! bed level in cell centre - NF90(nf90_def_var_deflate(map_file%ncid, map_file%zb_varid, 1, 1, nc_deflate_level)) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, '_FillValue', FILL_VALUE)) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'units', 'm')) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'standard_name', 'altitude')) - NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'bed_level_above_reference_level')) + if (store_dynamic_bed_level) then + ! + ! Time-varying bed level: define zb with an extra time dimension + ! + NF90(nf90_def_var(map_file%ncid, 'zb', NF90_FLOAT, (/map_file%nmesh2d_face_dimid, map_file%time_dimid/), map_file%zb_varid)) ! bed level in cell centre + NF90(nf90_def_var_deflate(map_file%ncid, map_file%zb_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'standard_name', 'altitude')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'bed_level_above_reference_level')) + ! + else + ! + ! Static bed level: define zb without a time dimension + ! + NF90(nf90_def_var(map_file%ncid, 'zb', NF90_FLOAT, (/map_file%nmesh2d_face_dimid/), map_file%zb_varid)) ! bed level in cell centre + NF90(nf90_def_var_deflate(map_file%ncid, map_file%zb_varid, 1, 1, nc_deflate_level)) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'units', 'm')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'standard_name', 'altitude')) + NF90(nf90_put_att(map_file%ncid, map_file%zb_varid, 'long_name', 'bed_level_above_reference_level')) + ! + endif ! if (.not. subgrid) then ! @@ -1544,22 +1561,30 @@ subroutine ncoutput_quadtree_map_init() ! vtmp = FILL_VALUE ! - if (subgrid) then - do nmq = 1, quadtree_nr_points - nm = index_sfincs_in_quadtree(nmq) - if (nm>0) then - vtmp(nmq) = subgrid_z_zmin(nm) - endif - enddo - NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp)) - else - do nmq = 1, quadtree_nr_points - nm = index_sfincs_in_quadtree(nmq) - if (nm>0) then - vtmp(nmq) = zb(nm) - endif - enddo - NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp)) + ! When store_dynamic_bed_level is enabled, zb has a time dimension, so the + ! static-shaped write is invalid here and must be skipped (the per-step + ! writer fills the variable instead). + ! + if (.not. store_dynamic_bed_level) then + ! + if (subgrid) then + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm>0) then + vtmp(nmq) = subgrid_z_zmin(nm) + endif + enddo + NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp)) + else + do nmq = 1, quadtree_nr_points + nm = index_sfincs_in_quadtree(nmq) + if (nm>0) then + vtmp(nmq) = zb(nm) + endif + enddo + NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp)) + endif + ! endif ! ! Subgrid slope @@ -2397,20 +2422,24 @@ subroutine ncoutput_update_regular_map(t,ntmapout) ! NF90(nf90_put_var(map_file%ncid, map_file%zs_varid, zsg, (/1, 1, ntmapout/))) ! write zs ! - if (store_dynamic_bed_level .and. .not. subgrid) then + if (store_dynamic_bed_level) then ! do nm = 1, np ! n = z_index_z_n(nm) m = z_index_z_m(nm) - ! - zsg(m, n) = zb(nm) - ! + ! + if (subgrid) then + zsg(m, n) = subgrid_z_zmin(nm) + else + zsg(m, n) = zb(nm) + endif + ! enddo ! - NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, zsg, (/1, 1, ntmapout/))) ! write zb + NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, zsg, (/1, 1, ntmapout/))) ! write zb (subgrid_z_zmin for subgrid runs) ! - endif + endif ! if (subgrid .eqv. .false. .or. store_hsubgrid .eqv. .true.) then ! @@ -2864,8 +2893,34 @@ subroutine ncoutput_update_quadtree_map(t,ntmapout) enddo ! NF90(nf90_put_var(map_file%ncid, map_file%zs_varid, vtmp, (/1, ntmapout/))) ! write zs - ! - ! Water depth + ! + ! Time-varying bed level + ! + if (store_dynamic_bed_level) then + ! + vtmp = FILL_VALUE + ! + do nmq = 1, quadtree_nr_points + ! + nm = index_sfincs_in_quadtree(nmq) + ! + if (nm>0) then + ! + if (subgrid) then + vtmp(nmq) = subgrid_z_zmin(nm) + else + vtmp(nmq) = zb(nm) + endif + ! + endif + ! + enddo + ! + NF90(nf90_put_var(map_file%ncid, map_file%zb_varid, vtmp, (/1, ntmapout/))) ! write zb (subgrid_z_zmin for subgrid runs) + ! + endif + ! + ! Water depth ! if (subgrid .eqv. .false. .or. store_hsubgrid .eqv. .true.) then ! From ccacf95c627d0a42cdd95c76c5e8199ed35df42b Mon Sep 17 00:00:00 2001 From: vanasseltk <167875592+vanasseltk@users.noreply.github.com> Date: Wed, 29 Apr 2026 15:42:02 +0200 Subject: [PATCH 56/65] do not allow for dike breach widening in opposite direction --- source/src/sfincs_src_structures.f90 | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index a17f85f89..33e06355d 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -1185,15 +1185,19 @@ subroutine update_src_structures(t, dt) ! Driving head H = upstream head above z_min minus downstream. ! z_breach = z_min_br - h_up = max(max(real(zs(nm_o1),4), real(zs(nm_o2),4)) - z_min_br, 0.0) - h_dn = max(min(real(zs(nm_o1),4), real(zs(nm_o2),4)) - z_min_br, 0.0) - dh = max(h_up - h_dn, 0.0) tau_hr = (real(t, 4) - t_phase1_br) / 3600.0 dt_hr = dt / 3600.0 - denom = max(1.0 + (f2 * g / uc_mat) * tau_hr, 1.0e-12) - dBdt_br = (f1 * f2 / log(10.0)) * (g * dh)**1.5 / & - (uc_mat * uc_mat * denom) - B_breach = B_breach + max(dBdt_br, 0.0) * dt_hr + ! Only widen when obs_1 (inside) is higher than obs_2 (outside). + ! Reversed flow (ebb/return) is allowed but does not erode further. + if (real(zs(nm_o1), 4) > real(zs(nm_o2), 4)) then + h_up = max(real(zs(nm_o1), 4) - z_min_br, 0.0) + h_dn = max(real(zs(nm_o2), 4) - z_min_br, 0.0) + dh = max(h_up - h_dn, 0.0) + denom = max(1.0 + (f2 * g / uc_mat) * tau_hr, 1.0e-12) + dBdt_br = (f1 * f2 / log(10.0)) * (g * dh)**1.5 / & + (uc_mat * uc_mat * denom) + B_breach = B_breach + max(dBdt_br, 0.0) * dt_hr + endif ! endif ! From 287675c9396addd1cf17f8bfaab3ed060abf5876 Mon Sep 17 00:00:00 2001 From: vanasseltk <167875592+vanasseltk@users.noreply.github.com> Date: Thu, 30 Apr 2026 09:29:23 +0200 Subject: [PATCH 57/65] more descriptive variables --- source/src/sfincs_src_structures.f90 | 88 +++++++++++++++------------- 1 file changed, 47 insertions(+), 41 deletions(-) diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index 33e06355d..6ed1f0975 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -845,8 +845,10 @@ subroutine update_src_structures(t, dt) real*4 :: h_up, h_dn, qq_sign logical :: open_fires, close_fires ! - real*4 :: z_breach, B_breach, z_crest_br, z_min_br, t_br, t0_br - real*4 :: f1, f2, uc_mat, t_phase1_br, tau_hr, dt_hr, denom, dBdt_br + real*4 :: crest_breach, width_breach, z_crest_breach, z_min_breach + real*4 :: tstart_breach, tstart_widening, t_phase1_deepening + real*4 :: vk_f1, vk_f2, uc_material, elapsed_widening_hr, dt_hr + real*4 :: widening_deceleration, widening_rate ! if (nr_src_structures <= 0) return ! @@ -876,16 +878,20 @@ subroutine update_src_structures(t, dt) !$acc dh, a_eff, & !$acc h_up, h_dn, qq_sign, & !$acc open_fires, close_fires, & - !$acc z_breach, B_breach, z_crest_br, z_min_br, t_br, t0_br, & - !$acc f1, f2, uc_mat, t_phase1_br, tau_hr, dt_hr, denom, dBdt_br ) + !$acc crest_breach, width_breach, z_crest_breach, z_min_breach, & + !$acc tstart_breach, tstart_widening, t_phase1_deepening, & + !$acc vk_f1, vk_f2, uc_material, elapsed_widening_hr, dt_hr, & + !$acc widening_deceleration, widening_rate ) !$omp parallel do & !$omp private( nm_s1, nm_s2, nm_o1, nm_o2, qq, elapsed, & !$omp zs_o1, zs_o2, frac, wdt, mng, zsill, dist, dzds, hgate, qq0, alpha, & !$omp dh, a_eff, & !$omp h_up, h_dn, qq_sign, & !$omp open_fires, close_fires, & - !$omp z_breach, B_breach, z_crest_br, z_min_br, t_br, t0_br, & - !$omp f1, f2, uc_mat, t_phase1_br, tau_hr, dt_hr, denom, dBdt_br ) & + !$omp crest_breach, width_breach, z_crest_breach, z_min_breach, & + !$omp tstart_breach, tstart_widening, t_phase1_deepening, & + !$omp vk_f1, vk_f2, uc_material, elapsed_widening_hr, dt_hr, & + !$omp widening_deceleration, widening_rate ) & !$omp schedule ( static ) do istruc = 1, nr_src_structures ! @@ -1152,82 +1158,82 @@ subroutine update_src_structures(t, dt) nm_o1 = src_struc_nm_o1(istruc) nm_o2 = src_struc_nm_o2(istruc) ! - z_crest_br = src_struc_z_crest(istruc) - z_min_br = src_struc_z_min(istruc) - t_br = src_struc_t_breach(istruc) - t0_br = src_struc_t0(istruc) - t_phase1_br = t_br + t0_br + z_crest_breach = src_struc_z_crest(istruc) + z_min_breach = src_struc_z_min(istruc) + tstart_breach = src_struc_t_breach(istruc) + tstart_widening = src_struc_t0(istruc) + t_phase1_deepening = tstart_breach + tstart_widening ! - B_breach = src_struc_breach_width(istruc) - z_breach = src_struc_breach_level(istruc) + width_breach = src_struc_breach_width(istruc) + crest_breach = src_struc_breach_level(istruc) ! if (src_struc_dike_core(istruc) == 1) then - f1 = 1.3; f2 = 0.04; uc_mat = 0.2 ! sand + vk_f1 = 1.3; vk_f2 = 0.04; uc_material = 0.2 ! sand else - f1 = 1.3; f2 = 0.04; uc_mat = 0.5 ! clay + vk_f1 = 1.3; vk_f2 = 0.04; uc_material = 0.5 ! clay endif ! ! --- Breach geometry update --- ! - if (real(t, 4) >= t_br) then + if (real(t, 4) >= tstart_breach) then ! - if (real(t, 4) < t_phase1_br) then + if (real(t, 4) < t_phase1_deepening) then ! ! Phase 1: crest lowers linearly to z_min over t0; width = B0 ! - z_breach = z_crest_br - (z_crest_br - z_min_br) * & - (real(t, 4) - t_br) / t0_br - B_breach = src_struc_B0(istruc) + crest_breach = z_crest_breach - (z_crest_breach - z_min_breach) * & + (real(t, 4) - tstart_breach) / tstart_widening + width_breach = src_struc_B0(istruc) ! else ! ! Phase 2: crest at z_min, breach widens via Verheij formula. ! Driving head H = upstream head above z_min minus downstream. ! - z_breach = z_min_br - tau_hr = (real(t, 4) - t_phase1_br) / 3600.0 - dt_hr = dt / 3600.0 + crest_breach = z_min_breach + elapsed_widening_hr = (real(t, 4) - t_phase1_deepening) / 3600.0 + dt_hr = dt / 3600.0 ! Only widen when obs_1 (inside) is higher than obs_2 (outside). ! Reversed flow (ebb/return) is allowed but does not erode further. if (real(zs(nm_o1), 4) > real(zs(nm_o2), 4)) then - h_up = max(real(zs(nm_o1), 4) - z_min_br, 0.0) - h_dn = max(real(zs(nm_o2), 4) - z_min_br, 0.0) - dh = max(h_up - h_dn, 0.0) - denom = max(1.0 + (f2 * g / uc_mat) * tau_hr, 1.0e-12) - dBdt_br = (f1 * f2 / log(10.0)) * (g * dh)**1.5 / & - (uc_mat * uc_mat * denom) - B_breach = B_breach + max(dBdt_br, 0.0) * dt_hr + h_up = max(real(zs(nm_o1), 4) - z_min_breach, 0.0) + h_dn = max(real(zs(nm_o2), 4) - z_min_breach, 0.0) + dh = max(h_up - h_dn, 0.0) + widening_deceleration = max(1.0 + (vk_f2 * g / uc_material) * elapsed_widening_hr, 1.0e-12) + widening_rate = (vk_f1 * vk_f2 / log(10.0)) * (g * dh)**1.5 / & + (uc_material * uc_material * widening_deceleration) + width_breach = width_breach + max(widening_rate, 0.0) * dt_hr endif ! endif ! else - z_breach = z_crest_br - B_breach = 0.0 + crest_breach = z_crest_breach + width_breach = 0.0 endif ! - src_struc_breach_level(istruc) = z_breach - src_struc_breach_width(istruc) = B_breach + src_struc_breach_level(istruc) = crest_breach + src_struc_breach_width(istruc) = width_breach ! ! --- Discharge through breach (culvert-style, obs-point WLs) --- ! dh = real(zs(nm_o1), 4) - real(zs(nm_o2), 4) if (dh >= 0.0) then - h_up = max(real(zs(nm_o1), 4) - z_breach, 0.0) - h_dn = max(real(zs(nm_o2), 4) - z_breach, 0.0) + h_up = max(real(zs(nm_o1), 4) - crest_breach, 0.0) + h_dn = max(real(zs(nm_o2), 4) - crest_breach, 0.0) qq_sign = 1.0 else - h_up = max(real(zs(nm_o2), 4) - z_breach, 0.0) - h_dn = max(real(zs(nm_o1), 4) - z_breach, 0.0) + h_up = max(real(zs(nm_o2), 4) - crest_breach, 0.0) + h_dn = max(real(zs(nm_o1), 4) - crest_breach, 0.0) qq_sign = -1.0 endif ! - if (h_up <= 0.0 .or. B_breach <= 0.0) then + if (h_up <= 0.0 .or. width_breach <= 0.0) then qq = 0.0 elseif (h_dn / h_up >= src_struc_submergence_ratio(istruc)) then - qq = qq_sign * B_breach * h_up * sqrt(2.0 * g * abs(dh)) + qq = qq_sign * width_breach * h_up * sqrt(2.0 * g * abs(dh)) else - qq = qq_sign * 1.71 * B_breach * sqrt(g) * h_up**1.5 + qq = qq_sign * 1.71 * width_breach * sqrt(g) * h_up**1.5 endif ! end select From f5215d3f7cda96e98b4fe8b2b9723a1fa03a1c6e Mon Sep 17 00:00:00 2001 From: Tim Leijnse Date: Wed, 6 May 2026 09:27:10 +0200 Subject: [PATCH 58/65] Delete source/sfincs/sfincs.vfproj.asselt.user --- source/sfincs/sfincs.vfproj.asselt.user | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 source/sfincs/sfincs.vfproj.asselt.user diff --git a/source/sfincs/sfincs.vfproj.asselt.user b/source/sfincs/sfincs.vfproj.asselt.user deleted file mode 100644 index 7910296a3..000000000 --- a/source/sfincs/sfincs.vfproj.asselt.user +++ /dev/null @@ -1,8 +0,0 @@ - - - - - - - - From 7da7f548c4c410c4151dfddc0517a1ef35e5dadd Mon Sep 17 00:00:00 2001 From: Tim Leijnse Date: Wed, 6 May 2026 09:27:37 +0200 Subject: [PATCH 59/65] Delete source/sfincs_lib/sfincs_lib.vfproj.asselt.user --- source/sfincs_lib/sfincs_lib.vfproj.asselt.user | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 source/sfincs_lib/sfincs_lib.vfproj.asselt.user diff --git a/source/sfincs_lib/sfincs_lib.vfproj.asselt.user b/source/sfincs_lib/sfincs_lib.vfproj.asselt.user deleted file mode 100644 index 3bfb867c8..000000000 --- a/source/sfincs_lib/sfincs_lib.vfproj.asselt.user +++ /dev/null @@ -1,8 +0,0 @@ - - - - - - - - From f82897e98964595e309fb9c419220a28e36f2c64 Mon Sep 17 00:00:00 2001 From: Tim Leijnse Date: Wed, 6 May 2026 10:27:27 +0200 Subject: [PATCH 60/65] Delete source/sfincs/sfincs.log --- source/sfincs/sfincs.log | 40 ---------------------------------------- 1 file changed, 40 deletions(-) delete mode 100644 source/sfincs/sfincs.log diff --git a/source/sfincs/sfincs.log b/source/sfincs/sfincs.log deleted file mode 100644 index 2b94f1aae..000000000 --- a/source/sfincs/sfincs.log +++ /dev/null @@ -1,40 +0,0 @@ - ------------- Welcome to SFINCS ------------ - - @@@@@ @@@@@@@ @@ @@ @@ @@@@ @@@@@ - @@@ @@@ @@@@@@@ @@ @@@ @@ @@@@@@@ @@@ @@@ - @@@ @@ @@ @@@ @@ @@ @@ @@@ - @@@@@ @@@@@@ @@ @@@@@@ @@ @@@@@ - @@@ @@ @@ @@ @@@ @@ @@ @@@ - @@@ @@@ @@ @@ @@ @@ @@@@@@ @@@ @@@ - @@@@@ @@ @@ @@ @ @@@@ @@@@@ - - .............. - ......:@@@@@@@@:...... - ..::::..@@........@@.:::::.. - ..:::::..@@..::..::..@@.::::::.. - .::::::..@@............@@.:::::::. - .::::::..@@..............@@.:::::::. - .::::::::..@@............@@..::::::::. - .:::::::::...@@.@..@@..@.@@..::::::::::. - .:::::::::...:@@@..@@..@@@:..:::::::::.. - ............@@.@@..@@..@@.@@............ - ^^^~~^^~~^^@@..............@@^^^~^^^~~^^ - .::::::::::@@..............@@.:::::::::. - .......:.@@.....@.....@....@@.:....... - .::....@@......@.@@@.@....@@.....::. - .:::~@@.:...:.@@...@@.:.:.@@~::::. - .::~@@@@@@@@@@.....@@@@@@@@@~::. - ..:~~~~~~~:.......:~~~~~~~:.. - ...................... - .............. - ------------------------------------------- - -Build-Revision: $Rev: v2.3.1 mt. Faber+branch-redo-infiltration -Build-Date: $Date: 2026-03-19 - ------- Preparing model simulation -------- - -Reading input file ... -Error : SFINCS input file "sfincs.inp" not found! SFINCS has stopped! From 66ec2f9e38201777059140b501a968e91adb1824 Mon Sep 17 00:00:00 2001 From: Tim Leijnse Date: Wed, 6 May 2026 10:27:50 +0200 Subject: [PATCH 61/65] Delete source/sfincs/sfincs.vfproj.keesn.user --- source/sfincs/sfincs.vfproj.keesn.user | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 source/sfincs/sfincs.vfproj.keesn.user diff --git a/source/sfincs/sfincs.vfproj.keesn.user b/source/sfincs/sfincs.vfproj.keesn.user deleted file mode 100644 index 6ae2aa06f..000000000 --- a/source/sfincs/sfincs.vfproj.keesn.user +++ /dev/null @@ -1,8 +0,0 @@ - - - - - - - - From 5013af39ff9cc62a29e883a56c117dd017b4393d Mon Sep 17 00:00:00 2001 From: Tim Leijnse Date: Wed, 6 May 2026 10:28:08 +0200 Subject: [PATCH 62/65] Delete source/sfincs_lib/sfincs_lib.vfproj.keesn.user --- source/sfincs_lib/sfincs_lib.vfproj.keesn.user | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 source/sfincs_lib/sfincs_lib.vfproj.keesn.user diff --git a/source/sfincs_lib/sfincs_lib.vfproj.keesn.user b/source/sfincs_lib/sfincs_lib.vfproj.keesn.user deleted file mode 100644 index 818b85e15..000000000 --- a/source/sfincs_lib/sfincs_lib.vfproj.keesn.user +++ /dev/null @@ -1,8 +0,0 @@ - - - - - - - - From 6d2e16c667ccc08a0c33444d8dc3562ca8acd2ec Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Tue, 26 May 2026 17:18:46 +0200 Subject: [PATCH 63/65] Add ifx Dockerfile and z1-z2 atom support Add a new multi-stage Dockerfile (build_scripts/Dockerfile.cpu.ifx) to build SFINCS with the Intel ifx compiler using the oneAPI HPC kit and produce a slim runtime image (static Intel runtime, bundled netcdf-fortran built with ifx). Update sfincs_rule_expression.f90 to recognize and evaluate a new atom 'z1-z2' (atom_z1_minus_z2): added token kind handling, parsing (longest-match for identifiers with '-'), evaluation branch, and updated error/message text to include the new atom. --- source/build_scripts/Dockerfile.cpu.ifx | 58 +++++++++++++++++++++++++ source/src/sfincs_rule_expression.f90 | 27 +++++++++--- 2 files changed, 79 insertions(+), 6 deletions(-) create mode 100644 source/build_scripts/Dockerfile.cpu.ifx diff --git a/source/build_scripts/Dockerfile.cpu.ifx b/source/build_scripts/Dockerfile.cpu.ifx new file mode 100644 index 000000000..820f69d1e --- /dev/null +++ b/source/build_scripts/Dockerfile.cpu.ifx @@ -0,0 +1,58 @@ +# SFINCS CPU image built with the Intel ifx compiler. +# +# Build from the SFINCS source ROOT (so the COPY context is the whole tree): +# docker build -f build_scripts/Dockerfile.cpu.ifx -t sfincs-cpu-ifx:local . +# +# Mirrors HurryWave's build_scripts/Dockerfile.cpu.ifx. Two stages: compile on +# the oneAPI HPC kit (which ships ifx) with the Intel runtime linked statically +# (-static-intel -qopenmp-link=static), then copy the install onto a slim ubuntu +# base. Static-linking keeps the final image ~1 GB instead of dragging in the +# multi-GB intel/oneapi-runtime image (MKL/MPI/TBB that SFINCS never uses). +# +# netcdf: Ubuntu's libnetcdff is gfortran-built and its .mod files are +# ABI-incompatible with ifx, so we let ./configure compile the BUNDLED +# netcdf-fortran (third_party_open/netcdf) with ifx. libnetcdf-dev supplies only +# the C library. (This is also why the gfortran -fallow-argument-mismatch flag +# from the gfortran Dockerfile is dropped here — it was a gfortran-only +# workaround for building netcdf-fortran; ifx neither needs nor understands it.) + +# ---- build stage ---------------------------------------------------------- +FROM intel/oneapi-hpckit:latest AS build +ENV DEBIAN_FRONTEND=noninteractive +RUN apt update && apt install -y dos2unix libnetcdf-dev build-essential \ + autoconf automake libtool pkg-config tzdata m4 + +COPY . /usr/src/sfincs +WORKDIR /usr/src/sfincs + +# Normalise line endings of anything that may have arrived as CRLF (Windows checkout). +RUN find . \( -name '*.m4' -o -name '*.ac' -o -name '*.am' \ + -o -name '*.f90' -o -name '*.F90' -o -name '*.sh' \) | xargs dos2unix + +# Build with ifx. +# -static-intel / -qopenmp-link=static : link the Intel runtime into the +# binary so it runs on the slim runtime stage (no oneAPI libs needed). +# --disable-openacc : pure CPU/OpenMP build (matches the gfortran CPU image). +# --disable-shared : force static libs, incl. the bundled netcdf-fortran. +# The oneAPI image already sourced setvars.sh (SETVARS_COMPLETED set, ifx on +# PATH) — do NOT re-source it: re-running setvars.sh without --force exits +# non-zero and would abort this RUN. +# +# NOTE: -fp-model fast=2 / -no-prec-div / -fno-alias / -fno-fnalias match +# HurryWave's ifx build (aggressive floating-point optimisation). Switch to +# -fp-model precise if you need tighter FP reproducibility vs the gfortran build. +RUN autoreconf -vif && \ + FC=ifx \ + FCFLAGS="-fpp -qopenmp -O3 -fp-model fast=2 -no-prec-div -fno-alias -fno-fnalias -w -static-intel -qopenmp-link=static" \ + FFLAGS="-fpp -qopenmp -O3 -fp-model fast=2 -no-prec-div -fno-alias -fno-fnalias -w -static-intel -qopenmp-link=static" \ + ./configure --disable-openacc --disable-shared && \ + make && make install + +# ---- runtime stage -------------------------------------------------------- +FROM ubuntu:jammy +ENV DEBIAN_FRONTEND=noninteractive +RUN apt update && apt install -y libnetcdf-dev tzdata && rm -rf /var/lib/apt/lists/* +COPY --from=build /usr/local /usr/local +VOLUME /data +WORKDIR /data +CMD ["sfincs"] diff --git a/source/src/sfincs_rule_expression.f90 b/source/src/sfincs_rule_expression.f90 index 8cd92bfc1..aba5f3e55 100644 --- a/source/src/sfincs_rule_expression.f90 +++ b/source/src/sfincs_rule_expression.f90 @@ -7,7 +7,7 @@ module sfincs_rule_expression ! or_expr := and_expr ( '|' and_expr )* ! and_expr := comp ( '&' comp )* ! comp := '(' expr ')' | atom cmp_op number - ! atom := 'z1' | 'z2' | 'z2-z1' (case-insensitive) + ! atom := 'z1' | 'z2' | 'z2-z1' | 'z1-z2' (case-insensitive) ! cmp_op := '<' | '>' | '<=' | '>=' | '=' | '==' ! number := real literal ! @@ -56,6 +56,7 @@ module sfincs_rule_expression integer, parameter :: atom_z1 = 1 integer, parameter :: atom_z2 = 2 integer, parameter :: atom_z2_minus_z1 = 3 + integer, parameter :: atom_z1_minus_z2 = 4 ! ! Comparator codes. ! @@ -320,6 +321,10 @@ pure function evaluate_rule(rule_id, z1, z2) result(fired) ! zval = z2 - z1 ! + case (atom_z1_minus_z2) + ! + zval = z1 - z2 + ! case default ! zval = 0.0 @@ -490,7 +495,7 @@ subroutine parse_rule_expression(src, ops, atoms, cmps, thresholds, nops, ierr, character(len=*), intent(out) :: errmsg ! ! Token kinds: - ! 1 = ident (z1/z2/z2-z1) payload: atom code in tok_atom + ! 1 = ident (z1/z2/z2-z1/z1-z2) payload: atom code in tok_atom ! 2 = number payload: real in tok_num ! 3 = lparen ! 4 = rparen @@ -808,9 +813,9 @@ subroutine tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ie ! endif ! - ! Identifiers: z1, z2, z2-z1. The 'z2-z1' atom contains a '-', - ! which would otherwise be eaten by the number path; we match it - ! as a longest-match-first prefix here. + ! Identifiers: z1, z2, z2-z1, z1-z2. The 'z2-z1' / 'z1-z2' atoms + ! contain a '-', which would otherwise be eaten by the number path; + ! we match them as longest-match-first prefixes here. ! kstart = pos ! @@ -830,6 +835,16 @@ subroutine tokenize_rule(src, tok_kind, tok_atom, tok_num, tok_pos, n_tokens, ie pos = pos + 5 cycle ! + elseif (lower(pos:pos+4) == 'z1-z2') then + ! + atom_code = atom_z1_minus_z2 + n_tokens = n_tokens + 1 + tok_kind(n_tokens) = tok_ident + tok_atom(n_tokens) = atom_code + tok_pos (n_tokens) = kstart + pos = pos + 5 + cycle + ! endif ! endif @@ -1057,7 +1072,7 @@ recursive subroutine parse_comp(tok_kind, tok_atom, tok_num, tok_pos, n_tokens, if (tok_kind(ip) /= tok_ident) then ! ierr = 1 - write(errmsg,'(a,i0)') 'expected atom (z1/z2/z2-z1) at position ', tok_pos(ip) + write(errmsg,'(a,i0)') 'expected atom (z1/z2/z2-z1/z1-z2) at position ', tok_pos(ip) return ! endif From ee41c34b0bd649f6068e53c97b3e7057af9c255d Mon Sep 17 00:00:00 2001 From: Maarten van Ormondt Date: Wed, 27 May 2026 13:33:31 +0200 Subject: [PATCH 64/65] Interruptible transitions and gate-fraction output Add support for interruptible open/close transitions for source structures and export per-structure gate open fraction to NetCDF. Introduces a logical/byte flag src_struc_interruptible (alloc, default false, parsed from TOML) and wires it through allocation, initialization, OpenACC data lists, logging, and parsing. State-machine logic for opening/closing was updated so interruptible structures can reverse mid-ramp by evaluating the opposite rule and reseeding src_struc_t_state to continue the ramp without a jump. Also add a NetCDF variable 'drainage_fraction_open' (his_file%drain_fraction_open_varid) and write src_struc_fraction_open per output timestep. Minor bookkeeping: OpenACC update and put_var calls updated to include the new arrays. --- source/src/sfincs_ncoutput.F90 | 13 ++- source/src/sfincs_openacc.f90 | 2 + source/src/sfincs_src_structures.f90 | 145 ++++++++++++++++++++++++--- 3 files changed, 142 insertions(+), 18 deletions(-) diff --git a/source/src/sfincs_ncoutput.F90 b/source/src/sfincs_ncoutput.F90 index f9569aeec..043b3f268 100644 --- a/source/src/sfincs_ncoutput.F90 +++ b/source/src/sfincs_ncoutput.F90 @@ -50,7 +50,7 @@ module sfincs_ncoutput integer :: crosssection_name_varid integer :: structure_height_varid, structure_x_varid, structure_y_varid integer :: thindam_x_varid, thindam_y_varid - integer :: drain_varid, drain_name_varid + integer :: drain_varid, drain_name_varid, drain_fraction_open_varid integer :: river_varid, river_name_varid integer :: urbdrain_varid, urbdrain_name_varid integer :: zb_varid @@ -2200,6 +2200,12 @@ subroutine ncoutput_his_init() NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'long_name', 'discharge through drainage structure')) NF90(nf90_put_att(his_file%ncid, his_file%drain_varid, 'coordinates', 'drainage_name')) ! + NF90(nf90_def_var(his_file%ncid, 'drainage_fraction_open', NF90_FLOAT, (/his_file%drain_dimid, his_file%time_dimid/), his_file%drain_fraction_open_varid)) ! time-varying gate open fraction (1=open, 0=closed) + NF90(nf90_put_att(his_file%ncid, his_file%drain_fraction_open_varid, '_FillValue', FILL_VALUE)) + NF90(nf90_put_att(his_file%ncid, his_file%drain_fraction_open_varid, 'units', '1')) + NF90(nf90_put_att(his_file%ncid, his_file%drain_fraction_open_varid, 'long_name', 'gate open fraction (1 = fully open, 0 = fully closed)')) + NF90(nf90_put_att(his_file%ncid, his_file%drain_fraction_open_varid, 'coordinates', 'drainage_name')) + ! endif ! if (nr_discharge_points>0 .and. store_river_discharge) then @@ -3274,7 +3280,7 @@ subroutine ncoutput_update_his(t,nthisout) use sfincs_crosssections use sfincs_runup_gauges use sfincs_snapwave - use sfincs_src_structures, only: nr_src_structures, src_struc_q_now + use sfincs_src_structures, only: nr_src_structures, src_struc_q_now, src_struc_fraction_open use sfincs_discharges, only: qtsrc, nr_discharge_points use sfincs_urban_drainage, only: nr_urban_drainage_zones, urban_drainage_q_total ! @@ -3570,9 +3576,10 @@ subroutine ncoutput_update_his(t,nthisout) ! if (nr_src_structures>0) then ! - !$acc update host(src_struc_q_now) + !$acc update host(src_struc_q_now, src_struc_fraction_open) ! NF90(nf90_put_var(his_file%ncid, his_file%drain_varid, src_struc_q_now, (/1, nthisout/))) ! write per-structure discharge + NF90(nf90_put_var(his_file%ncid, his_file%drain_fraction_open_varid, src_struc_fraction_open, (/1, nthisout/))) ! write per-structure gate open fraction ! endif ! diff --git a/source/src/sfincs_openacc.f90 b/source/src/sfincs_openacc.f90 index 46b67e8f9..b570dc9bd 100644 --- a/source/src/sfincs_openacc.f90 +++ b/source/src/sfincs_openacc.f90 @@ -42,6 +42,7 @@ subroutine initialize_openacc() !$acc src_struc_invert_1, src_struc_invert_2, & !$acc src_struc_submergence_ratio, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, src_struc_t_state, & + !$acc src_struc_interruptible, & !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & @@ -89,6 +90,7 @@ subroutine finalize_openacc() !$acc src_struc_invert_1, src_struc_invert_2, & !$acc src_struc_submergence_ratio, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, src_struc_t_state, & + !$acc src_struc_interruptible, & !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, rule_start, rule_length, & !$acc z_index_wavemaker, wavemaker_uvmean, wavemaker_nmd, wavemaker_nmu, wavemaker_ndm, wavemaker_num, & diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index ea05dcc41..ed6831ecb 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -181,6 +181,13 @@ module sfincs_src_structures character(len=:), allocatable :: rule_open character(len=:), allocatable :: rule_close ! + ! interruptible - when .true., an in-progress opening transition can be + ! reversed by the close rule mid-ramp (and a closing transition by the + ! open rule). When .false. (default), a transition always runs to + ! completion before the opposite rule is re-checked. + ! + logical :: interruptible + ! end type t_src_structure ! ! Module-level storage for structures parsed from a TOML input file. @@ -226,6 +233,12 @@ module sfincs_src_structures ! real*4, dimension(:), allocatable, public :: src_struc_t_state ! + ! Interruptible-transition flag. 1 = an opening/closing ramp can be reversed + ! mid-way by the opposite rule; 0 = the ramp runs to completion before rules + ! are re-checked. Only meaningful for rule-driven structures. + ! + integer*1, dimension(:), allocatable, public :: src_struc_interruptible + ! ! Coordinates ! real*4, dimension(:), allocatable, public :: src_struc_x_s1, src_struc_y_s1 @@ -440,6 +453,7 @@ subroutine initialize_src_structures() allocate(src_struc_status(nr_src_structures)) allocate(src_struc_fraction_open(nr_src_structures)) allocate(src_struc_t_state(nr_src_structures)) + allocate(src_struc_interruptible(nr_src_structures)) allocate(src_struc_name(nr_src_structures)) allocate(src_struc_x_s1(nr_src_structures)) allocate(src_struc_y_s1(nr_src_structures)) @@ -481,6 +495,7 @@ subroutine initialize_src_structures() src_struc_fraction_open = 1.0 ! default "fully open": structures without rules bypass the state machine and use this as a no-op multiplier in the common-tail scaling src_struc_status = 1 ! 0=closed, 1=open, 2=opening, 3=closing; default open (see above). Rule-driven structures overwrite this in the init-time seeding below. src_struc_t_state = 0.0 + src_struc_interruptible = 0 ! default: transitions run to completion (not reversible mid-ramp) src_struc_name = ' ' src_struc_x_s1 = 0.0 src_struc_y_s1 = 0.0 @@ -569,6 +584,12 @@ subroutine initialize_src_structures() src_struc_mannings_n(i) = src_structures(i)%mannings_n src_struc_opening_duration(i) = src_structures(i)%opening_duration src_struc_closing_duration(i) = src_structures(i)%closing_duration + ! + if (src_structures(i)%interruptible) then + src_struc_interruptible(i) = 1 + else + src_struc_interruptible(i) = 0 + endif src_struc_height(i) = src_structures(i)%height src_struc_invert_1(i) = src_structures(i)%invert_1 src_struc_invert_2(i) = src_structures(i)%invert_2 @@ -808,7 +829,7 @@ subroutine update_src_structures(t, dt) !$acc src_struc_invert_1, src_struc_invert_2, & !$acc src_struc_submergence_ratio, & !$acc src_struc_distance, src_struc_status, src_struc_fraction_open, & - !$acc src_struc_t_state, & + !$acc src_struc_t_state, src_struc_interruptible, & !$acc src_struc_rule_open, src_struc_rule_close, & !$acc rule_opcode, rule_atom, rule_cmp, rule_threshold, & !$acc rule_start, rule_length ) & @@ -899,37 +920,103 @@ subroutine update_src_structures(t, dt) ! case (2) ! - ! opening - advance on elapsed time; do not re-check rules + ! opening - advance on elapsed time. If interruptible and + ! the close rule fires, reverse into closing, resuming the + ! ramp from the current fraction_open so there is no jump. ! - elapsed = real(t, 4) - src_struc_t_state(istruc) + close_fires = .false. ! - if (src_struc_opening_duration(istruc) <= 0.0 .or. & - elapsed >= src_struc_opening_duration(istruc)) then + if (src_struc_interruptible(istruc) == 1 .and. src_struc_rule_close(istruc) > 0) then ! - src_struc_status(istruc) = 1 - src_struc_fraction_open(istruc) = 1.0 + close_fires = evaluate_rule(src_struc_rule_close(istruc), zs_o1, zs_o2) + ! + endif + ! + if (close_fires) then + ! + ! Re-seed t_state so closing continues from the current + ! fraction f: in closing, f = 1 - elapsed/closing_duration, + ! so elapsed = (1 - f) * closing_duration. + ! + if (src_struc_closing_duration(istruc) > 0.0) then + ! + src_struc_t_state(istruc) = real(t, 4) - & + (1.0 - src_struc_fraction_open(istruc)) * src_struc_closing_duration(istruc) + ! + else + ! + src_struc_t_state(istruc) = real(t, 4) + ! + endif + ! + src_struc_status(istruc) = 3 ! else ! - src_struc_fraction_open(istruc) = elapsed / src_struc_opening_duration(istruc) + elapsed = real(t, 4) - src_struc_t_state(istruc) + ! + if (src_struc_opening_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_opening_duration(istruc)) then + ! + src_struc_status(istruc) = 1 + src_struc_fraction_open(istruc) = 1.0 + ! + else + ! + src_struc_fraction_open(istruc) = elapsed / src_struc_opening_duration(istruc) + ! + endif ! endif ! case (3) ! - ! closing - advance on elapsed time; do not re-check rules + ! closing - advance on elapsed time. If interruptible and + ! the open rule fires, reverse into opening, resuming the + ! ramp from the current fraction_open so there is no jump. ! - elapsed = real(t, 4) - src_struc_t_state(istruc) + open_fires = .false. + ! + if (src_struc_interruptible(istruc) == 1 .and. src_struc_rule_open(istruc) > 0) then + ! + open_fires = evaluate_rule(src_struc_rule_open(istruc), zs_o1, zs_o2) + ! + endif ! - if (src_struc_closing_duration(istruc) <= 0.0 .or. & - elapsed >= src_struc_closing_duration(istruc)) then + if (open_fires) then + ! + ! Re-seed t_state so opening continues from the current + ! fraction f: in opening, f = elapsed/opening_duration, + ! so elapsed = f * opening_duration. + ! + if (src_struc_opening_duration(istruc) > 0.0) then + ! + src_struc_t_state(istruc) = real(t, 4) - & + src_struc_fraction_open(istruc) * src_struc_opening_duration(istruc) + ! + else + ! + src_struc_t_state(istruc) = real(t, 4) + ! + endif ! - src_struc_status(istruc) = 0 - src_struc_fraction_open(istruc) = 0.0 + src_struc_status(istruc) = 2 ! else ! - src_struc_fraction_open(istruc) = 1.0 - elapsed / src_struc_closing_duration(istruc) + elapsed = real(t, 4) - src_struc_t_state(istruc) + ! + if (src_struc_closing_duration(istruc) <= 0.0 .or. & + elapsed >= src_struc_closing_duration(istruc)) then + ! + src_struc_status(istruc) = 0 + src_struc_fraction_open(istruc) = 0.0 + ! + else + ! + src_struc_fraction_open(istruc) = 1.0 - elapsed / src_struc_closing_duration(istruc) + ! + endif ! endif ! @@ -1181,6 +1268,10 @@ subroutine read_toml_src_structures(filename, structures, ierr) ! submergence_ratio = ... ! culvert submergence threshold h_dn/h_up (-) ! rules_open = "(z1<0.5 | z2-z1>0.05) & z2<1.5" ! optional trigger expr ! rules_close = "z2>2.0" ! optional trigger expr + ! interruptible = true ! optional, default false: + ! ! allow an in-progress opening/closing ramp to be + ! ! reversed mid-way by the opposite rule (resumes + ! ! from the current fraction; no jump). ! ! Per-type required keys (enforced on parse): ! pump : name, src_1, src_2, q @@ -1470,6 +1561,11 @@ subroutine read_toml_src_structures(filename, structures, ierr) call get_value(tbl_struct, 'rules_close', rule_str, stat=stat) if (allocated(rule_str)) structures(i)%rule_close = rule_str ! + ! Optional: allow an in-progress transition to be reversed mid-ramp by + ! the opposite rule. Default false (transitions run to completion). + ! + call get_value(tbl_struct, 'interruptible', structures(i)%interruptible, .false., stat=stat) + ! enddo ! contains @@ -1947,6 +2043,25 @@ subroutine write_src_structures_log_summary() ! endif ! + ! Interruptible flag, only meaningful (and only printed) for rule-driven + ! structures. + ! + if (src_struc_rule_open(i) > 0 .or. src_struc_rule_close(i) > 0) then + ! + if (src_struc_interruptible(i) == 1) then + ! + write(logstr,'(a22,1x,a)') ' interruptible :', 'true' + ! + else + ! + write(logstr,'(a22,1x,a)') ' interruptible :', 'false' + ! + endif + ! + call write_log(logstr, 0) + ! + endif + ! ! Opening/closing durations. For gate structures these are always ! printed (above); for other types only print if rules are set and ! the duration is non-zero (non-default). From d4ac3aa65a0ffd1cf7e9fb645dc02d415df6e101 Mon Sep 17 00:00:00 2001 From: vanasseltk <167875592+vanasseltk@users.noreply.github.com> Date: Wed, 3 Jun 2026 09:54:39 +0200 Subject: [PATCH 65/65] commits file changes --- source/src/sfincs_input.f90 | 4 +- source/src/sfincs_src_structures.f90 | 107 ++++++++++++++++++--------- 2 files changed, 74 insertions(+), 37 deletions(-) diff --git a/source/src/sfincs_input.f90 b/source/src/sfincs_input.f90 index 03ed34732..45d5469e8 100644 --- a/source/src/sfincs_input.f90 +++ b/source/src/sfincs_input.f90 @@ -86,7 +86,7 @@ subroutine read_sfincs_input() use sfincs_data use sfincs_date use sfincs_error - use sfincs_src_structures, only: drnfile + use sfincs_src_structures, only: drnfile, dkbfile use sfincs_discharges, only: srcfile, disfile, netsrcdisfile ! implicit none @@ -243,6 +243,7 @@ subroutine read_sfincs_input() call get_keyword(500, 'weirfile', weirfile, 'none') ! weirs polyline file call get_keyword(500, 'manningfile', manningfile, 'none') ! spatially-varying Manning n file call get_keyword(500, 'drnfile', drnfile, 'none') ! drainage-structures (pumps/gates/culverts) TOML file + call get_keyword(500, 'dkbfile', dkbfile, 'none') ! dike breach structures TOML file call get_keyword(500, 'urbfile', urbfile, 'none') ! urban drainage zones TOML file call get_keyword(500, 'volfile', volfile, 'none') ! depression-storage volume file ! @@ -590,6 +591,7 @@ subroutine read_sfincs_input() disfile = 'none' netsrcdisfile = 'none' drnfile = 'none' + dkbfile = 'none' urbfile = 'none' ! meteo3d = .false. diff --git a/source/src/sfincs_src_structures.f90 b/source/src/sfincs_src_structures.f90 index e58b6a773..f21dfba4d 100644 --- a/source/src/sfincs_src_structures.f90 +++ b/source/src/sfincs_src_structures.f90 @@ -223,6 +223,12 @@ module sfincs_src_structures ! character(len=256), public :: drnfile ! + ! Input file path (sfincs.inp keyword 'dkbfile'); 'none' when no dike + ! breach file is supplied. Entries are appended to the same flat arrays + ! as drnfile structures so the runtime sees one unified pool. + ! + character(len=256), public :: dkbfile + ! ! Cell mapping ! integer, public :: nr_src_structures @@ -334,6 +340,12 @@ subroutine initialize_src_structures() logical :: ok, is_toml character(len=512) :: toml_path ! + ! dkbfile locals + ! + type(t_src_structure), allocatable :: src_structures_dkb(:) + type(t_src_structure), allocatable :: src_structures_all(:) + integer :: n_drn, n_dkb + ! ! Marshal locals ! integer :: i, ierr_parse @@ -353,55 +365,75 @@ subroutine initialize_src_structures() ! drainage_structures = .false. ! - if (drnfile(1:4) == 'none') return - ! - ! Existence check - ! - ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) - ! - ! Probe TOML / convert legacy / re-read TOML - ! - ! Probe: try to parse as TOML. This is a cheap check; on success we - ! discard the probe table and let read_toml_src_structures re-parse, - ! which keeps the two code paths decoupled. + if (drnfile(1:4) == 'none' .and. dkbfile(1:4) == 'none') return ! - call toml_load(probe_top, drnfile, error=probe_err) + ! Read drnfile (drainage structures: pumps / culverts / gates). + ! Skipped when drnfile = 'none'; dkbfile-only runs are valid. ! - is_toml = .not. allocated(probe_err) - ! - if (allocated(probe_err)) deallocate(probe_err) - if (allocated(probe_top)) deallocate(probe_top) - ! - if (is_toml) then + if (drnfile(1:4) /= 'none') then ! - ! TOML path: read drnfile directly. + ok = check_file_exists(drnfile, 'Drainage points drn file', .true.) ! - toml_path = drnfile + ! Probe TOML / convert legacy / re-read TOML ! - else + call toml_load(probe_top, drnfile, error=probe_err) ! - ! Legacy path: transcribe to a TOML sibling file, then fall through - ! to the TOML reader. The converter derives its own output path from - ! drnfile. + is_toml = .not. allocated(probe_err) ! - call convert_legacy_to_toml(drnfile, toml_path, ierr_conv) + if (allocated(probe_err)) deallocate(probe_err) + if (allocated(probe_top)) deallocate(probe_top) ! - if (ierr_conv /= 0) then - ! - write(logstr,'(a,a,a)')' Error ! Failed to convert legacy drn file "', trim(drnfile), & - '" to TOML; see preceding log entries for the reason' + if (is_toml) then + toml_path = drnfile + else + call convert_legacy_to_toml(drnfile, toml_path, ierr_conv) + if (ierr_conv /= 0) then + write(logstr,'(a,a,a)')' Error ! Failed to convert legacy drn file "', trim(drnfile), & + '" to TOML; see preceding log entries for the reason' + call stop_sfincs(trim(logstr), -1) + endif + endif + ! + call read_toml_src_structures(trim(toml_path), src_structures, ierr_toml) + ! + if (ierr_toml /= 0) then + write(logstr,'(a,a,a)')' Error ! Failed to load TOML src_structures file ', trim(toml_path), ' !' call stop_sfincs(trim(logstr), -1) - ! endif ! endif ! - call read_toml_src_structures(trim(toml_path), src_structures, ierr_toml) + ! If a dike breach file is also provided, read it and append its + ! entries to src_structures so the marshal sees one unified array. ! - if (ierr_toml /= 0) then + if (dkbfile(1:4) /= 'none') then + ! + ok = check_file_exists(dkbfile, 'Dike breach dkb file', .true.) + ! + call read_toml_src_structures(trim(dkbfile), src_structures_dkb, ierr_toml) + ! + if (ierr_toml /= 0) then + write(logstr,'(a,a,a)')' Error ! Failed to load TOML dkb file ', trim(dkbfile), ' !' + call stop_sfincs(trim(logstr), -1) + endif ! - write(logstr,'(a,a,a)')' Error ! Failed to load TOML src_structures file ', trim(toml_path), ' !' - call stop_sfincs(trim(logstr), -1) + if (allocated(src_structures_dkb)) then + ! + n_drn = 0 + if (allocated(src_structures)) n_drn = size(src_structures) + n_dkb = size(src_structures_dkb) + ! + allocate(src_structures_all(n_drn + n_dkb)) + ! + if (n_drn > 0) src_structures_all(1:n_drn) = src_structures(1:n_drn) + src_structures_all(n_drn+1 : n_drn+n_dkb) = src_structures_dkb(1:n_dkb) + ! + if (allocated(src_structures)) deallocate(src_structures) + if (allocated(src_structures_dkb)) deallocate(src_structures_dkb) + ! + call move_alloc(src_structures_all, src_structures) + ! + endif ! endif ! @@ -449,7 +481,9 @@ subroutine initialize_src_structures() ! endif ! - drainage_structures = .true. + ! drainage_structures is set after marshalling once src_struc_type is + ! populated; dike_breaching is set the same way (line ~755). + ! Both are resolved below via any() on the flat type array. ! ! Allocate flat arrays to size nr_src_structures and seed defaults. ! @@ -720,7 +754,8 @@ subroutine initialize_src_structures() ! endif ! - dike_breaching = any(src_struc_type == structure_dike_breach) + dike_breaching = any(src_struc_type == structure_dike_breach) + drainage_structures = any(src_struc_type /= structure_dike_breach) ! ! Write the per-structure descriptive block to the log file. ! Emitted before the gate-status seeding so the per-gate init status