Annotation of rpl/lapack/lapack/dlasrt.f, revision 1.1
1.1 ! bertrand 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