module DanielMain
  implicit none
  private
  
  type, public :: t_Daniel
    integer(INT_PTR_KIND()), private :: obj_units  ! Pointer to UI function
  contains
    final :: clean_sub
    procedure, public :: initialise => initialise_sub
    procedure, public :: array_test => array_test_sub
  end type t_Daniel

  ! Declare procedures.
  private :: initialise_sub
  private :: array_test_sub
  private :: MakeVariantSafeArray
  private :: GetVariantSafeArray
contains

! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************

! Release the pointers to the functions in the dll.
subroutine clean_sub(this)
  use ifcom, only : COMReleaseObject, COMUninitialize
  implicit none
  
  ! Declare variables in the argument list.
  type(t_Daniel), intent(inout) :: this

  ! Local variables
  integer(4) :: iresult
  
  if( this%obj_units == 0 )return

  iresult = COMReleaseObject(this%obj_units)
  call COMUninitialize()
  this%obj_units = 0

end subroutine clean_sub


! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************


! Initialise data. Also get pointer to functions from dll.
subroutine initialise_sub(this, error)
  use Daniel, only : CLSID_AnalysisDb, IID__AnalysisDb
  use ifwinty, only : CLSCTX_ALL, S_OK
  use ifcom, only : COMCreateObjectByGUID, COMInitialize 
  implicit none

  ! Declare variables in the argument list.
  class(t_Daniel) :: this
  logical, intent(out) :: error

  ! Local variables
  integer(4) :: status

  error = .true.
  call COMInitialize(status)
  
  ! Loading the dll through COM
  this%obj_units = 0
  call COMCreateObjectByGUID(CLSID_AnalysisDb,CLSCTX_ALL,IID__AnalysisDb,this%obj_units,status)

  ! Check for problems loading the dll through COM
  error = status /= S_OK

end subroutine initialise_sub


! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************

subroutine array_test_sub(this, error)
  use Daniel, only : $$AnalysisDb_ArrayTest
  use ifwinty, only : S_OK
  use IFCOMTY
  implicit none
  
  ! Variables passed as arguments
  class(t_Daniel) :: this
  logical, intent(out) :: error

  ! Local variables
  integer(4) :: iresult
  real(4), dimension(3), target :: a, b
  character(len=30) :: c
  integer(int_ptr_kind()) :: ptra, ptrb
  TYPE(VARIANT) :: VSAa, VSAb

  
  ! Initialise variables.
  continue
  ptra = loc(VSAa)
  ptrb = loc(VSAb)
  a = (/ 1.0, 2.0, 3.0 /)
  b = 2.0 * a
  c = " "
  
  call GetVariantSafeArray(a, VSAa)
  call GetVariantSafeArray(b, VSAb)
  
  ! Initialise
  error = .true.
  if( this%obj_units == 0 )return
    
  ! Call the DLL.
  iresult = $$AnalysisDb_ArrayTest(this%obj_units, VSAa%VU%PTR_VAL, VSAb%VU%PTR_VAL, c)
  
  error = iresult /= S_OK
end subroutine array_test_sub


! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************

subroutine MakeVariantSafeArray(VSA, FArr, ROWS)
  use IFCOMTY
  use IFCOM
  implicit none

  type(VARIANT), intent(out) :: VSA !Variant SafeArray
  integer, intent(in) :: ROWS
  real(4), dimension(ROWS), intent(in) :: FArr !Fortran Array
  type(VARIANT) :: TV !Temporary Variant
  integer(4) :: ret, indices(1), lbounds(1), ubounds(1), i
  type(sa_bounds) :: bounds(1)
  
  lbounds(1) = lbound(FArr,1)
  ubounds(1) = ubound(FArr,1)
  bounds(1)%lbound = lbounds(1)
  bounds(1)%extent = ubounds(1)
  VSA%VT = ior(VT_VARIANT, VT_SAFEARRAY)
  VSA%VU%PTR_VAL = SafeArrayCreate(VT_VARIANT, 1, bounds(1))
  
  call VariantInit(TV)
  TV%VT = VT_R4
  
  do i = lbounds(1), ubounds(1)
    indices(1) = i
    TV%VU%FLOAT_VAL = FArr(i)
    ret = SafeArrayPutElement(VSA%VU%PTR_VAL, indices(1), LOC(TV))
  end do

end subroutine MakeVariantSafeArray

! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************

subroutine GetVariantSafeArray(FortranArray, VariantSafeArray)
  use IFCOMTY
  implicit none

  real(4), dimension(:) :: FortranArray
  TYPE(VARIANT), intent(out) :: VariantSafeArray

  call MakeVariantSafeArray(VariantSafeArray, FortranArray, ubound(FortranArray,1))
end subroutine GetVariantSafeArray

! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************
! ****************************************************************************************

end module DanielMain