int
f2c_dsyr2(char* uplo, integer* N,
doublereal* alpha,
doublereal* X, integer* incX,
doublereal* Y, integer* incY,
doublereal* A, integer* lda)
{
dsyr2_(uplo, N, alpha,
X, incX, Y, incY, A, lda);
return 0;
}
void dsyr2(const UPLO Uplo,
const int N,
const double alpha,
const double *X,
const int incX,
const double *Y,
const int incY,
double *A,
const int lda) {
dsyr2_(UploChar[Uplo], &N, &alpha, X, &incX, Y, &incY, A, &lda);
}
/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
form T by an orthogonal similarity transformation: Q' * A * Q = T.
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.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if UPLO = 'U', the diagonal and first superdiagonal
of A are overwritten by the corresponding elements of the
tridiagonal matrix T, and the elements above the first
superdiagonal, with the array TAU, represent the orthogonal
matrix Q as a product of elementary reflectors; if UPLO
= 'L', the diagonal and first subdiagonal of A are over-
written by the corresponding elements of the tridiagonal
matrix T, and the elements below the first subdiagonal, with
the array TAU, represent the orthogonal matrix Q as a product
of elementary reflectors. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
D (output) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the tridiagonal matrix T:
D(i) = A(i,i).
E (output) DOUBLE PRECISION array, dimension (N-1)
The off-diagonal elements of the tridiagonal matrix T:
E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
TAU (output) DOUBLE PRECISION array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n-1) . . . H(2) H(1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
A(1:i-1,i+1), and tau in TAU(i).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(n-1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
and tau in TAU(i).
The contents of A on exit are illustrated by the following examples
with n = 5:
if UPLO = 'U': if UPLO = 'L':
( d e v2 v3 v4 ) ( d )
( d e v3 v4 ) ( e d )
( d e v4 ) ( v1 e d )
( d e ) ( v1 v2 e d )
( d ) ( v1 v2 v3 e d )
where d and e denote diagonal and off-diagonal elements of T, and vi
denotes an element of the vector defining H(i).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = 0.;
static doublereal c_b14 = -1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal taui;
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__;
static doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *
);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a_ref(i__, i__ + 1), &a_ref(1, i__ + 1), &c__1, &
taui);
e[i__] = a_ref(i__, i__ + 1);
if (taui != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
a_ref(i__, i__ + 1) = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a_ref(1, i__ +
1), &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a_ref(1,
i__ + 1), &c__1);
daxpy_(&i__, &alpha, &a_ref(1, i__ + 1), &c__1, &tau[1], &
c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
dsyr2_(uplo, &i__, &c_b14, &a_ref(1, i__ + 1), &c__1, &tau[1],
&c__1, &a[a_offset], lda);
a_ref(i__, i__ + 1) = e[i__];
}
d__[i__ + 1] = a_ref(i__ + 1, i__ + 1);
tau[i__] = taui;
/* L10: */
}
d__[1] = a_ref(1, 1);
} else {
/* Reduce the lower triangle of A */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(i+2:n,i)
Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*n), i__), &
c__1, &taui);
e[i__] = a_ref(i__ + 1, i__);
if (taui != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a_ref(i__ + 1, i__) = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b8, &tau[i__], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a_ref(
i__ + 1, i__), &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &tau[i__],
&c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a_ref(i__ + 1, i__), &c__1, &tau[
i__], &c__1, &a_ref(i__ + 1, i__ + 1), lda)
;
a_ref(i__ + 1, i__) = e[i__];
}
d__[i__] = a_ref(i__, i__);
tau[i__] = taui;
/* L20: */
}
d__[*n] = a_ref(*n, *n);
}
return 0;
/* End of DSYTD2 */
} /* dsytd2_ */
void
dsyr2(char uplo, int n, double alpha, double *x, int incx, double *y, int incy, double *a, int lda)
{
dsyr2_( &uplo, &n, &alpha, x, &incx, y, &incy, a, &lda);
}
/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
info)
{
/* -- LAPACK 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
=======
DSYGS2 reduces a real symmetric-definite generalized eigenproblem
to standard form.
If ITYPE = 1, the problem is A*x = lambda*B*x,
and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
B must have been previously factorized as U'*U or L*L' by DPOTRF.
Arguments
=========
ITYPE (input) INTEGER
= 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
= 2 or 3: compute U*A*U' or L'*A*L.
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored, and how B has been factorized.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n by n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the transformed matrix, stored in the
same format as A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) DOUBLE PRECISION array, dimension (LDB,N)
The triangular factor from the Cholesky factorization of B,
as returned by DPOTRF.
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.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublereal c_b6 = -1.;
static integer c__1 = 1;
static doublereal c_b27 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer k;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *,
integer *, doublereal *, integer *);
static doublereal ct;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal akk, bkk;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
akk = a_ref(k, k);
bkk = b_ref(k, k);
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
a_ref(k, k) = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &a_ref(k, k + 1), lda);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
dsyr2_(uplo, &i__2, &c_b6, &a_ref(k, k + 1), lda, &b_ref(
k, k + 1), ldb, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
daxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
dtrsv_(uplo, "Transpose", "Non-unit", &i__2, &b_ref(k + 1,
k + 1), ldb, &a_ref(k, k + 1), lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
akk = a_ref(k, k);
bkk = b_ref(k, k);
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
a_ref(k, k) = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &a_ref(k + 1, k), &c__1);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
dsyr2_(uplo, &i__2, &c_b6, &a_ref(k + 1, k), &c__1, &
b_ref(k + 1, k), &c__1, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
daxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
dtrsv_(uplo, "No transpose", "Non-unit", &i__2, &b_ref(k
+ 1, k + 1), ldb, &a_ref(k + 1, k), &c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
akk = a_ref(k, k);
bkk = b_ref(k, k);
i__2 = k - 1;
dtrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a_ref(1, k), &c__1);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
dsyr2_(uplo, &i__2, &c_b27, &a_ref(1, k), &c__1, &b_ref(1, k),
&c__1, &a[a_offset], lda);
i__2 = k - 1;
daxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
dscal_(&i__2, &bkk, &a_ref(1, k), &c__1);
/* Computing 2nd power */
d__1 = bkk;
a_ref(k, k) = akk * (d__1 * d__1);
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
akk = a_ref(k, k);
bkk = b_ref(k, k);
i__2 = k - 1;
dtrmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a_ref(k, 1), lda);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
dsyr2_(uplo, &i__2, &c_b27, &a_ref(k, 1), lda, &b_ref(k, 1),
ldb, &a[a_offset], lda);
i__2 = k - 1;
daxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
dscal_(&i__2, &bkk, &a_ref(k, 1), lda);
/* Computing 2nd power */
d__1 = bkk;
a_ref(k, k) = akk * (d__1 * d__1);
/* L40: */
}
}
}
return 0;
/* End of DSYGS2 */
} /* dsygs2_ */
/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer k;
doublereal ct, akk, bkk;
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *,
integer *, doublereal *, integer *),
xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYGS2 reduces a real symmetric-definite generalized eigenproblem */
/* to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
/* B must have been previously factorized as U'*U or L*L' by DPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
/* = 2 or 3: compute U*A*U' or L'*A*L. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored, and how B has been factorized. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by DPOTRF. */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
a[k + k * a_dim1] = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
dsyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
dtrsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + (
k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1],
lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
a[k + k * a_dim1] = akk;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1);
ct = akk * -.5;
i__2 = *n - k;
daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
dsyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
dtrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
&c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
i__2 = k - 1;
dtrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
/* Computing 2nd power */
d__1 = bkk;
a[k + k * a_dim1] = akk * (d__1 * d__1);
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
i__2 = k - 1;
dtrmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k + a_dim1], lda);
ct = akk * .5;
i__2 = k - 1;
daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k +
b_dim1], ldb, &a[a_offset], lda);
i__2 = k - 1;
daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
dscal_(&i__2, &bkk, &a[k + a_dim1], lda);
/* Computing 2nd power */
d__1 = bkk;
a[k + k * a_dim1] = akk * (d__1 * d__1);
/* L40: */
}
}
}
return 0;
/* End of DSYGS2 */
} /* dsygs2_ */
/* Subroutine */ int dstt21_(integer *n, integer *kband, doublereal *ad,
doublereal *ae, doublereal *sd, doublereal *se, doublereal *u,
integer *ldu, doublereal *work, doublereal *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1;
doublereal d__1, d__2, d__3;
/* Local variables */
static doublereal unfl;
extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static doublereal temp1, temp2;
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer j;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal anorm, wnorm;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
static doublereal 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
=======
DSTT21 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, DSTT21 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) DOUBLE PRECISION array, dimension (N)
The diagonal of the original (unfactored) matrix A. A is
assumed to be symmetric tridiagonal.
AE (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix S.
SE (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N*(N+1))
RESULT (output) DOUBLE PRECISION array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
RESULT(1) is always modified.
=====================================================================
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.;
result[2] = 0.;
if (*n <= 0) {
return 0;
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Precision");
/* Do Test 1
Copy A & Compute its 1-Norm: */
dlaset_("Full", n, n, &c_b5, &c_b5, &work[1], n);
anorm = 0.;
temp1 = 0.;
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 = (d__1 = ae[j], abs(d__1));
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = ad[j], abs(d__1)) + temp1 + temp2;
anorm = max(d__2,d__3);
temp1 = temp2;
/* L10: */
}
/* Computing 2nd power */
i__1 = *n;
work[i__1 * i__1] = ad[*n];
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = ad[*n], abs(d__1)) + temp1, d__2 = max(d__2,
d__3);
anorm = max(d__2,unfl);
/* Norm of A - USU' */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -sd[j];
dsyr_("L", n, &d__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) {
d__1 = -se[j];
dsyr2_("L", n, &d__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 = dlansy_("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.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
result[1] = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
result[1] = min(d__1,d__2) / (*n * ulp);
}
}
/* Do Test 2
Compute UU' - I */
dgemm_("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.;
/* L40: */
}
/* Computing MIN
Computing 2nd power */
i__1 = *n;
d__1 = (doublereal) (*n), d__2 = dlange_("1", n, n, &work[1], n, &work[
i__1 * i__1 + 1]);
result[2] = min(d__1,d__2) / (*n * ulp);
return 0;
/* End of DSTT21 */
} /* dstt21_ */
/* Subroutine */ int dsytd2_(char* uplo, integer* n, doublereal* a, integer *
lda, doublereal* d__, doublereal* e, doublereal* tau, integer* info) {
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
extern doublereal ddot_(integer*, doublereal*, integer*, doublereal*,
integer*);
doublereal taui;
extern /* Subroutine */ int dsyr2_(char*, integer*, doublereal*,
doublereal*, integer*, doublereal*, integer*, doublereal*,
integer*);
doublereal alpha;
extern logical lsame_(char*, char*);
extern /* Subroutine */ int daxpy_(integer*, doublereal*, doublereal*,
integer*, doublereal*, integer*);
logical upper;
extern /* Subroutine */ int dsymv_(char*, integer*, doublereal*,
doublereal*, integer*, doublereal*, integer*, doublereal*,
doublereal*, integer*), dlarfg_(integer*, doublereal*,
doublereal*, integer*, doublereal*), xerbla_(char*, integer *
);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */
/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */
/* 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. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
/* of A are overwritten by the corresponding elements of the */
/* tridiagonal matrix T, and the elements above the first */
/* superdiagonal, with the array TAU, represent the orthogonal */
/* matrix Q as a product of elementary reflectors; if UPLO */
/* = 'L', the diagonal and first subdiagonal of A are over- */
/* written by the corresponding elements of the tridiagonal */
/* matrix T, and the elements below the first subdiagonal, with */
/* the array TAU, represent the orthogonal matrix Q as a product */
/* of elementary reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* D (output) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n-1) . . . H(2) H(1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
/* A(1:i-1,i+1), and tau in TAU(i). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(n-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
/* and tau in TAU(i). */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( d e v2 v3 v4 ) ( d ) */
/* ( d e v3 v4 ) ( e d ) */
/* ( d e v4 ) ( v1 e d ) */
/* ( d e ) ( v1 v2 e d ) */
/* ( d ) ( v1 v2 v3 e d ) */
/* where d and e denote diagonal and off-diagonal elements of T, and vi */
/* denotes an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1
+ 1], &c__1, &taui);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
if (taui != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) *
a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1)
* a_dim1 + 1], &c__1);
daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1,
&tau[1], &c__1, &a[a_offset], lda);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
}
d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
tau[i__] = taui;
/* L10: */
}
d__[1] = a[a_dim1 + 1];
} else {
/* Reduce the lower triangle of A */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(i+2:n,i) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &taui);
e[i__] = a[i__ + 1 + i__ * a_dim1];
if (taui != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[
i__], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ +
1 + i__ * a_dim1], &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1,
&tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda);
a[i__ + 1 + i__ * a_dim1] = e[i__];
}
d__[i__] = a[i__ + i__ * a_dim1];
tau[i__] = taui;
/* L20: */
}
d__[*n] = a[*n + *n * a_dim1];
}
return 0;
/* End of DSYTD2 */
} /* dsytd2_ */
/* Subroutine */
int dsytd2_fla(char *uplo, integer *n, doublereal *a, integer * lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal taui;
extern /* Subroutine */
int dsyr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *);
doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
logical upper;
extern /* Subroutine */
int dsymv_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer * );
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0)
{
return 0;
}
if (upper)
{
/* Reduce the upper triangle of A */
for (i__ = *n - 1;
i__ >= 1;
--i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**T */
/* to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
if (taui != 0.)
{
/* Apply H(i) from both sides to A(1:i,1:i) */
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x**T * v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1], &c__1);
daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ 1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**T - w * v**T */
dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[1], &c__1, &a[a_offset], lda);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
}
d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
tau[i__] = taui;
/* L10: */
}
d__[1] = a[a_dim1 + 1];
}
else
{
/* Reduce the lower triangle of A */
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**T */
/* to annihilate A(i+2:n,i) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + i__ * a_dim1], &c__1, &taui);
e[i__] = a[i__ + 1 + i__ * a_dim1];
if (taui != 0.)
{
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ i__], &c__1);
/* Compute w := x - 1/2 * tau * (x**T * v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**T - w * v**T */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda);
a[i__ + 1 + i__ * a_dim1] = e[i__];
}
d__[i__] = a[i__ + i__ * a_dim1];
tau[i__] = taui;
/* L20: */
}
d__[*n] = a[*n + *n * a_dim1];
}
return 0;
/* End of DSYTD2 */
}
/* Subroutine */ int dsyt21_(integer *itype, char *uplo, integer *n, integer *
kband, doublereal *a, integer *lda, doublereal *d__, doublereal *e,
doublereal *u, integer *ldu, doublereal *v, integer *ldv, doublereal *
tau, doublereal *work, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2;
/* Local variables */
integer j, jr;
doublereal ulp;
integer jcol;
doublereal unfl;
integer jrow;
extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *), dsyr2_(
char *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *), dgemm_(
char *, char *, integer *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern logical lsame_(char *, char *);
integer iinfo;
doublereal anorm;
char cuplo[1];
doublereal vsave;
logical lower;
doublereal wnorm;
extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dorm2r_(char
*, char *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dlarfy_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYT21 generally checks a decomposition of the form */
/* A = U S U' */
/* where ' means transpose, A is symmetric, U is orthogonal, and S is */
/* diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1). */
/* If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
/* expressed as a product of Householder transformations, whose vectors */
/* are stored in the array "V" and whose scaling constants are in "TAU". */
/* We shall use the letter "V" to refer to the product of Householder */
/* transformations (which should be equal to U). */
/* Specifically, if ITYPE=1, then: */
/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU' | / ( n ulp ) */
/* If ITYPE=2, then: */
/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
/* If ITYPE=3, then: */
/* RESULT(1) = | I - VU' | / ( n ulp ) */
/* For ITYPE > 1, the transformation U is expressed as a product */
/* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)' and each */
/* vector v(j) has its first j elements 0 and the remaining n-j elements */
/* stored in V(j+1:n,j). */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the type of tests to be performed. */
/* 1: U expressed as a dense orthogonal matrix: */
/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU' | / ( n ulp ) */
/* 2: U expressed as a product V of Housholder transformations: */
/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
/* 3: U expressed both as a dense orthogonal matrix and */
/* as a product of Housholder transformations: */
/* RESULT(1) = | I - VU' | / ( n ulp ) */
/* UPLO (input) CHARACTER */
/* If UPLO='U', the upper triangle of A and V will be used and */
/* the (strictly) lower triangle will not be referenced. */
/* If UPLO='L', the lower triangle of A and V will be used and */
/* the (strictly) upper triangle will not be referenced. */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, DSYT21 does nothing. */
/* It must be at least zero. */
/* KBAND (input) INTEGER */
/* The bandwidth of the matrix. It may only be zero or one. */
/* If zero, then S is diagonal, and E is not referenced. If */
/* one, then S is symmetric tri-diagonal. */
/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
/* The original (unfactored) matrix. It is assumed to be */
/* symmetric, and only the upper (UPLO='U') or only the lower */
/* (UPLO='L') will be referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 1 */
/* and at least N. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix. */
/* E (input) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
/* (3,2) element, etc. */
/* Not referenced if KBAND=0. */
/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
/* If ITYPE=1 or 3, this contains the orthogonal matrix in */
/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
/* then it is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N and */
/* at least 1. */
/* V (input) DOUBLE PRECISION array, dimension (LDV, N) */
/* If ITYPE=2 or 3, the columns of this array contain the */
/* Householder vectors used to describe the orthogonal matrix */
/* in the decomposition. If UPLO='L', then the vectors are in */
/* the lower triangle, if UPLO='U', then in the upper */
/* triangle. */
/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
/* is set to one, and later reset to its original value, during */
/* the course of the calculation. */
/* If ITYPE=1, then it is neither referenced nor modified. */
/* LDV (input) INTEGER */
/* The leading dimension of V. LDV must be at least N and */
/* at least 1. */
/* TAU (input) DOUBLE PRECISION array, dimension (N) */
/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
/* v(j) v(j)' in the Householder transformation H(j) of */
/* the product U = H(1)...H(n-2) */
/* If ITYPE < 2, then TAU is not referenced. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N**2) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The values computed by the two tests described above. The */
/* values are currently limited to 1/ulp, to avoid overflow. */
/* RESULT(1) is always modified. RESULT(2) is modified only */
/* if ITYPE=1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
--work;
--result;
/* Function Body */
result[1] = 0.;
if (*itype == 1) {
result[2] = 0.;
}
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10. / ulp;
return 0;
}
/* Do Test 1 */
/* Norm of A: */
if (*itype == 3) {
anorm = 1.;
} else {
/* Computing MAX */
d__1 = dlansy_("1", cuplo, n, &a[a_offset], lda, &work[1]);
anorm = max(d__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U' */
dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
dlacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -d__[j];
dsyr_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
/* L10: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
d__1 = -e[j];
dsyr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1)
* u_dim1 + 1], &c__1, &work[1], n);
/* L20: */
}
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlansy_("1", cuplo, n, &work[1], n, &work[i__1 * i__1 + 1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V' - A */
dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
if (lower) {
/* Computing 2nd power */
i__1 = *n;
work[i__1 * i__1] = d__[*n];
for (j = *n - 1; j >= 1; --j) {
if (*kband == 1) {
work[(*n + 1) * (j - 1) + 2] = (1. - tau[j]) * e[j];
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
work[(j - 1) * *n + jr] = -tau[j] * e[j] * v[jr + j *
v_dim1];
/* L30: */
}
}
vsave = v[j + 1 + j * v_dim1];
v[j + 1 + j * v_dim1] = 1.;
i__1 = *n - j;
/* Computing 2nd power */
i__2 = *n;
dlarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
v[j + 1 + j * v_dim1] = vsave;
work[(*n + 1) * (j - 1) + 1] = d__[j];
/* L40: */
}
} else {
work[1] = d__[1];
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
if (*kband == 1) {
work[(*n + 1) * j] = (1. - tau[j]) * e[j];
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
work[j * *n + jr] = -tau[j] * e[j] * v[jr + (j + 1) *
v_dim1];
/* L50: */
}
}
vsave = v[j + (j + 1) * v_dim1];
v[j + (j + 1) * v_dim1] = 1.;
/* Computing 2nd power */
i__2 = *n;
dlarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
work[1], n, &work[i__2 * i__2 + 1]);
v[j + (j + 1) * v_dim1] = vsave;
work[(*n + 1) * j + 1] = d__[j + 1];
/* L60: */
}
}
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (lower) {
i__2 = *n;
for (jrow = jcol; jrow <= i__2; ++jrow) {
work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
/* L70: */
}
} else {
i__2 = jcol;
for (jrow = 1; jrow <= i__2; ++jrow) {
work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
/* L80: */
}
}
/* L90: */
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlansy_("1", cuplo, n, &work[1], n, &work[i__1 * i__1 + 1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V' - I */
if (*n < 2) {
return 0;
}
dlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
if (lower) {
i__1 = *n - 1;
i__2 = *n - 1;
/* Computing 2nd power */
i__3 = *n;
dorm2r_("R", "T", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
} else {
i__1 = *n - 1;
i__2 = *n - 1;
/* Computing 2nd power */
i__3 = *n;
dorm2l_("R", "T", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
}
if (iinfo != 0) {
result[1] = 10. / ulp;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.;
/* L100: */
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
}
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
result[1] = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
result[1] = min(d__1,d__2) / (*n * ulp);
}
}
/* Do Test 2 */
/* Compute UU' - I */
if (*itype == 1) {
dgemm_("N", "C", n, n, n, &c_b42, &u[u_offset], ldu, &u[u_offset],
ldu, &c_b10, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.;
/* L110: */
}
/* Computing MIN */
/* Computing 2nd power */
i__1 = *n;
d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), d__2 = (doublereal) (*n);
result[2] = min(d__1,d__2) / (*n * ulp);
}
return 0;
/* End of DSYT21 */
} /* dsyt21_ */
/* Subroutine */ int dlagsy_(integer *n, integer *k, doublereal *d,
doublereal *a, integer *lda, integer *iseed, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *), dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i, j;
static doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *), dsymv_(char *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal wa, wb, wn;
extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
integer *, integer *, integer *, doublereal *);
static doublereal tau;
/* -- LAPACK auxiliary test routine (version 2.0)
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLAGSY generates a real symmetric matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random orthogonal matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
orthogonal transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) DOUBLE PRECISION array, dimension (LDA,N)
The generated n by n symmetric matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("DLAGSY", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
a[i + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
a[i + i * a_dim1] = d[i];
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = dnrm2_(&i__1, &work[1], &c__1);
wa = d_sign(&wn, &work[1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = work[1] + wa;
i__1 = *n - i;
d__1 = 1. / wb;
dscal_(&i__1, &d__1, &work[2], &c__1);
work[1] = 1.;
tau = wb / wa;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * u */
i__1 = *n - i + 1;
dsymv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b12, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
i__1 = *n - i + 1;
alpha = tau * -.5 * ddot_(&i__1, &work[*n + 1], &c__1, &work[1], &
c__1);
i__1 = *n - i + 1;
daxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i + 1;
dsyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1,
&a[i + i * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = dnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
wa = d_sign(&wn, &a[*k + i + i * a_dim1]);
if (wn == 0.) {
tau = 0.;
} else {
wb = a[*k + i + i * a_dim1] + wa;
i__2 = *n - *k - i;
d__1 = 1. / wb;
dscal_(&i__2, &d__1, &a[*k + i + 1 + i * a_dim1], &c__1);
a[*k + i + i * a_dim1] = 1.;
tau = wb / wa;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i + (i + 1) *
a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b12, &work[1]
, &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
d__1 = -tau;
dger_(&i__2, &i__3, &d__1, &a[*k + i + i * a_dim1], &c__1, &work[1], &
c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * u */
i__2 = *n - *k - i + 1;
dsymv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b12, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
i__2 = *n - *k - i + 1;
alpha = tau * -.5 * ddot_(&i__2, &work[1], &c__1, &a[*k + i + i *
a_dim1], &c__1);
i__2 = *n - *k - i + 1;
daxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
dsyr2_("Lower", &i__2, &c_b19, &a[*k + i + i * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
a[*k + i + i * a_dim1] = -wa;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
a[j + i * a_dim1] = 0.;
/* L50: */
}
/* L60: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
a[j + i * a_dim1] = a[i + j * a_dim1];
/* L70: */
}
/* L80: */
}
return 0;
/* End of DLAGSY */
} /* dlagsy_ */
