 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, 00002 $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) 00003 * 00004 * -- LAPACK 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 * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. 00010 * 00011 * .. Scalar Arguments .. 00012 CHARACTER UPLO 00013 INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS 00014 * .. 00015 * .. Array Arguments .. 00016 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * ) 00017 COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), 00018 $ WORK( * ), X( LDX, * ) 00019 * .. 00020 * 00021 * Purpose 00022 * ======= 00023 * 00024 * ZPBRFS improves the computed solution to a system of linear 00025 * equations when the coefficient matrix is Hermitian positive definite 00026 * and banded, and provides error bounds and backward error estimates 00027 * for the solution. 00028 * 00029 * Arguments 00030 * ========= 00031 * 00032 * UPLO (input) CHARACTER*1 00033 * = 'U': Upper triangle of A is stored; 00034 * = 'L': Lower triangle of A is stored. 00035 * 00036 * N (input) INTEGER 00037 * The order of the matrix A. N >= 0. 00038 * 00039 * KD (input) INTEGER 00040 * The number of superdiagonals of the matrix A if UPLO = 'U', 00041 * or the number of subdiagonals if UPLO = 'L'. KD >= 0. 00042 * 00043 * NRHS (input) INTEGER 00044 * The number of right hand sides, i.e., the number of columns 00045 * of the matrices B and X. NRHS >= 0. 00046 * 00047 * AB (input) DOUBLE PRECISION array, dimension (LDAB,N) 00048 * The upper or lower triangle of the Hermitian band matrix A, 00049 * stored in the first KD+1 rows of the array. The j-th column 00050 * of A is stored in the j-th column of the array AB as follows: 00051 * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; 00052 * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). 00053 * 00054 * LDAB (input) INTEGER 00055 * The leading dimension of the array AB. LDAB >= KD+1. 00056 * 00057 * AFB (input) COMPLEX*16 array, dimension (LDAFB,N) 00058 * The triangular factor U or L from the Cholesky factorization 00059 * A = U**H*U or A = L*L**H of the band matrix A as computed by 00060 * ZPBTRF, in the same storage format as A (see AB). 00061 * 00062 * LDAFB (input) INTEGER 00063 * The leading dimension of the array AFB. LDAFB >= KD+1. 00064 * 00065 * B (input) COMPLEX*16 array, dimension (LDB,NRHS) 00066 * The right hand side matrix B. 00067 * 00068 * LDB (input) INTEGER 00069 * The leading dimension of the array B. LDB >= max(1,N). 00070 * 00071 * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) 00072 * On entry, the solution matrix X, as computed by ZPBTRS. 00073 * On exit, the improved solution matrix X. 00074 * 00075 * LDX (input) INTEGER 00076 * The leading dimension of the array X. LDX >= max(1,N). 00077 * 00078 * FERR (output) DOUBLE PRECISION array, dimension (NRHS) 00079 * The estimated forward error bound for each solution vector 00080 * X(j) (the j-th column of the solution matrix X). 00081 * If XTRUE is the true solution corresponding to X(j), FERR(j) 00082 * is an estimated upper bound for the magnitude of the largest 00083 * element in (X(j) - XTRUE) divided by the magnitude of the 00084 * largest element in X(j). The estimate is as reliable as 00085 * the estimate for RCOND, and is almost always a slight 00086 * overestimate of the true error. 00087 * 00088 * BERR (output) DOUBLE PRECISION array, dimension (NRHS) 00089 * The componentwise relative backward error of each solution 00090 * vector X(j) (i.e., the smallest relative change in 00091 * any element of A or B that makes X(j) an exact solution). 00092 * 00093 * WORK (workspace) COMPLEX*16 array, dimension (2*N) 00094 * 00095 * RWORK (workspace) DOUBLE PRECISION array, dimension (N) 00096 * 00097 * INFO (output) INTEGER 00098 * = 0: successful exit 00099 * < 0: if INFO = -i, the i-th argument had an illegal value 00100 * 00101 * Internal Parameters 00102 * =================== 00103 * 00104 * ITMAX is the maximum number of steps of iterative refinement. 00105 * 00106 * ===================================================================== 00107 * 00108 * .. Parameters .. 00109 INTEGER ITMAX 00110 PARAMETER ( ITMAX = 5 ) 00111 DOUBLE PRECISION ZERO 00112 PARAMETER ( ZERO = 0.0D+0 ) 00113 COMPLEX*16 ONE 00114 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 00115 DOUBLE PRECISION TWO 00116 PARAMETER ( TWO = 2.0D+0 ) 00117 DOUBLE PRECISION THREE 00118 PARAMETER ( THREE = 3.0D+0 ) 00119 * .. 00120 * .. Local Scalars .. 00121 LOGICAL UPPER 00122 INTEGER COUNT, I, J, K, KASE, L, NZ 00123 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK 00124 COMPLEX*16 ZDUM 00125 * .. 00126 * .. Local Arrays .. 00127 INTEGER ISAVE( 3 ) 00128 * .. 00129 * .. External Subroutines .. 00130 EXTERNAL XERBLA, ZAXPY, ZCOPY, ZHBMV, ZLACN2, ZPBTRS 00131 * .. 00132 * .. Intrinsic Functions .. 00133 INTRINSIC ABS, DBLE, DIMAG, MAX, MIN 00134 * .. 00135 * .. External Functions .. 00136 LOGICAL LSAME 00137 DOUBLE PRECISION DLAMCH 00138 EXTERNAL LSAME, DLAMCH 00139 * .. 00140 * .. Statement Functions .. 00141 DOUBLE PRECISION CABS1 00142 * .. 00143 * .. Statement Function definitions .. 00144 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 00145 * .. 00146 * .. Executable Statements .. 00147 * 00148 * Test the input parameters. 00149 * 00150 INFO = 0 00151 UPPER = LSAME( UPLO, 'U' ) 00152 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 00153 INFO = -1 00154 ELSE IF( N.LT.0 ) THEN 00155 INFO = -2 00156 ELSE IF( KD.LT.0 ) THEN 00157 INFO = -3 00158 ELSE IF( NRHS.LT.0 ) THEN 00159 INFO = -4 00160 ELSE IF( LDAB.LT.KD+1 ) THEN 00161 INFO = -6 00162 ELSE IF( LDAFB.LT.KD+1 ) THEN 00163 INFO = -8 00164 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 00165 INFO = -10 00166 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN 00167 INFO = -12 00168 END IF 00169 IF( INFO.NE.0 ) THEN 00170 CALL XERBLA( 'ZPBRFS', -INFO ) 00171 RETURN 00172 END IF 00173 * 00174 * Quick return if possible 00175 * 00176 IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN 00177 DO 10 J = 1, NRHS 00178 FERR( J ) = ZERO 00179 BERR( J ) = ZERO 00180 10 CONTINUE 00181 RETURN 00182 END IF 00183 * 00184 * NZ = maximum number of nonzero elements in each row of A, plus 1 00185 * 00186 NZ = MIN( N+1, 2*KD+2 ) 00187 EPS = DLAMCH( 'Epsilon' ) 00188 SAFMIN = DLAMCH( 'Safe minimum' ) 00189 SAFE1 = NZ*SAFMIN 00190 SAFE2 = SAFE1 / EPS 00191 * 00192 * Do for each right hand side 00193 * 00194 DO 140 J = 1, NRHS 00195 * 00196 COUNT = 1 00197 LSTRES = THREE 00198 20 CONTINUE 00199 * 00200 * Loop until stopping criterion is satisfied. 00201 * 00202 * Compute residual R = B - A * X 00203 * 00204 CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 ) 00205 CALL ZHBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE, 00206 $ WORK, 1 ) 00207 * 00208 * Compute componentwise relative backward error from formula 00209 * 00210 * max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) 00211 * 00212 * where abs(Z) is the componentwise absolute value of the matrix 00213 * or vector Z. If the i-th component of the denominator is less 00214 * than SAFE2, then SAFE1 is added to the i-th components of the 00215 * numerator and denominator before dividing. 00216 * 00217 DO 30 I = 1, N 00218 RWORK( I ) = CABS1( B( I, J ) ) 00219 30 CONTINUE 00220 * 00221 * Compute abs(A)*abs(X) + abs(B). 00222 * 00223 IF( UPPER ) THEN 00224 DO 50 K = 1, N 00225 S = ZERO 00226 XK = CABS1( X( K, J ) ) 00227 L = KD + 1 - K 00228 DO 40 I = MAX( 1, K-KD ), K - 1 00229 RWORK( I ) = RWORK( I ) + CABS1( AB( L+I, K ) )*XK 00230 S = S + CABS1( AB( L+I, K ) )*CABS1( X( I, J ) ) 00231 40 CONTINUE 00232 RWORK( K ) = RWORK( K ) + ABS( DBLE( AB( KD+1, K ) ) )* 00233 $ XK + S 00234 50 CONTINUE 00235 ELSE 00236 DO 70 K = 1, N 00237 S = ZERO 00238 XK = CABS1( X( K, J ) ) 00239 RWORK( K ) = RWORK( K ) + ABS( DBLE( AB( 1, K ) ) )*XK 00240 L = 1 - K 00241 DO 60 I = K + 1, MIN( N, K+KD ) 00242 RWORK( I ) = RWORK( I ) + CABS1( AB( L+I, K ) )*XK 00243 S = S + CABS1( AB( L+I, K ) )*CABS1( X( I, J ) ) 00244 60 CONTINUE 00245 RWORK( K ) = RWORK( K ) + S 00246 70 CONTINUE 00247 END IF 00248 S = ZERO 00249 DO 80 I = 1, N 00250 IF( RWORK( I ).GT.SAFE2 ) THEN 00251 S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) ) 00252 ELSE 00253 S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) / 00254 $ ( RWORK( I )+SAFE1 ) ) 00255 END IF 00256 80 CONTINUE 00257 BERR( J ) = S 00258 * 00259 * Test stopping criterion. Continue iterating if 00260 * 1) The residual BERR(J) is larger than machine epsilon, and 00261 * 2) BERR(J) decreased by at least a factor of 2 during the 00262 * last iteration, and 00263 * 3) At most ITMAX iterations tried. 00264 * 00265 IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. 00266 $ COUNT.LE.ITMAX ) THEN 00267 * 00268 * Update solution and try again. 00269 * 00270 CALL ZPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO ) 00271 CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 ) 00272 LSTRES = BERR( J ) 00273 COUNT = COUNT + 1 00274 GO TO 20 00275 END IF 00276 * 00277 * Bound error from formula 00278 * 00279 * norm(X - XTRUE) / norm(X) .le. FERR = 00280 * norm( abs(inv(A))* 00281 * ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) 00282 * 00283 * where 00284 * norm(Z) is the magnitude of the largest component of Z 00285 * inv(A) is the inverse of A 00286 * abs(Z) is the componentwise absolute value of the matrix or 00287 * vector Z 00288 * NZ is the maximum number of nonzeros in any row of A, plus 1 00289 * EPS is machine epsilon 00290 * 00291 * The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) 00292 * is incremented by SAFE1 if the i-th component of 00293 * abs(A)*abs(X) + abs(B) is less than SAFE2. 00294 * 00295 * Use ZLACN2 to estimate the infinity-norm of the matrix 00296 * inv(A) * diag(W), 00297 * where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) 00298 * 00299 DO 90 I = 1, N 00300 IF( RWORK( I ).GT.SAFE2 ) THEN 00301 RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) 00302 ELSE 00303 RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) + 00304 $ SAFE1 00305 END IF 00306 90 CONTINUE 00307 * 00308 KASE = 0 00309 100 CONTINUE 00310 CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE ) 00311 IF( KASE.NE.0 ) THEN 00312 IF( KASE.EQ.1 ) THEN 00313 * 00314 * Multiply by diag(W)*inv(A**H). 00315 * 00316 CALL ZPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO ) 00317 DO 110 I = 1, N 00318 WORK( I ) = RWORK( I )*WORK( I ) 00319 110 CONTINUE 00320 ELSE IF( KASE.EQ.2 ) THEN 00321 * 00322 * Multiply by inv(A)*diag(W). 00323 * 00324 DO 120 I = 1, N 00325 WORK( I ) = RWORK( I )*WORK( I ) 00326 120 CONTINUE 00327 CALL ZPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO ) 00328 END IF 00329 GO TO 100 00330 END IF 00331 * 00332 * Normalize error. 00333 * 00334 LSTRES = ZERO 00335 DO 130 I = 1, N 00336 LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) ) 00337 130 CONTINUE 00338 IF( LSTRES.NE.ZERO ) 00339 $ FERR( J ) = FERR( J ) / LSTRES 00340 * 00341 140 CONTINUE 00342 * 00343 RETURN 00344 * 00345 * End of ZPBRFS 00346 * 00347 END
1.7.3 
