1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
module tomlf_utils_sort
implicit none
type :: toml_key
character(len=:), allocatable :: key
end type toml_key
interface sort
module procedure :: sort_keys
end interface
abstract interface
pure function compare_less(lhs, rhs) result(less)
import :: toml_key
type(toml_key), intent (in) :: lhs
type(toml_key), intent (in) :: rhs
logical :: less
end function compare_less
end interface
contains
pure subroutine sort_keys(list, idx, compare)
type(toml_key), intent(inout) :: list(:)
integer, intent(out), optional :: idx(:)
procedure(compare_less), optional :: compare
integer :: low, high, i
type(toml_key), allocatable :: sorted(:)
integer, allocatable :: indexarray(:)
low = 1
high = size(list)
sorted = list
allocate(indexarray(high), source=[(i, i=low, high)])
if (present(compare)) then
call quicksort(sorted, indexarray, low, high, compare)
else
call quicksort(sorted, indexarray, low, high, compare_keys_less)
end if
do i = low, high
list(i) = sorted(indexarray(i))
end do
if (present(idx)) then
idx = indexarray
end if
end subroutine sort_keys
pure recursive subroutine quicksort(list, idx, low, high, less)
type(toml_key), intent(inout) :: list(:)
integer, intent(inout) :: idx(:)
integer, intent(in) :: low, high
procedure(compare_less) :: less
integer :: i, last
integer :: pivot
if (low < high) then
call swap(idx(low), idx((low + high)/2))
last = low
do i = low + 1, high
if (less(list(idx(i)), list(idx(low)))) then
last = last + 1
call swap(idx(last), idx(i))
end if
end do
call swap(idx(low), idx(last))
pivot = last
call quicksort(list, idx, low, pivot - 1, less)
call quicksort(list, idx, pivot + 1, high, less)
end if
end subroutine quicksort
pure subroutine swap(lhs, rhs)
integer, intent(inout) :: lhs
integer, intent(inout) :: rhs
integer :: tmp
tmp = lhs
lhs = rhs
rhs = tmp
end subroutine swap
pure function compare_keys_less(lhs, rhs) result(less)
type(toml_key), intent (in) :: lhs
type(toml_key), intent (in) :: rhs
logical :: less
less = lhs%key < rhs%key
end function compare_keys_less
end module tomlf_utils_sort
program functions_16
print *, "running functions_16 program"
end program
|
