1 | *DECK SSORT |
---|
2 | SUBROUTINE SSORT (X, Y, N, KFLAG) |
---|
3 | C***BEGIN PROLOGUE SSORT |
---|
4 | C***PURPOSE Sort an array and optionally make the same interchanges in |
---|
5 | C an auxiliary array. The array may be sorted in increasing |
---|
6 | C or decreasing order. A slightly modified QUICKSORT |
---|
7 | C algorithm is used. |
---|
8 | C***LIBRARY SLATEC |
---|
9 | C***CATEGORY N6A2B |
---|
10 | C***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) |
---|
11 | C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING |
---|
12 | C***AUTHOR Jones, R. E., (SNLA) |
---|
13 | C Wisniewski, J. A., (SNLA) |
---|
14 | C***DESCRIPTION |
---|
15 | C |
---|
16 | C SSORT sorts array X and optionally makes the same interchanges in |
---|
17 | C array Y. The array X may be sorted in increasing order or |
---|
18 | C decreasing order. A slightly modified quicksort algorithm is used. |
---|
19 | C |
---|
20 | C Description of Parameters |
---|
21 | C X - array of values to be sorted (usually abscissas) |
---|
22 | C Y - array to be (optionally) carried along |
---|
23 | C N - number of values in array X to be sorted |
---|
24 | C KFLAG - control parameter |
---|
25 | C = 2 means sort X in increasing order and carry Y along. |
---|
26 | C = 1 means sort X in increasing order (ignoring Y) |
---|
27 | C = -1 means sort X in decreasing order (ignoring Y) |
---|
28 | C = -2 means sort X in decreasing order and carry Y along. |
---|
29 | C |
---|
30 | C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm |
---|
31 | C for sorting with minimal storage, Communications of |
---|
32 | C the ACM, 12, 3 (1969), pp. 185-187. |
---|
33 | C***ROUTINES CALLED XERMSG |
---|
34 | C***REVISION HISTORY (YYMMDD) |
---|
35 | C 761101 DATE WRITTEN |
---|
36 | C 761118 Modified to use the Singleton quicksort algorithm. (JAW) |
---|
37 | C 890531 Changed all specific intrinsics to generic. (WRB) |
---|
38 | C 890831 Modified array declarations. (WRB) |
---|
39 | C 891009 Removed unreferenced statement labels. (WRB) |
---|
40 | C 891024 Changed category. (WRB) |
---|
41 | C 891024 REVISION DATE from Version 3.2 |
---|
42 | C 891214 Prologue converted to Version 4.0 format. (BAB) |
---|
43 | C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) |
---|
44 | C 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) |
---|
45 | C 920501 Reformatted the REFERENCES section. (DWL, WRB) |
---|
46 | C 920519 Clarified error messages. (DWL) |
---|
47 | C 920801 Declarations section rebuilt and code restructured to use |
---|
48 | C IF-THEN-ELSE-ENDIF. (RWC, WRB) |
---|
49 | C***END PROLOGUE SSORT |
---|
50 | C .. Scalar Arguments .. |
---|
51 | INTEGER KFLAG, N |
---|
52 | C .. Array Arguments .. |
---|
53 | REAL X(*), Y(*) |
---|
54 | C .. Local Scalars .. |
---|
55 | REAL R, T, TT, TTY, TY |
---|
56 | INTEGER I, IJ, J, K, KK, L, M, NN |
---|
57 | C .. Local Arrays .. |
---|
58 | INTEGER IL(21), IU(21) |
---|
59 | C .. External Subroutines .. |
---|
60 | C EXTERNAL XERMSG |
---|
61 | C .. Intrinsic Functions .. |
---|
62 | INTRINSIC ABS, INT |
---|
63 | C***FIRST EXECUTABLE STATEMENT SSORT |
---|
64 | NN = N |
---|
65 | C IF (NN .LT. 1) THEN |
---|
66 | C CALL XERMSG ('SLATEC', 'SSORT', |
---|
67 | C + 'The number of values to be sorted is not positive.', 1, 1) |
---|
68 | C RETURN |
---|
69 | C ENDIF |
---|
70 | C |
---|
71 | KK = ABS(KFLAG) |
---|
72 | C IF (KK.NE.1 .AND. KK.NE.2) THEN |
---|
73 | C CALL XERMSG ('SLATEC', 'SSORT', |
---|
74 | C + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, |
---|
75 | C + 1) |
---|
76 | C RETURN |
---|
77 | C ENDIF |
---|
78 | C |
---|
79 | C Alter array X to get decreasing order if needed |
---|
80 | C |
---|
81 | IF (KFLAG .LE. -1) THEN |
---|
82 | DO 10 I=1,NN |
---|
83 | X(I) = -X(I) |
---|
84 | 10 CONTINUE |
---|
85 | ENDIF |
---|
86 | C |
---|
87 | IF (KK .EQ. 2) GO TO 100 |
---|
88 | C |
---|
89 | C Sort X only |
---|
90 | C |
---|
91 | M = 1 |
---|
92 | I = 1 |
---|
93 | J = NN |
---|
94 | R = 0.375E0 |
---|
95 | C |
---|
96 | 20 IF (I .EQ. J) GO TO 60 |
---|
97 | IF (R .LE. 0.5898437E0) THEN |
---|
98 | R = R+3.90625E-2 |
---|
99 | ELSE |
---|
100 | R = R-0.21875E0 |
---|
101 | ENDIF |
---|
102 | C |
---|
103 | 30 K = I |
---|
104 | C |
---|
105 | C Select a central element of the array and save it in location T |
---|
106 | C |
---|
107 | IJ = I + INT((J-I)*R) |
---|
108 | T = X(IJ) |
---|
109 | C |
---|
110 | C If first element of array is greater than T, interchange with T |
---|
111 | C |
---|
112 | IF (X(I) .GT. T) THEN |
---|
113 | X(IJ) = X(I) |
---|
114 | X(I) = T |
---|
115 | T = X(IJ) |
---|
116 | ENDIF |
---|
117 | L = J |
---|
118 | C |
---|
119 | C If last element of array is less than than T, interchange with T |
---|
120 | C |
---|
121 | IF (X(J) .LT. T) THEN |
---|
122 | X(IJ) = X(J) |
---|
123 | X(J) = T |
---|
124 | T = X(IJ) |
---|
125 | C |
---|
126 | C If first element of array is greater than T, interchange with T |
---|
127 | C |
---|
128 | IF (X(I) .GT. T) THEN |
---|
129 | X(IJ) = X(I) |
---|
130 | X(I) = T |
---|
131 | T = X(IJ) |
---|
132 | ENDIF |
---|
133 | ENDIF |
---|
134 | C |
---|
135 | C Find an element in the second half of the array which is smaller |
---|
136 | C than T |
---|
137 | C |
---|
138 | 40 L = L-1 |
---|
139 | IF (X(L) .GT. T) GO TO 40 |
---|
140 | C |
---|
141 | C Find an element in the first half of the array which is greater |
---|
142 | C than T |
---|
143 | C |
---|
144 | 50 K = K+1 |
---|
145 | IF (X(K) .LT. T) GO TO 50 |
---|
146 | C |
---|
147 | C Interchange these elements |
---|
148 | C |
---|
149 | IF (K .LE. L) THEN |
---|
150 | TT = X(L) |
---|
151 | X(L) = X(K) |
---|
152 | X(K) = TT |
---|
153 | GO TO 40 |
---|
154 | ENDIF |
---|
155 | C |
---|
156 | C Save upper and lower subscripts of the array yet to be sorted |
---|
157 | C |
---|
158 | IF (L-I .GT. J-K) THEN |
---|
159 | IL(M) = I |
---|
160 | IU(M) = L |
---|
161 | I = K |
---|
162 | M = M+1 |
---|
163 | ELSE |
---|
164 | IL(M) = K |
---|
165 | IU(M) = J |
---|
166 | J = L |
---|
167 | M = M+1 |
---|
168 | ENDIF |
---|
169 | GO TO 70 |
---|
170 | C |
---|
171 | C Begin again on another portion of the unsorted array |
---|
172 | C |
---|
173 | 60 M = M-1 |
---|
174 | IF (M .EQ. 0) GO TO 190 |
---|
175 | I = IL(M) |
---|
176 | J = IU(M) |
---|
177 | C |
---|
178 | 70 IF (J-I .GE. 1) GO TO 30 |
---|
179 | IF (I .EQ. 1) GO TO 20 |
---|
180 | I = I-1 |
---|
181 | C |
---|
182 | 80 I = I+1 |
---|
183 | IF (I .EQ. J) GO TO 60 |
---|
184 | T = X(I+1) |
---|
185 | IF (X(I) .LE. T) GO TO 80 |
---|
186 | K = I |
---|
187 | C |
---|
188 | 90 X(K+1) = X(K) |
---|
189 | K = K-1 |
---|
190 | IF (T .LT. X(K)) GO TO 90 |
---|
191 | X(K+1) = T |
---|
192 | GO TO 80 |
---|
193 | C |
---|
194 | C Sort X and carry Y along |
---|
195 | C |
---|
196 | 100 M = 1 |
---|
197 | I = 1 |
---|
198 | J = NN |
---|
199 | R = 0.375E0 |
---|
200 | C |
---|
201 | 110 IF (I .EQ. J) GO TO 150 |
---|
202 | IF (R .LE. 0.5898437E0) THEN |
---|
203 | R = R+3.90625E-2 |
---|
204 | ELSE |
---|
205 | R = R-0.21875E0 |
---|
206 | ENDIF |
---|
207 | C |
---|
208 | 120 K = I |
---|
209 | C |
---|
210 | C Select a central element of the array and save it in location T |
---|
211 | C |
---|
212 | IJ = I + INT((J-I)*R) |
---|
213 | T = X(IJ) |
---|
214 | TY = Y(IJ) |
---|
215 | C |
---|
216 | C If first element of array is greater than T, interchange with T |
---|
217 | C |
---|
218 | IF (X(I) .GT. T) THEN |
---|
219 | X(IJ) = X(I) |
---|
220 | X(I) = T |
---|
221 | T = X(IJ) |
---|
222 | Y(IJ) = Y(I) |
---|
223 | Y(I) = TY |
---|
224 | TY = Y(IJ) |
---|
225 | ENDIF |
---|
226 | L = J |
---|
227 | C |
---|
228 | C If last element of array is less than T, interchange with T |
---|
229 | C |
---|
230 | IF (X(J) .LT. T) THEN |
---|
231 | X(IJ) = X(J) |
---|
232 | X(J) = T |
---|
233 | T = X(IJ) |
---|
234 | Y(IJ) = Y(J) |
---|
235 | Y(J) = TY |
---|
236 | TY = Y(IJ) |
---|
237 | C |
---|
238 | C If first element of array is greater than T, interchange with T |
---|
239 | C |
---|
240 | IF (X(I) .GT. T) THEN |
---|
241 | X(IJ) = X(I) |
---|
242 | X(I) = T |
---|
243 | T = X(IJ) |
---|
244 | Y(IJ) = Y(I) |
---|
245 | Y(I) = TY |
---|
246 | TY = Y(IJ) |
---|
247 | ENDIF |
---|
248 | ENDIF |
---|
249 | C |
---|
250 | C Find an element in the second half of the array which is smaller |
---|
251 | C than T |
---|
252 | C |
---|
253 | 130 L = L-1 |
---|
254 | IF (X(L) .GT. T) GO TO 130 |
---|
255 | C |
---|
256 | C Find an element in the first half of the array which is greater |
---|
257 | C than T |
---|
258 | C |
---|
259 | 140 K = K+1 |
---|
260 | IF (X(K) .LT. T) GO TO 140 |
---|
261 | C |
---|
262 | C Interchange these elements |
---|
263 | C |
---|
264 | IF (K .LE. L) THEN |
---|
265 | TT = X(L) |
---|
266 | X(L) = X(K) |
---|
267 | X(K) = TT |
---|
268 | TTY = Y(L) |
---|
269 | Y(L) = Y(K) |
---|
270 | Y(K) = TTY |
---|
271 | GO TO 130 |
---|
272 | ENDIF |
---|
273 | C |
---|
274 | C Save upper and lower subscripts of the array yet to be sorted |
---|
275 | C |
---|
276 | IF (L-I .GT. J-K) THEN |
---|
277 | IL(M) = I |
---|
278 | IU(M) = L |
---|
279 | I = K |
---|
280 | M = M+1 |
---|
281 | ELSE |
---|
282 | IL(M) = K |
---|
283 | IU(M) = J |
---|
284 | J = L |
---|
285 | M = M+1 |
---|
286 | ENDIF |
---|
287 | GO TO 160 |
---|
288 | C |
---|
289 | C Begin again on another portion of the unsorted array |
---|
290 | C |
---|
291 | 150 M = M-1 |
---|
292 | IF (M .EQ. 0) GO TO 190 |
---|
293 | I = IL(M) |
---|
294 | J = IU(M) |
---|
295 | C |
---|
296 | 160 IF (J-I .GE. 1) GO TO 120 |
---|
297 | IF (I .EQ. 1) GO TO 110 |
---|
298 | I = I-1 |
---|
299 | C |
---|
300 | 170 I = I+1 |
---|
301 | IF (I .EQ. J) GO TO 150 |
---|
302 | T = X(I+1) |
---|
303 | TY = Y(I+1) |
---|
304 | IF (X(I) .LE. T) GO TO 170 |
---|
305 | K = I |
---|
306 | C |
---|
307 | 180 X(K+1) = X(K) |
---|
308 | Y(K+1) = Y(K) |
---|
309 | K = K-1 |
---|
310 | IF (T .LT. X(K)) GO TO 180 |
---|
311 | X(K+1) = T |
---|
312 | Y(K+1) = TY |
---|
313 | GO TO 170 |
---|
314 | C |
---|
315 | C Clean up |
---|
316 | C |
---|
317 | 190 IF (KFLAG .LE. -1) THEN |
---|
318 | DO 200 I=1,NN |
---|
319 | X(I) = -X(I) |
---|
320 | 200 CONTINUE |
---|
321 | ENDIF |
---|
322 | RETURN |
---|
323 | END |
---|