 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, 00002 $ LDAB, WORK ) 00003 * 00004 * -- LAPACK auxiliary routine (version 3.2) -- 00005 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00006 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00007 * November 2006 00008 * 00009 * .. Scalar Arguments .. 00010 CHARACTER DIAG, NORM, UPLO 00011 INTEGER K, LDAB, N 00012 * .. 00013 * .. Array Arguments .. 00014 REAL AB( LDAB, * ), WORK( * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * SLANTB returns the value of the one norm, or the Frobenius norm, or 00021 * the infinity norm, or the element of largest absolute value of an 00022 * n by n triangular band matrix A, with ( k + 1 ) diagonals. 00023 * 00024 * Description 00025 * =========== 00026 * 00027 * SLANTB returns the value 00028 * 00029 * SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' 00030 * ( 00031 * ( norm1(A), NORM = '1', 'O' or 'o' 00032 * ( 00033 * ( normI(A), NORM = 'I' or 'i' 00034 * ( 00035 * ( normF(A), NORM = 'F', 'f', 'E' or 'e' 00036 * 00037 * where norm1 denotes the one norm of a matrix (maximum column sum), 00038 * normI denotes the infinity norm of a matrix (maximum row sum) and 00039 * normF denotes the Frobenius norm of a matrix (square root of sum of 00040 * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. 00041 * 00042 * Arguments 00043 * ========= 00044 * 00045 * NORM (input) CHARACTER*1 00046 * Specifies the value to be returned in SLANTB as described 00047 * above. 00048 * 00049 * UPLO (input) CHARACTER*1 00050 * Specifies whether the matrix A is upper or lower triangular. 00051 * = 'U': Upper triangular 00052 * = 'L': Lower triangular 00053 * 00054 * DIAG (input) CHARACTER*1 00055 * Specifies whether or not the matrix A is unit triangular. 00056 * = 'N': Non-unit triangular 00057 * = 'U': Unit triangular 00058 * 00059 * N (input) INTEGER 00060 * The order of the matrix A. N >= 0. When N = 0, SLANTB is 00061 * set to zero. 00062 * 00063 * K (input) INTEGER 00064 * The number of super-diagonals of the matrix A if UPLO = 'U', 00065 * or the number of sub-diagonals of the matrix A if UPLO = 'L'. 00066 * K >= 0. 00067 * 00068 * AB (input) REAL array, dimension (LDAB,N) 00069 * The upper or lower triangular band matrix A, stored in the 00070 * first k+1 rows of AB. The j-th column of A is stored 00071 * in the j-th column of the array AB as follows: 00072 * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; 00073 * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). 00074 * Note that when DIAG = 'U', the elements of the array AB 00075 * corresponding to the diagonal elements of the matrix A are 00076 * not referenced, but are assumed to be one. 00077 * 00078 * LDAB (input) INTEGER 00079 * The leading dimension of the array AB. LDAB >= K+1. 00080 * 00081 * WORK (workspace) REAL array, dimension (MAX(1,LWORK)), 00082 * where LWORK >= N when NORM = 'I'; otherwise, WORK is not 00083 * referenced. 00084 * 00085 * ===================================================================== 00086 * 00087 * .. Parameters .. 00088 REAL ONE, ZERO 00089 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00090 * .. 00091 * .. Local Scalars .. 00092 LOGICAL UDIAG 00093 INTEGER I, J, L 00094 REAL SCALE, SUM, VALUE 00095 * .. 00096 * .. External Subroutines .. 00097 EXTERNAL SLASSQ 00098 * .. 00099 * .. External Functions .. 00100 LOGICAL LSAME 00101 EXTERNAL LSAME 00102 * .. 00103 * .. Intrinsic Functions .. 00104 INTRINSIC ABS, MAX, MIN, SQRT 00105 * .. 00106 * .. Executable Statements .. 00107 * 00108 IF( N.EQ.0 ) THEN 00109 VALUE = ZERO 00110 ELSE IF( LSAME( NORM, 'M' ) ) THEN 00111 * 00112 * Find max(abs(A(i,j))). 00113 * 00114 IF( LSAME( DIAG, 'U' ) ) THEN 00115 VALUE = ONE 00116 IF( LSAME( UPLO, 'U' ) ) THEN 00117 DO 20 J = 1, N 00118 DO 10 I = MAX( K+2-J, 1 ), K 00119 VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) 00120 10 CONTINUE 00121 20 CONTINUE 00122 ELSE 00123 DO 40 J = 1, N 00124 DO 30 I = 2, MIN( N+1-J, K+1 ) 00125 VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) 00126 30 CONTINUE 00127 40 CONTINUE 00128 END IF 00129 ELSE 00130 VALUE = ZERO 00131 IF( LSAME( UPLO, 'U' ) ) THEN 00132 DO 60 J = 1, N 00133 DO 50 I = MAX( K+2-J, 1 ), K + 1 00134 VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) 00135 50 CONTINUE 00136 60 CONTINUE 00137 ELSE 00138 DO 80 J = 1, N 00139 DO 70 I = 1, MIN( N+1-J, K+1 ) 00140 VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) 00141 70 CONTINUE 00142 80 CONTINUE 00143 END IF 00144 END IF 00145 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 00146 * 00147 * Find norm1(A). 00148 * 00149 VALUE = ZERO 00150 UDIAG = LSAME( DIAG, 'U' ) 00151 IF( LSAME( UPLO, 'U' ) ) THEN 00152 DO 110 J = 1, N 00153 IF( UDIAG ) THEN 00154 SUM = ONE 00155 DO 90 I = MAX( K+2-J, 1 ), K 00156 SUM = SUM + ABS( AB( I, J ) ) 00157 90 CONTINUE 00158 ELSE 00159 SUM = ZERO 00160 DO 100 I = MAX( K+2-J, 1 ), K + 1 00161 SUM = SUM + ABS( AB( I, J ) ) 00162 100 CONTINUE 00163 END IF 00164 VALUE = MAX( VALUE, SUM ) 00165 110 CONTINUE 00166 ELSE 00167 DO 140 J = 1, N 00168 IF( UDIAG ) THEN 00169 SUM = ONE 00170 DO 120 I = 2, MIN( N+1-J, K+1 ) 00171 SUM = SUM + ABS( AB( I, J ) ) 00172 120 CONTINUE 00173 ELSE 00174 SUM = ZERO 00175 DO 130 I = 1, MIN( N+1-J, K+1 ) 00176 SUM = SUM + ABS( AB( I, J ) ) 00177 130 CONTINUE 00178 END IF 00179 VALUE = MAX( VALUE, SUM ) 00180 140 CONTINUE 00181 END IF 00182 ELSE IF( LSAME( NORM, 'I' ) ) THEN 00183 * 00184 * Find normI(A). 00185 * 00186 VALUE = ZERO 00187 IF( LSAME( UPLO, 'U' ) ) THEN 00188 IF( LSAME( DIAG, 'U' ) ) THEN 00189 DO 150 I = 1, N 00190 WORK( I ) = ONE 00191 150 CONTINUE 00192 DO 170 J = 1, N 00193 L = K + 1 - J 00194 DO 160 I = MAX( 1, J-K ), J - 1 00195 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 00196 160 CONTINUE 00197 170 CONTINUE 00198 ELSE 00199 DO 180 I = 1, N 00200 WORK( I ) = ZERO 00201 180 CONTINUE 00202 DO 200 J = 1, N 00203 L = K + 1 - J 00204 DO 190 I = MAX( 1, J-K ), J 00205 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 00206 190 CONTINUE 00207 200 CONTINUE 00208 END IF 00209 ELSE 00210 IF( LSAME( DIAG, 'U' ) ) THEN 00211 DO 210 I = 1, N 00212 WORK( I ) = ONE 00213 210 CONTINUE 00214 DO 230 J = 1, N 00215 L = 1 - J 00216 DO 220 I = J + 1, MIN( N, J+K ) 00217 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 00218 220 CONTINUE 00219 230 CONTINUE 00220 ELSE 00221 DO 240 I = 1, N 00222 WORK( I ) = ZERO 00223 240 CONTINUE 00224 DO 260 J = 1, N 00225 L = 1 - J 00226 DO 250 I = J, MIN( N, J+K ) 00227 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 00228 250 CONTINUE 00229 260 CONTINUE 00230 END IF 00231 END IF 00232 DO 270 I = 1, N 00233 VALUE = MAX( VALUE, WORK( I ) ) 00234 270 CONTINUE 00235 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 00236 * 00237 * Find normF(A). 00238 * 00239 IF( LSAME( UPLO, 'U' ) ) THEN 00240 IF( LSAME( DIAG, 'U' ) ) THEN 00241 SCALE = ONE 00242 SUM = N 00243 IF( K.GT.0 ) THEN 00244 DO 280 J = 2, N 00245 CALL SLASSQ( MIN( J-1, K ), 00246 $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE, 00247 $ SUM ) 00248 280 CONTINUE 00249 END IF 00250 ELSE 00251 SCALE = ZERO 00252 SUM = ONE 00253 DO 290 J = 1, N 00254 CALL SLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), 00255 $ 1, SCALE, SUM ) 00256 290 CONTINUE 00257 END IF 00258 ELSE 00259 IF( LSAME( DIAG, 'U' ) ) THEN 00260 SCALE = ONE 00261 SUM = N 00262 IF( K.GT.0 ) THEN 00263 DO 300 J = 1, N - 1 00264 CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, 00265 $ SUM ) 00266 300 CONTINUE 00267 END IF 00268 ELSE 00269 SCALE = ZERO 00270 SUM = ONE 00271 DO 310 J = 1, N 00272 CALL SLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, 00273 $ SUM ) 00274 310 CONTINUE 00275 END IF 00276 END IF 00277 VALUE = SCALE*SQRT( SUM ) 00278 END IF 00279 * 00280 SLANTB = VALUE 00281 RETURN 00282 * 00283 * End of SLANTB 00284 * 00285 END
1.7.3 
