Program Listing for File mf6bmi.f90

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

module mf6bmi
  use mf6bmiutil
  use bmif, only: bmi_failure, bmi_success
  use mf6coremodule
  use tdismodule, only: kper, kstp
  use iso_c_binding, only: c_int, c_char, c_double, c_null_char, c_loc, c_ptr,   &
                           c_f_pointer
  use kindmodule, only: dp, i4b, lgp
  use constantsmodule, only: lenmempath, lenvarname, memreadwrite, memreadonly
  use memorymanagermodule, only: mem_setptr, get_mem_elem_size, get_isize,       &
                                 get_mem_rank, get_mem_shape, get_mem_type,      &
                                 memorylist, get_from_memorylist
  use memorytypemodule, only: memorytype
  use memoryhelpermodule, only: create_mem_address
  use simvariablesmodule, only: simstdout, istdout
  use inputoutputmodule, only: getunit
  implicit none

  integer(c_int), bind(c, name="ISTDOUTTOFILE") :: istdout_to_file = 1
  !DEC$ ATTRIBUTES DLLEXPORT :: istdout_to_file

  contains

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

    if (istdout_to_file > 0) then
      ! -- open stdout file mfsim.stdout
      istdout = getunit()
      !
      ! -- set STDOUT to a physical file unit
      open(unit=istdout, file=simstdout)
    end if
    !
    ! -- initialize MODFLOW 6
    call mf6initialize()

    bmi_status = bmi_success

  end function bmi_initialize


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

    hasconverged = mf6update()

    bmi_status = bmi_success
  end function bmi_update


  function bmi_finalize() result(bmi_status) bind(C, name="finalize")
  !DEC$ ATTRIBUTES DLLEXPORT :: bmi_finalize
    use simvariablesmodule, only: iforcestop
    integer(kind=c_int) :: bmi_status

    ! we don't want a full stop() here, this disables it:
    iforcestop = 0
    call mf6finalize()

    bmi_status = bmi_success

  end function bmi_finalize


  function get_start_time(start_time) result(bmi_status) bind(C, name="get_start_time")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_start_time
    double precision, intent(out) :: start_time
    integer(kind=c_int) :: bmi_status

    start_time = 0.0_dp
    bmi_status = bmi_success

  end function get_start_time


  function get_end_time(end_time) result(bmi_status) bind(C, name="get_end_time")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_end_time
    use tdismodule, only: totalsimtime
    double precision, intent(out) :: end_time
    integer(kind=c_int) :: bmi_status

    end_time = totalsimtime
    bmi_status = bmi_success

  end function get_end_time

  function get_current_time(current_time) result(bmi_status) bind(C, name="get_current_time")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_current_time
    use tdismodule, only: totim
    double precision, intent(out) :: current_time
    integer(kind=c_int) :: bmi_status

    current_time = totim
    bmi_status = bmi_success

  end function get_current_time


  function get_time_step(time_step) result(bmi_status) bind(C, name="get_time_step")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_time_step
    use tdismodule, only: delt
    double precision, intent(out) :: time_step
    integer(kind=c_int) :: bmi_status

    time_step = delt
    bmi_status = bmi_success

  end function get_time_step

  function get_input_item_count(count) result(bmi_status) bind(C, name="get_input_item_count")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_input_item_count
    integer(kind=c_int), intent(out) :: count
    integer(kind=c_int) :: bmi_status
    ! local
    integer(I4B) :: ipos
    type(memorytype), pointer :: mt => null()

    count = 0
    do ipos = 1, memorylist%count()
      mt => memorylist%Get(ipos)
      if (mt%memaccess == memreadwrite) then
        count = count + 1
      end if
    end do

    bmi_status = bmi_success

  end function get_input_item_count

  function get_output_item_count(count) result(bmi_status) bind(C, name="get_output_item_count")
    !DEC$ ATTRIBUTES DLLEXPORT :: get_output_item_count
      integer(kind=c_int), intent(out) :: count
      integer(kind=c_int) :: bmi_status
      ! local
      integer(I4B) :: ipos
      type(memorytype), pointer :: mt => null()

      count = 0
      do ipos = 1, memorylist%count()
        mt => memorylist%Get(ipos)
        if (mt%memaccess == memreadonly .or. mt%memaccess == memreadwrite) then
          count = count + 1
        end if
      end do

      bmi_status = bmi_success

    end function get_output_item_count

  function get_input_var_names(c_names) result(bmi_status) bind(C, name="get_input_var_names")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_input_var_names
    character(kind=c_char,len=1), intent(inout) :: c_names(*)
    integer(kind=c_int) :: bmi_status
    ! local
    integer(I4B) :: imem, start, i
    type(memorytype), pointer :: mt => null()
    character(len=LENMEMADDRESS) :: var_address

    start = 1
    do imem = 1, memorylist%count()
      mt => memorylist%Get(imem)
      if (mt%memaccess == memreadwrite) then
        var_address = create_mem_address(mt%path, mt%name)
        do i = 1, len(trim(var_address))
          c_names(start + i - 1) = var_address(i:i)
        end do
        c_names(start + i) = c_null_char
        start = start + bmi_lenvaraddress
      end if
    end do

    bmi_status = bmi_success

  end function get_input_var_names

  function get_output_var_names(c_names) result(bmi_status) bind(C, name="get_output_var_names")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_output_var_names
    character(kind=c_char,len=1), intent(inout) :: c_names(*)
    integer(kind=c_int) :: bmi_status
    ! local
    integer(I4B) :: imem, start, i
    type(memorytype), pointer :: mt => null()
    character(len=LENMEMADDRESS) :: var_address

    start = 1
    do imem = 1, memorylist%count()
      mt => memorylist%Get(imem)
      if (mt%memaccess == memreadonly .or. mt%memaccess == memreadwrite) then
        var_address = create_mem_address(mt%path, mt%name)
        do i = 1, len(trim(var_address))
          c_names(start + i - 1) = var_address(i:i)
        end do
        c_names(start + i) = c_null_char
        start = start + bmi_lenvaraddress
      end if
    end do

    bmi_status = bmi_success

  end function get_output_var_names


  function get_var_itemsize(c_var_address, var_size) result(bmi_status) bind(C, name="get_var_itemsize")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_var_itemsize
    character (kind=c_char), intent(in) :: c_var_address(*)
    integer, intent(out) :: var_size
    integer(kind=c_int) :: bmi_status
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name_only

    call split_address(c_var_address, mem_path, var_name_only)

    bmi_status = bmi_success
    call get_mem_elem_size(var_name_only, mem_path, var_size)
    if (var_size == -1) bmi_status = bmi_failure

  end function get_var_itemsize

  function get_var_nbytes(c_var_address, var_nbytes) result(bmi_status) bind(C, name="get_var_nbytes")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_var_nbytes
    character (kind=c_char), intent(in) :: c_var_address(*)
    integer, intent(out) :: var_nbytes
    integer(kind=c_int) :: bmi_status
    ! local
    integer(I4B) :: var_size, isize
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name

    call split_address(c_var_address, mem_path, var_name)

    bmi_status = bmi_success
    call get_mem_elem_size(var_name, mem_path, var_size)
    if (var_size == -1) bmi_status = bmi_failure
    call get_isize(var_name, mem_path, isize)
    if (isize == -1) bmi_status = bmi_failure

    var_nbytes = var_size*isize

  end function get_var_nbytes

  function get_value_double(c_var_address, c_arr_ptr) result(bmi_status) bind(C, name="get_value_double")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_value_double
    use memorysethandlermodule, only: on_memory_set
    character (kind=c_char), intent(in) :: c_var_address(*)
    type(c_ptr), intent(in) :: c_arr_ptr
    integer :: bmi_status
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name
    integer(I4B) :: access_type
    logical(LGP) :: found
    integer(I4B) :: rank
    real(DP), pointer :: src_ptr, tgt_ptr
    real(DP), dimension(:), pointer, contiguous :: src1d_ptr, tgt1d_ptr
    real(DP), dimension(:,:), pointer, contiguous :: src2d_ptr, tgt2d_ptr
    integer(I4B) :: i, j

    bmi_status = bmi_failure

    call split_address(c_var_address, mem_path, var_name)

    ! check access
    access_type = get_memory_access_type(mem_path, var_name, found)
    if (.not. found) then
      write(istdout,*) 'BMI Error: unknown variable '//var_name//' at '//mem_path
      return
    end if

    if (access_type /= memreadwrite .and. access_type /= memreadonly) then
      write(istdout,*) 'BMI Error: no read access for variable '//var_name
      return
    end if

    ! convert pointer and copy data from memory manager into
    ! the passed array, using loops to avoid stack overflow
    rank = -1
    call get_mem_rank(var_name, mem_path, rank)

    if (rank == 0) then
      call mem_setptr(src_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, tgt_ptr)
      tgt_ptr = src_ptr
    else if (rank == 1) then
      call mem_setptr(src1d_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, tgt1d_ptr, shape(src1d_ptr))
      do i = 1, size(tgt1d_ptr)
        tgt1d_ptr(i) = src1d_ptr(i)
      end do
    else if (rank == 2) then
      call mem_setptr(src2d_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, tgt2d_ptr, shape(src2d_ptr))
      do j = 1, size(tgt2d_ptr,2)
        do i = 1, size(tgt2d_ptr,1)
          tgt2d_ptr(i,j) = src2d_ptr(i,j)
        end do
      end do
    else
      write(istdout,*) 'BMI Error: unsupported rank for variable '//var_name
      return
    end if

    bmi_status = bmi_success

  end function get_value_double

  function get_value_int(c_var_address, c_arr_ptr) result(bmi_status) bind(C, name="get_value_int")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_value_int
    use memorysethandlermodule, only: on_memory_set
    character (kind=c_char), intent(in) :: c_var_address(*)
    type(c_ptr), intent(in) :: c_arr_ptr
    integer :: bmi_status
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name
    integer(I4B) :: access_type
    logical(LGP) :: found
    integer(I4B) :: rank
    integer(I4B), pointer :: src_ptr, tgt_ptr
    integer(I4B), dimension(:), pointer, contiguous :: src1d_ptr, tgt1d_ptr
    integer(I4B), dimension(:,:), pointer, contiguous :: src2d_ptr, tgt2d_ptr
    integer(I4B) :: i, j

    bmi_status = bmi_failure

    call split_address(c_var_address, mem_path, var_name)

    ! check access
    access_type = get_memory_access_type(mem_path, var_name, found)
    if (.not. found) then
      write(istdout,*) 'BMI Error: unknown variable '//var_name//' at '//mem_path
      return
    end if

    if (access_type /= memreadwrite .and. access_type /= memreadonly) then
      write(istdout,*) 'BMI Error: no read access for variable '//var_name
      return
    end if

    ! convert pointer and copy data from memory manager into
    ! the passed array, using loops to avoid stack overflow
    rank = -1
    call get_mem_rank(var_name, mem_path, rank)

    if (rank == 0) then
      call mem_setptr(src_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, tgt_ptr)
      tgt_ptr = src_ptr
    else if (rank == 1) then
      call mem_setptr(src1d_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, tgt1d_ptr, shape(src1d_ptr))
      do i = 1, size(tgt1d_ptr)
        tgt1d_ptr(i) = src1d_ptr(i)
      end do
    else if (rank == 2) then
      call mem_setptr(src2d_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, tgt2d_ptr, shape(src2d_ptr))
      do j = 1, size(tgt2d_ptr,2)
        do i = 1, size(tgt2d_ptr,1)
          tgt2d_ptr(i,j) = src2d_ptr(i,j)
        end do
      end do
    else
      write(istdout,*) 'BMI Error: unsupported rank for variable '//var_name
      return
    end if

    bmi_status = bmi_success

  end function get_value_int

  function get_value_ptr_double(c_var_address, c_arr_ptr) result(bmi_status) bind(C, name="get_value_ptr_double")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_value_ptr_double
    character (kind=c_char), intent(in) :: c_var_address(*)
    type(c_ptr), intent(inout) :: c_arr_ptr
    integer(kind=c_int) :: bmi_status
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name
    integer(I4B) :: access_type
    logical(LGP) :: found
    real(DP), pointer :: scalar_ptr
    real(DP), dimension(:), pointer, contiguous :: array_ptr
    real(DP), dimension(:,:), pointer, contiguous :: array2d_ptr
    integer(I4B) :: rank

    bmi_status = bmi_failure

    call split_address(c_var_address, mem_path, var_name)

    ! check access
    access_type = get_memory_access_type(mem_path, var_name, found)
    if (.not. found) then
      write(istdout,*) 'BMI Error: unknown variable '//var_name//' at '//mem_path
      return
    end if

    if (access_type /= memreadwrite .and. access_type /= memreadonly) then
      write(istdout,*) 'BMI Error: no read access for variable '//var_name
      return
    end if

    rank = -1
    call get_mem_rank(var_name, mem_path, rank)
    if (rank == 0) then
      call mem_setptr(scalar_ptr, var_name, mem_path)
      c_arr_ptr = c_loc(scalar_ptr)
    else if (rank == 1) then
      call mem_setptr(array_ptr, var_name, mem_path)
      c_arr_ptr = c_loc(array_ptr)
    else if (rank == 2) then
      call mem_setptr(array2d_ptr, var_name, mem_path)
      c_arr_ptr = c_loc(array2d_ptr)
    else
      write(istdout,*) 'BMI Error: unsupported rank for variable '//var_name
      return
    end if

    bmi_status = bmi_success

  end function get_value_ptr_double


  function get_value_ptr_int(c_var_address, c_arr_ptr) result(bmi_status) bind(C, name="get_value_ptr_int")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_value_ptr_int
    character (kind=c_char), intent(in) :: c_var_address(*)
    type(c_ptr), intent(inout) :: c_arr_ptr
    integer(kind=c_int) :: bmi_status
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name
    integer(I4B) :: access_type
    logical(LGP) :: found
    integer(I4B) :: rank
    integer(I4B), pointer :: scalar_ptr
    integer(I4B), dimension(:), pointer, contiguous :: array_ptr
    integer(I4B), dimension(:,:), pointer, contiguous :: array2d_ptr

    bmi_status = bmi_failure

    call split_address(c_var_address, mem_path, var_name)

    ! check access
    access_type = get_memory_access_type(mem_path, var_name, found)
    if (.not. found) then
      write(istdout,*) 'BMI Error: unknown variable '//var_name//' at '//mem_path
      return
    end if

    if (access_type /= memreadwrite .and. access_type /= memreadonly) then
      write(istdout,*) 'BMI Error: no read access for variable '//var_name
      return
    end if

    rank = -1
    call get_mem_rank(var_name, mem_path, rank)

    if (rank == 0) then
      call mem_setptr(scalar_ptr, var_name, mem_path)
      c_arr_ptr = c_loc(scalar_ptr)
    else if (rank == 1) then
      call mem_setptr(array_ptr, var_name, mem_path)
      c_arr_ptr = c_loc(array_ptr)
    else if (rank == 2) then
      call mem_setptr(array_ptr, var_name, mem_path)
      c_arr_ptr = c_loc(array2d_ptr)
    else
      write(istdout,*) 'BMI Error: unsupported rank for variable '//var_name
      return
    end if

    bmi_status = bmi_success

  end function get_value_ptr_int

  function set_value_double(c_var_address, c_arr_ptr) result(bmi_status) bind(C, name="set_value_double")
  !DEC$ ATTRIBUTES DLLEXPORT :: set_value_double
    use memorysethandlermodule, only: on_memory_set
    character (kind=c_char), intent(in) :: c_var_address(*)
    type(c_ptr), intent(in) :: c_arr_ptr
    integer :: bmi_status
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name
    integer(I4B) :: access_type
    logical(LGP) :: found
    integer(I4B) :: rank
    real(DP), pointer :: src_ptr, tgt_ptr
    real(DP), dimension(:), pointer, contiguous :: src1d_ptr, tgt1d_ptr
    real(DP), dimension(:,:), pointer, contiguous :: src2d_ptr, tgt2d_ptr
    integer(I4B) :: i, j
    integer(I4B) :: status

    bmi_status = bmi_failure

    call split_address(c_var_address, mem_path, var_name)

    ! check access
    access_type = get_memory_access_type(mem_path, var_name, found)
    if (.not. found) then
      write(istdout,*) 'BMI Error: unknown variable '//var_name//' at '//mem_path
      return
    end if

    if (access_type /= memreadwrite) then
      write(istdout,*) 'BMI Error: cannot write to variable '//var_name
      return
    end if

    ! convert pointer and copy, using loops to avoid stack overflow
    rank = -1
    call get_mem_rank(var_name, mem_path, rank)

    if (rank == 0) then
      call mem_setptr(tgt_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, src_ptr)
      tgt_ptr = src_ptr
    else if (rank == 1) then
      call mem_setptr(tgt1d_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, src1d_ptr, shape(tgt1d_ptr))
      do i = 1, size(tgt1d_ptr)
        tgt1d_ptr(i) = src1d_ptr(i)
      end do
    else if (rank == 2) then
      call mem_setptr(tgt2d_ptr, var_name, mem_path)
      call c_f_pointer(c_arr_ptr, src2d_ptr, shape(tgt2d_ptr))
      do j = 1, size(tgt2d_ptr,2)
        do i = 1, size(tgt2d_ptr,1)
          tgt2d_ptr(i,j) = src2d_ptr(i,j)
        end do
      end do
    else
      write(istdout,*) 'BMI Error: unsupported rank for variable '//var_name
      return
    end if

    ! trigger event:
    call on_memory_set(var_name, mem_path, status)
    if (status /= 0) then
      ! something went terribly wrong here, aborting
      write(istdout,*) 'Fatal BMI Error: invalid writing of memory for variable '//var_name
      return
    end if

    bmi_status = bmi_success

  end function set_value_double

  function set_value_int(c_var_address, c_arr_ptr) result(bmi_status) bind(C, name="set_value_int")
    !DEC$ ATTRIBUTES DLLEXPORT :: set_value_int
      use memorysethandlermodule, only: on_memory_set
      character (kind=c_char), intent(in) :: c_var_address(*)
      type(c_ptr), intent(in) :: c_arr_ptr
      integer :: bmi_status
      ! local
      character(len=LENMEMPATH) :: mem_path
      character(len=LENVARNAME) :: var_name
      integer(I4B) :: access_type
      logical(LGP) :: found
      integer(I4B) :: rank
      integer(I4B), pointer :: src_ptr, tgt_ptr
      integer(I4B), dimension(:), pointer, contiguous :: src1d_ptr, tgt1d_ptr
      integer(I4B), dimension(:,:), pointer, contiguous :: src2d_ptr, tgt2d_ptr
      integer(I4B) :: i, j
      integer(I4B) :: status

      bmi_status = bmi_failure

      call split_address(c_var_address, mem_path, var_name)

      ! check access
      access_type = get_memory_access_type(mem_path, var_name, found)
      if (.not. found) then
        write(istdout,*) 'BMI Error: unknown variable '//var_name//' at '//mem_path
        return
      end if

      if (access_type /= memreadwrite) then
        write(istdout,*) 'BMI Error: cannot write to variable '//var_name
        return
      end if

      ! convert pointer and copy, using loops to avoid stack overflow
      rank = -1
      call get_mem_rank(var_name, mem_path, rank)

      if (rank == 0) then
        call mem_setptr(tgt_ptr, var_name, mem_path)
        call c_f_pointer(c_arr_ptr, src_ptr)
        tgt_ptr = src_ptr
      else if (rank == 1) then
        call mem_setptr(tgt1d_ptr, var_name, mem_path)
        call c_f_pointer(c_arr_ptr, src1d_ptr, shape(tgt1d_ptr))
        do i = 1, size(tgt1d_ptr)
          tgt1d_ptr(i) = src1d_ptr(i)
        end do
      else if (rank == 2) then
        call mem_setptr(tgt2d_ptr, var_name, mem_path)
        call c_f_pointer(c_arr_ptr, src2d_ptr, shape(tgt2d_ptr))
        do j = 1, size(tgt2d_ptr,2)
          do i = 1, size(tgt2d_ptr,1)
            tgt2d_ptr(i,j) = src2d_ptr(i,j)
          end do
        end do
      else
        write(istdout,*) 'BMI Error: unsupported rank for variable '//var_name
        return
      end if

      ! trigger event:
      call on_memory_set(var_name, mem_path, status)
      if (status /= 0) then
        ! something went terribly wrong here, aborting
        write(istdout,*) 'Fatal BMI Error: invalid writing of memory for variable '//var_name
        return
      end if

      bmi_status = bmi_success

    end function set_value_int

  function get_var_type(c_var_address, c_var_type) result(bmi_status) bind(C, name="get_var_type")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_var_type
    use constantsmodule, only: lenmemtype
    character (kind=c_char), intent(in) :: c_var_address(*)
    character (kind=c_char), intent(out) :: c_var_type(bmi_lenvartype)
    integer(kind=c_int) :: bmi_status
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name
    character(len=LENMEMTYPE) :: mem_type

    call split_address(c_var_address, mem_path, var_name)

    bmi_status = bmi_success
    call get_mem_type(var_name, mem_path, mem_type)
    c_var_type(1:len(trim(mem_type))+1) = string_to_char_array(trim(mem_type), len(trim(mem_type)))

    if (mem_type == 'UNKNOWN') then
      bmi_status = bmi_failure
    end if

  end function get_var_type

  function get_var_rank(c_var_address, c_var_rank) result(bmi_status) bind(C, name="get_var_rank")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_var_rank
    character (kind=c_char), intent(in) :: c_var_address(*)
    integer(kind=c_int), intent(out) :: c_var_rank
    integer(kind=c_int) :: bmi_status
    ! local
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name

    call split_address(c_var_address, mem_path, var_name)

    call get_mem_rank(var_name, mem_path, c_var_rank)
    if (c_var_rank == -1) then
        bmi_status = bmi_failure
        return
    end if

    bmi_status = bmi_success

  end function get_var_rank


  function get_var_shape(c_var_address, c_var_shape) result(bmi_status) bind(C, name="get_var_shape")
  !DEC$ ATTRIBUTES DLLEXPORT :: get_var_shape
    use constantsmodule, only: maxmemrank
    character (kind=c_char), intent(in) :: c_var_address(*)
    integer(c_int), intent(inout) :: c_var_shape(*)
    integer(kind=c_int) :: bmi_status
    ! local
    integer(I4B), dimension(MAXMEMRANK) :: var_shape
    integer(I4B) :: var_rank
    character(len=LENMEMPATH) :: mem_path
    character(len=LENVARNAME) :: var_name

    call split_address(c_var_address, mem_path, var_name)

    var_shape = 0
    var_rank = 0
    call get_mem_rank(var_name, mem_path, var_rank)
    call get_mem_shape(var_name, mem_path, var_shape)
    if (var_shape(1) == -1 .or. var_rank == -1) then
      bmi_status = bmi_failure
      return
    end if

    ! External calls to this BMI are assumed C style, so if the internal shape
    ! is (100,1) we get (100,1,undef) from the call get_mem_shape
    ! This we need to convert to C-style which should be (1,100).
    ! Hence, we reverse the array and drop undef:
    c_var_shape(1:var_rank) = var_shape(var_rank:1:-1)

    bmi_status = bmi_success

  end function get_var_shape

end module mf6bmi