433 lines
13 KiB
C
433 lines
13 KiB
C
#include "blaswrap.h"
|
|
#ifdef _cpluscplus
|
|
extern "C" {
|
|
#endif
|
|
#include "f2c.h"
|
|
|
|
/* Subroutine */ int dgbrfs_(char *trans, integer *n, integer *kl, integer *
|
|
ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb,
|
|
integer *ldafb, integer *ipiv, doublereal *b, integer *ldb,
|
|
doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
|
|
doublereal *work, integer *iwork, integer *info)
|
|
{
|
|
/* -- LAPACK routine (version 3.0) --
|
|
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
Courant Institute, Argonne National Lab, and Rice University
|
|
September 30, 1994
|
|
|
|
|
|
Purpose
|
|
=======
|
|
|
|
DGBRFS improves the computed solution to a system of linear
|
|
equations when the coefficient matrix is banded, and provides
|
|
error bounds and backward error estimates for the solution.
|
|
|
|
Arguments
|
|
=========
|
|
|
|
TRANS (input) CHARACTER*1
|
|
Specifies the form of the system of equations:
|
|
= 'N': A * X = B (No transpose)
|
|
= 'T': A**T * X = B (Transpose)
|
|
= 'C': A**H * X = B (Conjugate transpose = Transpose)
|
|
|
|
N (input) INTEGER
|
|
The order of the matrix A. N >= 0.
|
|
|
|
KL (input) INTEGER
|
|
The number of subdiagonals within the band of A. KL >= 0.
|
|
|
|
KU (input) INTEGER
|
|
The number of superdiagonals within the band of A. KU >= 0.
|
|
|
|
NRHS (input) INTEGER
|
|
The number of right hand sides, i.e., the number of columns
|
|
of the matrices B and X. NRHS >= 0.
|
|
|
|
AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
|
|
The original band matrix A, stored in rows 1 to KL+KU+1.
|
|
The j-th column of A is stored in the j-th column of the
|
|
array AB as follows:
|
|
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
|
|
|
|
LDAB (input) INTEGER
|
|
The leading dimension of the array AB. LDAB >= KL+KU+1.
|
|
|
|
AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
|
|
Details of the LU factorization of the band matrix A, as
|
|
computed by DGBTRF. U is stored as an upper triangular band
|
|
matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
|
|
the multipliers used during the factorization are stored in
|
|
rows KL+KU+2 to 2*KL+KU+1.
|
|
|
|
LDAFB (input) INTEGER
|
|
The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
|
|
|
|
IPIV (input) INTEGER array, dimension (N)
|
|
The pivot indices from DGBTRF; for 1<=i<=N, row i of the
|
|
matrix was interchanged with row IPIV(i).
|
|
|
|
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
|
|
The right hand side matrix B.
|
|
|
|
LDB (input) INTEGER
|
|
The leading dimension of the array B. LDB >= max(1,N).
|
|
|
|
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
|
|
On entry, the solution matrix X, as computed by DGBTRS.
|
|
On exit, the improved solution matrix X.
|
|
|
|
LDX (input) INTEGER
|
|
The leading dimension of the array X. LDX >= max(1,N).
|
|
|
|
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
|
|
The estimated forward error bound for each solution vector
|
|
X(j) (the j-th column of the solution matrix X).
|
|
If XTRUE is the true solution corresponding to X(j), FERR(j)
|
|
is an estimated upper bound for the magnitude of the largest
|
|
element in (X(j) - XTRUE) divided by the magnitude of the
|
|
largest element in X(j). The estimate is as reliable as
|
|
the estimate for RCOND, and is almost always a slight
|
|
overestimate of the true error.
|
|
|
|
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
|
|
The componentwise relative backward error of each solution
|
|
vector X(j) (i.e., the smallest relative change in
|
|
any element of A or B that makes X(j) an exact solution).
|
|
|
|
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
|
|
|
|
IWORK (workspace) INTEGER array, dimension (N)
|
|
|
|
INFO (output) INTEGER
|
|
= 0: successful exit
|
|
< 0: if INFO = -i, the i-th argument had an illegal value
|
|
|
|
Internal Parameters
|
|
===================
|
|
|
|
ITMAX is the maximum number of steps of iterative refinement.
|
|
|
|
=====================================================================
|
|
|
|
|
|
Test the input parameters.
|
|
|
|
Parameter adjustments */
|
|
/* Table of constant values */
|
|
static integer c__1 = 1;
|
|
static doublereal c_b15 = -1.;
|
|
static doublereal c_b17 = 1.;
|
|
|
|
/* System generated locals */
|
|
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
|
|
x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
|
|
doublereal d__1, d__2, d__3;
|
|
/* Local variables */
|
|
static integer kase;
|
|
static doublereal safe1, safe2;
|
|
static integer i__, j, k;
|
|
static doublereal s;
|
|
extern /* Subroutine */ int dgbmv_(char *, integer *, integer *, integer *
|
|
, integer *, doublereal *, doublereal *, integer *, doublereal *,
|
|
integer *, doublereal *, doublereal *, integer *);
|
|
extern logical lsame_(char *, char *);
|
|
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
|
|
doublereal *, integer *), daxpy_(integer *, doublereal *,
|
|
doublereal *, integer *, doublereal *, integer *);
|
|
static integer count, kk;
|
|
extern doublereal dlamch_(char *);
|
|
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
|
|
integer *, doublereal *, integer *);
|
|
static doublereal xk;
|
|
static integer nz;
|
|
static doublereal safmin;
|
|
extern /* Subroutine */ int xerbla_(char *, integer *), dgbtrs_(
|
|
char *, integer *, integer *, integer *, integer *, doublereal *,
|
|
integer *, integer *, doublereal *, integer *, integer *);
|
|
static logical notran;
|
|
static char transt[1];
|
|
static doublereal lstres, eps;
|
|
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
|
|
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
|
|
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
|
|
|
|
|
|
ab_dim1 = *ldab;
|
|
ab_offset = 1 + ab_dim1 * 1;
|
|
ab -= ab_offset;
|
|
afb_dim1 = *ldafb;
|
|
afb_offset = 1 + afb_dim1 * 1;
|
|
afb -= afb_offset;
|
|
--ipiv;
|
|
b_dim1 = *ldb;
|
|
b_offset = 1 + b_dim1 * 1;
|
|
b -= b_offset;
|
|
x_dim1 = *ldx;
|
|
x_offset = 1 + x_dim1 * 1;
|
|
x -= x_offset;
|
|
--ferr;
|
|
--berr;
|
|
--work;
|
|
--iwork;
|
|
|
|
/* Function Body */
|
|
*info = 0;
|
|
notran = lsame_(trans, "N");
|
|
if (! notran && ! lsame_(trans, "T") && ! lsame_(
|
|
trans, "C")) {
|
|
*info = -1;
|
|
} else if (*n < 0) {
|
|
*info = -2;
|
|
} else if (*kl < 0) {
|
|
*info = -3;
|
|
} else if (*ku < 0) {
|
|
*info = -4;
|
|
} else if (*nrhs < 0) {
|
|
*info = -5;
|
|
} else if (*ldab < *kl + *ku + 1) {
|
|
*info = -7;
|
|
} else if (*ldafb < (*kl << 1) + *ku + 1) {
|
|
*info = -9;
|
|
} else if (*ldb < max(1,*n)) {
|
|
*info = -12;
|
|
} else if (*ldx < max(1,*n)) {
|
|
*info = -14;
|
|
}
|
|
if (*info != 0) {
|
|
i__1 = -(*info);
|
|
xerbla_("DGBRFS", &i__1);
|
|
return 0;
|
|
}
|
|
|
|
/* Quick return if possible */
|
|
|
|
if (*n == 0 || *nrhs == 0) {
|
|
i__1 = *nrhs;
|
|
for (j = 1; j <= i__1; ++j) {
|
|
ferr[j] = 0.;
|
|
berr[j] = 0.;
|
|
/* L10: */
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
if (notran) {
|
|
*(unsigned char *)transt = 'T';
|
|
} else {
|
|
*(unsigned char *)transt = 'N';
|
|
}
|
|
|
|
/* NZ = maximum number of nonzero elements in each row of A, plus 1
|
|
|
|
Computing MIN */
|
|
i__1 = *kl + *ku + 2, i__2 = *n + 1;
|
|
nz = min(i__1,i__2);
|
|
eps = dlamch_("Epsilon");
|
|
safmin = dlamch_("Safe minimum");
|
|
safe1 = nz * safmin;
|
|
safe2 = safe1 / eps;
|
|
|
|
/* Do for each right hand side */
|
|
|
|
i__1 = *nrhs;
|
|
for (j = 1; j <= i__1; ++j) {
|
|
|
|
count = 1;
|
|
lstres = 3.;
|
|
L20:
|
|
|
|
/* Loop until stopping criterion is satisfied.
|
|
|
|
Compute residual R = B - op(A) * X,
|
|
where op(A) = A, A**T, or A**H, depending on TRANS. */
|
|
|
|
dcopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1);
|
|
dgbmv_(trans, n, n, kl, ku, &c_b15, &ab[ab_offset], ldab, &x_ref(1, j)
|
|
, &c__1, &c_b17, &work[*n + 1], &c__1);
|
|
|
|
/* Compute componentwise relative backward error from formula
|
|
|
|
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
|
|
|
|
where abs(Z) is the componentwise absolute value of the matrix
|
|
or vector Z. If the i-th component of the denominator is less
|
|
than SAFE2, then SAFE1 is added to the i-th components of the
|
|
numerator and denominator before dividing. */
|
|
|
|
i__2 = *n;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
work[i__] = (d__1 = b_ref(i__, j), abs(d__1));
|
|
/* L30: */
|
|
}
|
|
|
|
/* Compute abs(op(A))*abs(X) + abs(B). */
|
|
|
|
if (notran) {
|
|
i__2 = *n;
|
|
for (k = 1; k <= i__2; ++k) {
|
|
kk = *ku + 1 - k;
|
|
xk = (d__1 = x_ref(k, j), abs(d__1));
|
|
/* Computing MAX */
|
|
i__3 = 1, i__4 = k - *ku;
|
|
/* Computing MIN */
|
|
i__6 = *n, i__7 = k + *kl;
|
|
i__5 = min(i__6,i__7);
|
|
for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
|
|
work[i__] += (d__1 = ab_ref(kk + i__, k), abs(d__1)) * xk;
|
|
/* L40: */
|
|
}
|
|
/* L50: */
|
|
}
|
|
} else {
|
|
i__2 = *n;
|
|
for (k = 1; k <= i__2; ++k) {
|
|
s = 0.;
|
|
kk = *ku + 1 - k;
|
|
/* Computing MAX */
|
|
i__5 = 1, i__3 = k - *ku;
|
|
/* Computing MIN */
|
|
i__6 = *n, i__7 = k + *kl;
|
|
i__4 = min(i__6,i__7);
|
|
for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
|
|
s += (d__1 = ab_ref(kk + i__, k), abs(d__1)) * (d__2 =
|
|
x_ref(i__, j), abs(d__2));
|
|
/* L60: */
|
|
}
|
|
work[k] += s;
|
|
/* L70: */
|
|
}
|
|
}
|
|
s = 0.;
|
|
i__2 = *n;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
if (work[i__] > safe2) {
|
|
/* Computing MAX */
|
|
d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
|
|
i__];
|
|
s = max(d__2,d__3);
|
|
} else {
|
|
/* Computing MAX */
|
|
d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
|
|
/ (work[i__] + safe1);
|
|
s = max(d__2,d__3);
|
|
}
|
|
/* L80: */
|
|
}
|
|
berr[j] = s;
|
|
|
|
/* Test stopping criterion. Continue iterating if
|
|
1) The residual BERR(J) is larger than machine epsilon, and
|
|
2) BERR(J) decreased by at least a factor of 2 during the
|
|
last iteration, and
|
|
3) At most ITMAX iterations tried. */
|
|
|
|
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
|
|
|
|
/* Update solution and try again. */
|
|
|
|
dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
|
|
, &work[*n + 1], n, info);
|
|
daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x_ref(1, j), &c__1);
|
|
lstres = berr[j];
|
|
++count;
|
|
goto L20;
|
|
}
|
|
|
|
/* Bound error from formula
|
|
|
|
norm(X - XTRUE) / norm(X) .le. FERR =
|
|
norm( abs(inv(op(A)))*
|
|
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
|
|
|
|
where
|
|
norm(Z) is the magnitude of the largest component of Z
|
|
inv(op(A)) is the inverse of op(A)
|
|
abs(Z) is the componentwise absolute value of the matrix or
|
|
vector Z
|
|
NZ is the maximum number of nonzeros in any row of A, plus 1
|
|
EPS is machine epsilon
|
|
|
|
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
|
|
is incremented by SAFE1 if the i-th component of
|
|
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
|
|
|
|
Use DLACON to estimate the infinity-norm of the matrix
|
|
inv(op(A)) * diag(W),
|
|
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
|
|
|
|
i__2 = *n;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
if (work[i__] > safe2) {
|
|
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
|
|
work[i__];
|
|
} else {
|
|
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
|
|
work[i__] + safe1;
|
|
}
|
|
/* L90: */
|
|
}
|
|
|
|
kase = 0;
|
|
L100:
|
|
dlacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
|
|
kase);
|
|
if (kase != 0) {
|
|
if (kase == 1) {
|
|
|
|
/* Multiply by diag(W)*inv(op(A)**T). */
|
|
|
|
dgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
|
|
ipiv[1], &work[*n + 1], n, info);
|
|
i__2 = *n;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
work[*n + i__] *= work[i__];
|
|
/* L110: */
|
|
}
|
|
} else {
|
|
|
|
/* Multiply by inv(op(A))*diag(W). */
|
|
|
|
i__2 = *n;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
work[*n + i__] *= work[i__];
|
|
/* L120: */
|
|
}
|
|
dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
|
|
ipiv[1], &work[*n + 1], n, info);
|
|
}
|
|
goto L100;
|
|
}
|
|
|
|
/* Normalize error. */
|
|
|
|
lstres = 0.;
|
|
i__2 = *n;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
/* Computing MAX */
|
|
d__2 = lstres, d__3 = (d__1 = x_ref(i__, j), abs(d__1));
|
|
lstres = max(d__2,d__3);
|
|
/* L130: */
|
|
}
|
|
if (lstres != 0.) {
|
|
ferr[j] /= lstres;
|
|
}
|
|
|
|
/* L140: */
|
|
}
|
|
|
|
return 0;
|
|
|
|
/* End of DGBRFS */
|
|
|
|
} /* dgbrfs_ */
|
|
|
|
#undef ab_ref
|
|
#undef x_ref
|
|
#undef b_ref
|
|
|
|
|
|
#ifdef _cpluscplus
|
|
}
|
|
#endif
|