|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, 00002 $ 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 LDA, M, N 00012 * .. 00013 * .. Array Arguments .. 00014 REAL A( LDA, * ), WORK( * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * SLANTR returns the value of the one norm, or the Frobenius norm, or 00021 * the infinity norm, or the element of largest absolute value of a 00022 * trapezoidal or triangular matrix A. 00023 * 00024 * Description 00025 * =========== 00026 * 00027 * SLANTR returns the value 00028 * 00029 * SLANTR = ( 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 SLANTR as described 00047 * above. 00048 * 00049 * UPLO (input) CHARACTER*1 00050 * Specifies whether the matrix A is upper or lower trapezoidal. 00051 * = 'U': Upper trapezoidal 00052 * = 'L': Lower trapezoidal 00053 * Note that A is triangular instead of trapezoidal if M = N. 00054 * 00055 * DIAG (input) CHARACTER*1 00056 * Specifies whether or not the matrix A has unit diagonal. 00057 * = 'N': Non-unit diagonal 00058 * = 'U': Unit diagonal 00059 * 00060 * M (input) INTEGER 00061 * The number of rows of the matrix A. M >= 0, and if 00062 * UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero. 00063 * 00064 * N (input) INTEGER 00065 * The number of columns of the matrix A. N >= 0, and if 00066 * UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero. 00067 * 00068 * A (input) REAL array, dimension (LDA,N) 00069 * The trapezoidal matrix A (A is triangular if M = N). 00070 * If UPLO = 'U', the leading m by n upper trapezoidal part of 00071 * the array A contains the upper trapezoidal matrix, and the 00072 * strictly lower triangular part of A is not referenced. 00073 * If UPLO = 'L', the leading m by n lower trapezoidal part of 00074 * the array A contains the lower trapezoidal matrix, and the 00075 * strictly upper triangular part of A is not referenced. Note 00076 * that when DIAG = 'U', the diagonal elements of A are not 00077 * referenced and are assumed to be one. 00078 * 00079 * LDA (input) INTEGER 00080 * The leading dimension of the array A. LDA >= max(M,1). 00081 * 00082 * WORK (workspace) REAL array, dimension (MAX(1,LWORK)), 00083 * where LWORK >= M when NORM = 'I'; otherwise, WORK is not 00084 * referenced. 00085 * 00086 * ===================================================================== 00087 * 00088 * .. Parameters .. 00089 REAL ONE, ZERO 00090 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00091 * .. 00092 * .. Local Scalars .. 00093 LOGICAL UDIAG 00094 INTEGER I, J 00095 REAL SCALE, SUM, VALUE 00096 * .. 00097 * .. External Subroutines .. 00098 EXTERNAL SLASSQ 00099 * .. 00100 * .. External Functions .. 00101 LOGICAL LSAME 00102 EXTERNAL LSAME 00103 * .. 00104 * .. Intrinsic Functions .. 00105 INTRINSIC ABS, MAX, MIN, SQRT 00106 * .. 00107 * .. Executable Statements .. 00108 * 00109 IF( MIN( M, N ).EQ.0 ) THEN 00110 VALUE = ZERO 00111 ELSE IF( LSAME( NORM, 'M' ) ) THEN 00112 * 00113 * Find max(abs(A(i,j))). 00114 * 00115 IF( LSAME( DIAG, 'U' ) ) THEN 00116 VALUE = ONE 00117 IF( LSAME( UPLO, 'U' ) ) THEN 00118 DO 20 J = 1, N 00119 DO 10 I = 1, MIN( M, J-1 ) 00120 VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 00121 10 CONTINUE 00122 20 CONTINUE 00123 ELSE 00124 DO 40 J = 1, N 00125 DO 30 I = J + 1, M 00126 VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 00127 30 CONTINUE 00128 40 CONTINUE 00129 END IF 00130 ELSE 00131 VALUE = ZERO 00132 IF( LSAME( UPLO, 'U' ) ) THEN 00133 DO 60 J = 1, N 00134 DO 50 I = 1, MIN( M, J ) 00135 VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 00136 50 CONTINUE 00137 60 CONTINUE 00138 ELSE 00139 DO 80 J = 1, N 00140 DO 70 I = J, M 00141 VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 00142 70 CONTINUE 00143 80 CONTINUE 00144 END IF 00145 END IF 00146 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 00147 * 00148 * Find norm1(A). 00149 * 00150 VALUE = ZERO 00151 UDIAG = LSAME( DIAG, 'U' ) 00152 IF( LSAME( UPLO, 'U' ) ) THEN 00153 DO 110 J = 1, N 00154 IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN 00155 SUM = ONE 00156 DO 90 I = 1, J - 1 00157 SUM = SUM + ABS( A( I, J ) ) 00158 90 CONTINUE 00159 ELSE 00160 SUM = ZERO 00161 DO 100 I = 1, MIN( M, J ) 00162 SUM = SUM + ABS( A( I, J ) ) 00163 100 CONTINUE 00164 END IF 00165 VALUE = MAX( VALUE, SUM ) 00166 110 CONTINUE 00167 ELSE 00168 DO 140 J = 1, N 00169 IF( UDIAG ) THEN 00170 SUM = ONE 00171 DO 120 I = J + 1, M 00172 SUM = SUM + ABS( A( I, J ) ) 00173 120 CONTINUE 00174 ELSE 00175 SUM = ZERO 00176 DO 130 I = J, M 00177 SUM = SUM + ABS( A( I, J ) ) 00178 130 CONTINUE 00179 END IF 00180 VALUE = MAX( VALUE, SUM ) 00181 140 CONTINUE 00182 END IF 00183 ELSE IF( LSAME( NORM, 'I' ) ) THEN 00184 * 00185 * Find normI(A). 00186 * 00187 IF( LSAME( UPLO, 'U' ) ) THEN 00188 IF( LSAME( DIAG, 'U' ) ) THEN 00189 DO 150 I = 1, M 00190 WORK( I ) = ONE 00191 150 CONTINUE 00192 DO 170 J = 1, N 00193 DO 160 I = 1, MIN( M, J-1 ) 00194 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 00195 160 CONTINUE 00196 170 CONTINUE 00197 ELSE 00198 DO 180 I = 1, M 00199 WORK( I ) = ZERO 00200 180 CONTINUE 00201 DO 200 J = 1, N 00202 DO 190 I = 1, MIN( M, J ) 00203 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 00204 190 CONTINUE 00205 200 CONTINUE 00206 END IF 00207 ELSE 00208 IF( LSAME( DIAG, 'U' ) ) THEN 00209 DO 210 I = 1, N 00210 WORK( I ) = ONE 00211 210 CONTINUE 00212 DO 220 I = N + 1, M 00213 WORK( I ) = ZERO 00214 220 CONTINUE 00215 DO 240 J = 1, N 00216 DO 230 I = J + 1, M 00217 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 00218 230 CONTINUE 00219 240 CONTINUE 00220 ELSE 00221 DO 250 I = 1, M 00222 WORK( I ) = ZERO 00223 250 CONTINUE 00224 DO 270 J = 1, N 00225 DO 260 I = J, M 00226 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 00227 260 CONTINUE 00228 270 CONTINUE 00229 END IF 00230 END IF 00231 VALUE = ZERO 00232 DO 280 I = 1, M 00233 VALUE = MAX( VALUE, WORK( I ) ) 00234 280 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 = MIN( M, N ) 00243 DO 290 J = 2, N 00244 CALL SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) 00245 290 CONTINUE 00246 ELSE 00247 SCALE = ZERO 00248 SUM = ONE 00249 DO 300 J = 1, N 00250 CALL SLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) 00251 300 CONTINUE 00252 END IF 00253 ELSE 00254 IF( LSAME( DIAG, 'U' ) ) THEN 00255 SCALE = ONE 00256 SUM = MIN( M, N ) 00257 DO 310 J = 1, N 00258 CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, 00259 $ SUM ) 00260 310 CONTINUE 00261 ELSE 00262 SCALE = ZERO 00263 SUM = ONE 00264 DO 320 J = 1, N 00265 CALL SLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 00266 320 CONTINUE 00267 END IF 00268 END IF 00269 VALUE = SCALE*SQRT( SUM ) 00270 END IF 00271 * 00272 SLANTR = VALUE 00273 RETURN 00274 * 00275 * End of SLANTR 00276 * 00277 END
1.7.3 
