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
113
114
115
116
117
118
119
120
|
module template_sort_01_type
implicit none
public :: my_type, my_type_lt
type my_type
real :: d
end type
contains
pure elemental function lt_my_type(lhs, rhs) result(res)
type(my_type), intent(in) :: lhs, rhs
logical :: res
res = lhs%d < rhs%d
end function
end module
module template_sort_01_m
use template_sort_01_type
implicit none
private
public :: sort_t
requirement op_r(T, U, V, op_func)
type, deferred :: T
type, deferred :: U
type, deferred :: V
pure elemental function op_func(lhs, rhs) result(res)
type(T), intent(in) :: lhs
type(T), intent(in) :: rhs
type(V) :: res
end function
end requirement
template qsort_t(T, lt)
require :: op_r(T, T, logical, lt)
private
public :: qsort
contains
subroutine swp(lhs, rhs)
type(T), intent(inout) :: lhs
type(T), intent(inout) :: rhs
type(T) :: tmp
tmp = lhs
lhs = rhs
rhs = tmp
end subroutine
recursive subroutine qs(arr, low, high)
type(T), intent(inout) :: arr(:)
integer, intent(in) :: low, high
integer :: i, last
type(T) :: pivot
if (low < high) then
pivot = arr(high)
last = low - 1
do i = low, high - 1
if (lt(arr(i), pivot)) then
last = last + 1
call swp(arr(last), arr(i))
end if
end do
call swp(arr(last + 1), arr(high))
call qs(arr, low, last)
call qs(arr, last + 2, high)
end if
end subroutine
end template
contains
pure elemental function lt_real(lhs, rhs) result(res)
real, intent(in) :: lhs
real, intent(in) :: rhs
logical :: res
res = lhs < rhs
end function
pure elemental function lt_integer(lhs, rhs) result(res)
integer, intent(in) :: lhs
integer, intent(in) :: rhs
logical :: res
res = lhs < rhs
end function
subroutine test_template()
integer :: xi(10), i
real :: xr(10)
type(my_type) :: xm(10)
instantiate qsort_t(integer, lt_integer), only: qsort_integer => qs
instantiate qsort_t(real, lt_real), only: qsort_real => qs
instantiate qsort_t(my_type, lt_my_type), only: qsort_my_type => qs
xi = [2,4,1,5,6,24,51,3,42,2]
xr = [2,4,1,5,6,24,51,3,42,2]
do i = 1, 10
xm(i) = my_type(xr(i))
end do
call qsort_integer(xi, 1, 10)
call qsort_real(xr, 1, 10)
call qsort_my_type(xm, 1, 10)
print *, xi
print *, xr
print *, xm
end subroutine
end module
program template_sort_01
use template_sort_01_m
call test_template()
end program
|
