LAPACK: SRC/ztbrfs.f Source File

Go to the documentation of this file.
00001       SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, 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          DIAG, TRANS, UPLO
00013       INTEGER            INFO, KD, LDAB, LDB, LDX, N, NRHS
00014 *     ..
00015 *     .. Array Arguments ..
00016       DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
00017       COMPLEX*16         AB( LDAB, * ), B( LDB, * ), WORK( * ),
00018      $                   X( LDX, * )
00019 *     ..
00020 *
00021 *  Purpose
00022 *  =======
00023 *
00024 *  ZTBRFS provides error bounds and backward error estimates for the
00025 *  solution to a system of linear equations with a triangular band
00026 *  coefficient matrix.
00027 *
00028 *  The solution matrix X must be computed by ZTBTRS or some other
00029 *  means before entering this routine.  ZTBRFS does not do iterative
00030 *  refinement because doing so cannot improve the backward error.
00031 *
00032 *  Arguments
00033 *  =========
00034 *
00035 *  UPLO    (input) CHARACTER*1
00036 *          = 'U':  A is upper triangular;
00037 *          = 'L':  A is lower triangular.
00038 *
00039 *  TRANS   (input) CHARACTER*1
00040 *          Specifies the form of the system of equations:
00041 *          = 'N':  A * X = B     (No transpose)
00042 *          = 'T':  A**T * X = B  (Transpose)
00043 *          = 'C':  A**H * X = B  (Conjugate transpose)
00044 *
00045 *  DIAG    (input) CHARACTER*1
00046 *          = 'N':  A is non-unit triangular;
00047 *          = 'U':  A is unit triangular.
00048 *
00049 *  N       (input) INTEGER
00050 *          The order of the matrix A.  N >= 0.
00051 *
00052 *  KD      (input) INTEGER
00053 *          The number of superdiagonals or subdiagonals of the
00054 *          triangular band matrix A.  KD >= 0.
00055 *
00056 *  NRHS    (input) INTEGER
00057 *          The number of right hand sides, i.e., the number of columns
00058 *          of the matrices B and X.  NRHS >= 0.
00059 *
00060 *  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
00061 *          The upper or lower triangular band matrix A, stored in the
00062 *          first kd+1 rows of the array. The j-th column of A is stored
00063 *          in the j-th column of the array AB as follows:
00064 *          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
00065 *          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
00066 *          If DIAG = 'U', the diagonal elements of A are not referenced
00067 *          and are assumed to be 1.
00068 *
00069 *  LDAB    (input) INTEGER
00070 *          The leading dimension of the array AB.  LDAB >= KD+1.
00071 *
00072 *  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
00073 *          The right hand side matrix B.
00074 *
00075 *  LDB     (input) INTEGER
00076 *          The leading dimension of the array B.  LDB >= max(1,N).
00077 *
00078 *  X       (input) COMPLEX*16 array, dimension (LDX,NRHS)
00079 *          The solution matrix X.
00080 *
00081 *  LDX     (input) INTEGER
00082 *          The leading dimension of the array X.  LDX >= max(1,N).
00083 *
00084 *  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
00085 *          The estimated forward error bound for each solution vector
00086 *          X(j) (the j-th column of the solution matrix X).
00087 *          If XTRUE is the true solution corresponding to X(j), FERR(j)
00088 *          is an estimated upper bound for the magnitude of the largest
00089 *          element in (X(j) - XTRUE) divided by the magnitude of the
00090 *          largest element in X(j).  The estimate is as reliable as
00091 *          the estimate for RCOND, and is almost always a slight
00092 *          overestimate of the true error.
00093 *
00094 *  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
00095 *          The componentwise relative backward error of each solution
00096 *          vector X(j) (i.e., the smallest relative change in
00097 *          any element of A or B that makes X(j) an exact solution).
00098 *
00099 *  WORK    (workspace) COMPLEX*16 array, dimension (2*N)
00100 *
00101 *  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
00102 *
00103 *  INFO    (output) INTEGER
00104 *          = 0:  successful exit
00105 *          < 0:  if INFO = -i, the i-th argument had an illegal value
00106 *
00107 *  =====================================================================
00108 *
00109 *     .. Parameters ..
00110       DOUBLE PRECISION   ZERO
00111       PARAMETER          ( ZERO = 0.0D+0 )
00112       COMPLEX*16         ONE
00113       PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
00114 *     ..
00115 *     .. Local Scalars ..
00116       LOGICAL            NOTRAN, NOUNIT, UPPER
00117       CHARACTER          TRANSN, TRANST
00118       INTEGER            I, J, K, KASE, NZ
00119       DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
00120       COMPLEX*16         ZDUM
00121 *     ..
00122 *     .. Local Arrays ..
00123       INTEGER            ISAVE( 3 )
00124 *     ..
00125 *     .. External Subroutines ..
00126       EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZLACN2, ZTBMV, ZTBSV
00127 *     ..
00128 *     .. Intrinsic Functions ..
00129       INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
00130 *     ..
00131 *     .. External Functions ..
00132       LOGICAL            LSAME
00133       DOUBLE PRECISION   DLAMCH
00134       EXTERNAL           LSAME, DLAMCH
00135 *     ..
00136 *     .. Statement Functions ..
00137       DOUBLE PRECISION   CABS1
00138 *     ..
00139 *     .. Statement Function definitions ..
00140       CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
00141 *     ..
00142 *     .. Executable Statements ..
00143 *
00144 *     Test the input parameters.
00145 *
00146       INFO = 0
00147       UPPER = LSAME( UPLO, 'U' )
00148       NOTRAN = LSAME( TRANS, 'N' )
00149       NOUNIT = LSAME( DIAG, 'N' )
00150 *
00151       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
00152          INFO = -1
00153       ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
00154      $         LSAME( TRANS, 'C' ) ) THEN
00155          INFO = -2
00156       ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
00157          INFO = -3
00158       ELSE IF( N.LT.0 ) THEN
00159          INFO = -4
00160       ELSE IF( KD.LT.0 ) THEN
00161          INFO = -5
00162       ELSE IF( NRHS.LT.0 ) THEN
00163          INFO = -6
00164       ELSE IF( LDAB.LT.KD+1 ) THEN
00165          INFO = -8
00166       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
00167          INFO = -10
00168       ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
00169          INFO = -12
00170       END IF
00171       IF( INFO.NE.0 ) THEN
00172          CALL XERBLA( 'ZTBRFS', -INFO )
00173          RETURN
00174       END IF
00175 *
00176 *     Quick return if possible
00177 *
00178       IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
00179          DO 10 J = 1, NRHS
00180             FERR( J ) = ZERO
00181             BERR( J ) = ZERO
00182    10    CONTINUE
00183          RETURN
00184       END IF
00185 *
00186       IF( NOTRAN ) THEN
00187          TRANSN = 'N'
00188          TRANST = 'C'
00189       ELSE
00190          TRANSN = 'C'
00191          TRANST = 'N'
00192       END IF
00193 *
00194 *     NZ = maximum number of nonzero elements in each row of A, plus 1
00195 *
00196       NZ = KD + 2
00197       EPS = DLAMCH( 'Epsilon' )
00198       SAFMIN = DLAMCH( 'Safe minimum' )
00199       SAFE1 = NZ*SAFMIN
00200       SAFE2 = SAFE1 / EPS
00201 *
00202 *     Do for each right hand side
00203 *
00204       DO 250 J = 1, NRHS
00205 *
00206 *        Compute residual R = B - op(A) * X,
00207 *        where op(A) = A, A**T, or A**H, depending on TRANS.
00208 *
00209          CALL ZCOPY( N, X( 1, J ), 1, WORK, 1 )
00210          CALL ZTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK, 1 )
00211          CALL ZAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
00212 *
00213 *        Compute componentwise relative backward error from formula
00214 *
00215 *        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
00216 *
00217 *        where abs(Z) is the componentwise absolute value of the matrix
00218 *        or vector Z.  If the i-th component of the denominator is less
00219 *        than SAFE2, then SAFE1 is added to the i-th components of the
00220 *        numerator and denominator before dividing.
00221 *
00222          DO 20 I = 1, N
00223             RWORK( I ) = CABS1( B( I, J ) )
00224    20    CONTINUE
00225 *
00226          IF( NOTRAN ) THEN
00227 *
00228 *           Compute abs(A)*abs(X) + abs(B).
00229 *
00230             IF( UPPER ) THEN
00231                IF( NOUNIT ) THEN
00232                   DO 40 K = 1, N
00233                      XK = CABS1( X( K, J ) )
00234                      DO 30 I = MAX( 1, K-KD ), K
00235                         RWORK( I ) = RWORK( I ) +
00236      $                               CABS1( AB( KD+1+I-K, K ) )*XK
00237    30                CONTINUE
00238    40             CONTINUE
00239                ELSE
00240                   DO 60 K = 1, N
00241                      XK = CABS1( X( K, J ) )
00242                      DO 50 I = MAX( 1, K-KD ), K - 1
00243                         RWORK( I ) = RWORK( I ) +
00244      $                               CABS1( AB( KD+1+I-K, K ) )*XK
00245    50                CONTINUE
00246                      RWORK( K ) = RWORK( K ) + XK
00247    60             CONTINUE
00248                END IF
00249             ELSE
00250                IF( NOUNIT ) THEN
00251                   DO 80 K = 1, N
00252                      XK = CABS1( X( K, J ) )
00253                      DO 70 I = K, MIN( N, K+KD )
00254                         RWORK( I ) = RWORK( I ) +
00255      $                               CABS1( AB( 1+I-K, K ) )*XK
00256    70                CONTINUE
00257    80             CONTINUE
00258                ELSE
00259                   DO 100 K = 1, N
00260                      XK = CABS1( X( K, J ) )
00261                      DO 90 I = K + 1, MIN( N, K+KD )
00262                         RWORK( I ) = RWORK( I ) +
00263      $                               CABS1( AB( 1+I-K, K ) )*XK
00264    90                CONTINUE
00265                      RWORK( K ) = RWORK( K ) + XK
00266   100             CONTINUE
00267                END IF
00268             END IF
00269          ELSE
00270 *
00271 *           Compute abs(A**H)*abs(X) + abs(B).
00272 *
00273             IF( UPPER ) THEN
00274                IF( NOUNIT ) THEN
00275                   DO 120 K = 1, N
00276                      S = ZERO
00277                      DO 110 I = MAX( 1, K-KD ), K
00278                         S = S + CABS1( AB( KD+1+I-K, K ) )*
00279      $                      CABS1( X( I, J ) )
00280   110                CONTINUE
00281                      RWORK( K ) = RWORK( K ) + S
00282   120             CONTINUE
00283                ELSE
00284                   DO 140 K = 1, N
00285                      S = CABS1( X( K, J ) )
00286                      DO 130 I = MAX( 1, K-KD ), K - 1
00287                         S = S + CABS1( AB( KD+1+I-K, K ) )*
00288      $                      CABS1( X( I, J ) )
00289   130                CONTINUE
00290                      RWORK( K ) = RWORK( K ) + S
00291   140             CONTINUE
00292                END IF
00293             ELSE
00294                IF( NOUNIT ) THEN
00295                   DO 160 K = 1, N
00296                      S = ZERO
00297                      DO 150 I = K, MIN( N, K+KD )
00298                         S = S + CABS1( AB( 1+I-K, K ) )*
00299      $                      CABS1( X( I, J ) )
00300   150                CONTINUE
00301                      RWORK( K ) = RWORK( K ) + S
00302   160             CONTINUE
00303                ELSE
00304                   DO 180 K = 1, N
00305                      S = CABS1( X( K, J ) )
00306                      DO 170 I = K + 1, MIN( N, K+KD )
00307                         S = S + CABS1( AB( 1+I-K, K ) )*
00308      $                      CABS1( X( I, J ) )
00309   170                CONTINUE
00310                      RWORK( K ) = RWORK( K ) + S
00311   180             CONTINUE
00312                END IF
00313             END IF
00314          END IF
00315          S = ZERO
00316          DO 190 I = 1, N
00317             IF( RWORK( I ).GT.SAFE2 ) THEN
00318                S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
00319             ELSE
00320                S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
00321      $             ( RWORK( I )+SAFE1 ) )
00322             END IF
00323   190    CONTINUE
00324          BERR( J ) = S
00325 *
00326 *        Bound error from formula
00327 *
00328 *        norm(X - XTRUE) / norm(X) .le. FERR =
00329 *        norm( abs(inv(op(A)))*
00330 *           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
00331 *
00332 *        where
00333 *          norm(Z) is the magnitude of the largest component of Z
00334 *          inv(op(A)) is the inverse of op(A)
00335 *          abs(Z) is the componentwise absolute value of the matrix or
00336 *             vector Z
00337 *          NZ is the maximum number of nonzeros in any row of A, plus 1
00338 *          EPS is machine epsilon
00339 *
00340 *        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
00341 *        is incremented by SAFE1 if the i-th component of
00342 *        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
00343 *
00344 *        Use ZLACN2 to estimate the infinity-norm of the matrix
00345 *           inv(op(A)) * diag(W),
00346 *        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
00347 *
00348          DO 200 I = 1, N
00349             IF( RWORK( I ).GT.SAFE2 ) THEN
00350                RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
00351             ELSE
00352                RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
00353      $                      SAFE1
00354             END IF
00355   200    CONTINUE
00356 *
00357          KASE = 0
00358   210    CONTINUE
00359          CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
00360          IF( KASE.NE.0 ) THEN
00361             IF( KASE.EQ.1 ) THEN
00362 *
00363 *              Multiply by diag(W)*inv(op(A)**H).
00364 *
00365                CALL ZTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB, WORK,
00366      $                     1 )
00367                DO 220 I = 1, N
00368                   WORK( I ) = RWORK( I )*WORK( I )
00369   220          CONTINUE
00370             ELSE
00371 *
00372 *              Multiply by inv(op(A))*diag(W).
00373 *
00374                DO 230 I = 1, N
00375                   WORK( I ) = RWORK( I )*WORK( I )
00376   230          CONTINUE
00377                CALL ZTBSV( UPLO, TRANSN, DIAG, N, KD, AB, LDAB, WORK,
00378      $                     1 )
00379             END IF
00380             GO TO 210
00381          END IF
00382 *
00383 *        Normalize error.
00384 *
00385          LSTRES = ZERO
00386          DO 240 I = 1, N
00387             LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
00388   240    CONTINUE
00389          IF( LSTRES.NE.ZERO )
00390      $      FERR( J ) = FERR( J ) / LSTRES
00391 *
00392   250 CONTINUE
00393 *
00394       RETURN
00395 *
00396 *     End of ZTBRFS
00397 *
00398       END