LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
dlasrt.f
Go to the documentation of this file.
1 *> \brief \b DLASRT 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 DLASRT + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasrt.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasrt.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasrt.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE DLASRT( ID, N, D, INFO )
22 *
23 * .. Scalar Arguments ..
24 * CHARACTER ID
25 * INTEGER INFO, N
26 * ..
27 * .. Array Arguments ..
28 * DOUBLE PRECISION 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 DOUBLE PRECISION 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 *> \date September 2012
85 *
86 *> \ingroup auxOTHERcomputational
87 *
88 * =====================================================================
89  SUBROUTINE dlasrt( ID, N, D, INFO )
90 *
91 * -- LAPACK computational routine (version 3.4.2) --
92 * -- LAPACK is a software package provided by Univ. of Tennessee, --
93 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94 * September 2012
95 *
96 * .. Scalar Arguments ..
97  CHARACTER id
98  INTEGER info, n
99 * ..
100 * .. Array Arguments ..
101  DOUBLE PRECISION d( * )
102 * ..
103 *
104 * =====================================================================
105 *
106 * .. Parameters ..
107  INTEGER select
108  parameter( SELECT = 20 )
109 * ..
110 * .. Local Scalars ..
111  INTEGER dir, endd, i, j, start, stkpnt
112  DOUBLE PRECISION d1, d2, d3, dmnmx, tmp
113 * ..
114 * .. Local Arrays ..
115  INTEGER stack( 2, 32 )
116 * ..
117 * .. External Functions ..
118  LOGICAL lsame
119  EXTERNAL lsame
120 * ..
121 * .. External Subroutines ..
122  EXTERNAL xerbla
123 * ..
124 * .. Executable Statements ..
125 *
126 * Test the input paramters.
127 *
128  info = 0
129  dir = -1
130  IF( lsame( id, 'D' ) ) THEN
131  dir = 0
132  ELSE IF( lsame( id, 'I' ) ) THEN
133  dir = 1
134  END IF
135  IF( dir.EQ.-1 ) THEN
136  info = -1
137  ELSE IF( n.LT.0 ) THEN
138  info = -2
139  END IF
140  IF( info.NE.0 ) THEN
141  CALL xerbla( 'DLASRT', -info )
142  return
143  END IF
144 *
145 * Quick return if possible
146 *
147  IF( n.LE.1 )
148  $ return
149 *
150  stkpnt = 1
151  stack( 1, 1 ) = 1
152  stack( 2, 1 ) = n
153  10 continue
154  start = stack( 1, stkpnt )
155  endd = stack( 2, stkpnt )
156  stkpnt = stkpnt - 1
157  IF( endd-start.LE.SELECT .AND. endd-start.GT.0 ) THEN
158 *
159 * Do Insertion sort on D( START:ENDD )
160 *
161  IF( dir.EQ.0 ) THEN
162 *
163 * Sort into decreasing order
164 *
165  DO 30 i = start + 1, endd
166  DO 20 j = i, start + 1, -1
167  IF( d( j ).GT.d( j-1 ) ) THEN
168  dmnmx = d( j )
169  d( j ) = d( j-1 )
170  d( j-1 ) = dmnmx
171  ELSE
172  go to 30
173  END IF
174  20 continue
175  30 continue
176 *
177  ELSE
178 *
179 * Sort into increasing order
180 *
181  DO 50 i = start + 1, endd
182  DO 40 j = i, start + 1, -1
183  IF( d( j ).LT.d( j-1 ) ) THEN
184  dmnmx = d( j )
185  d( j ) = d( j-1 )
186  d( j-1 ) = dmnmx
187  ELSE
188  go to 50
189  END IF
190  40 continue
191  50 continue
192 *
193  END IF
194 *
195  ELSE IF( endd-start.GT.SELECT ) THEN
196 *
197 * Partition D( START:ENDD ) and stack parts, largest one first
198 *
199 * Choose partition entry as median of 3
200 *
201  d1 = d( start )
202  d2 = d( endd )
203  i = ( start+endd ) / 2
204  d3 = d( i )
205  IF( d1.LT.d2 ) THEN
206  IF( d3.LT.d1 ) THEN
207  dmnmx = d1
208  ELSE IF( d3.LT.d2 ) THEN
209  dmnmx = d3
210  ELSE
211  dmnmx = d2
212  END IF
213  ELSE
214  IF( d3.LT.d2 ) THEN
215  dmnmx = d2
216  ELSE IF( d3.LT.d1 ) THEN
217  dmnmx = d3
218  ELSE
219  dmnmx = d1
220  END IF
221  END IF
222 *
223  IF( dir.EQ.0 ) THEN
224 *
225 * Sort into decreasing order
226 *
227  i = start - 1
228  j = endd + 1
229  60 continue
230  70 continue
231  j = j - 1
232  IF( d( j ).LT.dmnmx )
233  $ go to 70
234  80 continue
235  i = i + 1
236  IF( d( i ).GT.dmnmx )
237  $ go to 80
238  IF( i.LT.j ) THEN
239  tmp = d( i )
240  d( i ) = d( j )
241  d( j ) = tmp
242  go to 60
243  END IF
244  IF( j-start.GT.endd-j-1 ) THEN
245  stkpnt = stkpnt + 1
246  stack( 1, stkpnt ) = start
247  stack( 2, stkpnt ) = j
248  stkpnt = stkpnt + 1
249  stack( 1, stkpnt ) = j + 1
250  stack( 2, stkpnt ) = endd
251  ELSE
252  stkpnt = stkpnt + 1
253  stack( 1, stkpnt ) = j + 1
254  stack( 2, stkpnt ) = endd
255  stkpnt = stkpnt + 1
256  stack( 1, stkpnt ) = start
257  stack( 2, stkpnt ) = j
258  END IF
259  ELSE
260 *
261 * Sort into increasing order
262 *
263  i = start - 1
264  j = endd + 1
265  90 continue
266  100 continue
267  j = j - 1
268  IF( d( j ).GT.dmnmx )
269  $ go to 100
270  110 continue
271  i = i + 1
272  IF( d( i ).LT.dmnmx )
273  $ go to 110
274  IF( i.LT.j ) THEN
275  tmp = d( i )
276  d( i ) = d( j )
277  d( j ) = tmp
278  go to 90
279  END IF
280  IF( j-start.GT.endd-j-1 ) THEN
281  stkpnt = stkpnt + 1
282  stack( 1, stkpnt ) = start
283  stack( 2, stkpnt ) = j
284  stkpnt = stkpnt + 1
285  stack( 1, stkpnt ) = j + 1
286  stack( 2, stkpnt ) = endd
287  ELSE
288  stkpnt = stkpnt + 1
289  stack( 1, stkpnt ) = j + 1
290  stack( 2, stkpnt ) = endd
291  stkpnt = stkpnt + 1
292  stack( 1, stkpnt ) = start
293  stack( 2, stkpnt ) = j
294  END IF
295  END IF
296  END IF
297  IF( stkpnt.GT.0 )
298  $ go to 10
299  return
300 *
301 * End of DLASRT
302 *
303  END