LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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*> \ingroup lasrt
85*
86* =====================================================================
87 SUBROUTINE dlasrt( 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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( 'DLASRT', -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 DLASRT
299*
300 END
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
dlasrt
subroutine dlasrt(id, n, d, info)
DLASRT sorts numbers in increasing or decreasing order.
Definition dlasrt.f:88