idm SA deferred size updates

Author: mjreno

src/Utilities/Idm/mf6blockfile/LoadMf6File.f90

@@ -627,10 +627,18 @@ subroutine parse_structarray_block(this, iblk)
       nrows = -1
     end if
 
-    ! create a structured array
-    this%structarray => constructStructArray(this%mf6_input, ncol, nrows, &
-                                             blocknum, this%mf6_input%mempath, &
-                                             this%mf6_input%component_mempath)
+    ! create a structured array; use a larger deferred init for blocks with no
+    ! explicit shape, which include APT based advanced packages.
+    if (nrows < 0) then
+      this%structarray => constructStructArray(this%mf6_input, ncol, nrows, &
+                                               blocknum, this%mf6_input%mempath, &
+                                               this%mf6_input%component_mempath, &
+                                               size_init=64)
+    else
+      this%structarray => constructStructArray(this%mf6_input, ncol, nrows, &
+                                               blocknum, this%mf6_input%mempath, &
+                                               this%mf6_input%component_mempath)
+    end if
     ! create structarray vectors for each column
     do icol = 1, ncol
       ! if block is reloadable, block number is first column

src/Utilities/Idm/mf6blockfile/Mf6FileKeystring.f90

@@ -133,19 +133,26 @@ end subroutine ainit
 
   subroutine df(this)
     use StructArrayModule, only: StructArrayType
+    use MemoryManagerModule, only: mem_setptr, get_isize
+    use CharacterStringModule, only: CharacterStringType
     class(KeystringLoadType), intent(inout) :: this
     type(StructArrayType), pointer :: sa
-    integer(I4B) :: n
+    type(CharacterStringType), dimension(:), pointer, contiguous :: &
+      auxnames => null()
+    integer(I4B) :: n, naux
     ! init tsmanager (TDIS now available)
     call this%tsmanager%tsmanager_df()
+    ! resolve aux names for PACKAGEDATA AUX TS registration
+    call get_isize('AUXILIARY', this%mf6_input%mempath, naux)
+    if (naux > 0) call mem_setptr(auxnames, 'AUXILIARY', this%mf6_input%mempath)
     ! register static TS links; mark as static so they survive reset
     do n = 1, this%static_loader%ts_sa_count()
       sa => this%static_loader%get_ts_sa(n)
       if (associated(sa)) then
         call sa%ts_update(this%tsmanager, &
                           this%mf6_input%subcomponent_name, &
                           this%ctx%iprpak, this%input_name, &
-                          is_static=.true.)
+                          is_static=.true., auxname_cst=auxnames)
       end if
     end do
   end subroutine df
@@ -221,10 +228,18 @@ subroutine create_structarray(this)
     padj = 0
     if (this%ctx%is_advanced) padj = 1
 
-    this%structarray => &
-      constructStructArray(this%mf6_input, this%nparam + padj, &
-                           nrow_prealloc, 0, this%mf6_input%mempath, &
-                           this%mf6_input%component_mempath)
+    if (this%ctx%is_advanced .and. nrow_prealloc < 0) then
+      ! includes APT based advanced packages
+      this%structarray => &
+        constructStructArray(this%mf6_input, this%nparam + padj, &
+                             nrow_prealloc, 0, this%mf6_input%mempath, &
+                             this%mf6_input%component_mempath, size_init=64)
+    else
+      this%structarray => &
+        constructStructArray(this%mf6_input, this%nparam + padj, &
+                             nrow_prealloc, 0, this%mf6_input%mempath, &
+                             this%mf6_input%component_mempath)
+    end if
 
     ! create leading (pre-keystring) columns unchanged
     do icol = 1, this%nleading

src/Utilities/Idm/mf6blockfile/StructArray.f90

@@ -77,13 +77,14 @@ module StructArrayModule
   !> @brief constructor for a struct_array
   !<
   function constructStructArray(mf6_input, ncol, nrow, blocknum, mempath, &
-                                component_mempath) result(struct_array)
+                                component_mempath, size_init) result(struct_array)
     type(ModflowInputType), intent(in) :: mf6_input
     integer(I4B), intent(in) :: ncol !< number of columns in the StructArrayType
     integer(I4B), intent(in) :: nrow !< number of rows in the StructArrayType
     integer(I4B), intent(in) :: blocknum !< valid block number or 0
     character(len=*), intent(in) :: mempath !< memory path for storing the vector
     character(len=*), intent(in) :: component_mempath
+    integer(I4B), optional, intent(in) :: size_init !< initial deferred allocation size (default 5)
     type(StructArrayType), pointer :: struct_array !< new StructArrayType
 
     ! allocate StructArrayType
@@ -100,6 +101,7 @@ function constructStructArray(mf6_input, ncol, nrow, blocknum, mempath, &
     if (struct_array%nrow == -1) then
       struct_array%nrow = 0
       struct_array%deferred_shape = .true.
+      if (present(size_init)) struct_array%deferred_size_init = size_init
     end if
 
     ! set blocknum
@@ -397,10 +399,16 @@ subroutine allocate_dbl1d_type(this, sv)
 
     if (sv%idt%shape == 'NAUX') then
       call mem_setptr(naux, sv%idt%shape, this%mempath)
-      call mem_allocate(dbl2d, naux, this%nrow, sv%idt%mf6varname, this%mempath)
+
+      if (this%deferred_shape) then
+        ! deferred: plain allocate so check_reallocate can grow it safely
+        allocate (dbl2d(naux, sv%size))
+      else
+        call mem_allocate(dbl2d, naux, this%nrow, sv%idt%mf6varname, this%mempath)
+      end if
 
       ! initialize
-      do m = 1, this%nrow
+      do m = 1, sv%size
         do n = 1, naux
           dbl2d(n, m) = DZERO
         end do
@@ -420,11 +428,11 @@ subroutine allocate_dbl1d_type(this, sv)
         call mem_setptr(nseg_1, 'NSEG_1', this%mempath)
       end if
 
-      ! allocate
-      call mem_allocate(dbl2d, nseg_1, this%nrow, sv%idt%mf6varname, this%mempath)
+      ! allocate; use sv%size for deferred-compatible initial row count
+      call mem_allocate(dbl2d, nseg_1, sv%size, sv%idt%mf6varname, this%mempath)
 
       ! initialize
-      do m = 1, this%nrow
+      do m = 1, sv%size
         do n = 1, nseg_1
           dbl2d(n, m) = DZERO
         end do
@@ -448,6 +456,7 @@ subroutine load_deferred_vector(this, icol)
     integer(I4B), dimension(:), pointer, contiguous :: p_int1d
     integer(I4B), dimension(:, :), pointer, contiguous :: p_int2d
     real(DP), dimension(:), pointer, contiguous :: p_dbl1d
+    real(DP), dimension(:, :), pointer, contiguous :: p_dbl2d
     type(CharacterStringType), dimension(:), pointer, contiguous :: p_charstr1d
     character(len=LENVARNAME) :: varname
     logical(LGP) :: overwrite
@@ -612,9 +621,24 @@ subroutine load_deferred_vector(this, icol)
       this%struct_vectors(icol)%int2d => p_int2d
       this%struct_vectors(icol)%size = this%nrow
     case (MTYPE_DBL2D)
-      errmsg = 'StructArray::load_deferred_vector &
-               &dbl2d reallocate unimplemented.'
-      call store_error(errmsg, terminate=.TRUE.)
+      if (isize > -1) then
+        errmsg = 'StructArray::load_deferred_vector &
+                 &dbl2d reallocate unimplemented.'
+        call store_error(errmsg, terminate=.TRUE.)
+      else
+        call mem_allocate(p_dbl2d, this%struct_vectors(icol)%intshape, &
+                          this%nrow, varname, this%mempath)
+        do i = 1, this%nrow
+          do j = 1, this%struct_vectors(icol)%intshape
+            p_dbl2d(j, i) = this%struct_vectors(icol)%dbl2d(j, i)
+          end do
+        end do
+      end if
+
+      deallocate (this%struct_vectors(icol)%dbl2d)
+
+      this%struct_vectors(icol)%dbl2d => p_dbl2d
+      this%struct_vectors(icol)%size = this%nrow
     case default
     end select
   end subroutine load_deferred_vector
@@ -717,6 +741,7 @@ subroutine check_reallocate(this)
     integer(I4B), dimension(:), pointer, contiguous :: p_int1d
     integer(I4B), dimension(:, :), pointer, contiguous :: p_int2d
     real(DP), dimension(:), pointer, contiguous :: p_dbl1d
+    real(DP), dimension(:, :), pointer, contiguous :: p_dbl2d
     type(CharacterStringType), dimension(:), pointer, contiguous :: p_charstr1d
     integer(I4B) :: reallocate_mult
 
@@ -792,7 +817,24 @@ subroutine check_reallocate(this)
           this%struct_vectors(j)%int2d => p_int2d
           this%struct_vectors(j)%size = newsize
         end if
-        ! TODO: case (6)
+      case (MTYPE_DBL2D)
+        if (this%nrow > this%struct_vectors(j)%size) then
+          newsize = this%struct_vectors(j)%size * reallocate_mult
+          allocate (p_dbl2d(this%struct_vectors(j)%intshape, newsize))
+
+          do i = 1, this%struct_vectors(j)%size
+            do k = 1, this%struct_vectors(j)%intshape
+              p_dbl2d(k, i) = this%struct_vectors(j)%dbl2d(k, i)
+            end do
+          end do
+
+          deallocate (this%struct_vectors(j)%dbl2d)
+
+          this%struct_vectors(j)%dbl2d => p_dbl2d
+          this%struct_vectors(j)%size = newsize
+        end if
+      case (MTYPE_UNDEF, MTYPE_INTVEC)
+        ! metadata-only or unsupported: skip reallocation check
       case default
         errmsg = 'IDM unimplemented. StructArray::check_reallocate &
                  &unsupported memtype.'
@@ -1222,8 +1264,9 @@ subroutine ts_update(this, tsmanager, subcomp_name, iprpak, input_name, &
     logical(LGP) :: do_clear, do_static
 
     do_clear = .true.
-    if (present(clear_strlocs)) do_clear = clear_strlocs
     do_static = .false.
+
+    if (present(clear_strlocs)) do_clear = clear_strlocs
     if (present(is_static)) do_static = is_static
 
     ! find BOUNDNAME column (0 = none)