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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
! { dg-do run }
!
! Check the fix for PR67779, in which array sections passed in the
! recursive calls to 'quicksort' had an incorrect offset.
!
! Contributed by Arjen Markus <arjen.markus895@gmail.com>
!
! NOTE: This is the version of the testcase in comment #16 (from Thomas Koenig)
!
module myclass_def
implicit none
type, abstract :: myclass
contains
procedure(assign_object), deferred :: copy
procedure(one_lower_than_two), deferred :: lower
procedure(print_object), deferred :: print
procedure, nopass :: quicksort ! without nopass, it does not work
end type myclass
abstract interface
subroutine assign_object( left, right )
import :: myclass
class(myclass), intent(inout) :: left
class(myclass), intent(in) :: right
end subroutine assign_object
end interface
abstract interface
logical function one_lower_than_two( op1, op2 )
import :: myclass
class(myclass), intent(in) :: op1, op2
end function one_lower_than_two
end interface
abstract interface
subroutine print_object( obj )
import :: myclass
class(myclass), intent(in) :: obj
end subroutine print_object
end interface
!
! Type containing a real
!
type, extends(myclass) :: mysortable
integer :: value
contains
procedure :: copy => copy_sortable
procedure :: lower => lower_sortable
procedure :: print => print_sortable
end type mysortable
contains
!
! Generic part
!
recursive subroutine quicksort( array )
class(myclass), dimension(:) :: array
class(myclass), allocatable :: v, tmp
integer :: i, j
integer :: k
i = 1
j = size(array)
allocate( v, source = array(1) )
allocate( tmp, source = array(1) )
call v%copy( array((j+i)/2) ) ! Use the middle element
do
do while ( array(i)%lower(v) )
i = i + 1
enddo
do while ( v%lower(array(j)) )
j = j - 1
enddo
if ( i <= j ) then
call tmp%copy( array(i) )
call array(i)%copy( array(j) )
call array(j)%copy( tmp )
i = i + 1
j = j - 1
endif
if ( i > j ) then
exit
endif
enddo
if ( 1 < j ) then
call quicksort( array(1:j) ) ! Problem here
endif
if ( i < size(array) ) then
call quicksort( array(i:) ) ! ....and here
endif
end subroutine quicksort
!
! Specific part
!
subroutine copy_sortable( left, right )
class(mysortable), intent(inout) :: left
class(myclass), intent(in) :: right
select type (right)
type is (mysortable)
select type (left)
type is (mysortable)
left = right
end select
end select
end subroutine copy_sortable
logical function lower_sortable( op1, op2 )
class(mysortable), intent(in) :: op1
class(myclass), intent(in) :: op2
select type (op2)
type is (mysortable)
lower_sortable = op1%value < op2%value
end select
end function lower_sortable
subroutine print_sortable( obj )
class(mysortable), intent(in) :: obj
write(*,'(G0," ")', advance="no") obj%value
end subroutine print_sortable
end module myclass_def
! test program
program test_quicksort
use myclass_def
implicit none
type(mysortable), dimension(20) :: array
real, dimension(20) :: values
call random_number(values)
array%value = int (1000000 * values)
! It would be pretty perverse if this failed!
if (check (array)) STOP 1
call quicksort( array )
! Check the array is correctly ordered
if (.not.check (array)) STOP 2
contains
logical function check (arg)
type(mysortable), dimension(:) :: arg
integer :: s
s = size (arg, 1)
check = all (arg(2 : s)%value .ge. arg(1 : s - 1)%value)
end function check
end program test_quicksort
|
