void cblas_sspmv(const enum CBLAS_ORDER order,
const enum CBLAS_UPLO Uplo, const integer N,
const float alpha, const float *AP,
const float *X, const integer incX, const float beta,
float *Y, const integer incY)
{
char UL;
#ifdef F77_CHAR
F77_CHAR F77_UL;
#else
#define F77_UL &UL
#endif
#define F77_N N
#define F77_incX incX
#define F77_incY incY
extern integer CBLAS_CallFromC;
extern integer RowMajorStrg;
RowMajorStrg = 0;
CBLAS_CallFromC = 1;
if (order == CblasColMajor)
{
if (Uplo == CblasUpper) UL = 'U';
else if (Uplo == CblasLower) UL = 'L';
else
{
cblas_xerbla(2, "cblas_sspmv","Illegal Uplo setting, %d\n",Uplo );
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
sspmv_(F77_UL, &F77_N, &alpha, AP, X,
&F77_incX, &beta, Y, &F77_incY);
}
else if (order == CblasRowMajor)
{
RowMajorStrg = 1;
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_sspmv","Illegal Uplo setting, %d\n", Uplo);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
sspmv_(F77_UL, &F77_N, &alpha,
AP, X,&F77_incX, &beta, Y, &F77_incY);
}
else cblas_xerbla(1, "cblas_sspmv", "Illegal Order setting, %d\n", order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
}
int
f2c_sspmv(char* uplo, integer* N,
real* alpha,
real* Ap,
real* X, integer* incX,
real* beta,
real* Y, integer* incY)
{
sspmv_(uplo, N, alpha, Ap,
X, incX, beta, Y, incY);
return 0;
}
/* Subroutine */ int sspgst_(integer *itype, char *uplo, integer *n, real *ap,
real *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2;
real r__1;
/* Local variables */
integer j, k, j1, k1, jj, kk;
real ct, ajj;
integer j1j1;
real akk;
integer k1k1;
real bjj, bkk;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), sspmv_(char *, integer *, real *, real *,
real *, integer *, real *, real *, integer *), stpmv_(
char *, char *, char *, integer *, real *, real *, integer *), stpsv_(char *, char *, char *, integer *,
real *, real *, integer *), xerbla_(char
*, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSPGST 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 SPPTRF. */
/* 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) REAL 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) REAL 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 SPPTRF. */
/* 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_("SSPGST", &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];
stpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], &
c__1);
i__2 = j - 1;
sspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, &
ap[j1], &c__1);
i__2 = j - 1;
r__1 = 1.f / bjj;
sscal_(&i__2, &r__1, &ap[j1], &c__1);
i__2 = j - 1;
ap[jj] = (ap[jj] - sdot_(&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 */
r__1 = bkk;
akk /= r__1 * r__1;
ap[kk] = akk;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
sscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
ct = akk * -.5f;
i__2 = *n - k;
saxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
sspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1]);
i__2 = *n - k;
saxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
stpsv_(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;
stpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1);
ct = akk * .5f;
i__2 = k - 1;
saxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
sspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1]);
i__2 = k - 1;
saxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
sscal_(&i__2, &bkk, &ap[k1], &c__1);
/* Computing 2nd power */
r__1 = bkk;
ap[kk] = akk * (r__1 * r__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 + sdot_(&i__2, &ap[jj + 1], &c__1, &bp[jj
+ 1], &c__1);
i__2 = *n - j;
sscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
sspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b11, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
stpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj],
&c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of SSPGST */
} /* sspgst_ */
void
sspmv(char uplo, int n, float alpha, float *ap, float *x, int incx, float beta, float *y, int incy)
{
sspmv_( &uplo, &n, &alpha, ap, x, &incx, &beta, y, &incy );
}
/* Subroutine */ int spprfs_(char *uplo, integer *n, integer *nrhs, real *ap,
real *afp, real *b, integer *ldb, real *x, integer *ldx, real *ferr,
real *berr, real *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
=======
SPPRFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric positive definite
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) REAL 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)*(2n-j)/2) = A(i,j) for j<=i<=n.
AFP (input) REAL array, dimension (N*(N+1)/2)
The triangular factor U or L from the Cholesky factorization
A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,
packed columnwise in a linear array in the same format as A
(see AP).
B (input) REAL 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) REAL array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by SPPTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL 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) REAL 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) REAL 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 real c_b12 = -1.f;
static real c_b14 = 1.f;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j, k;
static real s;
extern logical lsame_(char *, char *);
static integer count;
static logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *), sspmv_(char *, integer *, real *, real *, real *,
integer *, real *, real *, integer *);
static integer ik, kk;
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
static real lstres;
extern /* Subroutine */ int spptrs_(char *, integer *, integer *, real *,
real *, integer *, integer *);
static real 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;
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 = -7;
} else if (*ldx < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPPRFS", &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.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("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.f;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
scopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1);
sspmv_(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__] = (r__1 = b_ref(i__, j), dabs(r__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.f;
xk = (r__1 = x_ref(k, j), dabs(r__1));
ik = kk;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk;
s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x_ref(i__, j),
dabs(r__2));
++ik;
/* L40: */
}
work[k] = work[k] + (r__1 = ap[kk + k - 1], dabs(r__1)) * xk
+ s;
kk += k;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
xk = (r__1 = x_ref(k, j), dabs(r__1));
work[k] += (r__1 = ap[kk], dabs(r__1)) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk;
s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x_ref(i__, j),
dabs(r__2));
++ik;
/* L60: */
}
work[k] += s;
kk += *n - k + 1;
/* L70: */
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
i__];
s = dmax(r__2,r__3);
} else {
/* Computing MAX */
r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
/ (work[i__] + safe1);
s = dmax(r__2,r__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.f <= lstres && count <= 5) {
/* Update solution and try again. */
spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
saxpy_(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 SLACON 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__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__];
} else {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
slacon_(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'). */
spptrs_(uplo, n, &c__1, &afp[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: */
}
spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = x_ref(i__, j), dabs(r__1));
lstres = dmax(r__2,r__3);
/* L130: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of SPPRFS */
} /* spprfs_ */
/* Subroutine */ int ssptri_(char *uplo, integer *n, real *ap, integer *ipiv,
real *work, 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
=======
SSPTRI 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 SSPTRF.
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) REAL 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 SSPTRF,
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 SSPTRF.
WORK (workspace) REAL 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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static real c_b11 = -1.f;
static real c_b13 = 0.f;
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static real temp;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static real akkp1, d;
static integer j, k;
static real t;
extern logical lsame_(char *, char *);
static integer kstep;
static logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
), sspmv_(char *, integer *, real *, real *, real *, integer *,
real *, real *, integer *);
static real ak;
static integer kc, kp, kx;
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer kcnext, kpc, npp;
static real akp1;
#define WORK(I) work[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define AP(I) ap[(I)-1]
*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_("SSPTRI", &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.f) {
return 0;
}
kp -= *info;
/* L10: */
}
} 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.f) {
return 0;
}
kp = kp + *n - *info + 1;
/* L20: */
}
}
*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.f / AP(kc + k - 1);
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
scopy_(&i__1, &AP(kc), &c__1, &WORK(1), &c__1);
i__1 = k - 1;
sspmv_(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) -= sdot_(&i__1, &WORK(1), &c__1, &AP(kc), &
c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = (r__1 = AP(kcnext + k - 1), dabs(r__1));
ak = AP(kc + k - 1) / t;
akp1 = AP(kcnext + k) / t;
akkp1 = AP(kcnext + k - 1) / t;
d = t * (ak * akp1 - 1.f);
AP(kc + k - 1) = akp1 / d;
AP(kcnext + k) = ak / d;
AP(kcnext + k - 1) = -(doublereal)akkp1 / d;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
scopy_(&i__1, &AP(kc), &c__1, &WORK(1), &c__1);
i__1 = k - 1;
sspmv_(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) -= sdot_(&i__1, &WORK(1), &c__1, &AP(kc), &
c__1);
i__1 = k - 1;
AP(kcnext + k - 1) -= sdot_(&i__1, &AP(kc), &c__1, &AP(kcnext)
, &c__1);
i__1 = k - 1;
scopy_(&i__1, &AP(kcnext), &c__1, &WORK(1), &c__1);
i__1 = k - 1;
sspmv_(uplo, &i__1, &c_b11, &AP(1), &WORK(1), &c__1, &c_b13, &
AP(kcnext), &c__1);
i__1 = k - 1;
AP(kcnext + k) -= sdot_(&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;
sswap_(&i__1, &AP(kc), &c__1, &AP(kpc), &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1; j <= k-1; ++j) {
kx = kx + j - 1;
temp = AP(kc + j - 1);
AP(kc + j - 1) = AP(kx);
AP(kx) = temp;
/* L40: */
}
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.f / AP(kc);
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
scopy_(&i__1, &AP(kc + 1), &c__1, &WORK(1), &c__1);
i__1 = *n - k;
sspmv_(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) -= sdot_(&i__1, &WORK(1), &c__1, &AP(kc + 1), &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = (r__1 = AP(kcnext + 1), dabs(r__1));
ak = AP(kcnext) / t;
akp1 = AP(kc) / t;
akkp1 = AP(kcnext + 1) / t;
d = t * (ak * akp1 - 1.f);
AP(kcnext) = akp1 / d;
AP(kc) = ak / d;
AP(kcnext + 1) = -(doublereal)akkp1 / d;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
scopy_(&i__1, &AP(kc + 1), &c__1, &WORK(1), &c__1);
i__1 = *n - k;
sspmv_(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) -= sdot_(&i__1, &WORK(1), &c__1, &AP(kc + 1), &c__1);
i__1 = *n - k;
AP(kcnext + 1) -= sdot_(&i__1, &AP(kc + 1), &c__1, &AP(kcnext
+ 2), &c__1);
i__1 = *n - k;
scopy_(&i__1, &AP(kcnext + 2), &c__1, &WORK(1), &c__1);
i__1 = *n - k;
sspmv_(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) -= sdot_(&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;
sswap_(&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 <= kp-1; ++j) {
kx = kx + *n - j + 1;
temp = AP(kc + j - k);
AP(kc + j - k) = AP(kx);
AP(kx) = temp;
/* L70: */
}
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 SSPTRI */
} /* ssptri_ */
/* Subroutine */
int spprfs_(char *uplo, integer *n, integer *nrhs, real *ap, real *afp, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k;
real s;
integer ik, kk;
real xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3], count;
logical upper;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *), sspmv_(char *, integer *, real *, real *, real *, integer *, real *, real *, integer *), slacn2_(integer *, real *, real *, integer *, real *, integer *, integer *);
extern real slamch_(char *);
real safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
real lstres;
extern /* Subroutine */
int spptrs_(char *, integer *, integer *, real *, real *, 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;
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 = -7;
}
else if (*ldx < max(1,*n))
{
*info = -9;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SPPRFS", &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.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("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.f;
L20: /* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
sspmv_(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__] = (r__1 = b[i__ + j * b_dim1], f2c_abs(r__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.f;
xk = (r__1 = x[k + j * x_dim1], f2c_abs(r__1));
ik = kk;
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
work[i__] += (r__1 = ap[ik], f2c_abs(r__1)) * xk;
s += (r__1 = ap[ik], f2c_abs(r__1)) * (r__2 = x[i__ + j * x_dim1], f2c_abs(r__2));
++ik;
/* L40: */
}
work[k] = work[k] + (r__1 = ap[kk + k - 1], f2c_abs(r__1)) * xk + s;
kk += k;
/* L50: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
xk = (r__1 = x[k + j * x_dim1], f2c_abs(r__1));
work[k] += (r__1 = ap[kk], f2c_abs(r__1)) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
work[i__] += (r__1 = ap[ik], f2c_abs(r__1)) * xk;
s += (r__1 = ap[ik], f2c_abs(r__1)) * (r__2 = x[i__ + j * x_dim1], f2c_abs(r__2));
++ik;
/* L60: */
}
work[k] += s;
kk += *n - k + 1;
/* L70: */
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (work[i__] > safe2)
{
/* Computing MAX */
r__2 = s;
r__3 = (r__1 = work[*n + i__], f2c_abs(r__1)) / work[ i__]; // , expr subst
s = max(r__2,r__3);
}
else
{
/* Computing MAX */
r__2 = s;
r__3 = ((r__1 = work[*n + i__], f2c_abs(r__1)) + safe1) / (work[i__] + safe1); // , expr subst
s = max(r__2,r__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.f <= lstres && count <= 5)
{
/* Update solution and try again. */
spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
saxpy_(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 SLACN2 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__] = (r__1 = work[*n + i__], f2c_abs(r__1)) + nz * eps * work[i__];
}
else
{
work[i__] = (r__1 = work[*n + i__], f2c_abs(r__1)) + nz * eps * work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
slacn2_(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). */
spptrs_(uplo, n, &c__1, &afp[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: */
}
spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
/* Computing MAX */
r__2 = lstres;
r__3 = (r__1 = x[i__ + j * x_dim1], f2c_abs(r__1)); // , expr subst
lstres = max(r__2,r__3);
/* L130: */
}
if (lstres != 0.f)
{
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of SPPRFS */
}
/* Subroutine */ int ssptrd_(char *uplo, integer *n, real *ap, real *d, real *
e, real *tau, 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
=======
SSPTRD 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) REAL 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) REAL array, dimension (N)
The diagonal elements of the tridiagonal matrix T:
D(i) = A(i,i).
E (output) REAL 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) REAL 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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static real c_b8 = 0.f;
static real c_b14 = -1.f;
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static real taui;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static integer i;
extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *);
static real alpha;
extern logical lsame_(char *, char *);
static integer i1;
static logical upper;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), sspmv_(char *, integer *, real *, real *,
real *, integer *, real *, real *, integer *);
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *), slarfg_(
integer *, real *, real *, integer *, real *);
static integer i1i1;
#define TAU(I) tau[(I)-1]
#define E(I) e[(I)-1]
#define D(I) d[(I)-1]
#define AP(I) ap[(I)-1]
*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_("SSPTRD", &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) */
slarfg_(&i, &AP(i1 + i - 1), &AP(i1), &c__1, &taui);
E(i) = AP(i1 + i - 1);
if (taui != 0.f) {
/* Apply H(i) from both sides to A(1:i,1:i) */
AP(i1 + i - 1) = 1.f;
/* Compute y := tau * A * v storing y in TAU(1:
i) */
sspmv_(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 * -.5f * sdot_(&i, &TAU(1), &c__1, &AP(i1), &
c__1);
saxpy_(&i, &alpha, &AP(i1), &c__1, &TAU(1), &c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
sspr2_(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 <= *n-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;
slarfg_(&i__2, &AP(ii + 1), &AP(ii + 2), &c__1, &taui);
E(i) = AP(ii + 1);
if (taui != 0.f) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n)
*/
AP(ii + 1) = 1.f;
/* Compute y := tau * A * v storing y in TAU(i:
n-1) */
i__2 = *n - i;
sspmv_(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 * -.5f * sdot_(&i__2, &TAU(i), &c__1, &AP(ii + 1)
, &c__1);
i__2 = *n - i;
saxpy_(&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;
sspr2_(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 SSPTRD */
} /* ssptrd_ */
/* Subroutine */ int ssptri_(char *uplo, integer *n, real *ap, integer *ipiv,
real *work, integer *info)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
real d__;
integer j, k;
real t, ak;
integer kc, kp, kx, kpc, npp;
real akp1, temp;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
real akkp1;
extern logical lsame_(char *, char *);
integer kstep;
logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
), sspmv_(char *, integer *, real *, real *, real *, integer *,
real *, real *, integer *), xerbla_(char *, integer *);
integer kcnext;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSPTRI 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 SSPTRF. */
/* 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) REAL 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 SSPTRF, */
/* 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 SSPTRF. */
/* WORK (workspace) REAL 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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_("SSPTRI", &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.f) {
return 0;
}
kp -= *info;
/* L10: */
}
} 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.f) {
return 0;
}
kp = kp + *n - *info + 1;
/* L20: */
}
}
*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.f / ap[kc + k - 1];
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
scopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
sspmv_(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] -= sdot_(&i__1, &work[1], &c__1, &ap[kc], &
c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (r__1 = ap[kcnext + k - 1], dabs(r__1));
ak = ap[kc + k - 1] / t;
akp1 = ap[kcnext + k] / t;
akkp1 = ap[kcnext + k - 1] / t;
d__ = t * (ak * akp1 - 1.f);
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;
scopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
sspmv_(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] -= sdot_(&i__1, &work[1], &c__1, &ap[kc], &
c__1);
i__1 = k - 1;
ap[kcnext + k - 1] -= sdot_(&i__1, &ap[kc], &c__1, &ap[kcnext]
, &c__1);
i__1 = k - 1;
scopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
sspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
ap[kcnext], &c__1);
i__1 = k - 1;
ap[kcnext + k] -= sdot_(&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;
sswap_(&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;
/* L40: */
}
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.f / ap[kc];
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
scopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
sspmv_(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] -= sdot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (r__1 = ap[kcnext + 1], dabs(r__1));
ak = ap[kcnext] / t;
akp1 = ap[kc] / t;
akkp1 = ap[kcnext + 1] / t;
d__ = t * (ak * akp1 - 1.f);
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;
scopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
sspmv_(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] -= sdot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
i__1 = *n - k;
ap[kcnext + 1] -= sdot_(&i__1, &ap[kc + 1], &c__1, &ap[kcnext
+ 2], &c__1);
i__1 = *n - k;
scopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
sspmv_(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] -= sdot_(&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;
sswap_(&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;
/* L70: */
}
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 SSPTRI */
} /* ssptri_ */
/* Subroutine */ int sppt03_(char *uplo, integer *n, real *a, real *ainv,
real *work, integer *ldwork, real *rwork, real *rcond, real *resid)
{
/* System generated locals */
integer work_dim1, work_offset, i__1, i__2;
/* Local variables */
integer i__, j, jj;
real eps;
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sspmv_(char *, integer *, real *, real *, real *,
integer *, real *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
real ainvnm;
extern doublereal slansp_(char *, char *, integer *, real *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPPT03 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) REAL array, dimension (N*(N+1)/2) */
/* The original symmetric matrix A, stored as a packed */
/* triangular matrix. */
/* AINV (input) REAL array, dimension (N*(N+1)/2) */
/* The (symmetric) inverse of the matrix A, stored as a packed */
/* triangular matrix. */
/* WORK (workspace) REAL array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of A, computed as */
/* ( 1/norm(A) ) / norm(AINV). */
/* RESID (output) REAL */
/* 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.f;
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = slamch_("Epsilon");
anorm = slansp_("1", uplo, n, &a[1], &rwork[1]);
ainvnm = slansp_("1", uplo, n, &ainv[1], &rwork[1]);
if (anorm <= 0.f || ainvnm == 0.f) {
*rcond = 0.f;
*resid = 1.f / eps;
return 0;
}
*rcond = 1.f / 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) {
scopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], &
c__1);
i__2 = j - 1;
scopy_(&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;
scopy_(&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) {
sspmv_("Upper", n, &c_b13, &a[1], &work[(j + 1) * work_dim1 + 1],
&c__1, &c_b15, &work[j * work_dim1 + 1], &c__1)
;
/* L20: */
}
sspmv_("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;
scopy_(&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;
scopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], &
c__1);
i__2 = *n - j;
scopy_(&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) {
sspmv_("Lower", n, &c_b13, &a[1], &work[(j - 1) * work_dim1 + 1],
&c__1, &c_b15, &work[j * work_dim1 + 1], &c__1)
;
/* L40: */
}
sspmv_("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.f;
/* L50: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = slange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
*resid = *resid * *rcond / eps / (real) (*n);
return 0;
/* End of SPPT03 */
} /* sppt03_ */
/* Subroutine */ int ssprfs_(char *uplo, integer *n, integer *nrhs, real *ap,
real *afp, integer *ipiv, real *b, integer *ldb, real *x, integer *
ldx, real *ferr, real *berr, real *work, integer *iwork, integer *
info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k;
real s;
integer ik, kk;
real xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3], count;
logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *), sspmv_(char *, integer *, real *, real *, real *,
integer *, real *, real *, integer *), slacn2_(integer *,
real *, real *, integer *, real *, integer *, integer *);
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real lstres;
extern /* Subroutine */ int ssptrs_(char *, integer *, integer *, real *,
integer *, real *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call SLACN2 in place of SLACON, 5 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSPRFS 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) REAL 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) REAL 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 SSPTRF, 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 SSPTRF. */
/* B (input) REAL 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) REAL array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by SSPTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) REAL 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) REAL 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) REAL 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. */
/* ===================================================================== */
/* .. 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_("SSPRFS", &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.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("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.f;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
sspmv_(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__] = (r__1 = b[i__ + j * b_dim1], dabs(r__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.f;
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
ik = kk;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk;
s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x[i__ + j *
x_dim1], dabs(r__2));
++ik;
/* L40: */
}
work[k] = work[k] + (r__1 = ap[kk + k - 1], dabs(r__1)) * xk
+ s;
kk += k;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
work[k] += (r__1 = ap[kk], dabs(r__1)) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk;
s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x[i__ + j *
x_dim1], dabs(r__2));
++ik;
/* L60: */
}
work[k] += s;
kk += *n - k + 1;
/* L70: */
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
i__];
s = dmax(r__2,r__3);
} else {
/* Computing MAX */
r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
/ (work[i__] + safe1);
s = dmax(r__2,r__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.f <= lstres && count <= 5) {
/* Update solution and try again. */
ssptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
saxpy_(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 SLACN2 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__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__];
} else {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
slacn2_(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'). */
ssptrs_(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: */
}
ssptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
lstres = dmax(r__2,r__3);
/* L130: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of SSPRFS */
} /* ssprfs_ */
/* Subroutine */ int sppt02_(char *uplo, integer *n, integer *nrhs, real *a,
real *x, integer *ldx, real *b, integer *ldb, real *rwork, real *
resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real eps, anorm, bnorm;
extern doublereal sasum_(integer *, real *, integer *);
real xnorm;
extern /* Subroutine */ int sspmv_(char *, integer *, real *, real *,
real *, integer *, real *, real *, integer *);
extern doublereal slamch_(char *), slansp_(char *, char *,
integer *, real *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPPT02 computes the residual in the solution of a symmetric system */
/* of linear equations A*x = b when packed storage is used for the */
/* coefficient matrix. The ratio computed is */
/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */
/* where EPS is the machine precision. */
/* 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. */
/* NRHS (input) INTEGER */
/* The number of columns of B, the matrix of right hand sides. */
/* NRHS >= 0. */
/* A (input) REAL array, dimension (N*(N+1)/2) */
/* The original symmetric matrix A, stored as a packed */
/* triangular matrix. */
/* X (input) REAL array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - A*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
--a;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = slansp_("1", uplo, n, &a[1], &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute B - A*X for the matrix of right hand sides B. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
sspmv_(uplo, n, &c_b5, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b7, &b[j *
b_dim1 + 1], &c__1);
/* L10: */
}
/* Compute the maximum over the number of right hand sides of */
/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = sasum_(n, &b[j * b_dim1 + 1], &c__1);
xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L20: */
}
return 0;
/* End of SPPT02 */
} /* sppt02_ */
