config_engine.f90 – cfd-solver

Source Code

!> @file config_engine.f90
!> @brief Dimension-blind configuration engine: field descriptors + generic
!!        validation, normalization, and typed by-name access.
!!
!! Shared machinery for the per-dimension config modules (spec
!! 2026-07-06-multidim-machinery-refactor-design.md, section 4). A dimension
!! supplies DATA — a `field_desc_t(:)` table binding key/group/kind/bounds/
!! choices to pointers into its config derived type — and this engine supplies
!! the behavior. Cross-field and conditional rules stay in the per-dimension
!! validate routines; only unconditional per-field constraints (flagged
!! `check_in_validate`) are enforced here.
module config_engine
  use precision, only: wp
  use string_utils, only: lowercase_token, to_lower
  use option_registry, only: token_in_list, join_token_list
  implicit none
  private

  !> Value-kind tags. Owned here; re-exported by config_schema / config_schema_2d
  !! so their ABI-facing constants keep working unchanged.
  integer, parameter, public :: cfg_kind_int = 1
  integer, parameter, public :: cfg_kind_real = 2
  integer, parameter, public :: cfg_kind_logical = 3
  integer, parameter, public :: cfg_kind_choice = 4
  integer, parameter, public :: cfg_kind_string = 5
  integer, parameter, public :: cfg_kind_real3 = 6

  !> Generated choice-violation message styles (match the historical texts).
  integer, parameter, public :: choice_msg_valid_list = 1 !< '<p>: unknown <key> "<v>"; valid: <list>'
  integer, parameter, public :: choice_msg_one_of = 2     !< '<p>: <key> must be one of <list>'
  integer, parameter, public :: choice_msg_bare = 3       !< '<p>: unknown <key> "<v>"'

  !> One configuration field: schema metadata + validation constraint +
  !! a typed pointer into a live config instance. Exactly one of the pointer
  !! components is associated, per value_kind.
  type, public :: field_desc_t
    character(len=32) :: key = ''
    character(len=32) :: group = ''
    integer :: value_kind = 0
    character(len=256) :: help = ''
    logical :: has_min = .false.
    logical :: min_exclusive = .false.  !< .true. => violation when value <= min
    real(wp) :: min_value = 0.0_wp
    logical :: has_max = .false.
    real(wp) :: max_value = 0.0_wp
    character(len=64), allocatable :: choices(:)
    integer :: choice_msg_style = choice_msg_valid_list
    character(len=160) :: msg_choice = '' !< non-empty: used verbatim instead of the generated text
    logical :: casefold = .false.         !< normalize_fields lowercases this string field
    !> .false. => published in the schema but NOT checked by validate_fields
    !! (conditional/cross-field rules stay in the per-dim validate routine).
    logical :: check_in_validate = .true.
    character(len=160) :: msg_min = ''
    character(len=160) :: msg_max = ''
    integer, pointer :: iptr => null()
    real(wp), pointer :: rptr => null()
    logical, pointer :: lptr => null()
    character(len=:), pointer :: sptr => null()
    real(wp), pointer :: r3ptr(:) => null()
  end type field_desc_t

  public :: field_meta, field_index, normalize_fields, validate_fields
  public :: fields_get_integer, fields_get_real, fields_get_logical
  public :: fields_get_string, fields_get_real3
  public :: fields_set_integer, fields_set_real, fields_set_logical
  public :: fields_set_string, fields_set_real3

contains

  !> Metadata-only constructor. Callers associate the matching pointer
  !! component afterwards (build_field_table binds them to a target config).
  pure function field_meta(key, group, value_kind, help, has_min, min_exclusive, &
                           min_value, msg_min, has_max, max_value, msg_max, &
                           choices, choice_msg_style, msg_choice, casefold, &
                           check_in_validate) result(d)
    character(len=*), intent(in) :: key, group, help
    integer, intent(in) :: value_kind
    logical, intent(in), optional :: has_min, min_exclusive, has_max
    real(wp), intent(in), optional :: min_value, max_value
    character(len=*), intent(in), optional :: msg_min, msg_max, msg_choice
    character(len=*), intent(in), optional :: choices(:)
    integer, intent(in), optional :: choice_msg_style
    logical, intent(in), optional :: casefold, check_in_validate
    type(field_desc_t) :: d
    integer :: alloc_stat

    d % key = lowercase_token(key)
    d % group = group
    d % value_kind = value_kind
    d % help = help
    if (present(has_min)) d % has_min = has_min
    if (present(min_exclusive)) d % min_exclusive = min_exclusive
    if (present(min_value)) d % min_value = min_value
    if (present(msg_min)) d % msg_min = msg_min
    if (present(has_max)) d % has_max = has_max
    if (present(max_value)) d % max_value = max_value
    if (present(msg_max)) d % msg_max = msg_max
    if (present(choices)) then
      allocate (character(len=64) :: d % choices(size(choices)), stat=alloc_stat)
      if (alloc_stat /= 0) error stop 'config_engine: choices allocation failed'
      d % choices(:) = choices(:)
    end if
    if (present(choice_msg_style)) d % choice_msg_style = choice_msg_style
    if (present(msg_choice)) d % msg_choice = msg_choice
    if (present(casefold)) d % casefold = casefold
    if (present(check_in_validate)) d % check_in_validate = check_in_validate
  end function field_meta

  !> 1-based index of `key` in the table (normalized compare); 0 when absent.
  integer function field_index(fields, key) result(index)
    type(field_desc_t), intent(in) :: fields(:)
    character(len=*), intent(in) :: key
    character(len=32) :: normalized
    integer :: i

    normalized = lowercase_token(key)
    index = 0
    do i = 1, size(fields)
      if (trim(fields(i) % key) == trim(normalized)) then
        index = i
        return
      end if
    end do
  end function field_index

  !> Lowercase every casefold-flagged string field in place (the table-driven
  !! replacement for the 1D normalize_config).
  subroutine normalize_fields(fields)
    type(field_desc_t), intent(inout) :: fields(:)
    integer :: i

    do i = 1, size(fields)
      if (fields(i) % casefold) then
        if (associated(fields(i) % sptr)) fields(i) % sptr = lowercase_token(fields(i) % sptr)
      end if
    end do
  end subroutine normalize_fields

  !> Enforce every unconditional per-field constraint, in table order; first
  !! violation wins. `prefix` is the historical message prefix ('config' or
  !! 'config_2d'). Choice comparison casefolds the candidate via `to_lower`
  !! (length/blank-preserving), NOT `lowercase_token` (which adjustl's first):
  !! a leading-whitespace value like ' hllc' must be REJECTED here, matching
  !! the 2D to_lower-on-compare behavior; the 1D path already normalizes
  !! (adjustl+lowercase) via `normalize_fields` before this runs, so its
  !! stored values never carry leading blanks by the time they reach here.
  subroutine validate_fields(fields, prefix, ok, message)
    type(field_desc_t), intent(in) :: fields(:)
    character(len=*), intent(in) :: prefix
    logical, intent(out) :: ok
    character(len=*), intent(out) :: message
    integer :: i
    real(wp) :: v
    character(len=160) :: bound_msg

    ok = .true.
    message = ''
    do i = 1, size(fields)
      associate (f => fields(i))
        if (.not. f % check_in_validate) cycle
        select case (f % value_kind)
        case (cfg_kind_int, cfg_kind_real)
          if (f % value_kind == cfg_kind_int) then
            if (associated(f % iptr)) then
              v = real(f % iptr, wp)
            else
              bound_msg = 'config_engine: descriptor without bound pointer for key "'// &
                          trim(f % key)//'"'
              error stop trim(bound_msg)
            end if
          else
            if (associated(f % rptr)) then
              v = f % rptr
            else
              bound_msg = 'config_engine: descriptor without bound pointer for key "'// &
                          trim(f % key)//'"'
              error stop trim(bound_msg)
            end if
          end if
          if (f % has_min) then
            if ((f % min_exclusive .and. v <= f % min_value) .or. &
                (.not. f % min_exclusive .and. v < f % min_value)) then
              ok = .false.
              message = trim(f % msg_min)
              return
            end if
          end if
          if (f % has_max) then
            if (v > f % max_value) then
              ok = .false.
              message = trim(f % msg_max)
              return
            end if
          end if
        case (cfg_kind_choice)
          if (associated(f % sptr)) then
            if (allocated(f % choices)) then
              if (.not. token_in_list(to_lower(f % sptr), f % choices)) then
                ok = .false.
                message = choice_violation_message(prefix, f)
                return
              end if
            else
              bound_msg = 'config_engine: choice descriptor without allocated choices for key "'// &
                          trim(f % key)//'"'
              error stop trim(bound_msg)
            end if
          else
            bound_msg = 'config_engine: descriptor without bound pointer for key "'// &
                        trim(f % key)//'"'
            error stop trim(bound_msg)
          end if
        end select
      end associate
    end do
  end subroutine validate_fields

  !> Compose the historical choice-violation text for one field.
  function choice_violation_message(prefix, f) result(msg)
    character(len=*), intent(in) :: prefix
    type(field_desc_t), intent(in) :: f
    character(len=512) :: msg

    if (len_trim(f % msg_choice) > 0) then
      msg = trim(f % msg_choice)
      return
    end if
    select case (f % choice_msg_style)
    case (choice_msg_one_of)
      msg = trim(prefix)//': '//trim(f % key)//' must be one of '// &
            trim(join_token_list(f % choices))
    case (choice_msg_bare)
      msg = trim(prefix)//': unknown '//trim(f % key)//' "'//trim(f % sptr)//'"'
    case default
      msg = trim(prefix)//': unknown '//trim(f % key)//' "'//trim(f % sptr)// &
            '"; valid: '//trim(join_token_list(f % choices))
    end select
  end function choice_violation_message

  !> Typed by-name read. .false. on unknown key OR kind mismatch; the caller
  !! composes its historical error text (they differ between 1D and 2D).
  logical function fields_get_integer(fields, key, value) result(found)
    type(field_desc_t), intent(in) :: fields(:)
    character(len=*), intent(in) :: key
    integer, intent(out) :: value
    integer :: idx

    value = 0
    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_int) then
        value = fields(idx) % iptr
        found = .true.
      end if
    end if
  end function fields_get_integer

  logical function fields_get_real(fields, key, value) result(found)
    type(field_desc_t), intent(in) :: fields(:)
    character(len=*), intent(in) :: key
    real(wp), intent(out) :: value
    integer :: idx

    value = 0.0_wp
    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_real) then
        value = fields(idx) % rptr
        found = .true.
      end if
    end if
  end function fields_get_real

  logical function fields_get_logical(fields, key, value) result(found)
    type(field_desc_t), intent(in) :: fields(:)
    character(len=*), intent(in) :: key
    logical, intent(out) :: value
    integer :: idx

    value = .false.
    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_logical) then
        value = fields(idx) % lptr
        found = .true.
      end if
    end if
  end function fields_get_logical

  !> Strings and choices are both readable as strings (historical behavior).
  logical function fields_get_string(fields, key, value) result(found)
    type(field_desc_t), intent(in) :: fields(:)
    character(len=*), intent(in) :: key
    character(len=*), intent(out) :: value
    integer :: idx

    value = ''
    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_string .or. &
          fields(idx) % value_kind == cfg_kind_choice) then
        value = trim(fields(idx) % sptr)
        found = .true.
      end if
    end if
  end function fields_get_string

  logical function fields_get_real3(fields, key, value) result(found)
    type(field_desc_t), intent(in) :: fields(:)
    character(len=*), intent(in) :: key
    real(wp), intent(out) :: value(3)
    integer :: idx

    value = 0.0_wp
    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_real3) then
        value = fields(idx) % r3ptr
        found = .true.
      end if
    end if
  end function fields_get_real3

  logical function fields_set_integer(fields, key, value) result(found)
    type(field_desc_t), intent(inout) :: fields(:)
    character(len=*), intent(in) :: key
    integer, intent(in) :: value
    integer :: idx

    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_int) then
        fields(idx) % iptr = value
        found = .true.
      end if
    end if
  end function fields_set_integer

  logical function fields_set_real(fields, key, value) result(found)
    type(field_desc_t), intent(inout) :: fields(:)
    character(len=*), intent(in) :: key
    real(wp), intent(in) :: value
    integer :: idx

    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_real) then
        fields(idx) % rptr = value
        found = .true.
      end if
    end if
  end function fields_set_real

  logical function fields_set_logical(fields, key, value) result(found)
    type(field_desc_t), intent(inout) :: fields(:)
    character(len=*), intent(in) :: key
    logical, intent(in) :: value
    integer :: idx

    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_logical) then
        fields(idx) % lptr = value
        found = .true.
      end if
    end if
  end function fields_set_logical

  logical function fields_set_string(fields, key, value) result(found)
    type(field_desc_t), intent(inout) :: fields(:)
    character(len=*), intent(in) :: key
    character(len=*), intent(in) :: value
    integer :: idx

    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_string .or. &
          fields(idx) % value_kind == cfg_kind_choice) then
        fields(idx) % sptr = value
        found = .true.
      end if
    end if
  end function fields_set_string

  logical function fields_set_real3(fields, key, value) result(found)
    type(field_desc_t), intent(inout) :: fields(:)
    character(len=*), intent(in) :: key
    real(wp), intent(in) :: value(3)
    integer :: idx

    found = .false.
    idx = field_index(fields, key)
    if (idx > 0) then
      if (fields(idx) % value_kind == cfg_kind_real3) then
        fields(idx) % r3ptr = value
        found = .true.
      end if
    end if
  end function fields_set_real3

end module config_engine
config_engine.f90 Source File

Contents

Modules

Source Code

Source Code
