int
f2c_stpmv(char* uplo, char* trans, char* diag, integer* N,
real* Ap,
real* X, integer* incX)
{
stpmv_(uplo, trans, diag,
N, Ap, X, incX);
return 0;
}
/* Subroutine */ int sspgvd_(integer *itype, char *jobz, char *uplo, integer *
n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j, neig;
extern logical lsame_(char *, char *);
integer lwmin;
char trans[1];
logical upper, wantz;
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *), stpsv_(char *,
char *, char *, integer *, real *, real *, integer *), xerbla_(char *, integer *);
integer liwmin;
extern /* Subroutine */ int sspevd_(char *, char *, integer *, real *,
real *, real *, integer *, real *, integer *, integer *, integer *
, integer *), spptrf_(char *, integer *, real *,
integer *);
logical lquery;
extern /* Subroutine */ int sspgst_(integer *, char *, integer *, real *,
real *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSPGVD computes all the eigenvalues, and optionally, the eigenvectors */
/* of a real generalized symmetric-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
/* B are assumed to be symmetric, stored in packed format, and B is also */
/* positive definite. */
/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the contents of AP are destroyed. */
/* BP (input/output) REAL array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* B, packed columnwise in a linear array. The j-th column of B */
/* is stored in the array BP as follows: */
/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
/* On exit, the triangular factor U or L from the Cholesky */
/* factorization B = U**T*U or B = L*L**T, in the same storage */
/* format as B. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) REAL array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors. The eigenvectors are normalized as follows: */
/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If N <= 1, LWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LWORK >= 2*N. */
/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the required sizes of the WORK and IWORK */
/* arrays, returns these values as the first entries of the WORK */
/* and IWORK arrays, and no error message related to LWORK or */
/* LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the required sizes of the WORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK and IWORK arrays, and no error message related to */
/* LWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: SPPTRF or SSPEVD returned an error code: */
/* <= N: if INFO = i, SSPEVD failed to converge; */
/* i off-diagonal elements of an intermediate */
/* tridiagonal form did not converge to zero; */
/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info == 0) {
if (*n <= 1) {
liwmin = 1;
lwmin = 1;
} else {
if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = *n << 1;
}
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*liwork < liwmin && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSPGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of BP. */
spptrf_(uplo, n, &bp[1], info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
sspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1],
lwork, &iwork[1], liwork, info);
/* Computing MAX */
r__1 = (real) lwmin;
lwmin = dmax(r__1,work[1]);
/* Computing MAX */
r__1 = (real) liwmin, r__2 = (real) iwork[1];
liwmin = dmax(r__1,r__2);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1);
/* L20: */
}
}
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
return 0;
/* End of SSPGVD */
} /* sspgvd_ */
/* 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
stpmv(char uplo, char transa, char diag, int n, float *ap, float *x, int incx)
{
stpmv_( &uplo, &transa, &diag, &n, ap, x, &incx);
}
/* Subroutine */ int stpt03_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *ap, real *scale, real *cnorm, real *tscal, real *
x, integer *ldx, real *b, integer *ldb, real *work, real *resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
integer j, jj, ix;
real eps, err;
real xscal;
real tnorm, xnorm;
real bignum;
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STPT03 computes the residual for the solution to a scaled triangular */
/* system of equations A*x = s*b or A'*x = s*b when the triangular */
/* matrix A is stored in packed format. Here A' is the transpose of A, */
/* s is a scalar, and x and b are N by NRHS matrices. The test ratio is */
/* the maximum over the number of right hand sides of */
/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
/* where op(A) denotes A or A' and EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': A *x = s*b (No transpose) */
/* = 'T': A'*x = s*b (Transpose) */
/* = 'C': A'*x = s*b (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* 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 X and B. NRHS >= 0. */
/* AP (input) REAL array, dimension (N*(N+1)/2) */
/* The upper or lower triangular 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
/* SCALE (input) REAL */
/* The scaling factor s used in solving the triangular system. */
/* CNORM (input) REAL array, dimension (N) */
/* The 1-norms of the columns of A, not counting the diagonal. */
/* TSCAL (input) REAL */
/* The scaling factor used in computing the 1-norms in CNORM. */
/* CNORM actually contains the column norms of TSCAL*A. */
/* 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) REAL array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* WORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--ap;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Compute the norm of the triangular matrix A using the column */
/* norms already computed by SLATPS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
if (lsame_(uplo, "U")) {
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = tnorm, r__3 = *tscal * (r__1 = ap[jj], dabs(r__1)) +
cnorm[j];
tnorm = dmax(r__2,r__3);
jj = jj + j + 1;
/* L10: */
}
} else {
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = tnorm, r__3 = *tscal * (r__1 = ap[jj], dabs(r__1)) +
cnorm[j];
tnorm = dmax(r__2,r__3);
jj = jj + *n - j + 1;
/* L20: */
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L30: */
}
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
/* Computing MAX */
r__2 = 1.f, r__3 = (r__1 = x[ix + j * x_dim1], dabs(r__1));
xnorm = dmax(r__2,r__3);
xscal = 1.f / xnorm / (real) (*n);
sscal_(n, &xscal, &work[1], &c__1);
stpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
r__1 = -(*scale) * xscal;
saxpy_(n, &r__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
err = *tscal * (r__1 = work[ix], dabs(r__1));
ix = isamax_(n, &x[j * x_dim1 + 1], &c__1);
xnorm = (r__1 = x[ix + j * x_dim1], dabs(r__1));
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L40: */
}
return 0;
/* End of STPT03 */
} /* stpt03_ */
int sspgv_(int *itype, char *jobz, char *uplo, int *
n, float *ap, float *bp, float *w, float *z__, int *ldz, float *work,
int *info)
{
/* System generated locals */
int z_dim1, z_offset, i__1;
/* Local variables */
int j, neig;
extern int lsame_(char *, char *);
char trans[1];
int upper;
extern int sspev_(char *, char *, int *, float *,
float *, float *, int *, float *, int *);
int wantz;
extern int stpmv_(char *, char *, char *, int *,
float *, float *, int *), stpsv_(char *,
char *, char *, int *, float *, float *, int *), xerbla_(char *, int *), spptrf_(char
*, int *, float *, int *), sspgst_(int *, char
*, int *, float *, float *, int *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSPGV computes all the eigenvalues and, optionally, the eigenvectors */
/* of a float generalized symmetric-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
/* Here A and B are assumed to be symmetric, stored in packed format, */
/* and B is also positive definite. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the contents of AP are destroyed. */
/* BP (input/output) REAL array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* B, packed columnwise in a linear array. The j-th column of B */
/* is stored in the array BP as follows: */
/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
/* On exit, the triangular factor U or L from the Cholesky */
/* factorization B = U**T*U or B = L*L**T, in the same storage */
/* format as B. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) REAL array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors. The eigenvectors are normalized as follows: */
/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= MAX(1,N). */
/* WORK (workspace) REAL array, dimension (3*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: SPPTRF or SSPEV returned an error code: */
/* <= N: if INFO = i, SSPEV failed to converge; */
/* i off-diagonal elements of an intermediate */
/* tridiagonal form did not converge to zero. */
/* > N: if INFO = n + i, for 1 <= i <= n, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSPGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
spptrf_(uplo, n, &bp[1], info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
sspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1);
/* L20: */
}
}
}
return 0;
/* End of SSPGV */
} /* sspgv_ */
/* Subroutine */ int stpt01_(char *uplo, char *diag, integer *n, real *ap,
real *ainvp, real *rcond, real *work, real *resid)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
static real anorm;
static logical unitd;
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *);
static integer jc;
extern doublereal slamch_(char *);
static real ainvnm;
extern doublereal slantp_(char *, char *, char *, integer *, real *, real
*);
static real eps;
/* -- 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
=======
STPT01 computes the residual for a triangular matrix A times its
inverse when A is stored in packed format:
RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ),
where EPS is the machine epsilon.
Arguments
==========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input) REAL array, dimension (N*(N+1)/2)
The original upper or lower triangular 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
if UPLO = 'L',
AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
AINVP (input/output) REAL array, dimension (N*(N+1)/2)
On entry, the (triangular) inverse of the matrix A, packed
columnwise in a linear array as in AP.
On exit, the contents of AINVP are destroyed.
RCOND (output) REAL
The reciprocal condition number of A, computed as
1/(norm(A) * norm(AINV)).
WORK (workspace) REAL array, dimension (N)
RESID (output) REAL
norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
=====================================================================
Quick exit if N = 0.
Parameter adjustments */
--work;
--ainvp;
--ap;
/* 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 = slantp_("1", uplo, diag, n, &ap[1], &work[1]);
ainvnm = slantp_("1", uplo, diag, n, &ainvp[1], &work[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
*rcond = 0.f;
*resid = 1.f / eps;
return 0;
}
*rcond = 1.f / anorm / ainvnm;
/* Compute A * AINV, overwriting AINV. */
unitd = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (unitd) {
ainvp[jc + j - 1] = 1.f;
}
/* Form the j-th column of A*AINV */
stpmv_("Upper", "No transpose", diag, &j, &ap[1], &ainvp[jc], &
c__1);
/* Subtract 1 from the diagonal */
ainvp[jc + j - 1] += -1.f;
jc += j;
/* L10: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (unitd) {
ainvp[jc] = 1.f;
}
/* Form the j-th column of A*AINV */
i__2 = *n - j + 1;
stpmv_("Lower", "No transpose", diag, &i__2, &ap[jc], &ainvp[jc],
&c__1);
/* Subtract 1 from the diagonal */
ainvp[jc] += -1.f;
jc = jc + *n - j + 1;
/* L20: */
}
}
/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
*resid = slantp_("1", uplo, "Non-unit", n, &ainvp[1], &work[1]);
*resid = *resid * *rcond / (real) (*n) / eps;
return 0;
/* End of STPT01 */
} /* stpt01_ */
/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx,
real *ferr, real *berr, real *work, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
STPRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular packed
coefficient matrix.
The solution matrix X must be computed by STPTRS or some other
means before entering this routine. STPRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
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 triangular 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.
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
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) REAL array, dimension (LDX,NRHS)
The 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
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static real c_b19 = -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 logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *), stpmv_(char *, char *, char *, integer *, real *,
real *, integer *), stpsv_(char *, char *,
char *, integer *, real *, real *, integer *);
static integer kc;
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 logical notran;
static char transt[1];
static logical nounit;
static real lstres, eps;
#define AP(I) ap[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans,
"C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STPRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.f;
BERR(j) = 0.f;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
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 <= *nrhs; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A or A', depending on TRANS. */
scopy_(n, &X(1,j), &c__1, &WORK(*n + 1), &c__1);
stpmv_(uplo, trans, diag, n, &AP(1), &WORK(*n + 1), &c__1)
;
saxpy_(n, &c_b19, &B(1,j), &c__1, &WORK(*n + 1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = (r__1 = B(i,j), dabs(r__1));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
xk = (r__1 = X(k,j), dabs(r__1));
i__3 = k;
for (i = 1; i <= k; ++i) {
WORK(i) += (r__1 = AP(kc + i - 1), dabs(r__1)) *
xk;
/* L30: */
}
kc += k;
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
xk = (r__1 = X(k,j), dabs(r__1));
i__3 = k - 1;
for (i = 1; i <= k-1; ++i) {
WORK(i) += (r__1 = AP(kc + i - 1), dabs(r__1)) *
xk;
/* L50: */
}
WORK(k) += xk;
kc += k;
/* L60: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
xk = (r__1 = X(k,j), dabs(r__1));
i__3 = *n;
for (i = k; i <= *n; ++i) {
WORK(i) += (r__1 = AP(kc + i - k), dabs(r__1)) *
xk;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
xk = (r__1 = X(k,j), dabs(r__1));
i__3 = *n;
for (i = k + 1; i <= *n; ++i) {
WORK(i) += (r__1 = AP(kc + i - k), dabs(r__1)) *
xk;
/* L90: */
}
WORK(k) += xk;
kc = kc + *n - k + 1;
/* L100: */
}
}
}
} else {
/* Compute abs(A')*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.f;
i__3 = k;
for (i = 1; i <= k; ++i) {
s += (r__1 = AP(kc + i - 1), dabs(r__1)) * (r__2 =
X(i,j), dabs(r__2));
/* L110: */
}
WORK(k) += s;
kc += k;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = (r__1 = X(k,j), dabs(r__1));
i__3 = k - 1;
for (i = 1; i <= k-1; ++i) {
s += (r__1 = AP(kc + i - 1), dabs(r__1)) * (r__2 =
X(i,j), dabs(r__2));
/* L130: */
}
WORK(k) += s;
kc += k;
/* L140: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.f;
i__3 = *n;
for (i = k; i <= *n; ++i) {
s += (r__1 = AP(kc + i - k), dabs(r__1)) * (r__2 =
X(i,j), dabs(r__2));
/* L150: */
}
WORK(k) += s;
kc = kc + *n - k + 1;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = (r__1 = X(k,j), dabs(r__1));
i__3 = *n;
for (i = k + 1; i <= *n; ++i) {
s += (r__1 = AP(kc + i - k), dabs(r__1)) * (r__2 =
X(i,j), dabs(r__2));
/* L170: */
}
WORK(k) += s;
kc = kc + *n - k + 1;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i = 1; i <= *n; ++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);
}
/* L190: */
}
BERR(j) = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X
)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B
))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use SLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++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;
}
/* L200: */
}
kase = 0;
L210:
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(op(A)'). */
stpsv_(uplo, transt, diag, n, &AP(1), &WORK(*n + 1), &c__1);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L230: */
}
stpsv_(uplo, trans, diag, n, &AP(1), &WORK(*n + 1), &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = X(i,j), dabs(r__1));
lstres = dmax(r__2,r__3);
/* L240: */
}
if (lstres != 0.f) {
FERR(j) /= lstres;
}
/* L250: */
}
return 0;
/* End of STPRFS */
} /* stprfs_ */
/* Subroutine */ int sppt01_(char *uplo, integer *n, real *a, real *afac,
real *rwork, real *resid)
{
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, k;
real t;
integer kc;
real eps;
integer npp;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
integer *, real *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real anorm;
extern /* Subroutine */ int stpmv_(char *, char *, char *, 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 */
/* ======= */
/* SPPT01 reconstructs a symmetric positive definite packed matrix A */
/* from its L*L' or U'*U factorization and computes the residual */
/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/* norm( U'*U - A ) / ( N * norm(A) * 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. */
/* AFAC (input/output) REAL array, dimension (N*(N+1)/2) */
/* On entry, the factor L or U from the L*L' or U'*U */
/* factorization of A, stored as a packed triangular matrix. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*L' - A (or U'*U - A). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
--rwork;
--afac;
--a;
/* Function Body */
if (*n <= 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 the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
kc = *n * (*n - 1) / 2 + 1;
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
t = sdot_(&k, &afac[kc], &c__1, &afac[kc], &c__1);
afac[kc + k - 1] = t;
/* Compute the rest of column K. */
if (k > 1) {
i__1 = k - 1;
stpmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[1], &
afac[kc], &c__1);
kc -= k - 1;
}
/* L10: */
}
/* Compute the product L*L', overwriting L. */
} else {
kc = *n * (*n + 1) / 2;
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k < *n) {
i__1 = *n - k;
sspr_("Lower", &i__1, &c_b14, &afac[kc + 1], &c__1, &afac[kc
+ *n - k + 1]);
}
/* Scale column K by the diagonal element. */
t = afac[kc];
i__1 = *n - k + 1;
sscal_(&i__1, &t, &afac[kc], &c__1);
kc -= *n - k + 2;
/* L20: */
}
}
/* Compute the difference L*L' - A (or U'*U - A). */
npp = *n * (*n + 1) / 2;
i__1 = npp;
for (i__ = 1; i__ <= i__1; ++i__) {
afac[i__] -= a[i__];
/* L30: */
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = slansp_("1", uplo, n, &afac[1], &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of SPPT01 */
} /* sppt01_ */
/* Subroutine */ int stptri_(char *uplo, char *diag, integer *n, real *ap,
integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer j, jc, jj;
real ajj;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *), xerbla_(char *
, integer *);
integer jclast;
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STPTRI computes the inverse of a real upper or lower triangular */
/* matrix A stored in packed format. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* 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 triangular matrix A, stored */
/* 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. */
/* See below for further details. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same packed storage format. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
/* matrix is singular and its inverse can not be computed. */
/* Further Details */
/* =============== */
/* A triangular matrix A can be transferred to packed storage using one */
/* of the following program segments: */
/* UPLO = 'U': UPLO = 'L': */
/* JC = 1 JC = 1 */
/* DO 2 J = 1, N DO 2 J = 1, N */
/* DO 1 I = 1, J DO 1 I = J, N */
/* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */
/* 1 CONTINUE 1 CONTINUE */
/* JC = JC + J JC = JC + N - J + 1 */
/* 2 CONTINUE 2 CONTINUE */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STPTRI", &i__1);
return 0;
}
/* Check for singularity if non-unit. */
if (nounit) {
if (upper) {
jj = 0;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
jj += *info;
if (ap[jj] == 0.f) {
return 0;
}
/* L10: */
}
} else {
jj = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (ap[jj] == 0.f) {
return 0;
}
jj = jj + *n - *info + 1;
/* L20: */
}
}
*info = 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
ap[jc + j - 1] = 1.f / ap[jc + j - 1];
ajj = -ap[jc + j - 1];
} else {
ajj = -1.f;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
stpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], &
c__1);
i__2 = j - 1;
sscal_(&i__2, &ajj, &ap[jc], &c__1);
jc += j;
/* L30: */
}
} else {
/* Compute inverse of lower triangular matrix. */
jc = *n * (*n + 1) / 2;
for (j = *n; j >= 1; --j) {
if (nounit) {
ap[jc] = 1.f / ap[jc];
ajj = -ap[jc];
} else {
ajj = -1.f;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
stpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[
jc + 1], &c__1);
i__1 = *n - j;
sscal_(&i__1, &ajj, &ap[jc + 1], &c__1);
}
jclast = jc;
jc = jc - *n + j - 2;
/* L40: */
}
}
return 0;
/* End of STPTRI */
} /* stptri_ */
/* Subroutine */ int sspgvd_(integer *itype, char *jobz, char *uplo, integer *
n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
SSPGVD computes all the eigenvalues, and optionally, the eigenvectors
of a real generalized symmetric-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
B are assumed to be symmetric, stored in packed format, and B is also
positive definite.
If eigenvectors are desired, it uses a divide and conquer algorithm.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, the contents of AP are destroyed.
BP (input/output) REAL array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
B, packed columnwise in a linear array. The j-th column of B
is stored in the array BP as follows:
if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
On exit, the triangular factor U or L from the Cholesky
factorization B = U**T*U or B = L*L**T, in the same storage
format as B.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) REAL array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
eigenvectors. The eigenvectors are normalized as follows:
if ITYPE = 1 or 2, Z**T*B*Z = I;
if ITYPE = 3, Z**T*inv(B)*Z = I.
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace/output) REAL array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If N <= 1, LWORK >= 1.
If JOBZ = 'N' and N > 1, LWORK >= 2*N.
If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK.
If JOBZ = 'N' or N <= 1, LIWORK >= 1.
If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: SPPTRF or SSPEVD returned an error code:
<= N: if INFO = i, SSPEVD failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
/* Local variables */
static integer neig, j;
extern logical lsame_(char *, char *);
static integer lwmin;
static char trans[1];
static logical upper, wantz;
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *), stpsv_(char *,
char *, char *, integer *, real *, real *, integer *), xerbla_(char *, integer *);
static integer liwmin;
extern /* Subroutine */ int sspevd_(char *, char *, integer *, real *,
real *, real *, integer *, real *, integer *, integer *, integer *
, integer *), spptrf_(char *, integer *, real *,
integer *);
static logical lquery;
extern /* Subroutine */ int sspgst_(integer *, char *, integer *, real *,
real *, integer *);
static integer lgn;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
lgn = 0;
liwmin = 1;
lwmin = 1;
} else {
lgn = (integer) (log((real) (*n)) / log(2.f));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 5 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = *n << 1;
}
}
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldz < max(1,*n)) {
*info = -9;
} else if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*liwork < liwmin && ! lquery) {
*info = -13;
}
if (*info == 0) {
work[1] = (real) lwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSPGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of BP. */
spptrf_(uplo, n, &bp[1], info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
sspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1],
lwork, &iwork[1], liwork, info);
/* Computing MAX */
r__1 = (real) lwmin;
lwmin = dmax(r__1,work[1]);
/* Computing MAX */
r__1 = (real) liwmin, r__2 = (real) iwork[1];
liwmin = dmax(r__1,r__2);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), &
c__1);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), &
c__1);
/* L20: */
}
}
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
return 0;
/* End of SSPGVD */
} /* sspgvd_ */
/* Subroutine */ int spptri_(char *uplo, integer *n, real *ap, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
SPPTRI computes the inverse of a real symmetric positive definite
matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
computed by SPPTRF.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangular factor is stored in AP;
= 'L': Lower triangular factor is stored in AP.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) REAL array, dimension (N*(N+1)/2)
On entry, the triangular factor U or L from the Cholesky
factorization A = U**T*U or A = L*L**T, packed columnwise as
a linear array. The j-th column of U or L is stored in the
array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
On exit, the upper or lower triangle of the (symmetric)
inverse of A, overwriting the input factor U or L.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the (i,i) element of the factor U or L is
zero, and the inverse could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b8 = 1.f;
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2;
/* Local variables */
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
integer *, real *);
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical upper;
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *);
static integer jc, jj;
extern /* Subroutine */ int xerbla_(char *, integer *), stptri_(
char *, char *, integer *, real *, integer *);
static real ajj;
static integer jjn;
--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_("SPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
stptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0) {
return 0;
}
if (upper) {
/* Compute the product inv(U) * inv(U)'. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
if (j > 1) {
i__2 = j - 1;
sspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
ajj = ap[jj];
sscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
} else {
/* Compute the product inv(L)' * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
ap[jj] = sdot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
if (j < *n) {
i__2 = *n - j;
stpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[
jj + 1], &c__1);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of SPPTRI */
} /* spptri_ */
/* Subroutine */
int spptri_(char *uplo, integer *n, real *ap, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer j, jc, jj;
real ajj;
integer jjn;
extern real sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */
int sspr_(char *, integer *, real *, real *, integer *, real *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */
int stpmv_(char *, char *, char *, integer *, real *, real *, integer *), xerbla_(char * , integer *), stptri_(char *, char *, integer *, real *, 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--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_("SPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
stptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0)
{
return 0;
}
if (upper)
{
/* Compute the product inv(U) * inv(U)**T. */
jj = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
jc = jj + 1;
jj += j;
if (j > 1)
{
i__2 = j - 1;
sspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
ajj = ap[jj];
sscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
}
else
{
/* Compute the product inv(L)**T * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
ap[jj] = sdot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
if (j < *n)
{
i__2 = *n - j;
stpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ jj + 1], &c__1);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of SPPTRI */
}
/* Subroutine */
int stprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, real *ap, 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 kc;
real xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
logical upper;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *), stpmv_(char *, char *, char *, integer *, real *, real *, integer *), stpsv_(char *, char *, char *, integer *, real *, real *, integer *), slacn2_(integer *, real *, real *, integer *, real *, integer *, integer *);
extern real slamch_(char *);
real safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
logical notran;
char transt[1];
logical nounit;
real lstres;
/* -- 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;
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");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*nrhs < 0)
{
*info = -5;
}
else if (*ldb < max(1,*n))
{
*info = -8;
}
else if (*ldx < max(1,*n))
{
*info = -10;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("STPRFS", &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;
}
if (notran)
{
*(unsigned char *)transt = 'T';
}
else
{
*(unsigned char *)transt = 'N';
}
/* 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)
{
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A or A**T, depending on TRANS. */
scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
stpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1);
saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( f2c_abs(R(i)) / ( f2c_abs(op(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));
/* L20: */
}
if (notran)
{
/* Compute f2c_abs(A)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
kc = 1;
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
xk = (r__1 = x[k + j * x_dim1], f2c_abs(r__1));
i__3 = k;
for (i__ = 1;
i__ <= i__3;
++i__)
{
work[i__] += (r__1 = ap[kc + i__ - 1], f2c_abs(r__1)) * xk;
/* L30: */
}
kc += k;
/* L40: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
xk = (r__1 = x[k + j * x_dim1], f2c_abs(r__1));
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
work[i__] += (r__1 = ap[kc + i__ - 1], f2c_abs(r__1)) * xk;
/* L50: */
}
work[k] += xk;
kc += k;
/* L60: */
}
}
}
else
{
kc = 1;
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
xk = (r__1 = x[k + j * x_dim1], f2c_abs(r__1));
i__3 = *n;
for (i__ = k;
i__ <= i__3;
++i__)
{
work[i__] += (r__1 = ap[kc + i__ - k], f2c_abs(r__1)) * xk;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
xk = (r__1 = x[k + j * x_dim1], f2c_abs(r__1));
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
work[i__] += (r__1 = ap[kc + i__ - k], f2c_abs(r__1)) * xk;
/* L90: */
}
work[k] += xk;
kc = kc + *n - k + 1;
/* L100: */
}
}
}
}
else
{
/* Compute f2c_abs(A**T)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
kc = 1;
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
i__3 = k;
for (i__ = 1;
i__ <= i__3;
++i__)
{
s += (r__1 = ap[kc + i__ - 1], f2c_abs(r__1)) * (r__2 = x[i__ + j * x_dim1], f2c_abs(r__2));
/* L110: */
}
work[k] += s;
kc += k;
/* L120: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = (r__1 = x[k + j * x_dim1], f2c_abs(r__1));
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
s += (r__1 = ap[kc + i__ - 1], f2c_abs(r__1)) * (r__2 = x[i__ + j * x_dim1], f2c_abs(r__2));
/* L130: */
}
work[k] += s;
kc += k;
/* L140: */
}
}
}
else
{
kc = 1;
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
i__3 = *n;
for (i__ = k;
i__ <= i__3;
++i__)
{
s += (r__1 = ap[kc + i__ - k], f2c_abs(r__1)) * (r__2 = x[i__ + j * x_dim1], f2c_abs(r__2));
/* L150: */
}
work[k] += s;
kc = kc + *n - k + 1;
/* L160: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = (r__1 = x[k + j * x_dim1], f2c_abs(r__1));
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
s += (r__1 = ap[kc + i__ - k], f2c_abs(r__1)) * (r__2 = x[i__ + j * x_dim1], f2c_abs(r__2));
/* L170: */
}
work[k] += s;
kc = kc + *n - k + 1;
/* L180: */
}
}
}
}
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);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( f2c_abs(inv(op(A)))* */
/* ( f2c_abs(R) + NZ*EPS*( f2c_abs(op(A))*f2c_abs(X)+f2c_abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* 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(op(A))*f2c_abs(X)+f2c_abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* f2c_abs(op(A))*f2c_abs(X) + f2c_abs(B) is less than SAFE2. */
/* Use SLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = f2c_abs(R) + NZ*EPS*( f2c_abs(op(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;
}
/* L200: */
}
kase = 0;
L210:
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(op(A)**T). */
stpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1);
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[*n + i__] = work[i__] * work[*n + i__];
/* L220: */
}
}
else
{
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[*n + i__] = work[i__] * work[*n + i__];
/* L230: */
}
stpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1);
}
goto L210;
}
/* 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);
/* L240: */
}
if (lstres != 0.f)
{
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of STPRFS */
}
/* Subroutine */ int sspgv_(integer *itype, char *jobz, char *uplo, integer *
n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work,
integer *info)
{
/* -- LAPACK driver 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
=======
SSPGV computes all the eigenvalues and, optionally, the eigenvectors
of a real generalized symmetric-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
Here A and B are assumed to be symmetric, stored in packed format,
and B is also positive definite.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, the contents of AP are destroyed.
BP (input/output) REAL array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
B, packed columnwise in a linear array. The j-th column of B
is stored in the array BP as follows:
if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
On exit, the triangular factor U or L from the Cholesky
factorization B = U**T*U or B = L*L**T, in the same storage
format as B.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) REAL array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
eigenvectors. The eigenvectors are normalized as follows:
if ITYPE = 1 or 2, Z**T*B*Z = I;
if ITYPE = 3, Z**T*inv(B)*Z = I.
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) REAL array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: SPPTRF or SSPEV returned an error code:
<= N: if INFO = i, SSPEV failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero.
> N: if INFO = n + i, for 1 <= i <= n, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Local variables */
static integer neig, j;
extern logical lsame_(char *, char *);
static char trans[1];
static logical upper;
extern /* Subroutine */ int sspev_(char *, char *, integer *, real *,
real *, real *, integer *, real *, integer *);
static logical wantz;
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *), stpsv_(char *,
char *, char *, integer *, real *, real *, integer *), xerbla_(char *, integer *), spptrf_(char
*, integer *, real *, integer *), sspgst_(integer *, char
*, integer *, real *, real *, integer *);
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
*info = 0;
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSPGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
spptrf_(uplo, n, &bp[1], info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
sspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), &
c__1);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), &
c__1);
/* L20: */
}
}
}
return 0;
/* End of SSPGV */
} /* sspgv_ */
/* Subroutine */ int spptri_(char *uplo, integer *n, real *ap, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer j, jc, jj;
real ajj;
integer jjn;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
integer *, real *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *), xerbla_(char *
, integer *), stptri_(char *, char *, integer *, real *,
integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPPTRI computes the inverse of a real symmetric positive definite */
/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
/* computed by SPPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangular factor is stored in AP; */
/* = 'L': Lower triangular factor is stored in AP. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
/* On entry, the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T, packed columnwise as */
/* a linear array. The j-th column of U or L is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* On exit, the upper or lower triangle of the (symmetric) */
/* inverse of A, overwriting the input factor U or L. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
/* zero, and the inverse could not be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--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_("SPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
stptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0) {
return 0;
}
if (upper) {
/* Compute the product inv(U) * inv(U)'. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
if (j > 1) {
i__2 = j - 1;
sspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
ajj = ap[jj];
sscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
} else {
/* Compute the product inv(L)' * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
ap[jj] = sdot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
if (j < *n) {
i__2 = *n - j;
stpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[
jj + 1], &c__1);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of SPPTRI */
} /* spptri_ */
/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx,
real *ferr, real *berr, real *work, integer *iwork, integer *info,
ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
{
/* 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 i__, j, k;
static real s;
static integer kc;
static real xk;
static integer nz;
static real eps;
static integer kase;
static real safe1, safe2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *), stpmv_(char *, char *, char *, integer *, real *,
real *, integer *, ftnlen, ftnlen, ftnlen), stpsv_(char *, char *,
char *, integer *, real *, real *, integer *, ftnlen, ftnlen,
ftnlen);
extern doublereal slamch_(char *, ftnlen);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_(
integer *, real *, real *, integer *, real *, integer *);
static logical notran;
static char transt[1];
static logical nounit;
static real lstres;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STPRFS provides error bounds and backward error estimates for the */
/* solution to a system of linear equations with a triangular packed */
/* coefficient matrix. */
/* The solution matrix X must be computed by STPTRS or some other */
/* means before entering this routine. STPRFS does not do iterative */
/* refinement because doing so cannot improve the backward error. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* 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 triangular 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. */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* 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) REAL array, dimension (LDX,NRHS) */
/* The 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
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", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && !
lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STPRFS", &i__1, (ftnlen)6);
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;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon", (ftnlen)7);
safmin = slamch_("Safe minimum", (ftnlen)12);
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A or A', depending on TRANS. */
scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
stpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[kc + i__ - 1], dabs(r__1))
* xk;
/* L30: */
}
kc += k;
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[kc + i__ - 1], dabs(r__1))
* xk;
/* L50: */
}
work[k] += xk;
kc += k;
/* L60: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[kc + i__ - k], dabs(r__1))
* xk;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[kc + i__ - k], dabs(r__1))
* xk;
/* L90: */
}
work[k] += xk;
kc = kc + *n - k + 1;
/* L100: */
}
}
}
} else {
/* Compute abs(A')*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
/* L110: */
}
work[k] += s;
kc += k;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
/* L130: */
}
work[k] += s;
kc += k;
/* L140: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
s += (r__1 = ap[kc + i__ - k], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
/* L150: */
}
work[k] += s;
kc = kc + *n - k + 1;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
s += (r__1 = ap[kc + i__ - k], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
/* L170: */
}
work[k] += s;
kc = kc + *n - k + 1;
/* L180: */
}
}
}
}
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);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(op(A)))* */
/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
/* Use SLACON to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (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;
}
/* L200: */
}
kase = 0;
L210:
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(op(A)'). */
stpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1, (
ftnlen)1, (ftnlen)1, (ftnlen)1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L230: */
}
stpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1, (
ftnlen)1, (ftnlen)1, (ftnlen)1);
}
goto L210;
}
/* 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);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of STPRFS */
} /* stprfs_ */
