| 1 |
694 |
jeremybenn |
! { dg-do run }
|
| 2 |
|
|
!
|
| 3 |
|
|
! class based quick sort program - starting point comment #0 of pr41539
|
| 4 |
|
|
!
|
| 5 |
|
|
! Note assignment with vector index reference fails because temporary
|
| 6 |
|
|
! allocation does not occur - also false dependency detected. Nullification
|
| 7 |
|
|
! of temp descriptor data causes a segfault.
|
| 8 |
|
|
!
|
| 9 |
|
|
module m_qsort
|
| 10 |
|
|
implicit none
|
| 11 |
|
|
type, abstract :: sort_t
|
| 12 |
|
|
contains
|
| 13 |
|
|
procedure(disp), deferred :: disp
|
| 14 |
|
|
procedure(lt_cmp), deferred :: lt_cmp
|
| 15 |
|
|
procedure(assign), deferred :: assign
|
| 16 |
|
|
generic :: operator(<) => lt_cmp
|
| 17 |
|
|
generic :: assignment(=) => assign
|
| 18 |
|
|
end type sort_t
|
| 19 |
|
|
interface
|
| 20 |
|
|
elemental integer function disp(a)
|
| 21 |
|
|
import
|
| 22 |
|
|
class(sort_t), intent(in) :: a
|
| 23 |
|
|
end function disp
|
| 24 |
|
|
end interface
|
| 25 |
|
|
interface
|
| 26 |
|
|
impure elemental logical function lt_cmp(a,b)
|
| 27 |
|
|
import
|
| 28 |
|
|
class(sort_t), intent(in) :: a, b
|
| 29 |
|
|
end function lt_cmp
|
| 30 |
|
|
end interface
|
| 31 |
|
|
interface
|
| 32 |
|
|
elemental subroutine assign(a,b)
|
| 33 |
|
|
import
|
| 34 |
|
|
class(sort_t), intent(out) :: a
|
| 35 |
|
|
class(sort_t), intent(in) :: b
|
| 36 |
|
|
end subroutine assign
|
| 37 |
|
|
end interface
|
| 38 |
|
|
contains
|
| 39 |
|
|
|
| 40 |
|
|
subroutine qsort(a)
|
| 41 |
|
|
class(sort_t), intent(inout),allocatable :: a(:)
|
| 42 |
|
|
class(sort_t), allocatable :: tmp (:)
|
| 43 |
|
|
integer, allocatable :: index_array (:)
|
| 44 |
|
|
integer :: i
|
| 45 |
|
|
allocate (tmp(size (a, 1)), source = a)
|
| 46 |
|
|
index_array = [(i, i = 1, size (a, 1))]
|
| 47 |
|
|
call internal_qsort (tmp, index_array) ! Do not move class elements around until end
|
| 48 |
|
|
a = tmp(index_array)
|
| 49 |
|
|
end subroutine qsort
|
| 50 |
|
|
|
| 51 |
|
|
recursive subroutine internal_qsort (x, iarray)
|
| 52 |
|
|
class(sort_t), intent(inout),allocatable :: x(:)
|
| 53 |
|
|
class(sort_t), allocatable :: ptr
|
| 54 |
|
|
integer, allocatable :: iarray(:), above(:), below(:), itmp(:)
|
| 55 |
|
|
integer :: pivot, nelem, i, iptr
|
| 56 |
|
|
if (.not.allocated (iarray)) return
|
| 57 |
|
|
nelem = size (iarray, 1)
|
| 58 |
|
|
if (nelem .le. 1) return
|
| 59 |
|
|
pivot = nelem / 2
|
| 60 |
|
|
allocate (ptr, source = x(iarray(pivot))) ! Pointer to the pivot element
|
| 61 |
|
|
do i = 1, nelem
|
| 62 |
|
|
iptr = iarray(i) ! Index for i'th element
|
| 63 |
|
|
if (ptr%lt_cmp (x(iptr))) then ! Compare pivot with i'th element
|
| 64 |
|
|
itmp = [iptr]
|
| 65 |
|
|
above = concat (itmp, above) ! Invert order to prevent infinite loops
|
| 66 |
|
|
else
|
| 67 |
|
|
itmp = [iptr]
|
| 68 |
|
|
below = concat (itmp, below) ! -ditto-
|
| 69 |
|
|
end if
|
| 70 |
|
|
end do
|
| 71 |
|
|
call internal_qsort (x, above) ! Recursive sort of 'above' and 'below'
|
| 72 |
|
|
call internal_qsort (x, below)
|
| 73 |
|
|
iarray = concat (below, above) ! Concatenate the result
|
| 74 |
|
|
end subroutine internal_qsort
|
| 75 |
|
|
|
| 76 |
|
|
function concat (ia, ib) result (ic)
|
| 77 |
|
|
integer, allocatable, dimension(:) :: ia, ib, ic
|
| 78 |
|
|
if (allocated (ia) .and. allocated (ib)) then
|
| 79 |
|
|
ic = [ia, ib]
|
| 80 |
|
|
else if (allocated (ia)) then
|
| 81 |
|
|
ic = ia
|
| 82 |
|
|
else if (allocated (ib)) then
|
| 83 |
|
|
ic = ib
|
| 84 |
|
|
end if
|
| 85 |
|
|
end function concat
|
| 86 |
|
|
end module m_qsort
|
| 87 |
|
|
|
| 88 |
|
|
module test
|
| 89 |
|
|
use m_qsort
|
| 90 |
|
|
implicit none
|
| 91 |
|
|
type, extends(sort_t) :: sort_int_t
|
| 92 |
|
|
integer :: i
|
| 93 |
|
|
contains
|
| 94 |
|
|
procedure :: disp => disp_int
|
| 95 |
|
|
procedure :: lt_cmp => lt_cmp_int
|
| 96 |
|
|
procedure :: assign => assign_int
|
| 97 |
|
|
end type
|
| 98 |
|
|
contains
|
| 99 |
|
|
elemental integer function disp_int(a)
|
| 100 |
|
|
class(sort_int_t), intent(in) :: a
|
| 101 |
|
|
disp_int = a%i
|
| 102 |
|
|
end function disp_int
|
| 103 |
|
|
elemental subroutine assign_int (a, b)
|
| 104 |
|
|
class(sort_int_t), intent(out) :: a
|
| 105 |
|
|
class(sort_t), intent(in) :: b ! TODO: gfortran does not throw 'class(sort_int_t)'
|
| 106 |
|
|
select type (b)
|
| 107 |
|
|
class is (sort_int_t)
|
| 108 |
|
|
a%i = b%i
|
| 109 |
|
|
class default
|
| 110 |
|
|
a%i = -1
|
| 111 |
|
|
end select
|
| 112 |
|
|
end subroutine assign_int
|
| 113 |
|
|
impure elemental logical function lt_cmp_int(a,b) result(cmp)
|
| 114 |
|
|
class(sort_int_t), intent(in) :: a
|
| 115 |
|
|
class(sort_t), intent(in) :: b
|
| 116 |
|
|
select type(b)
|
| 117 |
|
|
type is(sort_int_t)
|
| 118 |
|
|
if (a%i < b%i) then
|
| 119 |
|
|
cmp = .true.
|
| 120 |
|
|
else
|
| 121 |
|
|
cmp = .false.
|
| 122 |
|
|
end if
|
| 123 |
|
|
class default
|
| 124 |
|
|
ERROR STOP "Don't compare apples with oranges"
|
| 125 |
|
|
end select
|
| 126 |
|
|
end function lt_cmp_int
|
| 127 |
|
|
end module test
|
| 128 |
|
|
|
| 129 |
|
|
program main
|
| 130 |
|
|
use test
|
| 131 |
|
|
class(sort_t), allocatable :: A(:)
|
| 132 |
|
|
integer :: i, m(5)= [7 , 4, 5, 2, 3]
|
| 133 |
|
|
allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)])
|
| 134 |
|
|
! print *, "Before qsort: ", A%disp()
|
| 135 |
|
|
call qsort(A)
|
| 136 |
|
|
! print *, "After qsort: ", A%disp()
|
| 137 |
|
|
if (any (A%disp() .ne. [2,3,4,5,7])) call abort
|
| 138 |
|
|
end program main
|
| 139 |
|
|
|
| 140 |
|
|
! { dg-final { cleanup-modules "m_qsort test" } }
|
