int
f2c_cher2(char* uplo, integer* N,
complex* alpha,
complex* X, integer* incX,
complex* Y, integer* incY,
complex* A, integer* lda)
{
cher2_(uplo, N, alpha,
X, incX, Y, incY, A, lda);
return 0;
}
int chegs2_(int *itype, char *uplo, int *n, complex *
a, int *lda, complex *b, int *ldb, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
float r__1, r__2;
complex q__1;
/* Local variables */
int k;
complex ct;
float akk, bkk;
extern int cher2_(char *, int *, complex *, complex *
, int *, complex *, int *, complex *, int *);
extern int lsame_(char *, char *);
extern int caxpy_(int *, complex *, complex *,
int *, complex *, int *);
int upper;
extern int ctrmv_(char *, char *, char *, int *,
complex *, int *, complex *, int *), ctrsv_(char *, char *, char *, int *, complex *,
int *, complex *, int *), clacgv_(
int *, complex *, int *), csscal_(int *, float *,
complex *, 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 */
/* ======= */
/* CHEGS2 reduces a complex Hermitian-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 CPOTRF. */
/* 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 */
/* Hermitian 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) COMPLEX array, dimension (LDA,N) */
/* On entry, the Hermitian 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) COMPLEX array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by CPOTRF. */
/* 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_("CHEGS2", &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) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a[k + (k + 1) * a_dim1], lda);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cher2_(uplo, &i__2, &q__1, &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;
caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) *
a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &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) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a[k + 1 + k * a_dim1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cher2_(uplo, &i__2, &q__1, &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;
caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
ctrsv_(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) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* 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) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
clacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k - 1;
ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a[k + a_dim1], lda);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
clacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1]
, ldb, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
clacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a[k + a_dim1], lda);
i__2 = k - 1;
clacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L40: */
}
}
}
return 0;
/* End of CHEGS2 */
} /* chegs2_ */
void
cher2(char uplo, int n, complex *alpha, complex *x, int incx, complex *y, int incy, complex *a, int lda)
{
cher2_( &uplo, &n, alpha, x, &incx, y, &incy, a, &lda);
}
/* Subroutine */ int chegs2_(integer *itype, char *uplo, integer *n, complex *
a, integer *lda, complex *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
September 30, 1994
Purpose
=======
CHEGS2 reduces a complex Hermitian-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 CPOTRF.
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
Hermitian 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) COMPLEX array, dimension (LDA,N)
On entry, the Hermitian 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) COMPLEX array, dimension (LDB,N)
The triangular factor from the Cholesky factorization of B,
as returned by CPOTRF.
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 complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1, r__2;
complex q__1;
/* Local variables */
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static integer k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *);
static complex ct;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static real akk, bkk;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
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_("CHEGS2", &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) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = a_subscr(k, k);
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a_ref(k, k + 1), lda);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
clacgv_(&i__2, &a_ref(k, k + 1), lda);
i__2 = *n - k;
clacgv_(&i__2, &b_ref(k, k + 1), ldb);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cher2_(uplo, &i__2, &q__1, &a_ref(k, k + 1), lda, &b_ref(
k, k + 1), ldb, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
clacgv_(&i__2, &b_ref(k, k + 1), ldb);
i__2 = *n - k;
ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &
b_ref(k + 1, k + 1), ldb, &a_ref(k, k + 1), lda);
i__2 = *n - k;
clacgv_(&i__2, &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) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = a_subscr(k, k);
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a_ref(k + 1, k), &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cher2_(uplo, &i__2, &q__1, &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;
caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
ctrsv_(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) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
i__2 = k - 1;
ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a_ref(1, k), &c__1);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a_ref(1, k), &c__1, &b_ref(1, k),
&c__1, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a_ref(1, k), &c__1);
i__2 = a_subscr(k, k);
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* 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) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
i__2 = k - 1;
clacgv_(&i__2, &a_ref(k, 1), lda);
i__2 = k - 1;
ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a_ref(k, 1), lda);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
clacgv_(&i__2, &b_ref(k, 1), ldb);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a_ref(k, 1), lda, &b_ref(k, 1),
ldb, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
clacgv_(&i__2, &b_ref(k, 1), ldb);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a_ref(k, 1), lda);
i__2 = k - 1;
clacgv_(&i__2, &a_ref(k, 1), lda);
i__2 = a_subscr(k, k);
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L40: */
}
}
}
return 0;
/* End of CHEGS2 */
} /* chegs2_ */
/* Subroutine */
int chetd2_(char *uplo, integer *n, complex *a, integer *lda, real *d__, real *e, complex *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
integer i__;
complex taui;
extern /* Subroutine */
int cher2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, integer *);
complex alpha;
extern /* Complex */
VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int chemv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * ), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int clarfg_(integer *, complex *, complex *, integer *, complex *), 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_("CHETD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0)
{
return 0;
}
if (upper)
{
/* Reduce the upper triangle of A */
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1;
a[i__1].i = 0.f; // , expr subst
for (i__ = *n - 1;
i__ >= 1;
--i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**H */
/* to annihilate A(1:i-1,i+1) */
i__1 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__1].r;
alpha.i = a[i__1].i; // , expr subst
clarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0.f || taui.i != 0.f)
{
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i__ + (i__ + 1) * a_dim1;
a[i__1].r = 1.f;
a[i__1].i = 0.f; // , expr subst
/* Compute x := tau * A * v storing x in TAU(1:i) */
chemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x**H * v) * v */
q__3.r = -.5f;
q__3.i = -0.f; // , expr subst
q__2.r = q__3.r * taui.r - q__3.i * taui.i;
q__2.i = q__3.r * taui.i + q__3.i * taui.r; // , expr subst
cdotc_f2c_(&q__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1] , &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i;
q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; // , expr subst
alpha.r = q__1.r;
alpha.i = q__1.i; // , expr subst
caxpy_(&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**H - w * v**H */
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cher2_(uplo, &i__, &q__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, & tau[1], &c__1, &a[a_offset], lda);
}
else
{
i__1 = i__ + i__ * a_dim1;
i__2 = i__ + i__ * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1;
a[i__1].i = 0.f; // , expr subst
}
i__1 = i__ + (i__ + 1) * a_dim1;
i__2 = i__;
a[i__1].r = e[i__2];
a[i__1].i = 0.f; // , expr subst
i__1 = i__ + 1;
i__2 = i__ + 1 + (i__ + 1) * a_dim1;
d__[i__1] = a[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r;
tau[i__1].i = taui.i; // , expr subst
/* L10: */
}
i__1 = a_dim1 + 1;
d__[1] = a[i__1].r;
}
else
{
/* Reduce the lower triangle of A */
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
r__1 = a[i__2].r;
a[i__1].r = r__1;
a[i__1].i = 0.f; // , expr subst
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**H */
/* to annihilate A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, & taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0.f || taui.i != 0.f)
{
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
chemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[ i__], &c__1);
/* Compute w := x - 1/2 * tau * (x**H * v) * v */
q__3.r = -.5f;
q__3.i = -0.f; // , expr subst
q__2.r = q__3.r * taui.r - q__3.i * taui.i;
q__2.i = q__3.r * taui.i + q__3.i * taui.r; // , expr subst
i__2 = *n - i__;
cdotc_f2c_(&q__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i;
q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; // , expr subst
alpha.r = q__1.r;
alpha.i = q__1.i; // , expr subst
i__2 = *n - i__;
caxpy_(&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**H - w * v**H */
i__2 = *n - i__;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cher2_(uplo, &i__2, &q__1, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda);
}
else
{
i__2 = i__ + 1 + (i__ + 1) * a_dim1;
i__3 = i__ + 1 + (i__ + 1) * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1;
a[i__2].i = 0.f; // , expr subst
}
i__2 = i__ + 1 + i__ * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3];
a[i__2].i = 0.f; // , expr subst
i__2 = i__;
i__3 = i__ + i__ * a_dim1;
d__[i__2] = a[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r;
tau[i__2].i = taui.i; // , expr subst
/* L20: */
}
i__1 = *n;
i__2 = *n + *n * a_dim1;
d__[i__1] = a[i__2].r;
}
return 0;
/* End of CHETD2 */
}
/* Subroutine */ int claghe_slu(integer *n, integer *k, real *d, complex *a,
integer *lda, integer *iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static integer i, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *);
static complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), chemv_(char *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
extern real scnrm2_(integer *, complex *, integer *);
static complex wa, wb;
static real wn;
extern /* Subroutine */ int clarnv_slu(integer *, integer *, integer *, complex *);
extern int input_error(char *, int *);
static complex 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
September 30, 1994
Purpose
=======
CLAGHE generates a complex hermitian matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
unitary 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) REAL array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX array, dimension (LDA,N)
The generated n by n hermitian 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) COMPLEX 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);
input_error("CLAGHE", &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) {
i__3 = i + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
clarnv_slu(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
d__1 = wn / c_abs(&work[1]);
q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* 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;
chemv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__1 = *n - i + 1;
cdotc_(&q__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__1 = *n - i + 1;
caxpy_(&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;
q__1.r = -1.f, q__1.i = 0.f;
cher2_("Lower", &i__1, &q__1, &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 = scnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / c_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *k + i + i * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *k - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* 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;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1)
* a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[
1], &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__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;
chemv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__2 = *n - *k - i + 1;
cdotc_(&q__4, &i__2, &work[1], &c__1, &a[*k + i + i * a_dim1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - *k - i + 1;
caxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
q__1.r = -1.f, q__1.i = 0.f;
cher2_("Lower", &i__2, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1]
, &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
i__2 = *k + i + i * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L50: */
}
/* L60: */
}
/* Store full hermitian matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = j + i * a_dim1;
r_cnjg(&q__1, &a[i + j * a_dim1]);
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of CLAGHE */
} /* claghe_slu */
/* Subroutine */ int cstt21_(integer *n, integer *kband, real *ad, real *ae,
real *sd, real *se, complex *u, integer *ldu, complex *work, real *
rwork, real *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
complex q__1, q__2;
/* Local variables */
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *);
static real unfl;
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static real temp1, temp2;
static integer j;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
static real anorm, wnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
static real ulp;
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
/* -- 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
=======
CSTT21 checks a decomposition of the form
A = U S U*
where * means conjugate transpose, A is real symmetric tridiagonal,
U is unitary, and S is real and 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, CSTT21 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 real 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 real (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) COMPLEX array, dimension (LDU, N)
The unitary matrix in the decomposition.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N.
WORK (workspace) COMPLEX array, dimension (N**2)
RWORK (workspace) REAL array, dimension (N)
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;
--rwork;
--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: */
claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
anorm = 0.f;
temp1 = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = j;
work[i__2].r = ad[i__3], work[i__2].i = 0.f;
i__2 = (*n + 1) * (j - 1) + 2;
i__3 = j;
work[i__2].r = ae[i__3], work[i__2].i = 0.f;
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__2 = *n;
i__1 = i__2 * i__2;
i__3 = *n;
work[i__1].r = ad[i__3], work[i__1].i = 0.f;
/* 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];
cher_("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) {
i__2 = j;
q__2.r = se[i__2], q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
cher2_("L", n, &q__1, &u_ref(1, j), &c__1, &u_ref(1, j + 1), &
c__1, &work[1], n);
/* L30: */
}
}
wnorm = clanhe_("1", "L", n, &work[1], n, &rwork[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 */
cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b1, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i + 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L40: */
}
/* Computing MIN */
r__1 = (real) (*n), r__2 = clange_("1", n, n, &work[1], n, &rwork[1]);
result[2] = dmin(r__1,r__2) / (*n * ulp);
return 0;
/* End of CSTT21 */
} /* cstt21_ */
/* Subroutine */ int chet21_(integer *itype, char *uplo, integer *n, integer *
kband, complex *a, integer *lda, real *d__, real *e, complex *u,
integer *ldu, complex *v, integer *ldv, complex *tau, complex *work,
real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
integer j, jr;
real ulp;
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *);
integer jcol;
real unfl;
integer jrow;
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *),
cgemm_(char *, char *, integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
integer iinfo;
real anorm;
char cuplo[1];
complex vsave;
logical lower;
real wnorm;
extern /* Subroutine */ int cunm2l_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *), cunm2r_(char *, char *,
integer *, integer *, integer *, complex *, integer *, complex *,
complex *, integer *, complex *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), clarfy_(char *, integer *, complex *, integer *, complex
*, complex *, integer *, complex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHET21 generally checks a decomposition of the form */
/* A = U S U* */
/* where * means conjugate transpose, A is hermitian, U is unitary, and */
/* S is diagonal (if KBAND=0) or (real) 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 - UV* | / ( 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 unitary 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 unitary matrix and */
/* as a product of Housholder transformations: */
/* RESULT(1) = | I - UV* | / ( 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, CHET21 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) COMPLEX array, dimension (LDA, N) */
/* The original (unfactored) matrix. It is assumed to be */
/* hermitian, 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) REAL array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix. */
/* E (input) REAL 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) COMPLEX array, dimension (LDU, N) */
/* If ITYPE=1 or 3, this contains the unitary 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) COMPLEX array, dimension (LDV, N) */
/* If ITYPE=2 or 3, the columns of this array contain the */
/* Householder vectors used to describe the unitary 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) COMPLEX 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) COMPLEX array, dimension (2*N**2) */
/* RWORK (workspace) REAL array, dimension (N) */
/* 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. 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;
--rwork;
--result;
/* Function Body */
result[1] = 0.f;
if (*itype == 1) {
result[2] = 0.f;
}
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10.f / ulp;
return 0;
}
/* Do Test 1 */
/* Norm of A: */
if (*itype == 3) {
anorm = 1.f;
} else {
/* Computing MAX */
r__1 = clanhe_("1", cuplo, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U* */
claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
clacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__1 = -d__[j];
cher_(cuplo, n, &r__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) {
i__2 = j;
q__2.r = e[i__2], q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
cher2_(cuplo, n, &q__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
* u_dim1 + 1], &c__1, &work[1], n);
/* L20: */
}
}
wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V* - A */
claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
if (lower) {
/* Computing 2nd power */
i__2 = *n;
i__1 = i__2 * i__2;
i__3 = *n;
work[i__1].r = d__[i__3], work[i__1].i = 0.f;
for (j = *n - 1; j >= 1; --j) {
if (*kband == 1) {
i__1 = (*n + 1) * (j - 1) + 2;
i__2 = j;
q__2.r = 1.f - tau[i__2].r, q__2.i = 0.f - tau[i__2].i;
i__3 = j;
q__1.r = e[i__3] * q__2.r, q__1.i = e[i__3] * q__2.i;
work[i__1].r = q__1.r, work[i__1].i = q__1.i;
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
i__2 = (j - 1) * *n + jr;
i__3 = j;
q__3.r = -tau[i__3].r, q__3.i = -tau[i__3].i;
i__4 = j;
q__2.r = e[i__4] * q__3.r, q__2.i = e[i__4] * q__3.i;
i__5 = jr + j * v_dim1;
q__1.r = q__2.r * v[i__5].r - q__2.i * v[i__5].i,
q__1.i = q__2.r * v[i__5].i + q__2.i * v[i__5]
.r;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L30: */
}
}
i__1 = j + 1 + j * v_dim1;
vsave.r = v[i__1].r, vsave.i = v[i__1].i;
i__1 = j + 1 + j * v_dim1;
v[i__1].r = 1.f, v[i__1].i = 0.f;
i__1 = *n - j;
/* Computing 2nd power */
i__2 = *n;
clarfy_("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]);
i__1 = j + 1 + j * v_dim1;
v[i__1].r = vsave.r, v[i__1].i = vsave.i;
i__1 = (*n + 1) * (j - 1) + 1;
i__2 = j;
work[i__1].r = d__[i__2], work[i__1].i = 0.f;
/* L40: */
}
} else {
work[1].r = d__[1], work[1].i = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
if (*kband == 1) {
i__2 = (*n + 1) * j;
i__3 = j;
q__2.r = 1.f - tau[i__3].r, q__2.i = 0.f - tau[i__3].i;
i__4 = j;
q__1.r = e[i__4] * q__2.r, q__1.i = e[i__4] * q__2.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = j * *n + jr;
i__4 = j;
q__3.r = -tau[i__4].r, q__3.i = -tau[i__4].i;
i__5 = j;
q__2.r = e[i__5] * q__3.r, q__2.i = e[i__5] * q__3.i;
i__6 = jr + (j + 1) * v_dim1;
q__1.r = q__2.r * v[i__6].r - q__2.i * v[i__6].i,
q__1.i = q__2.r * v[i__6].i + q__2.i * v[i__6]
.r;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L50: */
}
}
i__2 = j + (j + 1) * v_dim1;
vsave.r = v[i__2].r, vsave.i = v[i__2].i;
i__2 = j + (j + 1) * v_dim1;
v[i__2].r = 1.f, v[i__2].i = 0.f;
/* Computing 2nd power */
i__2 = *n;
clarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
work[1], n, &work[i__2 * i__2 + 1]);
i__2 = j + (j + 1) * v_dim1;
v[i__2].r = vsave.r, v[i__2].i = vsave.i;
i__2 = (*n + 1) * j + 1;
i__3 = j + 1;
work[i__2].r = d__[i__3], work[i__2].i = 0.f;
/* L60: */
}
}
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (lower) {
i__2 = *n;
for (jrow = jcol; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L70: */
}
} else {
i__2 = jcol;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L80: */
}
}
/* L90: */
}
wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V* - I */
if (*n < 2) {
return 0;
}
clacpy_(" ", 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;
cunm2r_("R", "C", 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;
cunm2l_("R", "C", 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.f / ulp;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L100: */
}
wnorm = clange_("1", n, n, &work[1], n, &rwork[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 */
if (*itype == 1) {
cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
&c_b1, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L110: */
}
/* Computing MIN */
r__1 = clange_("1", n, n, &work[1], n, &rwork[1]), r__2 = (
real) (*n);
result[2] = dmin(r__1,r__2) / (*n * ulp);
}
return 0;
/* End of CHET21 */
} /* chet21_ */
