MODFLOW 6  version 6.9.0.dev0
USGS Modular Hydrologic Model
StructArray.f90
Go to the documentation of this file.
1 !> @brief This module contains the StructArrayModule
2 !!
3 !! This module contains the routines for reading a
4 !! structured list, which consists of a separate vector
5 !! for each column in the list.
6 !!
7 !<
9 
10  use kindmodule, only: i4b, dp, lgp
11  use constantsmodule, only: dzero, izero, dnodata, &
14  use simvariablesmodule, only: errmsg
27  use stlvecintmodule, only: stlvecint
28  use idmloggermodule, only: idm_log_var
31 
32  implicit none
33  private
34  public :: structarraytype
36  public :: idm_input_varname
37  public :: is_auxval
38  public :: find_auxname_index
39 
40  !> @brief type for structured array
41  !!
42  !! This type is used to read and store a list
43  !! that consists of multiple one-dimensional
44  !! vectors.
45  !!
46  !<
48  integer(I4B) :: ncol
49  integer(I4B) :: nrow
50  integer(I4B) :: blocknum
51  logical(LGP) :: deferred_shape = .false.
52  integer(I4B) :: deferred_size_init = 5
53  character(len=LENMEMPATH) :: mempath
54  character(len=LENMEMPATH) :: component_mempath
55  type(structvectortype), dimension(:), allocatable :: struct_vectors
56  integer(I4B), dimension(:), allocatable :: startidx
57  integer(I4B), dimension(:), allocatable :: numcols
58  type(modflowinputtype) :: mf6_input
59  contains
60  procedure :: mem_create_vector
62  procedure :: count
63  procedure :: get
64  procedure :: allocate_int_type
65  procedure :: allocate_dbl_type
66  procedure :: allocate_charstr_type
67  procedure :: allocate_int1d_type
68  procedure :: allocate_dbl1d_type
69  procedure :: read_param
70  procedure :: read_from_parser
72  procedure :: read_from_binary
73  procedure :: memload_vectors
74  procedure :: load_deferred_vector
75  procedure :: log_structarray_vars
76  procedure :: check_reallocate
77  procedure :: ts_update
78  procedure :: ts_update_adv
79  procedure :: ts_update_indexed
80  procedure, private :: ts_update_dedup
81 
82  end type structarraytype
83 
84 contains
85 
86  !> @brief constructor for a struct_array
87  !<
88  function constructstructarray(mf6_input, ncol, nrow, blocknum, mempath, &
89  component_mempath, size_init) result(struct_array)
90  type(modflowinputtype), intent(in) :: mf6_input
91  integer(I4B), intent(in) :: ncol !< number of columns in the StructArrayType
92  integer(I4B), intent(in) :: nrow !< number of rows in the StructArrayType
93  integer(I4B), intent(in) :: blocknum !< valid block number or 0
94  character(len=*), intent(in) :: mempath !< memory path for storing the vector
95  character(len=*), intent(in) :: component_mempath
96  integer(I4B), optional, intent(in) :: size_init !< initial deferred allocation size (default 5)
97  type(structarraytype), pointer :: struct_array !< new StructArrayType
98 
99  ! allocate StructArrayType
100  allocate (struct_array)
101 
102  ! set description of input
103  struct_array%mf6_input = mf6_input
104 
105  ! set number of arrays
106  struct_array%ncol = ncol
107 
108  ! set rows if known or set deferred
109  struct_array%nrow = nrow
110  if (struct_array%nrow == -1) then
111  struct_array%nrow = 0
112  struct_array%deferred_shape = .true.
113  if (present(size_init)) then
114  ! ignore a non-sensible value and keep the default deferred_size_init
115  if (size_init >= 1) struct_array%deferred_size_init = size_init
116  end if
117  end if
118 
119  ! set blocknum
120  if (blocknum > 0) then
121  struct_array%blocknum = blocknum
122  else
123  struct_array%blocknum = 0
124  end if
125 
126  ! set mempath
127  struct_array%mempath = mempath
128  struct_array%component_mempath = component_mempath
129 
130  ! allocate StructVectorType objects
131  allocate (struct_array%struct_vectors(ncol))
132  allocate (struct_array%startidx(ncol))
133  allocate (struct_array%numcols(ncol))
134  end function constructstructarray
135 
136  !> @brief destructor for a struct_array
137  !<
138  subroutine destructstructarray(struct_array)
139  type(structarraytype), pointer, intent(inout) :: struct_array !< StructArrayType to destroy
140  deallocate (struct_array%struct_vectors)
141  deallocate (struct_array%startidx)
142  deallocate (struct_array%numcols)
143  deallocate (struct_array)
144  nullify (struct_array)
145  end subroutine destructstructarray
146 
147  !> @brief create new vector in StructArrayType
148  !<
149  subroutine mem_create_vector(this, icol, idt, charlen, varname)
150  class(structarraytype) :: this !< StructArrayType
151  integer(I4B), intent(in) :: icol !< column to create
152  type(inputparamdefinitiontype), pointer :: idt
153  integer(I4B), optional, intent(in) :: charlen !< override character length for charstr1d
154  character(len=*), optional, intent(in) :: varname !< override the memory-manager name (default idt%mf6varname)
155  type(structvectortype) :: sv
156  integer(I4B) :: numcol
157 
158  ! initialize
159  numcol = 1
160  sv%idt => idt
161  sv%icol = icol
162  if (present(charlen)) sv%charlen = charlen
163  if (present(varname)) sv%varname_override = varname
164 
165  ! set size
166  if (this%deferred_shape) then
167  sv%size = this%deferred_size_init
168  else
169  sv%size = this%nrow
170  end if
171 
172  ! allocate array memory for StructVectorType
173  select case (idt%datatype)
174  case ('INTEGER')
175  call this%allocate_int_type(sv)
176  case ('DOUBLE')
177  call this%allocate_dbl_type(sv)
178  case ('STRING', 'KEYWORD')
179  call this%allocate_charstr_type(sv)
180  case ('INTEGER1D')
181  call this%allocate_int1d_type(sv)
182  if (sv%memtype == mtype_int2d) then
183  numcol = sv%intshape
184  end if
185  case ('DOUBLE1D')
186  call this%allocate_dbl1d_type(sv)
187  numcol = sv%intshape
188  case default
189  errmsg = 'IDM unimplemented. StructArray::mem_create_vector &
190  &type='//trim(idt%datatype)
191  call store_error(errmsg, .true.)
192  end select
193 
194  ! set the object in the Struct Array
195  this%struct_vectors(icol) = sv
196  this%numcols(icol) = numcol
197  if (icol == 1) then
198  this%startidx(icol) = 1
199  else
200  this%startidx(icol) = this%startidx(icol - 1) + this%numcols(icol - 1)
201  end if
202  end subroutine mem_create_vector
203 
204  !> @brief Create a metadata-only StructVector for a KEYWORD indicator column
205  !!
206  !! Sets idt, body_start, and head_nbody but allocates no data arrays.
207  !! Used for KEYWORD indicator columns that have been consolidated into the
208  !! SETTING column; these vectors serve only as dispatch-map entries.
209  !<
210  subroutine mem_create_metadata_vector(this, icol, idt, body_start, head_nbody)
211  class(structarraytype) :: this !< StructArrayType
212  integer(I4B), intent(in) :: icol !< column index
213  type(inputparamdefinitiontype), pointer :: idt !< input definition (for tagname lookup)
214  integer(I4B), intent(in) :: body_start !< SA column index of the head's first body (0 if none)
215  integer(I4B), intent(in) :: head_nbody !< number of body columns following the head
216  type(structvectortype) :: sv
217 
218  sv%idt => idt
219  sv%icol = icol
220  sv%body_start = body_start
221  sv%head_nbody = head_nbody
222  sv%memtype = mtype_undef
223  sv%size = 0
224 
225  this%struct_vectors(icol) = sv
226  this%numcols(icol) = 0
227  if (icol == 1) then
228  this%startidx(icol) = 1
229  else
230  this%startidx(icol) = this%startidx(icol - 1) + this%numcols(icol - 1)
231  end if
232  end subroutine mem_create_metadata_vector
233 
234  !> @brief Derive a TS-capable setting's raw input array name, distinct
235  !! from its persistent array (allocated under mf6varname itself).
236  !<
237  function idm_input_varname(idt) result(varname)
238  type(inputparamdefinitiontype), intent(in) :: idt
239  character(len=LENVARNAME) :: varname
240 
241  if (len_trim(idt%mf6varname) + len(idm_input_suffix) > lenvarname) then
242  write (errmsg, '(*(G0))') &
243  'IDM mf6internal "', trim(idt%mf6varname), '" exceeds ', &
244  lenvarname - len(idm_input_suffix), ' characters (IDM reserves ', &
245  len(idm_input_suffix), ' for the internal input-array suffix "', &
246  idm_input_suffix, '").'
247  call store_error(errmsg, terminate=.true.)
248  end if
249  varname = trim(idt%mf6varname)//idm_input_suffix
250  end function idm_input_varname
251 
252  function count(this)
253  class(structarraytype) :: this !< StructArrayType
254  integer(I4B) :: count
255  count = size(this%struct_vectors)
256  end function count
257 
258  subroutine set_pointer(sv, sv_target)
259  type(structvectortype), pointer :: sv
260  type(structvectortype), target :: sv_target
261  sv => sv_target
262  end subroutine set_pointer
263 
264  function get(this, idx) result(sv)
265  class(structarraytype) :: this !< StructArrayType
266  integer(I4B), intent(in) :: idx
267  type(structvectortype), pointer :: sv
268  call set_pointer(sv, this%struct_vectors(idx))
269  end function get
270 
271  !> @brief allocate integer input type
272  !<
273  subroutine allocate_int_type(this, sv)
274  class(structarraytype) :: this !< StructArrayType
275  type(structvectortype), intent(inout) :: sv
276  integer(I4B), dimension(:), pointer, contiguous :: int1d
277  integer(I4B) :: j, nrow
278 
279  if (this%deferred_shape) then
280  ! shape not known, allocate locally
281  nrow = this%deferred_size_init
282  allocate (int1d(this%deferred_size_init))
283  else
284  ! shape known, allocate in managed memory
285  nrow = this%nrow
286  call mem_allocate(int1d, this%nrow, sv%idt%mf6varname, this%mempath)
287  end if
288 
289  ! initialize vector values
290  do j = 1, nrow
291  int1d(j) = izero
292  end do
293 
294  sv%memtype = mtype_int
295  sv%int1d => int1d
296  end subroutine allocate_int_type
297 
298  !> @brief allocate double input type
299  !<
300  subroutine allocate_dbl_type(this, sv)
301  class(structarraytype) :: this !< StructArrayType
302  type(structvectortype), intent(inout) :: sv
303  real(DP), dimension(:), pointer, contiguous :: dbl1d
304  character(len=LENVARNAME) :: varname
305  integer(I4B) :: j, nrow
306 
307  varname = sv%idt%mf6varname
308  if (len_trim(sv%varname_override) > 0) varname = sv%varname_override
309 
310  if (this%deferred_shape) then
311  ! shape not known, allocate locally
312  nrow = this%deferred_size_init
313  allocate (dbl1d(this%deferred_size_init))
314  else
315  ! shape known, allocate in managed memory
316  nrow = this%nrow
317  call mem_allocate(dbl1d, this%nrow, varname, this%mempath)
318  end if
319 
320  ! initialize
321  do j = 1, nrow
322  dbl1d(j) = dzero
323  end do
324 
325  sv%memtype = mtype_dbl
326  sv%dbl1d => dbl1d
327  end subroutine allocate_dbl_type
328 
329  !> @brief allocate charstr input type
330  !<
331  subroutine allocate_charstr_type(this, sv)
332  class(structarraytype) :: this !< StructArrayType
333  type(structvectortype), intent(inout) :: sv
334  type(characterstringtype), dimension(:), pointer, contiguous :: charstr1d
335  integer(I4B) :: j
336 
337  if (this%deferred_shape) then
338  allocate (charstr1d(this%deferred_size_init))
339  else
340  call mem_allocate(charstr1d, sv%charlen, this%nrow, &
341  sv%idt%mf6varname, this%mempath)
342  end if
343 
344  do j = 1, this%nrow
345  charstr1d(j) = ''
346  end do
347 
348  sv%memtype = mtype_str
349  sv%charstr1d => charstr1d
350  end subroutine allocate_charstr_type
351 
352  !> @brief allocate int1d input type
353  !<
354  subroutine allocate_int1d_type(this, sv)
355  use constantsmodule, only: lenmodelname
358  class(structarraytype) :: this !< StructArrayType
359  type(structvectortype), intent(inout) :: sv
360  integer(I4B), dimension(:, :), pointer, contiguous :: int2d
361  type(stlvecint), pointer :: intvector
362  type(stlvecint), pointer :: intvector_ia
363  integer(I4B), pointer :: ncelldim, exgid
364  character(len=LENMEMPATH) :: input_mempath
365  character(len=LENMODELNAME) :: mname
366  type(characterstringtype), dimension(:), contiguous, &
367  pointer :: charstr1d
368  integer(I4B) :: nrow, n, m
369 
370  if (sv%idt%shape == 'NCELLDIM') then
371  ! if EXCHANGE set to NCELLDIM of appropriate model
372  if (this%mf6_input%component_type == 'EXG') then
373  ! set pointer to EXGID
374  call mem_setptr(exgid, 'EXGID', this%mf6_input%mempath)
375  ! set pointer to appropriate exchange model array
376  input_mempath = create_mem_path('SIM', 'NAM', idm_context)
377  if (sv%idt%tagname == 'CELLIDM1') then
378  call mem_setptr(charstr1d, 'EXGMNAMEA', input_mempath)
379  else if (sv%idt%tagname == 'CELLIDM2') then
380  call mem_setptr(charstr1d, 'EXGMNAMEB', input_mempath)
381  end if
382 
383  ! set the model name
384  mname = charstr1d(exgid)
385 
386  ! set ncelldim pointer
387  input_mempath = create_mem_path(component=mname, context=idm_context)
388  call mem_setptr(ncelldim, sv%idt%shape, input_mempath)
389  else
390  call mem_setptr(ncelldim, sv%idt%shape, this%component_mempath)
391  end if
392 
393  if (this%deferred_shape) then
394  ! shape not known, allocate locally
395  nrow = this%deferred_size_init
396  allocate (int2d(ncelldim, this%deferred_size_init))
397  else
398  ! shape known, allocate in managed memory
399  nrow = this%nrow
400  call mem_allocate(int2d, ncelldim, this%nrow, &
401  sv%idt%mf6varname, this%mempath)
402  end if
403 
404  ! initialize
405  do m = 1, nrow
406  do n = 1, ncelldim
407  int2d(n, m) = izero
408  end do
409  end do
410 
411  sv%memtype = mtype_int2d
412  sv%int2d => int2d
413  sv%intshape => ncelldim
414  else
415  ! allocate intvector object
416  allocate (intvector)
417  ! initialize STLVecInt
418  call intvector%init()
419  sv%memtype = mtype_intvec
420  sv%intvector => intvector
421  sv%size = -1
422  ! seed the CSR row-offset vector (ia(1) = 1)
423  allocate (intvector_ia)
424  call intvector_ia%init()
425  call intvector_ia%push_back(1)
426  sv%intvector_ia => intvector_ia
427  if (trim(sv%idt%shape) == ':') then
428  ! ragged column: width unknown until read_param reads to end of
429  ! record; intvector_shape stays unassociated
430  sv%intvector_ragged = .true.
431  else
432  ! set pointer to dynamic shape
433  call mem_setptr(sv%intvector_shape, sv%idt%shape, this%mempath)
434  end if
435  end if
436  end subroutine allocate_int1d_type
437 
438  !> @brief allocate dbl1d input type
439  !<
440  subroutine allocate_dbl1d_type(this, sv)
441  use memorymanagermodule, only: get_isize
442  class(structarraytype) :: this !< StructArrayType
443  type(structvectortype), intent(inout) :: sv
444  real(DP), dimension(:, :), pointer, contiguous :: dbl2d
445  integer(I4B), pointer :: naux, nseg, nseg_1
446  integer(I4B) :: nseg1_isize, n, m
447 
448  if (sv%idt%shape == 'NAUX') then
449  call mem_setptr(naux, sv%idt%shape, this%mempath)
450 
451  if (this%deferred_shape) then
452  ! deferred: plain allocate so check_reallocate can grow it safely
453  allocate (dbl2d(naux, sv%size))
454  else
455  call mem_allocate(dbl2d, naux, this%nrow, sv%idt%mf6varname, this%mempath)
456  end if
457 
458  ! initialize
459  do m = 1, sv%size
460  do n = 1, naux
461  dbl2d(n, m) = dzero
462  end do
463  end do
464 
465  sv%memtype = mtype_dbl2d
466  sv%dbl2d => dbl2d
467  sv%intshape => naux
468  else if (sv%idt%shape == 'NSEG-1') then
469  call mem_setptr(nseg, 'NSEG', this%mempath)
470  call get_isize('NSEG_1', this%mempath, nseg1_isize)
471 
472  if (nseg1_isize < 0) then
473  call mem_allocate(nseg_1, 'NSEG_1', this%mempath)
474  nseg_1 = nseg - 1
475  else
476  call mem_setptr(nseg_1, 'NSEG_1', this%mempath)
477  end if
478 
479  if (this%deferred_shape) then
480  ! deferred: plain allocate so check_reallocate can grow it safely
481  allocate (dbl2d(nseg_1, sv%size))
482  else
483  call mem_allocate(dbl2d, nseg_1, sv%size, sv%idt%mf6varname, this%mempath)
484  end if
485 
486  ! initialize
487  do m = 1, sv%size
488  do n = 1, nseg_1
489  dbl2d(n, m) = dzero
490  end do
491  end do
492 
493  sv%memtype = mtype_dbl2d
494  sv%dbl2d => dbl2d
495  sv%intshape => nseg_1
496  else
497  errmsg = 'IDM unimplemented. StructArray::allocate_dbl1d_type &
498  & unsupported shape "'//trim(sv%idt%shape)//'".'
499  call store_error(errmsg, terminate=.true.)
500  end if
501  end subroutine allocate_dbl1d_type
502 
503  subroutine load_deferred_vector(this, icol)
504  use memorymanagermodule, only: get_isize
505  class(structarraytype) :: this !< StructArrayType
506  integer(I4B), intent(in) :: icol
507  integer(I4B) :: i, j, isize
508  integer(I4B), dimension(:), pointer, contiguous :: p_int1d
509  integer(I4B), dimension(:, :), pointer, contiguous :: p_int2d
510  real(DP), dimension(:), pointer, contiguous :: p_dbl1d
511  real(DP), dimension(:, :), pointer, contiguous :: p_dbl2d
512  type(characterstringtype), dimension(:), pointer, contiguous :: p_charstr1d
513  character(len=LENVARNAME) :: varname
514  logical(LGP) :: overwrite
515 
516  overwrite = .true.
517  if (this%struct_vectors(icol)%idt%blockname == 'SOLUTIONGROUP') &
518  overwrite = .false.
519 
520  ! set varname
521  varname = this%struct_vectors(icol)%idt%mf6varname
522  ! check if already mem managed variable
523  call get_isize(varname, this%mempath, isize)
524 
525  ! allocate and load based on memtype
526  select case (this%struct_vectors(icol)%memtype)
527  case (mtype_int)
528  if (isize > -1) then
529  ! variable exists, reallocate and append
530  call mem_setptr(p_int1d, varname, this%mempath)
531 
532  if (overwrite) then
533  ! overwrite existing array
534  if (this%nrow > isize) then
535  ! reallocate
536  call mem_reallocate(p_int1d, this%nrow, varname, this%mempath)
537  end if
538 
539  ! write new data
540  do i = 1, this%nrow
541  p_int1d(i) = this%struct_vectors(icol)%int1d(i)
542  end do
543 
544  if (isize > this%nrow) then
545  ! initialize excess space
546  do i = this%nrow + 1, isize
547  p_int1d(i) = izero
548  end do
549  end if
550  else
551  ! reallocate to new size
552  call mem_reallocate(p_int1d, this%nrow + isize, varname, this%mempath)
553 
554  ! write new data after existing
555  do i = 1, this%nrow
556  p_int1d(isize + i) = this%struct_vectors(icol)%int1d(i)
557  end do
558  end if
559  else
560  ! allocate memory manager vector
561  call mem_allocate(p_int1d, this%nrow, varname, this%mempath)
562 
563  ! load local vector to managed memory
564  do i = 1, this%nrow
565  p_int1d(i) = this%struct_vectors(icol)%int1d(i)
566  end do
567  end if
568 
569  ! deallocate local memory
570  deallocate (this%struct_vectors(icol)%int1d)
571 
572  ! update structvector
573  this%struct_vectors(icol)%int1d => p_int1d
574  this%struct_vectors(icol)%size = this%nrow
575  case (mtype_dbl)
576  if (isize > -1) then
577  call mem_setptr(p_dbl1d, varname, this%mempath)
578 
579  if (overwrite) then
580  if (this%nrow > isize) then
581  call mem_reallocate(p_dbl1d, this%nrow, varname, this%mempath)
582  end if
583 
584  do i = 1, this%nrow
585  p_dbl1d(i) = this%struct_vectors(icol)%dbl1d(i)
586  end do
587 
588  if (isize > this%nrow) then
589  do i = this%nrow + 1, isize
590  p_dbl1d(i) = dzero
591  end do
592  end if
593  else
594  call mem_reallocate(p_dbl1d, this%nrow + isize, varname, &
595  this%mempath)
596  do i = 1, this%nrow
597  p_dbl1d(isize + i) = this%struct_vectors(icol)%dbl1d(i)
598  end do
599  end if
600  else
601  call mem_allocate(p_dbl1d, this%nrow, varname, this%mempath)
602 
603  do i = 1, this%nrow
604  p_dbl1d(i) = this%struct_vectors(icol)%dbl1d(i)
605  end do
606  end if
607 
608  deallocate (this%struct_vectors(icol)%dbl1d)
609 
610  this%struct_vectors(icol)%dbl1d => p_dbl1d
611  this%struct_vectors(icol)%size = this%nrow
612  !
613  case (mtype_str)
614  if (isize > -1) then
615  call mem_setptr(p_charstr1d, varname, this%mempath)
616 
617  if (overwrite) then
618  if (this%nrow > isize) then
619  call mem_reallocate(p_charstr1d, this%struct_vectors(icol)%charlen, &
620  this%nrow, varname, this%mempath)
621  end if
622 
623  do i = 1, this%nrow
624  p_charstr1d(i) = this%struct_vectors(icol)%charstr1d(i)
625  end do
626 
627  if (isize > this%nrow) then
628  do i = this%nrow + 1, isize
629  p_charstr1d(i) = ''
630  end do
631  end if
632  else
633  call mem_reallocate(p_charstr1d, this%struct_vectors(icol)%charlen, &
634  this%nrow + isize, varname, this%mempath)
635  do i = 1, this%nrow
636  p_charstr1d(isize + i) = this%struct_vectors(icol)%charstr1d(i)
637  end do
638  end if
639  else
640  call mem_allocate(p_charstr1d, this%struct_vectors(icol)%charlen, &
641  this%nrow, varname, this%mempath)
642  do i = 1, this%nrow
643  p_charstr1d(i) = this%struct_vectors(icol)%charstr1d(i)
644  call this%struct_vectors(icol)%charstr1d(i)%destroy()
645  end do
646  end if
647 
648  deallocate (this%struct_vectors(icol)%charstr1d)
649 
650  this%struct_vectors(icol)%charstr1d => p_charstr1d
651  this%struct_vectors(icol)%size = this%nrow
652  case (mtype_intvec) ! intvector reallocate unimplemented
653  errmsg = 'StructArray::load_deferred_vector &
654  &intvector reallocate unimplemented.'
655  call store_error(errmsg, terminate=.true.)
656  case (mtype_int2d)
657  if (isize > -1) then
658  errmsg = 'StructArray::load_deferred_vector &
659  &int2d reallocate unimplemented.'
660  call store_error(errmsg, terminate=.true.)
661  else
662  call mem_allocate(p_int2d, this%struct_vectors(icol)%intshape, &
663  this%nrow, varname, this%mempath)
664  do i = 1, this%nrow
665  do j = 1, this%struct_vectors(icol)%intshape
666  p_int2d(j, i) = this%struct_vectors(icol)%int2d(j, i)
667  end do
668  end do
669  end if
670 
671  deallocate (this%struct_vectors(icol)%int2d)
672 
673  this%struct_vectors(icol)%int2d => p_int2d
674  this%struct_vectors(icol)%size = this%nrow
675  case (mtype_dbl2d)
676  if (isize > -1) then
677  errmsg = 'StructArray::load_deferred_vector &
678  &dbl2d reallocate unimplemented.'
679  call store_error(errmsg, terminate=.true.)
680  else
681  call mem_allocate(p_dbl2d, this%struct_vectors(icol)%intshape, &
682  this%nrow, varname, this%mempath)
683  do i = 1, this%nrow
684  do j = 1, this%struct_vectors(icol)%intshape
685  p_dbl2d(j, i) = this%struct_vectors(icol)%dbl2d(j, i)
686  end do
687  end do
688  end if
689 
690  deallocate (this%struct_vectors(icol)%dbl2d)
691 
692  this%struct_vectors(icol)%dbl2d => p_dbl2d
693  this%struct_vectors(icol)%size = this%nrow
694  case default
695  end select
696  end subroutine load_deferred_vector
697 
698  !> @brief load deferred vectors into managed memory
699  !<
700  subroutine memload_vectors(this)
701  class(structarraytype) :: this !< StructArrayType
702  integer(I4B) :: icol, j
703  integer(I4B), dimension(:), pointer, contiguous :: p_intvector
704  integer(I4B), dimension(:), pointer, contiguous :: p_intvector_ia
705  character(len=LENVARNAME) :: varname
706 
707  do icol = 1, this%ncol
708  ! set varname
709  varname = this%struct_vectors(icol)%idt%mf6varname
710 
711  if (this%struct_vectors(icol)%memtype == mtype_intvec) then
712  ! intvectors always need to be loaded
713  ! size intvector to number of values read
714  call this%struct_vectors(icol)%intvector%shrink_to_fit()
715 
716  ! allocate memory manager vector
717  call mem_allocate(p_intvector, &
718  this%struct_vectors(icol)%intvector%size, &
719  varname, this%mempath)
720 
721  ! load local vector to managed memory
722  do j = 1, this%struct_vectors(icol)%intvector%size
723  p_intvector(j) = this%struct_vectors(icol)%intvector%at(j)
724  end do
725 
726  ! cleanup local memory
727  call this%struct_vectors(icol)%intvector%destroy()
728  deallocate (this%struct_vectors(icol)%intvector)
729  nullify (this%struct_vectors(icol)%intvector_shape)
730 
731  ! publish the parallel CSR-style row-offset vector as <TAGNAME>_IA
732  call mem_allocate(p_intvector_ia, &
733  this%struct_vectors(icol)%intvector_ia%size, &
734  trim(varname)//'_IA', this%mempath)
735  do j = 1, this%struct_vectors(icol)%intvector_ia%size
736  p_intvector_ia(j) = this%struct_vectors(icol)%intvector_ia%at(j)
737  end do
738  call this%struct_vectors(icol)%intvector_ia%destroy()
739  deallocate (this%struct_vectors(icol)%intvector_ia)
740  nullify (this%struct_vectors(icol)%intvector_ia)
741  else if (this%deferred_shape) then
742  ! load as shape wasn't known
743  call this%load_deferred_vector(icol)
744  end if
745  end do
746  end subroutine memload_vectors
747 
748  !> @brief log information about the StructArrayType
749  !<
750  subroutine log_structarray_vars(this, iout)
751  class(structarraytype) :: this !< StructArrayType
752  integer(I4B), intent(in) :: iout !< unit number for output
753  integer(I4B) :: j, nts
754  integer(I4B), dimension(:), pointer, contiguous :: int1d
755  character(len=LINELENGTH) :: ts_count_str
756 
757  ! idm variable logging
758  do j = 1, this%ncol
759  ! log based on memtype
760  select case (this%struct_vectors(j)%memtype)
761  case (mtype_int)
762  call idm_log_var(this%struct_vectors(j)%int1d, &
763  this%struct_vectors(j)%idt%tagname, &
764  this%mempath, iout)
765  case (mtype_dbl)
766  nts = this%struct_vectors(j)%ts_strlocs%count()
767  if (nts > 0) then
768  write (ts_count_str, '(i0, " time-series bound entries")') nts
769  call idm_log_var(this%struct_vectors(j)%idt%tagname, &
770  this%mempath, iout, .false., trim(ts_count_str))
771  else
772  call idm_log_var(this%struct_vectors(j)%dbl1d, &
773  this%struct_vectors(j)%idt%tagname, &
774  this%mempath, iout)
775  end if
776  case (mtype_intvec)
777  call mem_setptr(int1d, this%struct_vectors(j)%idt%mf6varname, &
778  this%mempath)
779  call idm_log_var(int1d, this%struct_vectors(j)%idt%tagname, &
780  this%mempath, iout)
781  case (mtype_int2d)
782  call idm_log_var(this%struct_vectors(j)%int2d, &
783  this%struct_vectors(j)%idt%tagname, &
784  this%mempath, iout)
785  case (mtype_dbl2d)
786  nts = this%struct_vectors(j)%ts_strlocs%count()
787  if (nts > 0) then
788  write (ts_count_str, '(i0, " time-series bound entries")') nts
789  call idm_log_var(this%struct_vectors(j)%idt%tagname, &
790  this%mempath, iout, .false., trim(ts_count_str))
791  else
792  call idm_log_var(this%struct_vectors(j)%dbl2d, &
793  this%struct_vectors(j)%idt%tagname, &
794  this%mempath, iout)
795  end if
796  end select
797  end do
798  end subroutine log_structarray_vars
799 
800  !> @brief reallocate local memory for deferred vectors if necessary
801  !<
802  subroutine check_reallocate(this)
803  class(structarraytype) :: this !< StructArrayType
804  integer(I4B) :: i, j, k, newsize
805  integer(I4B), dimension(:), pointer, contiguous :: p_int1d
806  integer(I4B), dimension(:, :), pointer, contiguous :: p_int2d
807  real(DP), dimension(:), pointer, contiguous :: p_dbl1d
808  real(DP), dimension(:, :), pointer, contiguous :: p_dbl2d
809  type(characterstringtype), dimension(:), pointer, contiguous :: p_charstr1d
810  integer(I4B) :: reallocate_mult
811 
812  ! set growth rate
813  reallocate_mult = 2
814 
815  do j = 1, this%ncol
816  ! reallocate based on memtype
817  select case (this%struct_vectors(j)%memtype)
818  case (mtype_int)
819  ! check if more space needed
820  if (this%nrow > this%struct_vectors(j)%size) then
821  ! calculate new size
822  newsize = this%struct_vectors(j)%size * reallocate_mult
823  ! allocate new vector
824  allocate (p_int1d(newsize))
825 
826  ! copy from old to new
827  do i = 1, this%struct_vectors(j)%size
828  p_int1d(i) = this%struct_vectors(j)%int1d(i)
829  end do
830 
831  ! deallocate old vector
832  deallocate (this%struct_vectors(j)%int1d)
833 
834  ! update struct array object
835  this%struct_vectors(j)%int1d => p_int1d
836  this%struct_vectors(j)%size = newsize
837  end if
838  case (mtype_dbl)
839  if (this%nrow > this%struct_vectors(j)%size) then
840  newsize = this%struct_vectors(j)%size * reallocate_mult
841  allocate (p_dbl1d(newsize))
842 
843  do i = 1, this%struct_vectors(j)%size
844  p_dbl1d(i) = this%struct_vectors(j)%dbl1d(i)
845  end do
846 
847  deallocate (this%struct_vectors(j)%dbl1d)
848 
849  this%struct_vectors(j)%dbl1d => p_dbl1d
850  this%struct_vectors(j)%size = newsize
851  end if
852  !
853  case (mtype_str)
854  if (this%nrow > this%struct_vectors(j)%size) then
855  newsize = this%struct_vectors(j)%size * reallocate_mult
856  allocate (p_charstr1d(newsize))
857 
858  do i = 1, this%struct_vectors(j)%size
859  p_charstr1d(i) = this%struct_vectors(j)%charstr1d(i)
860  call this%struct_vectors(j)%charstr1d(i)%destroy()
861  end do
862 
863  deallocate (this%struct_vectors(j)%charstr1d)
864 
865  this%struct_vectors(j)%charstr1d => p_charstr1d
866  this%struct_vectors(j)%size = newsize
867  end if
868  case (mtype_int2d)
869  if (this%nrow > this%struct_vectors(j)%size) then
870  newsize = this%struct_vectors(j)%size * reallocate_mult
871  allocate (p_int2d(this%struct_vectors(j)%intshape, newsize))
872 
873  do i = 1, this%struct_vectors(j)%size
874  do k = 1, this%struct_vectors(j)%intshape
875  p_int2d(k, i) = this%struct_vectors(j)%int2d(k, i)
876  end do
877  end do
878 
879  deallocate (this%struct_vectors(j)%int2d)
880 
881  this%struct_vectors(j)%int2d => p_int2d
882  this%struct_vectors(j)%size = newsize
883  end if
884  case (mtype_dbl2d)
885  if (this%nrow > this%struct_vectors(j)%size) then
886  newsize = this%struct_vectors(j)%size * reallocate_mult
887  allocate (p_dbl2d(this%struct_vectors(j)%intshape, newsize))
888 
889  do i = 1, this%struct_vectors(j)%size
890  do k = 1, this%struct_vectors(j)%intshape
891  p_dbl2d(k, i) = this%struct_vectors(j)%dbl2d(k, i)
892  end do
893  end do
894 
895  deallocate (this%struct_vectors(j)%dbl2d)
896 
897  this%struct_vectors(j)%dbl2d => p_dbl2d
898  this%struct_vectors(j)%size = newsize
899  end if
900  case (mtype_undef, mtype_intvec)
901  ! metadata-only or unsupported: skip reallocation check
902  case default
903  errmsg = 'IDM unimplemented. StructArray::check_reallocate &
904  &unsupported memtype.'
905  call store_error(errmsg, terminate=.true.)
906  end select
907  end do
908  end subroutine check_reallocate
909 
910  subroutine read_param(this, parser, sv_col, irow, timeseries, iout)
911  use inputoutputmodule, only: upcase
912  class(structarraytype) :: this !< StructArrayType
913  type(blockparsertype), intent(inout) :: parser !< block parser to read from
914  integer(I4B), intent(in) :: sv_col
915  integer(I4B), intent(in) :: irow
916  logical(LGP), intent(in) :: timeseries
917  integer(I4B), intent(in) :: iout !< unit number for output
918  integer(I4B) :: n, intval, numval, icol
919  character(len=LINELENGTH) :: str
920  character(len=:), allocatable :: line
921  logical(LGP) :: preserve_case, success
922 
923  select case (this%struct_vectors(sv_col)%memtype)
924  case (mtype_undef)
925  ! MTYPE_UNDEF vectors are metadata-only (KEYWORD dispatch headers).
926  write (errmsg, '(a,i0)') &
927  'IDM read_param called for MTYPE_UNDEF metadata vector at column ', sv_col
928  call store_error(errmsg, .true.)
929  case (mtype_int)
930  ! if reloadable block and first col, store blocknum
931  if (sv_col == 1 .and. this%blocknum > 0) then
932  ! store blocknum
933  this%struct_vectors(sv_col)%int1d(irow) = this%blocknum
934  else
935  ! read and store int
936  this%struct_vectors(sv_col)%int1d(irow) = parser%GetInteger()
937  end if
938  case (mtype_dbl)
939  if (this%struct_vectors(sv_col)%idt%timeseries .and. timeseries) then
940  call parser%GetString(str)
941  this%struct_vectors(sv_col)%dbl1d(irow) = &
942  this%struct_vectors(sv_col)%read_token(str, this%startidx(sv_col), &
943  1, irow)
944  else if (sv_col == this%ncol .and. &
945  .not. this%struct_vectors(sv_col)%idt%required) then
946  call parser%TryGetDouble(this%struct_vectors(sv_col)%dbl1d(irow), success)
947  if (.not. success) &
948  this%struct_vectors(sv_col)%dbl1d(irow) = dnodata
949  else
950  this%struct_vectors(sv_col)%dbl1d(irow) = parser%GetDouble()
951  end if
952  case (mtype_str)
953  if (this%struct_vectors(sv_col)%idt%shape /= '' .and. &
954  sv_col == this%ncol) then
955  ! last column with any shape: store rest of line
956  call parser%GetRemainingLine(line)
957  this%struct_vectors(sv_col)%charstr1d(irow) = line
958  deallocate (line)
959  else
960  ! read string token; a shape on a non-last column marks something
961  ! other than "rest of line", so it reads the same as unshaped
962  preserve_case = (.not. this%struct_vectors(sv_col)%idt%preserve_case)
963  call parser%GetString(str, preserve_case)
964  this%struct_vectors(sv_col)%charstr1d(irow) = str
965  end if
966  case (mtype_intvec)
967  if (this%struct_vectors(sv_col)%intvector_ragged) then
968  ! read to end of record; consumers compare the actual count read
969  ! against whatever width they independently expect
970  numval = 0
971  success = .true.
972  do while (success)
973  call parser%TryGetInteger(intval, success)
974  if (success) then
975  call this%struct_vectors(sv_col)%intvector%push_back(intval)
976  numval = numval + 1
977  end if
978  end do
979  else
980  ! get shape for this row
981  numval = this%struct_vectors(sv_col)%intvector_shape(irow)
982  ! read and store row values
983  do n = 1, numval
984  intval = parser%GetInteger()
985  call this%struct_vectors(sv_col)%intvector%push_back(intval)
986  end do
987  end if
988  ! extend the CSR-style row-offset vector with this row's running total
989  call this%struct_vectors(sv_col)%intvector_ia%push_back( &
990  this%struct_vectors(sv_col)%intvector_ia%at( &
991  this%struct_vectors(sv_col)%intvector_ia%size) + numval)
992  case (mtype_int2d)
993  ! read and store row values
994  ! handle 'NONE' keyword (SFR unconnected reaches) for backward compatibility
995  if (trim(this%mf6_input%subcomponent_type) == 'SFR' .and. &
996  this%struct_vectors(sv_col)%idt%tagname == 'CELLID') then
997  call parser%GetString(str)
998  call upcase(str)
999  if (str == 'NONE') then
1000  ! NONE means unconnected; store zeros for all dimensions
1001  do n = 1, this%struct_vectors(sv_col)%intshape
1002  this%struct_vectors(sv_col)%int2d(n, irow) = 0
1003  end do
1004  else
1005  ! first token already read as str; parse as integer and read the rest
1006  read (str, *, iostat=numval) intval
1007  if (numval /= 0) then
1008  write (errmsg, '(a,a,a)') &
1009  'CELLID must be an integer or the keyword NONE, got: ', &
1010  trim(str), '.'
1011  call store_error(errmsg, terminate=.true.)
1012  end if
1013  this%struct_vectors(sv_col)%int2d(1, irow) = intval
1014  do n = 2, this%struct_vectors(sv_col)%intshape
1015  this%struct_vectors(sv_col)%int2d(n, irow) = parser%GetInteger()
1016  end do
1017  end if
1018  else
1019  do n = 1, this%struct_vectors(sv_col)%intshape
1020  this%struct_vectors(sv_col)%int2d(n, irow) = parser%GetInteger()
1021  end do
1022  end if
1023  case (mtype_dbl2d)
1024  ! read and store row values
1025  do n = 1, this%struct_vectors(sv_col)%intshape
1026  if (this%struct_vectors(sv_col)%idt%timeseries .and. timeseries) then
1027  call parser%GetString(str)
1028  icol = this%startidx(sv_col) + n - 1
1029  this%struct_vectors(sv_col)%dbl2d(n, irow) = &
1030  this%struct_vectors(sv_col)%read_token(str, icol, n, irow)
1031  else
1032  this%struct_vectors(sv_col)%dbl2d(n, irow) = parser%GetDouble()
1033  end if
1034  end do
1035  end select
1036  end subroutine read_param
1037 
1038  !> @brief True if idt is AUXVAL: its AUX index is resolved dynamically
1039  !! from a sibling AUXNAME, not feature-indexed by its own mf6varname.
1040  !<
1041  function is_auxval(idt) result(res)
1042  type(inputparamdefinitiontype), intent(in) :: idt
1043  logical(LGP) :: res
1044 
1045  res = (trim(idt%tagname) == 'AUXVAL')
1046  end function is_auxval
1047 
1048  !> @brief Find the AUX array position matching auxname, 0 if none.
1049  !<
1050  function find_auxname_index(auxname, auxnames, naux) result(jj)
1051  character(len=*), intent(in) :: auxname
1052  type(characterstringtype), dimension(:), intent(in) :: auxnames
1053  integer(I4B), intent(in) :: naux
1054  integer(I4B) :: jj
1055  character(len=LINELENGTH) :: thisauxname
1056  integer(I4B) :: n
1057 
1058  jj = 0
1059  do n = 1, naux
1060  thisauxname = auxnames(n)
1061  if (trim(auxname) == trim(thisauxname)) then
1062  jj = n
1063  return
1064  end if
1065  end do
1066  end function find_auxname_index
1067 
1068  !> @brief read from the block parser to fill the StructArrayType
1069  !<
1070  function read_from_parser(this, parser, timeseries, iout, input_name) &
1071  result(irow)
1072  class(structarraytype) :: this !< StructArrayType
1073  type(blockparsertype), intent(inout) :: parser !< block parser to read from
1074  logical(LGP), intent(in) :: timeseries
1075  integer(I4B), intent(in) :: iout !< unit number for output
1076  character(len=*), intent(in) :: input_name !< input filename for error messages
1077  integer(I4B) :: irow, j
1078  logical(LGP) :: endofblock
1079 
1080  ! initialize index irow
1081  irow = 0
1082 
1083  ! reset nrow if deferred shape
1084  if (this%deferred_shape) then
1085  this%nrow = 0
1086  end if
1087 
1088  ! read entire block
1089  do
1090  ! read next line
1091  call parser%GetNextLine(endofblock)
1092  if (endofblock) then
1093  ! no more lines
1094  exit
1095  else if (this%deferred_shape) then
1096  ! shape unknown, track lines read
1097  this%nrow = this%nrow + 1
1098  ! check and update memory allocation
1099  call this%check_reallocate()
1100  end if
1101  ! update irow index
1102  irow = irow + 1
1103  if (this%deferred_shape) then
1104  else
1105  ! check allocated array size against user bound
1106  if (irow > this%nrow) then
1107  write (errmsg, '(a,i0,a)') &
1108  'Input error: line count exceeds input dimension. Expected rows=', &
1109  this%nrow, '.'
1110  call store_error(errmsg)
1111  call store_error_filename(input_name)
1112  end if
1113  end if
1114  ! handle line reads by column memtype
1115  do j = 1, this%ncol
1116  call this%read_param(parser, j, irow, timeseries, iout)
1117  end do
1118  end do
1119  ! if deferred shape vectors were read, load to input path
1120  call this%memload_vectors()
1121  ! log loaded variables
1122  if (iout > 0) then
1123  call this%log_structarray_vars(iout)
1124  end if
1125  end function read_from_parser
1126 
1127  !> @brief read keystring period block into the StructArrayType
1128  !!
1129  !! Each input line contains nleading fixed columns followed by a dispatch
1130  !! keyword. Two dispatch modes are supported:
1131  !!
1132  !! Simple dispatch: keyword matches a DOUBLE/STRING/INTEGER column.
1133  !! One value token is read from the parser into that column.
1134  !! All other member columns receive their sentinel for that row.
1135  !!
1136  !! Compound dispatch: keyword matches a KEYWORD-type column (e.g.
1137  !! FLOWING_WELL). No parser token is read for the KEYWORD column —
1138  !! the dispatch keyword itself is stored. Subsequent non-KEYWORD
1139  !! columns (the compound sub-members, e.g. FWELEV/FWCOND/FWRLEN)
1140  !! are read from the parser in order until the next KEYWORD column
1141  !! or the end of the member columns.
1142  !!
1143  !! No-value KEYWORD dispatch: a KEYWORD column with no sub-members
1144  !! immediately following stores the dispatch keyword and reads
1145  !! nothing further.
1146  !!
1147  !<
1148  function read_from_parser_keystring(this, parser, timeseries, nleading, &
1149  iout, input_name) result(irow)
1150  use inputoutputmodule, only: upcase
1151  use simmodule, only: store_error_filename
1152  class(structarraytype) :: this !< StructArrayType
1153  type(blockparsertype), intent(inout) :: parser !< block parser to read from
1154  logical(LGP), intent(in) :: timeseries !< .true. when TS files loaded
1155  integer(I4B), intent(in) :: nleading !< number of leading (fixed) columns
1156  integer(I4B), intent(in) :: iout !< unit number for output
1157  character(len=*), intent(in) :: input_name !< input filename for error messages
1158  integer(I4B) :: irow
1159  logical(LGP) :: endofblock, is_keyword_dispatch
1160  character(len=LINELENGTH) :: keyword
1161  integer(I4B) :: icol, found_col, last_set_col, setting_icol
1162 
1163  irow = 0
1164 
1165  ! SETTING column is always at nleading+1 when present; detect by tagname
1166  setting_icol = 0
1167  if (nleading + 1 <= this%ncol) then
1168  if (trim(this%struct_vectors(nleading + 1)%idt%tagname) == 'SETTING') then
1169  setting_icol = nleading + 1
1170  end if
1171  end if
1172 
1173  ! reset nrow if deferred shape
1174  if (this%deferred_shape) then
1175  this%nrow = 0
1176  end if
1177 
1178  do
1179  call parser%GetNextLine(endofblock)
1180  if (endofblock) exit
1181 
1182  if (this%deferred_shape) then
1183  this%nrow = this%nrow + 1
1184  call this%check_reallocate()
1185  end if
1186  irow = irow + 1
1187 
1188  ! bounds check for pre-allocated (non-deferred) arrays
1189  if (.not. this%deferred_shape) then
1190  if (irow > this%nrow) then
1191  write (errmsg, '(a,i0,a)') &
1192  'Input error: keystring row count exceeds pre-allocated maxbound=', &
1193  this%nrow, '.'
1194  call store_error(errmsg)
1195  call store_error_filename(input_name)
1196  exit
1197  end if
1198  end if
1199 
1200  ! read leading fixed columns (e.g. CELLID, IFNO)
1201  do icol = 1, nleading
1202  call this%read_param(parser, icol, irow, .false., iout)
1203  end do
1204 
1205  ! read dispatch keyword
1206  call parser%GetString(keyword)
1207  call upcase(keyword)
1208 
1209  ! match the keystring-member column, skipping SETTING and a KEYWORD
1210  ! header's own sub-members (reachable only through their header)
1211  found_col = 0
1212  icol = nleading + 1
1213  do while (icol <= this%ncol)
1214  if (icol == setting_icol) then
1215  icol = icol + 1
1216  cycle
1217  end if
1218  if (trim(this%struct_vectors(icol)%idt%tagname) == trim(keyword)) then
1219  found_col = icol
1220  exit
1221  end if
1222  if (this%struct_vectors(icol)%head_nbody > 0) then
1223  icol = icol + this%struct_vectors(icol)%head_nbody + 1
1224  else
1225  icol = icol + 1
1226  end if
1227  end do
1228 
1229  if (found_col < 1) then
1230  write (errmsg, '(a,a,a)') &
1231  'Unrecognized keystring keyword "', trim(keyword), &
1232  '" in PERIOD block.'
1233  call store_error(errmsg)
1234  call store_error_filename(input_name)
1235  cycle
1236  end if
1237 
1238  ! write mf6varname, not tagname, since SETTING is also used as
1239  ! a memory-manager name and tagname can exceed LENVARNAME
1240  if (setting_icol > 0) then
1241  this%struct_vectors(setting_icol)%charstr1d(irow) = &
1242  trim(this%struct_vectors(found_col)%idt%mf6varname)
1243  end if
1244 
1245  ! determine dispatch mode and set/read matched column(s)
1246  is_keyword_dispatch = &
1247  (this%struct_vectors(found_col)%idt%datatype == 'KEYWORD')
1248 
1249  if (is_keyword_dispatch) then
1250  ! compound/no-value KEYWORD dispatch has no data of its own;
1251  ! read its body members starting at body_start instead
1252  last_set_col = found_col
1253  if (this%struct_vectors(found_col)%body_start > 0) then
1254  do icol = this%struct_vectors(found_col)%body_start, &
1255  this%struct_vectors(found_col)%body_start + &
1256  this%struct_vectors(found_col)%head_nbody - 1
1257  if (icol > this%ncol) exit
1258  call this%read_param(parser, icol, irow, timeseries, iout)
1259  last_set_col = icol
1260  end do
1261  end if
1262  else
1263  ! Simple single-value dispatch: read one value for the matched column
1264  call this%read_param(parser, found_col, irow, timeseries, iout)
1265  last_set_col = found_col
1266  end if
1267 
1268  ! fill sentinels for all non-matched member columns
1269  do icol = nleading + 1, this%ncol
1270  ! skip SETTING column (always written above when present)
1271  if (icol == setting_icol) cycle
1272  ! skip metadata vectors (MTYPE_UNDEF, no allocated data arrays)
1273  if (this%struct_vectors(icol)%memtype == mtype_undef) cycle
1274  if (icol >= found_col .and. icol <= last_set_col) cycle
1275  select case (this%struct_vectors(icol)%memtype)
1276  case (mtype_int) ! INTEGER: use IZERO sentinel
1277  this%struct_vectors(icol)%int1d(irow) = izero
1278  case (mtype_dbl) ! DOUBLE: use DNODATA sentinel
1279  this%struct_vectors(icol)%dbl1d(irow) = dnodata
1280  case (mtype_str) ! STRING or KEYWORD: use empty string sentinel
1281  this%struct_vectors(icol)%charstr1d(irow) = ''
1282  end select
1283  end do
1284  end do
1285 
1286  call this%memload_vectors()
1287 
1288  if (iout > 0) then
1289  call this%log_structarray_vars(iout)
1290  end if
1291  end function read_from_parser_keystring
1292 
1293  !> @brief read from binary input to fill the StructArrayType
1294  !<
1295  function read_from_binary(this, inunit, iout) result(irow)
1296  class(structarraytype) :: this !< StructArrayType
1297  integer(I4B), intent(in) :: inunit !< unit number for binary input
1298  integer(I4B), intent(in) :: iout !< unit number for output
1299  integer(I4B) :: irow, ierr
1300  integer(I4B) :: j, k
1301  integer(I4B) :: intval, numval
1302  character(len=LINELENGTH) :: fname
1303  character(len=*), parameter :: fmtlsterronly = &
1304  "('Error reading LIST from file: ',&
1305  &1x,a,1x,' on UNIT: ',I0)"
1306 
1307  ! set error and exit if deferred shape
1308  if (this%deferred_shape) then
1309  errmsg = 'IDM unimplemented. StructArray::read_from_binary deferred shape &
1310  &not supported for binary inputs.'
1311  call store_error(errmsg, terminate=.true.)
1312  end if
1313  ! initialize
1314  irow = 0
1315  ierr = 0
1316  readloop: do
1317  ! update irow index
1318  irow = irow + 1
1319  ! handle line reads by column memtype
1320  do j = 1, this%ncol
1321  select case (this%struct_vectors(j)%memtype)
1322  case (mtype_int)
1323  read (inunit, iostat=ierr) this%struct_vectors(j)%int1d(irow)
1324  case (mtype_dbl)
1325  read (inunit, iostat=ierr) this%struct_vectors(j)%dbl1d(irow)
1326  case (mtype_str)
1327  errmsg = 'List style binary inputs not supported &
1328  &for text columns, tag='// &
1329  trim(this%struct_vectors(j)%idt%tagname)//'.'
1330  call store_error(errmsg, terminate=.true.)
1331  case (mtype_intvec)
1332  if (this%struct_vectors(j)%intvector_ragged) then
1333  errmsg = 'List style binary inputs not supported for &
1334  &self-sizing (ragged) columns, tag='// &
1335  trim(this%struct_vectors(j)%idt%tagname)//'.'
1336  call store_error(errmsg, terminate=.true.)
1337  end if
1338  ! get shape for this row
1339  numval = this%struct_vectors(j)%intvector_shape(irow)
1340  ! read and store row values
1341  do k = 1, numval
1342  if (ierr == 0) then
1343  read (inunit, iostat=ierr) intval
1344  call this%struct_vectors(j)%intvector%push_back(intval)
1345  end if
1346  end do
1347  case (mtype_int2d)
1348  ! read and store row values
1349  do k = 1, this%struct_vectors(j)%intshape
1350  if (ierr == 0) then
1351  read (inunit, iostat=ierr) this%struct_vectors(j)%int2d(k, irow)
1352  end if
1353  end do
1354  case (mtype_dbl2d)
1355  do k = 1, this%struct_vectors(j)%intshape
1356  if (ierr == 0) then
1357  read (inunit, iostat=ierr) this%struct_vectors(j)%dbl2d(k, irow)
1358  end if
1359  end do
1360  end select
1361 
1362  ! handle error cases
1363  select case (ierr)
1364  case (0)
1365  ! no error
1366  case (:-1)
1367  ! End of block was encountered
1368  irow = irow - 1
1369  exit readloop
1370  case (1:)
1371  ! Error
1372  inquire (unit=inunit, name=fname)
1373  write (errmsg, fmtlsterronly) trim(adjustl(fname)), inunit
1374  call store_error(errmsg, terminate=.true.)
1375  case default
1376  end select
1377  end do
1378  if (irow == this%nrow) exit readloop
1379  end do readloop
1380 
1381  ! Stop if errors were detected
1382  !if (count_errors() > 0) then
1383  ! call store_error_unit(inunit)
1384  !end if
1385 
1386  ! if deferred shape vectors were read, load to input path
1387  call this%memload_vectors()
1388 
1389  ! log loaded variables
1390  if (iout > 0) then
1391  call this%log_structarray_vars(iout)
1392  end if
1393  end function read_from_binary
1394 
1395  !> @brief link time-series strings in this struct array to a tsmanager
1396  !!
1397  !! Iterates over struct vectors that carry deferred TS tokens and
1398  !! registers each with the supplied tsmanager. Handles both BND
1399  !! (MTYPE_DBL / dbl1d) and AUX (MTYPE_DBL2D / dbl2d) columns.
1400  !! Pass auxname_cst only when AUX columns may carry time series.
1401  !!
1402  !<
1403  subroutine ts_update(this, tsmanager, subcomp_name, iprpak, input_name, &
1404  auxname_cst, clear_strlocs, ifno_map)
1405  class(structarraytype), intent(inout) :: this
1406  type(timeseriesmanagertype), pointer, intent(inout) :: tsmanager
1407  character(len=*), intent(in) :: subcomp_name
1408  integer(I4B), intent(in) :: iprpak
1409  character(len=*), intent(in) :: input_name
1410  type(characterstringtype), dimension(:), pointer, intent(in), &
1411  optional :: auxname_cst
1412  logical(LGP), optional, intent(in) :: clear_strlocs !< if .false. strlocs are preserved for re-registration (default .true.)
1413  integer(I4B), dimension(:), optional, intent(in) :: ifno_map !< if present, maps ts_strloc%row (PACKAGEDATA row) to its feature number, used as the TS link row address
1414  type(tsstringloctype), pointer :: ts_strloc
1415  type(timeserieslinktype), pointer :: tsLink
1416  real(DP), pointer :: bndElem
1417  character(len=LENBOUNDNAME) :: boundname
1418  integer(I4B) :: m, n, iboundname, irow
1419  logical(LGP) :: do_clear
1420 
1421  do_clear = .true.
1422  if (present(clear_strlocs)) do_clear = clear_strlocs
1423 
1424  ! find BOUNDNAME column (0 = none)
1425  iboundname = 0
1426  do m = 1, this%ncol
1427  if (this%struct_vectors(m)%idt%mf6varname == 'BOUNDNAME') then
1428  iboundname = m
1429  exit
1430  end if
1431  end do
1432 
1433  do m = 1, this%ncol
1434  if (.not. this%struct_vectors(m)%idt%timeseries) cycle
1435  do n = 1, this%struct_vectors(m)%ts_strlocs%count()
1436  ts_strloc => this%struct_vectors(m)%get_ts_strloc(n)
1437  nullify (tslink)
1438  irow = ts_strloc%row
1439  if (present(ifno_map)) irow = ifno_map(ts_strloc%row)
1440  select case (this%struct_vectors(m)%memtype)
1441  case (mtype_dbl) ! dbl1d (BND)
1442  bndelem => this%struct_vectors(m)%dbl1d(ts_strloc%row)
1443  ! -- JCol=0, consistent with ts_update_indexed, so a stale
1444  ! -- PACKAGEDATA-level link is found and cleared like AUX's
1445  call read_value_or_time_series(ts_strloc%token, irow, &
1446  0, bndelem, &
1447  subcomp_name, 'BND', tsmanager, &
1448  iprpak, tslink)
1449  if (associated(tslink)) then
1450  tslink%Text = this%struct_vectors(m)%idt%mf6varname
1451  if (iboundname > 0) then
1452  boundname = &
1453  this%struct_vectors(iboundname)%charstr1d(ts_strloc%row)
1454  tslink%BndName = boundname
1455  end if
1456  end if
1457  case (mtype_dbl2d) ! dbl2d (AUX)
1458  if (.not. present(auxname_cst)) cycle
1459  if (.not. associated(auxname_cst)) cycle
1460  bndelem => this%struct_vectors(m)%dbl2d(ts_strloc%col, ts_strloc%row)
1461  ! -- JCol is the AUX array position (ts_strloc%col), not the
1462  ! -- row-schema column, so remove_existing_link can find it
1463  call read_value_or_time_series(ts_strloc%token, irow, &
1464  ts_strloc%col, bndelem, &
1465  subcomp_name, 'AUX', tsmanager, &
1466  iprpak, tslink)
1467  if (associated(tslink)) then
1468  tslink%Text = auxname_cst(ts_strloc%col)
1469  if (iboundname > 0) then
1470  boundname = &
1471  this%struct_vectors(iboundname)%charstr1d(ts_strloc%row)
1472  tslink%BndName = boundname
1473  end if
1474  end if
1475  end select
1476  end do
1477  if (do_clear) call this%struct_vectors(m)%clear()
1478  end do
1479 
1480  if (count_errors() > 0) then
1481  call store_error_filename(input_name)
1482  end if
1483  end subroutine ts_update
1484 
1485  !> @brief Shared dedup-aware TS resolution for one PERIOD-block column:
1486  !! TS-linked rows resolve via their preserved token, remaining literal
1487  !! rows via remove_existing_link, then clear(). naux=1 (via both rank
1488  !! remaps in ts_update_indexed) covers the single-column BND case.
1489  !<
1490  subroutine ts_update_dedup(this, icol, tsmanager, subcomp_name, iprpak, &
1491  nrows, addr_map, category, names, featarr2d, &
1492  raw2d)
1493  class(structarraytype), intent(inout) :: this
1494  integer(I4B), intent(in) :: icol
1495  type(timeseriesmanagertype), pointer, intent(inout) :: tsmanager
1496  character(len=*), intent(in) :: subcomp_name
1497  character(len=*), intent(in) :: category !< 'AUX' or 'BND'
1498  integer(I4B), intent(in) :: iprpak
1499  integer(I4B), intent(in) :: nrows !< rows read this period
1500  integer(I4B), dimension(:), intent(in) :: addr_map !< PERIOD row -> feature index
1501  character(len=LENVARNAME), dimension(:), intent(in) :: names !< size naux
1502  real(DP), dimension(:, :), pointer, intent(in) :: featarr2d !< (naux, nfeatures) permanent target
1503  real(DP), dimension(:, :), pointer, intent(in) :: raw2d !< (naux, nrows) raw column source
1504  type(tsstringloctype), pointer :: ts_strloc
1505  real(DP), pointer :: bndElem
1506  logical(LGP) :: found
1507  integer(I4B) :: n, j, k, nts, i, naux
1508  logical(LGP), dimension(:, :), allocatable :: handled2
1509 
1510  naux = size(names)
1511  allocate (handled2(naux, nrows))
1512  handled2 = .false.
1513 
1514  ! time-series-linked rows: resolve via their preserved token
1515  nts = this%struct_vectors(icol)%ts_strlocs%count()
1516  do k = 1, nts
1517  ts_strloc => this%struct_vectors(icol)%get_ts_strloc(k)
1518  i = addr_map(ts_strloc%row)
1519  if (i < 1 .or. i > size(featarr2d, 2)) cycle
1520  bndelem => featarr2d(ts_strloc%col, i)
1522  ts_strloc%token, i, ts_strloc%col, bndelem, subcomp_name, &
1523  category, tsmanager, iprpak, trim(names(ts_strloc%col)))
1524  handled2(ts_strloc%col, ts_strloc%row) = .true.
1525  end do
1526 
1527  ! literal rows: clear any stale link, then assign; DNODATA means
1528  ! unset this row -- leave the value and any link untouched
1529  do n = 1, nrows
1530  i = addr_map(n)
1531  if (i < 1 .or. i > size(featarr2d, 2)) cycle
1532  do j = 1, naux
1533  if (handled2(j, n)) cycle
1534  if (raw2d(j, n) == dnodata) cycle
1535  found = remove_existing_link(tsmanager, i, j, subcomp_name, &
1536  category, trim(names(j)))
1537  featarr2d(j, i) = raw2d(j, n)
1538  end do
1539  end do
1540  deallocate (handled2)
1541 
1542  ! clear strlocs so a later period's parse (different row indexing)
1543  ! doesn't reprocess these against a mismatched addr_map
1544  call this%struct_vectors(icol)%clear()
1545  end subroutine ts_update_dedup
1546 
1547  !> @brief Dedup-aware counterpart to ts_update for one MTYPE_DBL2D
1548  !! (AUX) PERIOD-block column.
1549  !<
1550  subroutine ts_update_adv(this, icol, tsmanager, subcomp_name, iprpak, &
1551  nrows, ifno_map, auxname_cst, featarr2d)
1552  class(structarraytype), intent(inout) :: this
1553  integer(I4B), intent(in) :: icol
1554  type(timeseriesmanagertype), pointer, intent(inout) :: tsmanager
1555  character(len=*), intent(in) :: subcomp_name
1556  integer(I4B), intent(in) :: iprpak
1557  integer(I4B), intent(in) :: nrows !< rows read this period
1558  integer(I4B), dimension(:), intent(in) :: ifno_map !< PERIOD row -> feature index
1559  type(characterstringtype), dimension(:), pointer, intent(in) :: auxname_cst !< AUX column names, indexed 1..naux
1560  real(DP), dimension(:, :), pointer, intent(in) :: featarr2d !< permanent dbl2d (AUX) target
1561  character(len=LENVARNAME) :: names(size(auxname_cst))
1562  integer(I4B) :: j
1563 
1564  do j = 1, size(auxname_cst)
1565  names(j) = auxname_cst(j)
1566  end do
1567  call this%ts_update_dedup(icol, tsmanager, subcomp_name, iprpak, &
1568  nrows, ifno_map, 'AUX', names, featarr2d, &
1569  this%struct_vectors(icol)%dbl2d)
1570  end subroutine ts_update_adv
1571 
1572  !> @brief Dedup-aware resolution of one MTYPE_DBL PERIOD-block column
1573  !! into its permanent array, shared by both loaders. nrows is explicit
1574  !! since the list loader's row_addr is a permanent, maxbound-sized
1575  !! array, not sized to nrows.
1576  !<
1577  subroutine ts_update_indexed(this, icol, tsmanager, subcomp_name, &
1578  iprpak, nrows, row_addr, varname, featarr)
1579  class(structarraytype), intent(inout) :: this
1580  integer(I4B), intent(in) :: icol
1581  type(timeseriesmanagertype), pointer, intent(inout) :: tsmanager
1582  character(len=*), intent(in) :: subcomp_name
1583  integer(I4B), intent(in) :: iprpak
1584  integer(I4B), intent(in) :: nrows !< rows to process this period
1585  integer(I4B), dimension(:), intent(in) :: row_addr
1586  character(len=*), intent(in) :: varname
1587  real(DP), dimension(:), pointer, contiguous, intent(in) :: featarr
1588  real(DP), dimension(:, :), pointer :: featarr2d, raw2d
1589  character(len=LENVARNAME) :: names(1)
1590 
1591  ! naux=1 rank remaps onto the shared 2D core; neither is a copy
1592  featarr2d(1:1, 1:size(featarr)) => featarr
1593  raw2d(1:1, 1:nrows) => this%struct_vectors(icol)%dbl1d(1:nrows)
1594  names(1) = varname
1595  call this%ts_update_dedup(icol, tsmanager, subcomp_name, iprpak, &
1596  nrows, row_addr, 'BND', names, featarr2d, &
1597  raw2d)
1598  end subroutine ts_update_indexed
1599 
1600 end module structarraymodule
This module contains block parser methods.
Definition: BlockParser.f90:7
This module contains simulation constants.
Definition: Constants.f90:9
integer(i4b), parameter linelength
maximum length of a standard line
Definition: Constants.f90:45
integer(i4b), parameter lenmodelname
maximum length of the model name
Definition: Constants.f90:22
real(dp), parameter dnodata
real no data constant
Definition: Constants.f90:95
character(len= *), parameter idm_input_suffix
input array suffix applied when data array shares name
Definition: Constants.f90:135
integer(i4b), parameter lenvarname
maximum length of a variable name
Definition: Constants.f90:17
integer(i4b), parameter lenboundname
maximum length of a bound name
Definition: Constants.f90:36
integer(i4b), parameter izero
integer constant zero
Definition: Constants.f90:51
real(dp), parameter dzero
real constant zero
Definition: Constants.f90:65
integer(i4b), parameter lenmempath
maximum length of the memory path
Definition: Constants.f90:27
This module contains the Input Data Model Logger Module.
Definition: IdmLogger.f90:7
Input definition module.
subroutine, public upcase(word)
Convert to upper case.
This module defines variable data types.
Definition: kind.f90:8
character(len=lenmempath) function create_mem_path(component, subcomponent, context)
returns the path to the memory object
subroutine, public get_isize(name, mem_path, isize)
@ brief Get the number of elements for this variable
This module contains the ModflowInputModule.
Definition: ModflowInput.f90:9
This module contains simulation methods.
Definition: Sim.f90:10
subroutine, public store_error(msg, terminate)
Store an error message.
Definition: Sim.f90:92
integer(i4b) function, public count_errors()
Return number of errors.
Definition: Sim.f90:59
subroutine, public store_error_filename(filename, terminate)
Store the erroring file name.
Definition: Sim.f90:204
This module contains simulation variables.
Definition: SimVariables.f90:9
character(len=maxcharlen) errmsg
error message string
character(len=linelength) idm_context
This module contains the StructArrayModule.
Definition: StructArray.f90:8
integer(i4b) function count(this)
character(len=lenvarname) function, public idm_input_varname(idt)
Derive a TS-capable setting's raw input array name, distinct from its persistent array (allocated und...
integer(i4b) function read_from_binary(this, inunit, iout)
read from binary input to fill the StructArrayType
subroutine memload_vectors(this)
load deferred vectors into managed memory
integer(i4b) function read_from_parser_keystring(this, parser, timeseries, nleading, iout, input_name)
read keystring period block into the StructArrayType
subroutine set_pointer(sv, sv_target)
logical(lgp) function, public is_auxval(idt)
True if idt is AUXVAL: its AUX index is resolved dynamically from a sibling AUXNAME,...
subroutine allocate_dbl1d_type(this, sv)
allocate dbl1d input type
subroutine ts_update_dedup(this, icol, tsmanager, subcomp_name, iprpak, nrows, addr_map, category, names, featarr2d, raw2d)
Shared dedup-aware TS resolution for one PERIOD-block column: TS-linked rows resolve via their preser...
subroutine mem_create_metadata_vector(this, icol, idt, body_start, head_nbody)
Create a metadata-only StructVector for a KEYWORD indicator column.
subroutine check_reallocate(this)
reallocate local memory for deferred vectors if necessary
integer(i4b) function, public find_auxname_index(auxname, auxnames, naux)
Find the AUX array position matching auxname, 0 if none.
subroutine ts_update_adv(this, icol, tsmanager, subcomp_name, iprpak, nrows, ifno_map, auxname_cst, featarr2d)
Dedup-aware counterpart to ts_update for one MTYPE_DBL2D (AUX) PERIOD-block column.
subroutine load_deferred_vector(this, icol)
subroutine allocate_dbl_type(this, sv)
allocate double input type
subroutine allocate_charstr_type(this, sv)
allocate charstr input type
subroutine ts_update_indexed(this, icol, tsmanager, subcomp_name, iprpak, nrows, row_addr, varname, featarr)
Dedup-aware resolution of one MTYPE_DBL PERIOD-block column into its permanent array,...
subroutine mem_create_vector(this, icol, idt, charlen, varname)
create new vector in StructArrayType
integer(i4b) function read_from_parser(this, parser, timeseries, iout, input_name)
read from the block parser to fill the StructArrayType
subroutine allocate_int_type(this, sv)
allocate integer input type
subroutine ts_update(this, tsmanager, subcomp_name, iprpak, input_name, auxname_cst, clear_strlocs, ifno_map)
link time-series strings in this struct array to a tsmanager
subroutine log_structarray_vars(this, iout)
log information about the StructArrayType
subroutine read_param(this, parser, sv_col, irow, timeseries, iout)
subroutine, public destructstructarray(struct_array)
destructor for a struct_array
subroutine allocate_int1d_type(this, sv)
allocate int1d input type
type(structvectortype) function, pointer get(this, idx)
type(structarraytype) function, pointer, public constructstructarray(mf6_input, ncol, nrow, blocknum, mempath, component_mempath, size_init)
constructor for a struct_array
Definition: StructArray.f90:90
This module contains the StructVectorModule.
Definition: StructVector.f90:7
@, public mtype_intvec
intvector column
@, public mtype_dbl
dbl1d column
@, public mtype_int2d
int2d (NCELLDIM) column
@, public mtype_int
int1d column
@, public mtype_dbl2d
dbl2d (NAUX/NSEG) column
@, public mtype_str
charstr1d column
@, public mtype_undef
undefined memtype
subroutine, public read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, auxOrBnd, tsManager, iprpak, varName)
Call this subroutine from advanced packages to define timeseries link for a variable (varName).
logical function, public remove_existing_link(tsManager, ii, jj, pkgName, auxOrBnd, varName)
Remove an existing timeseries link if it is defined.
subroutine, public read_value_or_time_series(textInput, ii, jj, bndElem, pkgName, auxOrBnd, tsManager, iprpak, tsLink)
Call this subroutine if the time-series link is available or needed.
This class is used to store a single deferred-length character string. It was designed to work in an ...
Definition: CharString.f90:23
Input parameter definition. Describes an input parameter.
derived type for storing input definition for a file
type for structured array
Definition: StructArray.f90:47
derived type for generic vector
derived type which describes time series string field