[Fortran] 纯文本查看 复制代码
module sorting_example_mod
use iso_c_binding
implicit none
interface
subroutine qsort_C(array, elem_count, elem_size, comparison_fun) bind(C,name="qsort")
use iso_c_binding, only: c_ptr, c_funptr,c_int
implicit none
type(c_ptr), value :: array
integer(c_int), value :: elem_count
integer(c_int), value :: elem_size
type(c_funptr), value :: comparison_fun
end subroutine qsort_C
end interface
contains
! user defined compare function
integer(c_int) function compare_real8(s1, s2) bind(C)result(flag)
type(c_ptr), value :: s1, s2
real(kind=8), pointer :: t1, t2
call c_f_pointer(s1, t1)
call c_f_pointer(s2, t2)
if(t1 < t2) flag = -1_c_int
if(abs(t1-t2)<epsilon(1.d0)) flag = 0_c_int
if(t1 > t2) flag = 1_c_int
end function compare_real8
integer(c_int) function compare_int(s1, s2) bind(C)result(flag)
type(c_ptr), value :: s1, s2
integer, pointer :: t1, t2
call c_f_pointer(s1, t1)
call c_f_pointer(s2, t2)
if(t1 < t2) flag = -1_c_int
if(t1 == t2) flag = 0_c_int
if(t1 > t2) flag = 1_c_int
end function compare_int
end module sorting_example_mod
program test_qsort
use iso_c_binding
use sorting_example_mod
real(kind=8),target::a(5)
integer,target::b(5)=[1,3,4,2,5]
call random_number(a)
call qsort_C(c_loc(a(1)), &
elem_count = 5, &
elem_size = 8, &
comparison_fun = c_funloc(compare_real8))
write(*,*)a
call qsort_C(c_loc(b(1)), &
elem_count = 5, &
elem_size = 4, &
comparison_fun = c_funloc(compare_int))
write(*,*)b
end program test_qsort