/* 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_ */
int sppsv_(char *uplo, int *n, int *nrhs, float *ap,
float *b, int *ldb, int *info)
{
/* System generated locals */
int b_dim1, b_offset, i__1;
/* Local variables */
extern int lsame_(char *, char *);
extern int xerbla_(char *, int *), spptrf_(
char *, int *, float *, int *), spptrs_(char *,
int *, int *, float *, float *, int *, int *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPPSV computes the solution to a float system of linear equations */
/* A * X = B, */
/* where A is an N-by-N symmetric positive definite matrix stored in */
/* packed format and X and B are N-by-NRHS matrices. */
/* The Cholesky decomposition is used to factor A as */
/* A = U**T* U, if UPLO = 'U', or */
/* A = L * L**T, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is a lower triangular */
/* matrix. The factored form of A is then used to solve the system of */
/* equations A * X = B. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., 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 matrix B. NRHS >= 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. */
/* See below for further details. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T, in the same storage */
/* format as A. */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i of A is not */
/* positive definite, so the factorization could not be */
/* completed, and the solution has not been computed. */
/* Further Details */
/* =============== */
/* The packed storage scheme is illustrated by the following example */
/* when N = 4, UPLO = 'U': */
/* Two-dimensional storage of the symmetric matrix A: */
/* a11 a12 a13 a14 */
/* a22 a23 a24 */
/* a33 a34 (aij = conjg(aji)) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < MAX(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPPSV ", &i__1);
return 0;
}
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
spptrf_(uplo, n, &ap[1], info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
spptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info);
}
return 0;
/* End of SPPSV */
} /* sppsv_ */
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 serrpo_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static real anrm, a[16] /* was [4][4] */, b[4];
static integer i__, j;
static real w[12], x[4], rcond;
static char c2[2];
static real r1[4], r2[4];
extern /* Subroutine */ int spbtf2_(char *, integer *, integer *, real *,
integer *, integer *);
static real af[16] /* was [4][4] */;
extern /* Subroutine */ int spotf2_(char *, integer *, real *, integer *,
integer *);
static integer iw[4];
extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), spbcon_(char *, integer *, integer *, real
*, integer *, real *, real *, real *, integer *, integer *), spbequ_(char *, integer *, integer *, real *, integer *,
real *, real *, real *, integer *), spbrfs_(char *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *), spbtrf_(char *, integer *,
integer *, real *, integer *, integer *), spocon_(char *,
integer *, real *, integer *, real *, real *, real *, integer *,
integer *), sppcon_(char *, integer *, real *, real *,
real *, real *, integer *, integer *), spoequ_(integer *,
real *, integer *, real *, real *, real *, integer *), spbtrs_(
char *, integer *, integer *, integer *, real *, integer *, real *
, integer *, integer *), sporfs_(char *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *, real *, real *, real *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotri_(char *, integer *, real *, integer *, integer *), sppequ_(char *, integer *, real *, real *, real *, real
*, integer *), spprfs_(char *, integer *, integer *, real
*, real *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *), spptrf_(char *, integer *,
real *, integer *), spptri_(char *, integer *, real *,
integer *), spotrs_(char *, integer *, integer *, real *,
integer *, real *, integer *, integer *), spptrs_(char *,
integer *, integer *, real *, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
#define a_ref(a_1,a_2) a[(a_2)*4 + a_1 - 5]
#define af_ref(a_1,a_2) af[(a_2)*4 + a_1 - 5]
/* -- 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
=======
SERRPO tests the error exits for the REAL routines
for symmetric positive definite matrices.
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, j) = 1.f / (real) (i__ + j);
af_ref(i__, j) = 1.f / (real) (i__ + j);
/* L10: */
}
b[j - 1] = 0.f;
r1[j - 1] = 0.f;
r2[j - 1] = 0.f;
w[j - 1] = 0.f;
x[j - 1] = 0.f;
iw[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "PO")) {
/* Test error exits of the routines that use the Cholesky
decomposition of a symmetric positive definite matrix.
SPOTRF */
s_copy(srnamc_1.srnamt, "SPOTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spotrf_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotrf_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotrf_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTF2 */
s_copy(srnamc_1.srnamt, "SPOTF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spotf2_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotf2_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotf2_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTRI */
s_copy(srnamc_1.srnamt, "SPOTRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spotri_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotri_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotri_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTRS */
s_copy(srnamc_1.srnamt, "SPOTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
spotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPORFS */
s_copy(srnamc_1.srnamt, "SPORFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOCON */
s_copy(srnamc_1.srnamt, "SPOCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOEQU */
s_copy(srnamc_1.srnamt, "SPOEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PP")) {
/* Test error exits of the routines that use the Cholesky
decomposition of a symmetric positive definite packed matrix.
SPPTRF */
s_copy(srnamc_1.srnamt, "SPPTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spptrf_("/", &c__0, a, &info);
chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptrf_("U", &c_n1, a, &info);
chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPTRI */
s_copy(srnamc_1.srnamt, "SPPTRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spptri_("/", &c__0, a, &info);
chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptri_("U", &c_n1, a, &info);
chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPTRS */
s_copy(srnamc_1.srnamt, "SPPTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPRFS */
s_copy(srnamc_1.srnamt, "SPPRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
spprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
spprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPCON */
s_copy(srnamc_1.srnamt, "SPPCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPEQU */
s_copy(srnamc_1.srnamt, "SPPEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PB")) {
/* Test error exits of the routines that use the Cholesky
decomposition of a symmetric positive definite band matrix.
SPBTRF */
s_copy(srnamc_1.srnamt, "SPBTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spbtrf_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbtrf_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBTF2 */
s_copy(srnamc_1.srnamt, "SPBTF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spbtf2_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbtf2_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBTRS */
s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
spbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBRFS */
s_copy(srnamc_1.srnamt, "SPBRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
spbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBCON */
s_copy(srnamc_1.srnamt, "SPBCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBEQU */
s_copy(srnamc_1.srnamt, "SPBEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
spbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRPO */
} /* serrpo_ */
/* 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 serrpo_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real a[16] /* was [4][4] */, b[4];
integer i__, j;
real w[12], x[4];
char c2[2];
real r1[4], r2[4], af[16] /* was [4][4] */;
integer iw[4], info;
real anrm, rcond;
extern /* Subroutine */ int spbtf2_(char *, integer *, integer *, real *,
integer *, integer *), spotf2_(char *, integer *, real *,
integer *, integer *), alaesm_(char *, logical *, integer
*);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), spbcon_(char *, integer *, integer *, real
*, integer *, real *, real *, real *, integer *, integer *), spbequ_(char *, integer *, integer *, real *, integer *,
real *, real *, real *, integer *), spbrfs_(char *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *), spbtrf_(char *, integer *,
integer *, real *, integer *, integer *), spocon_(char *,
integer *, real *, integer *, real *, real *, real *, integer *,
integer *), sppcon_(char *, integer *, real *, real *,
real *, real *, integer *, integer *), spoequ_(integer *,
real *, integer *, real *, real *, real *, integer *), spbtrs_(
char *, integer *, integer *, integer *, real *, integer *, real *
, integer *, integer *), sporfs_(char *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *, real *, real *, real *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotri_(char *, integer *, real *, integer *, integer *), sppequ_(char *, integer *, real *, real *, real *, real
*, integer *), spprfs_(char *, integer *, integer *, real
*, real *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *), spptrf_(char *, integer *,
real *, integer *), spptri_(char *, integer *, real *,
integer *), spotrs_(char *, integer *, integer *, real *,
integer *, real *, integer *, integer *), spptrs_(char *,
integer *, integer *, real *, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRPO tests the error exits for the REAL routines */
/* for symmetric positive definite matrices. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
af[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
/* L10: */
}
b[j - 1] = 0.f;
r1[j - 1] = 0.f;
r2[j - 1] = 0.f;
w[j - 1] = 0.f;
x[j - 1] = 0.f;
iw[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "PO")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite matrix. */
/* SPOTRF */
s_copy(srnamc_1.srnamt, "SPOTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spotrf_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotrf_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotrf_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTF2 */
s_copy(srnamc_1.srnamt, "SPOTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spotf2_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotf2_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotf2_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTRI */
s_copy(srnamc_1.srnamt, "SPOTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spotri_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotri_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotri_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTRS */
s_copy(srnamc_1.srnamt, "SPOTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
spotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPORFS */
s_copy(srnamc_1.srnamt, "SPORFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOCON */
s_copy(srnamc_1.srnamt, "SPOCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOEQU */
s_copy(srnamc_1.srnamt, "SPOEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PP")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite packed matrix. */
/* SPPTRF */
s_copy(srnamc_1.srnamt, "SPPTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spptrf_("/", &c__0, a, &info);
chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptrf_("U", &c_n1, a, &info);
chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPTRI */
s_copy(srnamc_1.srnamt, "SPPTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spptri_("/", &c__0, a, &info);
chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptri_("U", &c_n1, a, &info);
chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPTRS */
s_copy(srnamc_1.srnamt, "SPPTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPRFS */
s_copy(srnamc_1.srnamt, "SPPRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
spprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
spprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPCON */
s_copy(srnamc_1.srnamt, "SPPCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPEQU */
s_copy(srnamc_1.srnamt, "SPPEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PB")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite band matrix. */
/* SPBTRF */
s_copy(srnamc_1.srnamt, "SPBTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbtrf_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbtrf_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBTF2 */
s_copy(srnamc_1.srnamt, "SPBTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbtf2_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbtf2_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBTRS */
s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
spbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBRFS */
s_copy(srnamc_1.srnamt, "SPBRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
spbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBCON */
s_copy(srnamc_1.srnamt, "SPBCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBEQU */
s_copy(srnamc_1.srnamt, "SPBEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRPO */
} /* serrpo_ */
/* Subroutine */ int schkpp_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
nmax, real *a, real *afac, real *ainv, real *b, real *x, real *xact,
real *work, real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char packs[1*2] = "C" "R";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3;
/* Local variables */
integer i__, k, n, in, kl, ku, lda, npp, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
real rcondc;
char packit[1];
real cndnum;
real result[8];
/* Fortran I/O blocks */
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKPP tests SPPTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) REAL array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AFAC (workspace) REAL array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINV (workspace) REAL array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrpo_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L100;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
*(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
;
/* Set up parameters with SLATB4 and generate a test matrix */
/* with SLATMS. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
1], &info);
/* Check error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.f;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.f;
ioff += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.f;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.f;
/* L50: */
}
}
} else {
izero = 0;
}
/* Compute the L*L' or U'*U factorization of the matrix. */
npp = n * (n + 1) / 2;
scopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
s_copy(srnamc_1.srnamt, "SPPTRF", (ftnlen)32, (ftnlen)6);
spptrf_(uplo, &n, &afac[1], &info);
/* Check error code from SPPTRF. */
if (info != izero) {
alaerh_(path, "SPPTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
scopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
sppt01_(uplo, &n, &a[1], &ainv[1], &rwork[1], result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
scopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
s_copy(srnamc_1.srnamt, "SPPTRI", (ftnlen)32, (ftnlen)6);
spptri_(uplo, &n, &ainv[1], &info);
/* Check error code from SPPTRI. */
if (info != 0) {
alaerh_(path, "SPPTRI", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
sppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[1],
&rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)6);
slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "SPPTRS", (ftnlen)32, (ftnlen)6);
spptrs_(uplo, &n, &nrhs, &afac[1], &x[1], &lda, &info);
/* Check error code from SPPTRS. */
if (info != 0) {
alaerh_(path, "SPPTRS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
sppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "SPPRFS", (ftnlen)32, (ftnlen)6);
spprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &b[1], &lda, &x[
1], &lda, &rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[1], &info);
/* Check error code from SPPRFS. */
if (info != 0) {
alaerh_(path, "SPPRFS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[4]);
sppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
&xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = slansp_("1", uplo, &n, &a[1], &rwork[1]);
s_copy(srnamc_1.srnamt, "SPPCON", (ftnlen)32, (ftnlen)6);
sppcon_(uplo, &n, &afac[1], &anorm, &rcond, &work[1], &iwork[
1], &info);
/* Check error code from SPPCON. */
if (info != 0) {
alaerh_(path, "SPPCON", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[7] = sget06_(&rcond, &rcondc);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SCHKPP */
} /* schkpp_ */
/* 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 sppsv_(char *uplo, integer *n, integer *nrhs, real *ap, real *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */
int xerbla_(char *, integer *), spptrf_( char *, integer *, real *, integer *), spptrs_(char *, integer *, integer *, real *, real *, integer *, integer *);
/* -- LAPACK driver 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 .. */
/* .. */
/* ===================================================================== */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*ldb < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SPPSV ", &i__1);
return 0;
}
/* Compute the Cholesky factorization A = U**T*U or A = L*L**T. */
spptrf_(uplo, n, &ap[1], info);
if (*info == 0)
{
/* Solve the system A*X = B, overwriting B with X. */
spptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info);
}
return 0;
/* End of SPPSV */
}
/* Subroutine */ int sppsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, real *ap, real *afp, char *equed, real *s, real *b, integer *
ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real
*work, integer *iwork, 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
=======
SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
compute the solution to a real system of linear equations
A * X = B,
where A is an N-by-N symmetric positive definite matrix stored in
packed format and X and B are N-by-NRHS matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'E', real scaling factors are computed to equilibrate
the system:
diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
Whether or not the system will be equilibrated depends on the
scaling of the matrix A, but if equilibration is used, A is
overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
factor the matrix A (after equilibration if FACT = 'E') as
A = U**T* U, if UPLO = 'U', or
A = L * L**T, if UPLO = 'L',
where U is an upper triangular matrix and L is a lower triangular
matrix.
3. If the leading i-by-i principal minor is not positive definite,
then the routine returns with INFO = i. Otherwise, the factored
form of A is used to estimate the condition number of the matrix
A. If the reciprocal of the condition number is less than machine
precision, INFO = N+1 is returned as a warning, but the routine
still goes on to solve for X and compute error bounds as
described below.
4. The system of equations is solved for X using the factored form
of A.
5. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
6. If equilibration was used, the matrix X is premultiplied by
diag(S) so that it solves the original system before
equilibration.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of the matrix A is
supplied on entry, and if not, whether the matrix A should be
equilibrated before it is factored.
= 'F': On entry, AFP contains the factored form of A.
If EQUED = 'Y', the matrix A has been equilibrated
with scaling factors given by S. AP and AFP will not
be modified.
= 'N': The matrix A will be copied to AFP and factored.
= 'E': The matrix A will be equilibrated if necessary, then
copied to AFP and factored.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The number of linear equations, i.e., 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/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, except if FACT = 'F'
and EQUED = 'Y', then A must contain the equilibrated matrix
diag(S)*A*diag(S). 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.
See below for further details. A is not modified if
FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
diag(S)*A*diag(S).
AFP (input or output) REAL array, dimension
(N*(N+1)/2)
If FACT = 'F', then AFP is an input argument and on entry
contains the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L', in the same storage
format as A. If EQUED .ne. 'N', then AFP is the factored
form of the equilibrated matrix A.
If FACT = 'N', then AFP is an output argument and on exit
returns the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L' of the original matrix A.
If FACT = 'E', then AFP is an output argument and on exit
returns the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L' of the equilibrated
matrix A (see the description of AP for the form of the
equilibrated matrix).
EQUED (input or output) CHARACTER*1
Specifies the form of equilibration that was done.
= 'N': No equilibration (always true if FACT = 'N').
= 'Y': Equilibration was done, i.e., A has been replaced by
diag(S) * A * diag(S).
EQUED is an input argument if FACT = 'F'; otherwise, it is an
output argument.
S (input or output) REAL array, dimension (N)
The scale factors for A; not accessed if EQUED = 'N'. S is
an input argument if FACT = 'F'; otherwise, S is an output
argument. If FACT = 'F' and EQUED = 'Y', each element of S
must be positive.
B (input/output) REAL array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
B is overwritten by diag(S) * B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) REAL array, dimension (LDX,NRHS)
If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
the original system of equations. Note that if EQUED = 'Y',
A and B are modified on exit, and the solution to the
equilibrated system is inv(diag(S))*X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) REAL
The estimate of the reciprocal condition number of the matrix
A after equilibration (if done). If RCOND is less than the
machine precision (in particular, if RCOND = 0), the matrix
is singular to working precision. This condition is
indicated by a return code of INFO > 0.
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
> 0: if INFO = i, and i is
<= N: the leading minor of order i of A is
not positive definite, so the factorization
could not be completed, and the solution has not
been computed. RCOND = 0 is returned.
= N+1: U is nonsingular, but RCOND is less than machine
precision, meaning that the matrix is singular
to working precision. Nevertheless, the
solution and error bounds are computed because
there are a number of situations where the
computed solution can be more accurate than the
value of RCOND would suggest.
Further Details
===============
The packed storage scheme is illustrated by the following example
when N = 4, UPLO = 'U':
Two-dimensional storage of the symmetric matrix A:
a11 a12 a13 a14
a22 a23 a24
a33 a34 (aij = conjg(aji))
a44
Packed storage of the upper triangle of A:
AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
static real amax, smin, smax;
static integer i__, j;
extern logical lsame_(char *, char *);
static real scond, anorm;
static logical equil, rcequ;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static integer infequ;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
extern doublereal slansp_(char *, char *, integer *, real *, real *);
extern /* Subroutine */ int sppcon_(char *, integer *, real *, real *,
real *, real *, integer *, integer *), slaqsp_(char *,
integer *, real *, real *, real *, real *, char *)
;
static real smlnum;
extern /* Subroutine */ int sppequ_(char *, integer *, real *, real *,
real *, real *, integer *), spprfs_(char *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, integer *, integer *), spptrf_(
char *, integer *, real *, integer *), spptrs_(char *,
integer *, integer *, real *, real *, integer *, integer *);
#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;
--s;
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;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -7;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
/* L10: */
}
if (smin <= 0.f) {
*info = -8;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPPSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
sppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
slaqsp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b_ref(i__, j) = s[i__] * b_ref(i__, j);
/* L20: */
}
/* L30: */
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
i__1 = *n * (*n + 1) / 2;
scopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
spptrf_(uplo, n, &afp[1], info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = slansp_("I", uplo, n, &ap[1], &work[1]);
/* Compute the reciprocal of the condition number of A. */
sppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
/* Compute the solution matrix X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
spptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and
compute error bounds and backward error estimates for it. */
spprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info);
/* Transform the solution matrix X to a solution of the original
system. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
x_ref(i__, j) = s[i__] * x_ref(i__, j);
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
/* L60: */
}
}
return 0;
/* End of SPPSVX */
} /* sppsvx_ */