optionsdatabase.F90

Go to the documentation of this file.

module optionsdatabase_mod
  use datadefn_mod, only : default_precision, string_length, long_string_length
  use collections_mod, only : list_type, hashmap_type, c_size, c_get_integer, c_get_string, c_get_real, c_get_logical, c_contains, &
       c_generic_at, c_key_at, c_put_integer, c_put_real, c_put_string, c_put_logical, c_remove
  use conversions_mod, only : conv_to_logical, conv_to_integer, conv_to_real, conv_is_logical, conv_is_integer, &
       conv_is_real, conv_to_string, conv_single_real_to_double
  use logging_mod, only: log_error, log_log
  implicit none

#ifndef TEST_MODE
  private
#endif
  integer, parameter :: logical_type=0,&  !< Type of logical value data
                        integer_type=1,&  
                        real_type=2,&     
                        string_type=3     

  ! Extra key size for a specific array element, the lookup key is allocated with the length of the key plus this
  integer, parameter :: array_append_size = 10

  interface options_add
    module procedure options_add_integer, options_add_real, options_add_logical, options_add_string
  end interface options_add

  public load_command_line_into_options_database, options_has_key, options_get_logical, options_get_integer, &
    options_get_string, options_get_real, options_add, options_size, options_key_at, options_value_at, &
    options_get_array_size, options_get_integer_array, options_get_real_array, &
    options_get_string_array, options_get_logical_array, options_remove_key

  contains

  integer function options_size(options_database)
    type(hashmap_type), intent(inout) :: options_database

    options_size = c_size(options_database)
  end function options_size

  character(len=STRING_LENGTH) function options_key_at(options_database, i)
    type(hashmap_type), intent(inout) :: options_database
    integer, intent(in) :: i

    options_key_at = c_key_at(options_database, i)
  end function options_key_at

  function options_value_at(options_database, i)
    type(hashmap_type), intent(inout) :: options_database
    integer, intent(in) :: i
    class(*), pointer :: options_value_at

    options_value_at=>c_generic_at(options_database, i)
  end function options_value_at

  logical function options_has_key(options_database, key)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key

    options_has_key = c_contains(options_database, trim(key))
    if (.not. options_has_key) then
      options_has_key = c_contains(options_database, trim(key)//"a_size")
    end if
  end function options_has_key

  real(kind=DEFAULT_PRECISION) function options_get_real(options_database, key, index)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    integer, intent(in), optional :: index

    character(len=len(key)+ARRAY_APPEND_SIZE) :: lookup_key

    if (present(index)) then
      lookup_key=get_options_array_key(key, index)
    else
      lookup_key=key
    end if
    call check_options_key_exists(options_database, lookup_key)
    options_get_real=c_get_real(options_database, lookup_key)
  end function options_get_real

  subroutine options_get_real_array(options_database, key, array_data, from, to)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    real(kind=DEFAULT_PRECISION), dimension(:), intent(inout) :: array_data
    integer, intent(in), optional :: from, to

    integer :: num_elements, i, start, end

    num_elements=options_get_array_size(options_database, key)
    if (num_elements .gt. 0 .and. options_has_key(options_database, trim(key)//"a_size")) then
      if (present(from)) then
        start=from
      else
        start=1
      end if
      if (present(to)) then
        end=to
      else
        end=num_elements
      end if
      do i=start, num_elements
        array_data((i-start)+1)=options_get_real(options_database, key, i)
      end do
    else
      if (options_has_key(options_database, key)) then
        if (present(from)) then
          if (from .gt. 1) return          
        end if
        if (present(to)) then
          if (to .lt. 1) return
        end if
        array_data(1)=options_get_real(options_database, key)
      end if
    end if
  end subroutine options_get_real_array  

  logical function options_get_logical(options_database, key, index)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    integer, intent(in), optional :: index

    character(len=len(key)+ARRAY_APPEND_SIZE) :: lookup_key

    if (present(index)) then
      lookup_key=get_options_array_key(key, index)
    else
      lookup_key=key
    end if
    call check_options_key_exists(options_database, lookup_key)
    options_get_logical=c_get_logical(options_database, lookup_key)
  end function options_get_logical

  subroutine options_get_logical_array(options_database, key, array_data, from, to)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    logical, dimension(:), intent(inout) :: array_data
    integer, intent(in), optional :: from, to

    integer :: num_elements, i, start, end

    num_elements=options_get_array_size(options_database, key)
    if (num_elements .gt. 0 .and. options_has_key(options_database, trim(key)//"a_size")) then
      if (present(from)) then
        start=from
      else
        start=1
      end if
      if (present(to)) then
        end=to
      else
        end=num_elements
      end if
      do i=start, num_elements
        array_data((i-start)+1)=options_get_logical(options_database, key, i)
      end do
    else
      if (options_has_key(options_database, key)) then
        if (present(from)) then
          if (from .gt. 1) return          
        end if
        if (present(to)) then
          if (to .lt. 1) return
        end if
        array_data(1)=options_get_logical(options_database, key)
      end if
    end if
  end subroutine options_get_logical_array  

  integer function options_get_integer(options_database, key, index)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    integer, intent(in), optional :: index

    character(len=len(key)+ARRAY_APPEND_SIZE) :: lookup_key

    if (present(index)) then
      lookup_key=get_options_array_key(key, index)
    else
      lookup_key=key
    end if
    call check_options_key_exists(options_database, lookup_key)
    options_get_integer=c_get_integer(options_database, lookup_key)
  end function options_get_integer

  subroutine options_get_integer_array(options_database, key, array_data, from, to)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    integer, dimension(:), intent(inout) :: array_data
    integer, intent(in), optional :: from, to

    integer :: num_elements, i, start, end

    num_elements=options_get_array_size(options_database, key)
    if (num_elements .gt. 0 .and. options_has_key(options_database, trim(key)//"a_size")) then
      if (present(from)) then
        start=from
      else
        start=1
      end if
      if (present(to)) then
        end=to
      else
        end=num_elements
      end if
      do i=start, num_elements
        array_data((i-start)+1)=options_get_integer(options_database, key, i)
      end do
    else
      if (options_has_key(options_database, key)) then
        if (present(from)) then
          if (from .gt. 1) return          
        end if
        if (present(to)) then
          if (to .lt. 1) return
        end if
        array_data(1)=options_get_integer(options_database, key)
      end if
    end if
  end subroutine options_get_integer_array  

  character(len=STRING_LENGTH) function options_get_string(options_database, key, index)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    integer, intent(in), optional :: index

    character(len=len(key)+ARRAY_APPEND_SIZE) :: lookup_key

    if (present(index)) then
      lookup_key=get_options_array_key(key, index)
    else
      lookup_key=key
    end if
    call check_options_key_exists(options_database, lookup_key)
    options_get_string=c_get_string(options_database, lookup_key)
  end function options_get_string

  subroutine options_get_string_array(options_database, key, array_data, from, to)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    character(len=STRING_LENGTH), dimension(:), intent(inout) :: array_data
    integer, intent(in), optional :: from, to

    integer :: num_elements, i, start, end

    num_elements=options_get_array_size(options_database, key)
    if (num_elements .gt. 0 .and. options_has_key(options_database, trim(key)//"a_size")) then
      if (present(from)) then
        start=from
      else
        start=1
      end if
      if (present(to)) then
        end=to
      else
        end=num_elements
      end if
      do i=start, num_elements
        array_data((i-start)+1)=options_get_string(options_database, key, i)
      end do
    else
      if (options_has_key(options_database, key)) then
        if (present(from)) then
          if (from .gt. 1) return          
        end if
        if (present(to)) then
          if (to .lt. 1) return
        end if
        array_data(1)=options_get_string(options_database, key)
      end if
    end if
  end subroutine options_get_string_array  

  integer function options_get_array_size(options_database, key)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key

    if (options_has_key(options_database, trim(key)//"a_size")) then
      options_get_array_size=options_get_integer(options_database, trim(key)//"a_size")
    else if (options_has_key(options_database, trim(key))) then
      options_get_array_size=1
    else
      options_get_array_size=0
    end if    
  end function options_get_array_size

  subroutine load_command_line_into_options_database(options_database)
    type(hashmap_type), intent(inout) :: options_database

    integer :: i, arguments, equals_posn, type_of_config
    character(len=LONG_STRING_LENGTH) :: specific_arg

    arguments = command_argument_count()

    do i=1,arguments
      call get_command_argument(i, value = specific_arg)
      specific_arg = trim(specific_arg)
      equals_posn=index(specific_arg, "=")  ! Get the position of the equals character
      if (index(specific_arg, "--") .eq. 1) then
        if (equals_posn .gt. 0) then
          type_of_config = get_argument_value_type(specific_arg(equals_posn+1 : len(specific_arg)))
        else
          ! If no equals then it is a logical switch (to true)
          type_of_config = logical_type
        end if        
        call add_specific_option_key_value_pair(type_of_config, options_database, specific_arg)
      end if
    end do
  end subroutine load_command_line_into_options_database

  subroutine options_remove_key(options_database, key)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key

    integer :: array_size, i
    
    if (options_has_key(options_database, key)) then          
      array_size=options_get_array_size(options_database, key)
      if (array_size .gt. 0) then
        do i=1,array_size
          if (options_has_key(options_database, get_options_array_key(key, i))) then
            call c_remove(options_database, get_options_array_key(key, i))
          end if
        end do
        call c_remove(options_database, trim(key)//"a_size")
      end if
    else 
      call c_remove(options_database, key)
    end if
  end subroutine options_remove_key  

  !--------------------------------------------------------------------------
  ! Private procedures acting as helpers to the functionality of the registry
  !--------------------------------------------------------------------------

  subroutine check_options_key_exists(options_database, key)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key

    if (.not. options_has_key(options_database, key)) then
      call log_log(log_error, "No configuration option with key "//trim(key)//" present")
    end if    
  end subroutine check_options_key_exists  

  subroutine options_add_real(options_database, key, real_value, do_not_replace, array_index)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    real(kind=DEFAULT_PRECISION), intent(in) :: real_value
    integer, intent(in), optional :: array_index
    logical, intent(in), optional :: do_not_replace

    integer :: temp_size
    character(len=len(key)+ARRAY_APPEND_SIZE) :: lookup_key

    if (present(do_not_replace)) then
      if (do_not_replace) then
        if (present(array_index)) then
          if (options_has_key(options_database, trim(key)//"a_"//conv_to_string(array_index))) return
        else
          if (options_has_key(options_database, key)) return
        end if
      end if      
    end if

    if (present(array_index)) then
      if (options_has_key(options_database, trim(key)//"a_size")) then
        temp_size=options_get_integer(options_database, trim(key)//"a_size")
        if (temp_size .lt. array_index) temp_size=temp_size+1
      else
        temp_size=1
      end if
      call options_add(options_database, trim(key)//"a_size", temp_size)      
      lookup_key=get_options_array_key(key, array_index)
    else
      lookup_key=key
    end if
    call c_put_real(options_database, lookup_key, real_value)
  end subroutine options_add_real

  subroutine options_add_logical(options_database, key, logical_value, do_not_replace, array_index)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    logical, intent(in) :: logical_value
    integer, intent(in), optional :: array_index
    logical, intent(in), optional :: do_not_replace

    integer :: temp_size
    character(len=len(key)+ARRAY_APPEND_SIZE) :: lookup_key

    if (present(do_not_replace)) then
      if (do_not_replace) then
        if (present(array_index)) then
          if (options_has_key(options_database, trim(key)//"a_"//conv_to_string(array_index))) return
        else
          if (options_has_key(options_database, key)) return
        end if
      end if      
    end if

    if (present(array_index)) then
      if (options_has_key(options_database, trim(key)//"a_size")) then
        temp_size=options_get_integer(options_database, trim(key)//"a_size")
        if (temp_size .lt. array_index) temp_size=temp_size+1
      else
        temp_size=1
      end if
      call options_add(options_database, trim(key)//"a_size", temp_size)
      lookup_key=get_options_array_key(key, array_index)
    else
      lookup_key=key
    end if
    call c_put_logical(options_database, lookup_key, logical_value)    
  end subroutine options_add_logical

  subroutine options_add_string(options_database, key, string_value, do_not_replace, array_index)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key, string_value
    integer, intent(in), optional :: array_index
    logical, intent(in), optional :: do_not_replace

    character(len=STRING_LENGTH) :: value_to_store
    integer :: temp_size
    character(len=len(key)+ARRAY_APPEND_SIZE) :: lookup_key

    if (present(do_not_replace)) then
      if (do_not_replace) then
        if (present(array_index)) then
          if (options_has_key(options_database, trim(key)//"a_"//conv_to_string(array_index))) return
        else
          if (options_has_key(options_database, key)) return
        end if
      end if      
    end if

    value_to_store=string_value

    if (present(array_index)) then
      if (options_has_key(options_database, trim(key)//"a_size")) then
        temp_size=options_get_integer(options_database, trim(key)//"a_size")
        if (temp_size .lt. array_index) temp_size=temp_size+1
      else
        temp_size=1
      end if
      call options_add(options_database, trim(key)//"a_size", temp_size)
      lookup_key=get_options_array_key(key, array_index)
    else
      lookup_key=key
    end if
    call c_put_string(options_database, lookup_key, value_to_store)
  end subroutine options_add_string

  recursive subroutine options_add_integer(options_database, key, int_value, do_not_replace, array_index)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    integer, intent(in) :: int_value
    integer, intent(in), optional :: array_index
    logical, intent(in), optional :: do_not_replace

    integer :: temp_size
    character(len=len(key)+ARRAY_APPEND_SIZE) :: lookup_key

    if (present(do_not_replace)) then
      if (do_not_replace) then
        if (present(array_index)) then
          if (options_has_key(options_database, trim(key)//"a_"//conv_to_string(array_index))) return
        else
          if (options_has_key(options_database, key)) return
        end if
      end if      
    end if

    if (present(array_index)) then
      if (options_has_key(options_database, trim(key)//"a_size")) then
        temp_size=options_get_integer(options_database, trim(key)//"a_size")
        if (temp_size .lt. array_index) temp_size=temp_size+1
      else
        temp_size=1
      end if
      call options_add(options_database, trim(key)//"a_size", temp_size)
      lookup_key=get_options_array_key(key, array_index)
    else
      lookup_key=key
    end if
    call c_put_integer(options_database, lookup_key, int_value)    
  end subroutine options_add_integer

  character(len=STRING_LENGTH) function get_options_array_key(key, index)
    character(len=*), intent(in) :: key
    integer, intent(in) :: index

    get_options_array_key=trim(key)//"a_"//trim(conv_to_string(index))
  end function get_options_array_key  

  integer function get_argument_value_type(specific_value)
    character(len=*), intent(in) :: specific_value
    integer :: dot_posn, exponent_posn

    if (conv_is_logical(specific_value)) then
      get_argument_value_type = logical_type
      return
      else
    end if

    dot_posn = index(specific_value,".")
    exponent_posn = index(specific_value,"e")
    if (dot_posn .eq. 0 .and. exponent_posn .eq. 0) then
      ! No dot, therefore an integer or string
      if (conv_is_integer(specific_value)) then
        get_argument_value_type = integer_type
        return
      end if
    else
      ! A dot is present, therefore a real or string
      if (conv_is_real(specific_value)) then
        get_argument_value_type = real_type
        return
      end if
    end if
    get_argument_value_type = string_type ! Default string type
  end function get_argument_value_type

  subroutine add_specific_option_key_value_pair(type_of_config, parse_options, specific_arg)
    integer, intent(in) :: type_of_config
    character(len=*), intent(in) :: specific_arg
    type(hashmap_type), intent(inout) :: parse_options

    integer :: equals_posn
    equals_posn=index(specific_arg, "=")  ! Get the position of the equals character

    if (type_of_config == logical_type) then
      if (equals_posn .gt. 0) then
        call set_options_logical_value(parse_options, specific_arg(3:equals_posn-1), &
          conv_to_logical(specific_arg(equals_posn+1:len(specific_arg))))
      else
        ! Handle the case where there is just a key (no value)
        call set_options_logical_value(parse_options, specific_arg(3:len(specific_arg)), .true.)
      end if
    else if (type_of_config == integer_type) then
      call set_options_integer_value(parse_options, specific_arg(3:equals_posn-1), &
        conv_to_integer(specific_arg(equals_posn+1:len(specific_arg))))
    else if (type_of_config == real_type) then
      call set_options_real_value(parse_options, specific_arg(3:equals_posn-1), &
        conv_single_real_to_double(conv_to_real(specific_arg(equals_posn+1:len(specific_arg)))))
    else if (type_of_config == string_type) then
      call set_options_string_value(parse_options, specific_arg(3:equals_posn-1), specific_arg(equals_posn+1:len(specific_arg)))
    end if
  end subroutine add_specific_option_key_value_pair

  subroutine set_options_logical_value(optionhashmap_type, key, logical_value)
    type(hashmap_type), intent(inout) :: optionhashmap_type
    character(len=*), intent(in) :: key
    logical, intent(in) :: logical_value

    call c_put_logical(optionhashmap_type, key, logical_value)
  end subroutine set_options_logical_value

  subroutine set_options_real_value(optionhashmap_type, key, real_value)
    type(hashmap_type), intent(inout) :: optionhashmap_type
    character(len=*), intent(in) :: key
    real(kind=DEFAULT_PRECISION), intent(in) :: real_value

    call c_put_real(optionhashmap_type, key, real_value)
  end subroutine set_options_real_value

  subroutine set_options_integer_value(optionhashmap_type, key, int_value)
    type(hashmap_type), intent(inout) :: optionhashmap_type
    character(len=*), intent(in) :: key
    integer, intent(in) :: int_value

    call c_put_integer(optionhashmap_type, key, int_value)
  end subroutine set_options_integer_value

  subroutine set_options_string_value(optionhashmap_type, key, str_value)
    type(hashmap_type), intent(inout) :: optionhashmap_type
    character(len=*), intent(in) :: key
    character(len=*), intent(in) :: str_value

    character(len=STRING_LENGTH) :: write_value

    ! We do an assignment here to force the value to be default size, otherwise might underflow
    write_value = str_value
    call c_put_string(optionhashmap_type, key, write_value)
  end subroutine set_options_string_value
end module optionsdatabase_mod