LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
slasrt.f
Go to the documentation of this file.
1 *> \brief \b SLASRT sorts numbers in increasing or decreasing order.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download SLASRT + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasrt.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasrt.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasrt.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE SLASRT( ID, N, D, INFO )
22 *
23 * .. Scalar Arguments ..
24 * CHARACTER ID
25 * INTEGER INFO, N
26 * ..
27 * .. Array Arguments ..
28 * REAL D( * )
29 * ..
30 *
31 *
32 *> \par Purpose:
33 * =============
34 *>
35 *> \verbatim
36 *>
37 *> Sort the numbers in D in increasing order (if ID = 'I') or
38 *> in decreasing order (if ID = 'D' ).
39 *>
40 *> Use Quick Sort, reverting to Insertion sort on arrays of
41 *> size <= 20. Dimension of STACK limits N to about 2**32.
42 *> \endverbatim
43 *
44 * Arguments:
45 * ==========
46 *
47 *> \param[in] ID
48 *> \verbatim
49 *> ID is CHARACTER*1
50 *> = 'I': sort D in increasing order;
51 *> = 'D': sort D in decreasing order.
52 *> \endverbatim
53 *>
54 *> \param[in] N
55 *> \verbatim
56 *> N is INTEGER
57 *> The length of the array D.
58 *> \endverbatim
59 *>
60 *> \param[in,out] D
61 *> \verbatim
62 *> D is REAL array, dimension (N)
63 *> On entry, the array to be sorted.
64 *> On exit, D has been sorted into increasing order
65 *> (D(1) <= ... <= D(N) ) or into decreasing order
66 *> (D(1) >= ... >= D(N) ), depending on ID.
67 *> \endverbatim
68 *>
69 *> \param[out] INFO
70 *> \verbatim
71 *> INFO is INTEGER
72 *> = 0: successful exit
73 *> < 0: if INFO = -i, the i-th argument had an illegal value
74 *> \endverbatim
75 *
76 * Authors:
77 * ========
78 *
79 *> \author Univ. of Tennessee
80 *> \author Univ. of California Berkeley
81 *> \author Univ. of Colorado Denver
82 *> \author NAG Ltd.
83 *
84 *> \ingroup auxOTHERcomputational
85 *
86 * =====================================================================
87  SUBROUTINE slasrt( ID, N, D, INFO )
88 *
89 * -- LAPACK computational routine --
90 * -- LAPACK is a software package provided by Univ. of Tennessee, --
91 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
92 *
93 * .. Scalar Arguments ..
94  CHARACTER ID
95  INTEGER INFO, N
96 * ..
97 * .. Array Arguments ..
98  REAL D( * )
99 * ..
100 *
101 * =====================================================================
102 *
103 * .. Parameters ..
104  INTEGER SELECT
105  parameter( SELECT = 20 )
106 * ..
107 * .. Local Scalars ..
108  INTEGER DIR, ENDD, I, J, START, STKPNT
109  REAL D1, D2, D3, DMNMX, TMP
110 * ..
111 * .. Local Arrays ..
112  INTEGER STACK( 2, 32 )
113 * ..
114 * .. External Functions ..
115  LOGICAL LSAME
116  EXTERNAL lsame
117 * ..
118 * .. External Subroutines ..
119  EXTERNAL xerbla
120 * ..
121 * .. Executable Statements ..
122 *
123 * Test the input parameters.
124 *
125  info = 0
126  dir = -1
127  IF( lsame( id, 'D' ) ) THEN
128  dir = 0
129  ELSE IF( lsame( id, 'I' ) ) THEN
130  dir = 1
131  END IF
132  IF( dir.EQ.-1 ) THEN
133  info = -1
134  ELSE IF( n.LT.0 ) THEN
135  info = -2
136  END IF
137  IF( info.NE.0 ) THEN
138  CALL xerbla( 'SLASRT', -info )
139  RETURN
140  END IF
141 *
142 * Quick return if possible
143 *
144  IF( n.LE.1 )
145  $ RETURN
146 *
147  stkpnt = 1
148  stack( 1, 1 ) = 1
149  stack( 2, 1 ) = n
150  10 CONTINUE
151  start = stack( 1, stkpnt )
152  endd = stack( 2, stkpnt )
153  stkpnt = stkpnt - 1
154  IF( endd-start.LE.SELECT .AND. endd-start.GT.0 ) THEN
155 *
156 * Do Insertion sort on D( START:ENDD )
157 *
158  IF( dir.EQ.0 ) THEN
159 *
160 * Sort into decreasing order
161 *
162  DO 30 i = start + 1, endd
163  DO 20 j = i, start + 1, -1
164  IF( d( j ).GT.d( j-1 ) ) THEN
165  dmnmx = d( j )
166  d( j ) = d( j-1 )
167  d( j-1 ) = dmnmx
168  ELSE
169  GO TO 30
170  END IF
171  20 CONTINUE
172  30 CONTINUE
173 *
174  ELSE
175 *
176 * Sort into increasing order
177 *
178  DO 50 i = start + 1, endd
179  DO 40 j = i, start + 1, -1
180  IF( d( j ).LT.d( j-1 ) ) THEN
181  dmnmx = d( j )
182  d( j ) = d( j-1 )
183  d( j-1 ) = dmnmx
184  ELSE
185  GO TO 50
186  END IF
187  40 CONTINUE
188  50 CONTINUE
189 *
190  END IF
191 *
192  ELSE IF( endd-start.GT.SELECT ) THEN
193 *
194 * Partition D( START:ENDD ) and stack parts, largest one first
195 *
196 * Choose partition entry as median of 3
197 *
198  d1 = d( start )
199  d2 = d( endd )
200  i = ( start+endd ) / 2
201  d3 = d( i )
202  IF( d1.LT.d2 ) THEN
203  IF( d3.LT.d1 ) THEN
204  dmnmx = d1
205  ELSE IF( d3.LT.d2 ) THEN
206  dmnmx = d3
207  ELSE
208  dmnmx = d2
209  END IF
210  ELSE
211  IF( d3.LT.d2 ) THEN
212  dmnmx = d2
213  ELSE IF( d3.LT.d1 ) THEN
214  dmnmx = d3
215  ELSE
216  dmnmx = d1
217  END IF
218  END IF
219 *
220  IF( dir.EQ.0 ) THEN
221 *
222 * Sort into decreasing order
223 *
224  i = start - 1
225  j = endd + 1
226  60 CONTINUE
227  70 CONTINUE
228  j = j - 1
229  IF( d( j ).LT.dmnmx )
230  $ GO TO 70
231  80 CONTINUE
232  i = i + 1
233  IF( d( i ).GT.dmnmx )
234  $ GO TO 80
235  IF( i.LT.j ) THEN
236  tmp = d( i )
237  d( i ) = d( j )
238  d( j ) = tmp
239  GO TO 60
240  END IF
241  IF( j-start.GT.endd-j-1 ) THEN
242  stkpnt = stkpnt + 1
243  stack( 1, stkpnt ) = start
244  stack( 2, stkpnt ) = j
245  stkpnt = stkpnt + 1
246  stack( 1, stkpnt ) = j + 1
247  stack( 2, stkpnt ) = endd
248  ELSE
249  stkpnt = stkpnt + 1
250  stack( 1, stkpnt ) = j + 1
251  stack( 2, stkpnt ) = endd
252  stkpnt = stkpnt + 1
253  stack( 1, stkpnt ) = start
254  stack( 2, stkpnt ) = j
255  END IF
256  ELSE
257 *
258 * Sort into increasing order
259 *
260  i = start - 1
261  j = endd + 1
262  90 CONTINUE
263  100 CONTINUE
264  j = j - 1
265  IF( d( j ).GT.dmnmx )
266  $ GO TO 100
267  110 CONTINUE
268  i = i + 1
269  IF( d( i ).LT.dmnmx )
270  $ GO TO 110
271  IF( i.LT.j ) THEN
272  tmp = d( i )
273  d( i ) = d( j )
274  d( j ) = tmp
275  GO TO 90
276  END IF
277  IF( j-start.GT.endd-j-1 ) THEN
278  stkpnt = stkpnt + 1
279  stack( 1, stkpnt ) = start
280  stack( 2, stkpnt ) = j
281  stkpnt = stkpnt + 1
282  stack( 1, stkpnt ) = j + 1
283  stack( 2, stkpnt ) = endd
284  ELSE
285  stkpnt = stkpnt + 1
286  stack( 1, stkpnt ) = j + 1
287  stack( 2, stkpnt ) = endd
288  stkpnt = stkpnt + 1
289  stack( 1, stkpnt ) = start
290  stack( 2, stkpnt ) = j
291  END IF
292  END IF
293  END IF
294  IF( stkpnt.GT.0 )
295  $ GO TO 10
296  RETURN
297 *
298 * End of SLASRT
299 *
300  END
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
subroutine slasrt(ID, N, D, INFO)
SLASRT sorts numbers in increasing or decreasing order.
Definition: slasrt.f:88