SRC/zgbrfs.f

   1 *> \brief \b ZGBRFS
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download ZGBRFS + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbrfs.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbrfs.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbrfs.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
  22 *                          IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
  23 *                          INFO )
  24 *
  25 *       .. Scalar Arguments ..
  26 *       CHARACTER          TRANS
  27 *       INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
  28 *       ..
  29 *       .. Array Arguments ..
  30 *       INTEGER            IPIV( * )
  31 *       DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
  32 *       COMPLEX*16         AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
  33 *      $                   WORK( * ), X( LDX, * )
  34 *       ..
  35 *
  36 *
  37 *> \par Purpose:
  38 *  =============
  39 *>
  40 *> \verbatim
  41 *>
  42 *> ZGBRFS improves the computed solution to a system of linear
  43 *> equations when the coefficient matrix is banded, and provides
  44 *> error bounds and backward error estimates for the solution.
  45 *> \endverbatim
  46 *
  47 *  Arguments:
  48 *  ==========
  49 *
  50 *> \param[in] TRANS
  51 *> \verbatim
  52 *>          TRANS is CHARACTER*1
  53 *>          Specifies the form of the system of equations:
  54 *>          = 'N':  A * X = B     (No transpose)
  55 *>          = 'T':  A**T * X = B  (Transpose)
  56 *>          = 'C':  A**H * X = B  (Conjugate transpose)
  57 *> \endverbatim
  58 *>
  59 *> \param[in] N
  60 *> \verbatim
  61 *>          N is INTEGER
  62 *>          The order of the matrix A.  N >= 0.
  63 *> \endverbatim
  64 *>
  65 *> \param[in] KL
  66 *> \verbatim
  67 *>          KL is INTEGER
  68 *>          The number of subdiagonals within the band of A.  KL >= 0.
  69 *> \endverbatim
  70 *>
  71 *> \param[in] KU
  72 *> \verbatim
  73 *>          KU is INTEGER
  74 *>          The number of superdiagonals within the band of A.  KU >= 0.
  75 *> \endverbatim
  76 *>
  77 *> \param[in] NRHS
  78 *> \verbatim
  79 *>          NRHS is INTEGER
  80 *>          The number of right hand sides, i.e., the number of columns
  81 *>          of the matrices B and X.  NRHS >= 0.
  82 *> \endverbatim
  83 *>
  84 *> \param[in] AB
  85 *> \verbatim
  86 *>          AB is COMPLEX*16 array, dimension (LDAB,N)
  87 *>          The original band matrix A, stored in rows 1 to KL+KU+1.
  88 *>          The j-th column of A is stored in the j-th column of the
  89 *>          array AB as follows:
  90 *>          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
  91 *> \endverbatim
  92 *>
  93 *> \param[in] LDAB
  94 *> \verbatim
  95 *>          LDAB is INTEGER
  96 *>          The leading dimension of the array AB.  LDAB >= KL+KU+1.
  97 *> \endverbatim
  98 *>
  99 *> \param[in] AFB
 100 *> \verbatim
 101 *>          AFB is COMPLEX*16 array, dimension (LDAFB,N)
 102 *>          Details of the LU factorization of the band matrix A, as
 103 *>          computed by ZGBTRF.  U is stored as an upper triangular band
 104 *>          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
 105 *>          the multipliers used during the factorization are stored in
 106 *>          rows KL+KU+2 to 2*KL+KU+1.
 107 *> \endverbatim
 108 *>
 109 *> \param[in] LDAFB
 110 *> \verbatim
 111 *>          LDAFB is INTEGER
 112 *>          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.
 113 *> \endverbatim
 114 *>
 115 *> \param[in] IPIV
 116 *> \verbatim
 117 *>          IPIV is INTEGER array, dimension (N)
 118 *>          The pivot indices from ZGBTRF; for 1<=i<=N, row i of the
 119 *>          matrix was interchanged with row IPIV(i).
 120 *> \endverbatim
 121 *>
 122 *> \param[in] B
 123 *> \verbatim
 124 *>          B is COMPLEX*16 array, dimension (LDB,NRHS)
 125 *>          The right hand side matrix B.
 126 *> \endverbatim
 127 *>
 128 *> \param[in] LDB
 129 *> \verbatim
 130 *>          LDB is INTEGER
 131 *>          The leading dimension of the array B.  LDB >= max(1,N).
 132 *> \endverbatim
 133 *>
 134 *> \param[in,out] X
 135 *> \verbatim
 136 *>          X is COMPLEX*16 array, dimension (LDX,NRHS)
 137 *>          On entry, the solution matrix X, as computed by ZGBTRS.
 138 *>          On exit, the improved solution matrix X.
 139 *> \endverbatim
 140 *>
 141 *> \param[in] LDX
 142 *> \verbatim
 143 *>          LDX is INTEGER
 144 *>          The leading dimension of the array X.  LDX >= max(1,N).
 145 *> \endverbatim
 146 *>
 147 *> \param[out] FERR
 148 *> \verbatim
 149 *>          FERR is DOUBLE PRECISION array, dimension (NRHS)
 150 *>          The estimated forward error bound for each solution vector
 151 *>          X(j) (the j-th column of the solution matrix X).
 152 *>          If XTRUE is the true solution corresponding to X(j), FERR(j)
 153 *>          is an estimated upper bound for the magnitude of the largest
 154 *>          element in (X(j) - XTRUE) divided by the magnitude of the
 155 *>          largest element in X(j).  The estimate is as reliable as
 156 *>          the estimate for RCOND, and is almost always a slight
 157 *>          overestimate of the true error.
 158 *> \endverbatim
 159 *>
 160 *> \param[out] BERR
 161 *> \verbatim
 162 *>          BERR is DOUBLE PRECISION array, dimension (NRHS)
 163 *>          The componentwise relative backward error of each solution
 164 *>          vector X(j) (i.e., the smallest relative change in
 165 *>          any element of A or B that makes X(j) an exact solution).
 166 *> \endverbatim
 167 *>
 168 *> \param[out] WORK
 169 *> \verbatim
 170 *>          WORK is COMPLEX*16 array, dimension (2*N)
 171 *> \endverbatim
 172 *>
 173 *> \param[out] RWORK
 174 *> \verbatim
 175 *>          RWORK is DOUBLE PRECISION array, dimension (N)
 176 *> \endverbatim
 177 *>
 178 *> \param[out] INFO
 179 *> \verbatim
 180 *>          INFO is INTEGER
 181 *>          = 0:  successful exit
 182 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
 183 *> \endverbatim
 184 *
 185 *> \par Internal Parameters:
 186 *  =========================
 187 *>
 188 *> \verbatim
 189 *>  ITMAX is the maximum number of steps of iterative refinement.
 190 *> \endverbatim
 191 *
 192 *  Authors:
 193 *  ========
 194 *
 195 *> \author Univ. of Tennessee
 196 *> \author Univ. of California Berkeley
 197 *> \author Univ. of Colorado Denver
 198 *> \author NAG Ltd.
 199 *
 200 *> \date November 2011
 201 *
 202 *> \ingroup complex16GBcomputational
 203 *
 204 *  =====================================================================
 205       SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
 206      $                   IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
 207      $                   INFO )
 208 *
 209 *  -- LAPACK computational routine (version 3.4.0) --
 210 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 211 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 212 *     November 2011
 213 *
 214 *     .. Scalar Arguments ..
 215       CHARACTER          TRANS
 216       INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
 217 *     ..
 218 *     .. Array Arguments ..
 219       INTEGER            IPIV( * )
 220       DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
 221       COMPLEX*16         AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
 222      $                   WORK( * ), X( LDX, * )
 223 *     ..
 224 *
 225 *  =====================================================================
 226 *
 227 *     .. Parameters ..
 228       INTEGER            ITMAX
 229       PARAMETER          ( ITMAX = 5 )
 230       DOUBLE PRECISION   ZERO
 231       PARAMETER          ( ZERO = 0.0D+0 )
 232       COMPLEX*16         CONE
 233       PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
 234       DOUBLE PRECISION   TWO
 235       PARAMETER          ( TWO = 2.0D+0 )
 236       DOUBLE PRECISION   THREE
 237       PARAMETER          ( THREE = 3.0D+0 )
 238 *     ..
 239 *     .. Local Scalars ..
 240       LOGICAL            NOTRAN
 241       CHARACTER          TRANSN, TRANST
 242       INTEGER            COUNT, I, J, K, KASE, KK, NZ
 243       DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
 244       COMPLEX*16         ZDUM
 245 *     ..
 246 *     .. Local Arrays ..
 247       INTEGER            ISAVE( 3 )
 248 *     ..
 249 *     .. External Subroutines ..
 250       EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGBMV, ZGBTRS, ZLACN2
 251 *     ..
 252 *     .. Intrinsic Functions ..
 253       INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
 254 *     ..
 255 *     .. External Functions ..
 256       LOGICAL            LSAME
 257       DOUBLE PRECISION   DLAMCH
 258       EXTERNAL           LSAME, DLAMCH
 259 *     ..
 260 *     .. Statement Functions ..
 261       DOUBLE PRECISION   CABS1
 262 *     ..
 263 *     .. Statement Function definitions ..
 264       CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
 265 *     ..
 266 *     .. Executable Statements ..
 267 *
 268 *     Test the input parameters.
 269 *
 270       INFO = 0
 271       NOTRAN = LSAME( TRANS, 'N' )
 272       IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
 273      $    LSAME( TRANS, 'C' ) ) THEN
 274          INFO = -1
 275       ELSE IF( N.LT.0 ) THEN
 276          INFO = -2
 277       ELSE IF( KL.LT.0 ) THEN
 278          INFO = -3
 279       ELSE IF( KU.LT.0 ) THEN
 280          INFO = -4
 281       ELSE IF( NRHS.LT.0 ) THEN
 282          INFO = -5
 283       ELSE IF( LDAB.LT.KL+KU+1 ) THEN
 284          INFO = -7
 285       ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
 286          INFO = -9
 287       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
 288          INFO = -12
 289       ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
 290          INFO = -14
 291       END IF
 292       IF( INFO.NE.0 ) THEN
 293          CALL XERBLA( 'ZGBRFS', -INFO )
 294          RETURN
 295       END IF
 296 *
 297 *     Quick return if possible
 298 *
 299       IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
 300          DO 10 J = 1, NRHS
 301             FERR( J ) = ZERO
 302             BERR( J ) = ZERO
 303    10    CONTINUE
 304          RETURN
 305       END IF
 306 *
 307       IF( NOTRAN ) THEN
 308          TRANSN = 'N'
 309          TRANST = 'C'
 310       ELSE
 311          TRANSN = 'C'
 312          TRANST = 'N'
 313       END IF
 314 *
 315 *     NZ = maximum number of nonzero elements in each row of A, plus 1
 316 *
 317       NZ = MIN( KL+KU+2, N+1 )
 318       EPS = DLAMCH( 'Epsilon' )
 319       SAFMIN = DLAMCH( 'Safe minimum' )
 320       SAFE1 = NZ*SAFMIN
 321       SAFE2 = SAFE1 / EPS
 322 *
 323 *     Do for each right hand side
 324 *
 325       DO 140 J = 1, NRHS
 326 *
 327          COUNT = 1
 328          LSTRES = THREE
 329    20    CONTINUE
 330 *
 331 *        Loop until stopping criterion is satisfied.
 332 *
 333 *        Compute residual R = B - op(A) * X,
 334 *        where op(A) = A, A**T, or A**H, depending on TRANS.
 335 *
 336          CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
 337          CALL ZGBMV( TRANS, N, N, KL, KU, -CONE, AB, LDAB, X( 1, J ), 1,
 338      $               CONE, WORK, 1 )
 339 *
 340 *        Compute componentwise relative backward error from formula
 341 *
 342 *        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
 343 *
 344 *        where abs(Z) is the componentwise absolute value of the matrix
 345 *        or vector Z.  If the i-th component of the denominator is less
 346 *        than SAFE2, then SAFE1 is added to the i-th components of the
 347 *        numerator and denominator before dividing.
 348 *
 349          DO 30 I = 1, N
 350             RWORK( I ) = CABS1( B( I, J ) )
 351    30    CONTINUE
 352 *
 353 *        Compute abs(op(A))*abs(X) + abs(B).
 354 *
 355          IF( NOTRAN ) THEN
 356             DO 50 K = 1, N
 357                KK = KU + 1 - K
 358                XK = CABS1( X( K, J ) )
 359                DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
 360                   RWORK( I ) = RWORK( I ) + CABS1( AB( KK+I, K ) )*XK
 361    40          CONTINUE
 362    50       CONTINUE
 363          ELSE
 364             DO 70 K = 1, N
 365                S = ZERO
 366                KK = KU + 1 - K
 367                DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
 368                   S = S + CABS1( AB( KK+I, K ) )*CABS1( X( I, J ) )
 369    60          CONTINUE
 370                RWORK( K ) = RWORK( K ) + S
 371    70       CONTINUE
 372          END IF
 373          S = ZERO
 374          DO 80 I = 1, N
 375             IF( RWORK( I ).GT.SAFE2 ) THEN
 376                S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
 377             ELSE
 378                S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
 379      $             ( RWORK( I )+SAFE1 ) )
 380             END IF
 381    80    CONTINUE
 382          BERR( J ) = S
 383 *
 384 *        Test stopping criterion. Continue iterating if
 385 *           1) The residual BERR(J) is larger than machine epsilon, and
 386 *           2) BERR(J) decreased by at least a factor of 2 during the
 387 *              last iteration, and
 388 *           3) At most ITMAX iterations tried.
 389 *
 390          IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
 391      $       COUNT.LE.ITMAX ) THEN
 392 *
 393 *           Update solution and try again.
 394 *
 395             CALL ZGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, WORK, N,
 396      $                   INFO )
 397             CALL ZAXPY( N, CONE, WORK, 1, X( 1, J ), 1 )
 398             LSTRES = BERR( J )
 399             COUNT = COUNT + 1
 400             GO TO 20
 401          END IF
 402 *
 403 *        Bound error from formula
 404 *
 405 *        norm(X - XTRUE) / norm(X) .le. FERR =
 406 *        norm( abs(inv(op(A)))*
 407 *           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
 408 *
 409 *        where
 410 *          norm(Z) is the magnitude of the largest component of Z
 411 *          inv(op(A)) is the inverse of op(A)
 412 *          abs(Z) is the componentwise absolute value of the matrix or
 413 *             vector Z
 414 *          NZ is the maximum number of nonzeros in any row of A, plus 1
 415 *          EPS is machine epsilon
 416 *
 417 *        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
 418 *        is incremented by SAFE1 if the i-th component of
 419 *        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
 420 *
 421 *        Use ZLACN2 to estimate the infinity-norm of the matrix
 422 *           inv(op(A)) * diag(W),
 423 *        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
 424 *
 425          DO 90 I = 1, N
 426             IF( RWORK( I ).GT.SAFE2 ) THEN
 427                RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
 428             ELSE
 429                RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
 430      $                      SAFE1
 431             END IF
 432    90    CONTINUE
 433 *
 434          KASE = 0
 435   100    CONTINUE
 436          CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
 437          IF( KASE.NE.0 ) THEN
 438             IF( KASE.EQ.1 ) THEN
 439 *
 440 *              Multiply by diag(W)*inv(op(A)**H).
 441 *
 442                CALL ZGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
 443      $                      WORK, N, INFO )
 444                DO 110 I = 1, N
 445                   WORK( I ) = RWORK( I )*WORK( I )
 446   110          CONTINUE
 447             ELSE
 448 *
 449 *              Multiply by inv(op(A))*diag(W).
 450 *
 451                DO 120 I = 1, N
 452                   WORK( I ) = RWORK( I )*WORK( I )
 453   120          CONTINUE
 454                CALL ZGBTRS( TRANSN, N, KL, KU, 1, AFB, LDAFB, IPIV,
 455      $                      WORK, N, INFO )
 456             END IF
 457             GO TO 100
 458          END IF
 459 *
 460 *        Normalize error.
 461 *
 462          LSTRES = ZERO
 463          DO 130 I = 1, N
 464             LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
 465   130    CONTINUE
 466          IF( LSTRES.NE.ZERO )
 467      $      FERR( J ) = FERR( J ) / LSTRES
 468 *
 469   140 CONTINUE
 470 *
 471       RETURN
 472 *
 473 *     End of ZGBRFS
 474 *
 475       END