![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b DLASRT 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download DLASRT + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasrt.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasrt.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasrt.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE DLASRT( ID, N, D, INFO ) 00022 * 00023 * .. Scalar Arguments .. 00024 * CHARACTER ID 00025 * INTEGER INFO, N 00026 * .. 00027 * .. Array Arguments .. 00028 * DOUBLE PRECISION D( * ) 00029 * .. 00030 * 00031 * 00032 *> \par Purpose: 00033 * ============= 00034 *> 00035 *> \verbatim 00036 *> 00037 *> Sort the numbers in D in increasing order (if ID = 'I') or 00038 *> in decreasing order (if ID = 'D' ). 00039 *> 00040 *> Use Quick Sort, reverting to Insertion sort on arrays of 00041 *> size <= 20. Dimension of STACK limits N to about 2**32. 00042 *> \endverbatim 00043 * 00044 * Arguments: 00045 * ========== 00046 * 00047 *> \param[in] ID 00048 *> \verbatim 00049 *> ID is CHARACTER*1 00050 *> = 'I': sort D in increasing order; 00051 *> = 'D': sort D in decreasing order. 00052 *> \endverbatim 00053 *> 00054 *> \param[in] N 00055 *> \verbatim 00056 *> N is INTEGER 00057 *> The length of the array D. 00058 *> \endverbatim 00059 *> 00060 *> \param[in,out] D 00061 *> \verbatim 00062 *> D is DOUBLE PRECISION array, dimension (N) 00063 *> On entry, the array to be sorted. 00064 *> On exit, D has been sorted into increasing order 00065 *> (D(1) <= ... <= D(N) ) or into decreasing order 00066 *> (D(1) >= ... >= D(N) ), depending on ID. 00067 *> \endverbatim 00068 *> 00069 *> \param[out] INFO 00070 *> \verbatim 00071 *> INFO is INTEGER 00072 *> = 0: successful exit 00073 *> < 0: if INFO = -i, the i-th argument had an illegal value 00074 *> \endverbatim 00075 * 00076 * Authors: 00077 * ======== 00078 * 00079 *> \author Univ. of Tennessee 00080 *> \author Univ. of California Berkeley 00081 *> \author Univ. of Colorado Denver 00082 *> \author NAG Ltd. 00083 * 00084 *> \date November 2011 00085 * 00086 *> \ingroup auxOTHERcomputational 00087 * 00088 * ===================================================================== 00089 SUBROUTINE DLASRT( ID, N, D, INFO ) 00090 * 00091 * -- LAPACK computational routine (version 3.4.0) -- 00092 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00093 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00094 * November 2011 00095 * 00096 * .. Scalar Arguments .. 00097 CHARACTER ID 00098 INTEGER INFO, N 00099 * .. 00100 * .. Array Arguments .. 00101 DOUBLE PRECISION D( * ) 00102 * .. 00103 * 00104 * ===================================================================== 00105 * 00106 * .. Parameters .. 00107 INTEGER SELECT 00108 PARAMETER ( SELECT = 20 ) 00109 * .. 00110 * .. Local Scalars .. 00111 INTEGER DIR, ENDD, I, J, START, STKPNT 00112 DOUBLE PRECISION D1, D2, D3, DMNMX, TMP 00113 * .. 00114 * .. Local Arrays .. 00115 INTEGER STACK( 2, 32 ) 00116 * .. 00117 * .. External Functions .. 00118 LOGICAL LSAME 00119 EXTERNAL LSAME 00120 * .. 00121 * .. External Subroutines .. 00122 EXTERNAL XERBLA 00123 * .. 00124 * .. Executable Statements .. 00125 * 00126 * Test the input paramters. 00127 * 00128 INFO = 0 00129 DIR = -1 00130 IF( LSAME( ID, 'D' ) ) THEN 00131 DIR = 0 00132 ELSE IF( LSAME( ID, 'I' ) ) THEN 00133 DIR = 1 00134 END IF 00135 IF( DIR.EQ.-1 ) THEN 00136 INFO = -1 00137 ELSE IF( N.LT.0 ) THEN 00138 INFO = -2 00139 END IF 00140 IF( INFO.NE.0 ) THEN 00141 CALL XERBLA( 'DLASRT', -INFO ) 00142 RETURN 00143 END IF 00144 * 00145 * Quick return if possible 00146 * 00147 IF( N.LE.1 ) 00148 $ RETURN 00149 * 00150 STKPNT = 1 00151 STACK( 1, 1 ) = 1 00152 STACK( 2, 1 ) = N 00153 10 CONTINUE 00154 START = STACK( 1, STKPNT ) 00155 ENDD = STACK( 2, STKPNT ) 00156 STKPNT = STKPNT - 1 00157 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN 00158 * 00159 * Do Insertion sort on D( START:ENDD ) 00160 * 00161 IF( DIR.EQ.0 ) THEN 00162 * 00163 * Sort into decreasing order 00164 * 00165 DO 30 I = START + 1, ENDD 00166 DO 20 J = I, START + 1, -1 00167 IF( D( J ).GT.D( J-1 ) ) THEN 00168 DMNMX = D( J ) 00169 D( J ) = D( J-1 ) 00170 D( J-1 ) = DMNMX 00171 ELSE 00172 GO TO 30 00173 END IF 00174 20 CONTINUE 00175 30 CONTINUE 00176 * 00177 ELSE 00178 * 00179 * Sort into increasing order 00180 * 00181 DO 50 I = START + 1, ENDD 00182 DO 40 J = I, START + 1, -1 00183 IF( D( J ).LT.D( J-1 ) ) THEN 00184 DMNMX = D( J ) 00185 D( J ) = D( J-1 ) 00186 D( J-1 ) = DMNMX 00187 ELSE 00188 GO TO 50 00189 END IF 00190 40 CONTINUE 00191 50 CONTINUE 00192 * 00193 END IF 00194 * 00195 ELSE IF( ENDD-START.GT.SELECT ) THEN 00196 * 00197 * Partition D( START:ENDD ) and stack parts, largest one first 00198 * 00199 * Choose partition entry as median of 3 00200 * 00201 D1 = D( START ) 00202 D2 = D( ENDD ) 00203 I = ( START+ENDD ) / 2 00204 D3 = D( I ) 00205 IF( D1.LT.D2 ) THEN 00206 IF( D3.LT.D1 ) THEN 00207 DMNMX = D1 00208 ELSE IF( D3.LT.D2 ) THEN 00209 DMNMX = D3 00210 ELSE 00211 DMNMX = D2 00212 END IF 00213 ELSE 00214 IF( D3.LT.D2 ) THEN 00215 DMNMX = D2 00216 ELSE IF( D3.LT.D1 ) THEN 00217 DMNMX = D3 00218 ELSE 00219 DMNMX = D1 00220 END IF 00221 END IF 00222 * 00223 IF( DIR.EQ.0 ) THEN 00224 * 00225 * Sort into decreasing order 00226 * 00227 I = START - 1 00228 J = ENDD + 1 00229 60 CONTINUE 00230 70 CONTINUE 00231 J = J - 1 00232 IF( D( J ).LT.DMNMX ) 00233 $ GO TO 70 00234 80 CONTINUE 00235 I = I + 1 00236 IF( D( I ).GT.DMNMX ) 00237 $ GO TO 80 00238 IF( I.LT.J ) THEN 00239 TMP = D( I ) 00240 D( I ) = D( J ) 00241 D( J ) = TMP 00242 GO TO 60 00243 END IF 00244 IF( J-START.GT.ENDD-J-1 ) THEN 00245 STKPNT = STKPNT + 1 00246 STACK( 1, STKPNT ) = START 00247 STACK( 2, STKPNT ) = J 00248 STKPNT = STKPNT + 1 00249 STACK( 1, STKPNT ) = J + 1 00250 STACK( 2, STKPNT ) = ENDD 00251 ELSE 00252 STKPNT = STKPNT + 1 00253 STACK( 1, STKPNT ) = J + 1 00254 STACK( 2, STKPNT ) = ENDD 00255 STKPNT = STKPNT + 1 00256 STACK( 1, STKPNT ) = START 00257 STACK( 2, STKPNT ) = J 00258 END IF 00259 ELSE 00260 * 00261 * Sort into increasing order 00262 * 00263 I = START - 1 00264 J = ENDD + 1 00265 90 CONTINUE 00266 100 CONTINUE 00267 J = J - 1 00268 IF( D( J ).GT.DMNMX ) 00269 $ GO TO 100 00270 110 CONTINUE 00271 I = I + 1 00272 IF( D( I ).LT.DMNMX ) 00273 $ GO TO 110 00274 IF( I.LT.J ) THEN 00275 TMP = D( I ) 00276 D( I ) = D( J ) 00277 D( J ) = TMP 00278 GO TO 90 00279 END IF 00280 IF( J-START.GT.ENDD-J-1 ) THEN 00281 STKPNT = STKPNT + 1 00282 STACK( 1, STKPNT ) = START 00283 STACK( 2, STKPNT ) = J 00284 STKPNT = STKPNT + 1 00285 STACK( 1, STKPNT ) = J + 1 00286 STACK( 2, STKPNT ) = ENDD 00287 ELSE 00288 STKPNT = STKPNT + 1 00289 STACK( 1, STKPNT ) = J + 1 00290 STACK( 2, STKPNT ) = ENDD 00291 STKPNT = STKPNT + 1 00292 STACK( 1, STKPNT ) = START 00293 STACK( 2, STKPNT ) = J 00294 END IF 00295 END IF 00296 END IF 00297 IF( STKPNT.GT.0 ) 00298 $ GO TO 10 00299 RETURN 00300 * 00301 * End of DLASRT 00302 * 00303 END