Program Listing for File mf6xmi.f90

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

module mf6xmi
  use mf6bmi
  use mf6bmiutil
  use mf6coremodule
  use kindmodule
  use bmif, only: bmi_success, bmi_failure
  use iso_c_binding, only: c_int, c_char
  implicit none


  integer(I4B), pointer :: iterationcounter => null()

  contains

  function xmi_prepare_time_step(dt) result(bmi_status) bind(C, name="prepare_time_step")
  !DEC$ ATTRIBUTES DLLEXPORT :: xmi_prepare_time_step
    double precision, intent(in) :: dt
    integer(kind=c_int) :: bmi_status

    call mf6preparetimestep()
    bmi_status = bmi_success

  end function xmi_prepare_time_step

  function xmi_do_time_step() result(bmi_status) bind(C, name="do_time_step")
  !DEC$ ATTRIBUTES DLLEXPORT :: xmi_do_time_step
    integer(kind=c_int) :: bmi_status

    call mf6dotimestep()
    bmi_status = bmi_success

  end function xmi_do_time_step

  function xmi_finalize_time_step() result(bmi_status) bind(C, name="finalize_time_step")
  !DEC$ ATTRIBUTES DLLEXPORT :: xmi_finalize_time_step
    integer(kind=c_int) :: bmi_status
    ! local
    logical :: hasconverged

    hasconverged = mf6finalizetimestep()
    if (hasconverged) then
      bmi_status = bmi_success
    else
      bmi_status = bmi_failure
    end if

  end function xmi_finalize_time_step

  function xmi_get_subcomponent_count(count) result(bmi_status) bind(C, name="get_subcomponent_count")
  !DEC$ ATTRIBUTES DLLEXPORT :: xmi_get_subcomponent_count
    use listsmodule, only: solutiongrouplist
    use simvariablesmodule, only: istdout
    integer(kind=c_int), intent(out) :: count
    integer(kind=c_int) :: bmi_status
    ! local
    class(solutiongrouptype), pointer :: sgp

    ! the following is true for all calls at this level (subcomponent)
    if (solutiongrouplist%Count() /= 1) then
      write(istdout,*) 'Error: BMI does not support the use of multiple solution groups'
      count = -1
      bmi_status = bmi_failure
      return
    end if

    sgp => getsolutiongroupfromlist(solutiongrouplist, 1)
    count = sgp%nsolutions
    bmi_status = bmi_success

  end function xmi_get_subcomponent_count

  function xmi_prepare_solve(subcomponent_idx) result(bmi_status) bind(C, name="prepare_solve")
  !DEC$ ATTRIBUTES DLLEXPORT :: xmi_prepare_solve
    use listsmodule, only: solutiongrouplist
    use numericalsolutionmodule
    use simvariablesmodule, only: istdout
    integer(kind=c_int) :: subcomponent_idx
    integer(kind=c_int) :: bmi_status
    ! local
    class(numericalsolutiontype), pointer :: ns

     ! people might not call 'xmi_get_subcomponent_count' first, so let's repeat this:
    if (solutiongrouplist%Count() /= 1) then
      write(istdout,*) 'Error: BMI does not support the use of multiple solution groups'
      bmi_status = bmi_failure
      return
    end if

    ! get the numerical solution we are running
    ns => getsolution(subcomponent_idx)

    ! *_ad (model, exg, sln)
    call ns%prepareSolve()

    ! reset counter
    allocate(iterationcounter)
    iterationcounter = 0

    bmi_status = bmi_success

  end function xmi_prepare_solve

  function xmi_solve(subcomponent_idx, has_converged) result(bmi_status) bind(C, name="solve")
  !DEC$ ATTRIBUTES DLLEXPORT :: xmi_solve
    use numericalsolutionmodule
    integer(kind=c_int), intent(in) :: subcomponent_idx
    integer(kind=c_int), intent(out) :: has_converged
    integer(kind=c_int) :: bmi_status
    ! local
    class(numericalsolutiontype), pointer :: ns

    ! get the numerical solution we are running
    ns => getsolution(subcomponent_idx)

    ! execute the nth iteration
    iterationcounter = iterationcounter + 1
    call ns%solve(iterationcounter)

    ! the following check is equivalent to that in NumericalSolution%sln_ca
    if (ns%icnvg == 1) then
      has_converged = 1
    else
      has_converged = 0
    end if

    bmi_status = bmi_success

  end function xmi_solve

  function xmi_finalize_solve(subcomponent_idx) result(bmi_status) bind(C, name="finalize_solve")
  !DEC$ ATTRIBUTES DLLEXPORT :: xmi_finalize_solve
    use numericalsolutionmodule
    integer(kind=c_int), intent(in) :: subcomponent_idx
        integer(kind=c_int) :: bmi_status
    ! local
    class(numericalsolutiontype), pointer :: ns
    integer(I4B) :: hasconverged

    ! get the numerical solution we are running
    ns => getsolution(subcomponent_idx)

    ! hasConverged is equivalent to the isgcnvg variable which is initialized to 1,
    ! see the body of the picard loop in SolutionGroupType%sgp_ca
    hasconverged = 1

    ! finish up
    call ns%finalizeSolve(iterationcounter, hasconverged, 0)

    ! check convergence on solution
    if (hasconverged == 1) then
      bmi_status = bmi_success
    else
      bmi_status = bmi_failure
    end if

    ! clear this for safety
    deallocate(iterationcounter)

  end function xmi_finalize_solve

  function get_var_address(c_component_name, c_subcomponent_name, &
                          c_var_name, c_var_address) &
                          result(bmi_status) bind(c, name="get_var_address")
    !DEC$ ATTRIBUTES DLLEXPORT :: get_var_address
    use memoryhelpermodule, only: create_mem_path, create_mem_address
    use constantsmodule, only: lencomponentname, lenvarname, lenmempath, lenmemaddress
    character(kind=c_char), intent(in) :: c_component_name(*)
    character(kind=c_char), intent(in) :: c_subcomponent_name(*)
    character(kind=c_char), intent(in) :: c_var_name(*)
    character(kind=c_char), intent(out) :: c_var_address(bmi_lenvaraddress)
    integer(kind=c_int) :: bmi_status

    ! local
    character(len=LENCOMPONENTNAME) :: component_name
    character(len=LENCOMPONENTNAME) :: subcomponent_name
    character(len=LENVARNAME) :: variable_name
    character(len=LENMEMPATH) :: mem_path
    character(len=LENMEMADDRESS) :: mem_address

    ! convert to Fortran strings
    component_name = char_array_to_string(c_component_name, strlen(c_component_name))
    subcomponent_name = char_array_to_string(c_subcomponent_name, strlen(c_subcomponent_name))
    variable_name = char_array_to_string(c_var_name, strlen(c_var_name))

    ! create memory address
    if (subcomponent_name == '') then
      mem_path = create_mem_path(component_name)
    else
      mem_path = create_mem_path(component_name, subcomponent_name)
    end if
    mem_address = create_mem_address(mem_path, variable_name)

    ! convert to c string:
    c_var_address(1:len(trim(mem_address))+1) = string_to_char_array(trim(mem_address), len(trim(mem_address)))

    bmi_status = bmi_success

  end function get_var_address

end module mf6xmi