|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SLASRT( ID, N, D, INFO ) 00002 * 00003 * -- LAPACK routine (version 3.2) -- 00004 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00005 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 CHARACTER ID 00010 INTEGER INFO, N 00011 * .. 00012 * .. Array Arguments .. 00013 REAL D( * ) 00014 * .. 00015 * 00016 * Purpose 00017 * ======= 00018 * 00019 * Sort the numbers in D in increasing order (if ID = 'I') or 00020 * in decreasing order (if ID = 'D' ). 00021 * 00022 * Use Quick Sort, reverting to Insertion sort on arrays of 00023 * size <= 20. Dimension of STACK limits N to about 2**32. 00024 * 00025 * Arguments 00026 * ========= 00027 * 00028 * ID (input) CHARACTER*1 00029 * = 'I': sort D in increasing order; 00030 * = 'D': sort D in decreasing order. 00031 * 00032 * N (input) INTEGER 00033 * The length of the array D. 00034 * 00035 * D (input/output) REAL array, dimension (N) 00036 * On entry, the array to be sorted. 00037 * On exit, D has been sorted into increasing order 00038 * (D(1) <= ... <= D(N) ) or into decreasing order 00039 * (D(1) >= ... >= D(N) ), depending on ID. 00040 * 00041 * INFO (output) INTEGER 00042 * = 0: successful exit 00043 * < 0: if INFO = -i, the i-th argument had an illegal value 00044 * 00045 * ===================================================================== 00046 * 00047 * .. Parameters .. 00048 INTEGER SELECT 00049 PARAMETER ( SELECT = 20 ) 00050 * .. 00051 * .. Local Scalars .. 00052 INTEGER DIR, ENDD, I, J, START, STKPNT 00053 REAL D1, D2, D3, DMNMX, TMP 00054 * .. 00055 * .. Local Arrays .. 00056 INTEGER STACK( 2, 32 ) 00057 * .. 00058 * .. External Functions .. 00059 LOGICAL LSAME 00060 EXTERNAL LSAME 00061 * .. 00062 * .. External Subroutines .. 00063 EXTERNAL XERBLA 00064 * .. 00065 * .. Executable Statements .. 00066 * 00067 * Test the input paramters. 00068 * 00069 INFO = 0 00070 DIR = -1 00071 IF( LSAME( ID, 'D' ) ) THEN 00072 DIR = 0 00073 ELSE IF( LSAME( ID, 'I' ) ) THEN 00074 DIR = 1 00075 END IF 00076 IF( DIR.EQ.-1 ) THEN 00077 INFO = -1 00078 ELSE IF( N.LT.0 ) THEN 00079 INFO = -2 00080 END IF 00081 IF( INFO.NE.0 ) THEN 00082 CALL XERBLA( 'SLASRT', -INFO ) 00083 RETURN 00084 END IF 00085 * 00086 * Quick return if possible 00087 * 00088 IF( N.LE.1 ) 00089 $ RETURN 00090 * 00091 STKPNT = 1 00092 STACK( 1, 1 ) = 1 00093 STACK( 2, 1 ) = N 00094 10 CONTINUE 00095 START = STACK( 1, STKPNT ) 00096 ENDD = STACK( 2, STKPNT ) 00097 STKPNT = STKPNT - 1 00098 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN 00099 * 00100 * Do Insertion sort on D( START:ENDD ) 00101 * 00102 IF( DIR.EQ.0 ) THEN 00103 * 00104 * Sort into decreasing order 00105 * 00106 DO 30 I = START + 1, ENDD 00107 DO 20 J = I, START + 1, -1 00108 IF( D( J ).GT.D( J-1 ) ) THEN 00109 DMNMX = D( J ) 00110 D( J ) = D( J-1 ) 00111 D( J-1 ) = DMNMX 00112 ELSE 00113 GO TO 30 00114 END IF 00115 20 CONTINUE 00116 30 CONTINUE 00117 * 00118 ELSE 00119 * 00120 * Sort into increasing order 00121 * 00122 DO 50 I = START + 1, ENDD 00123 DO 40 J = I, START + 1, -1 00124 IF( D( J ).LT.D( J-1 ) ) THEN 00125 DMNMX = D( J ) 00126 D( J ) = D( J-1 ) 00127 D( J-1 ) = DMNMX 00128 ELSE 00129 GO TO 50 00130 END IF 00131 40 CONTINUE 00132 50 CONTINUE 00133 * 00134 END IF 00135 * 00136 ELSE IF( ENDD-START.GT.SELECT ) THEN 00137 * 00138 * Partition D( START:ENDD ) and stack parts, largest one first 00139 * 00140 * Choose partition entry as median of 3 00141 * 00142 D1 = D( START ) 00143 D2 = D( ENDD ) 00144 I = ( START+ENDD ) / 2 00145 D3 = D( I ) 00146 IF( D1.LT.D2 ) THEN 00147 IF( D3.LT.D1 ) THEN 00148 DMNMX = D1 00149 ELSE IF( D3.LT.D2 ) THEN 00150 DMNMX = D3 00151 ELSE 00152 DMNMX = D2 00153 END IF 00154 ELSE 00155 IF( D3.LT.D2 ) THEN 00156 DMNMX = D2 00157 ELSE IF( D3.LT.D1 ) THEN 00158 DMNMX = D3 00159 ELSE 00160 DMNMX = D1 00161 END IF 00162 END IF 00163 * 00164 IF( DIR.EQ.0 ) THEN 00165 * 00166 * Sort into decreasing order 00167 * 00168 I = START - 1 00169 J = ENDD + 1 00170 60 CONTINUE 00171 70 CONTINUE 00172 J = J - 1 00173 IF( D( J ).LT.DMNMX ) 00174 $ GO TO 70 00175 80 CONTINUE 00176 I = I + 1 00177 IF( D( I ).GT.DMNMX ) 00178 $ GO TO 80 00179 IF( I.LT.J ) THEN 00180 TMP = D( I ) 00181 D( I ) = D( J ) 00182 D( J ) = TMP 00183 GO TO 60 00184 END IF 00185 IF( J-START.GT.ENDD-J-1 ) THEN 00186 STKPNT = STKPNT + 1 00187 STACK( 1, STKPNT ) = START 00188 STACK( 2, STKPNT ) = J 00189 STKPNT = STKPNT + 1 00190 STACK( 1, STKPNT ) = J + 1 00191 STACK( 2, STKPNT ) = ENDD 00192 ELSE 00193 STKPNT = STKPNT + 1 00194 STACK( 1, STKPNT ) = J + 1 00195 STACK( 2, STKPNT ) = ENDD 00196 STKPNT = STKPNT + 1 00197 STACK( 1, STKPNT ) = START 00198 STACK( 2, STKPNT ) = J 00199 END IF 00200 ELSE 00201 * 00202 * Sort into increasing order 00203 * 00204 I = START - 1 00205 J = ENDD + 1 00206 90 CONTINUE 00207 100 CONTINUE 00208 J = J - 1 00209 IF( D( J ).GT.DMNMX ) 00210 $ GO TO 100 00211 110 CONTINUE 00212 I = I + 1 00213 IF( D( I ).LT.DMNMX ) 00214 $ GO TO 110 00215 IF( I.LT.J ) THEN 00216 TMP = D( I ) 00217 D( I ) = D( J ) 00218 D( J ) = TMP 00219 GO TO 90 00220 END IF 00221 IF( J-START.GT.ENDD-J-1 ) THEN 00222 STKPNT = STKPNT + 1 00223 STACK( 1, STKPNT ) = START 00224 STACK( 2, STKPNT ) = J 00225 STKPNT = STKPNT + 1 00226 STACK( 1, STKPNT ) = J + 1 00227 STACK( 2, STKPNT ) = ENDD 00228 ELSE 00229 STKPNT = STKPNT + 1 00230 STACK( 1, STKPNT ) = J + 1 00231 STACK( 2, STKPNT ) = ENDD 00232 STKPNT = STKPNT + 1 00233 STACK( 1, STKPNT ) = START 00234 STACK( 2, STKPNT ) = J 00235 END IF 00236 END IF 00237 END IF 00238 IF( STKPNT.GT.0 ) 00239 $ GO TO 10 00240 RETURN 00241 * 00242 * End of SLASRT 00243 * 00244 END
1.7.3 
