mf6bmiUtil.f90

Go to the documentation of this file.

!> @brief This module contains helper routines and parameters for the MODFLOW 6 BMI
!!
!<
module mf6bmiutil
  use mf6bmierror
  use iso_c_binding, only: c_int, c_char, c_null_char
  use constantsmodule, only: maxcharlen, lenmempath, lenvarname, &
                             lenmodelname, linelength, lenmemtype, &
                             lenmemaddress, lencomponentname
  use kindmodule, only: dp, i4b, lgp
  use messagemodule, only: write_message
  use simvariablesmodule, only: istdout
  use memoryhelpermodule, only: split_mem_address, split_mem_path
  implicit none
 
  ! the following exported parameters will trigger annoying warnings with
  ! the Intel Fortran compiler (4049,4217). We know that these can be ignored:
  !
  ! https://community.intel.com/t5/Intel-Fortran-Compiler/suppress-linker-warnings/td-p/855137
  ! https://community.intel.com/t5/Intel-Fortran-Compiler/Locally-Defined-Symbol-Imported/m-p/900805
  !
  ! and gfortran does so anyway. They have been disabled in the linker config.
 
  integer(I4B), parameter :: lengridtype = 16 !< max length for Fortran grid type string
  integer(I4B), parameter :: lenunits = 16 !< max length for Fortran units string
  integer(I4B), parameter :: lenvarlocation = 16 !< max length for Fortran variable location string
 
  integer(c_int), bind(C, name="BMI_LENVARTYPE") :: bmi_lenvartype = &
                                                    lenmemtype + 1 !< max. length for variable type C-strings
  !DIR$ ATTRIBUTES DLLEXPORT :: BMI_LENVARTYPE
 
  integer(c_int), bind(C, name="BMI_LENGRIDTYPE") :: bmi_lengridtype = &
                                                     lengridtype + 1 !< max. length for grid type C-strings
  !DIR$ ATTRIBUTES DLLEXPORT :: BMI_LENGRIDTYPE
 
  integer(c_int), bind(C, name="BMI_LENUNITS") :: bmi_lenunits = &
                                                  lenunits + 1 !< max. length for units C-strings
  !DIR$ ATTRIBUTES DLLEXPORT :: BMI_LENUNITS
 
  integer(c_int), bind(C, name="BMI_LENVARLOCATION") :: bmi_lenvarlocation = &
                                                        lenvarlocation + 1 !< max. length for variable location C-strings
  !DIR$ ATTRIBUTES DLLEXPORT :: BMI_LENVARLOCATION
 
  integer(c_int), bind(C, name="BMI_LENVARADDRESS") :: bmi_lenvaraddress = &
                                                       lenmemaddress + 1 !< max. length for the variable's address C-string
  !DIR$ ATTRIBUTES DLLEXPORT :: BMI_LENVARADDRESS
 
  integer(c_int), bind(C, name="BMI_LENCOMPONENTNAME") :: bmi_lencomponentname = &
                                                          256 !< component name length, i.e. 'MODFLOW 6'
  !DIR$ ATTRIBUTES DLLEXPORT :: BMI_LENCOMPONENTNAME
 
  integer(c_int), bind(C, name="BMI_LENVERSION") :: bmi_lenversion = 256 !< length of version string, e.g. '6.3.1' or '6.4.1-dev'
  !DIR$ ATTRIBUTES DLLEXPORT :: BMI_LENVERSION
 
contains
 
  !> @brief Split the variable address string
  !!
  !! Splits the full address string into a memory path and variable name,
  !! following the rules used by the memory manager. The error handling
  !! is inside to avoid lots of duplication
  !<
  subroutine split_address(c_var_address, mem_path, var_name, success)
    ! -- modules
    use memoryhelpermodule, only: mempathseparator
    ! -- dummy variables
    character(kind=c_char), intent(in) :: c_var_address(*) !< full address of a variable
    character(len=LENMEMPATH), intent(out) :: mem_path !< memory path used by the memory manager
    character(len=LENVARNAME), intent(out) :: var_name !< name of the variable
    logical(LGP), intent(out) :: success !< false when invalid
    ! -- local variables
    character(len=LENMEMADDRESS) :: var_address
    logical(LGP) :: valid, found
 
    success = .false.
 
    ! try and split the address string:
    var_address = char_array_to_string(c_var_address, &
                                       strlen(c_var_address, lenmemaddress + 1))
    call split_mem_address(var_address, mem_path, var_name, valid)
    if (.not. valid) then
      write (bmi_last_error, fmt_invalid_var) trim(var_address)
      call report_bmi_error(bmi_last_error)
      return
    end if
 
    ! check if the variable even exists:
    call check_mem_address(mem_path, var_name, found)
    if (.not. found) then
      write (bmi_last_error, fmt_unknown_var) trim(var_name), trim(mem_path)
      call report_bmi_error(bmi_last_error)
      return
    end if
 
    ! warn if the variable is addressed by a deprecated name
    call warn_deprecated_address(mem_path, var_name)
 
    success = .true.
 
  end subroutine split_address
 
  !> @brief Check if the variable exists in the memory manager
  !<
  subroutine check_mem_address(mem_path, var_name, found)
    ! -- modules
    use memorymanagermodule, only: get_from_memorystore
    use memorytypemodule, only: memorytype
    ! -- dummy variables
    character(len=LENMEMPATH), intent(in) :: mem_path !< memory path used by the memory manager
    character(len=LENVARNAME), intent(in) :: var_name !< name of the variable
    logical(LGP), intent(out) :: found !< true when found
    ! -- local variables
    type(memorytype), pointer :: mt
 
    found = .false.
    mt => null()
 
    ! check = false: otherwise stop is called when the variable does not exist
    call get_from_memorystore(var_name, mem_path, mt, found, check=.false.)
 
  end subroutine check_mem_address
 
  !> @brief Store a warning the first time a deprecated variable name is used
  !<
  subroutine warn_deprecated_address(mem_path, var_name)
    ! -- modules
    use memoryaliasmodule, only: get_deprecated_alias
    use simmodule, only: store_warning
    ! -- dummy variables
    character(len=LENMEMPATH), intent(in) :: mem_path !< memory path used by the memory manager
    character(len=LENVARNAME), intent(in) :: var_name !< name of the variable
    ! -- local variables
    logical(LGP) :: found
    character(len=LENMEMADDRESS) :: replacement
    character(len=LINELENGTH) :: version
    character(len=MAXCHARLEN) :: msg
 
    call get_deprecated_alias(var_name, mem_path, found, replacement, version)
    if (.not. found) return
 
    write (msg, '(a)') &
      "API VARIABLE '"//trim(var_name)//"' IN '"//trim(mem_path)// &
      "' WAS DEPRECATED IN VERSION "//trim(version)//". USE '"// &
      trim(replacement)//"' INSTEAD."
    call store_warning(trim(msg), substring=trim(msg))
 
  end subroutine warn_deprecated_address
 
  !> @brief Returns the string length without the trailing null character
  !<
  pure function strlen(char_array, max_len) result(string_length)
    ! -- dummy variables
    integer(I4B), intent(in) :: max_len
    character(c_char), intent(in) :: char_array(max_len) !< C-style character string
    integer(I4B) :: string_length !< Fortran string length
    ! -- local variables
    integer(I4B) :: i
 
    string_length = 0
    do i = 1, size(char_array)
      if (char_array(i) .eq. c_null_char) then
        string_length = i - 1
        exit
      end if
    end do
 
  end function strlen
 
  !> @brief Convert C-style string to Fortran character string
  !<
  pure function char_array_to_string(char_array, length) result(f_string)
    ! -- dummy variables
    integer(c_int), intent(in) :: length !< string length without terminating null character
    character(c_char), intent(in) :: char_array(length) !< string to convert
    character(len=length) :: f_string !< Fortran fixed length character string
    ! -- local variables
    integer(I4B) :: i
 
    do i = 1, length
      f_string(i:i) = char_array(i)
    end do
 
  end function char_array_to_string
 
  !> @brief Convert Fortran string to C-style character string
  !<
  pure function string_to_char_array(string, length) result(c_array)
    ! -- dummy variables
    integer(c_int), intent(in) :: length !< Fortran string length
    character(len=length), intent(in) :: string !< string to convert
    character(kind=c_char, len=1) :: c_array(length + 1) !< C-style character string
    ! -- local variables
    integer(I4B) :: i
 
    do i = 1, length
      c_array(i) = string(i:i)
    end do
    c_array(length + 1) = c_null_char
 
  end function string_to_char_array
 
  !> @brief Extract the model name from a memory address string
  !<
  function extract_model_name(var_address, success) result(model_name)
    ! -- dummy variables
    character(len=*), intent(in) :: var_address !< the memory address for the variable
    character(len=LENMODELNAME) :: model_name !< the extracted model name
    logical(LGP), intent(out) :: success
    ! -- local variables
    character(len=LENMEMPATH) :: mem_path
    character(len=LENCOMPONENTNAME) :: dummy_component
    character(len=LENVARNAME) :: var_name
    logical(LGP) :: split_succeeded
 
    success = .false.
 
    call split_mem_address(var_address, mem_path, var_name, split_succeeded)
    if (.not. split_succeeded) then
      return
    end if
 
    call split_mem_path(mem_path, model_name, dummy_component)
    success = .true.
 
  end function extract_model_name
 
  !> @brief Get the model name from the grid id
  !<
  function get_model_name(grid_id) result(model_name)
    ! -- modules
    use listsmodule, only: basemodellist
    use basemodelmodule, only: basemodeltype, getbasemodelfromlist
    ! -- dummy variables
    integer(kind=c_int), intent(in) :: grid_id !< grid id
    character(len=LENMODELNAME) :: model_name !< model name
    ! -- local variables
    integer(I4B) :: i
    class(basemodeltype), pointer :: basemodel
    character(len=LINELENGTH) :: error_msg
 
    model_name = ''
 
    do i = 1, basemodellist%Count()
      basemodel => getbasemodelfromlist(basemodellist, i)
      if (basemodel%id == grid_id) then
        model_name = basemodel%name
        return
      end if
    end do
 
    write (error_msg, '(a,i0)') 'BMI error: no model for grid id ', grid_id
    call write_message(error_msg, iunit=istdout, skipbefore=1, skipafter=1)
  end function get_model_name
 
  !> @brief Get the solution object for this index
  !<
  function getsolution(subcomponent_idx) result(solution)
    ! -- modules
    use solutiongroupmodule
    use basesolutionmodule, only: basesolutiontype, getbasesolutionfromlist
    use listsmodule, only: basesolutionlist, solutiongrouplist
    ! -- dummy variables
    integer(I4B), intent(in) :: subcomponent_idx !< index of solution
    class(basesolutiontype), pointer :: solution !< Base Solution
    ! -- local variables
    class(solutiongrouptype), pointer :: sgp
    integer(I4B) :: solutionidx
 
    ! this is equivalent to how it's done in sgp_ca
    sgp => getsolutiongroupfromlist(solutiongrouplist, 1)
    solutionidx = sgp%idsolutions(subcomponent_idx)
    solution => getbasesolutionfromlist(basesolutionlist, solutionidx)
  end function getsolution
 
  !> @brief Get the grid type for a named model as a fortran string
  !<
  subroutine get_grid_type_model(model_name, grid_type_f)
    ! -- modules
    use listsmodule, only: basemodellist
    use basemodelmodule, only: basemodeltype, getbasemodelfromlist
    ! -- dummy variables
    character(len=LENMODELNAME) :: model_name
    character(len=LENGRIDTYPE) :: grid_type_f
    ! -- local variables
    integer(I4B) :: i
    class(basemodeltype), pointer :: baseModel
 
    do i = 1, basemodellist%Count()
      basemodel => getbasemodelfromlist(basemodellist, i)
      if (basemodel%name == model_name) then
        call basemodel%dis%get_dis_type(grid_type_f)
        return
      end if
    end do
  end subroutine get_grid_type_model
 
  !> @brief Confirm that grid is of an expected type
  !<
  function confirm_grid_type(grid_id, expected_type) result(is_match)
    ! -- dummy variables
    integer(kind=c_int), intent(in) :: grid_id
    character(len=*), intent(in) :: expected_type
    logical :: is_match
    ! -- local variables
    character(len=LENMODELNAME) :: model_name
    character(len=LENGRIDTYPE) :: grid_type
 
    is_match = .false.
 
    model_name = get_model_name(grid_id)
    call get_grid_type_model(model_name, grid_type)
    ! careful comparison:
    if (expected_type == grid_type) is_match = .true.
  end function confirm_grid_type
 
end module mf6bmiutil