diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings.f90
index 3dbf1d4b2b..902e27d9cc 100644
--- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings.f90
+++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings.f90
@@ -423,6 +423,7 @@ subroutine fill_open_boundary_cells_with_inner_values_fewer(number_of_links, lin
end subroutine fill_open_boundary_cells_with_inner_values_fewer
subroutine findexternalboundarypoints() ! find external boundary points
+ use string_module, only: strsplit
use m_netw
use m_flow, filetype_hide => filetype ! Two stages: 1 = collect elsets for which data is provided
use m_flowgeom ! 2 = add relations between elsets and their providers
@@ -442,102 +443,107 @@ subroutine findexternalboundarypoints() ! find external boundary points
use m_filez, only: oldfil, doclose
use messagehandling, only: msgbuf, msg_flush, err_flush
+ ! Local variables
+ character(len=256), dimension(:), allocatable :: file_names !< list of external forcing filenames
character(len=256) :: filename
- integer :: filetype
+ character(len=256) :: filename_new !< filename being processed
+ character(len=64) :: varname
+ logical :: stat !< status of inquire
+ logical :: ext_force_bnd_used
+ real(kind=dp) :: return_time
integer, allocatable :: kce(:) ! kc edges (numl)
integer, allocatable :: ke(:) ! kc edges (numl)
- logical :: jawel
+ integer :: filetype
integer :: ja_ext_force
- logical :: ext_force_bnd_used
- integer :: ierr, method
- real(kind=dp) :: return_time
- integer :: numz, numu, nums, numtm, numsd, numt, numuxy, numn, num1d2d, numqh, numw, numtr, numsf
+ integer :: ierr
+ integer :: method
+ integer :: numz
+ integer :: numu
+ integer :: nums
+ integer :: numtm
+ integer :: numsd
+ integer :: numt
+ integer :: numuxy
+ integer :: numn
+ integer :: num1d2d
+ integer :: numqh
+ integer :: numw
+ integer :: numtr
+ integer :: numsf
integer :: nx
integer :: ierror
integer :: num_bc_ini_blocks
- character(len=64) :: varname
-
+ integer :: i !< loop counter
+
+ ! Initialize
jatimespace = 1
-
return_time = 0
ja_ext_force = 0
ext_force_bnd_used = .false.
- if (len(trim(md_extfile)) > 0) then
- inquire (file=trim(md_extfile), exist=jawel)
- if (jawel) then
- if (mext /= 0) then
- ! Close first, if left open after prior flow_geominit().
- ! NOTE: AvD: this if-check relies on the fact that mext is *not* set to 0 in default_fm_external_forcing_data(), when reinitializing an already initialized model.
- call doclose(mext)
- end if
-
- call oldfil(mext, md_extfile)
- call split_filename(md_extfile, md_extfile_dir, filename) ! Remember base dir for this ext file
- ja_ext_force = 1
- else
- call qnerror('External forcing file '''//trim(md_extfile)//''' not found.', ' ', ' ')
- write (msgbuf, '(a,a,a)') 'External forcing file ''', trim(md_extfile), ''' not found.'
- call err_flush()
- end if
- end if
- if (len(trim(md_extfile_new)) > 0) then
- inquire (file=trim(md_extfile_new), exist=jawel)
- if (jawel) then
- ext_force_bnd_used = .true.
- else
- call qnerror('Boundary external forcing file '''//trim(md_extfile_new)//''' not found.', ' ', ' ')
- write (msgbuf, '(a,a,a)') 'Boundary external forcing file ''', trim(md_extfile_new), ''' not found.'
- call err_flush()
- end if
- end if
-
-! if (ja_ext_force == 0 .and. .not. ext_force_bnd_used) then
-! return
-! endif
+ ! Allocate and initialize temporary arrays
+ ! deallocate xe, ye, and xyen arrays if allocated
if (allocated(xe)) then
- deallocate (xe, ye, xyen) ! centre points of all net links, also needed for opening closed boundaries
- end if
-
- !mx1Dend = 0 ! count MAX nr of 1D endpoints
- !do L = 1,numl1D
- ! if ( kn(3,L) == 1) then ! zeker weten
- ! k1 = kn(1,L) ; k2 = kn(2,L)
- ! if (nmk(k1) == 1 .and. nmk(k2) == 2 .and. lne(1,L) < 0 .or. &
- ! nmk(k2) == 1 .and. nmk(k1) == 2 .and. lne(2,L) < 0 ) then
- ! mx1Dend = mx1Dend + 1
- ! endif
- ! endif
- !enddo
- !
- !
- !nx = numl + mx1Dend
+ ! centre points of all net links, also needed for opening closed boundaries
+ deallocate(xe)
+ deallocate(ye)
+ deallocate(xyen)
+ end if
! count number of 2D links and 1D endpoints
call count_links(mx1Dend, Nx)
- allocate (xe(nx), stat=ierr)
- xe = 0 ! used in findexternalboundarypoints
+ ! reallocate xe, ye, and xyen arrays
+ allocate(xe(nx), stat=ierr)
+ xe = 0.0_dp ! used in findexternalboundarypoints
call aerr('xe (nx)', ierr, nx)
- allocate (ye(nx), stat=ierr)
- ye = 0
+
+ allocate(ye(nx), stat=ierr)
+ ye = 0.0_dp
call aerr('ye (nx)', ierr, nx)
- allocate (xyen(2, nx), stat=ierr)
+
+ allocate(xyen(2, nx), stat=ierr)
xyen = 0.0_dp
call aerr('xyen(2, nx)', ierr, nx)
- ! some temp arrays
-
if (allocated(kez)) then
! If flow_geominit was called separately from a flow_modelinit:
- deallocate (kez, keu, kes, ketm, kesd, keuxy, ket, ken, ke1d2d, keg, ked, kep, kedb, keklep, kevalv, kegs, kegen, itpez, itpenz, itpeu, itpenu, kew)
+ deallocate(kez)
+ deallocate(keu)
+ deallocate(kes)
+ deallocate(ketm)
+ deallocate(kesd)
+ deallocate(keuxy)
+ deallocate(ket)
+ deallocate(ken)
+ deallocate(ke1d2d)
+ deallocate(keg)
+ deallocate(ked)
+ deallocate(kep)
+ deallocate(kedb)
+ deallocate(keklep)
+ deallocate(kevalv)
+ deallocate(kegs)
+ deallocate(kegen)
+ deallocate(itpez)
+ deallocate(itpenz)
+ deallocate(itpeu)
+ deallocate(itpenu)
+ deallocate(kew)
end if
+
if (allocated(ftpet)) then
- deallocate (ftpet)
+ deallocate(ftpet)
end if
- allocate (kce(nx), ke(nx), kez(nx), keu(nx), kes(nx), ketm(nx), kesd(nx), keuxy(nx), ket(nx), ken(nx), ke1d2d(nx), keg(nx), ked(nx), kep(nx), kedb(nx), keklep(nx), kevalv(nx), kegs(nx), kegen(nx), itpez(nx), itpenz(nx), itpeu(nx), itpenu(nx), kew(nx), ftpet(nx), stat=ierr)
- call aerr('kce(nx), ke(nx), kez(nx), keu(nx), kes(nx), ketm(nx), kesd(nx), keuxy(nx), ket(nx), ken(nx), ke1d2d(nx), keg(nx), ked(nx), kep(nx), kedb(nx), keklep(nx), kevalv(nx), kegs(nx), kegen(nx), itpez(nx), itpenz(nx), itpeu(nx) , itpenu(nx), kew(nx), ftpet(nx)', ierr, 17 * nx)
+
+ allocate(kce(nx), ke(nx), kez(nx), keu(nx), kes(nx), ketm(nx), kesd(nx), keuxy(nx), ket(nx), ken(nx), ke1d2d(nx), keg(nx), &
+ ked(nx), kep(nx), kedb(nx), keklep(nx), kevalv(nx), kegs(nx), kegen(nx), itpez(nx), itpenz(nx), itpeu(nx), itpenu(nx), &
+ kew(nx), ftpet(nx), stat=ierr)
+ call aerr('kce(nx), ke(nx), kez(nx), keu(nx), kes(nx), ketm(nx), kesd(nx), keuxy(nx), ket(nx), ken(nx), ke1d2d(nx), &
+ keg(nx), ked(nx), kep(nx), kedb(nx), keklep(nx), kevalv(nx), kegs(nx), kegen(nx), itpez(nx), itpenz(nx), itpeu(nx), &
+ itpenu(nx), kew(nx), ftpet(nx)', ierr, 17 * nx)
+
kce = 0
ke = 0
kez = 0
@@ -564,45 +570,45 @@ subroutine findexternalboundarypoints() ! find external boundary points
ftpet = 1e6_dp
if (allocated(ketr)) then
- deallocate (ketr)
+ deallocate(ketr)
end if
- allocate (ketr(nx, 1), stat=ierr)
+ allocate(ketr(nx, 1), stat=ierr)
call aerr('ketr(nx,1)', ierr, nx)
ketr = 0
if (allocated(nbndtr)) then
- deallocate (nbndtr)
+ deallocate(nbndtr)
end if
- allocate (nbndtr(1), stat=ierr)
+ allocate(nbndtr(1), stat=ierr)
call aerr('nbndtr(1)', ierr, 1)
nbndtr = 0
if (allocated(trnames)) then
- deallocate (trnames)
+ deallocate(trnames)
end if
- allocate (trnames(1), stat=ierr)
+ allocate(trnames(1), stat=ierr)
call aerr('trnames(1)', ierr, 1)
trnames(1) = ''
numtracers = 0
if (allocated(kesf)) then
- deallocate (kesf)
+ deallocate(kesf)
end if
- allocate (kesf(1, nx), stat=ierr) ! would have been nice to have stmpar%lsedsus,
- call aerr('kesf(1,nx)', ierr, nx) ! but no can do, jammer de bammer...
+ allocate(kesf(1, nx), stat=ierr)
+ call aerr('kesf(1,nx)', ierr, nx)
kesf = 0
if (allocated(nbndsf)) then
- deallocate (nbndsf)
+ deallocate(nbndsf)
end if
- allocate (nbndsf(1), stat=ierr)
+ allocate(nbndsf(1), stat=ierr)
call aerr('nbndsf(1)', ierr, 1)
nbndsf = 0
if (allocated(sfnames)) then
- deallocate (sfnames)
+ deallocate(sfnames)
end if
- allocate (sfnames(1), stat=ierr)
+ allocate(sfnames(1), stat=ierr)
call aerr('sfnames(1)', ierr, 1)
sfnames = ''
numfracs = 0
@@ -610,24 +616,24 @@ subroutine findexternalboundarypoints() ! find external boundary points
call make_mirrorcells(Nx, xe, ye, xyen, kce, ke, ierror)
if (jampi == 1) then
-! disable mirror cells that are not mirror cells in the whole model by setting kce=0
+ ! disable mirror cells that are not mirror cells in the whole model by setting kce=0
call partition_reduce_mirrorcells(Nx, kce, ke, ierror)
end if
nbndz = 0 ! startindex waterlevel bnds
- nbndu = 0 ! startindex velocity bnds
- nbnds = 0 ! startindex salinity bnds
+ nbndu = 0 ! startindex velocity bnds
+ nbnds = 0 ! startindex salinity bnds
nbndtm = 0 ! startindex temperature bnds
nbndt = 0 ! startindex tangential vel. bnds
nbnduxy = 0 ! startindex uxuy vel. bnds
- nbndn = 0 ! startindex normal vel. bnds
+ nbndn = 0 ! startindex normal vel. bnds
nbnd1d2d = 0 ! startindex 1d2d bnds
ngate = 0 ! startindex gate links
ncdam = 0 ! startindex cdam links
npump = 0 ! startindex pump links
nbndw = 0 ! startindex wave energy bnds
- nqbnd = 0 ! nr of q sections or specified q bnd's
+ nqbnd = 0 ! nr of q sections or specified q bnd's
nqhbnd = 0 ! nr of qh boundary sections or specified qh bnd's
ngatesg = 0 ! nr of gate signals or specified gates ! not in loop below because flow links not ready yet
ncdamsg = 0 ! nr of controllable dam signals
@@ -635,11 +641,50 @@ subroutine findexternalboundarypoints() ! find external boundary points
nshiptxy = 0 ! nr of ship xyt signals
nwbnd = 0 ! nr of wave-energy boundaries
+ ! Check if external forcing files exist
num_bc_ini_blocks = 0
- if (ext_force_bnd_used) then
- ! first read the ini-format *.ext external forcings file (default file format for boundary conditions)
- call read_location_files_from_boundary_blocks(trim(md_extfile_new), nx, kce, num_bc_ini_blocks, &
- numz, numu, nums, numtm, numsd, numt, numuxy, numn, num1d2d, numqh, numw, numtr, numsf)
+
+ ! Old external forcing file
+ if (len_trim(md_extfile) > 0) then
+ inquire(file=trim(md_extfile), exist=stat)
+ if (stat) then
+ if (mext /= 0) then
+ ! Close first, if left open after prior flow_geominit().
+ ! NOTE: AvD: this if-check relies on the fact that mext is *not* set to 0 in default_fm_external_forcing_data(), when reinitializing an already initialized model.
+ call doclose(mext)
+ end if
+
+ call oldfil(mext, md_extfile)
+ call split_filename(md_extfile, md_extfile_dir, filename) ! Remember base dir for this ext file
+ ja_ext_force = 1
+ else
+ call qnerror('External forcing file '''//trim(md_extfile)//''' not found.', ' ', ' ')
+ write (msgbuf, '(a,a,a)') 'External forcing file ''', trim(md_extfile), ''' not found.'
+ call err_flush()
+ end if
+ end if
+
+ ! New external forcing file
+ if (len_trim(md_extfile_new) > 0) then
+ ! Split md_extfile_new in separate file names (separated by spaces)
+ call strsplit(trim(md_extfile_new), 1, file_names, 1)
+
+ ! Loop over files and check existence
+ do i = 1, size(file_names)
+ filename_new = trim(file_names(i))
+
+ inquire(file=filename_new, exist=stat)
+ if (stat) then
+ ! first read the ini-format *.ext external forcings file (default file format for boundary conditions)
+ call read_location_files_from_boundary_blocks(filename_new, nx, kce, num_bc_ini_blocks, &
+ numz, numu, nums, numtm, numsd, numt, numuxy, numn, num1d2d, numqh, numw, numtr, numsf)
+ else
+ call qnerror('Boundary external forcing file '''//filename_new//''' not found.', ' ', ' ')
+ write (msgbuf, '(a,a,a)') 'Boundary external forcing file ''', filename_new, ''' not found.'
+ call err_flush()
+ end if
+
+ end do
end if
do while (ja_ext_force == 1) ! read legacy format *.ext file
@@ -658,14 +703,16 @@ subroutine findexternalboundarypoints() ! find external boundary points
jatimespace = 1 ! module is to be used
- call processexternalboundarypoints(qid, filename, filetype, return_time, nx, kce, numz, numu, nums, numtm, numsd, numt, numuxy, numn, num1d2d, numqh, numw, numtr, numsf, 1.0_dp, transformcoef)
+ call processexternalboundarypoints(qid, filename, filetype, return_time, nx, kce, numz, numu, nums, &
+ numtm, numsd, numt, numuxy, numn, num1d2d, numqh, numw, numtr, numsf, 1.0_dp, transformcoef)
end if
end do
- deallocate (kce)
- deallocate (ke)
+ ! Deallocate temporary arrays
+ deallocate(kce)
+ deallocate(ke)
if (mext /= 0) then
rewind (mext) ! prepare input file
diff --git a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90 b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90
index ef2c462bd5..f34e49e2f2 100644
--- a/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90
+++ b/src/engines_gpl/dflowfm/packages/dflowfm_kernel/src/dflowfm_kernel/timespace/fm_external_forcings_init.f90
@@ -39,12 +39,12 @@
!> reads new external forcings file and makes required initialisations. Only to be called once as part of fm_initexternalforcings.
module subroutine init_new(external_force_file_name, iresult)
use properties, only: get_version_number, prop_file
- use tree_structures, only: tree_data, tree_create, tree_destroy, tree_num_nodes, tree_count_nodes_byname, tree_get_name
+ use tree_structures, only: tree_data, tree_create, tree_create_node, tree_destroy, tree_num_nodes, tree_count_nodes_byname, tree_get_name
use messageHandling, only: warn_flush, err_flush, msgbuf, LEVEL_FATAL
use fm_external_forcings_data, only: nbndz, itpenz, nbndu, itpenu, thrtt, set_lateral_count_in_external_forcings_file
use m_flowgeom, only: ba
use m_laterals, only: balat, qplat, lat_ids, n1latsg, n2latsg, kclat, numlatsg, nnlat
- use string_module, only: str_tolower
+ use string_module, only: str_tolower, strsplit
use system_utils, only: split_filename
use unstruc_model, only: ExtfileNewMajorVersion, ExtfileNewMinorVersion
use m_ec_parameters, only: provFile_uniform
@@ -63,6 +63,7 @@ module subroutine init_new(external_force_file_name, iresult)
integer :: initial_threshold_abort
logical :: res
logical :: is_successful
+ type(tree_data), pointer :: main_ptr !< main tree of extForceBnd-file
type(tree_data), pointer :: bnd_ptr !< tree of extForceBnd-file's [boundary] blocks
type(tree_data), pointer :: node_ptr
integer :: istat
@@ -74,143 +75,164 @@ module subroutine init_new(external_force_file_name, iresult)
integer :: ib, ibqh, ibt
integer :: maxlatsg, max_num_src
integer :: major, minor
+ character(len=INI_VALUE_LEN), dimension(:), allocatable :: file_names
character(len=:), allocatable :: file_name
+ integer :: i_filename
integer, allocatable :: itpenzr(:), itpenur(:)
iresult = DFM_NOERR
- file_name = trim(external_force_file_name)
- if (len_trim(file_name) <= 0) then
- ! empty line in MDU is allowed: exit without error
- return
- end if
-
res = .true.
- call tree_create(file_name, bnd_ptr)
- call prop_file('ini', file_name, bnd_ptr, istat)
- if (istat /= 0) then
- write (msgbuf, '(a,a,a)') 'External forcing file ''', trim(file_name), ''' could not be read'
- call err_flush()
- iresult = DFM_WRONGINPUT
- return
- end if
+ ! Trim external_force_file_name and split in case of multiple files
+ call strsplit(trim(external_force_file_name), 1, file_names, 1)
- ! check FileVersion
- major = 1
- minor = 0
- call get_version_number(bnd_ptr, major=major, minor=minor, success=is_successful)
- if ((major /= ExtfileNewMajorVersion .and. major /= 1) .or. minor > ExtfileNewMinorVersion) then
- write (msgbuf, '(a,i0,".",i2.2,a,i0,".",i2.2,a)') 'Unsupported format of new external forcing file detected in ''' &
- //file_name//''': v', major, minor, '. Current format: v', ExtfileNewMajorVersion, ExtfileNewMinorVersion, &
- '. Ignoring this file.'
- call err_flush()
- iresult = DFM_WRONGINPUT
+ if (len_trim(file_names(1)) <= 0) then
+ ! empty line in MDU is allowed: exit without error
return
end if
- call init_registered_items()
-
- call split_filename(file_name, base_dir, fnam) ! Remember base dir of input file, to resolve all refenced files below w.r.t. that base dir.
+ ! Create main tree for external forcing files
+ call tree_create('main', main_ptr)
- num_items_in_file = tree_num_nodes(bnd_ptr)
+ ! Loop over all specified external forcing files and create nodes for each file
+ do i_filename = 1, size(file_names)
+ file_name = trim(file_names(i_filename))
- ! Build temporary reverse lookup table that maps boundary block # in file -> boundary condition nr in openbndsect (separate for u and z).
- allocate (itpenzr(num_items_in_file))
- allocate (itpenur(num_items_in_file))
- itpenzr(:) = 0
- itpenur(:) = 0
- do ibt = 1, nbndz
- ib = itpenz(ibt)
- if (ib > 0 .and. ib <= num_items_in_file) then
- itpenzr(ib) = ibt
+ call tree_create_node(main_ptr, file_name, bnd_ptr)
+ call prop_file('ini', file_name, bnd_ptr, istat)
+ if (istat /= DFM_NOERR) then
+ write (msgbuf, '(a,a,a)') 'External forcing file ''', file_name, ''' could not be read'
+ call err_flush()
+ iresult = DFM_WRONGINPUT
+ return
end if
- end do
- do ibt = 1, nbndu
- ib = itpenu(ibt)
- if (ib > 0 .and. ib <= num_items_in_file) then
- itpenur(ib) = ibt
+
+ ! check FileVersion
+ major = 1
+ minor = 0
+ call get_version_number(bnd_ptr, major=major, minor=minor, success=is_successful)
+ if ((major /= ExtfileNewMajorVersion .and. major /= 1) .or. minor > ExtfileNewMinorVersion) then
+ write (msgbuf, '(a,i0,".",i2.2,a,i0,".",i2.2,a)') 'Unsupported format of new external forcing file detected in ''' &
+ //file_name//''': v', major, minor, '. Current format: v', ExtfileNewMajorVersion, ExtfileNewMinorVersion, &
+ '. Ignoring this file.'
+ call err_flush()
+ iresult = DFM_WRONGINPUT
+ return
end if
end do
- ! Allocate lateral provider array now, just once, because otherwise realloc's in the loop would destroy target arrays in ecInstance.
- maxlatsg = tree_count_nodes_byname(bnd_ptr, 'lateral')
- if (maxlatsg > 0) then
- call realloc(balat, maxlatsg, keepExisting=.false., fill=0.0_dp)
- call realloc(qplat, [max(1, kmx), maxlatsg], keepExisting=.false., fill=0.0_dp)
- call realloc(lat_ids, maxlatsg, keepExisting=.false.)
- call realloc(n1latsg, maxlatsg, keepExisting=.false., fill=0)
- call realloc(n2latsg, maxlatsg, keepExisting=.false., fill=0)
- end if
-
- ! Allocate source-sink related arrays now, just once, because otherwise realloc's in the loop would destroy target arrays in ecInstance.
- max_num_src = tree_count_nodes_byname(bnd_ptr, 'sourcesink')
- if (max_num_src > 0) then
- call reallocsrc(max_num_src, 0)
- end if
+ call init_registered_items()
- ib = 0
- ibqh = 0
- initial_threshold_abort = threshold_abort
- threshold_abort = LEVEL_FATAL
- do i = 1, num_items_in_file
- node_ptr => bnd_ptr%child_nodes(i)%node_ptr
- group_name = trim(tree_get_name(node_ptr))
+ do i_filename = 1, size(file_names)
+ bnd_ptr => main_ptr%child_nodes(i_filename)%node_ptr ! get pointer to current ext forcing file tree
+ file_name = trim(file_names(i_filename))
- select case (str_tolower(group_name))
- case ('general')
- ! General block, was already read.
+ call split_filename(file_name, base_dir, fnam) ! Remember base dir of input file, to resolve all refenced files below w.r.t. that base dir.
- case ('boundary')
- res = res .and. init_boundary_forcings(node_ptr, base_dir, file_name, group_name, itpenzr, itpenur, ib, ibqh)
+ num_items_in_file = tree_num_nodes(bnd_ptr) ! number of items in this ext forcing file
- case ('lateral')
- res = res .and. init_lateral_forcings(node_ptr, base_dir, i, major)
+ ! Build temporary reverse lookup table that maps boundary block # in file -> boundary condition nr in openbndsect (separate for u and z).
+ allocate (itpenzr(num_items_in_file))
+ allocate (itpenur(num_items_in_file))
+ itpenzr(:) = 0
+ itpenur(:) = 0
+ do ibt = 1, nbndz
+ ib = itpenz(ibt)
+ if (ib > 0 .and. ib <= num_items_in_file) then
+ itpenzr(ib) = ibt
+ end if
+ end do
+ do ibt = 1, nbndu
+ ib = itpenu(ibt)
+ if (ib > 0 .and. ib <= num_items_in_file) then
+ itpenur(ib) = ibt
+ end if
+ end do
- case ('meteo')
- res = res .and. init_meteo_forcings(node_ptr, base_dir, file_name, group_name)
+ ! Allocate lateral provider array now, just once, because otherwise realloc's in the loop would destroy target arrays in ecInstance.
+ maxlatsg = tree_count_nodes_byname(bnd_ptr, 'lateral')
+ if (maxlatsg > 0) then
+ call realloc(balat, maxlatsg, keepExisting=.false., fill=0.0_dp)
+ call realloc(qplat, [max(1, kmx), maxlatsg], keepExisting=.false., fill=0.0_dp)
+ call realloc(lat_ids, maxlatsg, keepExisting=.false.)
+ call realloc(n1latsg, maxlatsg, keepExisting=.false., fill=0)
+ call realloc(n2latsg, maxlatsg, keepExisting=.false., fill=0)
+ end if
- case ('sourcesink')
- res = res .and. init_sourcesink_forcings(node_ptr, base_dir, file_name, group_name)
+ ! Allocate source-sink related arrays now, just once, because otherwise realloc's in the loop would destroy target arrays in ecInstance.
+ max_num_src = tree_count_nodes_byname(bnd_ptr, 'sourcesink')
+ if (max_num_src > 0) then
+ call reallocsrc(max_num_src, 0)
+ end if
- case default ! Unrecognized item in an ext block
- ! res remains unchanged: Not an error (support commented/disabled blocks in ext file)
- write (msgbuf, '(5a)') 'Unrecognized block in file ''', file_name, ''': [', group_name, ']. Ignoring this block.'
- call warn_flush()
- end select
- end do
- threshold_abort = initial_threshold_abort
+ ib = 0
+ ibqh = 0
+ initial_threshold_abort = threshold_abort
+ threshold_abort = LEVEL_FATAL
+ do i = 1, num_items_in_file
+ node_ptr => bnd_ptr%child_nodes(i)%node_ptr
+ group_name = trim(tree_get_name(node_ptr))
+
+ select case (str_tolower(group_name))
+ case ('general')
+ ! General block, was already read.
+
+ case ('boundary')
+ is_successful = init_boundary_forcings(node_ptr, base_dir, file_name, group_name, itpenzr, itpenur, ib, ibqh)
+ res = res .and. is_successful
+
+ case ('lateral')
+ is_successful = init_lateral_forcings(node_ptr, base_dir, i, major)
+ res = res .and. is_successful
+
+ case ('meteo')
+ is_successful = init_meteo_forcings(node_ptr, base_dir, file_name, group_name)
+ res = res .and. is_successful
+
+ case ('sourcesink')
+ is_successful = init_sourcesink_forcings(node_ptr, base_dir, file_name, group_name)
+ res = res .and. is_successful
+
+ case default ! Unrecognized item in an ext block
+ ! res remains unchanged: Not an error (support commented/disabled blocks in ext file)
+ write (msgbuf, '(5a)') 'Unrecognized block in file ''', file_name, ''': [', group_name, ']. Ignoring this block.'
+ call warn_flush()
+ end select
+ end do
+ threshold_abort = initial_threshold_abort
- if (allocated(itpenzr)) then
- deallocate (itpenzr)
- end if
- if (allocated(itpenur)) then
- deallocate (itpenur)
- end if
- if (numlatsg > 0) then
- do n = 1, numlatsg
- balat(n) = 0.0_dp
- do k1 = n1latsg(n), n2latsg(n)
- k = nnlat(k1)
- if (k > 0) then
- if (.not. is_ghost_node(k)) then
- balat(n) = balat(n) + ba(k)
+ if (allocated(itpenzr)) then
+ deallocate (itpenzr)
+ end if
+ if (allocated(itpenur)) then
+ deallocate (itpenur)
+ end if
+ if (numlatsg > 0) then
+ do n = 1, numlatsg
+ balat(n) = 0.0_dp
+ do k1 = n1latsg(n), n2latsg(n)
+ k = nnlat(k1)
+ if (k > 0) then
+ if (.not. is_ghost_node(k)) then
+ balat(n) = balat(n) + ba(k)
+ end if
end if
- end if
+ end do
end do
- end do
- if (jampi > 0) then
- call reduce_sum(numlatsg, balat)
- end if
- if (allocated(kclat)) then
- deallocate (kclat)
+ if (jampi > 0) then
+ call reduce_sum(numlatsg, balat)
+ end if
+ if (allocated(kclat)) then
+ deallocate (kclat)
+ end if
end if
- end if
- call check_file_tree_for_deprecated_keywords(bnd_ptr, deprecated_ext_keywords, istat, prefix='While reading '''//trim(file_name)//'''')
+ call check_file_tree_for_deprecated_keywords(bnd_ptr, deprecated_ext_keywords, istat, prefix='While reading '''//file_name//'''')
- call set_lateral_count_in_external_forcings_file(numlatsg) !save number of laterals to module variable
+ call set_lateral_count_in_external_forcings_file(numlatsg) !save number of laterals to module variable
+ end do
- call tree_destroy(bnd_ptr)
+ call tree_destroy(main_ptr)
if (allocated(thrtt)) then
call init_threttimes()
end if
diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/properties.f90 b/src/utils_lgpl/deltares_common/packages/deltares_common/src/properties.f90
index 910625a79f..854daa39aa 100644
--- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/properties.f90
+++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/properties.f90
@@ -332,7 +332,9 @@ subroutine prop_inifile_pointer(lu, tree)
! There could be a comment (started by #) after line continuation backslash
num_hash = 0
do i = 1, lcend ! count number of #
- if (linecont(i:i) == '#') num_hash = num_hash + 1
+ if (linecont(i:i) == '#') then
+ num_hash = num_hash + 1
+ end if
end do
if (num_hash == 0) then ! if none, it is easy
lcend = len_trim(linecont)
diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/tree_struct.f90 b/src/utils_lgpl/deltares_common/packages/deltares_common/src/tree_struct.f90
index 946ba81840..7f519ea6cc 100644
--- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/tree_struct.f90
+++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/tree_struct.f90
@@ -88,73 +88,73 @@ module tree_structures
! Public routines, types and parameters
!
public :: tree_data
- public :: tree_create, tree_create_node, tree_add_node, tree_get_node_by_name, tree_num_nodes, &
- tree_count_nodes_byname, tree_disconnect_node, &
- tree_get_data_ptr, tree_put_data, tree_get_name, tree_get_data, &
- tree_get_datatype, tree_get_data_string, &
- tree_traverse, tree_traverse_level, print_tree, &
- tree_fold, tree_destroy, tree_get_data_alloc_string, tree_remove_child_by_name
+ public :: tree_create
+ public :: tree_create_node
+ public :: tree_add_node
+ public :: tree_get_node_by_name
+ public :: tree_num_nodes
+ public :: tree_count_nodes_byname
+ public :: tree_disconnect_node
+ public :: tree_get_data_ptr
+ public :: tree_put_data
+ public :: tree_get_name
+ public :: tree_get_data
+ public :: tree_get_datatype
+ public :: tree_get_data_string
+ public :: tree_traverse
+ public :: tree_traverse_level
+ public :: print_tree
+ public :: tree_fold
+ public :: tree_destroy
+ public :: tree_get_data_alloc_string
+ public :: tree_remove_child_by_name
+
! nested function has to be public for gfortran
public :: dealloc_tree_data
contains
-! tree_create --
-! Create a new tree
-!
-! Arguments:
-! name Name of the new tree
-! tree Pointer to the new tree
-! Result:
-! The argument tree points to a new, empty tree structure or is
-! not associated
-!
+ !> Create a new tree.
+ !> After calling, the argument tree points to a new empty tree structure or is not associated
subroutine tree_create(name, tree, maxlenpar)
- character(len=*), intent(in) :: name
- type(tree_data), pointer, intent(out) :: tree
+ character(len=*), intent(in) :: name !< Name of the new tree
+ type(tree_data), pointer, intent(out) :: tree !< Pointer to the new tree
integer :: error
integer :: newsize
integer, optional :: maxlenpar
- if (present(maxlenpar)) maxlen = maxlenpar
+ if (present(maxlenpar)) then
+ maxlen = maxlenpar
+ end if
- allocate (tree, stat=error)
+ allocate(tree, stat=error)
if (error /= 0) then
- nullify (tree)
+ nullify(tree)
else
newsize = size(transfer(name, node_value))
- allocate (tree%node_name(1:newsize), stat=error)
+ allocate(tree%node_name(1:newsize), stat=error)
if (error /= 0) then
- deallocate (tree)
- nullify (tree)
+ deallocate(tree)
+ nullify(tree)
return
else
tree%node_name(1:newsize) = transfer(name, node_value)
tree%node_visit = 0
- nullify (tree%node_data)
- nullify (tree%node_data_type)
- nullify (tree%child_nodes)
+ nullify(tree%node_data)
+ nullify(tree%node_data_type)
+ nullify(tree%child_nodes)
end if
end if
end subroutine tree_create
-! tree_create_node --
-! Create a new node to the given tree or node
-!
-! Arguments:
-! tree The tree or node to which to append the new node
-! name Name of the new node
-! node Pointer to the new node
-! Result:
-! The argument node points to a new, empty node or is
-! not associated
-!
+ !< Create a new node to the given tree or node.
+ !< The argument node points to a new, empty node or is not associated
subroutine tree_create_node(tree, name, node)
- character(len=*), intent(in) :: name
- type(tree_data), pointer :: tree
- type(tree_data), pointer :: node
+ character(len=*), intent(in) :: name !> Name of the new node
+ type(tree_data), pointer :: tree !> The tree or node to which to append the new node
+ type(tree_data), pointer :: node !> Pointer to the new node
integer :: ierror
diff --git a/src/utils_lgpl/gridgeom/packages/gridgeom/src/network_data.f90 b/src/utils_lgpl/gridgeom/packages/gridgeom/src/network_data.f90
index 8975557a4e..90ed6ebd04 100644
--- a/src/utils_lgpl/gridgeom/packages/gridgeom/src/network_data.f90
+++ b/src/utils_lgpl/gridgeom/packages/gridgeom/src/network_data.f90
@@ -55,6 +55,7 @@
module network_data
+ use precision, only: dp
use m_dimens
use m_landboundary
use m_polygon
@@ -123,9 +124,10 @@ module network_data
integer, allocatable :: LC(:) !< (numl) Mask array for net links.
integer, allocatable :: LC0(:) !< Backup for lc.
real, allocatable :: RLIN(:) !< (numl) Placeholder for link values to be displayed.
- double precision, allocatable :: xe(:), ye(:) !< (numl) Edge (link) center coordinates.
- double precision, allocatable :: dxe(:) !< (numl) Edge (link) actual length. OPTIONAL. When unallocated, we default to Euclidean distance between the netnodes xk,yk.
- double precision, allocatable :: dxe0(:) !< Backup for dxe.
+ real(kind=dp), allocatable :: xe(:) !< (numl) Edge (link) center coordinates.
+ real(kind=dp), allocatable :: ye(:) !< (numl) Edge (link) center coordinates.
+ real(kind=dp), allocatable :: dxe(:) !< (numl) Edge (link) actual length. OPTIONAL. When unallocated, we default to Euclidean distance between the netnodes xk,yk.
+ real(kind=dp), allocatable :: dxe0(:) !< Backup for dxe.
integer, allocatable :: KTRI(:), KTON(:), KBT(:)
! Edge (and cell) related : ! there are more edges than flow links .....
diff --git a/test/deltares_testbench/configs/include/dimr_dflowfm_all_but_validation_cases.xml b/test/deltares_testbench/configs/include/dimr_dflowfm_all_but_validation_cases.xml
index 58fba167d7..2d688d146d 100644
--- a/test/deltares_testbench/configs/include/dimr_dflowfm_all_but_validation_cases.xml
+++ b/test/deltares_testbench/configs/include/dimr_dflowfm_all_but_validation_cases.xml
@@ -1790,6 +1790,17 @@
+
+ e02_dflowfm/f005_boundary_conditions/c160_multiple_extfiles
+ 3600.0
+
+
+
+
+
+
+
+
e02_dflowfm/f006_external_forcing/c012_spatially_varying_dicoww
3600.0