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