myqsort.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	myqsort (n, a, perm, error)

Function/Subroutine Documentation

myqsort()

subroutine myqsort	(	integer	n,
			a,
		integer, dimension(n)	perm,
		integer	error )

Definition at line 50 of file myqsort.F.

C-----------------------------------------------
c     q u i c k s o r t
C Sedgewick algorithm from "Implementing Quicksort Programs"
C     A: data
C     N: len
C     PERM: permutations
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER N,ERROR,PERM(N)
C     REAL
        my_real
     .    a(n)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER :: STACKLEN
        INTEGER :: TRESHOLD
        INTEGER :: DONE
C the max STACKLEN <= 1 + 2 x log2 (N+1)/(TRESHOLD + 2)
        parameter( stacklen = 128 ,
     .             treshold   =  9 )
C
        INTEGER :: I
        INTEGER :: IPLUS1
        INTEGER :: J
        INTEGER :: JMINUS1
        INTEGER :: K
        INTEGER :: LEFT
        INTEGER :: LLEN
        INTEGER :: RIGHT
        INTEGER :: RLEN
        INTEGER :: TOP
        INTEGER :: STACK(STACKLEN)
C     REAL
        my_real
     .          rk, rv
C
        error = 0
C
        IF  (n < 1)  THEN
          error = -1
          RETURN
        ENDIF
 
        IF  (n == 1)  THEN
          perm(1)=1
          RETURN
        ENDIF
 
        DO  i = 1, n
          perm(i) = i
        ENDDO
C
        top = 1
        left = 1
        right = n
        IF (n <= treshold) THEN
          done = 1
        ELSE
          done = 0
        ENDIF
 
c     QUICKSORT
c
        DO WHILE (done /= 1)
          rk = a((left+right)/2)
          a((left+right)/2) = a(left)
          a(left) = rk
C
          k = perm((left+right)/2)
          perm((left+right)/2) = perm(left)
          perm(left) = k
 
          IF( a(left+1) > a(right) ) THEN
            rk = a(left+1)
            a(left+1) = a(right)
            a(right) = rk
            k = perm(left+1)
            perm(left+1) = perm(right)
            perm(right) = k
          ENDIF
          IF( a(left) > a(right) ) THEN
            rk = a(left)
            a(left) = a(right)
            a(right) = rk
            k = perm(left)
            perm(left) = perm(right)
            perm(right) = k
          ENDIF
          IF( a(left+1) >  a(left) ) THEN
            rk = a(left+1)
            a(left+1) = a(left)
            a(left) = rk
            k = perm(left+1)
            perm(left+1) = perm(left)
            perm(left) = k
          ENDIF
 
          rv = a(left)
          i = left+1
          j = right
 
          DO WHILE(j >= i)
            i  = i + 1
            DO WHILE(a(i) <  rv)
              i = i +1
            ENDDO
            j = j - 1
            DO WHILE(a(j) > rv)
              j = j - 1
            ENDDO
            IF (j >= i) THEN
              rk = a(i)
              a(i) = a(j)
              a(j) = rk
              k = perm(i)
              perm(i) = perm(j)
              perm(j) = k
            ENDIF
          ENDDO
C
          rk = a(left)
          a(left) = a(j)
          a(j) = rk
C
          k = perm(left)
          perm(left) = perm(j)
          perm(j) = k
C
          llen = j-left
          rlen = right - i + 1
 
          IF(max(llen, rlen) <= treshold ) THEN
            IF  (top == 1) THEN
              done = 1
            ELSE
              top = top - 2
              left = stack(top)
              right = stack(top+1)
            ENDIF
          ELSE IF(min(llen, rlen) <=  treshold) THEN
            IF( llen > rlen ) THEN
              right = j - 1
            ELSE
              left = i
            ENDIF
          ELSE
            IF( llen > rlen ) THEN
              stack(top) = left
              stack(top+1) = j-1
              left = i
            ELSE
              stack(top) = i
              stack(top+1) = right
              right = j-1
            ENDIF
            top = top + 2
          ENDIF
        END DO
c
c     INSERTION SORT
c
        i = n - 1
        iplus1 = n
        DO WHILE (i > 0)
          IF( a(i) > a(iplus1) ) THEN
            rk = a(i)
            k  = perm(i)
            j = iplus1
            jminus1 = i
            DO WHILE(a(j) <  rk)
              a(jminus1) = a(j)
              perm(jminus1) = perm(j)
              jminus1 = j
              j = j + 1
              IF  ( j > n )  EXIT
            ENDDO
            a(jminus1) = rk
            perm(jminus1) = k
          ENDIF
C
          iplus1 = i
          i = i - 1
        ENDDO
c
        RETURN
c
c     -------------------
c