int
f2c_dspmv(char* uplo, integer* N,
doublereal* alpha,
doublereal* Ap,
doublereal* X, integer* incX,
doublereal* beta,
doublereal* Y, integer* incY)
{
dspmv_(uplo, N, alpha, Ap,
X, incX, beta, Y, incY);
return 0;
}
void
dspmv(char uplo, int n, double alpha, double *ap, double *x, int incx, double beta, double *y, int incy)
{
dspmv_( &uplo, &n, &alpha, ap, x, &incx, &beta, y, &incy );
}
/* Subroutine */ int dsptri_(char *uplo, integer *n, doublereal *ap, integer *
ipiv, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
doublereal d__;
integer j, k;
doublereal t, ak;
integer kc, kp, kx, kpc, npp;
doublereal akp1;
doublereal temp, akkp1;
integer kstep;
logical upper;
integer kcnext;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DSPTRI computes the inverse of a real symmetric indefinite matrix */
/* A in packed storage using the factorization A = U*D*U**T or */
/* A = L*D*L**T computed by DSPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by DSPTRF, */
/* stored as a packed triangular matrix. */
/* On exit, if INFO = 0, the (symmetric) inverse of the original */
/* matrix, stored as a packed triangular matrix. The j-th column */
/* of inv(A) is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSPTRF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
/* inverse could not be computed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--work;
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
kp = *n * (*n + 1) / 2;
for (*info = *n; *info >= 1; --(*info)) {
if (ipiv[*info] > 0 && ap[kp] == 0.) {
return 0;
}
kp -= *info;
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
kp = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (ipiv[*info] > 0 && ap[kp] == 0.) {
return 0;
}
kp = kp + *n - *info + 1;
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
kcnext = kc + k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
ap[kc + k - 1] = 1. / ap[kc + k - 1];
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
ap[kc], &c__1);
i__1 = k - 1;
ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], &
c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (d__1 = ap[kcnext + k - 1], abs(d__1));
ak = ap[kc + k - 1] / t;
akp1 = ap[kcnext + k] / t;
akkp1 = ap[kcnext + k - 1] / t;
d__ = t * (ak * akp1 - 1.);
ap[kc + k - 1] = akp1 / d__;
ap[kcnext + k] = ak / d__;
ap[kcnext + k - 1] = -akkp1 / d__;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
ap[kc], &c__1);
i__1 = k - 1;
ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], &
c__1);
i__1 = k - 1;
ap[kcnext + k - 1] -= ddot_(&i__1, &ap[kc], &c__1, &ap[kcnext]
, &c__1);
i__1 = k - 1;
dcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
ap[kcnext], &c__1);
i__1 = k - 1;
ap[kcnext + k] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext], &
c__1);
}
kstep = 2;
kcnext = kcnext + k + 1;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading */
/* submatrix A(1:k+1,1:k+1) */
kpc = (kp - 1) * kp / 2 + 1;
i__1 = kp - 1;
dswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
temp = ap[kc + j - 1];
ap[kc + j - 1] = ap[kx];
ap[kx] = temp;
}
temp = ap[kc + k - 1];
ap[kc + k - 1] = ap[kpc + kp - 1];
ap[kpc + kp - 1] = temp;
if (kstep == 2) {
temp = ap[kc + k + k - 1];
ap[kc + k + k - 1] = ap[kc + k + kp - 1];
ap[kc + k + kp - 1] = temp;
}
}
k += kstep;
kc = kcnext;
goto L30;
L50:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
npp = *n * (*n + 1) / 2;
k = *n;
kc = npp;
L60:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L80;
}
kcnext = kc - (*n - k + 2);
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
ap[kc] = 1. / ap[kc];
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
dspmv_(uplo, &i__1, &c_b11, &ap[kc + *n - k + 1], &work[1], &
c__1, &c_b13, &ap[kc + 1], &c__1);
i__1 = *n - k;
ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (d__1 = ap[kcnext + 1], abs(d__1));
ak = ap[kcnext] / t;
akp1 = ap[kc] / t;
akkp1 = ap[kcnext + 1] / t;
d__ = t * (ak * akp1 - 1.);
ap[kcnext] = akp1 / d__;
ap[kc] = ak / d__;
ap[kcnext + 1] = -akkp1 / d__;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1],
&c__1, &c_b13, &ap[kc + 1], &c__1);
i__1 = *n - k;
ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
i__1 = *n - k;
ap[kcnext + 1] -= ddot_(&i__1, &ap[kc + 1], &c__1, &ap[kcnext
+ 2], &c__1);
i__1 = *n - k;
dcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1],
&c__1, &c_b13, &ap[kcnext + 2], &c__1);
i__1 = *n - k;
ap[kcnext] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext + 2], &
c__1);
}
kstep = 2;
kcnext -= *n - k + 3;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing */
/* submatrix A(k-1:n,k-1:n) */
kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
c__1);
}
kx = kc + kp - k;
i__1 = kp - 1;
for (j = k + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
temp = ap[kc + j - k];
ap[kc + j - k] = ap[kx];
ap[kx] = temp;
}
temp = ap[kc];
ap[kc] = ap[kpc];
ap[kpc] = temp;
if (kstep == 2) {
temp = ap[kc - *n + k - 1];
ap[kc - *n + k - 1] = ap[kc - *n + kp - 1];
ap[kc - *n + kp - 1] = temp;
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of DSPTRI */
} /* dsptri_ */
/* Subroutine */ int dlarhs_(char *path, char *xtype, char *uplo, char *trans,
integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
b, integer *ldb, integer *iseed, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static logical band;
static char diag[1];
static logical tran;
static integer j;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *),
dgbmv_(char *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dsbmv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dtbmv_(char *,
char *, char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *), dtrmm_(char *,
char *, char *, char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static char c1[1], c2[2];
extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dsymm_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dtpmv_(
char *, char *, char *, integer *, doublereal *, doublereal *,
integer *);
static integer mb, nx;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
static logical notran, gen, tri, qrs, sym;
#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]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLARHS chooses a set of NRHS random solution vectors and sets
up the right hand sides for the linear system
op( A ) * X = B,
where op( A ) may be A or A' (transpose of A).
Arguments
=========
PATH (input) CHARACTER*3
The type of the real matrix A. PATH may be given in any
combination of upper and lower case. Valid types include
xGE: General m x n matrix
xGB: General banded matrix
xPO: Symmetric positive definite, 2-D storage
xPP: Symmetric positive definite packed
xPB: Symmetric positive definite banded
xSY: Symmetric indefinite, 2-D storage
xSP: Symmetric indefinite packed
xSB: Symmetric indefinite banded
xTR: Triangular
xTP: Triangular packed
xTB: Triangular banded
xQR: General m x n matrix
xLQ: General m x n matrix
xQL: General m x n matrix
xRQ: General m x n matrix
where the leading character indicates the precision.
XTYPE (input) CHARACTER*1
Specifies how the exact solution X will be determined:
= 'N': New solution; generate a random X.
= 'C': Computed; use value of X on entry.
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
matrix A is stored, if A is symmetric.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to the matrix A.
= 'N': System is A * x = b
= 'T': System is A'* x = b
= 'C': System is A'* x = b
M (input) INTEGER
The number or rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
KL (input) INTEGER
Used only if A is a band matrix; specifies the number of
subdiagonals of A if A is a general band matrix or if A is
symmetric or triangular and UPLO = 'L'; specifies the number
of superdiagonals of A if A is symmetric or triangular and
UPLO = 'U'. 0 <= KL <= M-1.
KU (input) INTEGER
Used only if A is a general band matrix or if A is
triangular.
If PATH = xGB, specifies the number of superdiagonals of A,
and 0 <= KU <= N-1.
If PATH = xTR, xTP, or xTB, specifies whether or not the
matrix has unit diagonal:
= 1: matrix has non-unit diagonal (default)
= 2: matrix has unit diagonal
NRHS (input) INTEGER
The number of right hand side vectors in the system A*X = B.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The test matrix whose type is given by PATH.
LDA (input) INTEGER
The leading dimension of the array A.
If PATH = xGB, LDA >= KL+KU+1.
If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
Otherwise, LDA >= max(1,M).
X (input or output) DOUBLE PRECISION array, dimension(LDX,NRHS)
On entry, if XTYPE = 'C' (for 'Computed'), then X contains
the exact solution to the system of linear equations.
On exit, if XTYPE = 'N' (for 'New'), then X is initialized
with random values.
LDX (input) INTEGER
The leading dimension of the array X. If TRANS = 'N',
LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
B (output) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side vector(s) for the system of equations,
computed from B = op(A) * X, where op(A) is determined by
TRANS.
LDB (input) INTEGER
The leading dimension of the array B. If TRANS = 'N',
LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
ISEED (input/output) INTEGER array, dimension (4)
The seed vector for the random number generator (used in
DLATMS). Modified on exit.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--iseed;
/* Function Body */
*info = 0;
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
tran = lsame_(trans, "T") || lsame_(trans, "C");
notran = ! tran;
gen = lsame_(path + 1, "G");
qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
"Q");
sym = lsame_(path + 1, "P") || lsame_(path + 1,
"S");
tri = lsame_(path + 1, "T");
band = lsame_(path + 2, "B");
if (! lsame_(c1, "Double precision")) {
*info = -1;
} else if (! (lsame_(xtype, "N") || lsame_(xtype,
"C"))) {
*info = -2;
} else if ((sym || tri) && ! (lsame_(uplo, "U") ||
lsame_(uplo, "L"))) {
*info = -3;
} else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
*info = -4;
} else if (*m < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (band && *kl < 0) {
*info = -7;
} else if (band && *ku < 0) {
*info = -8;
} else if (*nrhs < 0) {
*info = -9;
} else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
kl + 1 || band && gen && *lda < *kl + *ku + 1) {
*info = -11;
} else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
*info = -13;
} else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLARHS", &i__1);
return 0;
}
/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
if (tran) {
nx = *m;
mb = *n;
} else {
nx = *n;
mb = *m;
}
if (! lsame_(xtype, "C")) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dlarnv_(&c__2, &iseed[1], n, &x_ref(1, j));
/* L10: */
}
}
/* Multiply X by op( A ) using an appropriate
matrix multiply routine. */
if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
"QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
lsamen_(&c__2, c2, "RQ")) {
/* General matrix */
dgemm_(trans, "N", &mb, nrhs, &nx, &c_b32, &a[a_offset], lda, &x[
x_offset], ldx, &c_b33, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
c__2, c2, "SY")) {
/* Symmetric matrix, 2-D storage */
dsymm_("Left", uplo, n, nrhs, &c_b32, &a[a_offset], lda, &x[x_offset],
ldx, &c_b33, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dgbmv_(trans, &mb, &nx, kl, ku, &c_b32, &a[a_offset], lda, &x_ref(
1, j), &c__1, &c_b33, &b_ref(1, j), &c__1);
/* L20: */
}
} else if (lsamen_(&c__2, c2, "PB")) {
/* Symmetric matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dsbmv_(uplo, n, kl, &c_b32, &a[a_offset], lda, &x_ref(1, j), &
c__1, &c_b33, &b_ref(1, j), &c__1);
/* L30: */
}
} else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
c__2, c2, "SP")) {
/* Symmetric matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dspmv_(uplo, n, &c_b32, &a[a_offset], &x_ref(1, j), &c__1, &c_b33,
&b_ref(1, j), &c__1);
/* L40: */
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrix. Note that for triangular matrices,
KU = 1 => non-unit triangular
KU = 2 => unit triangular */
dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
dtrmm_("Left", uplo, trans, diag, n, nrhs, &c_b32, &a[a_offset], lda,
&b[b_offset], ldb)
;
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular matrix, packed storage */
dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dtpmv_(uplo, trans, diag, n, &a[a_offset], &b_ref(1, j), &c__1);
/* L50: */
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular matrix, banded storage */
dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dtbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b_ref(1, j),
&c__1);
/* L60: */
}
} else {
/* If PATH is none of the above, return with an error code. */
*info = -1;
i__1 = -(*info);
xerbla_("DLARHS", &i__1);
}
return 0;
/* End of DLARHS */
} /* dlarhs_ */
/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n,
doublereal *ap, doublereal *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
integer j, k, j1, k1, jj, kk;
doublereal ct, ajj;
integer j1j1;
doublereal akk;
integer k1k1;
doublereal bjj, bkk;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dspmv_(char *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
logical upper;
extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
doublereal *, doublereal *, integer *),
dtpsv_(char *, char *, char *, integer *, doublereal *,
doublereal *, integer *), xerbla_(char *,
integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSPGST reduces a real symmetric-definite generalized eigenproblem */
/* to standard form, using packed storage. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */
/* B must have been previously factorized as U**T*U or L*L**T by DPPTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */
/* = 2 or 3: compute U*A*U**T or L**T*A*L. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**T*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**T. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The triangular factor from the Cholesky factorization of B, */
/* stored in the same format as A, as returned by DPPTRF. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPGST", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
bjj = bp[jj];
dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], &
c__1);
i__2 = j - 1;
dspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, &
ap[j1], &c__1);
i__2 = j - 1;
d__1 = 1. / bjj;
dscal_(&i__2, &d__1, &ap[j1], &c__1);
i__2 = j - 1;
ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], &
c__1)) / bjj;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
akk = ap[kk];
bkk = bp[kk];
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
ap[kk] = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
dspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1]);
i__2 = *n - k;
daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
akk = ap[kk];
bkk = bp[kk];
i__2 = k - 1;
dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
dspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1]);
i__2 = k - 1;
daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
dscal_(&i__2, &bkk, &ap[k1], &c__1);
/* Computing 2nd power */
d__1 = bkk;
ap[kk] = akk * (d__1 * d__1);
/* L30: */
}
} else {
/* Compute L'*A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
ajj = ap[jj];
bjj = bp[jj];
i__2 = *n - j;
ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj
+ 1], &c__1);
i__2 = *n - j;
dscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
dspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b11, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj],
&c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of DSPGST */
} /* dspgst_ */
/* Subroutine */
int dspgst_(integer *itype, char *uplo, integer *n, doublereal *ap, doublereal *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
integer j, k, j1, k1, jj, kk;
doublereal ct, ajj;
integer j1j1;
doublereal akk;
integer k1k1;
doublereal bjj, bkk;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
extern /* Subroutine */
int dspr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dspmv_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *);
logical upper;
extern /* Subroutine */
int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), dtpsv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3)
{
*info = -1;
}
else if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSPGST", &i__1);
return 0;
}
if (*itype == 1)
{
if (upper)
{
/* Compute inv(U**T)*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
bjj = bp[jj];
dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], & c__1);
i__2 = j - 1;
dspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, & ap[j1], &c__1);
i__2 = j - 1;
d__1 = 1. / bjj;
dscal_(&i__2, &d__1, &ap[j1], &c__1);
i__2 = j - 1;
ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], & c__1)) / bjj;
/* L10: */
}
}
else
{
/* Compute inv(L)*A*inv(L**T) */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
akk = ap[kk];
bkk = bp[kk];
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
ap[kk] = akk;
if (k < *n)
{
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
dspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]);
i__2 = *n - k;
daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
}
else
{
if (upper)
{
/* Compute U*A*U**T */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
akk = ap[kk];
bkk = bp[kk];
i__2 = k - 1;
dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
dspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]);
i__2 = k - 1;
daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
dscal_(&i__2, &bkk, &ap[k1], &c__1);
/* Computing 2nd power */
d__1 = bkk;
ap[kk] = akk * (d__1 * d__1);
/* L30: */
}
}
else
{
/* Compute L**T *A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
ajj = ap[jj];
bjj = bp[jj];
i__2 = *n - j;
ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
i__2 = *n - j;
dscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
dspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, & c_b11, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj], &c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of DSPGST */
}
/* Subroutine */
int dsptrd_(char *uplo, integer *n, doublereal *ap, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer i__, i1, ii, i1i1;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal taui;
extern /* Subroutine */
int dspr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *);
doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dspmv_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *);
logical upper;
extern /* Subroutine */
int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--tau;
--e;
--d__;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSPTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0)
{
return 0;
}
if (upper)
{
/* Reduce the upper triangle of A. */
/* I1 is the index in AP of A(1,I+1). */
i1 = *n * (*n - 1) / 2 + 1;
for (i__ = *n - 1;
i__ >= 1;
--i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**T */
/* to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui);
e[i__] = ap[i1 + i__ - 1];
if (taui != 0.)
{
/* Apply H(i) from both sides to A(1:i,1:i) */
ap[i1 + i__ - 1] = 1.;
/* Compute y := tau * A * v storing y in TAU(1:i) */
dspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b8, &tau[ 1], &c__1);
/* Compute w := y - 1/2 * tau * (y**T *v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &ap[i1], & c__1);
daxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**T - w * v**T */
dspr2_(uplo, &i__, &c_b14, &ap[i1], &c__1, &tau[1], &c__1, & ap[1]);
ap[i1 + i__ - 1] = e[i__];
}
d__[i__ + 1] = ap[i1 + i__];
tau[i__] = taui;
i1 -= i__;
/* L10: */
}
d__[1] = ap[1];
}
else
{
/* Reduce the lower triangle of A. II is the index in AP of */
/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
ii = 1;
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i1i1 = ii + *n - i__ + 1;
/* Generate elementary reflector H(i) = I - tau * v * v**T */
/* to annihilate A(i+2:n,i) */
i__2 = *n - i__;
dlarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui);
e[i__] = ap[ii + 1];
if (taui != 0.)
{
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
ap[ii + 1] = 1.;
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & c_b8, &tau[i__], &c__1);
/* Compute w := y - 1/2 * tau * (y**T *v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**T - w * v**T */
i__2 = *n - i__;
dspr2_(uplo, &i__2, &c_b14, &ap[ii + 1], &c__1, &tau[i__], & c__1, &ap[i1i1]);
ap[ii + 1] = e[i__];
}
d__[i__] = ap[ii];
tau[i__] = taui;
ii = i1i1;
/* L20: */
}
d__[*n] = ap[ii];
}
return 0;
/* End of DSPTRD */
}
/* Subroutine */ int dsprfs_(char *uplo, integer *n, integer *nrhs,
doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b,
integer *ldb, doublereal *x, integer *ldx, doublereal *ferr,
doublereal *berr, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, k;
doublereal s;
integer ik, kk;
doublereal xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
integer isave[3];
integer count;
logical upper;
doublereal safmin;
doublereal lstres;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* DSPRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is symmetric indefinite */
/* and packed, and provides error bounds and backward error estimates */
/* for the solution. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The upper or lower triangle of the symmetric matrix A, packed */
/* columnwise in a linear array. The j-th column of A is stored */
/* in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The factored form of the matrix A. AFP contains the block */
/* diagonal matrix D and the multipliers used to obtain the */
/* factor U or L from the factorization A = U*D*U**T or */
/* A = L*D*L**T as computed by DSPTRF, stored as a packed */
/* triangular matrix. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSPTRF. */
/* 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 DSPTRS. */
/* 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 */
--ap;
--afp;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPRFS", &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.;
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
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 - A * X */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, &
work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(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[i__ + j * b_dim1], abs(d__1));
}
/* Compute abs(A)*abs(X) + abs(B). */
kk = 1;
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
xk = (d__1 = x[k + j * x_dim1], abs(d__1));
ik = kk;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j *
x_dim1], abs(d__2));
++ik;
}
work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk +
s;
kk += k;
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
xk = (d__1 = x[k + j * x_dim1], abs(d__1));
work[k] += (d__1 = ap[kk], abs(d__1)) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j *
x_dim1], abs(d__2));
++ik;
}
work[k] += s;
kk += *n - k + 1;
}
}
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);
}
}
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. */
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
;
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of 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(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
/* Use DLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(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;
}
}
kase = 0;
L100:
dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
}
dsptrs_(uplo, n, &c__1, &afp[1], &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[i__ + j * x_dim1], abs(d__1));
lstres = max(d__2,d__3);
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
}
return 0;
/* End of DSPRFS */
} /* dsprfs_ */
/* Subroutine */ int dsptrd_(char *uplo, integer *n, doublereal *ap,
doublereal *d__, doublereal *e, doublereal *tau, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer i__, i1, ii, i1i1;
doublereal taui;
doublereal alpha;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DSPTRD reduces a real symmetric matrix A stored in packed form to */
/* symmetric tridiagonal form T by an orthogonal similarity */
/* transformation: Q**T * A * Q = T. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
/* of A are overwritten by the corresponding elements of the */
/* tridiagonal matrix T, and the elements above the first */
/* superdiagonal, with the array TAU, represent the orthogonal */
/* matrix Q as a product of elementary reflectors; if UPLO */
/* = 'L', the diagonal and first subdiagonal of A are over- */
/* written by the corresponding elements of the tridiagonal */
/* matrix T, and the elements below the first subdiagonal, with */
/* the array TAU, represent the orthogonal matrix Q as a product */
/* of elementary reflectors. See Further Details. */
/* D (output) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n-1) . . . H(2) H(1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */
/* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(n-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */
/* overwriting A(i+2:n,i), and tau is stored in TAU(i). */
/* ===================================================================== */
/* Test the input parameters */
/* Parameter adjustments */
--tau;
--e;
--d__;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A. */
/* I1 is the index in AP of A(1,I+1). */
i1 = *n * (*n - 1) / 2 + 1;
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui);
e[i__] = ap[i1 + i__ - 1];
if (taui != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
ap[i1 + i__ - 1] = 1.;
/* Compute y := tau * A * v storing y in TAU(1:i) */
dspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b8, &tau[
1], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &ap[i1], &
c__1);
daxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
dspr2_(uplo, &i__, &c_b14, &ap[i1], &c__1, &tau[1], &c__1, &
ap[1]);
ap[i1 + i__ - 1] = e[i__];
}
d__[i__ + 1] = ap[i1 + i__];
tau[i__] = taui;
i1 -= i__;
}
d__[1] = ap[1];
} else {
/* Reduce the lower triangle of A. II is the index in AP of */
/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
ii = 1;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i1i1 = ii + *n - i__ + 1;
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(i+2:n,i) */
i__2 = *n - i__;
dlarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui);
e[i__] = ap[ii + 1];
if (taui != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
ap[ii + 1] = 1.;
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
c_b8, &tau[i__], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &ap[ii +
1], &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
i__2 = *n - i__;
dspr2_(uplo, &i__2, &c_b14, &ap[ii + 1], &c__1, &tau[i__], &
c__1, &ap[i1i1]);
ap[ii + 1] = e[i__];
}
d__[i__] = ap[ii];
tau[i__] = taui;
ii = i1i1;
}
d__[*n] = ap[ii];
}
return 0;
/* End of DSPTRD */
} /* dsptrd_ */
/* Subroutine */
int dsprfs_(char *uplo, integer *n, integer *nrhs, doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, k;
doublereal s;
integer ik, kk;
doublereal xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
integer count;
extern /* Subroutine */
int dspmv_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *);
logical upper;
extern /* Subroutine */
int dlacn2_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */
int dsptrs_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--afp;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*ldb < max(1,*n))
{
*info = -8;
}
else if (*ldx < max(1,*n))
{
*info = -10;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSPRFS", &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;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
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 - A * X */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, & work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( f2c_abs(R(i)) / ( f2c_abs(A)*f2c_abs(X) + f2c_abs(B) )(i) ) */
/* where f2c_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[i__ + j * b_dim1], f2c_abs(d__1));
/* L30: */
}
/* Compute f2c_abs(A)*f2c_abs(X) + f2c_abs(B). */
kk = 1;
if (upper)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.;
xk = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
ik = kk;
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
work[i__] += (d__1 = ap[ik], f2c_abs(d__1)) * xk;
s += (d__1 = ap[ik], f2c_abs(d__1)) * (d__2 = x[i__ + j * x_dim1], f2c_abs(d__2));
++ik;
/* L40: */
}
work[k] = work[k] + (d__1 = ap[kk + k - 1], f2c_abs(d__1)) * xk + s;
kk += k;
/* L50: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.;
xk = (d__1 = x[k + j * x_dim1], f2c_abs(d__1));
work[k] += (d__1 = ap[kk], f2c_abs(d__1)) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
work[i__] += (d__1 = ap[ik], f2c_abs(d__1)) * xk;
s += (d__1 = ap[ik], f2c_abs(d__1)) * (d__2 = x[i__ + j * x_dim1], f2c_abs(d__2));
++ik;
/* L60: */
}
work[k] += s;
kk += *n - k + 1;
/* 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__], f2c_abs(d__1)) / work[ i__]; // , expr subst
s = max(d__2,d__3);
}
else
{
/* Computing MAX */
d__2 = s;
d__3 = ((d__1 = work[*n + i__], f2c_abs(d__1)) + safe1) / (work[i__] + safe1); // , expr subst
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. */
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) ;
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( f2c_abs(inv(A))* */
/* ( f2c_abs(R) + NZ*EPS*( f2c_abs(A)*f2c_abs(X)+f2c_abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of A */
/* f2c_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 f2c_abs(R)+NZ*EPS*(f2c_abs(A)*f2c_abs(X)+f2c_abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* f2c_abs(A)*f2c_abs(X) + f2c_abs(B) is less than SAFE2. */
/* Use DLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = f2c_abs(R) + NZ*EPS*( f2c_abs(A)*f2c_abs(X)+f2c_abs(B) ))) */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (work[i__] > safe2)
{
work[i__] = (d__1 = work[*n + i__], f2c_abs(d__1)) + nz * eps * work[i__];
}
else
{
work[i__] = (d__1 = work[*n + i__], f2c_abs(d__1)) + nz * eps * work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Multiply by diag(W)*inv(A**T). */
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
}
else if (kase == 2)
{
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dsptrs_(uplo, n, &c__1, &afp[1], &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[i__ + j * x_dim1], f2c_abs(d__1)); // , expr subst
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.)
{
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of DSPRFS */
}
/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n,
doublereal *ap, doublereal *bp, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DSPGST reduces a real symmetric-definite generalized eigenproblem
to standard form, using packed storage.
If ITYPE = 1, the problem is A*x = lambda*B*x,
and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
B must have been previously factorized as U**T*U or L*L**T by DPPTRF.
Arguments
=========
ITYPE (input) INTEGER
= 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
= 2 or 3: compute U*A*U**T or L**T*A*L.
UPLO (input) CHARACTER
= 'U': Upper triangle of A is stored and B is factored as
U**T*U;
= 'L': Lower triangle of A is stored and B is factored as
L*L**T.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
On exit, if INFO = 0, the transformed matrix, stored in the
same format as A.
BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
The triangular factor from the Cholesky factorization of B,
stored in the same format as A, as returned by DPPTRF.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b9 = -1.;
static doublereal c_b11 = 1.;
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *);
static integer j, k;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dspmv_(char *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
static logical upper;
static integer j1, k1;
extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
doublereal *, doublereal *, integer *),
dtpsv_(char *, char *, char *, integer *, doublereal *,
doublereal *, integer *);
static integer jj, kk;
static doublereal ct;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal ajj;
static integer j1j1;
static doublereal akk;
static integer k1k1;
static doublereal bjj, bkk;
#define BP(I) bp[(I)-1]
#define AP(I) ap[(I)-1]
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPGST", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U)
J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle
of A */
bjj = BP(jj);
dtpsv_(uplo, "Transpose", "Nonunit", &j, &BP(1), &AP(j1), &
c__1);
i__2 = j - 1;
dspmv_(uplo, &i__2, &c_b9, &AP(1), &BP(j1), &c__1, &c_b11, &
AP(j1), &c__1);
i__2 = j - 1;
d__1 = 1. / bjj;
dscal_(&i__2, &d__1, &AP(j1), &c__1);
i__2 = j - 1;
AP(jj) = (AP(jj) - ddot_(&i__2, &AP(j1), &c__1, &BP(j1), &
c__1)) / bjj;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L')
KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
*/
kk = 1;
i__1 = *n;
for (k = 1; k <= *n; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
akk = AP(kk);
bkk = BP(kk);
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
AP(kk) = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &AP(kk + 1), &c__1);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &BP(kk + 1), &c__1, &AP(kk + 1), &c__1)
;
i__2 = *n - k;
dspr2_(uplo, &i__2, &c_b9, &AP(kk + 1), &c__1, &BP(kk + 1)
, &c__1, &AP(k1k1));
i__2 = *n - k;
daxpy_(&i__2, &ct, &BP(kk + 1), &c__1, &AP(kk + 1), &c__1)
;
i__2 = *n - k;
dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &BP(k1k1),
&AP(kk + 1), &c__1);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U'
K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= *n; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
akk = AP(kk);
bkk = BP(kk);
i__2 = k - 1;
dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &BP(1), &AP(
k1), &c__1);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &BP(k1), &c__1, &AP(k1), &c__1);
i__2 = k - 1;
dspr2_(uplo, &i__2, &c_b11, &AP(k1), &c__1, &BP(k1), &c__1, &
AP(1));
i__2 = k - 1;
daxpy_(&i__2, &ct, &BP(k1), &c__1, &AP(k1), &c__1);
i__2 = k - 1;
dscal_(&i__2, &bkk, &AP(k1), &c__1);
/* Computing 2nd power */
d__1 = bkk;
AP(kk) = akk * (d__1 * d__1);
/* L30: */
}
} else {
/* Compute L'*A*L
JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
*/
jj = 1;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle
of A */
ajj = AP(jj);
bjj = BP(jj);
i__2 = *n - j;
AP(jj) = ajj * bjj + ddot_(&i__2, &AP(jj + 1), &c__1, &BP(jj
+ 1), &c__1);
i__2 = *n - j;
dscal_(&i__2, &bjj, &AP(jj + 1), &c__1);
i__2 = *n - j;
dspmv_(uplo, &i__2, &c_b11, &AP(j1j1), &BP(jj + 1), &c__1, &
c_b11, &AP(jj + 1), &c__1);
i__2 = *n - j + 1;
dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &BP(jj), &AP(jj),
&c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of DSPGST */
} /* dspgst_ */
/* Subroutine */ int dspt21_(integer *itype, char *uplo, integer *n, integer *
kband, doublereal *ap, doublereal *d__, doublereal *e, doublereal *u,
integer *ldu, doublereal *vp, doublereal *tau, doublereal *work,
doublereal *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
integer j, jp, jr, jp1, lap;
doublereal ulp;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal unfl, temp;
extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *), dspr2_(char *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *), dgemm_(char *, char *, integer *
, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
integer iinfo;
doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
char cuplo[1];
doublereal vsave;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
logical lower;
extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
doublereal wnorm;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *);
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
extern /* Subroutine */ int dopmtr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSPT21 generally checks a decomposition of the form */
/* A = U S U' */
/* where ' means transpose, A is symmetric (stored in packed format), U */
/* is orthogonal, and S is diagonal (if KBAND=0) or symmetric */
/* tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as a */
/* dense matrix, otherwise the U is expressed as a product of */
/* Householder transformations, whose vectors are stored in the array */
/* "V" and whose scaling constants are in "TAU"; we shall use the */
/* letter "V" to refer to the product of Householder transformations */
/* (which should be equal to U). */
/* Specifically, if ITYPE=1, then: */
/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU' | / ( n ulp ) */
/* If ITYPE=2, then: */
/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
/* If ITYPE=3, then: */
/* RESULT(1) = | I - VU' | / ( n ulp ) */
/* Packed storage means that, for example, if UPLO='U', then the columns */
/* of the upper triangle of A are stored one after another, so that */
/* A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if */
/* UPLO='L', then the columns of the lower triangle of A are stored one */
/* after another in AP, so that A(j+1,j+1) immediately follows A(n,j) */
/* in the array AP. This means that A(i,j) is stored in: */
/* AP( i + j*(j-1)/2 ) if UPLO='U' */
/* AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L' */
/* The array VP bears the same relation to the matrix V that A does to */
/* AP. */
/* For ITYPE > 1, the transformation U is expressed as a product */
/* of Householder transformations: */
/* If UPLO='U', then V = H(n-1)...H(1), where */
/* H(j) = I - tau(j) v(j) v(j)' */
/* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1), */
/* (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ), */
/* the j-th element is 1, and the last n-j elements are 0. */
/* If UPLO='L', then V = H(1)...H(n-1), where */
/* H(j) = I - tau(j) v(j) v(j)' */
/* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the */
/* (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e., */
/* in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .) */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the type of tests to be performed. */
/* 1: U expressed as a dense orthogonal matrix: */
/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU' | / ( n ulp ) */
/* 2: U expressed as a product V of Housholder transformations: */
/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
/* 3: U expressed both as a dense orthogonal matrix and */
/* as a product of Housholder transformations: */
/* RESULT(1) = | I - VU' | / ( n ulp ) */
/* UPLO (input) CHARACTER */
/* If UPLO='U', AP and VP are considered to contain the upper */
/* triangle of A and V. */
/* If UPLO='L', AP and VP are considered to contain the lower */
/* triangle of A and V. */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, DSPT21 does nothing. */
/* It must be at least zero. */
/* KBAND (input) INTEGER */
/* The bandwidth of the matrix. It may only be zero or one. */
/* If zero, then S is diagonal, and E is not referenced. If */
/* one, then S is symmetric tri-diagonal. */
/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The original (unfactored) matrix. It is assumed to be */
/* symmetric, and contains the columns of just the upper */
/* triangle (UPLO='U') or only the lower triangle (UPLO='L'), */
/* packed one after another. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix. */
/* E (input) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
/* (3,2) element, etc. */
/* Not referenced if KBAND=0. */
/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
/* If ITYPE=1 or 3, this contains the orthogonal matrix in */
/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
/* then it is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N and */
/* at least 1. */
/* VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* If ITYPE=2 or 3, the columns of this array contain the */
/* Householder vectors used to describe the orthogonal matrix */
/* in the decomposition, as described in purpose. */
/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
/* is set to one, and later reset to its original value, during */
/* the course of the calculation. */
/* If ITYPE=1, then it is neither referenced nor modified. */
/* TAU (input) DOUBLE PRECISION array, dimension (N) */
/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
/* v(j) v(j)' in the Householder transformation H(j) of */
/* the product U = H(1)...H(n-2) */
/* If ITYPE < 2, then TAU is not referenced. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N) */
/* Workspace. */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The values computed by the two tests described above. The */
/* values are currently limited to 1/ulp, to avoid overflow. */
/* RESULT(1) is always modified. RESULT(2) is modified only */
/* if ITYPE=1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 1) Constants */
/* Parameter adjustments */
--ap;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--vp;
--tau;
--work;
--result;
/* Function Body */
result[1] = 0.;
if (*itype == 1) {
result[2] = 0.;
}
if (*n <= 0) {
return 0;
}
lap = *n * (*n + 1) / 2;
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10. / ulp;
return 0;
}
/* Do Test 1 */
/* Norm of A: */
if (*itype == 3) {
anorm = 1.;
} else {
/* Computing MAX */
d__1 = dlansp_("1", cuplo, n, &ap[1], &work[1]);
anorm = max(d__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U' */
dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
dcopy_(&lap, &ap[1], &c__1, &work[1], &c__1);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -d__[j];
dspr_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1]);
/* L10: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
d__1 = -e[j];
dspr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1)
* u_dim1 + 1], &c__1, &work[1]);
/* L20: */
}
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlansp_("1", cuplo, n, &work[1], &work[i__1 * i__1 + 1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V' - A */
dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
if (lower) {
work[lap] = d__[*n];
for (j = *n - 1; j >= 1; --j) {
jp = ((*n << 1) - j) * (j - 1) / 2;
jp1 = jp + *n - j;
if (*kband == 1) {
work[jp + j + 1] = (1. - tau[j]) * e[j];
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
work[jp + jr] = -tau[j] * e[j] * vp[jp + jr];
/* L30: */
}
}
if (tau[j] != 0.) {
vsave = vp[jp + j + 1];
vp[jp + j + 1] = 1.;
i__1 = *n - j;
dspmv_("L", &i__1, &c_b26, &work[jp1 + j + 1], &vp[jp + j
+ 1], &c__1, &c_b10, &work[lap + 1], &c__1);
i__1 = *n - j;
temp = tau[j] * -.5 * ddot_(&i__1, &work[lap + 1], &c__1,
&vp[jp + j + 1], &c__1);
i__1 = *n - j;
daxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap +
1], &c__1);
i__1 = *n - j;
d__1 = -tau[j];
dspr2_("L", &i__1, &d__1, &vp[jp + j + 1], &c__1, &work[
lap + 1], &c__1, &work[jp1 + j + 1]);
vp[jp + j + 1] = vsave;
}
work[jp + j] = d__[j];
/* L40: */
}
} else {
work[1] = d__[1];
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
jp = j * (j - 1) / 2;
jp1 = jp + j;
if (*kband == 1) {
work[jp1 + j] = (1. - tau[j]) * e[j];
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
work[jp1 + jr] = -tau[j] * e[j] * vp[jp1 + jr];
/* L50: */
}
}
if (tau[j] != 0.) {
vsave = vp[jp1 + j];
vp[jp1 + j] = 1.;
dspmv_("U", &j, &c_b26, &work[1], &vp[jp1 + 1], &c__1, &
c_b10, &work[lap + 1], &c__1);
temp = tau[j] * -.5 * ddot_(&j, &work[lap + 1], &c__1, &
vp[jp1 + 1], &c__1);
daxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
c__1);
d__1 = -tau[j];
dspr2_("U", &j, &d__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
, &c__1, &work[1]);
vp[jp1 + j] = vsave;
}
work[jp1 + j + 1] = d__[j + 1];
/* L60: */
}
}
i__1 = lap;
for (j = 1; j <= i__1; ++j) {
work[j] -= ap[j];
/* L70: */
}
wnorm = dlansp_("1", cuplo, n, &work[1], &work[lap + 1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V' - I */
if (*n < 2) {
return 0;
}
dlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
/* Computing 2nd power */
i__1 = *n;
dopmtr_("R", cuplo, "T", n, n, &vp[1], &tau[1], &work[1], n, &work[
i__1 * i__1 + 1], &iinfo);
if (iinfo != 0) {
result[1] = 10. / ulp;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.;
/* L80: */
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
}
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
result[1] = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
result[1] = min(d__1,d__2) / (*n * ulp);
}
}
/* Do Test 2 */
/* Compute UU' - I */
if (*itype == 1) {
dgemm_("N", "C", n, n, n, &c_b26, &u[u_offset], ldu, &u[u_offset],
ldu, &c_b10, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.;
/* L90: */
}
/* Computing MIN */
/* Computing 2nd power */
i__1 = *n;
d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), d__2 = (doublereal) (*n);
result[2] = min(d__1,d__2) / (*n * ulp);
}
return 0;
/* End of DSPT21 */
} /* dspt21_ */
/* Subroutine */ int dsprfs_(char *uplo, integer *n, integer *nrhs,
doublereal *ap, doublereal *afp, 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
=======
DSPRFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric indefinite
and packed, and provides error bounds and backward error estimates
for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
The upper or lower triangle of the symmetric matrix A, packed
columnwise in a linear array. The j-th column of A is stored
in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
The factored form of the matrix A. AFP contains the block
diagonal matrix D and the multipliers used to obtain the
factor U or L from the factorization A = U*D*U**T or
A = L*D*L**T as computed by DSPTRF, stored as a packed
triangular matrix.
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by DSPTRF.
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 DSPTRS.
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_b12 = -1.;
static doublereal c_b14 = 1.;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
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 logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer count;
extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
static logical upper;
static integer ik, 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 *);
static doublereal lstres;
extern /* Subroutine */ int dsptrs_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
static doublereal 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]
--ap;
--afp;
--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;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPRFS", &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;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
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 - A * X */
dcopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1);
dspmv_(uplo, n, &c_b12, &ap[1], &x_ref(1, j), &c__1, &c_b14, &work[*n
+ 1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(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(A)*abs(X) + abs(B). */
kk = 1;
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
xk = (d__1 = x_ref(k, j), abs(d__1));
ik = kk;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x_ref(i__, j),
abs(d__2));
++ik;
/* L40: */
}
work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk +
s;
kk += k;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
xk = (d__1 = x_ref(k, j), abs(d__1));
work[k] += (d__1 = ap[kk], abs(d__1)) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x_ref(i__, j),
abs(d__2));
++ik;
/* L60: */
}
work[k] += s;
kk += *n - k + 1;
/* 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. */
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
daxpy_(n, &c_b14, &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(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of 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(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(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(A'). */
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dsptrs_(uplo, n, &c__1, &afp[1], &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 DSPRFS */
} /* dsprfs_ */
/* Subroutine */ int dppt03_(char *uplo, integer *n, doublereal *a,
doublereal *ainv, doublereal *work, integer *ldwork, doublereal *
rwork, doublereal *rcond, doublereal *resid)
{
/* System generated locals */
integer work_dim1, work_offset, i__1, i__2;
/* Local variables */
integer i__, j, jj;
doublereal eps;
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dspmv_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *),
dlansp_(char *, char *, integer *, doublereal *, doublereal *);
doublereal ainvnm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPPT03 computes the residual for a symmetric packed matrix times its */
/* inverse: */
/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The original symmetric matrix A, stored as a packed */
/* triangular matrix. */
/* AINV (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The (symmetric) inverse of the matrix A, stored as a packed */
/* triangular matrix. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of A, computed as */
/* ( 1/norm(A) ) / norm(AINV). */
/* RESID (output) DOUBLE PRECISION */
/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--a;
--ainv;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*rcond = 1.;
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = dlamch_("Epsilon");
anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]);
ainvnm = dlansp_("1", uplo, n, &ainv[1], &rwork[1]);
if (anorm <= 0. || ainvnm == 0.) {
*rcond = 0.;
*resid = 1. / eps;
return 0;
}
*rcond = 1. / anorm / ainvnm;
/* UPLO = 'U': */
/* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */
/* expand it to a full matrix, then multiply by A one column at a */
/* time, moving the result one column to the left. */
if (lsame_(uplo, "U")) {
/* Copy AINV */
jj = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
dcopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], &
c__1);
i__2 = j - 1;
dcopy_(&i__2, &ainv[jj], &c__1, &work[j + (work_dim1 << 1)],
ldwork);
jj += j;
/* L10: */
}
jj = (*n - 1) * *n / 2 + 1;
i__1 = *n - 1;
dcopy_(&i__1, &ainv[jj], &c__1, &work[*n + (work_dim1 << 1)], ldwork);
/* Multiply by A */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
dspmv_("Upper", n, &c_b13, &a[1], &work[(j + 1) * work_dim1 + 1],
&c__1, &c_b15, &work[j * work_dim1 + 1], &c__1)
;
/* L20: */
}
dspmv_("Upper", n, &c_b13, &a[1], &ainv[jj], &c__1, &c_b15, &work[*n *
work_dim1 + 1], &c__1);
/* UPLO = 'L': */
/* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */
/* and multiply by A, moving each column to the right. */
} else {
/* Copy AINV */
i__1 = *n - 1;
dcopy_(&i__1, &ainv[2], &c__1, &work[work_dim1 + 1], ldwork);
jj = *n + 1;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = *n - j + 1;
dcopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], &
c__1);
i__2 = *n - j;
dcopy_(&i__2, &ainv[jj + 1], &c__1, &work[j + j * work_dim1],
ldwork);
jj = jj + *n - j + 1;
/* L30: */
}
/* Multiply by A */
for (j = *n; j >= 2; --j) {
dspmv_("Lower", n, &c_b13, &a[1], &work[(j - 1) * work_dim1 + 1],
&c__1, &c_b15, &work[j * work_dim1 + 1], &c__1)
;
/* L40: */
}
dspmv_("Lower", n, &c_b13, &a[1], &ainv[1], &c__1, &c_b15, &work[
work_dim1 + 1], &c__1);
}
/* Add the identity matrix to WORK . */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__ + i__ * work_dim1] += 1.;
/* L50: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = dlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
*resid = *resid * *rcond / eps / (doublereal) (*n);
return 0;
/* End of DPPT03 */
} /* dppt03_ */
