parameters.F90

Go to the documentation of this file.

module parameters
 
  use iso_c_binding, only    : c_int, c_float, c_double, c_bool
  use datetime, only         : datetime_t
  use exceptions
  use file_operations, only  : ascii_file_t
  use logfiles
  use fstring
  use fstring_list, only     : fstring_list_t
  use dictionary
  use constants_and_conversions
  implicit none
 
  private
 
  !! module to provide a single POC for storage and retrieval of parameter scalars and vectors
  !! need to provide a method for storing, finding, and retrieving parameters.
  !! dictionary: keyword, string_list
 
  !! first create list of files. parse through each file, adding to the param dictionary.
  !! once complete, allow other modules to interrogate the dictionary. return matches in the
  !! data type required for the parameter. once all params are in place, the data structures can be
  !! deallocated.
 
  type, public :: parameters_t
 
    type (fstring_list_t)               :: filenames
    type (fstring_list_t)               :: delimiters
    type (fstring_list_t)               :: comment_chars
    integer (c_int)                     :: count           = 0
 
  contains
 
    procedure            :: add_filename_to_list_sub
    generic              :: add_file => add_filename_to_list_sub
 
    procedure            :: add_to_param_list_sub
    generic              :: add_parameters => add_to_param_list_sub
 
    procedure            :: munge_files_and_add_to_param_list_sub
    generic              :: munge_file => munge_files_and_add_to_param_list_sub
 
    procedure            :: get_parameter_values_int
    procedure            :: get_parameter_values_float
    procedure            :: get_parameter_values_logical
    procedure            :: get_parameter_table_float
    procedure            :: get_parameter_values_string_list
 
    generic              :: get_parameters => get_parameter_values_int,         &
                                              get_parameter_values_float,       &
                                              get_parameter_table_float,        &
                                              get_parameter_values_logical,     &
                                              get_parameter_values_string_list
 
    procedure            :: grep_name => grep_parameter_name
 
 
    ! other functionality:
    !  * retrieve parameter list:
    !      1) input = single string
    !      2) input = string list
    !  * basic error checking re: number of params in list
 
 
 
  end type parameters_t
 
  type (parameters_t), public :: params
  type (dict_t), public       :: params_dict
 
  integer (c_int), parameter  :: max_table_record_len = 2048
 
contains
 
  subroutine add_filename_to_list_sub( this, sFilename, sDelimiters, sCommentChars )
 
    class(parameters_t)                          :: this
    character (len=*), intent(in)                 :: sFilename
    character (len=*), intent(in), optional       :: sDelimiters
    character (len=*), intent(in), optional       :: sCommentChars
 
    ! [ LOCALS ]
    character (len=:), allocatable  :: sDelimiters_
    character (len=:), allocatable  :: sCommentChars_
 
    if ( present(scommentchars) ) then
      scommentchars_ = scommentchars
    else
      scommentchars_ = comment_characters
    endif
 
    if (present(sdelimiters) ) then
      sdelimiters_ = sdelimiters
    else
      sdelimiters_ = tab
    endif
 
    this%count = this%count + 1
 
    call this%filenames%append( sfilename )
    call this%delimiters%append( sdelimiters_ )
    call this%comment_chars%append( scommentchars_ )
 
  end subroutine add_filename_to_list_sub
 
!--------------------------------------------------------------------------------------------------
 
  subroutine munge_files_and_add_to_param_list_sub(this, comment_chars, delimiters)
 
    class(parameters_t)    :: this
    character (len=*), intent(in), optional  :: comment_chars
    character (len=*), intent(in), optional  :: delimiters
 
    ! [ LOCALS ]
    integer (c_int)                :: iFileIndex, iColIndex, iTempIndex
    integer (c_int)                :: iStat
    type (ASCII_FILE_T)            :: DF
    type (DICT_ENTRY_T), pointer   :: pDict
    type (DICT_ENTRY_T), pointer   :: pCurrentDict
    integer (c_int)                :: iNumberOfHeaderLines
    character (len=:), allocatable :: sNumberOfHeaderLines
    character (len=256)            :: column_name
    character (len=256)            :: tempstr2
    character (len=256)            :: qualified_column_name
    character (len=256)            :: filename1
    character (len=:), allocatable :: comment_chars_
    character (len=:), allocatable :: delimiters_
    logical (c_bool), allocatable  :: skip_this_column(:)
    type (FSTRING_LIST_T)          :: unique_file_list
    integer (kind=c_int)           :: row_indx
    integer (c_int)                :: number_of_columns
    character (len=MAX_TABLE_RECORD_LEN) :: sRecord, sItem
 
    if ( present(comment_chars) ) then
      comment_chars_ = trim(comment_chars)
    else
      comment_chars_ = comment_characters
    endif
 
    if ( present(delimiters) ) then
      delimiters_ = trim(delimiters)
    else
      delimiters_ = tab
    endif
 
    !
    ! proper way to screen for duplicate filenames is further down in loop
    !
    !unique_file_list = this%filenames%unique()
    !if ( unique_file_list%get(1) .ne. '<NA>' ) then
 
    if ( this%filenames%get(1) .ne. '<NA>' ) then
 
      do ifileindex = 1, this%filenames%count
 
        filename1 = this%filenames%get(ifileindex)
 
        ! if this filename has already been seen and processed, ignore and move on to next filename
        if ( unique_file_list%count_matching(filename1) > 0 ) cycle
 
        call unique_file_list%append(filename1)
 
        ! open the file associated with current file index value
        call df%open(sfilename = filename1,                                  &
                     scommentchars = comment_chars_,                         &
                     sdelimiters = delimiters_ )
 
        ! obtain the headers from the file
        df%slColNames = df%readHeader()
 
        number_of_columns = df%slColNames%count
 
        call logs%write( "Number of columns in file: "//ascharacter( number_of_columns ), itab=35)
 
        !call DF%slColNames%print()
 
        if (allocated(skip_this_column))  deallocate(skip_this_column)
        allocate(skip_this_column(number_of_columns))
        skip_this_column = false
 
        ! loop over each column header
        do icolindex = 1, df%slColNames%count
 
          column_name = df%slColNames%get(icolindex)
 
          if ( params_dict%key_already_in_use( column_name ) ) then
 
            skip_this_column( icolindex ) = true
 
            call warn("Column name "//squote(column_name)//" already in use. Data in this column will be ignored." &
              //" [filename = "//squote(filename1)//"]")
 
            ! Dec 2019: let try eliminating duplicates from the dictionary altogether
 
            ! ! add dictionary entry to dictionary, tack "DUP" on end of name
            ! tempstr = trim(adjustl(tempstr))//"_DUP"
            ! ! update the string list to reflect duplicate entry
 
            ! call DF%slColNames%replace( iColIndex, tempstr )
            ! call pDict%add_key( asUppercase( tempstr ) )
            ! call PARAMS_DICT%add_entry( pDict )
 
          else
 
            ! create and allocate memory for dictionary entry
            pdict => null()
            allocate( pdict, stat=istat )
            call assert(istat == 0, "Failed to allocate memory for dictionary object", &
              __file__, __line__ )
 
            ! first add the key to the dictionary entry,
            ! then add dictionary entry to dictionary
            call pdict%add_key( column_name )
            call params_dict%add_entry( pdict )
 
          endif
 
        enddo
 
        row_indx = 0
 
        ! now read in the remainder of the file
        do while ( .not. df%isEOF() )
 
          ! read in next line of file
          srecord = df%readLine()
 
          ! skip blank lines
          if ( len_trim(srecord) == 0 ) cycle
 
          row_indx = row_indx + 1
 
          ! loop over each column header
          do icolindex = 1, df%slColNames%count
 
            ! break off next column of data for the current record
            call chomp(srecord, sitem, this%delimiters%get(ifileindex) )
 
            if ( skip_this_column(icolindex) )  cycle
 
            column_name = df%slColNames%get(icolindex)
          
            ! find pointer associated with header name
            ! (inefficient, but should be OK for small # of columns)
            pcurrentdict => params_dict%get_entry( column_name )
 
            if ( associated( pcurrentdict )) then
 
              ! if not null, it means that we were able to return a pointer
              ! associated with the current column heading
              call pcurrentdict%add_value( sitem )
 
            else
 
              call warn("Internal programming error: null pointer detected" &
                //" -- was trying to find pointer associated with column "//dquote(df%slColNames%get(icolindex)), &
                __file__, __line__)
 
            endif
 
          enddo
 
        enddo
 
        deallocate(skip_this_column)
 
        call df%close()
 
      enddo
      
    endif
 
  end subroutine munge_files_and_add_to_param_list_sub
 
!--------------------------------------------------------------------------------------------------
 
  subroutine add_to_param_list_sub(this, sKey, sValues, iValues, fValues, dValues, lValues)
 
    class(parameters_t)                         :: this
    character (len=*), intent(in)                :: sKey
    character (len=*), intent(in), optional      :: sValues(:)
    integer (c_int), intent(in), optional   :: iValues(:)
    real (c_float), intent(in), optional    :: fValues(:)
    real (c_double), intent(in), optional   :: dValues(:)
    logical (c_bool), intent(in), optional  :: lValues(:)
 
    ! [ LOCALS ]
    integer (c_int)         :: iStat
    type (DICT_ENTRY_T), pointer :: pDict
    integer (c_int)         :: iIndex
    type (DICT_ENTRY_T), pointer :: pCurrentDict
    character (len=MAX_TABLE_RECORD_LEN) :: sRecord, sItem
 
 
    pcurrentdict => null()
    pcurrentdict => params_dict%get_entry( skey )
 
    if ( .not. associated( pcurrentdict )) then
 
      ! if key does not currently exist, make a new entry with this key value
      allocate( pcurrentdict, stat=istat )
 
      call assert(istat == 0, "Failed to allocate memory for dictionary object", &
          __file__, __line__ )
 
      ! add dictionary entry to dictionary
      call pcurrentdict%add_key( skey )
      call params_dict%add_entry( pcurrentdict )
 
    endif
 
    if ( present( svalues ) ) then
 
      do iindex = lbound(svalues,1), ubound(svalues,1)
 
        call pcurrentdict%add_value( svalues( iindex ) )
 
      enddo
 
    else if ( present ( ivalues ) ) then
 
      do iindex = lbound(ivalues,1), ubound(ivalues,1)
 
        call pcurrentdict%add_value( ivalues( iindex ) )
 
      enddo
 
    else if ( present ( fvalues ) ) then
 
      do iindex = lbound(fvalues,1), ubound(fvalues,1)
 
        call pcurrentdict%add_value( fvalues( iindex ) )
 
      enddo
 
    else if ( present ( dvalues ) ) then
 
      do iindex = lbound(dvalues,1), ubound(dvalues,1)
 
        call pcurrentdict%add_value( dvalues( iindex ) )
 
      enddo
 
    else if ( present ( lvalues ) ) then
 
      do iindex = lbound(lvalues,1), ubound(lvalues,1)
 
        call pcurrentdict%add_value( lvalues( iindex ) )
 
      enddo
 
    endif
 
  end subroutine add_to_param_list_sub
 
!--------------------------------------------------------------------------------------------------
 
  function grep_parameter_name( this, sKey, lFatal )      result( slList )
 
    class(parameters_t)                                       :: this
    character (len=*), intent(in)                              :: skey
    logical (c_bool), intent(in), optional                :: lfatal
    type ( fstring_list_t )                                     :: sllist
 
    ! [ LOCALS ]
    logical (c_bool) :: lfatal_l
 
    if ( present (lfatal) ) then
      lfatal_l = lfatal
    else
      lfatal_l = false
    endif
 
    sllist = params_dict%grep_keys( asuppercase( skey ) )
 
    if ( lfatal_l ) then
 
       if ( sllist%get(1) .strequal. "<NA>" )                              &
         call warn( "Failed to find a lookup table column whose name contains "        &
           //dquote( skey )//".", lfatal = lfatal_l )
 
    endif
 
  end function grep_parameter_name
 
!--------------------------------------------------------------------------------------------------
 
  subroutine get_parameter_values_logical( this, lValues, slKeys, sKey, lFatal )
 
    class(parameters_t)                                        :: this
    logical (c_bool), intent(in out), allocatable          :: lValues(:)
    type (FSTRING_LIST_T), intent(in out),              optional :: slKeys
    character (len=*),    intent(in ),                 optional :: sKey
    logical (c_bool), intent(in),                 optional :: lFatal
 
    ! [ LOCALS ]
    logical (c_bool) :: lFatal_l
 
    if ( present (lfatal) ) then
      lfatal_l = lfatal
    else
      lfatal_l = false
    endif
 
    if ( present( slkeys) ) then
 
      call params_dict%get_values( slkeys=slkeys, lvalues=lvalues,            &
        is_fatal=lfatal_l )
 
!       if ( any( iValues <= iTINYVAL ) ) &
!         call warn( "Failed to find a lookup table column named " &
!           //dQuote( slKeys%list_all() )//".", lFatal = lFatal_l )
 
    else if ( present( skey) ) then
 
      call params_dict%get_values( skey=skey, lvalues=lvalues )
 
!       if ( any( iValues <= iTINYVAL ) ) &
!         call warn( "Failed to find a lookup table column named " &
!           //dQuote( sKey )//".", lFatal = lFatal_l )
 
    endif
 
  end subroutine get_parameter_values_logical
 
!--------------------------------------------------------------------------------------------------
 
  subroutine get_parameter_values_datetime( this, dtValues, slKeys, sKey, lFatal )
 
    class(parameters_t)                                        :: this
    type (DATETIME_T), intent(in out), allocatable              :: dtValues(:)
    type (FSTRING_LIST_T), intent(in out),             optional :: slKeys
    character (len=*),    intent(in ),                 optional :: sKey
    logical (c_bool), intent(in),                      optional :: lFatal
 
    ! [ LOCALS ]
    logical (c_bool)                        :: lFatal_l
    type (FSTRING_LIST_T)                   :: slValues
    integer (c_int)                         :: n
    integer (c_int)                         :: istat
 
    if ( present (lfatal) ) then
      lfatal_l = lfatal
    else
      lfatal_l = false
    endif
 
    if ( present( slkeys) ) then
 
      call params_dict%get_values( slkeys=slkeys, slstring=slvalues, is_fatal=lfatal_l )
 
    else if ( present( skey) ) then
 
      call params_dict%get_values( skey=skey, slstring=slvalues )
 
    endif
 
    allocate(dtvalues(slvalues%count), stat=istat)
 
    do n=1, slvalues%count
      call dtvalues(n)%parseDate(slvalues%get(n))
    enddo  
 
  end subroutine get_parameter_values_datetime
 
  !--------------------------------------------------------------------------------------------------
 
  subroutine get_parameter_values_string_list( this, slValues, slKeys, sKey, lFatal )
 
    class(parameters_t)                               :: this
    type (FSTRING_LIST_T), intent(out)                 :: slValues
    type (FSTRING_LIST_T), intent(inout), optional     :: slKeys
    character (len=*), intent(in ), optional           :: sKey
    logical (c_bool), intent(in), optional             :: lFatal
 
    ! [ LOCALS ]
    logical (c_bool) :: lFatal_l
 
    if ( present (lfatal) ) then
      lfatal_l = lfatal
    else
      lfatal_l = false
    endif
 
    if ( present( slkeys) ) then
 
      call params_dict%get_values( slkeys=slkeys, slstring=slvalues,          &
        is_fatal=lfatal_l )
 
       if ( slvalues%get(1) .strequal. "<NA>" ) then
         call warn( "Failed to find a lookup table column named "             &
           //dquote( slkeys%list_all() )//".", lfatal = lfatal_l )
       end if
 
    else if ( present( skey) ) then
 
      call params_dict%get_values( skey=skey, slstring=slvalues )
 
      if ( slvalues%get(1) .strequal. "<NA>" ) then
        call warn( "Failed to find a lookup table column named "              &
          //dquote( skey )//".", lfatal = lfatal_l )
      end if
 
    endif
 
  end subroutine get_parameter_values_string_list
 
!--------------------------------------------------------------------------------------------------
 
  subroutine get_parameter_values_int( this, iValues, slKeys, sKey, lFatal )
 
    class(parameters_t)                                       :: this
    integer (c_int), intent(out), allocatable             :: iValues(:)
    type (FSTRING_LIST_T), intent(in out),             optional :: slKeys
    character (len=*),    intent(in ),                optional :: sKey
    logical (c_bool), intent(in),                optional :: lFatal
 
    ! [ LOCALS ]
    logical (c_bool) :: lFatal_l
 
    if ( present (lfatal) ) then
      lfatal_l = lfatal
    else
      lfatal_l = false
    endif
 
    if ( present( slkeys) ) then
 
      call params_dict%get_values( slkeys=slkeys, ivalues=ivalues,            &
        is_fatal=lfatal_l )
 
      if ( any( ivalues <= itinyval ) ) &
        call warn( "Failed to find a lookup table column named " &
          //dquote( slkeys%list_all() )//".", lfatal = lfatal_l )
 
    else if ( present( skey) ) then
 
      call params_dict%get_values( skey=skey, ivalues=ivalues,                &
        is_fatal=lfatal_l )
 
      if ( any( ivalues <= itinyval ) ) &
        call warn( "Failed to find a lookup table column named " &
          //dquote( skey )//".", lfatal = lfatal_l )
 
    endif
 
  end subroutine get_parameter_values_int
 
!--------------------------------------------------------------------------------------------------
 
  subroutine get_parameter_values_float( this, fValues, slKeys, sKey, lFatal )
 
    class(parameters_t)                                       :: this
    real (c_float),  intent(in out), allocatable               :: fValues(:)
    type (FSTRING_LIST_T), intent(in out),            optional :: slKeys
    character (len=*),    intent(in ),                optional :: sKey
    logical (c_bool), intent(in),                     optional :: lFatal
 
    ! [ LOCALS ]
    logical (c_bool) :: lFatal_l
 
    if ( present (lfatal) ) then
      lfatal_l = lfatal
    else
      lfatal_l = false
    endif
 
    if ( present( slkeys) ) then
 
      call params_dict%get_values( slkeys=slkeys, fvalues=fvalues )
 
      if ( any( fvalues <= ftinyval ) ) &
        call warn( "Failed to find a lookup table column named " &
          //dquote( slkeys%list_all() )//".", lfatal = lfatal_l )
 
    else if ( present( skey) ) then
 
      call params_dict%get_values( skey=skey, fvalues=fvalues,                &
        is_fatal=lfatal_l )
 
      if ( any( fvalues <= ftinyval ) ) &
        call warn( "Failed to find a lookup table column named " &
          //dquote( skey )//".", lfatal = lfatal_l )
 
    endif
 
  end subroutine get_parameter_values_float
 
!--------------------------------------------------------------------------------------------------
 
  subroutine get_parameter_table_float( this, fValues, sPrefix, iNumRows, lFatal )
 
    use fstring
 
    class(parameters_t)                                       :: this
    real (c_float),  intent(in out), allocatable               :: fValues(:,:)
    character (len=*),    intent(in)                           :: sPrefix
    integer (c_int), intent(in)                                :: iNumRows
    logical (c_bool), intent(in),                     optional :: lFatal
 
    ! [ LOCALS ]
    integer (c_int)             :: iIndex
    integer (c_int)             :: iStat
    character (len=256)         :: sText
    integer (c_int)             :: iNumCols
    type (FSTRING_LIST_T)        :: slList
    real (c_float), allocatable :: fTempVal(:)
    logical (c_bool)            :: lFatal_l
 
    if ( present (lfatal) ) then
      lfatal_l = lfatal
    else
      lfatal_l = false
    endif
 
    sllist = params%grep_name( sprefix )
 
    inumcols = sllist%count
 
    if ( inumcols == 0 ) then
 
      call warn( "Failed to find a lookup table column named " &
        //dquote( sprefix )//".", lfatal = lfatal_l )
 
    else
 
      allocate( ftempval( inumrows ), stat=istat )
      call assert( istat == 0, "Problem allocating memory.", __file__, __line__ )
 
      allocate( fvalues( inumrows, inumcols ), stat=istat )
      call assert( istat == 0, "Problem allocating memory."                            &
        //"~iNumCols: "//ascharacter(inumcols)//"; iNumRows: "//ascharacter(inumrows)  &
        //" sPrefix: "//dquote(sprefix), __file__, __line__ )
 
      do iindex = 1, inumcols
 
        stext = trim( sllist%get( iindex ) )
        call params_dict%get_values( skey=stext, fvalues=ftempval,            &
          is_fatal=lfatal_l )
 
        call assert( size( ftempval, 1) == size( fvalues, 1),                 &
          "Mismatch in array size. Dictionary key: "//squote( stext )         &
          //"  expected size: "//ascharacter( size( fvalues, 1) )             &
          //"  size of items in dictionary: "                                 &
          //ascharacter( size( ftempval, 1) )   )
 
        fvalues(:,iindex) = ftempval
      enddo
 
    endif
 
  end subroutine get_parameter_table_float
 
end module parameters