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 auxOTHERcomputational
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
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlasrt.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack