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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
! { dg-do run }
!
! class based quick sort program - starting point comment #0 of pr41539
!
! Note assignment with vector index reference fails because temporary
! allocation does not occur - also false dependency detected. Nullification
! of temp descriptor data causes a segfault.
!
module m_qsort
implicit none
type, abstract :: sort_t
contains
procedure(disp), deferred :: disp
procedure(lt_cmp), deferred :: lt_cmp
procedure(assign), deferred :: assign
generic :: operator(<) => lt_cmp
generic :: assignment(=) => assign
end type sort_t
interface
elemental integer function disp(a)
import
class(sort_t), intent(in) :: a
end function disp
end interface
interface
impure elemental logical function lt_cmp(a,b)
import
class(sort_t), intent(in) :: a, b
end function lt_cmp
end interface
interface
impure elemental subroutine assign(a,b)
import
class(sort_t), intent(out) :: a
class(sort_t), intent(in) :: b
end subroutine assign
end interface
contains
subroutine qsort(a)
class(sort_t), intent(inout),allocatable :: a(:)
class(sort_t), allocatable :: tmp (:)
integer, allocatable :: index_array (:)
integer :: i
allocate (tmp(size (a, 1)), source = a)
index_array = [(i, i = 1, size (a, 1))]
call internal_qsort (tmp, index_array) ! Do not move class elements around until end
a = tmp(index_array)
end subroutine qsort
recursive subroutine internal_qsort (x, iarray)
class(sort_t), intent(inout),allocatable :: x(:)
class(sort_t), allocatable :: ptr
integer, allocatable :: iarray(:), above(:), below(:), itmp(:)
integer :: pivot, nelem, i, iptr
if (.not.allocated (iarray)) return
nelem = size (iarray, 1)
if (nelem .le. 1) return
pivot = nelem / 2
allocate (ptr, source = x(iarray(pivot))) ! Pointer to the pivot element
do i = 1, nelem
iptr = iarray(i) ! Index for i'th element
if (ptr%lt_cmp (x(iptr))) then ! Compare pivot with i'th element
itmp = [iptr]
above = concat (itmp, above) ! Invert order to prevent infinite loops
else
itmp = [iptr]
below = concat (itmp, below) ! -ditto-
end if
end do
call internal_qsort (x, above) ! Recursive sort of 'above' and 'below'
call internal_qsort (x, below)
iarray = concat (below, above) ! Concatenate the result
end subroutine internal_qsort
function concat (ia, ib) result (ic)
integer, allocatable, dimension(:) :: ia, ib, ic
if (allocated (ia) .and. allocated (ib)) then
ic = [ia, ib]
else if (allocated (ia)) then
ic = ia
else if (allocated (ib)) then
ic = ib
end if
end function concat
end module m_qsort
module test
use m_qsort
implicit none
type, extends(sort_t) :: sort_int_t
integer :: i
contains
procedure :: disp => disp_int
procedure :: lt_cmp => lt_cmp_int
procedure :: assign => assign_int
end type
contains
elemental integer function disp_int(a)
class(sort_int_t), intent(in) :: a
disp_int = a%i
end function disp_int
impure elemental subroutine assign_int (a, b)
class(sort_int_t), intent(out) :: a
class(sort_t), intent(in) :: b ! TODO: gfortran does not throw 'class(sort_int_t)'
select type (b)
class is (sort_int_t)
a%i = b%i
class default
a%i = -1
end select
end subroutine assign_int
impure elemental logical function lt_cmp_int(a,b) result(cmp)
class(sort_int_t), intent(in) :: a
class(sort_t), intent(in) :: b
select type(b)
type is(sort_int_t)
if (a%i < b%i) then
cmp = .true.
else
cmp = .false.
end if
class default
ERROR STOP "Don't compare apples with oranges"
end select
end function lt_cmp_int
end module test
program main
use test
class(sort_t), allocatable :: A(:)
integer :: i, m(5)= [7 , 4, 5, 2, 3]
allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)])
! print *, "Before qsort: ", A%disp()
call qsort(A)
! print *, "After qsort: ", A%disp()
if (any (A%disp() .ne. [2,3,4,5,7])) STOP 1
end program main
|
