40 integer(I4B) :: blocknum
41 logical(LGP) :: deferred_shape = .false.
42 integer(I4B) :: deferred_size_init = 5
43 character(len=LENMEMPATH) :: mempath
44 character(len=LENMEMPATH) :: component_mempath
46 integer(I4B),
dimension(:),
allocatable :: startidx
47 integer(I4B),
dimension(:),
allocatable :: numcols
73 component_mempath)
result(struct_array)
75 integer(I4B),
intent(in) :: ncol
76 integer(I4B),
intent(in) :: nrow
77 integer(I4B),
intent(in) :: blocknum
78 character(len=*),
intent(in) :: mempath
79 character(len=*),
intent(in) :: component_mempath
83 allocate (struct_array)
86 struct_array%mf6_input = mf6_input
89 struct_array%ncol = ncol
92 struct_array%nrow = nrow
93 if (struct_array%nrow == 0)
then
94 struct_array%deferred_shape = .true.
98 if (blocknum > 0)
then
99 struct_array%blocknum = blocknum
101 struct_array%blocknum = 0
105 struct_array%mempath = mempath
106 struct_array%component_mempath = component_mempath
109 allocate (struct_array%struct_vectors(ncol))
110 allocate (struct_array%startidx(ncol))
111 allocate (struct_array%numcols(ncol))
119 deallocate (struct_array%struct_vectors)
120 deallocate (struct_array%startidx)
121 deallocate (struct_array%numcols)
122 deallocate (struct_array)
123 nullify (struct_array)
130 integer(I4B),
intent(in) :: icol
133 integer(I4B) :: numcol
141 if (this%deferred_shape)
then
142 sv%size = this%deferred_size_init
148 select case (idt%datatype)
152 call this%allocate_int_type(sv)
156 call this%allocate_dbl_type(sv)
158 case (
'STRING',
'KEYWORD')
160 call this%allocate_charstr_type(sv)
164 call this%allocate_int1d_type(sv)
165 if (sv%memtype == 5)
then
171 call this%allocate_dbl1d_type(sv)
175 errmsg =
'IDM unimplemented. StructArray::mem_create_vector &
176 &type='//trim(idt%datatype)
181 this%struct_vectors(icol) = sv
183 this%numcols(icol) = numcol
185 this%startidx(icol) = 1
187 this%startidx(icol) = this%startidx(icol - 1) + this%numcols(icol - 1)
196 integer(I4B) ::
count
197 count =
size(this%struct_vectors)
206 function get(this, idx)
result(sv)
208 integer(I4B),
intent(in) :: idx
218 integer(I4B),
dimension(:),
pointer,
contiguous :: int1d
219 integer(I4B) :: j, nrow
221 if (this%deferred_shape)
then
223 nrow = this%deferred_size_init
224 allocate (int1d(this%deferred_size_init))
228 call mem_allocate(int1d, this%nrow, sv%idt%mf6varname, this%mempath)
248 real(DP),
dimension(:),
pointer,
contiguous :: dbl1d
249 integer(I4B) :: j, nrow
251 if (this%deferred_shape)
then
253 nrow = this%deferred_size_init
254 allocate (dbl1d(this%deferred_size_init))
258 call mem_allocate(dbl1d, this%nrow, sv%idt%mf6varname, this%mempath)
281 if (this%deferred_shape)
then
282 allocate (charstr1d(this%deferred_size_init))
285 sv%idt%mf6varname, this%mempath)
293 sv%charstr1d => charstr1d
307 integer(I4B),
dimension(:, :),
pointer,
contiguous :: int2d
309 integer(I4B),
pointer :: ncelldim, exgid
310 character(len=LENMEMPATH) :: input_mempath
311 character(len=LENMODELNAME) :: mname
314 integer(I4B) :: nrow, n, m
316 if (sv%idt%shape ==
'NCELLDIM')
then
319 if (this%mf6_input%component_type ==
'EXG')
then
322 call mem_setptr(exgid,
'EXGID', this%mf6_input%mempath)
327 if (sv%idt%tagname ==
'CELLIDM1')
then
328 call mem_setptr(charstr1d,
'EXGMNAMEA', input_mempath)
329 else if (sv%idt%tagname ==
'CELLIDM2')
then
330 call mem_setptr(charstr1d,
'EXGMNAMEB', input_mempath)
334 mname = charstr1d(exgid)
338 call mem_setptr(ncelldim, sv%idt%shape, input_mempath)
341 call mem_setptr(ncelldim, sv%idt%shape, this%component_mempath)
344 if (this%deferred_shape)
then
346 nrow = this%deferred_size_init
347 allocate (int2d(ncelldim, this%deferred_size_init))
353 sv%idt%mf6varname, this%mempath)
365 sv%intshape => ncelldim
373 call intvector%init()
376 sv%intvector => intvector
380 call mem_setptr(sv%intvector_shape, sv%idt%shape, this%mempath)
393 real(DP),
dimension(:, :),
pointer,
contiguous :: dbl2d
394 integer(I4B),
pointer :: naux, nseg, nseg_1
395 integer(I4B) :: nseg1_isize, n, m
397 if (sv%idt%shape ==
'NAUX')
then
398 call mem_setptr(naux, sv%idt%shape, this%mempath)
400 call mem_allocate(dbl2d, naux, this%nrow, sv%idt%mf6varname, this%mempath)
413 else if (sv%idt%shape ==
'NSEG-1')
then
416 call get_isize(
'NSEG_1', this%mempath, nseg1_isize)
418 if (nseg1_isize < 0)
then
422 call mem_setptr(nseg_1,
'NSEG_1', this%mempath)
425 call mem_allocate(dbl2d, nseg_1, this%nrow, sv%idt%mf6varname, this%mempath)
436 sv%intshape => nseg_1
439 errmsg =
'IDM unimplemented. StructArray::allocate_dbl1d_type &
440 & unsupported shape "'//trim(sv%idt%shape)//
'".'
451 integer(I4B),
intent(in) :: icol
452 integer(I4B) :: i, j, isize
453 integer(I4B),
dimension(:),
pointer,
contiguous :: p_int1d
454 integer(I4B),
dimension(:, :),
pointer,
contiguous :: p_int2d
455 real(DP),
dimension(:),
pointer,
contiguous :: p_dbl1d
457 character(len=LENVARNAME) :: varname
460 varname = this%struct_vectors(icol)%idt%mf6varname
463 call get_isize(varname, this%mempath, isize)
466 select case (this%struct_vectors(icol)%memtype)
472 call mem_setptr(p_int1d, varname, this%mempath)
476 call mem_reallocate(p_int1d, this%nrow + isize, varname, this%mempath)
479 p_int1d(isize + i) = this%struct_vectors(icol)%int1d(i)
484 call mem_allocate(p_int1d, this%nrow, varname, this%mempath)
488 p_int1d(i) = this%struct_vectors(icol)%int1d(i)
493 deallocate (this%struct_vectors(icol)%int1d)
496 this%struct_vectors(icol)%int1d => p_int1d
497 this%struct_vectors(icol)%size = this%nrow
502 call mem_setptr(p_dbl1d, varname, this%mempath)
507 p_dbl1d(isize + i) = this%struct_vectors(icol)%dbl1d(i)
510 call mem_allocate(p_dbl1d, this%nrow, varname, this%mempath)
513 p_dbl1d(i) = this%struct_vectors(icol)%dbl1d(i)
517 deallocate (this%struct_vectors(icol)%dbl1d)
519 this%struct_vectors(icol)%dbl1d => p_dbl1d
520 this%struct_vectors(icol)%size = this%nrow
525 call mem_setptr(p_charstr1d, varname, this%mempath)
530 p_charstr1d(isize + i) = this%struct_vectors(icol)%charstr1d(i)
538 p_charstr1d(i) = this%struct_vectors(icol)%charstr1d(i)
542 deallocate (this%struct_vectors(icol)%charstr1d)
544 this%struct_vectors(icol)%charstr1d => p_charstr1d
545 this%struct_vectors(icol)%size = this%nrow
551 call mem_setptr(p_int2d, varname, this%mempath)
552 call mem_reallocate(p_int2d, this%struct_vectors(icol)%intshape, &
553 this%nrow, varname, this%mempath)
556 do j = 1, this%struct_vectors(icol)%intshape
557 p_int2d(j, isize + i) = this%struct_vectors(icol)%int2d(j, i)
561 call mem_allocate(p_int2d, this%struct_vectors(icol)%intshape, &
562 this%nrow, varname, this%mempath)
565 do j = 1, this%struct_vectors(icol)%intshape
566 p_int2d(j, i) = this%struct_vectors(icol)%int2d(j, i)
571 deallocate (this%struct_vectors(icol)%int2d)
573 this%struct_vectors(icol)%int2d => p_int2d
574 this%struct_vectors(icol)%size = this%nrow
578 errmsg =
'IDM unimplemented. StructArray::load_deferred_vector &
579 &unsupported memtype.'
591 integer(I4B) :: icol, j
592 integer(I4B),
dimension(:),
pointer,
contiguous :: p_intvector
593 character(len=LENVARNAME) :: varname
595 do icol = 1, this%ncol
598 varname = this%struct_vectors(icol)%idt%mf6varname
600 if (this%struct_vectors(icol)%memtype == 4)
then
604 call this%struct_vectors(icol)%intvector%shrink_to_fit()
608 this%struct_vectors(icol)%intvector%size, &
609 varname, this%mempath)
612 do j = 1, this%struct_vectors(icol)%intvector%size
613 p_intvector(j) = this%struct_vectors(icol)%intvector%at(j)
617 call this%struct_vectors(icol)%intvector%destroy()
618 deallocate (this%struct_vectors(icol)%intvector)
619 nullify (this%struct_vectors(icol)%intvector_shape)
621 else if (this%deferred_shape)
then
624 call this%load_deferred_vector(icol)
636 integer(I4B),
intent(in) :: iout
638 integer(I4B),
dimension(:),
pointer,
contiguous :: int1d
644 select case (this%struct_vectors(j)%memtype)
649 this%struct_vectors(j)%idt%tagname, &
654 if (this%struct_vectors(j)%ts_strlocs%count() > 0)
then
655 call idm_log_var(this%struct_vectors(j)%idt%tagname, &
656 this%mempath, iout, .false.)
659 this%struct_vectors(j)%idt%tagname, &
665 call mem_setptr(int1d, this%struct_vectors(j)%idt%mf6varname, &
668 call idm_log_var(int1d, this%struct_vectors(j)%idt%tagname, &
674 this%struct_vectors(j)%idt%tagname, &
679 if (this%struct_vectors(j)%ts_strlocs%count() > 0)
then
680 call idm_log_var(this%struct_vectors(j)%idt%tagname, &
681 this%mempath, iout, .false.)
684 this%struct_vectors(j)%idt%tagname, &
700 integer(I4B) :: i, j, k, newsize
701 integer(I4B),
dimension(:),
pointer,
contiguous :: p_int1d
702 integer(I4B),
dimension(:, :),
pointer,
contiguous :: p_int2d
703 real(DP),
dimension(:),
pointer,
contiguous :: p_dbl1d
705 integer(I4B) :: reallocate_mult
713 select case (this%struct_vectors(j)%memtype)
718 if (this%nrow > this%struct_vectors(j)%size)
then
721 newsize = this%struct_vectors(j)%size * reallocate_mult
724 allocate (p_int1d(newsize))
727 do i = 1, this%struct_vectors(j)%size
728 p_int1d(i) = this%struct_vectors(j)%int1d(i)
732 deallocate (this%struct_vectors(j)%int1d)
735 this%struct_vectors(j)%int1d => p_int1d
736 this%struct_vectors(j)%size = newsize
740 if (this%nrow > this%struct_vectors(j)%size)
then
742 newsize = this%struct_vectors(j)%size * reallocate_mult
744 allocate (p_dbl1d(newsize))
746 do i = 1, this%struct_vectors(j)%size
747 p_dbl1d(i) = this%struct_vectors(j)%dbl1d(i)
750 deallocate (this%struct_vectors(j)%dbl1d)
752 this%struct_vectors(j)%dbl1d => p_dbl1d
753 this%struct_vectors(j)%size = newsize
757 if (this%nrow > this%struct_vectors(j)%size)
then
759 newsize = this%struct_vectors(j)%size * reallocate_mult
761 allocate (p_charstr1d(newsize))
763 do i = 1, this%struct_vectors(j)%size
764 p_charstr1d(i) = this%struct_vectors(j)%charstr1d(i)
767 deallocate (this%struct_vectors(j)%charstr1d)
769 this%struct_vectors(j)%charstr1d => p_charstr1d
770 this%struct_vectors(j)%size = newsize
773 if (this%nrow > this%struct_vectors(j)%size)
then
775 newsize = this%struct_vectors(j)%size * reallocate_mult
777 allocate (p_int2d(this%struct_vectors(j)%intshape, newsize))
779 do i = 1, this%struct_vectors(j)%size
780 do k = 1, this%struct_vectors(j)%intshape
781 p_int2d(k, i) = this%struct_vectors(j)%int2d(k, i)
785 deallocate (this%struct_vectors(j)%int2d)
787 this%struct_vectors(j)%int2d => p_int2d
788 this%struct_vectors(j)%size = newsize
792 errmsg =
'IDM unimplemented. StructArray::check_reallocate &
793 &unsupported memtype.'
806 integer(I4B),
intent(in) :: sv_col
807 integer(I4B),
intent(in) :: irow
808 logical(LGP),
intent(in) :: timeseries
809 integer(I4B),
intent(in) :: iout
810 integer(I4B),
optional,
intent(in) :: auxcol
811 integer(I4B) :: n, intval, numval, icol
812 character(len=LINELENGTH) :: str
813 character(len=:),
allocatable :: line
814 logical(LGP) :: preserve_case
816 select case (this%struct_vectors(sv_col)%memtype)
821 if (sv_col == 1 .and. this%blocknum > 0)
then
823 this%struct_vectors(sv_col)%int1d(irow) = this%blocknum
826 this%struct_vectors(sv_col)%int1d(irow) = parser%GetInteger()
831 if (this%struct_vectors(sv_col)%idt%timeseries .and. timeseries)
then
832 call parser%GetString(str)
833 if (
present(auxcol))
then
838 this%struct_vectors(sv_col)%dbl1d(irow) = &
839 this%struct_vectors(sv_col)%read_token(str, this%startidx(sv_col), &
842 this%struct_vectors(sv_col)%dbl1d(irow) = parser%GetDouble()
847 if (this%struct_vectors(sv_col)%idt%shape /=
'')
then
849 if (sv_col == this%ncol)
then
850 call parser%GetRemainingLine(line)
851 this%struct_vectors(sv_col)%charstr1d(irow) = line
857 preserve_case = (.not. this%struct_vectors(sv_col)%idt%preserve_case)
858 call parser%GetString(str, preserve_case)
859 this%struct_vectors(sv_col)%charstr1d(irow) = str
865 numval = this%struct_vectors(sv_col)%intvector_shape(irow)
869 intval = parser%GetInteger()
870 call this%struct_vectors(sv_col)%intvector%push_back(intval)
876 do n = 1, this%struct_vectors(sv_col)%intshape
877 this%struct_vectors(sv_col)%int2d(n, irow) = parser%GetInteger()
883 do n = 1, this%struct_vectors(sv_col)%intshape
884 if (this%struct_vectors(sv_col)%idt%timeseries .and. timeseries)
then
885 call parser%GetString(str)
886 icol = this%startidx(sv_col) + n - 1
887 this%struct_vectors(sv_col)%dbl2d(n, irow) = &
888 this%struct_vectors(sv_col)%read_token(str, icol, n, irow)
890 this%struct_vectors(sv_col)%dbl2d(n, irow) = parser%GetDouble()
905 logical(LGP),
intent(in) :: timeseries
906 integer(I4B),
intent(in) :: iout
907 integer(I4B) :: irow, j
908 logical(LGP) :: endofblock
917 call parser%GetNextLine(endofblock)
923 else if (this%deferred_shape)
then
926 this%nrow = this%nrow + 1
929 call this%check_reallocate()
938 call this%write_struct_vector(parser, j, irow, timeseries, iout)
944 call this%memload_vectors()
948 call this%log_structarray_vars(iout)
959 integer(I4B),
intent(in) :: inunit
960 integer(I4B),
intent(in) :: iout
961 integer(I4B) :: irow, ierr
963 integer(I4B) :: intval, numval
964 character(len=LINELENGTH) :: fname
965 character(len=*),
parameter :: fmtlsterronly = &
966 "('Error reading LIST from file: ',&
967 &1x,a,1x,' on UNIT: ',I0)"
970 if (this%deferred_shape)
then
972 errmsg =
'IDM unimplemented. StructArray::read_from_binary deferred shape &
973 ¬ supported for binary inputs.'
990 select case (this%struct_vectors(j)%memtype)
993 read (inunit, iostat=ierr) this%struct_vectors(j)%int1d(irow)
995 read (inunit, iostat=ierr) this%struct_vectors(j)%dbl1d(irow)
998 errmsg =
'List style binary inputs not supported &
999 &for text columns, tag='// &
1000 trim(this%struct_vectors(j)%idt%tagname)//
'.'
1006 numval = this%struct_vectors(j)%intvector_shape(irow)
1011 read (inunit, iostat=ierr) intval
1012 call this%struct_vectors(j)%intvector%push_back(intval)
1019 do k = 1, this%struct_vectors(j)%intshape
1021 read (inunit, iostat=ierr) this%struct_vectors(j)%int2d(k, irow)
1026 do k = 1, this%struct_vectors(j)%intshape
1028 read (inunit, iostat=ierr) this%struct_vectors(j)%dbl2d(k, irow)
1046 inquire (unit=inunit, name=fname)
1047 write (
errmsg, fmtlsterronly) trim(adjustl(fname)), inunit
1055 if (irow == this%nrow)
exit readloop
1065 call this%memload_vectors()
1069 call this%log_structarray_vars(iout)
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
integer(i4b), parameter lenvarname
maximum length of a variable 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.
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)
subroutine mem_create_vector(this, icol, idt)
create new vector in StructArrayType
type(structarraytype) function, pointer, public constructstructarray(mf6_input, ncol, nrow, blocknum, mempath, component_mempath)
constructor for a struct_array
integer(i4b) function read_from_parser(this, parser, timeseries, iout)
read from the block parser to fill the StructArrayType
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
subroutine set_pointer(sv, sv_target)
subroutine allocate_dbl1d_type(this, sv)
allocate dbl1d input type
subroutine check_reallocate(this)
reallocate local memory for deferred vectors if necessary
subroutine load_deferred_vector(this, icol)
subroutine write_struct_vector(this, parser, sv_col, irow, timeseries, iout, auxcol)
subroutine allocate_dbl_type(this, sv)
allocate double input type
subroutine allocate_charstr_type(this, sv)
allocate charstr input type
subroutine allocate_int_type(this, sv)
allocate integer input type
subroutine log_structarray_vars(this, iout)
log information about the StructArrayType
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)
This module contains the StructVectorModule.
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