quick_sort1.f

Go to the documentation of this file.

C From HDK@psuvm.psu.edu Thu Dec  8 15:27:16 MST 1994
C 
C The following was converted from Algol recursive to Fortran iterative
C by a colleague at Penn State (a long time ago - Fortran 66, please
C excuse the GoTo's). The following code also corrects a bug in the
C Quicksort algorithm published in the ACM (see Algorithm 402, CACM,
C Sept. 1970, pp 563-567; also you younger folks who weren't born at
C that time might find interesting the history of the Quicksort
C algorithm beginning with the original published in CACM, July 1961,
C pp 321-322, Algorithm 64). Note that the following algorithm sorts
C integer data; actual data is not moved but sort is affected by sorting
C a companion index array (see leading comments). The data type being
C sorted can be changed by changing one line; see comments after
C declarations and subsequent one regarding comparisons(Fortran
C 77 takes care of character comparisons of course, so that comment
C is merely historical from the days when we had to write character
C compare subprograms, usually in assembler language for a specific
C mainframe platform at that time). But the following algorithm is
C good, still one of the best available.


      SUBROUTINE qsorti (ORD,N,A)
C
C==============SORTS THE ARRAY A(I),I=1,2,...,N BY PUTTING THE
C   ASCENDING ORDER VECTOR IN ORD.  THAT IS ASCENDING ORDERED A
C   IS A(ORD(I)),I=1,2,...,N; DESCENDING ORDER A IS A(ORD(N-I+1)),
C   I=1,2,...,N .  THIS SORT RUNS IN TIME PROPORTIONAL TO N LOG N .
C
C
C     ACM QUICKSORT - ALGORITHM #402 - IMPLEMENTED IN FORTRAN 66 BY
C                                 WILLIAM H. VERITY, WHV@PSUVM.PSU.EDU
C                                 CENTER FOR ACADEMIC COMPUTING
C                                 THE PENNSYLVANIA STATE UNIVERSITY
C                                 UNIVERSITY PARK, PA.  16802
C
      IMPLICIT INTEGER (A-Z)
C
      dimension ord(n),poplst(2,20)
      integer X,XX,Z,ZZ,Y
C
C     TO SORT DIFFERENT INPUT TYPES, CHANGE THE FOLLOWING
C     SPECIFICATION STATEMENTS; FOR EXAMPLE, FOR FORTRAN CHARACTER
C     USE THE FOLLOWING:  CHARACTER *(*) A(N)
C
      integer A(n)
C
      ndeep=0
      u1=n
      l1=1
      DO 1  i=1,n
    1 ord(i)=i
    2 IF (u1.LE.l1) RETURN
C
    3 l=l1
      u=u1
C
C PART
C
    4 p=l
      q=u
C     FOR CHARACTER SORTS, THE FOLLOWING 3 STATEMENTS WOULD BECOME
C     X = ORD(P)
C     Z = ORD(Q)
C     IF (A(X) .LE. A(Z)) GO TO 2
C
C     WHERE "CLE" IS A LOGICAL FUNCTION WHICH RETURNS "TRUE" IF THE
C     FIRST ARGUMENT IS LESS THAN OR EQUAL TO THE SECOND, BASED ON "LEN"
C     CHARACTERS.
C
      x=a(ord(p))
      z=a(ord(q))
      IF (x.LE.z) GO TO 5
      y=x
      x=z
      z=y
      yp=ord(p)
      ord(p)=ord(q)
      ord(q)=yp
    5 IF (u-l.LE.1) GO TO 15
      xx=x
      ix=p
      zz=z
      iz=q
C
C LEFT
C
    6 p=p+1
      IF (p.GE.q) GO TO 7
      x=a(ord(p))
      IF (x.GE.xx) GO TO 8
      GO TO 6
    7 p=q-1
      GO TO 13
C
C RIGHT
C
    8 q=q-1
      IF (q.LE.p) GO TO 9
      z=a(ord(q))
      IF (z.LE.zz) GO TO 10
      GO TO 8
    9 q=p
      p=p-1
      z=x
      x=a(ord(p))
C
C DIST
C
   10 IF (x.LE.z) GO TO 11
      y=x
      x=z
      z=y
      ip=ord(p)
      ord(p)=ord(q)
      ord(q)=ip
   11 IF (x.LE.xx) GO TO 12
      xx=x
      ix=p
   12 IF (z.GE.zz) GO TO 6
      zz=z
      iz=q
      GO TO 6
C
C OUT
C
   13 CONTINUE
      IF (.NOT.(p.NE.ix.AND.x.NE.xx)) GO TO 14
      ip=ord(p)
      ord(p)=ord(ix)
      ord(ix)=ip
   14 CONTINUE
      IF (.NOT.(q.NE.iz.AND.z.NE.zz)) GO TO 15
      iq=ord(q)
      ord(q)=ord(iz)
      ord(iz)=iq
   15 CONTINUE
      IF (u-q.LE.p-l) GO TO 16
      l1=l
      u1=p-1
      l=q+1
      GO TO 17
   16 u1=u
      l1=q+1
      u=p-1
   17 CONTINUE
      IF (u1.LE.l1) GO TO 18
C
C START RECURSIVE CALL
C
      ndeep=ndeep+1
      poplst(1,ndeep)=u
      poplst(2,ndeep)=l
      GO TO 3
   18 IF (u.GT.l) GO TO 4
C
C POP BACK UP IN THE RECURSION LIST
C
      IF (ndeep.EQ.0) GO TO 2
      u=poplst(1,ndeep)
      l=poplst(2,ndeep)
      ndeep=ndeep-1
      GO TO 18
C
C END SORT
C END QSORT
C
      END