File:
[local] /
rpl /
lapack /
lapack /
dlasrt.f
Revision
1.7:
download - view:
text,
annotated -
select for diffs -
revision graph
Tue Dec 21 13:53:33 2010 UTC (13 years, 5 months ago) by
bertrand
Branches:
MAIN
CVS tags:
rpl-4_1_3,
rpl-4_1_2,
rpl-4_1_1,
rpl-4_1_0,
rpl-4_0_24,
rpl-4_0_22,
rpl-4_0_21,
rpl-4_0_20,
rpl-4_0,
HEAD
Mise à jour de lapack vers la version 3.3.0.
1: SUBROUTINE DLASRT( ID, N, D, INFO )
2: *
3: * -- LAPACK routine (version 3.2) --
4: * -- LAPACK is a software package provided by Univ. of Tennessee, --
5: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6: * November 2006
7: *
8: * .. Scalar Arguments ..
9: CHARACTER ID
10: INTEGER INFO, N
11: * ..
12: * .. Array Arguments ..
13: DOUBLE PRECISION D( * )
14: * ..
15: *
16: * Purpose
17: * =======
18: *
19: * Sort the numbers in D in increasing order (if ID = 'I') or
20: * in decreasing order (if ID = 'D' ).
21: *
22: * Use Quick Sort, reverting to Insertion sort on arrays of
23: * size <= 20. Dimension of STACK limits N to about 2**32.
24: *
25: * Arguments
26: * =========
27: *
28: * ID (input) CHARACTER*1
29: * = 'I': sort D in increasing order;
30: * = 'D': sort D in decreasing order.
31: *
32: * N (input) INTEGER
33: * The length of the array D.
34: *
35: * D (input/output) DOUBLE PRECISION array, dimension (N)
36: * On entry, the array to be sorted.
37: * On exit, D has been sorted into increasing order
38: * (D(1) <= ... <= D(N) ) or into decreasing order
39: * (D(1) >= ... >= D(N) ), depending on ID.
40: *
41: * INFO (output) INTEGER
42: * = 0: successful exit
43: * < 0: if INFO = -i, the i-th argument had an illegal value
44: *
45: * =====================================================================
46: *
47: * .. Parameters ..
48: INTEGER SELECT
49: PARAMETER ( SELECT = 20 )
50: * ..
51: * .. Local Scalars ..
52: INTEGER DIR, ENDD, I, J, START, STKPNT
53: DOUBLE PRECISION D1, D2, D3, DMNMX, TMP
54: * ..
55: * .. Local Arrays ..
56: INTEGER STACK( 2, 32 )
57: * ..
58: * .. External Functions ..
59: LOGICAL LSAME
60: EXTERNAL LSAME
61: * ..
62: * .. External Subroutines ..
63: EXTERNAL XERBLA
64: * ..
65: * .. Executable Statements ..
66: *
67: * Test the input paramters.
68: *
69: INFO = 0
70: DIR = -1
71: IF( LSAME( ID, 'D' ) ) THEN
72: DIR = 0
73: ELSE IF( LSAME( ID, 'I' ) ) THEN
74: DIR = 1
75: END IF
76: IF( DIR.EQ.-1 ) THEN
77: INFO = -1
78: ELSE IF( N.LT.0 ) THEN
79: INFO = -2
80: END IF
81: IF( INFO.NE.0 ) THEN
82: CALL XERBLA( 'DLASRT', -INFO )
83: RETURN
84: END IF
85: *
86: * Quick return if possible
87: *
88: IF( N.LE.1 )
89: $ RETURN
90: *
91: STKPNT = 1
92: STACK( 1, 1 ) = 1
93: STACK( 2, 1 ) = N
94: 10 CONTINUE
95: START = STACK( 1, STKPNT )
96: ENDD = STACK( 2, STKPNT )
97: STKPNT = STKPNT - 1
98: IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
99: *
100: * Do Insertion sort on D( START:ENDD )
101: *
102: IF( DIR.EQ.0 ) THEN
103: *
104: * Sort into decreasing order
105: *
106: DO 30 I = START + 1, ENDD
107: DO 20 J = I, START + 1, -1
108: IF( D( J ).GT.D( J-1 ) ) THEN
109: DMNMX = D( J )
110: D( J ) = D( J-1 )
111: D( J-1 ) = DMNMX
112: ELSE
113: GO TO 30
114: END IF
115: 20 CONTINUE
116: 30 CONTINUE
117: *
118: ELSE
119: *
120: * Sort into increasing order
121: *
122: DO 50 I = START + 1, ENDD
123: DO 40 J = I, START + 1, -1
124: IF( D( J ).LT.D( J-1 ) ) THEN
125: DMNMX = D( J )
126: D( J ) = D( J-1 )
127: D( J-1 ) = DMNMX
128: ELSE
129: GO TO 50
130: END IF
131: 40 CONTINUE
132: 50 CONTINUE
133: *
134: END IF
135: *
136: ELSE IF( ENDD-START.GT.SELECT ) THEN
137: *
138: * Partition D( START:ENDD ) and stack parts, largest one first
139: *
140: * Choose partition entry as median of 3
141: *
142: D1 = D( START )
143: D2 = D( ENDD )
144: I = ( START+ENDD ) / 2
145: D3 = D( I )
146: IF( D1.LT.D2 ) THEN
147: IF( D3.LT.D1 ) THEN
148: DMNMX = D1
149: ELSE IF( D3.LT.D2 ) THEN
150: DMNMX = D3
151: ELSE
152: DMNMX = D2
153: END IF
154: ELSE
155: IF( D3.LT.D2 ) THEN
156: DMNMX = D2
157: ELSE IF( D3.LT.D1 ) THEN
158: DMNMX = D3
159: ELSE
160: DMNMX = D1
161: END IF
162: END IF
163: *
164: IF( DIR.EQ.0 ) THEN
165: *
166: * Sort into decreasing order
167: *
168: I = START - 1
169: J = ENDD + 1
170: 60 CONTINUE
171: 70 CONTINUE
172: J = J - 1
173: IF( D( J ).LT.DMNMX )
174: $ GO TO 70
175: 80 CONTINUE
176: I = I + 1
177: IF( D( I ).GT.DMNMX )
178: $ GO TO 80
179: IF( I.LT.J ) THEN
180: TMP = D( I )
181: D( I ) = D( J )
182: D( J ) = TMP
183: GO TO 60
184: END IF
185: IF( J-START.GT.ENDD-J-1 ) THEN
186: STKPNT = STKPNT + 1
187: STACK( 1, STKPNT ) = START
188: STACK( 2, STKPNT ) = J
189: STKPNT = STKPNT + 1
190: STACK( 1, STKPNT ) = J + 1
191: STACK( 2, STKPNT ) = ENDD
192: ELSE
193: STKPNT = STKPNT + 1
194: STACK( 1, STKPNT ) = J + 1
195: STACK( 2, STKPNT ) = ENDD
196: STKPNT = STKPNT + 1
197: STACK( 1, STKPNT ) = START
198: STACK( 2, STKPNT ) = J
199: END IF
200: ELSE
201: *
202: * Sort into increasing order
203: *
204: I = START - 1
205: J = ENDD + 1
206: 90 CONTINUE
207: 100 CONTINUE
208: J = J - 1
209: IF( D( J ).GT.DMNMX )
210: $ GO TO 100
211: 110 CONTINUE
212: I = I + 1
213: IF( D( I ).LT.DMNMX )
214: $ GO TO 110
215: IF( I.LT.J ) THEN
216: TMP = D( I )
217: D( I ) = D( J )
218: D( J ) = TMP
219: GO TO 90
220: END IF
221: IF( J-START.GT.ENDD-J-1 ) THEN
222: STKPNT = STKPNT + 1
223: STACK( 1, STKPNT ) = START
224: STACK( 2, STKPNT ) = J
225: STKPNT = STKPNT + 1
226: STACK( 1, STKPNT ) = J + 1
227: STACK( 2, STKPNT ) = ENDD
228: ELSE
229: STKPNT = STKPNT + 1
230: STACK( 1, STKPNT ) = J + 1
231: STACK( 2, STKPNT ) = ENDD
232: STKPNT = STKPNT + 1
233: STACK( 1, STKPNT ) = START
234: STACK( 2, STKPNT ) = J
235: END IF
236: END IF
237: END IF
238: IF( STKPNT.GT.0 )
239: $ GO TO 10
240: RETURN
241: *
242: * End of DLASRT
243: *
244: 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