Quick sort

[JohnNichols]

    !  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?

[mecej4]

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.