int
f2c_ssyr(char* uplo, integer* N,
real* alpha,
real* X, integer* incX,
real* A, integer* lda)
{
ssyr_(uplo, N, alpha, X, incX, A, lda);
return 0;
}
/* Subroutine */ int spbstf_(char *uplo, integer *n, integer *kd, real *ab,
integer *ldab, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer j, m, km;
real ajj;
integer kld;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SPBSTF computes a split Cholesky factorization of a real */
/* symmetric positive definite band matrix A. */
/* This routine is designed to be used in conjunction with SSBGST. */
/* The factorization has the form A = S**T*S where S is a band matrix */
/* of the same bandwidth as A and the following structure: */
/* S = ( U ) */
/* ( M L ) */
/* where U is upper triangular of order m = (n+kd)/2, and L is lower */
/* triangular of order n-m. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) REAL array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first kd+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, if INFO = 0, the factor S from the split Cholesky */
/* factorization A = S**T*S. See Further Details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the factorization could not be completed, */
/* because the updated element a(i,i) was negative; the */
/* matrix A is not positive definite. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* N = 7, KD = 2: */
/* S = ( s11 s12 s13 ) */
/* ( s22 s23 s24 ) */
/* ( s33 s34 ) */
/* ( s44 ) */
/* ( s53 s54 s55 ) */
/* ( s64 s65 s66 ) */
/* ( s75 s76 s77 ) */
/* If UPLO = 'U', the array AB holds: */
/* on entry: on exit: */
/* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 */
/* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 */
/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
/* If UPLO = 'L', the array AB holds: */
/* on entry: on exit: */
/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
/* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * */
/* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * */
/* Array elements marked * are not used by the routine. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPBSTF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = max(i__1,i__2);
/* Set the splitting point m. */
m = (*n + *kd) / 2;
if (upper) {
/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */
i__1 = m + 1;
for (j = *n; j >= i__1; --j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
ajj = ab[*kd + 1 + j * ab_dim1];
if (ajj <= 0.f) {
goto L50;
}
ajj = sqrt(ajj);
ab[*kd + 1 + j * ab_dim1] = ajj;
/* Computing MIN */
i__2 = j - 1;
km = min(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th column and update the */
/* the leading submatrix within the band. */
r__1 = 1.f / ajj;
sscal_(&km, &r__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
ssyr_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1,
&ab[*kd + 1 + (j - km) * ab_dim1], &kld);
}
/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */
i__1 = m;
for (j = 1; j <= i__1; ++j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
ajj = ab[*kd + 1 + j * ab_dim1];
if (ajj <= 0.f) {
goto L50;
}
ajj = sqrt(ajj);
ab[*kd + 1 + j * ab_dim1] = ajj;
/* Computing MIN */
i__2 = *kd, i__3 = m - j;
km = min(i__2,i__3);
/* Compute elements j+1:j+km of the j-th row and update the */
/* trailing submatrix within the band. */
if (km > 0) {
r__1 = 1.f / ajj;
sscal_(&km, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
ssyr_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld,
&ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
}
}
} else {
/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */
i__1 = m + 1;
for (j = *n; j >= i__1; --j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
ajj = ab[j * ab_dim1 + 1];
if (ajj <= 0.f) {
goto L50;
}
ajj = sqrt(ajj);
ab[j * ab_dim1 + 1] = ajj;
/* Computing MIN */
i__2 = j - 1;
km = min(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th row and update the */
/* trailing submatrix within the band. */
r__1 = 1.f / ajj;
sscal_(&km, &r__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
ssyr_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld,
&ab[(j - km) * ab_dim1 + 1], &kld);
}
/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */
i__1 = m;
for (j = 1; j <= i__1; ++j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
ajj = ab[j * ab_dim1 + 1];
if (ajj <= 0.f) {
goto L50;
}
ajj = sqrt(ajj);
ab[j * ab_dim1 + 1] = ajj;
/* Computing MIN */
i__2 = *kd, i__3 = m - j;
km = min(i__2,i__3);
/* Compute elements j+1:j+km of the j-th column and update the */
/* trailing submatrix within the band. */
if (km > 0) {
r__1 = 1.f / ajj;
sscal_(&km, &r__1, &ab[j * ab_dim1 + 2], &c__1);
ssyr_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[(
j + 1) * ab_dim1 + 1], &kld);
}
}
}
return 0;
L50:
*info = j;
return 0;
/* End of SPBSTF */
} /* spbstf_ */
/* Subroutine */ int sstt21_(integer *n, integer *kband, real *ad, real *ae,
real *sd, real *se, real *u, integer *ldu, real *work, real *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
static real unfl;
extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
integer *, real *, integer *);
static real temp1, temp2;
static integer j;
extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *), sgemm_(
char *, char *, integer *, integer *, integer *, real *, real *,
integer *, real *, integer *, real *, real *, integer *);
static real anorm, wnorm;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
static real ulp;
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTT21 checks a decomposition of the form
A = U S U'
where ' means transpose, A is symmetric tridiagonal, U is orthogonal,
and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
Two tests are performed:
RESULT(1) = | A - U S U' | / ( |A| n ulp )
RESULT(2) = | I - UU' | / ( n ulp )
Arguments
=========
N (input) INTEGER
The size of the matrix. If it is zero, SSTT21 does nothing.
It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix S. It may only be zero or one.
If zero, then S is diagonal, and SE is not referenced. If
one, then S is symmetric tri-diagonal.
AD (input) REAL array, dimension (N)
The diagonal of the original (unfactored) matrix A. A is
assumed to be symmetric tridiagonal.
AE (input) REAL array, dimension (N-1)
The off-diagonal of the original (unfactored) matrix A. A
is assumed to be symmetric tridiagonal. AE(1) is the (1,2)
and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
SD (input) REAL array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix S.
SE (input) REAL array, dimension (N-1)
The off-diagonal of the (symmetric tri-) diagonal matrix S.
Not referenced if KBSND=0. If KBAND=1, then AE(1) is the
(1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
element, etc.
U (input) REAL array, dimension (LDU, N)
The orthogonal matrix in the decomposition.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N.
WORK (workspace) REAL array, dimension (N*(N+1))
RESULT (output) REAL array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
RESULT(1) is always modified.
=====================================================================
1) Constants
Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--work;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0) {
return 0;
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Precision");
/* Do Test 1
Copy A & Compute its 1-Norm: */
slaset_("Full", n, n, &c_b5, &c_b5, &work[1], n);
anorm = 0.f;
temp1 = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] = ad[j];
work[(*n + 1) * (j - 1) + 2] = ae[j];
temp2 = (r__1 = ae[j], dabs(r__1));
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = ad[j], dabs(r__1)) + temp1 + temp2;
anorm = dmax(r__2,r__3);
temp1 = temp2;
/* L10: */
}
/* Computing 2nd power */
i__1 = *n;
work[i__1 * i__1] = ad[*n];
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = ad[*n], dabs(r__1)) + temp1, r__2 = max(r__2,
r__3);
anorm = dmax(r__2,unfl);
/* Norm of A - USU' */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__1 = -sd[j];
ssyr_("L", n, &r__1, &u_ref(1, j), &c__1, &work[1], n);
/* L20: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
r__1 = -se[j];
ssyr2_("L", n, &r__1, &u_ref(1, j), &c__1, &u_ref(1, j + 1), &
c__1, &work[1], n);
/* L30: */
}
}
/* Computing 2nd power */
i__1 = *n;
wnorm = slansy_("1", "L", n, &work[1], n, &work[i__1 * i__1 + 1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *n * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*n);
result[1] = dmin(r__1,r__2) / (*n * ulp);
}
}
/* Do Test 2
Compute UU' - I */
sgemm_("N", "C", n, n, n, &c_b19, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b5, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.f;
/* L40: */
}
/* Computing MIN
Computing 2nd power */
i__1 = *n;
r__1 = (real) (*n), r__2 = slange_("1", n, n, &work[1], n, &work[i__1 *
i__1 + 1]);
result[2] = dmin(r__1,r__2) / (*n * ulp);
return 0;
/* End of SSTT21 */
} /* sstt21_ */
void
ssyr(char uplo, int n, float alpha, float *x, int incx, float *a, int lda)
{
ssyr_( &uplo, &n, &alpha, x, &incx, a, &lda);
}
/* Subroutine */ int spst01_(char *uplo, integer *n, real *a, integer *lda,
real *afac, integer *ldafac, real *perm, integer *ldperm, integer *
piv, real *rwork, real *resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2;
/* Local variables */
integer i__, j, k;
real t, eps;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real anorm;
extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *);
extern doublereal slamch_(char *), slansy_(char *, char *,
integer *, real *, integer *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPST01 reconstructs a symmetric positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - 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 (LDA,N) */
/* The original symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) REAL array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) REAL array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = slansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] = 0.f;
/* L100: */
}
/* L110: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
t = sdot_(&k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
afac[k + k * afac_dim1] = t;
/* Compute the rest of column K. */
i__1 = k - 1;
strmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L120: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] = 0.f;
/* L130: */
}
/* L140: */
}
}
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 + 1 <= *n) {
i__1 = *n - k;
ssyr_("Lower", &i__1, &c_b18, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
t = afac[k + k * afac_dim1];
i__1 = *n - k + 1;
sscal_(&i__1, &t, &afac[k + k * afac_dim1], &c__1);
/* L150: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
perm[piv[i__] + piv[j] * perm_dim1] = afac[i__ + j *
afac_dim1];
} else {
perm[piv[i__] + piv[j] * perm_dim1] = afac[j + i__ *
afac_dim1];
}
}
/* L160: */
}
/* L170: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
perm[piv[i__] + piv[j] * perm_dim1] = afac[i__ + j *
afac_dim1];
} else {
perm[piv[i__] + piv[j] * perm_dim1] = afac[j + i__ *
afac_dim1];
}
}
/* L180: */
}
/* L190: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
perm[i__ + j * perm_dim1] -= a[i__ + j * a_dim1];
/* L200: */
}
/* L210: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
perm[i__ + j * perm_dim1] -= a[i__ + j * a_dim1];
/* L220: */
}
/* L230: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = slansy_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of SPST01 */
} /* spst01_ */
int spbtf2_(char *uplo, int *n, int *kd, float *ab,
int *ldab, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3;
float r__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int j, kn;
float ajj;
int kld;
extern int ssyr_(char *, int *, float *, float *,
int *, float *, int *);
extern int lsame_(char *, char *);
extern int sscal_(int *, float *, float *, int *);
int upper;
extern int xerbla_(char *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPBTF2 computes the Cholesky factorization of a float symmetric */
/* positive definite band matrix A. */
/* The factorization has the form */
/* A = U' * U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix, U' is the transpose of U, and */
/* L is lower triangular. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* 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 order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) REAL array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+kd). */
/* On exit, if INFO = 0, the triangular factor U or L from the */
/* Cholesky factorization A = U'*U or A = L*L' of the band */
/* matrix A, in the same storage format as A. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* N = 6, KD = 2, and UPLO = 'U': */
/* On entry: On exit: */
/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* Similarly, if UPLO = 'L' the format of A is as follows: */
/* On entry: On exit: */
/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
/* Array elements marked * are not used by the routine. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = MAX(i__1,i__2);
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
ajj = ab[*kd + 1 + j * ab_dim1];
if (ajj <= 0.f) {
goto L30;
}
ajj = sqrt(ajj);
ab[*kd + 1 + j * ab_dim1] = ajj;
/* Compute elements J+1:J+KN of row J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = MIN(i__2,i__3);
if (kn > 0) {
r__1 = 1.f / ajj;
sscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
ssyr_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
&ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
ajj = ab[j * ab_dim1 + 1];
if (ajj <= 0.f) {
goto L30;
}
ajj = sqrt(ajj);
ab[j * ab_dim1 + 1] = ajj;
/* Compute elements J+1:J+KN of column J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = MIN(i__2,i__3);
if (kn > 0) {
r__1 = 1.f / ajj;
sscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1);
ssyr_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
j + 1) * ab_dim1 + 1], &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of SPBTF2 */
} /* spbtf2_ */
/* Subroutine */
int spbstf_(char *uplo, integer *n, integer *kd, real *ab, integer *ldab, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j, m, km;
real ajj;
integer kld;
extern /* Subroutine */
int ssyr_(char *, integer *, real *, real *, integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */
int xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*kd < 0)
{
*info = -3;
}
else if (*ldab < *kd + 1)
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SPBSTF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Computing MAX */
i__1 = 1;
i__2 = *ldab - 1; // , expr subst
kld = max(i__1,i__2);
/* Set the splitting point m. */
m = (*n + *kd) / 2;
if (upper)
{
/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */
i__1 = m + 1;
for (j = *n;
j >= i__1;
--j)
{
/* Compute s(j,j) and test for non-positive-definiteness. */
ajj = ab[*kd + 1 + j * ab_dim1];
if (ajj <= 0.f)
{
goto L50;
}
ajj = sqrt(ajj);
ab[*kd + 1 + j * ab_dim1] = ajj;
/* Computing MIN */
i__2 = j - 1;
km = min(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th column and update the */
/* the leading submatrix within the band. */
r__1 = 1.f / ajj;
sscal_(&km, &r__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
ssyr_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1, &ab[*kd + 1 + (j - km) * ab_dim1], &kld);
/* L10: */
}
/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */
i__1 = m;
for (j = 1;
j <= i__1;
++j)
{
/* Compute s(j,j) and test for non-positive-definiteness. */
ajj = ab[*kd + 1 + j * ab_dim1];
if (ajj <= 0.f)
{
goto L50;
}
ajj = sqrt(ajj);
ab[*kd + 1 + j * ab_dim1] = ajj;
/* Computing MIN */
i__2 = *kd;
i__3 = m - j; // , expr subst
km = min(i__2,i__3);
/* Compute elements j+1:j+km of the j-th row and update the */
/* trailing submatrix within the band. */
if (km > 0)
{
r__1 = 1.f / ajj;
sscal_(&km, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
ssyr_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld, &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
}
/* L20: */
}
}
else
{
/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */
i__1 = m + 1;
for (j = *n;
j >= i__1;
--j)
{
/* Compute s(j,j) and test for non-positive-definiteness. */
ajj = ab[j * ab_dim1 + 1];
if (ajj <= 0.f)
{
goto L50;
}
ajj = sqrt(ajj);
ab[j * ab_dim1 + 1] = ajj;
/* Computing MIN */
i__2 = j - 1;
km = min(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th row and update the */
/* trailing submatrix within the band. */
r__1 = 1.f / ajj;
sscal_(&km, &r__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
ssyr_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld, &ab[(j - km) * ab_dim1 + 1], &kld);
/* L30: */
}
/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */
i__1 = m;
for (j = 1;
j <= i__1;
++j)
{
/* Compute s(j,j) and test for non-positive-definiteness. */
ajj = ab[j * ab_dim1 + 1];
if (ajj <= 0.f)
{
goto L50;
}
ajj = sqrt(ajj);
ab[j * ab_dim1 + 1] = ajj;
/* Computing MIN */
i__2 = *kd;
i__3 = m - j; // , expr subst
km = min(i__2,i__3);
/* Compute elements j+1:j+km of the j-th column and update the */
/* trailing submatrix within the band. */
if (km > 0)
{
r__1 = 1.f / ajj;
sscal_(&km, &r__1, &ab[j * ab_dim1 + 2], &c__1);
ssyr_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[( j + 1) * ab_dim1 + 1], &kld);
}
/* L40: */
}
}
return 0;
L50:
*info = j;
return 0;
/* End of SPBSTF */
}
/* Subroutine */ int spbt01_(char *uplo, integer *n, integer *kd, real *a,
integer *lda, real *afac, integer *ldafac, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, k;
real t;
integer kc, ml, mu;
real eps;
integer klen;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real anorm;
extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *);
extern doublereal slamch_(char *), slansb_(char *, char *,
integer *, integer *, real *, integer *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPBT01 reconstructs a symmetric positive definite band 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, L' is the conjugate transpose of */
/* L, and U' is the conjugate transpose of U. */
/* 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. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The original symmetric band matrix A. If UPLO = 'U', the */
/* upper triangular part of A is stored as a band matrix; if */
/* UPLO = 'L', the lower triangular part of A is stored. The */
/* columns of the appropriate triangle are stored in the columns */
/* of A and the diagonals of the triangle are stored in the rows */
/* of A. See SPBTRF for further details. */
/* LDA (input) INTEGER. */
/* The leading dimension of the array A. LDA >= max(1,KD+1). */
/* AFAC (input) REAL array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the factor */
/* L or U from the L*L' or U'*U factorization in band storage */
/* format, as computed by SPBTRF. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. */
/* LDAFAC >= max(1,KD+1). */
/* 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = slansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
for (k = *n; k >= 1; --k) {
/* Computing MAX */
i__1 = 1, i__2 = *kd + 2 - k;
kc = max(i__1,i__2);
klen = *kd + 1 - kc;
/* Compute the (K,K) element of the result. */
i__1 = klen + 1;
t = sdot_(&i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc + k *
afac_dim1], &c__1);
afac[*kd + 1 + k * afac_dim1] = t;
/* Compute the rest of column K. */
if (klen > 0) {
i__1 = *ldafac - 1;
strmv_("Upper", "Transpose", "Non-unit", &klen, &afac[*kd + 1
+ (k - klen) * afac_dim1], &i__1, &afac[kc + k *
afac_dim1], &c__1);
}
/* L10: */
}
/* UPLO = 'L': Compute the product L*L', overwriting L. */
} else {
for (k = *n; k >= 1; --k) {
/* Computing MIN */
i__1 = *kd, i__2 = *n - k;
klen = min(i__1,i__2);
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (klen > 0) {
i__1 = *ldafac - 1;
ssyr_("Lower", &klen, &c_b14, &afac[k * afac_dim1 + 2], &c__1,
&afac[(k + 1) * afac_dim1 + 1], &i__1);
}
/* Scale column K by the diagonal element. */
t = afac[k * afac_dim1 + 1];
i__1 = klen + 1;
sscal_(&i__1, &t, &afac[k * afac_dim1 + 1], &c__1);
/* L20: */
}
}
/* Compute the difference L*L' - A or U'*U - A. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = *kd + 2 - j;
mu = max(i__2,i__3);
i__2 = *kd + 1;
for (i__ = mu; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
/* L30: */
}
/* L40: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd + 1, i__3 = *n - j + 1;
ml = min(i__2,i__3);
i__2 = ml;
for (i__ = 1; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
/* L50: */
}
/* L60: */
}
}
/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
*resid = slansb_("I", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of SPBT01 */
} /* spbt01_ */
void STARPU_SSYR (const char *uplo, const int n, const float alpha,
const float *x, const int incx, float *A, const int lda)
{
ssyr_(uplo, &n, &alpha, x, &incx, A, &lda);
}
