- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
! Console31.f90
!
! FUNCTIONS:
! Console31 - Entry point of console application.
!
MODULE qsort_mod
IMPLICIT NONE
TYPE group
INTEGER :: order ! original order of unsorted data
REAL :: VALUE ! values to be sorted by
END TYPE group
CONTAINS
RECURSIVE SUBROUTINE QSort(a,na)
! DUMMY ARGUMENTS
INTEGER, INTENT(in) :: nA
TYPE (group), DIMENSION(nA), INTENT(in out) :: A
! LOCAL VARIABLES
INTEGER :: left, right
REAL :: random
REAL :: pivot
TYPE (group) :: temp
INTEGER :: marker
IF (nA > 1) THEN
CALL random_NUMBER(random)
pivot = A(INT(random*REAL(nA-1))+1)%VALUE ! Choice a random pivot (not best performance, but avoids worst-case)
left = 1
right = nA
! Partition loop
DO
IF (left >= right) EXIT
DO
IF (A(right)%VALUE <= pivot) EXIT
right = right - 1
write(*,*)"here1"
END DO
DO
IF (A(left)%VALUE >= pivot) EXIT
left = left + 1
write(*,*)"here2"
END DO
IF (left < right) THEN
temp = A(left)
A(left) = A(right)
A(right) = temp
write(*,*)"here3",left, right, temp
END IF
END DO
IF (left == right) THEN
marker = left + 1
write(*,*)"here4"
ELSE
marker = left
write(*,*)"here5"
END IF
write(*,*)"here6"
CALL QSort(A(:marker-1),marker-1)
write(*,*)"here7"
CALL QSort(A(marker:),nA-marker+1)
write(*,*)"here8",nA-marker+1
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
This comes from Rosetta Stone, the code gets stuck in an infinite loop at line 54.
I have been playing with it for a while and I am none the wiser. Any ideas would help?
Link Copied
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
The Fortran code for Qsort at Rosetta Code is defective. Consider what happens when nA = 2, the two elements have equal values and the "Partition Loop" is entered. The two equal values are swapped, but RIGHT=2 and LEFT=1 remain unchanged. That partition loop is now an infinite loop.
The quicksort algorithm is such that loop counts are highly dependent on the data being sorted, and that makes debugging the code quite tricky. Such codes often break if the input array has repeated values.
Here is a much simpler code that implements the same algorithm, adapted from a different source.
! quicksort.f -*-f90-*-
! Author: t-nissie
! License: GPLv3
! Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
!!
recursive subroutine quicksort(a, first, last)
implicit none
real a(*), pivot, t
integer first, last
integer i, j
call random_number(t)
pivot = a(int(t*(last-first)+first))
i = first; j = last
do
do while (a(i) < pivot)
i=i+1
end do
do while (pivot < a(j))
j=j-1
end do
if (i >= j) exit
t = a(i); a(i) = a(j); a(j) = t
i=i+1; j=j-1
end do
if (first < i-1) call quicksort(a, first, i-1)
if (j+1 < last) call quicksort(a, j+1, last)
end subroutine quicksort
program tqsort
integer, parameter :: N = 50
integer i
real :: x(N)
call random_number(x)
call quicksort(X,1,N)
print '(5(I5,F8.2))',(i,x(i),i=1,N)
end program
You can modify the main program part by putting in the code to generate the more elaborate array that you wish to sort.

- Subscribe to RSS Feed
- Mark Topic as New
- Mark Topic as Read
- Float this Topic for Current User
- Bookmark
- Subscribe
- Printer Friendly Page