|
=={{header|Fortran}}==
{{Works with|Fortran|90 and later}}
recursive subroutine fsort(a)
use inserts, only:insertion_sort !Not included in this posting
'''WARNING: The implementation of QuickSort in Fortran below is flawed:'''
implicit none
# If the largest element is in the last slot, the call to QSort(A(marker:),nA-marker+1) goes beyond the end of the array. This can cause exceptions and bad results.
!
# The use of a random number causes non reproducible performance.
! PARAMETER definitions
!
'''Instead of this algorithm rather use https://gist.github.com/t-nissie/479f0f16966925fa29ea'''
integer, parameter :: changesize = 64
!
<syntaxhighlight lang="fortran">MODULE qsort_mod
! Dummy arguments
!
IMPLICIT NONE
real, dimension(:) ,contiguous :: a
intent (inout) a
TYPE group
!
INTEGER :: order ! original order of unsorted data
! Local variables
REAL :: VALUE ! values to be sorted by
!
END TYPE group
integer :: first = 1
integer :: i
CONTAINS
integer :: j
integer :: last
RECURSIVE SUBROUTINE QSort(a,na)
logical :: stay
! DUMMY ARGUMENTSreal :: t
INTEGER, INTENT(in) real :: nA x
!
TYPE (group), DIMENSION(nA), INTENT(in out) :: A
!*Code
!
! LOCAL VARIABLES
INTEGER :: leftlast = size(a, right1)
if( (last - first)<changesize )then
REAL :: random
call insertion_sort(a(first:last))
REAL :: pivot
TYPE (group) :: temp return
INTEGER :: markerend if
j = shiftr((first + last), 1) + 1
!
IF (nA > 1) THEN
x = a(j)
i CALL= random_NUMBER(random)first
j = last
pivot = A(INT(random*REAL(nA-1))+1)%VALUE ! Choice a random pivot (not best performance, but avoids worst-case)
leftstay = 1.true.
do rightwhile =( nAstay )
! Partition loop do while ( a(i)<x )
DO i = i + 1
IFend (left >= right) EXITdo
DOdo while ( x<a(j) )
IF (A(right)%VALUEj <= pivot)j EXIT- 1
end right = right - 1do
ENDif( DOj<i )then
DO stay = .false.
IF (A(left)%VALUE >= pivot) EXITelse
left t = lefta(i) ! Swap +the 1values
END DO a(i) = a(j)
IF (left < right a(j) THEN= t
temp i = Ai + 1 ! Adjust the pointers (leftPIVOT POINTS)
A(left) j = A(right)j - 1
end A(right) = tempif
end END IFdo
if( first<i - 1 )call fsort(a(first:i - 1)) ! We still have some left to do on the lower
END DO
if( j + 1<last )call fsort(a(j + 1:last)) ! We still have some left to do on the upper
return
IF (left == right) THEN
end subroutine fsort
marker = left + 1
ELSE
marker = left
END IF
CALL QSort(A(:marker-1),marker-1)
CALL QSort(A(marker:),nA-marker+1) WARNING CAN GO BEYOND END OF ARRAY DO NOT USE THIS IMPLEMENTATION
END IF
END SUBROUTINE QSort
END MODULE qsort_mod
! Test Qsort Module
PROGRAM qsort_test
USE qsort_mod
IMPLICIT NONE
INTEGER, PARAMETER :: nl = 10, nc = 5, l = nc*nl, ns=33
TYPE (group), DIMENSION(l) :: A
INTEGER, DIMENSION(ns) :: seed
INTEGER :: i
REAL :: random
CHARACTER(LEN=80) :: fmt1, fmt2
! Using the Fibonacci sequence to initialize seed:
seed(1) = 1 ; seed(2) = 1
DO i = 3,ns
seed(i) = seed(i-1)+seed(i-2)
END DO
! Formats of the outputs
WRITE(fmt1,'(A,I2,A)') '(', nc, '(I5,2X,F6.2))'
WRITE(fmt2,'(A,I2,A)') '(3x', nc, '("Ord. Num.",3x))'
PRINT *, "Unsorted Values:"
PRINT fmt2,
CALL random_SEED(put = seed)
DO i = 1, l
CALL random_NUMBER(random)
A(i)%VALUE = NINT(1000*random)/10.0
A(i)%order = i
IF (MOD(i,nc) == 0) WRITE (*,fmt1) A(i-nc+1:i)
END DO
PRINT *
CALL QSort(A,l)
PRINT *, "Sorted Values:"
PRINT fmt2,
DO i = nc, l, nc
IF (MOD(i,nc) == 0) WRITE (*,fmt1) A(i-nc+1:i)
END DO
STOP
END PROGRAM qsort_test</syntaxhighlight>
{{out}}
<pre>
Compiled with GNU Fortran 9.3.0
Unsorted Values:
Ord. Num. Ord. Num. Ord. Num. Ord. Num. Ord. Num.
1 47.10 2 11.70 3 35.80 4 35.20 5 55.30
6 74.60 7 28.40 8 30.10 9 70.60 10 66.90
11 15.90 12 71.70 13 49.80 14 2.60 15 12.80
16 93.00 17 45.20 18 21.50 19 20.70 20 39.50
21 9.20 22 21.60 23 18.60 24 22.80 25 98.50
26 97.50 27 43.90 28 8.30 29 84.10 30 88.80
31 10.30 32 30.50 33 79.30 34 24.40 35 45.00
36 48.30 37 69.80 38 86.00 39 68.40 40 22.90
41 7.50 42 18.50 43 80.40 44 29.60 45 43.60
46 11.20 47 36.20 48 23.20 49 45.30 50 12.30
Sorted Values:
Ord. Num. Ord. Num. Ord. Num. Ord. Num. Ord. Num.
14 2.60 41 7.50 28 8.30 21 9.20 31 10.30
46 11.20 2 11.70 50 12.30 15 12.80 11 15.90
42 18.50 23 18.60 19 20.70 18 21.50 22 21.60
24 22.80 40 22.90 48 23.20 34 24.40 7 28.40
44 29.60 8 30.10 32 30.50 4 35.20 3 35.80
47 36.20 20 39.50 45 43.60 27 43.90 35 45.00
17 45.20 49 45.30 1 47.10 36 48.30 13 49.80
5 55.30 10 66.90 39 68.40 37 69.80 9 70.60
12 71.70 6 74.60 33 79.30 43 80.40 29 84.10
38 86.00 30 88.80 16 93.00 26 97.50 25 98.50
</pre>
A discussion about Quicksort pivot options, free source code for an optimized quicksort using insertion sort as a finisher, and an OpenMP multi-threaded quicksort is found at [http://balfortran.org balfortran.org]
=={{header|FreeBASIC}}==
|