/* Subroutine */ int chetrd_(char *uplo, integer *n, complex *a, integer *lda,
real *d, real *e, complex *tau, complex *work, integer *lwork,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHETRD reduces a complex Hermitian matrix A to real symmetric
tridiagonal form T by a unitary similarity transformation:
Q**H * A * Q = T.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
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 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 unitary
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 unitary 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) REAL array, dimension (N)
The diagonal elements of the tridiagonal matrix T:
D(i) = A(i,i).
E (output) REAL 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) COMPLEX array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 1.
For optimum performance LWORK >= N*NB, where NB is the
optimal blocksize.
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 complex scalar, and v is a complex 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 complex scalar, and v is a complex 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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
static real c_b23 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1;
/* Local variables */
static integer i, j;
extern logical lsame_(char *, char *);
static integer nbmin, iinfo;
static logical upper;
extern /* Subroutine */ int chetd2_(char *, integer *, complex *, integer
*, real *, real *, complex *, integer *), cher2k_(char *,
char *, integer *, integer *, complex *, complex *, integer *,
complex *, integer *, real *, complex *, integer *);
static integer nb, kk, nx;
extern /* Subroutine */ int clatrd_(char *, integer *, integer *, complex
*, integer *, real *, complex *, complex *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer ldwork, iws;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*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;
} else if (*lwork < 1) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHETRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
WORK(1).r = 1.f, WORK(1).i = 0.f;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1, 6L, 1L);
nx = *n;
iws = 1;
if (nb > 1 && nb < *n) {
/* Determine when to cross over from blocked to unblocked code
(last block is always handled by unblocked code).
Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "CHETRD", uplo, n, &c_n1, &c_n1, &
c_n1, 6L, 1L);
nx = max(i__1,i__2);
if (nx < *n) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: deter
mine the
minimum value of NB, and reduce NB or force us
e of
unblocked code by setting NX = N.
Computing MAX */
i__1 = *lwork / ldwork;
nb = max(i__1,1);
nbmin = ilaenv_(&c__2, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1,
6L, 1L);
if (nb < nbmin) {
nx = *n;
}
}
} else {
nx = *n;
}
} else {
nb = 1;
}
if (upper) {
/* Reduce the upper triangle of A.
Columns 1:kk are handled by the unblocked method. */
kk = *n - (*n - nx + nb - 1) / nb * nb;
i__1 = kk + 1;
i__2 = -nb;
for (i = *n - nb + 1; -nb < 0 ? i >= kk+1 : i <= kk+1; i += -nb) {
/* Reduce columns i:i+nb-1 to tridiagonal form and form
the
matrix W which is needed to update the unreduced part
of
the matrix */
i__3 = i + nb - 1;
clatrd_(uplo, &i__3, &nb, &A(1,1), lda, &E(1), &TAU(1), &
WORK(1), &ldwork);
/* Update the unreduced submatrix A(1:i-1,1:i-1), using
an
update of the form: A := A - V*W' - W*V' */
i__3 = i - 1;
q__1.r = -1.f, q__1.i = 0.f;
cher2k_(uplo, "No transpose", &i__3, &nb, &q__1, &A(1,i), lda, &WORK(1), &ldwork, &c_b23, &A(1,1), lda);
/* Copy superdiagonal elements back into A, and diagonal
elements into D */
i__3 = i + nb - 1;
for (j = i; j <= i+nb-1; ++j) {
i__4 = j - 1 + j * a_dim1;
i__5 = j - 1;
A(j-1,j).r = E(j-1), A(j-1,j).i = 0.f;
i__4 = j;
i__5 = j + j * a_dim1;
D(j) = A(j,j).r;
/* L10: */
}
/* L20: */
}
/* Use unblocked code to reduce the last or only block */
chetd2_(uplo, &kk, &A(1,1), lda, &D(1), &E(1), &TAU(1), &iinfo);
} else {
/* Reduce the lower triangle of A */
i__2 = *n - nx;
i__1 = nb;
for (i = 1; nb < 0 ? i >= *n-nx : i <= *n-nx; i += nb) {
/* Reduce columns i:i+nb-1 to tridiagonal form and form
the
matrix W which is needed to update the unreduced part
of
the matrix */
i__3 = *n - i + 1;
clatrd_(uplo, &i__3, &nb, &A(i,i), lda, &E(i), &TAU(i),
&WORK(1), &ldwork);
/* Update the unreduced submatrix A(i+nb:n,i+nb:n), usin
g
an update of the form: A := A - V*W' - W*V' */
i__3 = *n - i - nb + 1;
q__1.r = -1.f, q__1.i = 0.f;
cher2k_(uplo, "No transpose", &i__3, &nb, &q__1, &A(i+nb,i), lda, &WORK(nb + 1), &ldwork, &c_b23, &A(i+nb,i+nb), lda);
/* Copy subdiagonal elements back into A, and diagonal
elements into D */
i__3 = i + nb - 1;
for (j = i; j <= i+nb-1; ++j) {
i__4 = j + 1 + j * a_dim1;
i__5 = j;
A(j+1,j).r = E(j), A(j+1,j).i = 0.f;
i__4 = j;
i__5 = j + j * a_dim1;
D(j) = A(j,j).r;
/* L30: */
}
/* L40: */
}
/* Use unblocked code to reduce the last or only block */
i__1 = *n - i + 1;
chetd2_(uplo, &i__1, &A(i,i), lda, &D(i), &E(i), &TAU(i), &
iinfo);
}
WORK(1).r = (real) iws, WORK(1).i = 0.f;
return 0;
/* End of CHETRD */
} /* chetrd_ */
/* Subroutine */ int chetrd_(char *uplo, integer *n, complex *a, integer *lda,
real *d__, real *e, complex *tau, complex *work, integer *lwork,
integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1;
/* Local variables */
static integer i__, j, nb, kk, nx, iws;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static integer nbmin, iinfo;
static logical upper;
extern /* Subroutine */ int chetd2_(char *, integer *, complex *, integer
*, real *, real *, complex *, integer *, ftnlen), cher2k_(char *,
char *, integer *, integer *, complex *, complex *, integer *,
complex *, integer *, real *, complex *, integer *, ftnlen,
ftnlen), clatrd_(char *, integer *, integer *, complex *, integer
*, real *, complex *, complex *, integer *, ftnlen), xerbla_(char
*, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer ldwork, lwkopt;
static logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHETRD reduces a complex Hermitian matrix A to real symmetric */
/* tridiagonal form T by a unitary similarity transformation: */
/* Q**H * A * Q = T. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* 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 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 unitary */
/* 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 unitary 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) REAL array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T: */
/* D(i) = A(i,i). */
/* E (output) REAL 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) COMPLEX array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace/output) COMPLEX array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 1. */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* 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 complex scalar, and v is a complex 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 complex scalar, and v is a complex 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
--work;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*lwork < 1 && ! lquery) {
*info = -9;
}
if (*info == 0) {
/* Determine the block size. */
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = *n * nb;
work[1].r = (real) lwkopt, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHETRD", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
nx = *n;
iws = 1;
if (nb > 1 && nb < *n) {
/* Determine when to cross over from blocked to unblocked code */
/* (last block is always handled by unblocked code). */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "CHETRD", uplo, n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
if (nx < *n) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: determine the */
/* minimum value of NB, and reduce NB or force use of */
/* unblocked code by setting NX = N. */
/* Computing MAX */
i__1 = *lwork / ldwork;
nb = max(i__1,1);
nbmin = ilaenv_(&c__2, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1,
(ftnlen)6, (ftnlen)1);
if (nb < nbmin) {
nx = *n;
}
}
} else {
nx = *n;
}
} else {
nb = 1;
}
if (upper) {
/* Reduce the upper triangle of A. */
/* Columns 1:kk are handled by the unblocked method. */
kk = *n - (*n - nx + nb - 1) / nb * nb;
i__1 = kk + 1;
i__2 = -nb;
for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
i__2) {
/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
/* matrix W which is needed to update the unreduced part of */
/* the matrix */
i__3 = i__ + nb - 1;
clatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &
work[1], &ldwork, (ftnlen)1);
/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */
/* update of the form: A := A - V*W' - W*V' */
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cher2k_(uplo, "No transpose", &i__3, &nb, &q__1, &a[i__ * a_dim1
+ 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda, (
ftnlen)1, (ftnlen)12);
/* Copy superdiagonal elements back into A, and diagonal */
/* elements into D */
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
i__4 = j - 1 + j * a_dim1;
i__5 = j - 1;
a[i__4].r = e[i__5], a[i__4].i = 0.f;
i__4 = j;
i__5 = j + j * a_dim1;
d__[i__4] = a[i__5].r;
/* L10: */
}
/* L20: */
}
/* Use unblocked code to reduce the last or only block */
chetd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo,
(ftnlen)1);
} else {
/* Reduce the lower triangle of A */
i__2 = *n - nx;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
/* matrix W which is needed to update the unreduced part of */
/* the matrix */
i__3 = *n - i__ + 1;
clatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &
tau[i__], &work[1], &ldwork, (ftnlen)1);
/* Update the unreduced submatrix A(i+nb:n,i+nb:n), using */
/* an update of the form: A := A - V*W' - W*V' */
i__3 = *n - i__ - nb + 1;
q__1.r = -1.f, q__1.i = -0.f;
cher2k_(uplo, "No transpose", &i__3, &nb, &q__1, &a[i__ + nb +
i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[
i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)1, (ftnlen)
12);
/* Copy subdiagonal elements back into A, and diagonal */
/* elements into D */
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
i__4 = j + 1 + j * a_dim1;
i__5 = j;
a[i__4].r = e[i__5], a[i__4].i = 0.f;
i__4 = j;
i__5 = j + j * a_dim1;
d__[i__4] = a[i__5].r;
/* L30: */
}
/* L40: */
}
/* Use unblocked code to reduce the last or only block */
i__1 = *n - i__ + 1;
chetd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__],
&tau[i__], &iinfo, (ftnlen)1);
}
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CHETRD */
} /* chetrd_ */
