Mf6FileKeystring.f90

Go to the documentation of this file.

!> @brief Period block keystring-based input loader
!!
!! Each keystring member maps to a typed column in a StructArrayType.
!! A dispatch keyword on each input row selects the target column.
!!
!!   Simple dispatch: keyword matches a DOUBLE/STRING/INTEGER column;
!!   one value token is read into that column.
!!
!!   Compound dispatch: keyword matches a KEYWORD-type column (e.g.
!!   FLOWING_WELL).  The keyword token is stored directly; subsequent
!!   non-KEYWORD sub-member columns are read in order.
!!
!<
module mf6filekeystringmodule
 
  use kindmodule, only: dp, i4b, lgp
  use constantsmodule, only: linelength, lenvarname, dzero, dnodata
  use inputdefinitionmodule, only: inputparamdefinitiontype
  use modflowinputmodule, only: modflowinputtype
  use characterstringmodule, only: characterstringtype
  use memorymanagermodule, only: mem_setptr, get_isize
  use timeseriesmanagermodule, only: timeseriesmanagertype, tsmanager_cr, &
                                     read_value_or_time_series_adv
  use structarraymodule, only: structarraytype, constructstructarray, &
                               destructstructarray
  use asciiinputloadtypemodule, only: asciidynamicpkgloadbasetype
  use loadcontextmodule, only: loadcontexttype
  use loadmf6filemodule, only: loadmf6filetype
  use blockparsermodule, only: blockparsertype
 
  implicit none
  private
  public :: keystringloadtype
 
  !> @brief Keystring period block loader
  !!
  !! Leading fixed columns (e.g. CELLID) followed by a dispatch
  !! keyword that routes each input row to a typed member column.
  !!
  !<
  type, extends(asciidynamicpkgloadbasetype) :: keystringloadtype
    type(timeseriesmanagertype), pointer :: tsmanager => null()
    type(structarraytype), pointer :: structarray => null()
    type(loadcontexttype) :: ctx !< input load context
    type(loadmf6filetype) :: static_loader !< persistent static loader
    logical(LGP) :: ts_active !< .true. if TS files are loaded
    integer(I4B) :: nleading !< number of leading (pre-keystring) columns
  contains
    procedure :: ainit
    procedure :: df
    procedure :: ts_advance
    procedure :: rp
    procedure :: reset
    procedure :: destroy
    procedure :: create_structarray
    procedure :: allocate_period_settings
    procedure :: apply_period_settings
    procedure :: resolve_nfeatures
    procedure :: resolve_in_scope_setting
    procedure :: allocate_permanent_array
    procedure :: apply_setting_value
    procedure :: allocate_period_node_settings
    procedure :: apply_period_node_settings
  end type keystringloadtype
 
contains
 
  subroutine ainit(this, mf6_input, component_name, component_input_name, &
                   input_name, iperblock, parser, iout)
    use inputoutputmodule, only: getunit
    use memorymanagermodule, only: get_isize, mem_setptr
    use characterstringmodule, only: characterstringtype
    use loadmf6filemodule, only: loadmf6filetype
    use arrayhandlersmodule, only: expandarray
    class(keystringloadtype), intent(inout) :: this
    type(modflowinputtype), intent(in) :: mf6_input
    character(len=*), intent(in) :: component_name
    character(len=*), intent(in) :: component_input_name
    character(len=*), intent(in) :: input_name
    integer(I4B), intent(in) :: iperblock
    type(blockparsertype), pointer, intent(inout) :: parser
    integer(I4B), intent(in) :: iout
    type(characterstringtype), dimension(:), pointer, contiguous :: ts_fnames
    character(len=LINELENGTH) :: fname
    character(len=LENVARNAME), allocatable :: named_bound(:)
    character(len=LINELENGTH), dimension(:), allocatable :: member_names
    integer(I4B) :: n, nmembers, isize
 
    call this%DynamicPkgLoadType%init(mf6_input, component_name, &
                                      component_input_name, input_name, &
                                      iperblock, iout)
    this%ts_active = .false.
    this%nleading = 0
 
    allocate (this%tsmanager)
    call tsmanager_cr(this%tsmanager, iout)
 
    ! load static input (TS6_FILENAME tag sets static_loader%ts_active)
    call this%static_loader%load(parser, mf6_input, this%nc_vars, &
                                 this%input_name, iout)
 
    ! add declared TS files to tsmanager
    if (this%static_loader%ts_active) then
      this%ts_active = .true.
      call get_isize('TS6_FILENAME', mf6_input%mempath, isize)
      if (isize > 0) then
        call mem_setptr(ts_fnames, 'TS6_FILENAME', mf6_input%mempath)
        do n = 1, size(ts_fnames)
          fname = ts_fnames(n)
          call this%tsmanager%add_tsfile(fname, getunit())
        end do
      end if
    end if
 
    ! collect DIMENSIONS block parameter names for LoadContext;
    ! absent for TVK/TVS — LoadContext falls back to nodes * nmembers
    do n = 1, size(mf6_input%param_dfns)
      if (mf6_input%param_dfns(n)%blockname == 'DIMENSIONS') then
        call expandarray(named_bound)
        named_bound(size(named_bound)) = trim(mf6_input%param_dfns(n)%mf6varname)
      end if
    end do
 
    ! init load context
    if (allocated(named_bound)) then
      call this%ctx%init(mf6_input, named_bound=named_bound)
    else
      call this%ctx%init(mf6_input)
    end if
 
    call this%ctx%tags(this%param_names, this%nparam, this%input_name)
    this%nleading = this%ctx%nleading
 
    ! append keystring member column names
    call this%ctx%keystring_member_names(member_names, nmembers)
    do n = 1, nmembers
      this%nparam = this%nparam + 1
      call expandarray(this%param_names)
      this%param_names(this%nparam) = trim(member_names(n))
    end do
 
    ! finalize context setup (allocates NBOUND, NODEULIST, etc.)
    call this%ctx%allocate_arrays()
 
    ! pre-allocate structarray; reused across all periods
    call this%create_structarray()
  end subroutine ainit
 
  subroutine df(this)
    use structarraymodule, only: structarraytype
    class(keystringloadtype), intent(inout) :: this
    type(structarraytype), pointer :: sa
    integer(I4B) :: n
    ! init tsmanager (TDIS now available)
    call this%tsmanager%tsmanager_df()
    ! link static TS strlocs; preserve for re-registration after 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, &
                          clear_strlocs=.false.)
      end if
    end do
    ! DIMENSIONS-scoped packages (e.g. SPC): allocate permanent,
    ! feature-indexed storage for every PERIOD setting in scope, so a
    ! value survives across periods that don't reissue it
    if (this%ctx%is_dimensions_scoped) call this%allocate_period_settings()
    ! CELLID-addressed packages (TVK/TVS): same persistence goal, but
    ! node-indexed and package-resolved -- see allocate_period_node_settings
    if (this%ctx%is_cellid_scoped) call this%allocate_period_node_settings()
  end subroutine df
 
  subroutine ts_advance(this)
    class(keystringloadtype), intent(inout) :: this
    call this%tsmanager%ad()
  end subroutine ts_advance
 
  subroutine rp(this, parser)
    use idmloggermodule, only: idm_log_header, idm_log_close
    class(keystringloadtype), intent(inout) :: this
    type(blockparsertype), pointer, intent(inout) :: parser
 
    call this%reset()
 
    call idm_log_header(this%mf6_input%component_name, &
                        this%mf6_input%subcomponent_name, this%iout)
 
    this%ctx%nbound = &
      this%structarray%read_from_parser_keystring(parser, this%ts_active, &
                                                  this%nleading, this%iout, &
                                                  this%input_name)
 
    if (this%ctx%is_dimensions_scoped) call this%apply_period_settings()
    if (this%ctx%is_cellid_scoped) call this%apply_period_node_settings()
 
    if (this%ts_active) then
      call this%structarray%ts_update(this%tsmanager, &
                                      this%mf6_input%subcomponent_name, &
                                      this%ctx%iprpak, this%input_name)
    end if
 
    call idm_log_close(this%mf6_input%component_name, &
                       this%mf6_input%subcomponent_name, this%iout)
  end subroutine rp
 
  subroutine reset(this)
    use structarraymodule, only: structarraytype
    class(keystringloadtype), intent(inout) :: this
    type(structarraytype), pointer :: sa
    integer(I4B) :: n
    ! PERIOD settings persist across periods unless reissued, so TS links
    ! for packages with sticky, permanently-addressed settings are never
    ! reset (SETTING column dispatch keeps them current instead)
    if (.not. this%ctx%has_setting_dispatch) then
      ! clear TS links
      call this%tsmanager%reset(this%mf6_input%subcomponent_name)
    end if
    ! re-register static TS links (strlocs preserved in df); unrelated to
    ! PERIOD-block sticky-setting persistence, so this runs regardless of
    ! has_setting_dispatch
    if (this%ts_active) then
      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, &
                            clear_strlocs=.false.)
        end if
      end do
    end if
  end subroutine reset
 
  subroutine destroy(this)
    class(keystringloadtype), intent(inout) :: this
 
    call this%static_loader%cleanup()
 
    call this%tsmanager%da()
    deallocate (this%tsmanager)
    nullify (this%tsmanager)
 
    if (associated(this%structarray)) then
      call destructstructarray(this%structarray)
    end if
 
    call this%ctx%destroy()
    call this%DynamicPkgLoadType%destroy()
  end subroutine destroy
 
  !> @brief Resolve the permanent array's feature count: ctx%maxbound
  !! divided by the keystring member count, reversing the
  !! nodes*nmembers/DIMENSIONS-based scaling LoadContext applies.
  !<
  function resolve_nfeatures(this) result(nfeatures)
    class(keystringloadtype), intent(inout) :: this
    integer(I4B) :: nfeatures
    character(len=LINELENGTH), allocatable :: member_names(:)
    integer(I4B) :: nmembers
 
    nfeatures = 0
    call this%ctx%keystring_member_names(member_names, nmembers)
    if (nmembers > 0 .and. associated(this%ctx%maxbound)) then
      if (this%ctx%maxbound > 0) nfeatures = this%ctx%maxbound / nmembers
    end if
  end function resolve_nfeatures
 
  !> @brief Return idt for param_names(icol) if it's an in-scope PERIOD
  !! setting (STRING type with TIME_SERIES TRUE), else a disassociated
  !! pointer.
  !<
  function resolve_in_scope_setting(this, icol) result(idt)
    use definitionselectmodule, only: get_param_definition_type
    class(keystringloadtype), intent(inout) :: this
    integer(I4B), intent(in) :: icol
    type(inputparamdefinitiontype), pointer :: idt
 
    idt => get_param_definition_type(this%mf6_input%param_dfns, &
                                     this%mf6_input%component_type, &
                                     this%mf6_input%subcomponent_type, &
                                     'PERIOD', this%param_names(icol), &
                                     this%input_name)
    if (idt%datatype /= 'STRING' .or. .not. idt%timeseries) idt => null()
  end function resolve_in_scope_setting
 
  !> @brief Allocate idt's permanent array with init_value, unless already
  !! allocated.
  !<
  subroutine allocate_permanent_array(this, idt, nfeatures, init_value)
    use memorymanagermodule, only: mem_allocate
    class(keystringloadtype), intent(inout) :: this
    type(inputparamdefinitiontype), intent(in) :: idt
    integer(I4B), intent(in) :: nfeatures
    real(DP), intent(in) :: init_value
    real(DP), dimension(:), pointer, contiguous :: featarr => null()
    integer(I4B) :: isize
 
    call get_isize(trim(idt%tagname), this%mf6_input%mempath, isize)
    if (isize > 0) return ! already allocated (shouldn't happen; df() runs once)
    call mem_allocate(featarr, nfeatures, trim(idt%tagname), &
                      this%mf6_input%mempath)
    featarr = init_value
  end subroutine allocate_permanent_array
 
  !> @brief Resolve token (row i of period_val) as a literal or TS name
  !! directly against featarr(address).
  !<
  subroutine apply_setting_value(this, idt, period_val, i, address, featarr)
    class(keystringloadtype), intent(inout) :: this
    type(inputparamdefinitiontype), intent(in) :: idt
    type(characterstringtype), dimension(:), pointer, contiguous, &
      intent(in) :: period_val
    integer(I4B), intent(in) :: i
    integer(I4B), intent(in) :: address
    real(DP), dimension(:), pointer, contiguous, intent(inout) :: featarr
    real(DP), pointer :: bndElem
    character(len=LINELENGTH) :: token
 
    token = period_val(i)
    if (len_trim(token) == 0) return
    bndelem => featarr(address)
    call read_value_or_time_series_adv(token, address, 0, bndelem, &
                                       this%mf6_input%subcomponent_name, &
                                       'BND', this%tsmanager, &
                                       this%ctx%iprpak, trim(idt%tagname))
  end subroutine apply_setting_value
 
  !> @brief Allocate permanent, feature-indexed storage for every in-scope
  !! PERIOD setting, keyed by the field's public tag (e.g. CONCENTRATION).
  !<
  subroutine allocate_period_settings(this)
    class(keystringloadtype), intent(inout) :: this
    type(inputparamdefinitiontype), pointer :: idt
    integer(I4B) :: icol, nfeatures
 
    nfeatures = this%resolve_nfeatures()
    if (nfeatures < 1) return
 
    do icol = this%nleading + 1, this%nparam
      idt => this%resolve_in_scope_setting(icol)
      if (.not. associated(idt)) cycle
      call this%allocate_permanent_array(idt, nfeatures, dzero)
    end do
  end subroutine allocate_period_settings
 
  !> @brief Apply PERIOD settings (SPC) to their permanent, feature-indexed
  !! arrays
  !!
  !! Resolves each token (literal or TS name) directly against the
  !! permanent, BNDNO-addressed array, so a later period that doesn't
  !! repeat the setting leaves the prior value untouched.
  !<
  subroutine apply_period_settings(this)
    use definitionselectmodule, only: get_param_definition_type
    use simmodule, only: store_error
    use simvariablesmodule, only: errmsg
    class(keystringloadtype), intent(inout) :: this
    integer(I4B), pointer :: nbound => null()
    integer(I4B), dimension(:), pointer, contiguous :: period_bndno => null()
    type(characterstringtype), dimension(:), pointer, contiguous :: &
      period_setting => null()
    type(characterstringtype), dimension(:), pointer, contiguous :: &
      period_val => null()
    type(inputparamdefinitiontype), pointer :: idt
    real(DP), dimension(:), pointer, contiguous :: featarr => null()
    integer(I4B) :: i, icol, bndno, isize, nfeatures
    character(len=LINELENGTH) :: setting
 
    call get_isize('NBOUND', this%mf6_input%mempath, isize)
    if (isize < 1) return
    call mem_setptr(nbound, 'NBOUND', this%mf6_input%mempath)
    if (nbound <= 0) return
 
    nfeatures = this%resolve_nfeatures()
    if (nfeatures < 1) return
 
    ! the sole leading column is the permanent, stably-numbered feature
    ! address (BNDNO) -- resolved via its own idt, since the
    ! memory-manager key (mf6varname) isn't always the doc-facing tag
    idt => get_param_definition_type(this%mf6_input%param_dfns, &
                                     this%mf6_input%component_type, &
                                     this%mf6_input%subcomponent_type, &
                                     'PERIOD', this%param_names(1), &
                                     this%input_name)
    call mem_setptr(period_bndno, trim(idt%mf6varname), this%mf6_input%mempath)
    call mem_setptr(period_setting, 'SETTING', this%mf6_input%mempath)
 
    do icol = this%nleading + 1, this%nparam
      idt => this%resolve_in_scope_setting(icol)
      if (.not. associated(idt)) cycle
      call mem_setptr(featarr, trim(idt%tagname), this%mf6_input%mempath)
      call mem_setptr(period_val, trim(idt%mf6varname), this%mf6_input%mempath)
 
      do i = 1, nbound
        setting = period_setting(i)
        if (trim(setting) /= trim(idt%mf6varname)) cycle
        bndno = period_bndno(i)
        if (bndno < 1 .or. bndno > nfeatures) then
          write (errmsg, '(2(a,1x),i0,a)') &
            'BNDNO must be greater than 0 and', &
            'less than or equal to ', nfeatures, '.'
          call store_error(errmsg)
          cycle
        end if
        call this%apply_setting_value(idt, period_val, i, bndno, featarr)
      end do
    end do
  end subroutine apply_period_settings
 
  !> @brief Allocate permanent, node-indexed storage for every PERIOD
  !! setting in scope, for CELLID-addressed packages (TVK/TVS)
  !!
  !! Sized by ctx%nodes (product(MSHAPE), the unreduced node count).
  !! DNODATA marks "never set" so the package knows which nodes to
  !! copy into its own target array (e.g. NPF's K11) at the reduced
  !! node number.
  !<
  subroutine allocate_period_node_settings(this)
    class(keystringloadtype), intent(inout) :: this
    type(inputparamdefinitiontype), pointer :: idt
    integer(I4B) :: icol, nfeatures
 
    if (.not. associated(this%ctx%nodes)) return
    nfeatures = this%ctx%nodes
    if (nfeatures < 1) return
 
    do icol = this%nleading + 1, this%nparam
      idt => this%resolve_in_scope_setting(icol)
      if (.not. associated(idt)) cycle
      call this%allocate_permanent_array(idt, nfeatures, dnodata)
    end do
  end subroutine allocate_period_node_settings
 
  !> @brief Apply PERIOD settings to their permanent, node-indexed arrays,
  !! for CELLID-addressed packages (TVK/TVS)
  !!
  !! Mirrors apply_period_settings, but addresses by the unreduced node
  !! number (nodeu) computed from CELLID via MSHAPE. The reduced-node
  !! lookup stays package-side, where the real dis object is available.
  !<
  subroutine apply_period_node_settings(this)
    use geomutilmodule, only: get_node
    class(keystringloadtype), intent(inout) :: this
    integer(I4B), pointer :: nbound => null()
    integer(I4B), dimension(:, :), pointer, contiguous :: cellid => null()
    type(characterstringtype), dimension(:), pointer, contiguous :: &
      period_setting => null()
    type(characterstringtype), dimension(:), pointer, contiguous :: &
      period_val => null()
    type(inputparamdefinitiontype), pointer :: idt
    real(DP), dimension(:), pointer, contiguous :: featarr => null()
    integer(I4B) :: i, icol, nodeu, isize, nfeatures, ndim
    character(len=LINELENGTH) :: setting
 
    call get_isize('NBOUND', this%mf6_input%mempath, isize)
    if (isize < 1) return
    call mem_setptr(nbound, 'NBOUND', this%mf6_input%mempath)
    if (nbound <= 0) return
 
    if (.not. associated(this%ctx%nodes)) return
    nfeatures = this%ctx%nodes
    if (nfeatures < 1) return
    if (.not. associated(this%ctx%mshape)) return
    ndim = size(this%ctx%mshape)
 
    call mem_setptr(cellid, 'CELLID', this%mf6_input%mempath)
    call mem_setptr(period_setting, 'SETTING', this%mf6_input%mempath)
 
    do icol = this%nleading + 1, this%nparam
      idt => this%resolve_in_scope_setting(icol)
      if (.not. associated(idt)) cycle
      call mem_setptr(featarr, trim(idt%tagname), this%mf6_input%mempath)
      call mem_setptr(period_val, trim(idt%mf6varname), this%mf6_input%mempath)
 
      do i = 1, nbound
        setting = period_setting(i)
        if (trim(setting) /= trim(idt%mf6varname)) cycle
        if (ndim == 1) then
          nodeu = cellid(1, i)
        else if (ndim == 2) then
          nodeu = get_node(cellid(1, i), 1, cellid(2, i), &
                           this%ctx%mshape(1), 1, this%ctx%mshape(2))
        else
          nodeu = get_node(cellid(1, i), cellid(2, i), cellid(3, i), &
                           this%ctx%mshape(1), this%ctx%mshape(2), &
                           this%ctx%mshape(3))
        end if
        if (nodeu < 1 .or. nodeu > nfeatures) cycle
        call this%apply_setting_value(idt, period_val, i, nodeu, featarr)
      end do
    end do
  end subroutine apply_period_node_settings
 
  subroutine create_structarray(this)
    use definitionselectmodule, only: get_param_definition_type, &
                                      idt_parse_rectype
    use inputoutputmodule, only: upcase
    class(keystringloadtype), intent(inout) :: this
    type(inputparamdefinitiontype), pointer :: idt, pidt
    character(len=LINELENGTH), allocatable :: rec_cols(:)
    character(len=LINELENGTH) :: kwname, first_col
    integer(I4B) :: iparam, sa_icol, padj, nrow_prealloc, jparam, nrec_col, nsub
    logical(LGP) :: has_setting
 
    has_setting = this%ctx%has_setting_dispatch
    padj = 0
    if (has_setting) padj = 1
 
    ! use pre-allocated managed memory (maxbound = features * nmembers);
    ! fall back to deferred shape (-1) if maxbound is unavailable
    if (associated(this%ctx%maxbound) .and. this%ctx%maxbound > 0) then
      nrow_prealloc = this%ctx%maxbound
    else
      nrow_prealloc = -1
    end if
 
    this%structarray => &
      constructstructarray(this%mf6_input, this%nparam + padj, &
                           nrow_prealloc, 0, this%mf6_input%mempath, &
                           this%mf6_input%component_mempath)
 
    ! create leading (pre-keystring) columns unchanged
    do iparam = 1, this%nleading
      idt => get_param_definition_type(this%mf6_input%param_dfns, &
                                       this%mf6_input%component_type, &
                                       this%mf6_input%subcomponent_type, &
                                       'PERIOD', &
                                       this%param_names(iparam), this%input_name)
      call this%structarray%mem_create_vector(iparam, idt)
    end do
 
    ! create SETTING column (ctx owns setting_idt); records which keystring
    ! member was dispatched to on each row, for sticky-setting persistence
    if (has_setting) then
      call this%structarray%mem_create_vector(this%nleading + 1, &
                                              this%ctx%setting_idt)
    end if
 
    ! create keystring member columns, shifted past SETTING when present
    do iparam = this%nleading + 1, this%nparam
      sa_icol = iparam + padj
      idt => get_param_definition_type(this%mf6_input%param_dfns, &
                                       this%mf6_input%component_type, &
                                       this%mf6_input%subcomponent_type, &
                                       'PERIOD', &
                                       this%param_names(iparam), this%input_name)
      call this%structarray%mem_create_vector(sa_icol, idt)
 
      ! For KEYWORD member columns, store the compound sub-member count
      ! from the RECORD definition so read_from_parser_keystring reads
      ! exactly the right number of sub-values.
      if (trim(idt%datatype) == 'KEYWORD') then
        kwname = trim(idt%tagname)
        call upcase(kwname)
        nsub = 0
        do jparam = 1, size(this%mf6_input%param_dfns)
          pidt => this%mf6_input%param_dfns(jparam)
          if (pidt%blockname /= 'PERIOD') cycle
          if (pidt%datatype(1:6) /= 'RECORD') cycle
          call idt_parse_rectype(pidt, rec_cols, nrec_col)
          if (nrec_col >= 1) then
            first_col = trim(rec_cols(1))
            call upcase(first_col)
            if (trim(first_col) == trim(kwname)) then
              nsub = nrec_col - 1
              if (allocated(rec_cols)) deallocate (rec_cols)
              exit
            end if
          end if
          if (allocated(rec_cols)) deallocate (rec_cols)
        end do
        this%structarray%struct_vectors(sa_icol)%nsubmembers = nsub
      end if
    end do
  end subroutine create_structarray
 
end module mf6filekeystringmodule