module mod_sort
  use fgsl
  use mod_unit
  use, intrinsic :: iso_c_binding
  implicit none
  integer(fgsl_size_t), parameter :: dim = 40
  real(fgsl_double), parameter :: eps10=1.0d-10
  type(c_ptr) :: array_ptr
  real(c_double), dimension(dim), target :: array, t_array
  integer(fgsl_size_t), dimension(dim) :: p_array
  integer(fgsl_long), dimension(dim) :: i_array
contains
  function compare(x, y) bind(c)
    use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_double
    type(c_ptr), value :: x, y
    integer(c_int) :: compare
!
    real(c_double), pointer :: rx, ry
    call c_f_pointer(x, rx); call c_f_pointer(y, ry)
    compare = 0 ;  if (rx < ry) compare = -1
  end function compare
end module mod_sort
program sort
  use mod_sort
  implicit none
  type(fgsl_error_handler_t) :: std
  integer :: i, status
!
! Test sorting routines
!
  call unit_init(200)
  std = fgsl_set_error_handler_off()
  array = (/(dble(i),i=40,1,-1)/)
  array_ptr = c_loc(array)
  call fgsl_heapsort(array_ptr,dim,fgsl_sizeof(1.0d0),compare)
  call unit_assert_equal_within('fgsl_heapsort',(/(dble(i),i=1,40)/),array,eps10)
  array = (/(dble(i),i=40,1,-1)/)
  status = fgsl_heapsort_index(p_array,array_ptr,dim,fgsl_sizeof(1.0d0),compare)
  call unit_assert_equal('fgsl_heapsort_index_status',fgsl_success,status)
! NOTE: results use zero base!
  call unit_assert_equal('fgsl_heapsort_index',(/(i,i=39,0,-1)/),int(p_array))
  array = (/(dble(i),i=40,1,-1)/)
  call fgsl_sort(array,1_fgsl_size_t,dim)
  call unit_assert_equal_within('fgsl_heapsort',(/(dble(i),i=1,40)/),array,eps10)
  p_array = (/(dble(i),i=40,1,-1)/)
  call fgsl_sort(p_array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort',(/(i,i=1,40)/),int(p_array))
  array = (/(dble(i),i=40,1,-1)/)
  call fgsl_sort_index(p_array,array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_index',(/(i,i=39,0,-1)/),int(p_array))
  i_array = (/(i,i=40,1,-1)/)
  call fgsl_sort_index(p_array,i_array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_index',(/(i,i=39,0,-1)/),int(p_array))
  array = (/(dble(i),i=40,1,-1)/)
  status = fgsl_sort_smallest(t_array,dim,array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_smallest:status',fgsl_success,status)
  call unit_assert_equal_within('fgsl_sort_smallest',&
       (/(dble(i),i=1,40)/),t_array,eps10)
  i_array = (/(i,i=40,1,-1)/)
  status = fgsl_sort_smallest(p_array,dim,i_array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_smallest:status',fgsl_success,status)
  call unit_assert_equal('fgsl_sort_smallest',(/(i,i=1,40)/),int(p_array))
  array = (/(dble(i),i=40,1,-1)/)
  status = fgsl_sort_smallest_index(p_array,dim,array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_smallest_index',(/(i,i=39,0,-1)/),int(p_array))
  i_array = (/(i,i=40,1,-1)/)
  status = fgsl_sort_smallest_index(p_array,dim,i_array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_smallest_index',(/(i,i=39,0,-1)/),int(p_array))
  array = (/(dble(i),i=40,1,-1)/)
  status = fgsl_sort_largest(t_array,dim,array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_largest:status',fgsl_success,status)
  call unit_assert_equal_within('fgsl_sort_largest',&
       (/(dble(i),i=40,1,-1)/),t_array,eps10)
  i_array = (/(i,i=40,1,-1)/)
  status = fgsl_sort_largest(p_array,dim,i_array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_largest:status',fgsl_success,status)
  call unit_assert_equal('fgsl_sort_largest',(/(i,i=40,1,-1)/),int(p_array))
  array = (/(dble(i),i=40,1,-1)/)
  status = fgsl_sort_largest_index(p_array,dim,array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_largest_index',(/(i,i=0,39)/),int(p_array))
  i_array = (/(i,i=40,1,-1)/)
  status = fgsl_sort_largest_index(p_array,dim,i_array,1_fgsl_size_t,dim)
  call unit_assert_equal('fgsl_sort_largest_index',(/(i,i=0,39)/),int(p_array))
!
! Done
!
  call unit_finalize()  
end program sort
