Annotation of rpl/lapack/lapack/dlasrt.f, revision 1.8
1.8 ! bertrand 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: * =====================================================================
1.1 bertrand 89: SUBROUTINE DLASRT( ID, N, D, INFO )
90: *
1.8 ! bertrand 91: * -- LAPACK computational routine (version 3.4.0) --
1.1 bertrand 92: * -- LAPACK is a software package provided by Univ. of Tennessee, --
93: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.8 ! bertrand 94: * November 2011
1.1 bertrand 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