github.com/gonum/lapack@v0.0.0-20181123203213-e4cdc5a0bff9/internal/testdata/dlasqtest/dlasrt.f (about) 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 *> \date September 2012 85 * 86 *> \ingroup auxOTHERcomputational 87 * 88 * ===================================================================== 89 SUBROUTINE DLASRT( ID, N, D, INFO ) 90 * 91 * -- LAPACK computational routine (version 3.4.2) -- 92 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 93 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 94 * September 2012 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