1: *> \brief \b DLASRT
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 November 2011
85: *
86: *> \ingroup auxOTHERcomputational
87: *
88: * =====================================================================
89: SUBROUTINE DLASRT( ID, N, D, INFO )
90: *
91: * -- LAPACK computational routine (version 3.4.0) --
92: * -- LAPACK is a software package provided by Univ. of Tennessee, --
93: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94: * November 2011
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
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