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
56 integer(I4B),
dimension(:),
allocatable :: startidx
57 integer(I4B),
dimension(:),
allocatable :: numcols
89 component_mempath, size_init)
result(struct_array)
91 integer(I4B),
intent(in) :: ncol
92 integer(I4B),
intent(in) :: nrow
93 integer(I4B),
intent(in) :: blocknum
94 character(len=*),
intent(in) :: mempath
95 character(len=*),
intent(in) :: component_mempath
96 integer(I4B),
optional,
intent(in) :: size_init
100 allocate (struct_array)
103 struct_array%mf6_input = mf6_input
106 struct_array%ncol = ncol
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
115 if (size_init >= 1) struct_array%deferred_size_init = size_init
120 if (blocknum > 0)
then
121 struct_array%blocknum = blocknum
123 struct_array%blocknum = 0
127 struct_array%mempath = mempath
128 struct_array%component_mempath = component_mempath
131 allocate (struct_array%struct_vectors(ncol))
132 allocate (struct_array%startidx(ncol))
133 allocate (struct_array%numcols(ncol))
140 deallocate (struct_array%struct_vectors)
141 deallocate (struct_array%startidx)
142 deallocate (struct_array%numcols)
143 deallocate (struct_array)
144 nullify (struct_array)
151 integer(I4B),
intent(in) :: icol
153 integer(I4B),
optional,
intent(in) :: charlen
154 character(len=*),
optional,
intent(in) :: varname
156 integer(I4B) :: numcol
162 if (
present(charlen)) sv%charlen = charlen
163 if (
present(varname)) sv%varname_override = varname
166 if (this%deferred_shape)
then
167 sv%size = this%deferred_size_init
173 select case (idt%datatype)
175 call this%allocate_int_type(sv)
177 call this%allocate_dbl_type(sv)
178 case (
'STRING',
'KEYWORD')
179 call this%allocate_charstr_type(sv)
181 call this%allocate_int1d_type(sv)
186 call this%allocate_dbl1d_type(sv)
189 errmsg =
'IDM unimplemented. StructArray::mem_create_vector &
190 &type='//trim(idt%datatype)
195 this%struct_vectors(icol) = sv
196 this%numcols(icol) = numcol
198 this%startidx(icol) = 1
200 this%startidx(icol) = this%startidx(icol - 1) + this%numcols(icol - 1)
212 integer(I4B),
intent(in) :: icol
214 integer(I4B),
intent(in) :: body_start
215 integer(I4B),
intent(in) :: head_nbody
220 sv%body_start = body_start
221 sv%head_nbody = head_nbody
225 this%struct_vectors(icol) = sv
226 this%numcols(icol) = 0
228 this%startidx(icol) = 1
230 this%startidx(icol) = this%startidx(icol - 1) + this%numcols(icol - 1)
239 character(len=LENVARNAME) :: varname
242 write (
errmsg,
'(*(G0))') &
243 'IDM mf6internal "', trim(idt%mf6varname),
'" exceeds ', &
254 integer(I4B) ::
count
255 count =
size(this%struct_vectors)
264 function get(this, idx)
result(sv)
266 integer(I4B),
intent(in) :: idx
276 integer(I4B),
dimension(:),
pointer,
contiguous :: int1d
277 integer(I4B) :: j, nrow
279 if (this%deferred_shape)
then
281 nrow = this%deferred_size_init
282 allocate (int1d(this%deferred_size_init))
286 call mem_allocate(int1d, this%nrow, sv%idt%mf6varname, this%mempath)
303 real(DP),
dimension(:),
pointer,
contiguous :: dbl1d
304 character(len=LENVARNAME) :: varname
305 integer(I4B) :: j, nrow
307 varname = sv%idt%mf6varname
308 if (len_trim(sv%varname_override) > 0) varname = sv%varname_override
310 if (this%deferred_shape)
then
312 nrow = this%deferred_size_init
313 allocate (dbl1d(this%deferred_size_init))
317 call mem_allocate(dbl1d, this%nrow, varname, this%mempath)
337 if (this%deferred_shape)
then
338 allocate (charstr1d(this%deferred_size_init))
341 sv%idt%mf6varname, this%mempath)
349 sv%charstr1d => charstr1d
360 integer(I4B),
dimension(:, :),
pointer,
contiguous :: int2d
363 integer(I4B),
pointer :: ncelldim, exgid
364 character(len=LENMEMPATH) :: input_mempath
365 character(len=LENMODELNAME) :: mname
368 integer(I4B) :: nrow, n, m
370 if (sv%idt%shape ==
'NCELLDIM')
then
372 if (this%mf6_input%component_type ==
'EXG')
then
374 call mem_setptr(exgid,
'EXGID', this%mf6_input%mempath)
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)
384 mname = charstr1d(exgid)
388 call mem_setptr(ncelldim, sv%idt%shape, input_mempath)
390 call mem_setptr(ncelldim, sv%idt%shape, this%component_mempath)
393 if (this%deferred_shape)
then
395 nrow = this%deferred_size_init
396 allocate (int2d(ncelldim, this%deferred_size_init))
401 sv%idt%mf6varname, this%mempath)
413 sv%intshape => ncelldim
418 call intvector%init()
420 sv%intvector => intvector
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
430 sv%intvector_ragged = .true.
433 call mem_setptr(sv%intvector_shape, sv%idt%shape, this%mempath)
444 real(DP),
dimension(:, :),
pointer,
contiguous :: dbl2d
445 integer(I4B),
pointer :: naux, nseg, nseg_1
446 integer(I4B) :: nseg1_isize, n, m
448 if (sv%idt%shape ==
'NAUX')
then
449 call mem_setptr(naux, sv%idt%shape, this%mempath)
451 if (this%deferred_shape)
then
453 allocate (dbl2d(naux, sv%size))
455 call mem_allocate(dbl2d, naux, this%nrow, sv%idt%mf6varname, this%mempath)
468 else if (sv%idt%shape ==
'NSEG-1')
then
470 call get_isize(
'NSEG_1', this%mempath, nseg1_isize)
472 if (nseg1_isize < 0)
then
476 call mem_setptr(nseg_1,
'NSEG_1', this%mempath)
479 if (this%deferred_shape)
then
481 allocate (dbl2d(nseg_1, sv%size))
483 call mem_allocate(dbl2d, nseg_1, sv%size, sv%idt%mf6varname, this%mempath)
495 sv%intshape => nseg_1
497 errmsg =
'IDM unimplemented. StructArray::allocate_dbl1d_type &
498 & unsupported shape "'//trim(sv%idt%shape)//
'".'
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
513 character(len=LENVARNAME) :: varname
514 logical(LGP) :: overwrite
517 if (this%struct_vectors(icol)%idt%blockname ==
'SOLUTIONGROUP') &
521 varname = this%struct_vectors(icol)%idt%mf6varname
523 call get_isize(varname, this%mempath, isize)
526 select case (this%struct_vectors(icol)%memtype)
530 call mem_setptr(p_int1d, varname, this%mempath)
534 if (this%nrow > isize)
then
541 p_int1d(i) = this%struct_vectors(icol)%int1d(i)
544 if (isize > this%nrow)
then
546 do i = this%nrow + 1, isize
552 call mem_reallocate(p_int1d, this%nrow + isize, varname, this%mempath)
556 p_int1d(isize + i) = this%struct_vectors(icol)%int1d(i)
561 call mem_allocate(p_int1d, this%nrow, varname, this%mempath)
565 p_int1d(i) = this%struct_vectors(icol)%int1d(i)
570 deallocate (this%struct_vectors(icol)%int1d)
573 this%struct_vectors(icol)%int1d => p_int1d
574 this%struct_vectors(icol)%size = this%nrow
577 call mem_setptr(p_dbl1d, varname, this%mempath)
580 if (this%nrow > isize)
then
585 p_dbl1d(i) = this%struct_vectors(icol)%dbl1d(i)
588 if (isize > this%nrow)
then
589 do i = this%nrow + 1, isize
597 p_dbl1d(isize + i) = this%struct_vectors(icol)%dbl1d(i)
601 call mem_allocate(p_dbl1d, this%nrow, varname, this%mempath)
604 p_dbl1d(i) = this%struct_vectors(icol)%dbl1d(i)
608 deallocate (this%struct_vectors(icol)%dbl1d)
610 this%struct_vectors(icol)%dbl1d => p_dbl1d
611 this%struct_vectors(icol)%size = this%nrow
615 call mem_setptr(p_charstr1d, varname, this%mempath)
618 if (this%nrow > isize)
then
619 call mem_reallocate(p_charstr1d, this%struct_vectors(icol)%charlen, &
620 this%nrow, varname, this%mempath)
624 p_charstr1d(i) = this%struct_vectors(icol)%charstr1d(i)
627 if (isize > this%nrow)
then
628 do i = this%nrow + 1, isize
633 call mem_reallocate(p_charstr1d, this%struct_vectors(icol)%charlen, &
634 this%nrow + isize, varname, this%mempath)
636 p_charstr1d(isize + i) = this%struct_vectors(icol)%charstr1d(i)
640 call mem_allocate(p_charstr1d, this%struct_vectors(icol)%charlen, &
641 this%nrow, varname, this%mempath)
643 p_charstr1d(i) = this%struct_vectors(icol)%charstr1d(i)
644 call this%struct_vectors(icol)%charstr1d(i)%destroy()
648 deallocate (this%struct_vectors(icol)%charstr1d)
650 this%struct_vectors(icol)%charstr1d => p_charstr1d
651 this%struct_vectors(icol)%size = this%nrow
653 errmsg =
'StructArray::load_deferred_vector &
654 &intvector reallocate unimplemented.'
658 errmsg =
'StructArray::load_deferred_vector &
659 &int2d reallocate unimplemented.'
662 call mem_allocate(p_int2d, this%struct_vectors(icol)%intshape, &
663 this%nrow, varname, this%mempath)
665 do j = 1, this%struct_vectors(icol)%intshape
666 p_int2d(j, i) = this%struct_vectors(icol)%int2d(j, i)
671 deallocate (this%struct_vectors(icol)%int2d)
673 this%struct_vectors(icol)%int2d => p_int2d
674 this%struct_vectors(icol)%size = this%nrow
677 errmsg =
'StructArray::load_deferred_vector &
678 &dbl2d reallocate unimplemented.'
681 call mem_allocate(p_dbl2d, this%struct_vectors(icol)%intshape, &
682 this%nrow, varname, this%mempath)
684 do j = 1, this%struct_vectors(icol)%intshape
685 p_dbl2d(j, i) = this%struct_vectors(icol)%dbl2d(j, i)
690 deallocate (this%struct_vectors(icol)%dbl2d)
692 this%struct_vectors(icol)%dbl2d => p_dbl2d
693 this%struct_vectors(icol)%size = this%nrow
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
707 do icol = 1, this%ncol
709 varname = this%struct_vectors(icol)%idt%mf6varname
711 if (this%struct_vectors(icol)%memtype ==
mtype_intvec)
then
714 call this%struct_vectors(icol)%intvector%shrink_to_fit()
718 this%struct_vectors(icol)%intvector%size, &
719 varname, this%mempath)
722 do j = 1, this%struct_vectors(icol)%intvector%size
723 p_intvector(j) = this%struct_vectors(icol)%intvector%at(j)
727 call this%struct_vectors(icol)%intvector%destroy()
728 deallocate (this%struct_vectors(icol)%intvector)
729 nullify (this%struct_vectors(icol)%intvector_shape)
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)
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
743 call this%load_deferred_vector(icol)
752 integer(I4B),
intent(in) :: iout
753 integer(I4B) :: j, nts
754 integer(I4B),
dimension(:),
pointer,
contiguous :: int1d
755 character(len=LINELENGTH) :: ts_count_str
760 select case (this%struct_vectors(j)%memtype)
763 this%struct_vectors(j)%idt%tagname, &
766 nts = this%struct_vectors(j)%ts_strlocs%count()
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))
773 this%struct_vectors(j)%idt%tagname, &
777 call mem_setptr(int1d, this%struct_vectors(j)%idt%mf6varname, &
779 call idm_log_var(int1d, this%struct_vectors(j)%idt%tagname, &
783 this%struct_vectors(j)%idt%tagname, &
786 nts = this%struct_vectors(j)%ts_strlocs%count()
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))
793 this%struct_vectors(j)%idt%tagname, &
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
810 integer(I4B) :: reallocate_mult
817 select case (this%struct_vectors(j)%memtype)
820 if (this%nrow > this%struct_vectors(j)%size)
then
822 newsize = this%struct_vectors(j)%size * reallocate_mult
824 allocate (p_int1d(newsize))
827 do i = 1, this%struct_vectors(j)%size
828 p_int1d(i) = this%struct_vectors(j)%int1d(i)
832 deallocate (this%struct_vectors(j)%int1d)
835 this%struct_vectors(j)%int1d => p_int1d
836 this%struct_vectors(j)%size = newsize
839 if (this%nrow > this%struct_vectors(j)%size)
then
840 newsize = this%struct_vectors(j)%size * reallocate_mult
841 allocate (p_dbl1d(newsize))
843 do i = 1, this%struct_vectors(j)%size
844 p_dbl1d(i) = this%struct_vectors(j)%dbl1d(i)
847 deallocate (this%struct_vectors(j)%dbl1d)
849 this%struct_vectors(j)%dbl1d => p_dbl1d
850 this%struct_vectors(j)%size = newsize
854 if (this%nrow > this%struct_vectors(j)%size)
then
855 newsize = this%struct_vectors(j)%size * reallocate_mult
856 allocate (p_charstr1d(newsize))
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()
863 deallocate (this%struct_vectors(j)%charstr1d)
865 this%struct_vectors(j)%charstr1d => p_charstr1d
866 this%struct_vectors(j)%size = newsize
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))
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)
879 deallocate (this%struct_vectors(j)%int2d)
881 this%struct_vectors(j)%int2d => p_int2d
882 this%struct_vectors(j)%size = newsize
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))
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)
895 deallocate (this%struct_vectors(j)%dbl2d)
897 this%struct_vectors(j)%dbl2d => p_dbl2d
898 this%struct_vectors(j)%size = newsize
903 errmsg =
'IDM unimplemented. StructArray::check_reallocate &
904 &unsupported memtype.'
910 subroutine read_param(this, parser, sv_col, irow, timeseries, iout)
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
918 integer(I4B) :: n, intval, numval, icol
919 character(len=LINELENGTH) :: str
920 character(len=:),
allocatable :: line
921 logical(LGP) :: preserve_case, success
923 select case (this%struct_vectors(sv_col)%memtype)
926 write (
errmsg,
'(a,i0)') &
927 'IDM read_param called for MTYPE_UNDEF metadata vector at column ', sv_col
931 if (sv_col == 1 .and. this%blocknum > 0)
then
933 this%struct_vectors(sv_col)%int1d(irow) = this%blocknum
936 this%struct_vectors(sv_col)%int1d(irow) = parser%GetInteger()
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), &
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)
948 this%struct_vectors(sv_col)%dbl1d(irow) =
dnodata
950 this%struct_vectors(sv_col)%dbl1d(irow) = parser%GetDouble()
953 if (this%struct_vectors(sv_col)%idt%shape /=
'' .and. &
954 sv_col == this%ncol)
then
956 call parser%GetRemainingLine(line)
957 this%struct_vectors(sv_col)%charstr1d(irow) = line
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
967 if (this%struct_vectors(sv_col)%intvector_ragged)
then
973 call parser%TryGetInteger(intval, success)
975 call this%struct_vectors(sv_col)%intvector%push_back(intval)
981 numval = this%struct_vectors(sv_col)%intvector_shape(irow)
984 intval = parser%GetInteger()
985 call this%struct_vectors(sv_col)%intvector%push_back(intval)
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)
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)
999 if (str ==
'NONE')
then
1001 do n = 1, this%struct_vectors(sv_col)%intshape
1002 this%struct_vectors(sv_col)%int2d(n, irow) = 0
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: ', &
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()
1019 do n = 1, this%struct_vectors(sv_col)%intshape
1020 this%struct_vectors(sv_col)%int2d(n, irow) = parser%GetInteger()
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)
1032 this%struct_vectors(sv_col)%dbl2d(n, irow) = parser%GetDouble()
1045 res = (trim(idt%tagname) ==
'AUXVAL')
1051 character(len=*),
intent(in) :: auxname
1053 integer(I4B),
intent(in) :: naux
1055 character(len=LINELENGTH) :: thisauxname
1060 thisauxname = auxnames(n)
1061 if (trim(auxname) == trim(thisauxname))
then
1074 logical(LGP),
intent(in) :: timeseries
1075 integer(I4B),
intent(in) :: iout
1076 character(len=*),
intent(in) :: input_name
1077 integer(I4B) :: irow, j
1078 logical(LGP) :: endofblock
1084 if (this%deferred_shape)
then
1091 call parser%GetNextLine(endofblock)
1092 if (endofblock)
then
1095 else if (this%deferred_shape)
then
1097 this%nrow = this%nrow + 1
1099 call this%check_reallocate()
1103 if (this%deferred_shape)
then
1106 if (irow > this%nrow)
then
1107 write (
errmsg,
'(a,i0,a)') &
1108 'Input error: line count exceeds input dimension. Expected rows=', &
1116 call this%read_param(parser, j, irow, timeseries, iout)
1120 call this%memload_vectors()
1123 call this%log_structarray_vars(iout)
1149 iout, input_name)
result(irow)
1154 logical(LGP),
intent(in) :: timeseries
1155 integer(I4B),
intent(in) :: nleading
1156 integer(I4B),
intent(in) :: iout
1157 character(len=*),
intent(in) :: input_name
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
1167 if (nleading + 1 <= this%ncol)
then
1168 if (trim(this%struct_vectors(nleading + 1)%idt%tagname) ==
'SETTING')
then
1169 setting_icol = nleading + 1
1174 if (this%deferred_shape)
then
1179 call parser%GetNextLine(endofblock)
1180 if (endofblock)
exit
1182 if (this%deferred_shape)
then
1183 this%nrow = this%nrow + 1
1184 call this%check_reallocate()
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=', &
1201 do icol = 1, nleading
1202 call this%read_param(parser, icol, irow, .false., iout)
1206 call parser%GetString(keyword)
1213 do while (icol <= this%ncol)
1214 if (icol == setting_icol)
then
1218 if (trim(this%struct_vectors(icol)%idt%tagname) == trim(keyword))
then
1222 if (this%struct_vectors(icol)%head_nbody > 0)
then
1223 icol = icol + this%struct_vectors(icol)%head_nbody + 1
1229 if (found_col < 1)
then
1230 write (
errmsg,
'(a,a,a)') &
1231 'Unrecognized keystring keyword "', trim(keyword), &
1232 '" in PERIOD block.'
1240 if (setting_icol > 0)
then
1241 this%struct_vectors(setting_icol)%charstr1d(irow) = &
1242 trim(this%struct_vectors(found_col)%idt%mf6varname)
1246 is_keyword_dispatch = &
1247 (this%struct_vectors(found_col)%idt%datatype ==
'KEYWORD')
1249 if (is_keyword_dispatch)
then
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)
1264 call this%read_param(parser, found_col, irow, timeseries, iout)
1265 last_set_col = found_col
1269 do icol = nleading + 1, this%ncol
1271 if (icol == setting_icol) cycle
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)
1277 this%struct_vectors(icol)%int1d(irow) =
izero
1279 this%struct_vectors(icol)%dbl1d(irow) =
dnodata
1281 this%struct_vectors(icol)%charstr1d(irow) =
''
1286 call this%memload_vectors()
1289 call this%log_structarray_vars(iout)
1297 integer(I4B),
intent(in) :: inunit
1298 integer(I4B),
intent(in) :: iout
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)"
1308 if (this%deferred_shape)
then
1309 errmsg =
'IDM unimplemented. StructArray::read_from_binary deferred shape &
1310 ¬ supported for binary inputs.'
1321 select case (this%struct_vectors(j)%memtype)
1323 read (inunit, iostat=ierr) this%struct_vectors(j)%int1d(irow)
1325 read (inunit, iostat=ierr) this%struct_vectors(j)%dbl1d(irow)
1327 errmsg =
'List style binary inputs not supported &
1328 &for text columns, tag='// &
1329 trim(this%struct_vectors(j)%idt%tagname)//
'.'
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)//
'.'
1339 numval = this%struct_vectors(j)%intvector_shape(irow)
1343 read (inunit, iostat=ierr) intval
1344 call this%struct_vectors(j)%intvector%push_back(intval)
1349 do k = 1, this%struct_vectors(j)%intshape
1351 read (inunit, iostat=ierr) this%struct_vectors(j)%int2d(k, irow)
1355 do k = 1, this%struct_vectors(j)%intshape
1357 read (inunit, iostat=ierr) this%struct_vectors(j)%dbl2d(k, irow)
1372 inquire (unit=inunit, name=fname)
1373 write (
errmsg, fmtlsterronly) trim(adjustl(fname)), inunit
1378 if (irow == this%nrow)
exit readloop
1387 call this%memload_vectors()
1391 call this%log_structarray_vars(iout)
1403 subroutine ts_update(this, tsmanager, subcomp_name, iprpak, input_name, &
1404 auxname_cst, clear_strlocs, ifno_map)
1407 character(len=*),
intent(in) :: subcomp_name
1408 integer(I4B),
intent(in) :: iprpak
1409 character(len=*),
intent(in) :: input_name
1411 optional :: auxname_cst
1412 logical(LGP),
optional,
intent(in) :: clear_strlocs
1413 integer(I4B),
dimension(:),
optional,
intent(in) :: ifno_map
1416 real(DP),
pointer :: bndElem
1417 character(len=LENBOUNDNAME) :: boundname
1418 integer(I4B) :: m, n, iboundname, irow
1419 logical(LGP) :: do_clear
1422 if (
present(clear_strlocs)) do_clear = clear_strlocs
1427 if (this%struct_vectors(m)%idt%mf6varname ==
'BOUNDNAME')
then
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)
1438 irow = ts_strloc%row
1439 if (
present(ifno_map)) irow = ifno_map(ts_strloc%row)
1440 select case (this%struct_vectors(m)%memtype)
1442 bndelem => this%struct_vectors(m)%dbl1d(ts_strloc%row)
1447 subcomp_name,
'BND', tsmanager, &
1449 if (
associated(tslink))
then
1450 tslink%Text = this%struct_vectors(m)%idt%mf6varname
1451 if (iboundname > 0)
then
1453 this%struct_vectors(iboundname)%charstr1d(ts_strloc%row)
1454 tslink%BndName = boundname
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)
1464 ts_strloc%col, bndelem, &
1465 subcomp_name,
'AUX', tsmanager, &
1467 if (
associated(tslink))
then
1468 tslink%Text = auxname_cst(ts_strloc%col)
1469 if (iboundname > 0)
then
1471 this%struct_vectors(iboundname)%charstr1d(ts_strloc%row)
1472 tslink%BndName = boundname
1477 if (do_clear)
call this%struct_vectors(m)%clear()
1491 nrows, addr_map, category, names, featarr2d, &
1494 integer(I4B),
intent(in) :: icol
1496 character(len=*),
intent(in) :: subcomp_name
1497 character(len=*),
intent(in) :: category
1498 integer(I4B),
intent(in) :: iprpak
1499 integer(I4B),
intent(in) :: nrows
1500 integer(I4B),
dimension(:),
intent(in) :: addr_map
1501 character(len=LENVARNAME),
dimension(:),
intent(in) :: names
1502 real(DP),
dimension(:, :),
pointer,
intent(in) :: featarr2d
1503 real(DP),
dimension(:, :),
pointer,
intent(in) :: raw2d
1505 real(DP),
pointer :: bndElem
1506 logical(LGP) :: found
1507 integer(I4B) :: n, j, k, nts, i, naux
1508 logical(LGP),
dimension(:, :),
allocatable :: handled2
1511 allocate (handled2(naux, nrows))
1515 nts = this%struct_vectors(icol)%ts_strlocs%count()
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.
1531 if (i < 1 .or. i >
size(featarr2d, 2)) cycle
1533 if (handled2(j, n)) cycle
1534 if (raw2d(j, n) ==
dnodata) cycle
1536 category, trim(names(j)))
1537 featarr2d(j, i) = raw2d(j, n)
1540 deallocate (handled2)
1544 call this%struct_vectors(icol)%clear()
1551 nrows, ifno_map, auxname_cst, featarr2d)
1553 integer(I4B),
intent(in) :: icol
1555 character(len=*),
intent(in) :: subcomp_name
1556 integer(I4B),
intent(in) :: iprpak
1557 integer(I4B),
intent(in) :: nrows
1558 integer(I4B),
dimension(:),
intent(in) :: ifno_map
1560 real(DP),
dimension(:, :),
pointer,
intent(in) :: featarr2d
1561 character(len=LENVARNAME) :: names(size(auxname_cst))
1564 do j = 1,
size(auxname_cst)
1565 names(j) = auxname_cst(j)
1567 call this%ts_update_dedup(icol, tsmanager, subcomp_name, iprpak, &
1568 nrows, ifno_map,
'AUX', names, featarr2d, &
1569 this%struct_vectors(icol)%dbl2d)
1578 iprpak, nrows, row_addr, varname, featarr)
1580 integer(I4B),
intent(in) :: icol
1582 character(len=*),
intent(in) :: subcomp_name
1583 integer(I4B),
intent(in) :: iprpak
1584 integer(I4B),
intent(in) :: nrows
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)
1592 featarr2d(1:1, 1:
size(featarr)) => featarr
1593 raw2d(1:1, 1:nrows) => this%struct_vectors(icol)%dbl1d(1:nrows)
1595 call this%ts_update_dedup(icol, tsmanager, subcomp_name, iprpak, &
1596 nrows, row_addr,
'BND', names, featarr2d, &
This module contains block parser methods.
This module contains simulation constants.
integer(i4b), parameter linelength
maximum length of a standard line
integer(i4b), parameter lenmodelname
maximum length of the model name
real(dp), parameter dnodata
real no data constant
character(len= *), parameter idm_input_suffix
input array suffix applied when data array shares name
integer(i4b), parameter lenvarname
maximum length of a variable name
integer(i4b), parameter lenboundname
maximum length of a bound name
integer(i4b), parameter izero
integer constant zero
real(dp), parameter dzero
real constant zero
integer(i4b), parameter lenmempath
maximum length of the memory path
This module contains the Input Data Model Logger Module.
This module defines variable data types.
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 simulation methods.
subroutine, public store_error(msg, terminate)
Store an error message.
integer(i4b) function, public count_errors()
Return number of errors.
subroutine, public store_error_filename(filename, terminate)
Store the erroring file name.
This module contains simulation variables.
character(len=maxcharlen) errmsg
error message string
character(len=linelength) idm_context
This module contains the StructArrayModule.
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
This module contains the StructVectorModule.
@, 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 ...
type for structured array
derived type for generic vector
derived type which describes time series string field