ssort.F

Go to the documentation of this file.

*DECK SSORT
      SUBROUTINE ssort (DX, DY, N, KFLAG)
C***BEGIN PROLOGUE  SSORT
C***PURPOSE  SORT AN ARRAY AND OPTIONALLY MAKE THE SAME INTERCHANGES IN
C            AN AUXILIARY ARRAY.  THE ARRAY MAY BE SORTED IN INCREASING
C            OR DECREASING ORDER.  A SLIGHTLY MODIFIED QUICKSORT
C            ALGORITHM IS USED.
C***LIBRARY   SLATEC
C***CATEGORY  N6A2B
C***TYPE      REAL (SSORT-S, SSORT-D, ISORT-I)
C***KEYWORDS  SINGLETON QUICKSORT, SORT, SORTING
C***AUTHOR  JONES, R. E., (SNLA)
C           WISNIEWSKI, J. A., (SNLA)
C***DESCRIPTION
C
C   SSORT SORTS ARRAY DX AND OPTIONALLY MAKES THE SAME INTERCHANGES IN
C   ARRAY DY.  THE ARRAY DX MAY BE SORTED IN INCREASING ORDER OR
C   DECREASING ORDER.  A SLIGHTLY MODIFIED QUICKSORT ALGORITHM IS USED.
C
C   DESCRIPTION OF PARAMETERS
C      DX - ARRAY OF VALUES TO BE SORTED   (USUALLY ABSCISSAS)
C      DY - ARRAY TO BE (OPTIONALLY) CARRIED ALONG
C      N  - NUMBER OF VALUES IN ARRAY DX TO BE SORTED
C      KFLAG - CONTROL PARAMETER
C            =  2  MEANS SORT DX IN INCREASING ORDER AND CARRY DY ALONG.
C            =  1  MEANS SORT DX IN INCREASING ORDER (IGNORING DY)
C            = -1  MEANS SORT DX IN DECREASING ORDER (IGNORING DY)
C            = -2  MEANS SORT DX IN DECREASING ORDER AND CARRY DY ALONG.
C
C***REFERENCES  R. C. SINGLETON, ALGORITHM 347, AN EFFICIENT ALGORITHM
C                 FOR SORTING WITH MINIMAL STORAGE, COMMUNICATIONS OF
C                 THE ACM, 12, 3 (1969), PP. 185-187.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   761101  DATE WRITTEN
C   761118  MODIFIED TO USE THE SINGLETON QUICKSORT ALGORITHM.  (JAW)
C   890531  CHANGED ALL SPECIFIC INTRINSICS TO GENERIC.  (WRB)
C   890831  MODIFIED ARRAY DECLARATIONS.  (WRB)
C   891009  REMOVED UNREFERENCED STATEMENT LABELS.  (WRB)
C   891024  CHANGED CATEGORY.  (WRB)
C   891024  REVISION DATE FROM VERSION 3.2
C   891214  PROLOGUE CONVERTED TO VERSION 4.0 FORMAT.  (BAB)
C   900315  CALLS TO XERROR CHANGED TO CALLS TO XERMSG.  (THJ)
C   901012  DECLARED ALL VARIABLES; CHANGED X,Y TO DX,DY; CHANGED
C           CODE TO PARALLEL SSORT. (M. MCCLAIN)
C   920501  REFORMATTED THE REFERENCES SECTION.  (DWL, WRB)
C   920519  CLARIFIED ERROR MESSAGES.  (DWL)
C   920801  DECLARATIONS SECTION REBUILT AND CODE RESTRUCTURED TO USE
C           IF-THEN-ELSE-ENDIF.  (RWC, WRB)
C***END PROLOGUE  SSORT
C     .. SCALAR ARGUMENTS ..
      INTEGER KFLAG, N
C     .. ARRAY ARGUMENTS ..
      REAL DX(*), DY(*)
C     .. LOCAL SCALARS ..
      REAL R, T, TT, TTY, TY
      INTEGER I, IJ, J, K, KK, L, M, NN
C     .. LOCAL ARRAYS ..
      INTEGER IL(21), IU(21)
C     .. EXTERNAL SUBROUTINES ..
C      EXTERNAL XERMSG
C     .. INTRINSIC FUNCTIONS ..
      INTRINSIC abs, int
C***FIRST EXECUTABLE STATEMENT  SSORT
      nn = n
      IF (nn .LT. 1) THEN
          WRITE(6,*)  
     +   "The number of values to be sorted is not positive."

C         CALL XERMSG ('SLATEC', 'SSORT',
C     +      'The number of values to be sorted is not positive.', 1, 1)

         RETURN
      ENDIF
C
      kk = abs(kflag)
      IF (kk.NE.1 .AND. kk.NE.2) THEN

          WRITE(6,*) 
     +    "The sort control parameter, K is bad."
C         CALL XERMSG ('SLATEC', 'SSORT',
C     +      'The sort control parameter, K, is not 2, 1, -1, or -2.', 2,
C     +      1)
         RETURN
      ENDIF
C
C     ALTER ARRAY DX TO GET DECREASING ORDER IF NEEDED
C
      IF (kflag .LE. -1) THEN
         DO 10 i=1,nn
            dx(i) = -dx(i)
   10    CONTINUE
      ENDIF
C
      IF (kk .EQ. 2) GO TO 100
C
C     SORT DX ONLY
C
      m = 1
      i = 1
      j = nn
      r = 0.375d0
C
   20 IF (i .EQ. j) GO TO 60
      IF (r .LE. 0.5898437d0) THEN
         r = r+3.90625d-2
      ELSE
         r = r-0.21875d0
      ENDIF
C
   30 k = i
C
C     SELECT A CENTRAL ELEMENT OF THE ARRAY AND SAVE IT IN LOCATION T
C
      ij = i + int((j-i)*r)
      t = dx(ij)
C
C     IF FIRST ELEMENT OF ARRAY IS GREATER THAN T, INTERCHANGE WITH T
C
      IF (dx(i) .GT. t) THEN
         dx(ij) = dx(i)
         dx(i) = t
         t = dx(ij)
      ENDIF
      l = j
C
C     IF LAST ELEMENT OF ARRAY IS LESS THAN THAN T, INTERCHANGE WITH T
C
      IF (dx(j) .LT. t) THEN
         dx(ij) = dx(j)
         dx(j) = t
         t = dx(ij)
C
C        IF FIRST ELEMENT OF ARRAY IS GREATER THAN T, INTERCHANGE WITH T
C
         IF (dx(i) .GT. t) THEN
            dx(ij) = dx(i)
            dx(i) = t
            t = dx(ij)
         ENDIF
      ENDIF
C
C     FIND AN ELEMENT IN THE SECOND HALF OF THE ARRAY WHICH IS SMALLER
C     THAN T
C
   40 l = l-1
      IF (dx(l) .GT. t) GO TO 40
C
C     FIND AN ELEMENT IN THE FIRST HALF OF THE ARRAY WHICH IS GREATER
C     THAN T
C
   50 k = k+1
      IF (dx(k) .LT. t) GO TO 50
C
C     INTERCHANGE THESE ELEMENTS
C
      IF (k .LE. l) THEN
         tt = dx(l)
         dx(l) = dx(k)
         dx(k) = tt
         GO TO 40
      ENDIF
C
C     SAVE UPPER AND LOWER SUBSCRIPTS OF THE ARRAY YET TO BE SORTED
C
      IF (l-i .GT. j-k) THEN
         il(m) = i
         iu(m) = l
         i = k
         m = m+1
      ELSE
         il(m) = k
         iu(m) = j
         j = l
         m = m+1
      ENDIF
      GO TO 70
C
C     BEGIN AGAIN ON ANOTHER PORTION OF THE UNSORTED ARRAY
C
   60 m = m-1
      IF (m .EQ. 0) GO TO 190
      i = il(m)
      j = iu(m)
C
   70 IF (j-i .GE. 1) GO TO 30
      IF (i .EQ. 1) GO TO 20
      i = i-1
C
   80 i = i+1
      IF (i .EQ. j) GO TO 60
      t = dx(i+1)
      IF (dx(i) .LE. t) GO TO 80
      k = i
C
   90 dx(k+1) = dx(k)
      k = k-1
      IF (t .LT. dx(k)) GO TO 90
      dx(k+1) = t
      GO TO 80
C
C     SORT DX AND CARRY DY ALONG
C
  100 m = 1
      i = 1
      j = nn
      r = 0.375d0
C
  110 IF (i .EQ. j) GO TO 150
      IF (r .LE. 0.5898437d0) THEN
         r = r+3.90625d-2
      ELSE
         r = r-0.21875d0
      ENDIF
C
  120 k = i
C
C     SELECT A CENTRAL ELEMENT OF THE ARRAY AND SAVE IT IN LOCATION T
C
      ij = i + int((j-i)*r)
      t = dx(ij)
      ty = dy(ij)
C
C     IF FIRST ELEMENT OF ARRAY IS GREATER THAN T, INTERCHANGE WITH T
C
      IF (dx(i) .GT. t) THEN
         dx(ij) = dx(i)
         dx(i) = t
         t = dx(ij)
         dy(ij) = dy(i)
         dy(i) = ty
         ty = dy(ij)
      ENDIF
      l = j
C
C     IF LAST ELEMENT OF ARRAY IS LESS THAN T, INTERCHANGE WITH T
C
      IF (dx(j) .LT. t) THEN
         dx(ij) = dx(j)
         dx(j) = t
         t = dx(ij)
         dy(ij) = dy(j)
         dy(j) = ty
         ty = dy(ij)
C
C        IF FIRST ELEMENT OF ARRAY IS GREATER THAN T, INTERCHANGE WITH T
C
         IF (dx(i) .GT. t) THEN
            dx(ij) = dx(i)
            dx(i) = t
            t = dx(ij)
            dy(ij) = dy(i)
            dy(i) = ty
            ty = dy(ij)
         ENDIF
      ENDIF
C
C     FIND AN ELEMENT IN THE SECOND HALF OF THE ARRAY WHICH IS SMALLER
C     THAN T
C
  130 l = l-1
      IF (dx(l) .GT. t) GO TO 130
C
C     FIND AN ELEMENT IN THE FIRST HALF OF THE ARRAY WHICH IS GREATER
C     THAN T
C
  140 k = k+1
      IF (dx(k) .LT. t) GO TO 140
C
C     INTERCHANGE THESE ELEMENTS
C
      IF (k .LE. l) THEN
         tt = dx(l)
         dx(l) = dx(k)
         dx(k) = tt
         tty = dy(l)
         dy(l) = dy(k)
         dy(k) = tty
         GO TO 130
      ENDIF
C
C     SAVE UPPER AND LOWER SUBSCRIPTS OF THE ARRAY YET TO BE SORTED
C
      IF (l-i .GT. j-k) THEN
         il(m) = i
         iu(m) = l
         i = k
         m = m+1
      ELSE
         il(m) = k
         iu(m) = j
         j = l
         m = m+1
      ENDIF
      GO TO 160
C
C     BEGIN AGAIN ON ANOTHER PORTION OF THE UNSORTED ARRAY
C
  150 m = m-1
      IF (m .EQ. 0) GO TO 190
      i = il(m)
      j = iu(m)
C
  160 IF (j-i .GE. 1) GO TO 120
      IF (i .EQ. 1) GO TO 110
      i = i-1
C
  170 i = i+1
      IF (i .EQ. j) GO TO 150
      t = dx(i+1)
      ty = dy(i+1)
      IF (dx(i) .LE. t) GO TO 170
      k = i
C
  180 dx(k+1) = dx(k)
      dy(k+1) = dy(k)
      k = k-1
      IF (t .LT. dx(k)) GO TO 180
      dx(k+1) = t
      dy(k+1) = ty
      GO TO 170
C
C     CLEAN UP
C
  190 IF (kflag .LE. -1) THEN
         DO 200 i=1,nn
            dx(i) = -dx(i)
  200    CONTINUE
      ENDIF
      RETURN
      END SUBROUTINE ssort