Program Listing for File mf6bmiUtil.f90

↰ Return to documentation for file (srcbmi/mf6bmiUtil.f90)

module mf6bmiutil
  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 genericutilitiesmodule, only: sim_message
  use simvariablesmodule, only: istdout
  use memorymanagermodule, only: get_from_memorylist
  use memoryhelpermodule, only: split_mem_address, split_mem_path
  use memorytypemodule, only: memorytype
  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

  integer(c_int), bind(c, name="BMI_LENVARTYPE") :: bmi_lenvartype = lenmemtype + 1
  !DEC$ ATTRIBUTES DLLEXPORT :: BMI_LENVARTYPE

  integer(c_int), bind(c, name="BMI_LENGRIDTYPE") :: bmi_lengridtype = lengridtype + 1
  !DEC$ ATTRIBUTES DLLEXPORT :: BMI_LENGRIDTYPE

  integer(c_int), bind(c, name="BMI_LENVARADDRESS") :: bmi_lenvaraddress = lenmemaddress + 1
  !DEC$ ATTRIBUTES DLLEXPORT :: BMI_LENVARADDRESS

contains

  subroutine split_address(c_var_address, mem_path, var_name)
    use memoryhelpermodule, only: mempathseparator
    character (kind=c_char), intent(in) :: c_var_address(*)
    character(len=LENMEMPATH), intent(out) :: mem_path
    character(len=LENVARNAME), intent(out) :: var_name
    ! local
    character(len=LENMEMPATH) :: var_address

    ! convert to fortran string
    var_address = char_array_to_string(c_var_address, strlen(c_var_address))

    call split_mem_address(var_address, mem_path, var_name)

  end subroutine split_address

  pure function strlen(char_array) result(string_length)
    character(c_char), intent(in) :: char_array(lenmempath)
    integer(I4B)                  :: string_length
    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

  pure function char_array_to_string(char_array, length) result(f_string)
    integer(c_int), intent(in) :: length
    character(c_char),intent(in) :: char_array(length)
    character(len=length) :: f_string
    integer(I4B) :: i

    do i = 1, length
      f_string(i:i) = char_array(i)
    enddo

  end function char_array_to_string

  pure function string_to_char_array(string, length) result(c_array)
  integer(c_int),intent(in) :: length
  character(len=length), intent(in) :: string
  character(kind=c_char,len=1) :: c_array(length+1)
  integer(I4B) :: i

  do i = 1, length
    c_array(i) = string(i:i)
  enddo
  c_array(length+1) = c_null_char

  end function string_to_char_array

  function extract_model_name(var_address) result(model_name)
    character(len=*), intent(in) :: var_address
    character(len=LENMODELNAME) :: model_name
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENCOMPONENTNAME) :: dummy_component
    character(len=LENVARNAME) :: var_name

    call split_mem_address(var_address, mem_path, var_name)
    call split_mem_path(mem_path, model_name, dummy_component)

  end function extract_model_name

  function get_model_name(grid_id) result(model_name)
    use listsmodule, only: basemodellist
    use basemodelmodule, only: basemodeltype, getbasemodelfromlist
    integer(kind=c_int), intent(in) :: grid_id
    character(len=LENMODELNAME) :: model_name
    ! local
    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 sim_message(error_msg, iunit=istdout, skipbefore=1, skipafter=1)
  end function get_model_name

  function getsolution(subcomponent_idx) result(solution)
    use solutiongroupmodule
    use numericalsolutionmodule
    use listsmodule, only: basesolutionlist, solutiongrouplist
    integer(I4B), intent(in) :: subcomponent_idx
    class(numericalsolutiontype), pointer :: solution
    ! local
    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 => getnumericalsolutionfromlist(basesolutionlist, solutionidx)
  end function getsolution

  subroutine get_grid_type_model(model_name, grid_type_f)
    use listsmodule, only: basemodellist
    use numericalmodelmodule, only: numericalmodeltype, getnumericalmodelfromlist
    character(len=LENMODELNAME) :: model_name
    character(len=LENGRIDTYPE) :: grid_type_f
    ! local
    integer(I4B) :: i
    class(numericalmodeltype), pointer :: numericalmodel

    do i = 1,basemodellist%Count()
      numericalmodel => getnumericalmodelfromlist(basemodellist, i)
      if (numericalmodel%name == model_name) then
        call numericalmodel%dis%get_dis_type(grid_type_f)
      end if
    end do
  end subroutine get_grid_type_model

  function confirm_grid_type(grid_id, expected_type) result(is_match)
    integer(kind=c_int), intent(in) :: grid_id
    character(len=*), intent(in) :: expected_type
    logical :: is_match
    ! local
    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

  function get_memory_access_type(mem_path, var_name, found) result(mem_access_type)
    character(len=*), intent(in) :: mem_path
    character(len=*), intent(in) :: var_name
    logical(LGP), intent(out) :: found
    integer(I4B) :: mem_access_type
    ! local
    type(memorytype), pointer :: mt

     ! check access
    found = .false.
    mem_access_type = -1
    mt => null()
    call get_from_memorylist(var_name, mem_path, mt, found, check=.false.)
    if (found) then
      mem_access_type = mt%memaccess
      found = .true.
    end if
  end function get_memory_access_type

end module mf6bmiUtil