mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
323 lines
7.6 KiB
Fortran
323 lines
7.6 KiB
Fortran
*DECK SSORT
|
|
SUBROUTINE SSORT (X, Y, 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 SINGLE PRECISION (SSORT-S, DSORT-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 X and optionally makes the same interchanges in
|
|
C array Y. The array X may be sorted in increasing order or
|
|
C decreasing order. A slightly modified quicksort algorithm is used.
|
|
C
|
|
C Description of Parameters
|
|
C X - array of values to be sorted (usually abscissas)
|
|
C Y - array to be (optionally) carried along
|
|
C N - number of values in array X to be sorted
|
|
C KFLAG - control parameter
|
|
C = 2 means sort X in increasing order and carry Y along.
|
|
C = 1 means sort X in increasing order (ignoring Y)
|
|
C = -1 means sort X in decreasing order (ignoring Y)
|
|
C = -2 means sort X in decreasing order and carry Y 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 SX,SY. (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 X(*), Y(*)
|
|
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 ..
|
|
EXTERNAL XERMSG
|
|
C .. Intrinsic Functions ..
|
|
INTRINSIC ABS, INT
|
|
C***FIRST EXECUTABLE STATEMENT SSORT
|
|
NN = N
|
|
IF (NN .LT. 1) THEN
|
|
CALL XERMSG ('SLATEC', 'SSORT',
|
|
+ '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
|
|
CALL XERMSG ('SLATEC', 'SSORT',
|
|
+ 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2,
|
|
+ 1)
|
|
RETURN
|
|
ENDIF
|
|
C
|
|
C Alter array X to get decreasing order if needed
|
|
C
|
|
IF (KFLAG .LE. -1) THEN
|
|
DO 10 I=1,NN
|
|
X(I) = -X(I)
|
|
10 CONTINUE
|
|
ENDIF
|
|
C
|
|
IF (KK .EQ. 2) GO TO 100
|
|
C
|
|
C Sort X only
|
|
C
|
|
M = 1
|
|
I = 1
|
|
J = NN
|
|
R = 0.375E0
|
|
C
|
|
20 IF (I .EQ. J) GO TO 60
|
|
IF (R .LE. 0.5898437E0) THEN
|
|
R = R+3.90625E-2
|
|
ELSE
|
|
R = R-0.21875E0
|
|
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 = X(IJ)
|
|
C
|
|
C If first element of array is greater than T, interchange with T
|
|
C
|
|
IF (X(I) .GT. T) THEN
|
|
X(IJ) = X(I)
|
|
X(I) = T
|
|
T = X(IJ)
|
|
ENDIF
|
|
L = J
|
|
C
|
|
C If last element of array is less than than T, interchange with T
|
|
C
|
|
IF (X(J) .LT. T) THEN
|
|
X(IJ) = X(J)
|
|
X(J) = T
|
|
T = X(IJ)
|
|
C
|
|
C If first element of array is greater than T, interchange with T
|
|
C
|
|
IF (X(I) .GT. T) THEN
|
|
X(IJ) = X(I)
|
|
X(I) = T
|
|
T = X(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 (X(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 (X(K) .LT. T) GO TO 50
|
|
C
|
|
C Interchange these elements
|
|
C
|
|
IF (K .LE. L) THEN
|
|
TT = X(L)
|
|
X(L) = X(K)
|
|
X(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 = X(I+1)
|
|
IF (X(I) .LE. T) GO TO 80
|
|
K = I
|
|
C
|
|
90 X(K+1) = X(K)
|
|
K = K-1
|
|
IF (T .LT. X(K)) GO TO 90
|
|
X(K+1) = T
|
|
GO TO 80
|
|
C
|
|
C Sort X and carry Y along
|
|
C
|
|
100 M = 1
|
|
I = 1
|
|
J = NN
|
|
R = 0.375E0
|
|
C
|
|
110 IF (I .EQ. J) GO TO 150
|
|
IF (R .LE. 0.5898437E0) THEN
|
|
R = R+3.90625E-2
|
|
ELSE
|
|
R = R-0.21875E0
|
|
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 = X(IJ)
|
|
TY = Y(IJ)
|
|
C
|
|
C If first element of array is greater than T, interchange with T
|
|
C
|
|
IF (X(I) .GT. T) THEN
|
|
X(IJ) = X(I)
|
|
X(I) = T
|
|
T = X(IJ)
|
|
Y(IJ) = Y(I)
|
|
Y(I) = TY
|
|
TY = Y(IJ)
|
|
ENDIF
|
|
L = J
|
|
C
|
|
C If last element of array is less than T, interchange with T
|
|
C
|
|
IF (X(J) .LT. T) THEN
|
|
X(IJ) = X(J)
|
|
X(J) = T
|
|
T = X(IJ)
|
|
Y(IJ) = Y(J)
|
|
Y(J) = TY
|
|
TY = Y(IJ)
|
|
C
|
|
C If first element of array is greater than T, interchange with T
|
|
C
|
|
IF (X(I) .GT. T) THEN
|
|
X(IJ) = X(I)
|
|
X(I) = T
|
|
T = X(IJ)
|
|
Y(IJ) = Y(I)
|
|
Y(I) = TY
|
|
TY = Y(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 (X(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 (X(K) .LT. T) GO TO 140
|
|
C
|
|
C Interchange these elements
|
|
C
|
|
IF (K .LE. L) THEN
|
|
TT = X(L)
|
|
X(L) = X(K)
|
|
X(K) = TT
|
|
TTY = Y(L)
|
|
Y(L) = Y(K)
|
|
Y(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 = X(I+1)
|
|
TY = Y(I+1)
|
|
IF (X(I) .LE. T) GO TO 170
|
|
K = I
|
|
C
|
|
180 X(K+1) = X(K)
|
|
Y(K+1) = Y(K)
|
|
K = K-1
|
|
IF (T .LT. X(K)) GO TO 180
|
|
X(K+1) = T
|
|
Y(K+1) = TY
|
|
GO TO 170
|
|
C
|
|
C Clean up
|
|
C
|
|
190 IF (KFLAG .LE. -1) THEN
|
|
DO 200 I=1,NN
|
|
X(I) = -X(I)
|
|
200 CONTINUE
|
|
ENDIF
|
|
RETURN
|
|
END
|