Below is an interesting use of PACK, which claims to require F90, but may be F03/F08?
It is extremely brief but is expensive on memory. It works well.
I have modified to do a forward sort and included code to test for various sizes.
! qsort_reals.f90 --
!
! Example belonging to 'Modern Fortran in Practice' by Arjen Markus
!
! This work is licensed under the Creative Commons Attribution 3.0 Unported License.
! To view a copy of this license, visit http://creativecommons.org/licenses/by/3.0/
! or send a letter to:
! Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA.
!
! Compact implementation of the QuickSort algorithm
!
! Note:
! Because the function uses Fortran 90 features, its interface should be made
! explicit when using it in an actual program. This is easiest via a module.
!
module qsort_functions
implicit none
contains
recursive function qsort_reals ( data ) result ( sorted )
real, dimension(:), intent(in) :: data
real, dimension(1:size(data)) :: sorted
write (*,*) size(data)
if ( size(data) > 1 ) then
sorted = &
(/ qsort_reals( pack( data(2:), data(2:) <= data(1) ) ), &
data(1), &
qsort_reals( pack( data(2:), data(2:) > data(1) ) ) /)
else
sorted = data
endif
end function qsort_reals
end module qsort_functions
Program test_sort_reals
real*8 t1,t2
integer i,n,j
open (11,file='markus_sort.txt', position='append')
do i = 2,5 ! 25
N = 2**i
call test_sort(N,j,t1, t2)
write ( *,11) i,' sort',n,j,' errors ',t1,t2
write (11,11) i,' sort',n,j,' errors ',t1,t2
end do
11 format (i3,a,2i10,a,2f12.6)
end Program test_sort_reals
real*8 function elapse_second ()
integer*8 :: clock, tick, start = -1
call system_clock ( clock, tick )
if ( start < 0 ) start = clock
elapse_second = dble(clock-start) / dble (tick)
end function elapse_second
subroutine test_sort (N, j, t, x)
use qsort_functions
integer N
!z real aa(N), aa_sort(N) ! automatic arrays
real, allocatable :: aa(:), aa_sort(:) ! allocate arrays
real*8 t, x
real*8, external :: elapse_second
integer i,j
!
allocate ( aa(N), aa_sort(N) )
call random_number (aa)
write (*,*) n, aa
!
! do sort
t = elapse_second ()
aa_sort = qsort_reals ( aa )
t = elapse_second () - t
!
! test sort is correct
x = elapse_second ()
j = 0
do i = 2, size(aa)
if ( aa_sort(i) >= aa_sort(i-1) ) cycle
j = j+1
write (*,*) i, aa_sort(i-1), aa_sort(i)
end do
x = elapse_second () - x
end subroutine test_sort