/* Subroutine */
int zlatrd_(char *uplo, integer *n, integer *nb, doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau, doublecomplex *w, integer *ldw)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, iw;
doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *);
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */
int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zhemv_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK auxiliary 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 .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0)
{
return 0;
}
if (lsame_(uplo, "U"))
{
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n;
i__ >= i__1;
--i__)
{
iw = i__ - *n + *nb;
if (i__ < *n)
{
/* Update A(1:i,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1;
a[i__2].i = 0.; // , expr subst
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__, &i__2, &z__1, &w[(iw + 1) * w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1;
a[i__2].i = 0.; // , expr subst
}
if (i__ > 1)
{
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1 + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = i__ - 1;
zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__ - 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = i__ - 1 + i__ * a_dim1;
a[i__2].r = 1.;
a[i__2].i = 0.; // , expr subst
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ * a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1);
if (i__ < *n)
{
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw + 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], & c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[( i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) * w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
}
i__2 = i__ - 1;
zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
z__3.r = -.5;
z__3.i = -0.; // , expr subst
i__2 = i__ - 1;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i;
z__2.i = z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; // , expr subst
i__3 = i__ - 1;
zdotc_f2c_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
alpha.r = z__1.r;
alpha.i = z__1.i; // , expr subst
i__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * w_dim1 + 1], &c__1);
}
/* L10: */
}
}
else
{
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Update A(i:n,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1;
a[i__2].i = 0.; // , expr subst
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda, &w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], & c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], & c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1;
a[i__2].i = 0.; // , expr subst
if (i__ < *n)
{
/* Generate elementary reflector H(i) 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;
zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.;
a[i__2].i = 0.; // , expr subst
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
zhemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1] , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1 + w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 + w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
z__3.r = -.5;
z__3.i = -0.; // , expr subst
i__2 = i__;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i;
z__2.i = z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; // , expr subst
i__3 = *n - i__;
zdotc_f2c_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[ i__ + 1 + i__ * a_dim1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
alpha.r = z__1.r;
alpha.i = z__1.i; // , expr subst
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of ZLATRD */
}
/* Subroutine */
int zhptrd_(char *uplo, integer *n, doublecomplex *ap, doublereal *d__, doublereal *e, doublecomplex *tau, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, i1, ii, i1i1;
doublecomplex taui;
extern /* Subroutine */
int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *);
doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */
int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--tau;
--e;
--d__;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHPTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0)
{
return 0;
}
if (upper)
{
/* Reduce the upper triangle of A. */
/* I1 is the index in AP of A(1,I+1). */
i1 = *n * (*n - 1) / 2 + 1;
i__1 = i1 + *n - 1;
i__2 = i1 + *n - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , 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 = i1 + i__ - 1;
alpha.r = ap[i__1].r;
alpha.i = ap[i__1].i; // , expr subst
zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0. || taui.i != 0.)
{
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i1 + i__ - 1;
ap[i__1].r = 1.;
ap[i__1].i = 0.; // , expr subst
/* Compute y := tau * A * v storing y in TAU(1:i) */
zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[ 1], &c__1);
/* Compute w := y - 1/2 * tau * (y**H *v) * v */
z__3.r = -.5;
z__3.i = -0.; // , expr subst
z__2.r = z__3.r * taui.r - z__3.i * taui.i;
z__2.i = z__3.r * taui.i + z__3.i * taui.r; // , expr subst
zdotc_f2c_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
alpha.r = z__1.r;
alpha.i = z__1.i; // , expr subst
zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**H - w * v**H */
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[ 1]);
}
i__1 = i1 + i__ - 1;
i__2 = i__;
ap[i__1].r = e[i__2];
ap[i__1].i = 0.; // , expr subst
i__1 = i__ + 1;
i__2 = i1 + i__;
d__[i__1] = ap[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r;
tau[i__1].i = taui.i; // , expr subst
i1 -= i__;
/* L10: */
}
d__[1] = ap[1].r;
}
else
{
/* Reduce the lower triangle of A. II is the index in AP of */
/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
ii = 1;
d__1 = ap[1].r;
ap[1].r = d__1;
ap[1].i = 0.; // , expr subst
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i1i1 = ii + *n - i__ + 1;
/* Generate elementary reflector H(i) = I - tau * v * v**H */
/* to annihilate A(i+2:n,i) */
i__2 = ii + 1;
alpha.r = ap[i__2].r;
alpha.i = ap[i__2].i; // , expr subst
i__2 = *n - i__;
zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0. || taui.i != 0.)
{
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = ii + 1;
ap[i__2].r = 1.;
ap[i__2].i = 0.; // , expr subst
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & c_b2, &tau[i__], &c__1);
/* Compute w := y - 1/2 * tau * (y**H *v) * v */
z__3.r = -.5;
z__3.i = -0.; // , expr subst
z__2.r = z__3.r * taui.r - z__3.i * taui.i;
z__2.i = z__3.r * taui.i + z__3.i * taui.r; // , expr subst
i__2 = *n - i__;
zdotc_f2c_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
alpha.r = z__1.r;
alpha.i = z__1.i; // , expr subst
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &ap[ii + 1], &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__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], & c__1, &ap[i1i1]);
}
i__2 = ii + 1;
i__3 = i__;
ap[i__2].r = e[i__3];
ap[i__2].i = 0.; // , expr subst
i__2 = i__;
i__3 = ii;
d__[i__2] = ap[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r;
tau[i__2].i = taui.i; // , expr subst
ii = i1i1;
/* L20: */
}
i__1 = *n;
i__2 = ii;
d__[i__1] = ap[i__2].r;
}
return 0;
/* End of ZHPTRD */
}
int zlatrd_(char *uplo, int *n, int *nb,
doublecomplex *a, int *lda, double *e, doublecomplex *tau,
doublecomplex *w, int *ldw)
{
/* System generated locals */
int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
double d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
int i__, iw;
doublecomplex alpha;
extern int lsame_(char *, char *);
extern int zscal_(int *, doublecomplex *,
doublecomplex *, int *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *);
extern int zgemv_(char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *, doublecomplex *, doublecomplex *, int *),
zhemv_(char *, int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *), zaxpy_(int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *), zlarfg_(int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *), zlacgv_(int *, doublecomplex *,
int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to */
/* Hermitian tridiagonal form by a unitary similarity */
/* transformation Q' * A * Q, and returns the matrices V and W which are */
/* needed to apply the transformation to the unreduced part of A. */
/* If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a */
/* matrix, of which the upper triangle is supplied; */
/* if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a */
/* matrix, of which the lower triangle is supplied. */
/* This is an auxiliary routine called by ZHETRD. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* NB (input) INTEGER */
/* The number of rows and columns to be reduced. */
/* A (input/output) COMPLEX*16 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 last NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements above the diagonal */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors; */
/* if UPLO = 'L', the first NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements below the diagonal */
/* 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). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
/* elements of the last NB columns of the reduced matrix; */
/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
/* the first NB columns of the reduced matrix. */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors, stored in */
/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
/* See Further Details. */
/* W (output) COMPLEX*16 array, dimension (LDW,NB) */
/* The n-by-nb matrix W required to update the unreduced part */
/* of A. */
/* LDW (input) INTEGER */
/* The leading dimension of the array W. LDW >= MAX(1,N). */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n) H(n-1) . . . H(n-nb+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:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
/* and tau in TAU(i-1). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* 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+1:n) is stored on exit in A(i+1:n,i), */
/* and tau in TAU(i). */
/* The elements of the vectors v together form the n-by-nb matrix V */
/* which is needed, with W, to apply the transformation to the unreduced */
/* part of the matrix, using a Hermitian rank-2k update of the form: */
/* A := A - V*W' - W*V'. */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5 and nb = 2: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( a a a v4 v5 ) ( d ) */
/* ( a a v4 v5 ) ( 1 d ) */
/* ( a 1 v5 ) ( v1 1 a ) */
/* ( d 1 ) ( v1 v2 a a ) */
/* ( d ) ( v1 v2 a a a ) */
/* where d denotes a diagonal element of the reduced matrix, a denotes */
/* an element of the original matrix that is unchanged, and vi denotes */
/* an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = i__ - 1;
zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__
- 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = i__ - 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ *
a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw
+ 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &
c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[(
i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1],
&c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
}
i__2 = i__ - 1;
zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
z__3.r = -.5, z__3.i = -0.;
i__2 = i__ - 1;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = i__ - 1;
zdotc_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ *
a_dim1 + 1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda,
&w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
if (i__ < *n) {
/* Generate elementary reflector H(i) 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;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[MIN(i__3, *n)+ i__ * a_dim1], &c__1,
&tau[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
zhemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1]
, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1
+ w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 +
w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
z__3.r = -.5, z__3.i = -0.;
i__2 = i__;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = *n - i__;
zdotc_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[
i__ + 1 + i__ * a_dim1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of ZLATRD */
} /* zlatrd_ */
/* Subroutine */ int zlahrd_(integer *n, integer *k, integer *nb,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t,
integer *ldt, doublecomplex *y, integer *ldy)
{
/* -- LAPACK auxiliary 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
=======
ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)
matrix A so that elements below the k-th subdiagonal are zero. The
reduction is performed by a unitary similarity transformation
Q' * A * Q. The routine returns the matrices V and T which determine
Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
This is an auxiliary routine called by ZGEHRD.
Arguments
=========
N (input) INTEGER
The order of the matrix A.
K (input) INTEGER
The offset for the reduction. Elements below the k-th
subdiagonal in the first NB columns are reduced to zero.
NB (input) INTEGER
The number of columns to be reduced.
A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)
On entry, the n-by-(n-k+1) general matrix A.
On exit, the elements on and above the k-th subdiagonal in
the first NB columns are overwritten with the corresponding
elements of the reduced matrix; the elements below the k-th
subdiagonal, with the array TAU, represent the matrix Q as a
product of elementary reflectors. The other columns of A are
unchanged. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
TAU (output) COMPLEX*16 array, dimension (NB)
The scalar factors of the elementary reflectors. See Further
Details.
T (output) COMPLEX*16 array, dimension (NB,NB)
The upper triangular matrix T.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= NB.
Y (output) COMPLEX*16 array, dimension (LDY,NB)
The n-by-nb matrix Y.
LDY (input) INTEGER
The leading dimension of the array Y. LDY >= max(1,N).
Further Details
===============
The matrix Q is represented as a product of nb elementary reflectors
Q = H(1) H(2) . . . H(nb).
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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
A(i+k+1:n,i), and tau in TAU(i).
The elements of the vectors v together form the (n-k+1)-by-nb matrix
V which is needed, with T and Y, to apply the transformation to the
unreduced part of the matrix, using an update of the form:
A := (I - V*T*V') * (A - Y*V').
The contents of A on exit are illustrated by the following example
with n = 7, k = 3 and nb = 2:
( a h a a a )
( a h a a a )
( a h a a a )
( h h a a a )
( v1 h a a a )
( v1 v2 a a a )
( v1 v2 a a a )
where a denotes an element of the original matrix A, h denotes a
modified element of the upper Hessenberg matrix H, and vi denotes an
element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
static integer i;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), ztrmv_(char *, char *,
char *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static doublecomplex ei;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *,
doublecomplex *, integer *);
#define TAU(I) tau[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define Y(I,J) y[(I)-1 + ((J)-1)* ( *ldy)]
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i = 1; i <= *nb; ++i) {
if (i > 1) {
/* Update A(1:n,i)
Compute i-th column of A - Y * V' */
i__2 = i - 1;
zlacgv_(&i__2, &A(*k+i-1,1), lda);
i__2 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", n, &i__2, &z__1, &Y(1,1), ldy, &A(*k+i-1,1), lda, &c_b2, &A(1,i), &c__1);
i__2 = i - 1;
zlacgv_(&i__2, &A(*k+i-1,1), lda);
/* Apply I - V * T' * V' to this column (call it b) from
the
left, using the last column of T as workspace
Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
( V2 ) ( b2 )
where V1 is unit lower triangular
w := V1' * b1 */
i__2 = i - 1;
zcopy_(&i__2, &A(*k+1,i), &c__1, &T(1,*nb)
, &c__1);
i__2 = i - 1;
ztrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &A(*k+1,1), lda, &T(1,*nb), &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i + 1;
i__3 = i - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &A(*k+i,1), lda, &A(*k+i,i), &c__1, &c_b2, &T(1,*nb), &c__1);
/* w := T'*w */
i__2 = i - 1;
ztrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &T(1,1), ldt, &T(1,*nb), &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i + 1;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &A(*k+i,1),
lda, &T(1,*nb), &c__1, &c_b2, &A(*k+i,i), &c__1);
/* b1 := b1 - V1*w */
i__2 = i - 1;
ztrmv_("Lower", "No transpose", "Unit", &i__2, &A(*k+1,1)
, lda, &T(1,*nb), &c__1);
i__2 = i - 1;
z__1.r = -1., z__1.i = 0.;
zaxpy_(&i__2, &z__1, &T(1,*nb), &c__1, &A(*k+1,i), &c__1);
i__2 = *k + i - 1 + (i - 1) * a_dim1;
A(*k+i-1,i-1).r = ei.r, A(*k+i-1,i-1).i = ei.i;
}
/* Generate the elementary reflector H(i) to annihilate
A(k+i+1:n,i) */
i__2 = *k + i + i * a_dim1;
ei.r = A(*k+i,i).r, ei.i = A(*k+i,i).i;
i__2 = *n - *k - i + 1;
/* Computing MIN */
i__3 = *k + i + 1;
zlarfg_(&i__2, &ei, &A(min(*k+i+1,*n),i), &c__1, &TAU(i));
i__2 = *k + i + i * a_dim1;
A(*k+i,i).r = 1., A(*k+i,i).i = 0.;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i + 1;
zgemv_("No transpose", n, &i__2, &c_b2, &A(1,i+1), lda,
&A(*k+i,i), &c__1, &c_b1, &Y(1,i), &
c__1);
i__2 = *n - *k - i + 1;
i__3 = i - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &A(*k+i,1)
, lda, &A(*k+i,i), &c__1, &c_b1, &T(1,i), &c__1);
i__2 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", n, &i__2, &z__1, &Y(1,1), ldy, &T(1,i), &c__1, &c_b2, &Y(1,i), &c__1);
zscal_(n, &TAU(i), &Y(1,i), &c__1);
/* Compute T(1:i,i) */
i__2 = i - 1;
i__3 = i;
z__1.r = -TAU(i).r, z__1.i = -TAU(i).i;
zscal_(&i__2, &z__1, &T(1,i), &c__1);
i__2 = i - 1;
ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &T(1,1), ldt,
&T(1,i), &c__1);
i__2 = i + i * t_dim1;
i__3 = i;
T(i,i).r = TAU(i).r, T(i,i).i = TAU(i).i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
A(*k+*nb,*nb).r = ei.r, A(*k+*nb,*nb).i = ei.i;
return 0;
/* End of ZLAHRD */
} /* zlahrd_ */
/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap,
doublereal *d__, doublereal *e, doublecomplex *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
September 30, 1994
Purpose
=======
ZHPTRD reduces a complex Hermitian matrix A stored in packed form 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.
AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, 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.
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) COMPLEX*16 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 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 AP,
overwriting A(1:i-1,i+1), and tau is stored 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 AP,
overwriting A(i+2:n,i), and tau is stored in TAU(i).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b2 = {0.,0.};
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
static doublecomplex taui;
extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *);
static integer i__;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer i1;
static logical upper;
extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static integer i1i1;
--tau;
--e;
--d__;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A.
I1 is the index in AP of A(1,I+1). */
i1 = *n * (*n - 1) / 2 + 1;
i__1 = i1 + *n - 1;
i__2 = i1 + *n - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(1:i-1,i+1) */
i__1 = i1 + i__ - 1;
alpha.r = ap[i__1].r, alpha.i = ap[i__1].i;
zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0. || taui.i != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i1 + i__ - 1;
ap[i__1].r = 1., ap[i__1].i = 0.;
/* Compute y := tau * A * v storing y in TAU(1:i) */
zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[
1], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
taui.i + z__3.i * taui.r;
zdotc_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
z__1.r = -1., z__1.i = 0.;
zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[
1]);
}
i__1 = i1 + i__ - 1;
i__2 = i__;
ap[i__1].r = e[i__2], ap[i__1].i = 0.;
i__1 = i__ + 1;
i__2 = i1 + i__;
d__[i__1] = ap[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r, tau[i__1].i = taui.i;
i1 -= i__;
/* L10: */
}
d__[1] = ap[1].r;
} else {
/* Reduce the lower triangle of A. II is the index in AP of
A(i,i) and I1I1 is the index of A(i+1,i+1). */
ii = 1;
d__1 = ap[1].r;
ap[1].r = d__1, ap[1].i = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i1i1 = ii + *n - i__ + 1;
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(i+2:n,i) */
i__2 = ii + 1;
alpha.r = ap[i__2].r, alpha.i = ap[i__2].i;
i__2 = *n - i__;
zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0. || taui.i != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = ii + 1;
ap[i__2].r = 1., ap[i__2].i = 0.;
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
c_b2, &tau[i__], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
taui.i + z__3.i * taui.r;
i__2 = *n - i__;
zdotc_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], &
c__1, &ap[i1i1]);
}
i__2 = ii + 1;
i__3 = i__;
ap[i__2].r = e[i__3], ap[i__2].i = 0.;
i__2 = i__;
i__3 = ii;
d__[i__2] = ap[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r, tau[i__2].i = taui.i;
ii = i1i1;
/* L20: */
}
i__1 = *n;
i__2 = ii;
d__[i__1] = ap[i__2].r;
}
return 0;
/* End of ZHPTRD */
} /* zhptrd_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j, ma, mn;
static doublecomplex aii;
static integer pvt;
static doublereal temp, temp2;
static integer itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
/* -- LAPACK auxiliary 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 */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZGEQP3. */
/* ZGEQPF computes a QR factorization with column pivoting of a */
/* complex M-by-N matrix A: A*P = Q*R. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0 */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of the array contains the */
/* min(M,N)-by-N upper triangular matrix R; the elements */
/* below the diagonal, together with the array TAU, */
/* represent the unitary matrix Q as a product of */
/* min(m,n) elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(i) = 0, */
/* the i-th column of A is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* RWORK (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 */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(n) */
/* Each H(i) has the form */
/* H = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
/* The matrix P is represented in jpvt as follows: If */
/* jpvt(j) = i */
/* then the jth column of P is the ith canonical unit vector. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--work;
--rwork;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQPF", &i__1, (ftnlen)6);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (jpvt[i__] != 0) {
if (i__ != itemp) {
zswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
&c__1);
jpvt[i__] = jpvt[itemp];
jpvt[itemp] = i__;
} else {
jpvt[i__] = i__;
}
++itemp;
} else {
jpvt[i__] = i__;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
zgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
, lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1],
info, (ftnlen)4, (ftnlen)19);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of */
/* work store the exact column norms. */
i__1 = *n;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
i__2 = *m - itemp;
rwork[i__] = dznrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
rwork[*n + i__] = rwork[i__];
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + idamax_(&i__2, &rwork[i__], &c__1);
if (pvt != i__) {
zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
rwork[pvt] = rwork[i__];
rwork[*n + pvt] = rwork[*n + i__];
}
/* Generate elementary reflector H(i) */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &aii, &a[min(i__3,*m) + i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (rwork[j] != 0.) {
/* Computing 2nd power */
d__1 = z_abs(&a[i__ + j * a_dim1]) / rwork[j];
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = rwork[j] / rwork[*n + j];
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i__ > 0) {
i__3 = *m - i__;
rwork[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
, &c__1);
rwork[*n + j] = rwork[j];
} else {
rwork[j] = 0.;
rwork[*n + j] = 0.;
}
} else {
rwork[j] *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
/* Subroutine */ int zlatrz_(integer *m, integer *n, integer *l,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern /* Subroutine */ int zlarz_(char *, integer *, integer *, integer *
, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), zlarfg_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *),
zlacgv_(integer *, doublecomplex *, integer *);
/* -- 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 */
/* ======= */
/* ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix */
/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means */
/* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary */
/* matrix and, R and A1 are M-by-M upper triangular matrices. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* L (input) INTEGER */
/* The number of columns of the matrix A containing the */
/* meaningful part of the Householder vectors. N-M >= L >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the leading M-by-N upper trapezoidal part of the */
/* array A must contain the matrix to be factorized. */
/* On exit, the leading M-by-M upper triangular part of A */
/* contains the upper triangular matrix R, and elements N-L+1 to */
/* N of the first M rows of A, with the array TAU, represent the */
/* unitary matrix Z as a product of M elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) COMPLEX*16 array, dimension (M) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), which is used to introduce zeros into */
/* the ( m - k + 1 )th row of A, is given in the form */
/* Z( k ) = ( I 0 ), */
/* ( 0 T( k ) ) */
/* where */
/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
/* ( 0 ) */
/* ( z( k ) ) */
/* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */
/* are chosen to annihilate the elements of the kth row of A2. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A2, such that the elements of z( k ) are */
/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A1. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
if (*m == 0) {
return 0;
} else if (*m == *n) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L10: */
}
return 0;
}
for (i__ = *m; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* [ A(i,i) A(i,n-l+1:n) ] */
zlacgv_(l, &a[i__ + (*n - *l + 1) * a_dim1], lda);
d_cnjg(&z__1, &a[i__ + i__ * a_dim1]);
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *l + 1;
zlarfg_(&i__1, &alpha, &a[i__ + (*n - *l + 1) * a_dim1], lda, &tau[
i__]);
i__1 = i__;
d_cnjg(&z__1, &tau[i__]);
tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
/* Apply H(i) to A(1:i-1,i:n) from the right */
i__1 = i__ - 1;
i__2 = *n - i__ + 1;
d_cnjg(&z__1, &tau[i__]);
zlarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1],
lda, &z__1, &a[i__ * a_dim1 + 1], lda, &work[1], (ftnlen)5);
i__1 = i__ + i__ * a_dim1;
d_cnjg(&z__1, &alpha);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L20: */
}
return 0;
/* End of ZLATRZ */
} /* zlatrz_ */
/* Subroutine */ int zlabrd_(integer *m, integer *n, integer *nb,
doublecomplex *a, integer *lda, doublereal *d, doublereal *e,
doublecomplex *tauq, doublecomplex *taup, doublecomplex *x, integer *
ldx, doublecomplex *y, integer *ldy)
{
/* -- LAPACK auxiliary 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
=======
ZLABRD reduces the first NB rows and columns of a complex general
m by n matrix A to upper or lower real bidiagonal form by a unitary
transformation Q' * A * P, and returns the matrices X and Y which
are needed to apply the transformation to the unreduced part of A.
If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
bidiagonal form.
This is an auxiliary routine called by ZGEBRD
Arguments
=========
M (input) INTEGER
The number of rows in the matrix A.
N (input) INTEGER
The number of columns in the matrix A.
NB (input) INTEGER
The number of leading rows and columns of A to be reduced.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the m by n general matrix to be reduced.
On exit, the first NB rows and columns of the matrix are
overwritten; the rest of the array is unchanged.
If m >= n, elements on and below the diagonal in the first NB
columns, with the array TAUQ, represent the unitary
matrix Q as a product of elementary reflectors; and
elements above the diagonal in the first NB rows, with the
array TAUP, represent the unitary matrix P as a product
of elementary reflectors.
If m < n, elements below the diagonal in the first NB
columns, with the array TAUQ, represent the unitary
matrix Q as a product of elementary reflectors, and
elements on and above the diagonal in the first NB rows,
with the array TAUP, represent the unitary matrix P as
a product of elementary reflectors.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
D (output) DOUBLE PRECISION array, dimension (NB)
The diagonal elements of the first NB rows and columns of
the reduced matrix. D(i) = A(i,i).
E (output) DOUBLE PRECISION array, dimension (NB)
The off-diagonal elements of the first NB rows and columns of
the reduced matrix.
TAUQ (output) COMPLEX*16 array dimension (NB)
The scalar factors of the elementary reflectors which
represent the unitary matrix Q. See Further Details.
TAUP (output) COMPLEX*16 array, dimension (NB)
The scalar factors of the elementary reflectors which
represent the unitary matrix P. See Further Details.
X (output) COMPLEX*16 array, dimension (LDX,NB)
The m-by-nb matrix X required to update the unreduced part
of A.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,M).
Y (output) COMPLEX*16 array, dimension (LDY,NB)
The n-by-nb matrix Y required to update the unreduced part
of A.
LDY (output) INTEGER
The leading dimension of the array Y. LDY >= max(1,N).
Further Details
===============
The matrices Q and P are represented as products of elementary
reflectors:
Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
Each H(i) and G(i) has the form:
H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
where tauq and taup are complex scalars, and v and u are complex
vectors.
If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
The elements of the vectors v and u together form the m-by-nb matrix
V and the nb-by-n matrix U' which are needed, with X and Y, to apply
the transformation to the unreduced part of the matrix, using a block
update of the form: A := A - V*Y' - X*U'.
The contents of A on exit are illustrated by the following examples
with nb = 2:
m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
( v1 v2 a a a ) ( v1 1 a a a a )
( v1 v2 a a a ) ( v1 v2 a a a a )
( v1 v2 a a a ) ( v1 v2 a a a a )
( v1 v2 a a a )
where a denotes an element of the original matrix which is unchanged,
vi denotes an element of the vector defining H(i), and ui an element
of the vector defining G(i).
=====================================================================
Quick return if possible
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
static integer i;
static doublecomplex alpha;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define TAUQ(I) tauq[(I)-1]
#define TAUP(I) taup[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
#define Y(I,J) y[(I)-1 + ((J)-1)* ( *ldy)]
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i = 1; i <= *nb; ++i) {
/* Update A(i:m,i) */
i__2 = i - 1;
zlacgv_(&i__2, &Y(i,1), ldy);
i__2 = *m - i + 1;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &A(i,1), lda, &
Y(i,1), ldy, &c_b2, &A(i,i), &c__1)
;
i__2 = i - 1;
zlacgv_(&i__2, &Y(i,1), ldy);
i__2 = *m - i + 1;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &X(i,1), ldx, &
A(1,i), &c__1, &c_b2, &A(i,i), &
c__1);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
i__2 = i + i * a_dim1;
alpha.r = A(i,i).r, alpha.i = A(i,i).i;
i__2 = *m - i + 1;
/* Computing MIN */
i__3 = i + 1;
zlarfg_(&i__2, &alpha, &A(min(i+1,*m),i), &c__1, &
TAUQ(i));
i__2 = i;
D(i) = alpha.r;
if (i < *n) {
i__2 = i + i * a_dim1;
A(i,i).r = 1., A(i,i).i = 0.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i + 1;
i__3 = *n - i;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &A(i,i+1), lda, &A(i,i), &c__1, &c_b1,
&Y(i+1,i), &c__1);
i__2 = *m - i + 1;
i__3 = i - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &A(i,1), lda, &A(i,i), &c__1, &c_b1, &Y(1,i), &c__1);
i__2 = *n - i;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &Y(i+1,1)
, ldy, &Y(1,i), &c__1, &c_b2, &Y(i+1,i), &c__1);
i__2 = *m - i + 1;
i__3 = i - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &X(i,1), ldx, &A(i,i), &c__1, &c_b1, &Y(1,i), &c__1);
i__2 = i - 1;
i__3 = *n - i;
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &A(1,i+1), lda, &Y(1,i), &c__1, &c_b2,
&Y(i+1,i), &c__1);
i__2 = *n - i;
zscal_(&i__2, &TAUQ(i), &Y(i+1,i), &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i;
zlacgv_(&i__2, &A(i,i+1), lda);
zlacgv_(&i, &A(i,1), lda);
i__2 = *n - i;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i, &z__1, &Y(i+1,1),
ldy, &A(i,1), lda, &c_b2, &A(i,i+1), lda);
zlacgv_(&i, &A(i,1), lda);
i__2 = i - 1;
zlacgv_(&i__2, &X(i,1), ldx);
i__2 = i - 1;
i__3 = *n - i;
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &A(1,i+1), lda, &X(i,1), ldx, &c_b2, &A(i,i+1), lda);
i__2 = i - 1;
zlacgv_(&i__2, &X(i,1), ldx);
/* Generate reflection P(i) to annihilate A(i,i+2
:n) */
i__2 = i + (i + 1) * a_dim1;
alpha.r = A(i,i+1).r, alpha.i = A(i,i+1).i;
i__2 = *n - i;
/* Computing MIN */
i__3 = i + 2;
zlarfg_(&i__2, &alpha, &A(i,min(i+2,*n)), lda, &
TAUP(i));
i__2 = i;
E(i) = alpha.r;
i__2 = i + (i + 1) * a_dim1;
A(i,i+1).r = 1., A(i,i+1).i = 0.;
/* Compute X(i+1:m,i) */
i__2 = *m - i;
i__3 = *n - i;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &A(i+1,i+1), lda, &A(i,i+1), lda, &c_b1,
&X(i+1,i), &c__1);
i__2 = *n - i;
zgemv_("Conjugate transpose", &i__2, &i, &c_b2, &Y(i+1,1), ldy, &A(i,i+1), lda, &c_b1, &
X(1,i), &c__1);
i__2 = *m - i;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i, &z__1, &A(i+1,1),
lda, &X(1,i), &c__1, &c_b2, &X(i+1,i), &c__1);
i__2 = i - 1;
i__3 = *n - i;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &A(1,i+1), lda, &A(i,i+1), lda, &
c_b1, &X(1,i), &c__1);
i__2 = *m - i;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &X(i+1,1)
, ldx, &X(1,i), &c__1, &c_b2, &X(i+1,i), &c__1);
i__2 = *m - i;
zscal_(&i__2, &TAUP(i), &X(i+1,i), &c__1);
i__2 = *n - i;
zlacgv_(&i__2, &A(i,i+1), lda);
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *nb;
for (i = 1; i <= *nb; ++i) {
/* Update A(i,i:n) */
i__2 = *n - i + 1;
zlacgv_(&i__2, &A(i,i), lda);
i__2 = i - 1;
zlacgv_(&i__2, &A(i,1), lda);
i__2 = *n - i + 1;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &Y(i,1), ldy, &
A(i,1), lda, &c_b2, &A(i,i), lda);
i__2 = i - 1;
zlacgv_(&i__2, &A(i,1), lda);
i__2 = i - 1;
zlacgv_(&i__2, &X(i,1), ldx);
i__2 = i - 1;
i__3 = *n - i + 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &A(1,i), lda, &X(i,1), ldx, &c_b2, &A(i,i),
lda);
i__2 = i - 1;
zlacgv_(&i__2, &X(i,1), ldx);
/* Generate reflection P(i) to annihilate A(i,i+1:n) */
i__2 = i + i * a_dim1;
alpha.r = A(i,i).r, alpha.i = A(i,i).i;
i__2 = *n - i + 1;
/* Computing MIN */
i__3 = i + 1;
zlarfg_(&i__2, &alpha, &A(i,min(i+1,*n)), lda, &TAUP(
i));
i__2 = i;
D(i) = alpha.r;
if (i < *m) {
i__2 = i + i * a_dim1;
A(i,i).r = 1., A(i,i).i = 0.;
/* Compute X(i+1:m,i) */
i__2 = *m - i;
i__3 = *n - i + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &A(i+1,i), lda, &A(i,i), lda, &c_b1, &X(i+1,i), &c__1);
i__2 = *n - i + 1;
i__3 = i - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &Y(i,1), ldy, &A(i,i), lda, &c_b1, &X(1,i), &c__1);
i__2 = *m - i;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &A(i+1,1)
, lda, &X(1,i), &c__1, &c_b2, &X(i+1,i), &c__1);
i__2 = i - 1;
i__3 = *n - i + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &A(1,i)
, lda, &A(i,i), lda, &c_b1, &X(1,i), &c__1);
i__2 = *m - i;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &X(i+1,1)
, ldx, &X(1,i), &c__1, &c_b2, &X(i+1,i), &c__1);
i__2 = *m - i;
zscal_(&i__2, &TAUP(i), &X(i+1,i), &c__1);
i__2 = *n - i + 1;
zlacgv_(&i__2, &A(i,i), lda);
/* Update A(i+1:m,i) */
i__2 = i - 1;
zlacgv_(&i__2, &Y(i,1), ldy);
i__2 = *m - i;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &A(i+1,1)
, lda, &Y(i,1), ldy, &c_b2, &A(i+1,i), &c__1);
i__2 = i - 1;
zlacgv_(&i__2, &Y(i,1), ldy);
i__2 = *m - i;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i, &z__1, &X(i+1,1),
ldx, &A(1,i), &c__1, &c_b2, &A(i+1,i), &c__1);
/* Generate reflection Q(i) to annihilate A(i+2:m
,i) */
i__2 = i + 1 + i * a_dim1;
alpha.r = A(i+1,i).r, alpha.i = A(i+1,i).i;
i__2 = *m - i;
/* Computing MIN */
i__3 = i + 2;
zlarfg_(&i__2, &alpha, &A(min(i+2,*m),i), &c__1, &
TAUQ(i));
i__2 = i;
E(i) = alpha.r;
i__2 = i + 1 + i * a_dim1;
A(i+1,i).r = 1., A(i+1,i).i = 0.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i;
i__3 = *n - i;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &A(i+1,i+1), lda, &A(i+1,i), &c__1,
&c_b1, &Y(i+1,i), &c__1);
i__2 = *m - i;
i__3 = i - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &A(i+1,1), lda, &A(i+1,i), &c__1, &c_b1, &
Y(1,i), &c__1);
i__2 = *n - i;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &Y(i+1,1)
, ldy, &Y(1,i), &c__1, &c_b2, &Y(i+1,i), &c__1);
i__2 = *m - i;
zgemv_("Conjugate transpose", &i__2, &i, &c_b2, &X(i+1,1), ldx, &A(i+1,i), &c__1, &c_b1, &
Y(1,i), &c__1);
i__2 = *n - i;
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &i, &i__2, &z__1, &A(1,i+1), lda, &Y(1,i), &c__1, &c_b2, &
Y(i+1,i), &c__1);
i__2 = *n - i;
zscal_(&i__2, &TAUQ(i), &Y(i+1,i), &c__1);
} else {
i__2 = *n - i + 1;
zlacgv_(&i__2, &A(i,i), lda);
}
/* L20: */
}
}
return 0;
/* End of ZLABRD */
} /* zlabrd_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZGEQPF computes a QR factorization with column pivoting of a
complex M-by-N matrix A: A*P = Q*R.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the upper triangle of the array contains the
min(M,N)-by-N upper triangular matrix R; the elements
below the diagonal, together with the array TAU,
represent the orthogonal matrix Q as a product of
min(m,n) elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
to the front of A*P (a leading column); if JPVT(i) = 0,
the i-th column of A is a free column.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
TAU (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors.
WORK (workspace) COMPLEX*16 array, dimension (N)
RWORK (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
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(n)
Each H(i) has the form
H = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
The matrix P is represented in jpvt as follows: If
jpvt(j) = i
then the jth column of P is the ith canonical unit vector.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static doublereal temp, temp2;
static integer i, j, itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer ma, mn;
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static doublecomplex aii;
static integer pvt;
#define JPVT(I) jpvt[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (JPVT(i) != 0) {
if (i != itemp) {
zswap_(m, &A(1,i), &c__1, &A(1,itemp), &
c__1);
JPVT(i) = JPVT(itemp);
JPVT(itemp) = i;
} else {
JPVT(i) = i;
}
++itemp;
} else {
JPVT(i) = i;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
zgeqr2_(m, &ma, &A(1,1), lda, &TAU(1), &WORK(1), info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &A(1,1)
, lda, &TAU(1), &A(1,ma+1), lda, &WORK(1),
info);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of
work store the exact column norms. */
i__1 = *n;
for (i = itemp + 1; i <= *n; ++i) {
i__2 = *m - itemp;
RWORK(i) = dznrm2_(&i__2, &A(itemp+1,i), &c__1);
RWORK(*n + i) = RWORK(i);
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i = itemp + 1; i <= mn; ++i) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i + 1;
pvt = i - 1 + idamax_(&i__2, &RWORK(i), &c__1);
if (pvt != i) {
zswap_(m, &A(1,pvt), &c__1, &A(1,i), &
c__1);
itemp = JPVT(pvt);
JPVT(pvt) = JPVT(i);
JPVT(i) = itemp;
RWORK(pvt) = RWORK(i);
RWORK(*n + pvt) = RWORK(*n + i);
}
/* Generate elementary reflector H(i) */
i__2 = i + i * a_dim1;
aii.r = A(i,i).r, aii.i = A(i,i).i;
i__2 = *m - i + 1;
/* Computing MIN */
i__3 = i + 1;
zlarfg_(&i__2, &aii, &A(min(i+1,*m),i), &c__1, &TAU(i)
);
i__2 = i + i * a_dim1;
A(i,i).r = aii.r, A(i,i).i = aii.i;
if (i < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i + i * a_dim1;
aii.r = A(i,i).r, aii.i = A(i,i).i;
i__2 = i + i * a_dim1;
A(i,i).r = 1., A(i,i).i = 0.;
i__2 = *m - i + 1;
i__3 = *n - i;
d_cnjg(&z__1, &TAU(i));
zlarf_("Left", &i__2, &i__3, &A(i,i), &c__1, &z__1,
&A(i,i+1), lda, &WORK(1));
i__2 = i + i * a_dim1;
A(i,i).r = aii.r, A(i,i).i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i + 1; j <= *n; ++j) {
if (RWORK(j) != 0.) {
/* Computing 2nd power */
d__1 = z_abs(&A(i,j)) / RWORK(j);
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = RWORK(j) / RWORK(*n + j);
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i > 0) {
i__3 = *m - i;
RWORK(j) = dznrm2_(&i__3, &A(i+1,j),
&c__1);
RWORK(*n + j) = RWORK(j);
} else {
RWORK(j) = 0.;
RWORK(*n + j) = 0.;
}
} else {
RWORK(j) *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
/* Subroutine */ int zlaqr3_(logical *wantt, logical *wantz, integer *n,
integer *ktop, integer *kbot, integer *nw, doublecomplex *h__,
integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__,
integer *ldz, integer *ns, integer *nd, doublecomplex *sh,
doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t,
integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv,
doublecomplex *work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublecomplex s;
integer jw;
doublereal foo;
integer kln;
doublecomplex tau;
integer knt;
doublereal ulp;
integer lwk1, lwk2, lwk3;
doublecomplex beta;
integer kcol, info, nmin, ifst, ilst, ltop, krow;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
integer infqr;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer kwtop;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *),
zlaqr4_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
);
extern doublereal dlamch_(char *);
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
doublereal safmax;
extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *,
logical *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *,
integer *, integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
doublereal smlnum;
extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *);
integer lwkopt;
extern /* Subroutine */ int zunmhr_(char *, char *, integer *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
);
/* -- LAPACK auxiliary routine (version 3.2.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* -- April 2009 -- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ****************************************************************** */
/* Aggressive early deflation: */
/* This subroutine accepts as input an upper Hessenberg matrix */
/* H and performs an unitary similarity transformation */
/* designed to detect and deflate fully converged eigenvalues from */
/* a trailing principal submatrix. On output H has been over- */
/* written by a new Hessenberg matrix that is a perturbation of */
/* an unitary similarity transformation of H. It is to be */
/* hoped that the final version of H has many zero subdiagonal */
/* entries. */
/* ****************************************************************** */
/* WANTT (input) LOGICAL */
/* If .TRUE., then the Hessenberg matrix H is fully updated */
/* so that the triangular Schur factor may be */
/* computed (in cooperation with the calling subroutine). */
/* If .FALSE., then only enough of H is updated to preserve */
/* the eigenvalues. */
/* WANTZ (input) LOGICAL */
/* If .TRUE., then the unitary matrix Z is updated so */
/* so that the unitary Schur factor may be computed */
/* (in cooperation with the calling subroutine). */
/* If .FALSE., then Z is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix H and (if WANTZ is .TRUE.) the */
/* order of the unitary matrix Z. */
/* KTOP (input) INTEGER */
/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
/* KBOT and KTOP together determine an isolated block */
/* along the diagonal of the Hessenberg matrix. */
/* KBOT (input) INTEGER */
/* It is assumed without a check that either */
/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
/* determine an isolated block along the diagonal of the */
/* Hessenberg matrix. */
/* NW (input) INTEGER */
/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
/* On input the initial N-by-N section of H stores the */
/* Hessenberg matrix undergoing aggressive early deflation. */
/* On output H has been transformed by a unitary */
/* similarity transformation, perturbed, and the returned */
/* to Hessenberg form that (it is to be hoped) has some */
/* zero subdiagonal entries. */
/* LDH (input) integer */
/* Leading dimension of H just as declared in the calling */
/* subroutine. N .LE. LDH */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* IF WANTZ is .TRUE., then on output, the unitary */
/* similarity transformation mentioned above has been */
/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ is .FALSE., then Z is unreferenced. */
/* LDZ (input) integer */
/* The leading dimension of Z just as declared in the */
/* calling subroutine. 1 .LE. LDZ. */
/* NS (output) integer */
/* The number of unconverged (ie approximate) eigenvalues */
/* returned in SR and SI that may be used as shifts by the */
/* calling subroutine. */
/* ND (output) integer */
/* The number of converged eigenvalues uncovered by this */
/* subroutine. */
/* SH (output) COMPLEX*16 array, dimension KBOT */
/* On output, approximate eigenvalues that may */
/* be used for shifts are stored in SH(KBOT-ND-NS+1) */
/* through SR(KBOT-ND). Converged eigenvalues are */
/* stored in SH(KBOT-ND+1) through SH(KBOT). */
/* V (workspace) COMPLEX*16 array, dimension (LDV,NW) */
/* An NW-by-NW work array. */
/* LDV (input) integer scalar */
/* The leading dimension of V just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* NH (input) integer scalar */
/* The number of columns of T. NH.GE.NW. */
/* T (workspace) COMPLEX*16 array, dimension (LDT,NW) */
/* LDT (input) integer */
/* The leading dimension of T just as declared in the */
/* calling subroutine. NW .LE. LDT */
/* NV (input) integer */
/* The number of rows of work array WV available for */
/* workspace. NV.GE.NW. */
/* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) */
/* LDWV (input) integer */
/* The leading dimension of W just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* WORK (workspace) COMPLEX*16 array, dimension LWORK. */
/* On exit, WORK(1) is set to an estimate of the optimal value */
/* of LWORK for the given values of N, NW, KTOP and KBOT. */
/* LWORK (input) integer */
/* The dimension of the work array WORK. LWORK = 2*NW */
/* suffices, but greater efficiency may result from larger */
/* values of LWORK. */
/* If LWORK = -1, then a workspace query is assumed; ZLAQR3 */
/* only estimates the optimal workspace size for the given */
/* values of N, NW, KTOP and KBOT. The estimate is returned */
/* in WORK(1). No error message related to LWORK is issued */
/* by XERBLA. Neither H nor Z are accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sh;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
/* ==== Workspace query call to ZGEHRD ==== */
i__1 = jw - 1;
zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
c_n1, &info);
lwk1 = (integer) work[1].r;
/* ==== Workspace query call to ZUNMHR ==== */
i__1 = jw - 1;
zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1].r;
/* ==== Workspace query call to ZLAQR4 ==== */
zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[1],
&c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, &infqr);
lwk3 = (integer) work[1].r;
/* ==== Optimal workspace ==== */
/* Computing MAX */
i__1 = jw + max(lwk1,lwk2);
lwkopt = max(i__1,lwk3);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
d__1 = (doublereal) lwkopt;
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1].r = 1., work[1].i = 0.;
if (*ktop > *kbot) {
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1) {
return 0;
}
/* ==== Machine constants ==== */
safmin = dlamch_("SAFE MINIMUM");
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_("PRECISION");
smlnum = safmin * ((doublereal) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s.r = 0., s.i = 0.;
} else {
i__1 = kwtop + (kwtop - 1) * h_dim1;
s.r = h__[i__1].r, s.i = h__[i__1].i;
}
if (*kbot == kwtop) {
/* ==== 1-by-1 deflation window: not much to do ==== */
i__1 = kwtop;
i__2 = kwtop + kwtop * h_dim1;
sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i;
*ns = 1;
*nd = 0;
/* Computing MAX */
i__1 = kwtop + kwtop * h_dim1;
d__5 = smlnum, d__6 = ulp * ((d__1 = h__[i__1].r, abs(d__1)) + (d__2 =
d_imag(&h__[kwtop + kwtop * h_dim1]), abs(d__2)));
if ((d__3 = s.r, abs(d__3)) + (d__4 = d_imag(&s), abs(d__4)) <= max(
d__5,d__6)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
i__1 = kwtop + (kwtop - 1) * h_dim1;
h__[i__1].r = 0., h__[i__1].i = 0.;
}
}
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
zlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
i__3);
zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
nmin = ilaenv_(&c__12, "ZLAQR3", "SV", &jw, &c__1, &jw, lwork);
if (jw > nmin) {
zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[
kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], lwork, &
infqr);
} else {
zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[
kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
}
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
i__1 = jw;
for (knt = infqr + 1; knt <= i__1; ++knt) {
/* ==== Small spike tip deflation test ==== */
i__2 = *ns + *ns * t_dim1;
foo = (d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns *
t_dim1]), abs(d__2));
if (foo == 0.) {
foo = (d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2));
}
i__2 = *ns * v_dim1 + 1;
/* Computing MAX */
d__5 = smlnum, d__6 = ulp * foo;
if (((d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2))) * ((
d__3 = v[i__2].r, abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1
+ 1]), abs(d__4))) <= max(d__5,d__6)) {
/* ==== One more converged eigenvalue ==== */
--(*ns);
} else {
/* ==== One undeflatable eigenvalue. Move it up out of the */
/* . way. (ZTREXC can not fail in this case.) ==== */
ifst = *ns;
ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &
ilst, &info);
++ilst;
}
/* L10: */
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0) {
s.r = 0., s.i = 0.;
}
if (*ns < jw) {
/* ==== sorting the diagonal of T improves accuracy for */
/* . graded matrices. ==== */
i__1 = *ns;
for (i__ = infqr + 1; i__ <= i__1; ++i__) {
ifst = i__;
i__2 = *ns;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + j * t_dim1;
i__4 = ifst + ifst * t_dim1;
if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[j + j *
t_dim1]), abs(d__2)) > (d__3 = t[i__4].r, abs(d__3))
+ (d__4 = d_imag(&t[ifst + ifst * t_dim1]), abs(d__4))
) {
ifst = j;
}
/* L20: */
}
ilst = i__;
if (ifst != ilst) {
ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &info);
}
/* L30: */
}
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__1 = jw;
for (i__ = infqr + 1; i__ <= i__1; ++i__) {
i__2 = kwtop + i__ - 1;
i__3 = i__ + i__ * t_dim1;
sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i;
/* L40: */
}
if (*ns < jw || s.r == 0. && s.i == 0.) {
if (*ns > 1 && (s.r != 0. || s.i != 0.)) {
/* ==== Reflect spike back into lower triangle ==== */
zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
i__1 = *ns;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d_cnjg(&z__1, &work[i__]);
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L50: */
}
beta.r = work[1].r, beta.i = work[1].i;
zlarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1].r = 1., work[1].i = 0.;
i__1 = jw - 2;
i__2 = jw - 2;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
d_cnjg(&z__1, &tau);
zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, &
work[jw + 1]);
zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
work[jw + 1]);
i__1 = *lwork - jw;
zgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
, &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1) {
i__1 = kwtop + (kwtop - 1) * h_dim1;
d_cnjg(&z__2, &v[v_dim1 + 1]);
z__1.r = s.r * z__2.r - s.i * z__2.i, z__1.i = s.r * z__2.i + s.i
* z__2.r;
h__[i__1].r = z__1.r, h__[i__1].i = z__1.i;
}
zlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
, ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
zcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
&i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && (s.r != 0. || s.i != 0.)) {
i__1 = *lwork - jw;
zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3,i__4);
zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop *
h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset],
ldwv);
zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
h_dim1], ldh);
/* L60: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1) {
/* Computing MIN */
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3,i__4);
zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, &
h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset],
ldt);
zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
h_dim1], ldh);
/* L70: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3,i__4);
zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop *
z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset]
, ldwv);
zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
kwtop * z_dim1], ldz);
/* L80: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting */
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
d__1 = (doublereal) lwkopt;
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
/* ==== End of ZLAQR3 ==== */
return 0;
} /* zlaqr3_ */
/* Subroutine */ int zlaqr5_(logical *wantt, logical *wantz, integer *kacc22,
integer *n, integer *ktop, integer *kbot, integer *nshfts,
doublecomplex *s, doublecomplex *h__, integer *ldh, integer *iloz,
integer *ihiz, doublecomplex *z__, integer *ldz, doublecomplex *v,
integer *ldv, doublecomplex *u, integer *ldu, integer *nv,
doublecomplex *wv, integer *ldwv, integer *nh, doublecomplex *wh,
integer *ldwh)
{
/* System generated locals */
integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1,
wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
/* Local variables */
integer j, k, m, i2, j2, i4, j4, k1;
doublereal h11, h12, h21, h22;
integer m22, ns, nu;
doublecomplex vt[3];
doublereal scl;
integer kdu, kms;
doublereal ulp;
integer knz, kzs;
doublereal tst1, tst2;
doublecomplex beta;
logical blk22, bmp22;
integer mend, jcol, jlen, jbot, mbot, jtop, jrow, mtop;
doublecomplex alpha;
logical accum;
integer ndcol, incol, krcol, nbmps;
doublereal safmin, safmax;
doublecomplex refsum;
integer mstart;
doublereal smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* This auxiliary subroutine called by ZLAQR0 performs a */
/* single small-bulge multi-shift QR sweep. */
/* WANTT (input) logical scalar */
/* WANTT = .true. if the triangular Schur factor */
/* is being computed. WANTT is set to .false. otherwise. */
/* WANTZ (input) logical scalar */
/* WANTZ = .true. if the unitary Schur factor is being */
/* computed. WANTZ is set to .false. otherwise. */
/* KACC22 (input) integer with value 0, 1, or 2. */
/* Specifies the computation mode of far-from-diagonal */
/* orthogonal updates. */
/* = 0: ZLAQR5 does not accumulate reflections and does not */
/* use matrix-matrix multiply to update far-from-diagonal */
/* matrix entries. */
/* = 1: ZLAQR5 accumulates reflections and uses matrix-matrix */
/* multiply to update the far-from-diagonal matrix entries. */
/* = 2: ZLAQR5 accumulates reflections, uses matrix-matrix */
/* multiply to update the far-from-diagonal matrix entries, */
/* and takes advantage of 2-by-2 block structure during */
/* matrix multiplies. */
/* N (input) integer scalar */
/* N is the order of the Hessenberg matrix H upon which this */
/* subroutine operates. */
/* KTOP (input) integer scalar */
/* KBOT (input) integer scalar */
/* These are the first and last rows and columns of an */
/* isolated diagonal block upon which the QR sweep is to be */
/* applied. It is assumed without a check that */
/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */
/* and */
/* either KBOT = N or H(KBOT+1,KBOT) = 0. */
/* NSHFTS (input) integer scalar */
/* NSHFTS gives the number of simultaneous shifts. NSHFTS */
/* must be positive and even. */
/* S (input/output) COMPLEX*16 array of size (NSHFTS) */
/* S contains the shifts of origin that define the multi- */
/* shift QR sweep. On output S may be reordered. */
/* H (input/output) COMPLEX*16 array of size (LDH,N) */
/* On input H contains a Hessenberg matrix. On output a */
/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */
/* to the isolated diagonal block in rows and columns KTOP */
/* through KBOT. */
/* LDH (input) integer scalar */
/* LDH is the leading dimension of H just as declared in the */
/* calling procedure. LDH.GE.MAX(1,N). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* Z (input/output) COMPLEX*16 array of size (LDZ,IHI) */
/* If WANTZ = .TRUE., then the QR Sweep unitary */
/* similarity transformation is accumulated into */
/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ = .FALSE., then Z is unreferenced. */
/* LDZ (input) integer scalar */
/* LDA is the leading dimension of Z just as declared in */
/* the calling procedure. LDZ.GE.N. */
/* V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2) */
/* LDV (input) integer scalar */
/* LDV is the leading dimension of V as declared in the */
/* calling procedure. LDV.GE.3. */
/* U (workspace) COMPLEX*16 array of size */
/* (LDU,3*NSHFTS-3) */
/* LDU (input) integer scalar */
/* LDU is the leading dimension of U just as declared in the */
/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */
/* NH (input) integer scalar */
/* NH is the number of columns in array WH available for */
/* workspace. NH.GE.1. */
/* WH (workspace) COMPLEX*16 array of size (LDWH,NH) */
/* LDWH (input) integer scalar */
/* Leading dimension of WH just as declared in the */
/* calling procedure. LDWH.GE.3*NSHFTS-3. */
/* NV (input) integer scalar */
/* NV is the number of rows in WV agailable for workspace. */
/* NV.GE.1. */
/* WV (workspace) COMPLEX*16 array of size */
/* (LDWV,3*NSHFTS-3) */
/* LDWV (input) integer scalar */
/* LDWV is the leading dimension of WV as declared in the */
/* in the calling subroutine. LDWV.GE.NV. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* Reference: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and */
/* Level 3 Performance, SIAM Journal of Matrix Analysis, */
/* volume 23, pages 929--947, 2002. */
/* ================================================================ */
/* ==== If there are no shifts, then there is nothing to do. ==== */
/* Parameter adjustments */
--s;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
wh_dim1 = *ldwh;
wh_offset = 1 + wh_dim1;
wh -= wh_offset;
/* Function Body */
if (*nshfts < 2) {
return 0;
}
/* ==== If the active block is empty or 1-by-1, then there */
/* . is nothing to do. ==== */
if (*ktop >= *kbot) {
return 0;
}
/* ==== NSHFTS is supposed to be even, but if it is odd, */
/* . then simply reduce it by one. ==== */
ns = *nshfts - *nshfts % 2;
/* ==== Machine constants for deflation ==== */
safmin = dlamch_("SAFE MINIMUM");
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_("PRECISION");
smlnum = safmin * ((doublereal) (*n) / ulp);
/* ==== Use accumulated reflections to update far-from-diagonal */
/* . entries ? ==== */
accum = *kacc22 == 1 || *kacc22 == 2;
/* ==== If so, exploit the 2-by-2 block structure? ==== */
blk22 = ns > 2 && *kacc22 == 2;
/* ==== clear trash ==== */
if (*ktop + 2 <= *kbot) {
i__1 = *ktop + 2 + *ktop * h_dim1;
h__[i__1].r = 0., h__[i__1].i = 0.;
}
/* ==== NBMPS = number of 2-shift bulges in the chain ==== */
nbmps = ns / 2;
/* ==== KDU = width of slab ==== */
kdu = nbmps * 6 - 3;
/* ==== Create and chase chains of NBMPS bulges ==== */
i__1 = *kbot - 2;
i__2 = nbmps * 3 - 2;
for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 :
incol <= i__1; incol += i__2) {
ndcol = incol + kdu;
if (accum) {
zlaset_("ALL", &kdu, &kdu, &c_b1, &c_b2, &u[u_offset], ldu);
}
/* ==== Near-the-diagonal bulge chase. The following loop */
/* . performs the near-the-diagonal part of a small bulge */
/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */
/* . chunk extends from column INCOL to column NDCOL */
/* . (including both column INCOL and column NDCOL). The */
/* . following loop chases a 3*NBMPS column long chain of */
/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */
/* . may be less than KTOP and and NDCOL may be greater than */
/* . KBOT indicating phantom columns from which to chase */
/* . bulges before they are actually introduced or to which */
/* . to chase bulges beyond column KBOT.) ==== */
/* Computing MIN */
i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2;
i__3 = min(i__4,i__5);
for (krcol = incol; krcol <= i__3; ++krcol) {
/* ==== Bulges number MTOP to MBOT are active double implicit */
/* . shift bulges. There may or may not also be small */
/* . 2-by-2 bulge, if there is room. The inactive bulges */
/* . (if any) must wait until the active bulges have moved */
/* . down the diagonal to make room. The phantom matrix */
/* . paradigm described above helps keep track. ==== */
/* Computing MAX */
i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1;
mtop = max(i__4,i__5);
/* Computing MIN */
i__4 = nbmps, i__5 = (*kbot - krcol) / 3;
mbot = min(i__4,i__5);
m22 = mbot + 1;
bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2;
/* ==== Generate reflections to chase the chain right */
/* . one column. (The minimum value of K is KTOP-1.) ==== */
i__4 = mbot;
for (m = mtop; m <= i__4; ++m) {
k = krcol + (m - 1) * 3;
if (k == *ktop - 1) {
zlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &s[(m <<
1) - 1], &s[m * 2], &v[m * v_dim1 + 1]);
i__5 = m * v_dim1 + 1;
alpha.r = v[i__5].r, alpha.i = v[i__5].i;
zlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m *
v_dim1 + 1]);
} else {
i__5 = k + 1 + k * h_dim1;
beta.r = h__[i__5].r, beta.i = h__[i__5].i;
i__5 = m * v_dim1 + 2;
i__6 = k + 2 + k * h_dim1;
v[i__5].r = h__[i__6].r, v[i__5].i = h__[i__6].i;
i__5 = m * v_dim1 + 3;
i__6 = k + 3 + k * h_dim1;
v[i__5].r = h__[i__6].r, v[i__5].i = h__[i__6].i;
zlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m *
v_dim1 + 1]);
/* ==== A Bulge may collapse because of vigilant */
/* . deflation or destructive underflow. In the */
/* . underflow case, try the two-small-subdiagonals */
/* . trick to try to reinflate the bulge. ==== */
i__5 = k + 3 + k * h_dim1;
i__6 = k + 3 + (k + 1) * h_dim1;
i__7 = k + 3 + (k + 2) * h_dim1;
if (h__[i__5].r != 0. || h__[i__5].i != 0. || (h__[i__6]
.r != 0. || h__[i__6].i != 0.) || h__[i__7].r ==
0. && h__[i__7].i == 0.) {
/* ==== Typical case: not collapsed (yet). ==== */
i__5 = k + 1 + k * h_dim1;
h__[i__5].r = beta.r, h__[i__5].i = beta.i;
i__5 = k + 2 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
i__5 = k + 3 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
} else {
/* ==== Atypical case: collapsed. Attempt to */
/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */
/* . If the fill resulting from the new */
/* . reflector is too large, then abandon it. */
/* . Otherwise, use the new one. ==== */
zlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, &
s[(m << 1) - 1], &s[m * 2], vt);
alpha.r = vt[0].r, alpha.i = vt[0].i;
zlarfg_(&c__3, &alpha, &vt[1], &c__1, vt);
d_cnjg(&z__2, vt);
i__5 = k + 1 + k * h_dim1;
d_cnjg(&z__5, &vt[1]);
i__6 = k + 2 + k * h_dim1;
z__4.r = z__5.r * h__[i__6].r - z__5.i * h__[i__6].i,
z__4.i = z__5.r * h__[i__6].i + z__5.i * h__[
i__6].r;
z__3.r = h__[i__5].r + z__4.r, z__3.i = h__[i__5].i +
z__4.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__5 = k + 2 + k * h_dim1;
z__3.r = refsum.r * vt[1].r - refsum.i * vt[1].i,
z__3.i = refsum.r * vt[1].i + refsum.i * vt[1]
.r;
z__2.r = h__[i__5].r - z__3.r, z__2.i = h__[i__5].i -
z__3.i;
z__1.r = z__2.r, z__1.i = z__2.i;
z__5.r = refsum.r * vt[2].r - refsum.i * vt[2].i,
z__5.i = refsum.r * vt[2].i + refsum.i * vt[2]
.r;
z__4.r = z__5.r, z__4.i = z__5.i;
i__6 = k + k * h_dim1;
i__7 = k + 1 + (k + 1) * h_dim1;
i__8 = k + 2 + (k + 2) * h_dim1;
if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1)
, abs(d__2)) + ((d__3 = z__4.r, abs(d__3)) + (
d__4 = d_imag(&z__4), abs(d__4))) > ulp * ((
d__5 = h__[i__6].r, abs(d__5)) + (d__6 =
d_imag(&h__[k + k * h_dim1]), abs(d__6)) + ((
d__7 = h__[i__7].r, abs(d__7)) + (d__8 =
d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
d__8))) + ((d__9 = h__[i__8].r, abs(d__9)) + (
d__10 = d_imag(&h__[k + 2 + (k + 2) * h_dim1])
, abs(d__10))))) {
/* ==== Starting a new bulge here would */
/* . create non-negligible fill. Use */
/* . the old one with trepidation. ==== */
i__5 = k + 1 + k * h_dim1;
h__[i__5].r = beta.r, h__[i__5].i = beta.i;
i__5 = k + 2 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
i__5 = k + 3 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
} else {
/* ==== Stating a new bulge here would */
/* . create only negligible fill. */
/* . Replace the old reflector with */
/* . the new one. ==== */
i__5 = k + 1 + k * h_dim1;
i__6 = k + 1 + k * h_dim1;
z__1.r = h__[i__6].r - refsum.r, z__1.i = h__[
i__6].i - refsum.i;
h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
i__5 = k + 2 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
i__5 = k + 3 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
i__5 = m * v_dim1 + 1;
v[i__5].r = vt[0].r, v[i__5].i = vt[0].i;
i__5 = m * v_dim1 + 2;
v[i__5].r = vt[1].r, v[i__5].i = vt[1].i;
i__5 = m * v_dim1 + 3;
v[i__5].r = vt[2].r, v[i__5].i = vt[2].i;
}
}
}
}
/* ==== Generate a 2-by-2 reflection, if needed. ==== */
k = krcol + (m22 - 1) * 3;
if (bmp22) {
if (k == *ktop - 1) {
zlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &s[(
m22 << 1) - 1], &s[m22 * 2], &v[m22 * v_dim1 + 1])
;
i__4 = m22 * v_dim1 + 1;
beta.r = v[i__4].r, beta.i = v[i__4].i;
zlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
* v_dim1 + 1]);
} else {
i__4 = k + 1 + k * h_dim1;
beta.r = h__[i__4].r, beta.i = h__[i__4].i;
i__4 = m22 * v_dim1 + 2;
i__5 = k + 2 + k * h_dim1;
v[i__4].r = h__[i__5].r, v[i__4].i = h__[i__5].i;
zlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
* v_dim1 + 1]);
i__4 = k + 1 + k * h_dim1;
h__[i__4].r = beta.r, h__[i__4].i = beta.i;
i__4 = k + 2 + k * h_dim1;
h__[i__4].r = 0., h__[i__4].i = 0.;
}
}
/* ==== Multiply H by reflections from the left ==== */
if (accum) {
jbot = min(ndcol,*kbot);
} else if (*wantt) {
jbot = *n;
} else {
jbot = *kbot;
}
i__4 = jbot;
for (j = max(*ktop,krcol); j <= i__4; ++j) {
/* Computing MIN */
i__5 = mbot, i__6 = (j - krcol + 2) / 3;
mend = min(i__5,i__6);
i__5 = mend;
for (m = mtop; m <= i__5; ++m) {
k = krcol + (m - 1) * 3;
d_cnjg(&z__2, &v[m * v_dim1 + 1]);
i__6 = k + 1 + j * h_dim1;
d_cnjg(&z__6, &v[m * v_dim1 + 2]);
i__7 = k + 2 + j * h_dim1;
z__5.r = z__6.r * h__[i__7].r - z__6.i * h__[i__7].i,
z__5.i = z__6.r * h__[i__7].i + z__6.i * h__[i__7]
.r;
z__4.r = h__[i__6].r + z__5.r, z__4.i = h__[i__6].i +
z__5.i;
d_cnjg(&z__8, &v[m * v_dim1 + 3]);
i__8 = k + 3 + j * h_dim1;
z__7.r = z__8.r * h__[i__8].r - z__8.i * h__[i__8].i,
z__7.i = z__8.r * h__[i__8].i + z__8.i * h__[i__8]
.r;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__6 = k + 1 + j * h_dim1;
i__7 = k + 1 + j * h_dim1;
z__1.r = h__[i__7].r - refsum.r, z__1.i = h__[i__7].i -
refsum.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
i__6 = k + 2 + j * h_dim1;
i__7 = k + 2 + j * h_dim1;
i__8 = m * v_dim1 + 2;
z__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i,
z__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8]
.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
z__2.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
i__6 = k + 3 + j * h_dim1;
i__7 = k + 3 + j * h_dim1;
i__8 = m * v_dim1 + 3;
z__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i,
z__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8]
.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
z__2.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
}
}
if (bmp22) {
k = krcol + (m22 - 1) * 3;
/* Computing MAX */
i__4 = k + 1;
i__5 = jbot;
for (j = max(i__4,*ktop); j <= i__5; ++j) {
d_cnjg(&z__2, &v[m22 * v_dim1 + 1]);
i__4 = k + 1 + j * h_dim1;
d_cnjg(&z__5, &v[m22 * v_dim1 + 2]);
i__6 = k + 2 + j * h_dim1;
z__4.r = z__5.r * h__[i__6].r - z__5.i * h__[i__6].i,
z__4.i = z__5.r * h__[i__6].i + z__5.i * h__[i__6]
.r;
z__3.r = h__[i__4].r + z__4.r, z__3.i = h__[i__4].i +
z__4.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__4 = k + 1 + j * h_dim1;
i__6 = k + 1 + j * h_dim1;
z__1.r = h__[i__6].r - refsum.r, z__1.i = h__[i__6].i -
refsum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = k + 2 + j * h_dim1;
i__6 = k + 2 + j * h_dim1;
i__7 = m22 * v_dim1 + 2;
z__2.r = refsum.r * v[i__7].r - refsum.i * v[i__7].i,
z__2.i = refsum.r * v[i__7].i + refsum.i * v[i__7]
.r;
z__1.r = h__[i__6].r - z__2.r, z__1.i = h__[i__6].i -
z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
}
}
/* ==== Multiply H by reflections from the right. */
/* . Delay filling in the last row until the */
/* . vigilant deflation check is complete. ==== */
if (accum) {
jtop = max(*ktop,incol);
} else if (*wantt) {
jtop = 1;
} else {
jtop = *ktop;
}
i__5 = mbot;
for (m = mtop; m <= i__5; ++m) {
i__4 = m * v_dim1 + 1;
if (v[i__4].r != 0. || v[i__4].i != 0.) {
k = krcol + (m - 1) * 3;
/* Computing MIN */
i__6 = *kbot, i__7 = k + 3;
i__4 = min(i__6,i__7);
for (j = jtop; j <= i__4; ++j) {
i__6 = m * v_dim1 + 1;
i__7 = j + (k + 1) * h_dim1;
i__8 = m * v_dim1 + 2;
i__9 = j + (k + 2) * h_dim1;
z__4.r = v[i__8].r * h__[i__9].r - v[i__8].i * h__[
i__9].i, z__4.i = v[i__8].r * h__[i__9].i + v[
i__8].i * h__[i__9].r;
z__3.r = h__[i__7].r + z__4.r, z__3.i = h__[i__7].i +
z__4.i;
i__10 = m * v_dim1 + 3;
i__11 = j + (k + 3) * h_dim1;
z__5.r = v[i__10].r * h__[i__11].r - v[i__10].i * h__[
i__11].i, z__5.i = v[i__10].r * h__[i__11].i
+ v[i__10].i * h__[i__11].r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__1.r = v[i__6].r * z__2.r - v[i__6].i * z__2.i,
z__1.i = v[i__6].r * z__2.i + v[i__6].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__6 = j + (k + 1) * h_dim1;
i__7 = j + (k + 1) * h_dim1;
z__1.r = h__[i__7].r - refsum.r, z__1.i = h__[i__7].i
- refsum.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
i__6 = j + (k + 2) * h_dim1;
i__7 = j + (k + 2) * h_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
z__2.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
i__6 = j + (k + 3) * h_dim1;
i__7 = j + (k + 3) * h_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 3]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
z__2.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
}
if (accum) {
/* ==== Accumulate U. (If necessary, update Z later */
/* . with with an efficient matrix-matrix */
/* . multiply.) ==== */
kms = k - incol;
/* Computing MAX */
i__4 = 1, i__6 = *ktop - incol;
i__7 = kdu;
for (j = max(i__4,i__6); j <= i__7; ++j) {
i__4 = m * v_dim1 + 1;
i__6 = j + (kms + 1) * u_dim1;
i__8 = m * v_dim1 + 2;
i__9 = j + (kms + 2) * u_dim1;
z__4.r = v[i__8].r * u[i__9].r - v[i__8].i * u[
i__9].i, z__4.i = v[i__8].r * u[i__9].i +
v[i__8].i * u[i__9].r;
z__3.r = u[i__6].r + z__4.r, z__3.i = u[i__6].i +
z__4.i;
i__10 = m * v_dim1 + 3;
i__11 = j + (kms + 3) * u_dim1;
z__5.r = v[i__10].r * u[i__11].r - v[i__10].i * u[
i__11].i, z__5.i = v[i__10].r * u[i__11]
.i + v[i__10].i * u[i__11].r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i +
z__5.i;
z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i,
z__1.i = v[i__4].r * z__2.i + v[i__4].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__4 = j + (kms + 1) * u_dim1;
i__6 = j + (kms + 1) * u_dim1;
z__1.r = u[i__6].r - refsum.r, z__1.i = u[i__6].i
- refsum.i;
u[i__4].r = z__1.r, u[i__4].i = z__1.i;
i__4 = j + (kms + 2) * u_dim1;
i__6 = j + (kms + 2) * u_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = u[i__6].r - z__2.r, z__1.i = u[i__6].i -
z__2.i;
u[i__4].r = z__1.r, u[i__4].i = z__1.i;
i__4 = j + (kms + 3) * u_dim1;
i__6 = j + (kms + 3) * u_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 3]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = u[i__6].r - z__2.r, z__1.i = u[i__6].i -
z__2.i;
u[i__4].r = z__1.r, u[i__4].i = z__1.i;
}
} else if (*wantz) {
/* ==== U is not accumulated, so update Z */
/* . now by multiplying by reflections */
/* . from the right. ==== */
i__7 = *ihiz;
for (j = *iloz; j <= i__7; ++j) {
i__4 = m * v_dim1 + 1;
i__6 = j + (k + 1) * z_dim1;
i__8 = m * v_dim1 + 2;
i__9 = j + (k + 2) * z_dim1;
z__4.r = v[i__8].r * z__[i__9].r - v[i__8].i *
z__[i__9].i, z__4.i = v[i__8].r * z__[
i__9].i + v[i__8].i * z__[i__9].r;
z__3.r = z__[i__6].r + z__4.r, z__3.i = z__[i__6]
.i + z__4.i;
i__10 = m * v_dim1 + 3;
i__11 = j + (k + 3) * z_dim1;
z__5.r = v[i__10].r * z__[i__11].r - v[i__10].i *
z__[i__11].i, z__5.i = v[i__10].r * z__[
i__11].i + v[i__10].i * z__[i__11].r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i +
z__5.i;
z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i,
z__1.i = v[i__4].r * z__2.i + v[i__4].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__4 = j + (k + 1) * z_dim1;
i__6 = j + (k + 1) * z_dim1;
z__1.r = z__[i__6].r - refsum.r, z__1.i = z__[
i__6].i - refsum.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = j + (k + 2) * z_dim1;
i__6 = j + (k + 2) * z_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = z__[i__6].r - z__2.r, z__1.i = z__[i__6]
.i - z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = j + (k + 3) * z_dim1;
i__6 = j + (k + 3) * z_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 3]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = z__[i__6].r - z__2.r, z__1.i = z__[i__6]
.i - z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
}
}
}
}
/* ==== Special case: 2-by-2 reflection (if needed) ==== */
k = krcol + (m22 - 1) * 3;
i__5 = m22 * v_dim1 + 1;
if (bmp22 && (v[i__5].r != 0. || v[i__5].i != 0.)) {
/* Computing MIN */
i__7 = *kbot, i__4 = k + 3;
i__5 = min(i__7,i__4);
for (j = jtop; j <= i__5; ++j) {
i__7 = m22 * v_dim1 + 1;
i__4 = j + (k + 1) * h_dim1;
i__6 = m22 * v_dim1 + 2;
i__8 = j + (k + 2) * h_dim1;
z__3.r = v[i__6].r * h__[i__8].r - v[i__6].i * h__[i__8]
.i, z__3.i = v[i__6].r * h__[i__8].i + v[i__6].i *
h__[i__8].r;
z__2.r = h__[i__4].r + z__3.r, z__2.i = h__[i__4].i +
z__3.i;
z__1.r = v[i__7].r * z__2.r - v[i__7].i * z__2.i, z__1.i =
v[i__7].r * z__2.i + v[i__7].i * z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__7 = j + (k + 1) * h_dim1;
i__4 = j + (k + 1) * h_dim1;
z__1.r = h__[i__4].r - refsum.r, z__1.i = h__[i__4].i -
refsum.i;
h__[i__7].r = z__1.r, h__[i__7].i = z__1.i;
i__7 = j + (k + 2) * h_dim1;
i__4 = j + (k + 2) * h_dim1;
d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i =
refsum.r * z__3.i + refsum.i * z__3.r;
z__1.r = h__[i__4].r - z__2.r, z__1.i = h__[i__4].i -
z__2.i;
h__[i__7].r = z__1.r, h__[i__7].i = z__1.i;
}
if (accum) {
kms = k - incol;
/* Computing MAX */
i__5 = 1, i__7 = *ktop - incol;
i__4 = kdu;
for (j = max(i__5,i__7); j <= i__4; ++j) {
i__5 = m22 * v_dim1 + 1;
i__7 = j + (kms + 1) * u_dim1;
i__6 = m22 * v_dim1 + 2;
i__8 = j + (kms + 2) * u_dim1;
z__3.r = v[i__6].r * u[i__8].r - v[i__6].i * u[i__8]
.i, z__3.i = v[i__6].r * u[i__8].i + v[i__6]
.i * u[i__8].r;
z__2.r = u[i__7].r + z__3.r, z__2.i = u[i__7].i +
z__3.i;
z__1.r = v[i__5].r * z__2.r - v[i__5].i * z__2.i,
z__1.i = v[i__5].r * z__2.i + v[i__5].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__5 = j + (kms + 1) * u_dim1;
i__7 = j + (kms + 1) * u_dim1;
z__1.r = u[i__7].r - refsum.r, z__1.i = u[i__7].i -
refsum.i;
u[i__5].r = z__1.r, u[i__5].i = z__1.i;
i__5 = j + (kms + 2) * u_dim1;
i__7 = j + (kms + 2) * u_dim1;
d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = u[i__7].r - z__2.r, z__1.i = u[i__7].i -
z__2.i;
u[i__5].r = z__1.r, u[i__5].i = z__1.i;
}
} else if (*wantz) {
i__4 = *ihiz;
for (j = *iloz; j <= i__4; ++j) {
i__5 = m22 * v_dim1 + 1;
i__7 = j + (k + 1) * z_dim1;
i__6 = m22 * v_dim1 + 2;
i__8 = j + (k + 2) * z_dim1;
z__3.r = v[i__6].r * z__[i__8].r - v[i__6].i * z__[
i__8].i, z__3.i = v[i__6].r * z__[i__8].i + v[
i__6].i * z__[i__8].r;
z__2.r = z__[i__7].r + z__3.r, z__2.i = z__[i__7].i +
z__3.i;
z__1.r = v[i__5].r * z__2.r - v[i__5].i * z__2.i,
z__1.i = v[i__5].r * z__2.i + v[i__5].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__5 = j + (k + 1) * z_dim1;
i__7 = j + (k + 1) * z_dim1;
z__1.r = z__[i__7].r - refsum.r, z__1.i = z__[i__7].i
- refsum.i;
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
i__5 = j + (k + 2) * z_dim1;
i__7 = j + (k + 2) * z_dim1;
d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = z__[i__7].r - z__2.r, z__1.i = z__[i__7].i -
z__2.i;
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
}
}
}
/* ==== Vigilant deflation check ==== */
mstart = mtop;
if (krcol + (mstart - 1) * 3 < *ktop) {
++mstart;
}
mend = mbot;
if (bmp22) {
++mend;
}
if (krcol == *kbot - 2) {
++mend;
}
i__4 = mend;
for (m = mstart; m <= i__4; ++m) {
/* Computing MIN */
i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3;
k = min(i__5,i__7);
/* ==== The following convergence test requires that */
/* . the tradition small-compared-to-nearby-diagonals */
/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */
/* . criteria both be satisfied. The latter improves */
/* . accuracy in some examples. Falling back on an */
/* . alternate convergence criterion when TST1 or TST2 */
/* . is zero (as done here) is traditional but probably */
/* . unnecessary. ==== */
i__5 = k + 1 + k * h_dim1;
if (h__[i__5].r != 0. || h__[i__5].i != 0.) {
i__5 = k + k * h_dim1;
i__7 = k + 1 + (k + 1) * h_dim1;
tst1 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 = d_imag(&
h__[k + k * h_dim1]), abs(d__2)) + ((d__3 = h__[
i__7].r, abs(d__3)) + (d__4 = d_imag(&h__[k + 1 +
(k + 1) * h_dim1]), abs(d__4)));
if (tst1 == 0.) {
if (k >= *ktop + 1) {
i__5 = k + (k - 1) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + (k - 1) * h_dim1]), abs(
d__2));
}
if (k >= *ktop + 2) {
i__5 = k + (k - 2) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + (k - 2) * h_dim1]), abs(
d__2));
}
if (k >= *ktop + 3) {
i__5 = k + (k - 3) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + (k - 3) * h_dim1]), abs(
d__2));
}
if (k <= *kbot - 2) {
i__5 = k + 2 + (k + 1) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 2 + (k + 1) * h_dim1]),
abs(d__2));
}
if (k <= *kbot - 3) {
i__5 = k + 3 + (k + 1) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 3 + (k + 1) * h_dim1]),
abs(d__2));
}
if (k <= *kbot - 4) {
i__5 = k + 4 + (k + 1) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 4 + (k + 1) * h_dim1]),
abs(d__2));
}
}
i__5 = k + 1 + k * h_dim1;
/* Computing MAX */
d__3 = smlnum, d__4 = ulp * tst1;
if ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = d_imag(&h__[
k + 1 + k * h_dim1]), abs(d__2)) <= max(d__3,d__4)
) {
/* Computing MAX */
i__5 = k + 1 + k * h_dim1;
i__7 = k + (k + 1) * h_dim1;
d__5 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 1 + k * h_dim1]), abs(d__2)),
d__6 = (d__3 = h__[i__7].r, abs(d__3)) + (
d__4 = d_imag(&h__[k + (k + 1) * h_dim1]),
abs(d__4));
h12 = max(d__5,d__6);
/* Computing MIN */
i__5 = k + 1 + k * h_dim1;
i__7 = k + (k + 1) * h_dim1;
d__5 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 1 + k * h_dim1]), abs(d__2)),
d__6 = (d__3 = h__[i__7].r, abs(d__3)) + (
d__4 = d_imag(&h__[k + (k + 1) * h_dim1]),
abs(d__4));
h21 = min(d__5,d__6);
i__5 = k + k * h_dim1;
i__7 = k + 1 + (k + 1) * h_dim1;
z__2.r = h__[i__5].r - h__[i__7].r, z__2.i = h__[i__5]
.i - h__[i__7].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
i__6 = k + 1 + (k + 1) * h_dim1;
d__5 = (d__1 = h__[i__6].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
d__2)), d__6 = (d__3 = z__1.r, abs(d__3)) + (
d__4 = d_imag(&z__1), abs(d__4));
h11 = max(d__5,d__6);
i__5 = k + k * h_dim1;
i__7 = k + 1 + (k + 1) * h_dim1;
z__2.r = h__[i__5].r - h__[i__7].r, z__2.i = h__[i__5]
.i - h__[i__7].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MIN */
i__6 = k + 1 + (k + 1) * h_dim1;
d__5 = (d__1 = h__[i__6].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
d__2)), d__6 = (d__3 = z__1.r, abs(d__3)) + (
d__4 = d_imag(&z__1), abs(d__4));
h22 = min(d__5,d__6);
scl = h11 + h12;
tst2 = h22 * (h11 / scl);
/* Computing MAX */
d__1 = smlnum, d__2 = ulp * tst2;
if (tst2 == 0. || h21 * (h12 / scl) <= max(d__1,d__2))
{
i__5 = k + 1 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
}
}
}
}
/* ==== Fill in the last row of each bulge. ==== */
/* Computing MIN */
i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3;
mend = min(i__4,i__5);
i__4 = mend;
for (m = mtop; m <= i__4; ++m) {
k = krcol + (m - 1) * 3;
i__5 = m * v_dim1 + 1;
i__7 = m * v_dim1 + 3;
z__2.r = v[i__5].r * v[i__7].r - v[i__5].i * v[i__7].i,
z__2.i = v[i__5].r * v[i__7].i + v[i__5].i * v[i__7]
.r;
i__6 = k + 4 + (k + 3) * h_dim1;
z__1.r = z__2.r * h__[i__6].r - z__2.i * h__[i__6].i, z__1.i =
z__2.r * h__[i__6].i + z__2.i * h__[i__6].r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__5 = k + 4 + (k + 1) * h_dim1;
z__1.r = -refsum.r, z__1.i = -refsum.i;
h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
i__5 = k + 4 + (k + 2) * h_dim1;
z__2.r = -refsum.r, z__2.i = -refsum.i;
d_cnjg(&z__3, &v[m * v_dim1 + 2]);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r *
z__3.i + z__2.i * z__3.r;
h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
i__5 = k + 4 + (k + 3) * h_dim1;
i__7 = k + 4 + (k + 3) * h_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 3]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i =
refsum.r * z__3.i + refsum.i * z__3.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i - z__2.i;
h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
}
/* ==== End of near-the-diagonal bulge chase. ==== */
}
/* ==== Use U (if accumulated) to update far-from-diagonal */
/* . entries in H. If required, use U to update Z as */
/* . well. ==== */
if (accum) {
if (*wantt) {
jtop = 1;
jbot = *n;
} else {
jtop = *ktop;
jbot = *kbot;
}
if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) {
/* ==== Updates not exploiting the 2-by-2 block */
/* . structure of U. K1 and NU keep track of */
/* . the location and size of U in the special */
/* . cases of introducing bulges and chasing */
/* . bulges off the bottom. In these special */
/* . cases and in case the number of shifts */
/* . is NS = 2, there is no 2-by-2 block */
/* . structure to exploit. ==== */
/* Computing MAX */
i__3 = 1, i__4 = *ktop - incol;
k1 = max(i__3,i__4);
/* Computing MAX */
i__3 = 0, i__4 = ndcol - *kbot;
nu = kdu - max(i__3,i__4) - k1 + 1;
/* ==== Horizontal Multiply ==== */
i__3 = jbot;
i__4 = *nh;
for (jcol = min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 :
jcol <= i__3; jcol += i__4) {
/* Computing MIN */
i__5 = *nh, i__7 = jbot - jcol + 1;
jlen = min(i__5,i__7);
zgemm_("C", "N", &nu, &jlen, &nu, &c_b2, &u[k1 + k1 *
u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1],
ldh, &c_b1, &wh[wh_offset], ldwh);
zlacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[
incol + k1 + jcol * h_dim1], ldh);
}
/* ==== Vertical multiply ==== */
i__4 = max(*ktop,incol) - 1;
i__3 = *nv;
for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
jrow += i__3) {
/* Computing MIN */
i__5 = *nv, i__7 = max(*ktop,incol) - jrow;
jlen = min(i__5,i__7);
zgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &h__[jrow + (
incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1],
ldu, &c_b1, &wv[wv_offset], ldwv);
zlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[
jrow + (incol + k1) * h_dim1], ldh);
}
/* ==== Z multiply (also vertical) ==== */
if (*wantz) {
i__3 = *ihiz;
i__4 = *nv;
for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
jrow += i__4) {
/* Computing MIN */
i__5 = *nv, i__7 = *ihiz - jrow + 1;
jlen = min(i__5,i__7);
zgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &z__[jrow + (
incol + k1) * z_dim1], ldz, &u[k1 + k1 *
u_dim1], ldu, &c_b1, &wv[wv_offset], ldwv);
zlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[
jrow + (incol + k1) * z_dim1], ldz)
;
}
}
} else {
/* ==== Updates exploiting U's 2-by-2 block structure. */
/* . (I2, I4, J2, J4 are the last rows and columns */
/* . of the blocks.) ==== */
i2 = (kdu + 1) / 2;
i4 = kdu;
j2 = i4 - i2;
j4 = kdu;
/* ==== KZS and KNZ deal with the band of zeros */
/* . along the diagonal of one of the triangular */
/* . blocks. ==== */
kzs = j4 - j2 - (ns + 1);
knz = ns + 1;
/* ==== Horizontal multiply ==== */
i__4 = jbot;
i__3 = *nh;
for (jcol = min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 :
jcol <= i__4; jcol += i__3) {
/* Computing MIN */
i__5 = *nh, i__7 = jbot - jcol + 1;
jlen = min(i__5,i__7);
/* ==== Copy bottom of H to top+KZS of scratch ==== */
/* (The first KZS rows get multiplied by zero.) ==== */
zlacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol *
h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh);
/* ==== Multiply by U21' ==== */
zlaset_("ALL", &kzs, &jlen, &c_b1, &c_b1, &wh[wh_offset],
ldwh);
ztrmm_("L", "U", "C", "N", &knz, &jlen, &c_b2, &u[j2 + 1
+ (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1]
, ldwh);
/* ==== Multiply top of H by U11' ==== */
zgemm_("C", "N", &i2, &jlen, &j2, &c_b2, &u[u_offset],
ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b2,
&wh[wh_offset], ldwh);
/* ==== Copy top of H to bottom of WH ==== */
zlacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1]
, ldh, &wh[i2 + 1 + wh_dim1], ldwh);
/* ==== Multiply by U21' ==== */
ztrmm_("L", "L", "C", "N", &j2, &jlen, &c_b2, &u[(i2 + 1)
* u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
zgemm_("C", "N", &i__5, &jlen, &i__7, &c_b2, &u[j2 + 1 + (
i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 +
jcol * h_dim1], ldh, &c_b2, &wh[i2 + 1 + wh_dim1],
ldwh);
/* ==== Copy it back ==== */
zlacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[
incol + 1 + jcol * h_dim1], ldh);
}
/* ==== Vertical multiply ==== */
i__3 = max(incol,*ktop) - 1;
i__4 = *nv;
for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
jrow += i__4) {
/* Computing MIN */
i__5 = *nv, i__7 = max(incol,*ktop) - jrow;
jlen = min(i__5,i__7);
/* ==== Copy right of H to scratch (the first KZS */
/* . columns get multiplied by zero) ==== */
zlacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) *
h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv);
/* ==== Multiply by U21 ==== */
zlaset_("ALL", &jlen, &kzs, &c_b1, &c_b1, &wv[wv_offset],
ldwv);
ztrmm_("R", "U", "N", "N", &jlen, &knz, &c_b2, &u[j2 + 1
+ (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) *
wv_dim1 + 1], ldwv);
/* ==== Multiply by U11 ==== */
zgemm_("N", "N", &jlen, &i2, &j2, &c_b2, &h__[jrow + (
incol + 1) * h_dim1], ldh, &u[u_offset], ldu, &
c_b2, &wv[wv_offset], ldwv);
/* ==== Copy left of H to right of scratch ==== */
zlacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) *
h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv);
/* ==== Multiply by U21 ==== */
i__5 = i4 - i2;
ztrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b2, &u[(i2 +
1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1]
, ldwv);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
zgemm_("N", "N", &jlen, &i__5, &i__7, &c_b2, &h__[jrow + (
incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 +
1) * u_dim1], ldu, &c_b2, &wv[(i2 + 1) * wv_dim1
+ 1], ldwv);
/* ==== Copy it back ==== */
zlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[
jrow + (incol + 1) * h_dim1], ldh);
}
/* ==== Multiply Z (also vertical) ==== */
if (*wantz) {
i__4 = *ihiz;
i__3 = *nv;
for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
jrow += i__3) {
/* Computing MIN */
i__5 = *nv, i__7 = *ihiz - jrow + 1;
jlen = min(i__5,i__7);
/* ==== Copy right of Z to left of scratch (first */
/* . KZS columns get multiplied by zero) ==== */
zlacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 +
j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 +
1], ldwv);
/* ==== Multiply by U12 ==== */
zlaset_("ALL", &jlen, &kzs, &c_b1, &c_b1, &wv[
wv_offset], ldwv);
ztrmm_("R", "U", "N", "N", &jlen, &knz, &c_b2, &u[j2
+ 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1)
* wv_dim1 + 1], ldwv);
/* ==== Multiply by U11 ==== */
zgemm_("N", "N", &jlen, &i2, &j2, &c_b2, &z__[jrow + (
incol + 1) * z_dim1], ldz, &u[u_offset], ldu,
&c_b2, &wv[wv_offset], ldwv);
/* ==== Copy left of Z to right of scratch ==== */
zlacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) *
z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1],
ldwv);
/* ==== Multiply by U21 ==== */
i__5 = i4 - i2;
ztrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b2, &u[(
i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) *
wv_dim1 + 1], ldwv);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
zgemm_("N", "N", &jlen, &i__5, &i__7, &c_b2, &z__[
jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2
+ 1 + (i2 + 1) * u_dim1], ldu, &c_b2, &wv[(i2
+ 1) * wv_dim1 + 1], ldwv);
/* ==== Copy the result back to Z ==== */
zlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &
z__[jrow + (incol + 1) * z_dim1], ldz);
}
}
}
}
}
/* ==== End of ZLAQR5 ==== */
return 0;
} /* zlaqr5_ */
/* Subroutine */ int zdrgev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s,
doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__,
doublecomplex *qe, integer *ldqe, doublecomplex *alpha, doublecomplex
*beta, doublecomplex *alpha1, doublecomplex *beta1, doublecomplex *
work, integer *lwork, doublereal *rwork, doublereal *result, integer *
info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGEV: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
"i3,\002, ISEED=(\002,3(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see ZDRGEV for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
"| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
"lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
" | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
" or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
"d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer iadd, ierr, nmax, i__, j, n;
static logical badnn;
static doublereal rmagn[4];
static doublecomplex ctemp;
extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *);
static integer nmats, jsize;
extern /* Subroutine */ int zggev_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
static integer nerrs, jtype, n1;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
integer *, integer *, integer *, integer *, logical *, doublereal
*, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *);
static integer jc, nb, in;
extern doublereal dlamch_(char *);
static integer jr;
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal safmin, safmax;
static integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
static integer minwrk, maxwrk;
static doublereal ulpinv;
static integer mtypes, ntestt;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9991, 0 };
#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)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define qe_subscr(a_1,a_2) (a_2)*qe_dim1 + a_1
#define qe_ref(a_1,a_2) qe[qe_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
June 30, 1999
Purpose
=======
ZDRGEV checks the nonsymmetric generalized eigenvalue problem driver
routine ZGGEV.
ZGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
generalized eigenvalues and, optionally, the left and right
eigenvectors.
A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
or a ratio alpha/beta = w, such that A - w*B is singular. It is
usually represented as the pair (alpha,beta), as there is reasonalbe
interpretation for beta=0, and even for both being zero.
A right generalized eigenvector corresponding to a generalized
eigenvalue w for a pair of matrices (A,B) is a vector r such that
(A - wB) * r = 0. A left generalized eigenvector is a vector l such
that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
When ZDRGEV is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified. For each size ("n")
and each type of matrix, a pair of matrices (A, B) will be generated
and used for testing. For each matrix pair, the following tests
will be performed and compared with the threshhold THRESH.
Results from ZGGEV:
(1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of
| VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
where VL**H is the conjugate-transpose of VL.
(2) | |VL(i)| - 1 | / ulp and whether largest component real
VL(i) denotes the i-th column of VL.
(3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of
| (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
(4) | |VR(i)| - 1 | / ulp and whether largest component real
VR(i) denotes the i-th column of VR.
(5) W(full) = W(partial)
W(full) denotes the eigenvalues computed when both l and r
are also computed, and W(partial) denotes the eigenvalues
computed when only W, only W and r, or only W and l are
computed.
(6) VL(full) = VL(partial)
VL(full) denotes the left eigenvectors computed when both l
and r are computed, and VL(partial) denotes the result
when only l is computed.
(7) VR(full) = VR(partial)
VR(full) denotes the right eigenvectors computed when both l
and r are also computed, and VR(partial) denotes the result
when only l is computed.
Test Matrices
---- --------
The sizes of the test matrices are specified by an array
NN(1:NSIZES); the value of each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) ( 0, 0 ) (a pair of zero matrices)
(2) ( I, 0 ) (an identity and a zero matrix)
(3) ( 0, I ) (an identity and a zero matrix)
(4) ( I, I ) (a pair of identity matrices)
t t
(5) ( J , J ) (a pair of transposed Jordan blocks)
t ( I 0 )
(6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
( 0 I ) ( 0 J )
and I is a k x k identity and J a (k+1)x(k+1)
Jordan block; k=(N-1)/2
(7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
matrix with those diagonal entries.)
(8) ( I, D )
(9) ( big*D, small*I ) where "big" is near overflow and small=1/big
(10) ( small*D, big*I )
(11) ( big*I, small*D )
(12) ( small*I, big*D )
(13) ( big*D, big*I )
(14) ( small*D, small*I )
(15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
t t
(16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
(17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
with random O(1) entries above the diagonal
and diagonal entries diag(T1) =
( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
( 0, N-3, N-4,..., 1, 0, 0 )
(18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
s = machine precision.
(19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
N-5
(20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
(21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
where r1,..., r(N-4) are random.
(22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
matrices.
Arguments
=========
NSIZES (input) INTEGER
The number of sizes of matrices to use. If it is zero,
ZDRGES does nothing. NSIZES >= 0.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. NN >= 0.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, ZDRGEV
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A. This
is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to ZDRGES to continue the same random number
sequence.
THRESH (input) DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error is
scaled to be O(1), so THRESH should be a reasonably small
multiple of 1, e.g., 10 or 100. In particular, it should
not depend on the precision (single vs. double) or the size
of the matrix. It must be at least zero.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IERR not equal to 0.)
A (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN))
Used to hold the original A matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
LDA (input) INTEGER
The leading dimension of A, B, S, and T.
It must be at least 1 and at least max( NN ).
B (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN))
Used to hold the original B matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
S (workspace) COMPLEX*16 array, dimension (LDA, max(NN))
The Schur form matrix computed from A by ZGGEV. On exit, S
contains the Schur form matrix corresponding to the matrix
in A.
T (workspace) COMPLEX*16 array, dimension (LDA, max(NN))
The upper triangular matrix computed from B by ZGGEV.
Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN))
The (left) eigenvectors matrix computed by ZGGEV.
LDQ (input) INTEGER
The leading dimension of Q and Z. It must
be at least 1 and at least max( NN ).
Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) )
The (right) orthogonal matrix computed by ZGGEV.
QE (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) )
QE holds the computed right or left eigenvectors.
LDQE (input) INTEGER
The leading dimension of QE. LDQE >= max(1,max(NN)).
ALPHA (workspace) COMPLEX*16 array, dimension (max(NN))
BETA (workspace) COMPLEX*16 array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by ZGGEV.
( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
generalized eigenvalue of A and B.
ALPHA1 (workspace) COMPLEX*16 array, dimension (max(NN))
BETA1 (workspace) COMPLEX*16 array, dimension (max(NN))
Like ALPHAR, ALPHAI, BETA, these arrays contain the
eigenvalues of A and B, but those computed when ZGGEV only
computes a partial eigendecomposition, i.e. not the
eigenvalues and left and right eigenvectors.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. LWORK >= N*(N+1)
RWORK (workspace) DOUBLE PRECISION array, dimension (8*N)
Real workspace.
RESULT (output) DOUBLE PRECISION array, dimension (2)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code. INFO is the
absolute value of the INFO value returned.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
qe_dim1 = *ldqe;
qe_offset = 1 + qe_dim1 * 1;
qe -= qe_offset;
--alpha;
--beta;
--alpha1;
--beta1;
--work;
--rwork;
--result;
/* Function Body
Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
} else if (*ldqe <= 1 || *ldqe < nmax) {
*info = -17;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = nmax * (nmax + 1);
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, (
ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2
= nmax * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGEV", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L210;
}
++nmats;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Generate test matrices A and B
Description of control parameters:
KZLASS: =1 means w/o rotation, =2 means w/ rotation,
=3 means random.
KATYPE: the "type" to be passed to ZLATM4 for computing A.
KAZERO: the pattern of zeros on the diagonal for A:
=1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
=4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
=6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
non-zero entries.)
KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
=2: large, =3: small.
LASIGN: .TRUE. if the diagonal elements of A are to be
multiplied by a random magnitude 1 number.
KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B.
KTRIAN: =0: don't fill in the upper triangle, =1: do.
KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L100;
}
ierr = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = a_subscr(iadd, iadd);
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b28, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = b_subscr(iadd, iadd);
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations
Generate Q, Z as Householder transformations times
a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = q_subscr(jr, jc);
zlarnd_(&z__1, &c__3, &iseed[1]);
q[i__5].r = z__1.r, q[i__5].i = z__1.i;
i__5 = z___subscr(jr, jc);
zlarnd_(&z__1, &c__3, &iseed[1]);
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L30: */
}
i__4 = n + 1 - jc;
zlarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = q_subscr(jc, jc);
d__2 = q[i__5].r;
d__1 = d_sign(&c_b28, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = q_subscr(jc, jc);
q[i__4].r = 1., q[i__4].i = 0.;
i__4 = n + 1 - jc;
zlarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = z___subscr(jc, jc);
d__2 = z__[i__5].r;
d__1 = d_sign(&c_b28, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = z___subscr(jc, jc);
z__[i__4].r = 1., z__[i__4].i = 0.;
/* L40: */
}
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = q_subscr(n, n);
q[i__3].r = 1., q[i__3].i = 0.;
i__3 = n;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n * 3;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = z___subscr(n, n);
z__[i__3].r = 1., z__[i__3].i = 0.;
i__3 = n << 1;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n << 2;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = a_subscr(jr, jc);
z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
z__1.i = z__2.r * a[i__7].i + z__2.i * a[
i__7].r;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = b_subscr(jr, jc);
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = b_subscr(jr, jc);
z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
z__1.i = z__2.r * b[i__7].i + z__2.i * b[
i__7].r;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L50: */
}
/* L60: */
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = kamagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = b_subscr(jr, jc);
i__6 = kbmagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L70: */
}
/* L80: */
}
}
L90:
if (ierr != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
return 0;
}
L100:
for (i__ = 1; i__ <= 7; ++i__) {
result[i__] = -1.;
/* L110: */
}
/* Call ZGGEV to compute eigenvalues and eigenvectors. */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &alpha[
1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
/* Do the tests (1) and (2) */
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
q_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[1]);
if (result[2] > *thresh) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Do the tests (3) and (4) */
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
z_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[3]);
if (result[4] > *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Do test (5) */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "ZGGEV2", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[5] = ulpinv;
}
/* L120: */
}
/* Do test (6): Compute eigenvalues and left eigenvectors,
and test them */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &qe[qe_offset], ldqe, &z__[z_offset]
, ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "ZGGEV3", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[6] = ulpinv;
}
/* L130: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = q_subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (q[i__5].r != qe[i__6].r || q[i__5].i != qe[i__6].i) {
result[6] = ulpinv;
}
/* L140: */
}
/* L150: */
}
/* Do test (7): Compute eigenvalues and right eigenvectors,
and test them */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &qe[qe_offset],
ldqe, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZGGEV4", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[7] = ulpinv;
}
/* L160: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = z___subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (z__[i__5].r != qe[i__6].r || z__[i__5].i != qe[i__6]
.i) {
result[7] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L190:
ntestt += 7;
/* Print out tests which fail. */
for (jr = 1; jr <= 9; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
do_fio(&c__1, "ZGV", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L200: */
}
L210:
;
}
/* L220: */
}
/* Summary */
alasvm_("ZGV", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGEV */
} /* zdrgev_ */
/* Subroutine */ int zgehd2_(integer *n, integer *ilo, integer *ihi,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work, 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
=======
ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
by a unitary similarity transformation: Q' * A * Q = H .
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that A is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to ZGEBAL; otherwise they should be
set to 1 and N respectively. See Further Details.
1 <= ILO <= IHI <= max(1,N).
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the n by n general matrix to be reduced.
On exit, the upper triangle and the first subdiagonal of A
are overwritten with the upper Hessenberg matrix H, 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).
TAU (output) COMPLEX*16 array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) COMPLEX*16 array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The matrix Q is represented as a product of (ihi-ilo) elementary
reflectors
Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
exit in A(i+2:ihi,i), and tau in TAU(i).
The contents of A are illustrated by the following example, with
n = 7, ilo = 2 and ihi = 6:
on entry, on exit,
( a a a a a a a ) ( a a h h h h a )
( a a a a a a ) ( a h h h h a )
( a a a a a a ) ( h h h h h h )
( a a a a a a ) ( v2 h h h h h )
( a a a a a a ) ( v2 v3 h h h h )
( a a a a a a ) ( v2 v3 v4 h h h )
( a ) ( a )
where a denotes an element of the original matrix A, h denotes a
modified element of the upper Hessenberg matrix H, 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;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i = *ilo; i <= *ihi-1; ++i) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*/
i__2 = i + 1 + i * a_dim1;
alpha.r = A(i+1,i).r, alpha.i = A(i+1,i).i;
i__2 = *ihi - i;
/* Computing MIN */
i__3 = i + 2;
zlarfg_(&i__2, &alpha, &A(min(i+2,*n),i), &c__1, &TAU(i));
i__2 = i + 1 + i * a_dim1;
A(i+1,i).r = 1., A(i+1,i).i = 0.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i;
zlarf_("Right", ihi, &i__2, &A(i+1,i), &c__1, &TAU(i), &
A(1,i+1), lda, &WORK(1));
/* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i;
i__3 = *n - i;
d_cnjg(&z__1, &TAU(i));
zlarf_("Left", &i__2, &i__3, &A(i+1,i), &c__1, &z__1, &A(i+1,i+1), lda, &WORK(1));
i__2 = i + 1 + i * a_dim1;
A(i+1,i).r = alpha.r, A(i+1,i).i = alpha.i;
/* L10: */
}
return 0;
/* End of ZGEHD2 */
} /* zgehd2_ */
/* Subroutine */ int zlapll_(integer *n, doublecomplex *x, integer *incx,
doublecomplex *y, integer *incy, doublereal *ssmin)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
static doublecomplex c__, a11, a12, a22, tau;
extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal ssmax;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Given two column vectors X and Y, let */
/* A = ( X Y ). */
/* The subroutine first computes the QR factorization of A = Q*R, */
/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */
/* The smaller singular value of R is returned in SSMIN, which is used */
/* as the measurement of the linear dependency of the vectors X and Y. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The length of the vectors X and Y. */
/* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX) */
/* On entry, X contains the N-vector X. */
/* On exit, X is overwritten. */
/* INCX (input) INTEGER */
/* The increment between successive elements of X. INCX > 0. */
/* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY) */
/* On entry, Y contains the N-vector Y. */
/* On exit, Y is overwritten. */
/* INCY (input) INTEGER */
/* The increment between successive elements of Y. INCY > 0. */
/* SSMIN (output) DOUBLE PRECISION */
/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--y;
--x;
/* Function Body */
if (*n <= 1) {
*ssmin = 0.;
return 0;
}
/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */
zlarfg_(n, &x[1], &x[*incx + 1], incx, &tau);
a11.r = x[1].r, a11.i = x[1].i;
x[1].r = 1., x[1].i = 0.;
d_cnjg(&z__3, &tau);
z__2.r = -z__3.r, z__2.i = -z__3.i;
zdotc_(&z__4, n, &x[1], incx, &y[1], incy);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i +
z__2.i * z__4.r;
c__.r = z__1.r, c__.i = z__1.i;
zaxpy_(n, &c__, &x[1], incx, &y[1], incy);
i__1 = *n - 1;
zlarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau);
a12.r = y[1].r, a12.i = y[1].i;
i__1 = *incy + 1;
a22.r = y[i__1].r, a22.i = y[i__1].i;
/* Compute the SVD of 2-by-2 Upper triangular matrix. */
d__1 = z_abs(&a11);
d__2 = z_abs(&a12);
d__3 = z_abs(&a22);
dlas2_(&d__1, &d__2, &d__3, ssmin, &ssmax);
return 0;
/* End of ZLAPLL */
} /* zlapll_ */
/* Subroutine */ int zlatme_(integer *n, char *dist, integer *iseed,
doublecomplex *d, integer *mode, doublereal *cond, doublecomplex *
dmax__, char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
integer *modes, doublereal *conds, integer *kl, integer *ku,
doublereal *anorm, doublecomplex *a, integer *lda, doublecomplex *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical bads;
static integer isim;
static doublereal temp;
static integer i, j;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
static integer iinfo;
static doublereal tempa[1];
static integer icols;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer idist;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer irows;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlatm1_(integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *, integer
*), zlatm1_(integer *, doublereal *, integer *, integer *,
integer *, doublecomplex *, integer *, integer *);
static integer ic, jc, ir;
static doublereal ralpha;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zlarge_(integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
static integer irsign;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer iupper;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
static doublecomplex xnorms;
static integer jcr;
static doublecomplex tau;
/* -- LAPACK 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
=======
ZLATME generates random non-symmetric square matrices with
specified eigenvalues for testing LAPACK programs.
ZLATME operates by applying the following sequence of
operations:
1. Set the diagonal to D, where D may be input or
computed according to MODE, COND, DMAX, and RSIGN
as described below.
2. If UPPER='T', the upper triangle of A is set to random values
out of distribution DIST.
3. If SIM='T', A is multiplied on the left by a random matrix
X, whose singular values are specified by DS, MODES, and
CONDS, and on the right by X inverse.
4. If KL < N-1, the lower bandwidth is reduced to KL using
Householder transformations. If KU < N-1, the upper
bandwidth is reduced to KU.
5. If ANORM is not negative, the matrix is scaled to have
maximum-element-norm ANORM.
(Note: since the matrix cannot be reduced beyond Hessenberg form,
no packing options are available.)
Arguments
=========
N - INTEGER
The number of columns (or rows) of A. Not modified.
DIST - CHARACTER*1
On entry, DIST specifies the type of distribution to be used
to generate the random eigen-/singular values, and on the
upper triangle (see UPPER).
'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
'N' => NORMAL( 0, 1 ) ( 'N' for normal )
'D' => uniform on the complex disc |z| < 1.
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. They should lie between 0 and 4095 inclusive,
and ISEED(4) should be odd. The random number generator
uses a linear congruential sequence limited to small
integers, and so should produce machine independent
random numbers. The values of ISEED are changed on
exit, and can be used in the next call to ZLATME
to continue the same random number sequence.
Changed on exit.
D - COMPLEX*16 array, dimension ( N )
This array is used to specify the eigenvalues of A. If
MODE=0, then D is assumed to contain the eigenvalues
otherwise they will be computed according to MODE, COND,
DMAX, and RSIGN and placed in D.
Modified if MODE is nonzero.
MODE - INTEGER
On entry this describes how the eigenvalues are to
be specified:
MODE = 0 means use D as input
MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
MODE = 5 sets D to random numbers in the range
( 1/COND , 1 ) such that their logarithms
are uniformly distributed.
MODE = 6 set D to random numbers from same distribution
as the rest of the matrix.
MODE < 0 has the same meaning as ABS(MODE), except that
the order of the elements of D is reversed.
Thus if MODE is between 1 and 4, D has entries ranging
from 1 to 1/COND, if between -1 and -4, D has entries
ranging from 1/COND to 1,
Not modified.
COND - DOUBLE PRECISION
On entry, this is used as described under MODE above.
If used, it must be >= 1. Not modified.
DMAX - COMPLEX*16
If MODE is neither -6, 0 nor 6, the contents of D, as
computed according to MODE and COND, will be scaled by
DMAX / max(abs(D(i))). Note that DMAX need not be
positive or real: if DMAX is negative or complex (or zero),
D will be scaled by a negative or complex number (or zero).
If RSIGN='F' then the largest (absolute) eigenvalue will be
equal to DMAX.
Not modified.
EI - CHARACTER*1 (ignored)
Not modified.
RSIGN - CHARACTER*1
If MODE is not 0, 6, or -6, and RSIGN='T', then the
elements of D, as computed according to MODE and COND, will
be multiplied by a random complex number from the unit
circle |z| = 1. If RSIGN='F', they will not be. RSIGN may
only have the values 'T' or 'F'.
Not modified.
UPPER - CHARACTER*1
If UPPER='T', then the elements of A above the diagonal
will be set to random numbers out of DIST. If UPPER='F',
they will not. UPPER may only have the values 'T' or 'F'.
Not modified.
SIM - CHARACTER*1
If SIM='T', then A will be operated on by a "similarity
transform", i.e., multiplied on the left by a matrix X and
on the right by X inverse. X = U S V, where U and V are
random unitary matrices and S is a (diagonal) matrix of
singular values specified by DS, MODES, and CONDS. If
SIM='F', then A will not be transformed.
Not modified.
DS - DOUBLE PRECISION array, dimension ( N )
This array is used to specify the singular values of X,
in the same way that D specifies the eigenvalues of A.
If MODE=0, the DS contains the singular values, which
may not be zero.
Modified if MODE is nonzero.
MODES - INTEGER
CONDS - DOUBLE PRECISION
Similar to MODE and COND, but for specifying the diagonal
of S. MODES=-6 and +6 are not allowed (since they would
result in randomly ill-conditioned eigenvalues.)
KL - INTEGER
This specifies the lower bandwidth of the matrix. KL=1
specifies upper Hessenberg form. If KL is at least N-1,
then A will have full lower bandwidth.
Not modified.
KU - INTEGER
This specifies the upper bandwidth of the matrix. KU=1
specifies lower Hessenberg form. If KU is at least N-1,
then A will have full upper bandwidth; if KU and KL
are both at least N-1, then A will be dense. Only one of
KU and KL may be less than N-1.
Not modified.
ANORM - DOUBLE PRECISION
If ANORM is not negative, then A will be scaled by a non-
negative real number to make the maximum-element-norm of A
to be ANORM.
Not modified.
A - COMPLEX*16 array, dimension ( LDA, N )
On exit A is the desired test matrix.
Modified.
LDA - INTEGER
LDA specifies the first dimension of A as declared in the
calling program. LDA must be at least M.
Not modified.
WORK - COMPLEX*16 array, dimension ( 3*N )
Workspace.
Modified.
INFO - INTEGER
Error code. On exit, INFO will be set to one of the
following values:
0 => normal return
-1 => N negative
-2 => DIST illegal string
-5 => MODE not in range -6 to 6
-6 => COND less than 1.0, and MODE neither -6, 0 nor 6
-9 => RSIGN is not 'T' or 'F'
-10 => UPPER is not 'T' or 'F'
-11 => SIM is not 'T' or 'F'
-12 => MODES=0 and DS has a zero singular value.
-13 => MODES is not in the range -5 to 5.
-14 => MODES is nonzero and CONDS is less than 1.
-15 => KL is less than 1.
-16 => KU is less than 1, or KL and KU are both less than
N-1.
-19 => LDA is less than M.
1 => Error return from ZLATM1 (computing D)
2 => Cannot scale to DMAX (max. eigenvalue is 0)
3 => Error return from DLATM1 (computing DS)
4 => Error return from ZLARGE
5 => Zero singular value from DLATM1.
=====================================================================
1) Decode and Test the input parameters.
Initialize flags & seed.
Parameter adjustments */
--iseed;
--d;
--ds;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else if (lsame_(dist, "D")) {
idist = 4;
} else {
idist = -1;
}
/* Decode RSIGN */
if (lsame_(rsign, "T")) {
irsign = 1;
} else if (lsame_(rsign, "F")) {
irsign = 0;
} else {
irsign = -1;
}
/* Decode UPPER */
if (lsame_(upper, "T")) {
iupper = 1;
} else if (lsame_(upper, "F")) {
iupper = 0;
} else {
iupper = -1;
}
/* Decode SIM */
if (lsame_(sim, "T")) {
isim = 1;
} else if (lsame_(sim, "F")) {
isim = 0;
} else {
isim = -1;
}
/* Check DS, if MODES=0 and ISIM=1 */
bads = FALSE_;
if (*modes == 0 && isim == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ds[j] == 0.) {
bads = TRUE_;
}
/* L10: */
}
}
/* Set INFO if an error */
if (*n < 0) {
*info = -1;
} else if (idist == -1) {
*info = -2;
} else if (abs(*mode) > 6) {
*info = -5;
} else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
*info = -6;
} else if (irsign == -1) {
*info = -9;
} else if (iupper == -1) {
*info = -10;
} else if (isim == -1) {
*info = -11;
} else if (bads) {
*info = -12;
} else if (isim == 1 && abs(*modes) > 5) {
*info = -13;
} else if (isim == 1 && *modes != 0 && *conds < 1.) {
*info = -14;
} else if (*kl < 1) {
*info = -15;
} else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
*info = -16;
} else if (*lda < max(1,*n)) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATME", &i__1);
return 0;
}
/* Initialize random number generator */
for (i = 1; i <= 4; ++i) {
iseed[i] = (i__1 = iseed[i], abs(i__1)) % 4096;
/* L20: */
}
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* 2) Set up diagonal of A
Compute D according to COND and MODE */
zlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d[1], n, &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && abs(*mode) != 6) {
/* Scale by DMAX */
temp = z_abs(&d[1]);
i__1 = *n;
for (i = 2; i <= i__1; ++i) {
/* Computing MAX */
d__1 = temp, d__2 = z_abs(&d[i]);
temp = max(d__1,d__2);
/* L30: */
}
if (temp > 0.) {
z__1.r = dmax__->r / temp, z__1.i = dmax__->i / temp;
alpha.r = z__1.r, alpha.i = z__1.i;
} else {
*info = 2;
return 0;
}
zscal_(n, &alpha, &d[1], &c__1);
}
zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
i__1 = *lda + 1;
zcopy_(n, &d[1], &c__1, &a[a_offset], &i__1);
/* 3) If UPPER='T', set upper triangle of A to random numbers. */
if (iupper != 0) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - 1;
zlarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]);
/* L40: */
}
}
/* 4) If SIM='T', apply similarity transformation.
-1
Transform is X A X , where X = U S V, thus
it is U S V A V' (1/S) U' */
if (isim != 0) {
/* Compute S (singular values of the eigenvector matrix)
according to CONDS and MODES */
dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
/* Multiply by V and V' */
zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
/* Multiply by S and (1/S) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zdscal_(n, &ds[j], &a[j + a_dim1], lda);
if (ds[j] != 0.) {
d__1 = 1. / ds[j];
zdscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
} else {
*info = 5;
return 0;
}
/* L50: */
}
/* Multiply by U and U' */
zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
}
/* 5) Reduce the bandwidth. */
if (*kl < *n - 1) {
/* Reduce bandwidth -- kill column */
i__1 = *n - 1;
for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
ic = jcr - *kl;
irows = *n + 1 - jcr;
icols = *n + *kl - jcr;
zcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
xnorms.r = work[1].r, xnorms.i = work[1].i;
zlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
d_cnjg(&z__1, &tau);
tau.r = z__1.r, tau.i = z__1.i;
work[1].r = 1., work[1].i = 0.;
zlarnd_(&z__1, &c__5, &iseed[1]);
alpha.r = z__1.r, alpha.i = z__1.i;
zgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1],
lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1);
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&irows, &icols, &z__1, &work[1], &c__1, &work[irows + 1], &
c__1, &a[jcr + (ic + 1) * a_dim1], lda);
zgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1],
&c__1, &c_b1, &work[irows + 1], &c__1);
d_cnjg(&z__2, &tau);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(n, &irows, &z__1, &work[irows + 1], &c__1, &work[1], &c__1,
&a[jcr * a_dim1 + 1], lda);
i__2 = jcr + ic * a_dim1;
a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
i__2 = irows - 1;
zlaset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic *
a_dim1], lda);
i__2 = icols + 1;
zscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda);
d_cnjg(&z__1, &alpha);
zscal_(n, &z__1, &a[jcr * a_dim1 + 1], &c__1);
/* L60: */
}
} else if (*ku < *n - 1) {
/* Reduce upper bandwidth -- kill a row at a time. */
i__1 = *n - 1;
for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
ir = jcr - *ku;
irows = *n + *ku - jcr;
icols = *n + 1 - jcr;
zcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
xnorms.r = work[1].r, xnorms.i = work[1].i;
zlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
d_cnjg(&z__1, &tau);
tau.r = z__1.r, tau.i = z__1.i;
work[1].r = 1., work[1].i = 0.;
i__2 = icols - 1;
zlacgv_(&i__2, &work[2], &c__1);
zlarnd_(&z__1, &c__5, &iseed[1]);
alpha.r = z__1.r, alpha.i = z__1.i;
zgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda,
&work[1], &c__1, &c_b1, &work[icols + 1], &c__1);
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&irows, &icols, &z__1, &work[icols + 1], &c__1, &work[1], &
c__1, &a[ir + 1 + jcr * a_dim1], lda);
zgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], &
c__1, &c_b1, &work[icols + 1], &c__1);
d_cnjg(&z__2, &tau);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&icols, n, &z__1, &work[1], &c__1, &work[icols + 1], &c__1,
&a[jcr + a_dim1], lda);
i__2 = ir + jcr * a_dim1;
a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
i__2 = icols - 1;
zlaset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) *
a_dim1], lda);
i__2 = irows + 1;
zscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1);
d_cnjg(&z__1, &alpha);
zscal_(n, &z__1, &a[jcr + a_dim1], lda);
/* L70: */
}
}
/* Scale the matrix to have norm ANORM */
if (*anorm >= 0.) {
temp = zlange_("M", n, n, &a[a_offset], lda, tempa);
if (temp > 0.) {
ralpha = *anorm / temp;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zdscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1);
/* L80: */
}
}
}
return 0;
/* End of ZLATME */
} /* zlatme_ */
/*< SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) >*/
/* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k;
doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *,
ftnlen), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
/* -- LAPACK routine (version 3.2.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* June 2010 */
/* .. Scalar Arguments .. */
/*< INTEGER INFO, LDA, M, N >*/
/* .. */
/* .. Array Arguments .. */
/*< COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* ZGEQR2 computes a QR factorization of a complex m by n matrix A: */
/* A = Q * R. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, the elements on and above the diagonal of the array */
/* contain the min(m,n) by n upper trapezoidal matrix R (R is */
/* upper triangular if m >= n); the elements below the diagonal, */
/* 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,M). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
/* 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
/* and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/*< COMPLEX*16 ONE >*/
/*< PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I, K >*/
/*< COMPLEX*16 ALPHA >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL XERBLA, ZLARF, ZLARFG >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC DCONJG, MAX, MIN >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/*< INFO = 0 >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/*< IF( M.LT.0 ) THEN >*/
if (*m < 0) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( LDA.LT.MAX( 1, M ) ) THEN >*/
} else if (*lda < max(1,*m)) {
/*< INFO = -4 >*/
*info = -4;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'ZGEQR2', -INFO ) >*/
i__1 = -(*info);
xerbla_("ZGEQR2", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< K = MIN( M, N ) >*/
k = min(*m,*n);
/*< DO 10 I = 1, K >*/
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
/*< >*/
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1]
, &c__1, &tau[i__]);
/*< IF( I.LT.N ) THEN >*/
if (i__ < *n) {
/* Apply H(i)' to A(i:m,i+1:n) from the left */
/*< ALPHA = A( I, I ) >*/
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/*< A( I, I ) = ONE >*/
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/*< >*/
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1,
&a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4);
/*< A( I, I ) = ALPHA >*/
i__2 = i__ + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
/*< END IF >*/
}
/*< 10 CONTINUE >*/
/* L10: */
}
/*< RETURN >*/
return 0;
/* End of ZGEQR2 */
/*< END >*/
} /* zgeqr2_ */
/*< SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) >*/
/* Subroutine */ int zgehd2_(integer *n, integer *ilo, integer *ihi,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__;
doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *,
ftnlen), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
/* -- 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 */
/* .. Scalar Arguments .. */
/*< INTEGER IHI, ILO, INFO, LDA, N >*/
/* .. */
/* .. Array Arguments .. */
/*< COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H */
/* by a unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= max(1,N). */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the n by n general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, 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). */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/*< COMPLEX*16 ONE >*/
/*< PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I >*/
/*< COMPLEX*16 ALPHA >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL XERBLA, ZLARF, ZLARFG >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC DCONJG, MAX, MIN >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/*< INFO = 0 >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/*< IF( N.LT.0 ) THEN >*/
if (*n < 0) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN >*/
} else if (*ilo < 1 || *ilo > max(1,*n)) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN >*/
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
/*< INFO = -3 >*/
*info = -3;
/*< ELSE IF( LDA.LT.MAX( 1, N ) ) THEN >*/
} else if (*lda < max(1,*n)) {
/*< INFO = -5 >*/
*info = -5;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'ZGEHD2', -INFO ) >*/
i__1 = -(*info);
xerbla_("ZGEHD2", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< DO 10 I = ILO, IHI - 1 >*/
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
/*< ALPHA = A( I+1, I ) >*/
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/*< CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) >*/
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[
i__]);
/*< A( I+1, I ) = ONE >*/
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
/*< >*/
i__2 = *ihi - i__;
zlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1], (ftnlen)5);
/* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */
/*< >*/
i__2 = *ihi - i__;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &z__1,
&a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4);
/*< A( I+1, I ) = ALPHA >*/
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< RETURN >*/
return 0;
/* End of ZGEHD2 */
/*< END >*/
} /* zgehd2_ */
/* Subroutine */ int zgebd2_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq,
doublecomplex *taup, doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *,
ftnlen), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *,
integer *);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEBD2 reduces a complex general m by n matrix A to upper or lower */
/* real bidiagonal form B by a unitary transformation: Q' * A * P = B. */
/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, */
/* if m >= n, the diagonal and the first superdiagonal are */
/* overwritten with the upper bidiagonal matrix B; the */
/* elements below the diagonal, with the array TAUQ, represent */
/* the unitary matrix Q as a product of elementary */
/* reflectors, and the elements above the first superdiagonal, */
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors; */
/* if m < n, the diagonal and the first subdiagonal are */
/* overwritten with the lower bidiagonal matrix B; the */
/* elements below the first subdiagonal, with the array TAUQ, */
/* represent the unitary matrix Q as a product of */
/* elementary reflectors, and the elements above the diagonal, */
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
/* The off-diagonal elements of the bidiagonal matrix B: */
/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
/* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix Q. See Further Details. */
/* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix P. See Further Details. */
/* WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* If m >= n, */
/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, and v and u are complex */
/* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */
/* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */
/* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, */
/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, v and u are complex vectors; */
/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The contents of A on exit are illustrated by the following examples: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
/* ( v1 v2 v3 v4 v5 ) */
/* where d and e denote diagonal and off-diagonal elements of B, vi */
/* denotes an element of the vector defining H(i), and ui an element of */
/* the vector defining G(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZGEBD2", &i__1, (ftnlen)6);
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1, &
tauq[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply H(i)' to A(i:m,i+1:n) from the left */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tauq[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1,
&a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4);
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
if (i__ < *n) {
/* Generate elementary reflector G(i) to annihilate */
/* A(i,i+2:n) */
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, &
taup[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + (i__ + 1) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__;
zlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1], (ftnlen)5);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + (i__ + 1) * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.;
} else {
i__2 = i__;
taup[i__2].r = 0., taup[i__2].i = 0.;
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, &
taup[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply G(i) to A(i+1:m,i:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
/* Computing MIN */
i__4 = i__ + 1;
zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &taup[
i__], &a[min(i__4,*m) + i__ * a_dim1], lda, &work[1], (
ftnlen)5);
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
if (i__ < *m) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:m,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1,
&tauq[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply H(i)' to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__;
i__3 = *n - i__;
d_cnjg(&z__1, &tauq[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
c__1, &z__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &
work[1], (ftnlen)4);
i__2 = i__ + 1 + i__ * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.;
} else {
i__2 = i__;
tauq[i__2].r = 0., tauq[i__2].i = 0.;
}
/* L20: */
}
}
return 0;
/* End of ZGEBD2 */
} /* zgebd2_ */
/* Subroutine */
int zgeqr2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k;
doublecomplex alpha;
extern /* Subroutine */
int zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *);
/* -- 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*m))
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZGEQR2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1] , &c__1, &tau[i__]);
if (i__ < *n)
{
/* Apply H(i)**H to A(i:m,i+1:n) from the left */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1.;
a[i__2].i = 0.; // , expr subst
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = alpha.r;
a[i__2].i = alpha.i; // , expr subst
}
/* L10: */
}
return 0;
/* End of ZGEQR2 */
}
/* Subroutine */ int zdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, doublereal *
thrshn, integer *nounit, doublecomplex *a, integer *lda,
doublecomplex *b, doublecomplex *s, doublecomplex *t, doublecomplex *
s2, doublecomplex *t2, doublecomplex *q, integer *ldq, doublecomplex *
z__, doublecomplex *alpha1, doublecomplex *beta1, doublecomplex *
alpha2, doublecomplex *beta2, doublecomplex *vl, doublecomplex *vr,
doublecomplex *work, integer *lwork, doublereal *rwork, doublereal *
result, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 ZDRVGG: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZDRVGG: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
" problem driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see ZDRVGG for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
" 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
"I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
"B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
"t.\002,/1x)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9,
i__10, i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14, d__15, d__16;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double d_imag(doublecomplex *);
/* Local variables */
integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
doublereal ulp;
integer iadd, nmax;
doublereal temp1, temp2;
logical badnn;
doublereal dumma[4];
integer iinfo;
doublereal rmagn[4];
doublecomplex ctemp;
extern /* Subroutine */ int zgegs_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *), zget51_(integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublereal *, doublereal *), zget52_(logical *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublereal *, doublereal *);
integer nmats, jsize;
extern /* Subroutine */ int zgegv_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
integer nerrs, jtype, ntest;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
integer *, integer *, integer *, integer *, logical *, doublereal
*, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal safmin, safmax;
integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
doublereal ulpinv;
integer lwkopt, mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* Purpose */
/* ======= */
/* ZDRVGG checks the nonsymmetric generalized eigenvalue driver */
/* routines. */
/* T T T */
/* ZGEGS factors A and B as Q S Z and Q T Z , where means */
/* transpose, T is upper triangular, S is in generalized Schur form */
/* (upper triangular), and Q and Z are unitary. It also */
/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=T(j,j) -- */
/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
/* eigenvalue problem */
/* det( A - w(j) B ) = 0 */
/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
/* problem */
/* det( m(j) A - B ) = 0 */
/* ZGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), the matrix L whose columns contain the */
/* generalized left eigenvectors l, and the matrix R whose columns */
/* contain the generalized right eigenvectors r for the pair (A,B). */
/* When ZDRVGG is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
/* tests will be performed and compared with the threshhold THRESH: */
/* Results from ZGEGS: */
/* H */
/* (1) | A - Q S Z | / ( |A| n ulp ) */
/* H */
/* (2) | B - Q T Z | / ( |B| n ulp ) */
/* H */
/* (3) | I - QQ | / ( n ulp ) */
/* H */
/* (4) | I - ZZ | / ( n ulp ) */
/* (5) maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* Results from ZGEGV: */
/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* Test Matrices */
/* ---- -------- */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random unitary matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZDRVGG does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZDRVGG */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZDRVGG to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. It must be at least zero. */
/* THRSHN (input) DOUBLE PRECISION */
/* Threshhold for reporting eigenvector normalization error. */
/* If the normalization of any eigenvector differs from 1 by */
/* more than THRSHN*ulp, then a special error message will be */
/* printed. (This is handled separately from the other tests, */
/* since only a compiler or programming error should cause an */
/* error message, at least if THRSHN is at least 5--10.) */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, T, S2, and T2. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from A by ZGEGS. */
/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by ZGEGS. */
/* S2 (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The matrix computed from A by ZGEGV. This will be the */
/* Schur (upper triangular) form of some matrix related to A, */
/* but will not, in general, be the same as S. */
/* T2 (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The matrix computed from B by ZGEGV. This will be the */
/* Schur form of some matrix related to B, but will not, in */
/* general, be the same as T. */
/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* The (left) unitary matrix computed by ZGEGS. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q, Z, VL, and VR. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* The (right) unitary matrix computed by ZGEGS. */
/* ALPHA1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* BETA1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by ZGEGS. */
/* ALPHA1(k) / BETA1(k) is the k-th generalized eigenvalue of */
/* the matrices in A and B. */
/* ALPHA2 (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* BETA2 (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by ZGEGV. */
/* ALPHA2(k) / BETA2(k) is the k-th generalized eigenvalue of */
/* the matrices in A and B. */
/* VL (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* The (lower triangular) left eigenvector matrix for the */
/* matrices in A and B. */
/* VR (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* The (upper triangular) right eigenvector matrix for the */
/* matrices in A and B. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* MAX( 2*N, N*(NB+1), (k+1)*(2*k+N+1) ), where "k" is the */
/* sum of the blocksize and number-of-shifts for ZHGEQZ, and */
/* NB is the greatest of the blocksizes for ZGEQRF, ZUNMQR, */
/* and ZUNGQR. (The blocksizes and the number-of-shifts are */
/* retrieved through calls to ILAENV.) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (8*N) */
/* RESULT (output) DOUBLE PRECISION array, dimension (7) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
s2_dim1 = *lda;
s2_offset = 1 + s2_dim1;
s2 -= s2_offset;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
vr_dim1 = *ldq;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *ldq;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alpha1;
--beta1;
--alpha2;
--beta2;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Maximum blocksize and shift -- we assume that blocksize and number */
/* of shifts are monotone increasing functions of N. */
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "ZUNGQR",
" ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
nbz = ilaenv_(&c__1, "ZHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
ns = ilaenv_(&c__4, "ZHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
i1 = nbz + ns;
/* Computing MAX */
i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
i1 << 1) + nmax + 1) * (i1 + 1);
lwkopt = max(i__1,i__2);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -10;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -19;
} else if (lwkopt > *lwork) {
*info = -30;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRVGG", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L150;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 7; ++j) {
result[j] = 0.;
/* L30: */
}
/* Compute A and B */
/* Description of control parameters: */
/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* LASIGN: .TRUE. if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number. */
/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = iadd + iadd * a_dim1;
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b39, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = iadd + iadd * b_dim1;
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = jr + jc * q_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
q[i__5].r = z__1.r, q[i__5].i = z__1.i;
i__5 = jr + jc * z_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L40: */
}
i__4 = n + 1 - jc;
zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = jc + jc * q_dim1;
d__2 = q[i__5].r;
d__1 = d_sign(&c_b39, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * q_dim1;
q[i__4].r = 1., q[i__4].i = 0.;
i__4 = n + 1 - jc;
zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = jc + jc * z_dim1;
d__2 = z__[i__5].r;
d__1 = d_sign(&c_b39, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * z_dim1;
z__[i__4].r = 1., z__[i__4].i = 0.;
/* L50: */
}
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * q_dim1;
q[i__3].r = 1., q[i__3].i = 0.;
i__3 = n;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n * 3;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * z_dim1;
z__[i__3].r = 1., z__[i__3].i = 0.;
i__3 = n << 1;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n << 2;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * a_dim1;
z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
z__1.i = z__2.r * a[i__7].i + z__2.i * a[
i__7].r;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * b_dim1;
z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
z__1.i = z__2.r * b[i__7].i + z__2.i * b[
i__7].r;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = kamagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = kbmagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
/* Call ZGEGS to compute H, T, Q, Z, alpha, and beta. */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = 1;
result[1] = ulpinv;
zgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
ldq, &work[1], lwork, &rwork[1], &iinfo);
if (iinfo != 0) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "ZGEGS", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L130;
}
ntest = 4;
/* Do tests 1--4 */
zget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
&result[1]);
zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
&result[2]);
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1], &
result[3]);
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
&result[4]);
/* Do test 5: compare eigenvalues with diagonals. */
temp1 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j + j * s_dim1;
z__2.r = alpha1[i__4].r - s[i__5].r, z__2.i = alpha1[i__4].i
- s[i__5].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__6 = j;
i__7 = j + j * t_dim1;
z__4.r = beta1[i__6].r - t[i__7].r, z__4.i = beta1[i__6].i -
t[i__7].i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__8 = j;
i__9 = j + j * s_dim1;
d__13 = safmin, d__14 = (d__1 = alpha1[i__8].r, abs(d__1)) + (
d__2 = d_imag(&alpha1[j]), abs(d__2)), d__13 = max(
d__13,d__14), d__14 = (d__3 = s[i__9].r, abs(d__3)) +
(d__4 = d_imag(&s[j + j * s_dim1]), abs(d__4));
/* Computing MAX */
i__10 = j;
i__11 = j + j * t_dim1;
d__15 = safmin, d__16 = (d__5 = beta1[i__10].r, abs(d__5)) + (
d__6 = d_imag(&beta1[j]), abs(d__6)), d__15 = max(
d__15,d__16), d__16 = (d__7 = t[i__11].r, abs(d__7))
+ (d__8 = d_imag(&t[j + j * t_dim1]), abs(d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&z__1),
abs(d__10))) / max(d__13,d__14) + ((d__11 = z__3.r,
abs(d__11)) + (d__12 = d_imag(&z__3), abs(d__12))) /
max(d__15,d__16)) / ulp;
temp1 = max(temp1,temp2);
/* L120: */
}
result[5] = temp1;
/* Call ZGEGV to compute S2, T2, VL, and VR, do tests. */
/* Eigenvalues and Eigenvectors */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
ntest = 6;
result[6] = ulpinv;
zgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
alpha2[1], &beta2[1], &vl[vl_offset], ldq, &vr[vr_offset],
ldq, &work[1], lwork, &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L130;
}
ntest = 7;
/* Do Tests 6 and 7 */
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
vl_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
1], dumma);
result[6] = dumma[0];
if (dumma[1] > *thrshn) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
vr_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
1], dumma);
result[7] = dumma[0];
if (dumma[1] > *thresh) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L130:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "ZGG", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Unitary", (ftnlen)7);
e_wsfe();
/* Tests performed */
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "*", (ftnlen)1);
do_fio(&c__1, "conjugate transpose", (ftnlen)19);
for (j = 1; j <= 5; ++j) {
do_fio(&c__1, "*", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L140: */
}
L150:
;
}
/* L160: */
}
/* Summary */
alasvm_("ZGG", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of ZDRVGG */
} /* zdrvgg_ */
/* Subroutine */ int zlahr2_(integer *n, integer *k, integer *nb,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t,
integer *ldt, doublecomplex *y, integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
integer i__;
doublecomplex ei;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemm_(char *, char *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztrmm_(char *, char *, char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrmv_(char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *,
doublecomplex *, integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an unitary similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by ZGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX*16 array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) COMPLEX*16 array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's ZLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = i__ - 1;
zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
i__2 = *n - *k;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b2, &a[*k + 1 +
i__ * a_dim1], &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
ztrmv_("Lower", "Conjugate transpose", "UNIT", &i__2, &a[*k + 1 +
a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
t[*nb * t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
ztrmv_("Upper", "Conjugate transpose", "NON-UNIT", &i__2, &t[
t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
ztrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
a[i__2].r = ei.r, a[i__2].i = ei.i;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
zlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
i__2 = *k + i__ + i__ * a_dim1;
ei.r = a[i__2].r, ei.i = a[i__2].i;
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
zgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b2, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
i__ * t_dim1 + 1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b2, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
zscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
ztrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
a[i__1].r = ei.r, a[i__1].i = ei.i;
/* Compute Y(1:K,1:NB) */
zlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
ztrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b2, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
zgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b2, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b2,
&y[y_offset], ldy);
}
ztrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b2, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of ZLAHR2 */
} /* zlahr2_ */
/* Subroutine */
int zlaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublecomplex *h__, integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__, integer *ldz, integer *ns, integer *nd, doublecomplex *sh, doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t, integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv, doublecomplex *work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublecomplex s;
integer jw;
doublereal foo;
integer kln;
doublecomplex tau;
integer knt;
doublereal ulp;
integer lwk1, lwk2;
doublecomplex beta;
integer kcol, info, ifst, ilst, ltop, krow;
extern /* Subroutine */
int zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *);
integer infqr;
extern /* Subroutine */
int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *);
integer kwtop;
extern /* Subroutine */
int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
doublereal safmin, safmax;
extern /* Subroutine */
int zgehrd_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *, logical *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *);
doublereal smlnum;
extern /* Subroutine */
int ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *);
integer lwkopt;
extern /* Subroutine */
int zunmhr_(char *, char *, integer *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * );
/* -- LAPACK auxiliary 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sh;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw;
i__2 = *kbot - *ktop + 1; // , expr subst
jw = min(i__1,i__2);
if (jw <= 2)
{
lwkopt = 1;
}
else
{
/* ==== Workspace query call to ZGEHRD ==== */
i__1 = jw - 1;
zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info);
lwk1 = (integer) work[1].r;
/* ==== Workspace query call to ZUNMHR ==== */
i__1 = jw - 1;
zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1].r;
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1)
{
d__1 = (doublereal) lwkopt;
z__1.r = d__1;
z__1.i = 0.; // , expr subst
work[1].r = z__1.r;
work[1].i = z__1.i; // , expr subst
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1].r = 1.;
work[1].i = 0.; // , expr subst
if (*ktop > *kbot)
{
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1)
{
return 0;
}
/* ==== Machine constants ==== */
safmin = dlamch_("SAFE MINIMUM");
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_("PRECISION");
smlnum = safmin * ((doublereal) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw;
i__2 = *kbot - *ktop + 1; // , expr subst
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop)
{
s.r = 0.;
s.i = 0.; // , expr subst
}
else
{
i__1 = kwtop + (kwtop - 1) * h_dim1;
s.r = h__[i__1].r;
s.i = h__[i__1].i; // , expr subst
}
if (*kbot == kwtop)
{
/* ==== 1-by-1 deflation window: not much to do ==== */
i__1 = kwtop;
i__2 = kwtop + kwtop * h_dim1;
sh[i__1].r = h__[i__2].r;
sh[i__1].i = h__[i__2].i; // , expr subst
*ns = 1;
*nd = 0;
/* Computing MAX */
i__1 = kwtop + kwtop * h_dim1;
d__5 = smlnum;
d__6 = ulp * ((d__1 = h__[i__1].r, f2c_abs(d__1)) + (d__2 = d_imag(&h__[kwtop + kwtop * h_dim1]), f2c_abs(d__2))); // , expr subst
if ((d__3 = s.r, f2c_abs(d__3)) + (d__4 = d_imag(&s), f2c_abs(d__4)) <= max( d__5,d__6))
{
*ns = 0;
*nd = 1;
if (kwtop > *ktop)
{
i__1 = kwtop + (kwtop - 1) * h_dim1;
h__[i__1].r = 0.;
h__[i__1].i = 0.; // , expr subst
}
}
work[1].r = 1.;
work[1].i = 0.; // , expr subst
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
zlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3);
zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
i__1 = jw;
for (knt = infqr + 1;
knt <= i__1;
++knt)
{
/* ==== Small spike tip deflation test ==== */
i__2 = *ns + *ns * t_dim1;
foo = (d__1 = t[i__2].r, f2c_abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns * t_dim1]), f2c_abs(d__2));
if (foo == 0.)
{
foo = (d__1 = s.r, f2c_abs(d__1)) + (d__2 = d_imag(&s), f2c_abs(d__2));
}
i__2 = *ns * v_dim1 + 1;
/* Computing MAX */
d__5 = smlnum;
d__6 = ulp * foo; // , expr subst
if (((d__1 = s.r, f2c_abs(d__1)) + (d__2 = d_imag(&s), f2c_abs(d__2))) * (( d__3 = v[i__2].r, f2c_abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1 + 1]), f2c_abs(d__4))) <= max(d__5,d__6))
{
/* ==== One more converged eigenvalue ==== */
--(*ns);
}
else
{
/* ==== One undeflatable eigenvalue. Move it up out of the */
/* . way. (ZTREXC can not fail in this case.) ==== */
ifst = *ns;
ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, & ilst, &info);
++ilst;
}
/* L10: */
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0)
{
s.r = 0.;
s.i = 0.; // , expr subst
}
if (*ns < jw)
{
/* ==== sorting the diagonal of T improves accuracy for */
/* . graded matrices. ==== */
i__1 = *ns;
for (i__ = infqr + 1;
i__ <= i__1;
++i__)
{
ifst = i__;
i__2 = *ns;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = j + j * t_dim1;
i__4 = ifst + ifst * t_dim1;
if ((d__1 = t[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag(&t[j + j * t_dim1]), f2c_abs(d__2)) > (d__3 = t[i__4].r, f2c_abs(d__3)) + (d__4 = d_imag(&t[ifst + ifst * t_dim1]), f2c_abs(d__4)) )
{
ifst = j;
}
/* L20: */
}
ilst = i__;
if (ifst != ilst)
{
ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &info);
}
/* L30: */
}
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__1 = jw;
for (i__ = infqr + 1;
i__ <= i__1;
++i__)
{
i__2 = kwtop + i__ - 1;
i__3 = i__ + i__ * t_dim1;
sh[i__2].r = t[i__3].r;
sh[i__2].i = t[i__3].i; // , expr subst
/* L40: */
}
if (*ns < jw || s.r == 0. && s.i == 0.)
{
if (*ns > 1 && (s.r != 0. || s.i != 0.))
{
/* ==== Reflect spike back into lower triangle ==== */
zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
i__1 = *ns;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__;
d_cnjg(&z__1, &work[i__]);
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
/* L50: */
}
beta.r = work[1].r;
beta.i = work[1].i; // , expr subst
zlarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1].r = 1.;
work[1].i = 0.; // , expr subst
i__1 = jw - 2;
i__2 = jw - 2;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
d_cnjg(&z__1, &tau);
zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, & work[jw + 1]);
zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]);
zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]);
i__1 = *lwork - jw;
zgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1)
{
i__1 = kwtop + (kwtop - 1) * h_dim1;
d_cnjg(&z__2, &v[v_dim1 + 1]);
z__1.r = s.r * z__2.r - s.i * z__2.i;
z__1.i = s.r * z__2.i + s.i * z__2.r; // , expr subst
h__[i__1].r = z__1.r;
h__[i__1].i = z__1.i; // , expr subst
}
zlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] , ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
zcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && (s.r != 0. || s.i != 0.))
{
i__1 = *lwork - jw;
zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt)
{
ltop = 1;
}
else
{
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop;
i__2 < 0 ? krow >= i__1 : krow <= i__1;
krow += i__2)
{
/* Computing MIN */
i__3 = *nv;
i__4 = kwtop - krow; // , expr subst
kln = min(i__3,i__4);
zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset], ldwv);
zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh);
/* L60: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt)
{
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1;
i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1)
{
/* Computing MIN */
i__3 = *nh;
i__4 = *n - kcol + 1; // , expr subst
kln = min(i__3,i__4);
zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset], ldt);
zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh);
/* L70: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz)
{
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz;
i__2 < 0 ? krow >= i__1 : krow <= i__1;
krow += i__2)
{
/* Computing MIN */
i__3 = *nv;
i__4 = *ihiz - krow + 1; // , expr subst
kln = min(i__3,i__4);
zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset] , ldwv);
zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz);
/* L80: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting */
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
d__1 = (doublereal) lwkopt;
z__1.r = d__1;
z__1.i = 0.; // , expr subst
work[1].r = z__1.r;
work[1].i = z__1.i; // , expr subst
/* ==== End of ZLAQR2 ==== */
return 0;
}
int zlabrd_(int *m, int *n, int *nb,
doublecomplex *a, int *lda, double *d__, double *e,
doublecomplex *tauq, doublecomplex *taup, doublecomplex *x, int *
ldx, doublecomplex *y, int *ldy)
{
/* System generated locals */
int a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
int i__;
doublecomplex alpha;
extern int zscal_(int *, doublecomplex *,
doublecomplex *, int *), zgemv_(char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *, doublecomplex *, doublecomplex *, int *),
zlarfg_(int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *), zlacgv_(int *, doublecomplex *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLABRD reduces the first NB rows and columns of a complex general */
/* m by n matrix A to upper or lower float bidiagonal form by a unitary */
/* transformation Q' * A * P, and returns the matrices X and Y which */
/* are needed to apply the transformation to the unreduced part of A. */
/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
/* bidiagonal form. */
/* This is an auxiliary routine called by ZGEBRD */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. */
/* NB (input) INTEGER */
/* The number of leading rows and columns of A to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, the first NB rows and columns of the matrix are */
/* overwritten; the rest of the array is unchanged. */
/* If m >= n, elements on and below the diagonal in the first NB */
/* columns, with the array TAUQ, represent the unitary */
/* matrix Q as a product of elementary reflectors; and */
/* elements above the diagonal in the first NB rows, with the */
/* array TAUP, represent the unitary matrix P as a product */
/* of elementary reflectors. */
/* If m < n, elements below the diagonal in the first NB */
/* columns, with the array TAUQ, represent the unitary */
/* matrix Q as a product of elementary reflectors, and */
/* elements on and above the diagonal in the first NB rows, */
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,M). */
/* D (output) DOUBLE PRECISION array, dimension (NB) */
/* The diagonal elements of the first NB rows and columns of */
/* the reduced matrix. D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (NB) */
/* The off-diagonal elements of the first NB rows and columns of */
/* the reduced matrix. */
/* TAUQ (output) COMPLEX*16 array dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix Q. See Further Details. */
/* TAUP (output) COMPLEX*16 array, dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix P. See Further Details. */
/* X (output) COMPLEX*16 array, dimension (LDX,NB) */
/* The m-by-nb matrix X required to update the unreduced part */
/* of A. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= MAX(1,M). */
/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
/* The n-by-nb matrix Y required to update the unreduced part */
/* of A. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= MAX(1,N). */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, and v and u are complex */
/* vectors. */
/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The elements of the vectors v and u together form the m-by-nb matrix */
/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
/* the transformation to the unreduced part of the matrix, using a block */
/* update of the form: A := A - V*Y' - X*U'. */
/* The contents of A on exit are illustrated by the following examples */
/* with nb = 2: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix which is unchanged, */
/* vi denotes an element of the vector defining H(i), and ui an element */
/* of the vector defining G(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda,
&y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + x_dim1], ldx,
&a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ *
a_dim1], &c__1);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[MIN(i__3, *m)+ i__ * a_dim1], &c__1, &
tauq[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
if (i__ < *n) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + (
i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], &
c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ +
a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ +
x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
y[i__ * y_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ +
1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
zlacgv_(&i__, &a[i__ + a_dim1], lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &y[i__ + 1 +
y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + (
i__ + 1) * a_dim1], lda);
zlacgv_(&i__, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ +
1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &
a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
/* Generate reflection P(i) to annihilate A(i,i+2:n) */
i__2 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[i__ + MIN(i__3, *n)* a_dim1], lda, &
taup[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + (i__ + 1) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__
+ 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1
+ y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b1, &x[i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b1, &x[i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *m - i__;
zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i,i:n) */
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + y_dim1], ldy,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1],
lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[i__ *
a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ +
i__ * a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
/* Generate reflection P(i) to annihilate A(i,i+1:n) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[i__ + MIN(i__3, *n)* a_dim1], lda, &
taup[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
if (i__ < *m) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ *
a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ +
y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 +
1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ *
x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *m - i__;
zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
/* Update A(i+1:m,i) */
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ +
1 + i__ * a_dim1], &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &x[i__ + 1 +
x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[
i__ + 1 + i__ * a_dim1], &c__1);
/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[MIN(i__3, *m)+ i__ * a_dim1], &c__1,
&tauq[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1]
, &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__;
zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1
+ x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__, &i__2, &z__1, &a[(i__ + 1)
* a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
} else {
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
}
/* L20: */
}
}
return 0;
/* End of ZLABRD */
} /* zlabrd_ */
/* Subroutine */ int zlatrd_(char *uplo, integer *n, integer *nb,
doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau,
doublecomplex *w, integer *ldw)
{
/* -- LAPACK auxiliary 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
=======
ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
Hermitian tridiagonal form by a unitary similarity
transformation Q' * A * Q, and returns the matrices V and W which are
needed to apply the transformation to the unreduced part of A.
If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
matrix, of which the upper triangle is supplied;
if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
matrix, of which the lower triangle is supplied.
This is an auxiliary routine called by ZHETRD.
Arguments
=========
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A.
NB (input) INTEGER
The number of rows and columns to be reduced.
A (input/output) COMPLEX*16 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 last NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements above the diagonal
with the array TAU, represent the unitary matrix Q as a
product of elementary reflectors;
if UPLO = 'L', the first NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements below the diagonal
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).
E (output) DOUBLE PRECISION array, dimension (N-1)
If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
elements of the last NB columns of the reduced matrix;
if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
the first NB columns of the reduced matrix.
TAU (output) COMPLEX*16 array, dimension (N-1)
The scalar factors of the elementary reflectors, stored in
TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
See Further Details.
W (output) COMPLEX*16 array, dimension (LDW,NB)
The n-by-nb matrix W required to update the unreduced part
of A.
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n) H(n-1) . . . H(n-nb+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:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
and tau in TAU(i-1).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(nb).
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+1:n) is stored on exit in A(i+1:n,i),
and tau in TAU(i).
The elements of the vectors v together form the n-by-nb matrix V
which is needed, with W, to apply the transformation to the unreduced
part of the matrix, using a Hermitian rank-2k update of the form:
A := A - V*W' - W*V'.
The contents of A on exit are illustrated by the following examples
with n = 5 and nb = 2:
if UPLO = 'U': if UPLO = 'L':
( a a a v4 v5 ) ( d )
( a a v4 v5 ) ( 1 d )
( a 1 v5 ) ( v1 1 a )
( d 1 ) ( v1 v2 a a )
( d ) ( v1 v2 a a a )
where d denotes a diagonal element of the reduced matrix, a denotes
an element of the original matrix that is unchanged, and vi denotes
an element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zhemv_(char *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer iw;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *,
doublecomplex *, integer *);
#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 w_subscr(a_1,a_2) (a_2)*w_dim1 + a_1
#define w_ref(a_1,a_2) w[w_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &w_ref(i__, iw + 1), ldw);
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &a_ref(1, i__ + 1),
lda, &w_ref(i__, iw + 1), ldw, &c_b2, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &w_ref(i__, iw + 1), ldw);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &w_ref(1, iw + 1),
ldw, &a_ref(i__, i__ + 1), lda, &c_b2, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate
A(1:i-2,i) */
i__2 = a_subscr(i__ - 1, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = i__ - 1;
zlarfg_(&i__2, &alpha, &a_ref(1, i__), &c__1, &tau[i__ - 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = a_subscr(i__ - 1, i__);
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a_ref(1,
i__), &c__1, &c_b1, &w_ref(1, iw), &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w_ref(
1, iw + 1), ldw, &a_ref(1, i__), &c__1, &c_b1, &
w_ref(i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(1, i__
+ 1), lda, &w_ref(i__ + 1, iw), &c__1, &c_b2, &
w_ref(1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a_ref(
1, i__ + 1), lda, &a_ref(1, i__), &c__1, &c_b1, &
w_ref(i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(1, iw
+ 1), ldw, &w_ref(i__ + 1, iw), &c__1, &c_b2, &
w_ref(1, iw), &c__1);
}
i__2 = i__ - 1;
zscal_(&i__2, &tau[i__ - 1], &w_ref(1, iw), &c__1);
z__3.r = -.5, z__3.i = 0.;
i__2 = i__ - 1;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = i__ - 1;
zdotc_(&z__4, &i__3, &w_ref(1, iw), &c__1, &a_ref(1, i__), &
c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &a_ref(1, i__), &c__1, &w_ref(1, iw), &
c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &w_ref(i__, 1), ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(i__, 1), lda, &
w_ref(i__, 1), ldw, &c_b2, &a_ref(i__, i__), &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &w_ref(i__, 1), ldw);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(i__, 1), ldw, &
a_ref(i__, 1), lda, &c_b2, &a_ref(i__, i__), &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate
A(i+2:n,i) */
i__2 = a_subscr(i__ + 1, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/* Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
zlarfg_(&i__3, &alpha, &a_ref(min(i__2,*n), i__), &c__1, &tau[
i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = a_subscr(i__ + 1, i__);
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
zhemv_("Lower", &i__2, &c_b2, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b1, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w_ref(i__
+ 1, 1), ldw, &a_ref(i__ + 1, i__), &c__1, &c_b1, &
w_ref(1, i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(i__ + 1, 1)
, lda, &w_ref(1, i__), &c__1, &c_b2, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a_ref(i__
+ 1, 1), lda, &a_ref(i__ + 1, i__), &c__1, &c_b1, &
w_ref(1, i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(i__ + 1, 1)
, ldw, &w_ref(1, i__), &c__1, &c_b2, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tau[i__], &w_ref(i__ + 1, i__), &c__1);
z__3.r = -.5, z__3.i = 0.;
i__2 = i__;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = *n - i__;
zdotc_(&z__4, &i__3, &w_ref(i__ + 1, i__), &c__1, &a_ref(i__
+ 1, i__), &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &w_ref(i__
+ 1, i__), &c__1);
}
/* L20: */
}
}
return 0;
/* End of ZLATRD */
} /* zlatrd_ */
/* Subroutine */ int zdrges_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s,
doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__,
doublecomplex *alpha, doublecomplex *beta, doublecomplex *work,
integer *lwork, doublereal *rwork, doublereal *result, logical *bwork,
integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGES: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGES: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized Schur from"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see ZDRGES for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
"Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
" / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
" = A is in Schur form S\002,/\002 6 = difference between (alpha"
",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
" \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
"ulp )\002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
" 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in "
"Schur form S\002,/\002 11 = difference between (alpha,beta) and "
"diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct n"
"umber of \002,\002selected eigenvalues\002,/)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14, d__15, d__16;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j, n, n1, jc, nb, in, jr;
doublereal ulp;
integer iadd, sdim, nmax, rsub;
char sort[1];
doublereal temp1, temp2;
logical badnn;
integer iinfo;
doublereal rmagn[4];
doublecomplex ctemp;
extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *), zgges_(char *, char *, char *, L_fp, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, logical *, integer *);
integer nmats, jsize;
extern /* Subroutine */ int zget54_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublereal *);
integer nerrs, jtype, ntest, isort;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
integer *, integer *, integer *, integer *, logical *, doublereal
*, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *);
logical ilabad;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal safmin, safmax;
integer knteig, ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern logical zlctes_(doublecomplex *, doublecomplex *);
integer minwrk, maxwrk;
doublereal ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
/* problem driver ZGGES. */
/* ZGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate */
/* transpose, S and T are upper triangular (i.e., in generalized Schur */
/* form), and Q and Z are unitary. It also computes the generalized */
/* eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, */
/* w(j) = alpha(j)/beta(j) is a root of the characteristic equation */
/* det( A - w(j) B ) = 0 */
/* Optionally it also reorder the eigenvalues so that a selected */
/* cluster of eigenvalues appears in the leading diagonal block of the */
/* Schur forms. */
/* When ZDRGES is called, a number of matrix "sizes" ("N's") and a */
/* number of matrix "TYPES" are specified. For each size ("N") */
/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
/* and used for testing. For each matrix pair, the following 13 tests */
/* will be performed and compared with the threshhold THRESH except */
/* the tests (5), (11) and (13). */
/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (5) if A is in Schur form (i.e. triangular form) (no sorting of */
/* eigenvalues) */
/* (6) if eigenvalues = diagonal elements of the Schur form (S, T), */
/* i.e., test the maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* (no sorting of eigenvalues) */
/* (7) | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) */
/* (with sorting of eigenvalues). */
/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) if A is in Schur form (i.e. quasi-triangular form) */
/* (with sorting of eigenvalues). */
/* (11) if eigenvalues = diagonal elements of the Schur form (S, T), */
/* i.e. test the maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* (with sorting of eigenvalues). */
/* (12) if sorting worked and SDIM is the number of eigenvalues */
/* which were CELECTed. */
/* Test Matrices */
/* ============= */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* DDRGES does nothing. NSIZES >= 0. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. NN >= 0. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, DDRGES */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A on input. */
/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to DDRGES to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. THRESH >= 0. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, and T. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by ZGGES. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by ZGGES. */
/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by ZGGES. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q and Z. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by ZGGES. */
/* ALPHA (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* BETA (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by ZGGES. */
/* ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A */
/* and B. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 3*N*N. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N ) */
/* Real workspace. */
/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alpha;
--beta;
--work;
--rwork;
--result;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = nmax * 3 * nmax;
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax + nmax * nb, i__2 = nmax * 3 * nmax;
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGES", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over matrix sizes */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
/* Loop over matrix types */
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L180;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 13; ++j) {
result[j] = 0.;
/* L30: */
}
/* Generate test matrices A and B */
/* Description of control parameters: */
/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* LASIGN: .TRUE. if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number. */
/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = iadd + iadd * a_dim1;
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b29, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = iadd + iadd * b_dim1;
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = jr + jc * q_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
q[i__5].r = z__1.r, q[i__5].i = z__1.i;
i__5 = jr + jc * z_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L40: */
}
i__4 = n + 1 - jc;
zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = jc + jc * q_dim1;
d__2 = q[i__5].r;
d__1 = d_sign(&c_b29, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * q_dim1;
q[i__4].r = 1., q[i__4].i = 0.;
i__4 = n + 1 - jc;
zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = jc + jc * z_dim1;
d__2 = z__[i__5].r;
d__1 = d_sign(&c_b29, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * z_dim1;
z__[i__4].r = 1., z__[i__4].i = 0.;
/* L50: */
}
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * q_dim1;
q[i__3].r = 1., q[i__3].i = 0.;
i__3 = n;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n * 3;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * z_dim1;
z__[i__3].r = 1., z__[i__3].i = 0.;
i__3 = n << 1;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n << 2;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * a_dim1;
z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
z__1.i = z__2.r * a[i__7].i + z__2.i * a[
i__7].r;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * b_dim1;
z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
z__1.i = z__2.r * b[i__7].i + z__2.i * b[
i__7].r;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = kamagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = kbmagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
for (i__ = 1; i__ <= 13; ++i__) {
result[i__] = -1.;
/* L120: */
}
/* Test with and without sorting of eigenvalues */
for (isort = 0; isort <= 1; ++isort) {
if (isort == 0) {
*(unsigned char *)sort = 'N';
rsub = 0;
} else {
*(unsigned char *)sort = 'S';
rsub = 5;
}
/* Call ZGGES to compute H, T, Q, Z, alpha, and beta. */
zlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = rsub + 1 + isort;
result[rsub + 1 + isort] = ulpinv;
zgges_("V", "V", sort, (L_fp)zlctes_, &n, &s[s_offset], lda, &
t[t_offset], lda, &sdim, &alpha[1], &beta[1], &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork,
&rwork[1], &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != n + 2) {
result[rsub + 1 + isort] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZGGES", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L160;
}
ntest = rsub + 4;
/* Do tests 1--4 (or tests 7--9 when reordering ) */
if (isort == 0) {
zget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
rwork[1], &result[1]);
zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
rwork[1], &result[2]);
} else {
zget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
s_offset], lda, &t[t_offset], lda, &q[q_offset],
ldq, &z__[z_offset], ldq, &work[1], &result[rsub
+ 2]);
}
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1]
, &result[rsub + 3]);
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[
1], &result[rsub + 4]);
/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
/* check Schur form of A and compare eigenvalues with */
/* diagonals. */
ntest = rsub + 6;
temp1 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
i__4 = j;
i__5 = j + j * s_dim1;
z__2.r = alpha[i__4].r - s[i__5].r, z__2.i = alpha[i__4]
.i - s[i__5].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__6 = j;
i__7 = j + j * t_dim1;
z__4.r = beta[i__6].r - t[i__7].r, z__4.i = beta[i__6].i
- t[i__7].i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__8 = j;
i__9 = j + j * s_dim1;
d__13 = safmin, d__14 = (d__1 = alpha[i__8].r, abs(d__1))
+ (d__2 = d_imag(&alpha[j]), abs(d__2)), d__13 =
max(d__13,d__14), d__14 = (d__3 = s[i__9].r, abs(
d__3)) + (d__4 = d_imag(&s[j + j * s_dim1]), abs(
d__4));
/* Computing MAX */
i__10 = j;
i__11 = j + j * t_dim1;
d__15 = safmin, d__16 = (d__5 = beta[i__10].r, abs(d__5))
+ (d__6 = d_imag(&beta[j]), abs(d__6)), d__15 =
max(d__15,d__16), d__16 = (d__7 = t[i__11].r, abs(
d__7)) + (d__8 = d_imag(&t[j + j * t_dim1]), abs(
d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&
z__1), abs(d__10))) / max(d__13,d__14) + ((d__11 =
z__3.r, abs(d__11)) + (d__12 = d_imag(&z__3),
abs(d__12))) / max(d__15,d__16)) / ulp;
if (j < n) {
i__4 = j + 1 + j * s_dim1;
if (s[i__4].r != 0. || s[i__4].i != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (j > 1) {
i__4 = j + (j - 1) * s_dim1;
if (s[i__4].r != 0. || s[i__4].i != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L130: */
}
result[rsub + 6] = temp1;
if (isort >= 1) {
/* Do test 12 */
ntest = 12;
result[12] = 0.;
knteig = 0;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
if (zlctes_(&alpha[i__], &beta[i__])) {
++knteig;
}
/* L140: */
}
if (sdim != knteig) {
result[13] = ulpinv;
}
}
/* L150: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L160:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, "ZGS", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Unitary", (ftnlen)7);
e_wsfe();
/* Tests performed */
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 8; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L170: */
}
L180:
;
}
/* L190: */
}
/* Summary */
alasvm_("ZGS", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGES */
} /* zdrges_ */
/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w,
doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork,
integer *info)
{
/* -- 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
Purpose
=======
ZHSEQR computes the eigenvalues of a complex upper Hessenberg
matrix H, and, optionally, the matrices T and Z from the Schur
decomposition H = Z T Z**H, where T is an upper triangular matrix
(the Schur form), and Z is the unitary matrix of Schur vectors.
Optionally Z may be postmultiplied into an input unitary matrix Q,
so that this routine can give the Schur factorization of a matrix A
which has been reduced to the Hessenberg form H by the unitary
matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
= 'S': compute eigenvalues and the Schur form T.
COMPZ (input) CHARACTER*1
= 'N': no Schur vectors are computed;
= 'I': Z is initialized to the unit matrix and the matrix Z
of Schur vectors of H is returned;
= 'V': Z must contain an unitary matrix Q on entry, and
the product Q*Z is returned.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to ZGEBAL, and then passed to CGEHRD
when the matrix output by ZGEBAL is reduced to Hessenberg
form. Otherwise ILO and IHI should be set to 1 and N
respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
H (input/output) COMPLEX*16 array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', H contains the upper triangular matrix
T from the Schur decomposition (the Schur form). If
JOB = 'E', the contents of H are unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX*16 array, dimension (N)
The computed eigenvalues. If JOB = 'S', the eigenvalues are
stored in the same order as on the diagonal of the Schur form
returned in H, with W(i) = H(i,i).
Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
If COMPZ = 'N': Z is not referenced.
If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
contains the unitary matrix Z of the Schur vectors of H.
If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
which is assumed to be equal to the unit matrix except for
the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
Normally Q is the unitary matrix generated by ZUNGHR after
the call to ZGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,N).
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
> 0: if INFO = i, ZHSEQR failed to compute all the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
static integer c__4 = 4;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__8 = 8;
static integer c__15 = 15;
static logical c_false = FALSE_;
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4[2],
i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
char ch__1[2];
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static doublereal unfl;
static doublecomplex temp;
static doublereal ovfl;
static integer i__, j, k, l;
static doublecomplex s[225] /* was [15][15] */, v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer itemp;
static doublereal rtemp;
static integer i1, i2;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical initz, wantt, wantz;
static doublereal rwork[1];
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer ii, nh;
extern doublereal dlamch_(char *);
static integer nr, ns, nv;
static doublecomplex vv[16];
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *), zlarfx_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static doublereal smlnum;
static logical lquery;
static integer itn;
static doublecomplex tau;
static integer its;
static doublereal ulp, tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define s_subscr(a_1,a_2) (a_2)*15 + a_1 - 16
#define s_ref(a_1,a_2) s[s_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
*info = 0;
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
lquery = *lwork == -1;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -10;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by ZGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = h___subscr(i__, j);
h__[i__3].r = 0., h__[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
} else {
i1 = *ilo;
i2 = *ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (i__ < *ihi) {
i__2 = h___subscr(i__ + 1, i__);
i__3 = h___subscr(i__ + 1, i__);
z__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, z__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
}
if (wantz) {
zscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
}
}
/* L50: */
}
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
zlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(2,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 1 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L60:
if (i__ < *ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__5 = h___subscr(k, k);
tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h___ref(
k - 1, k - 1)), abs(d__2)) + ((d__3 = h__[i__5].r, abs(
d__3)) + (d__4 = d_imag(&h___ref(k, k)), abs(d__4)));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = zlanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0., h__[i__2].i = 0.;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L170;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
i__3 = ii;
i__5 = h___subscr(ii, ii - 1);
i__6 = h___subscr(ii, ii);
d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = h__[i__6].r,
abs(d__2))) * 1.5;
w[i__3].r = d__3, w[i__3].i = 0.;
/* L90: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
zlacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &w[i__ -
ns + 1], &c__1, &ns, &z__[z_offset], ldz, &ierr);
if (ierr > 0) {
/* If ZLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = i__ - ns + ii;
i__5 = s_subscr(ii, ii);
w[i__3].r = s[i__5].r, w[i__3].i = s[i__5].i;
/* L100: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in W). The result is
stored in the local array V. */
v[0].r = 1., v[0].i = 0.;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0., v[i__3].i = 0.;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
zcopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
z__1.r = -w[i__5].r, z__1.i = -w[i__5].i;
zgemv_("No transpose", &i__3, &nv, &c_b2, &h___ref(l, l), ldh, vv,
&c__1, &z__1, v, &c__1);
++nv;
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = izamax_(&nv, v, &c__1);
i__3 = itemp - 1;
rtemp = (d__1 = v[i__3].r, abs(d__1)) + (d__2 = d_imag(&v[itemp -
1]), abs(d__2));
if (rtemp == 0.) {
v[0].r = 1., v[0].i = 0.;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0., v[i__5].i = 0.;
/* L120: */
}
} else {
rtemp = max(rtemp,smlnum);
d__1 = 1. / rtemp;
zdscal_(&nv, &d__1, v, &c__1);
}
/* L130: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__3,i__5);
if (k > l) {
zcopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
zlarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = i__;
for (ii = k + 1; ii <= i__3; ++ii) {
i__5 = h___subscr(ii, k - 1);
h__[i__5].r = 0., h__[i__5].i = 0.;
/* L140: */
}
}
v[0].r = 1., v[0].i = 0.;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
d_cnjg(&z__1, &tau);
zlarfx_("Left", &nr, &i__3, v, &z__1, &h___ref(k, k), ldh, &work[
1]);
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i__) - i1 + 1;
zlarfx_("Right", &i__3, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
if (wantz) {
/* Accumulate transformations in the matrix Z */
zlarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
}
/* L150: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (wantz) {
zscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
}
}
/* L160: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L170:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
zlahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &w[1], ilo, ihi,
&z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L60;
L180:
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
return 0;
/* End of ZHSEQR */
} /* zhseqr_ */
/* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *work, 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
=======
ZGEQR2 computes a QR factorization of a complex m by n matrix A:
A = Q * R.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the m by n matrix A.
On exit, the elements on and above the diagonal of the array
contain the min(m,n) by n upper trapezoidal matrix R (R is
upper triangular if m >= n); the elements below the diagonal,
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,M).
TAU (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) COMPLEX*16 array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(k), where k = min(m,n).
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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
and tau in TAU(i).
=====================================================================
Test the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, k;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQR2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
Computing MIN */
i__2 = i__ + 1;
i__3 = *m - i__ + 1;
zlarfg_(&i__3, &a_ref(i__, i__), &a_ref(min(i__2,*m), i__), &c__1, &
tau[i__]);
if (i__ < *n) {
/* Apply H(i)' to A(i:m,i+1:n) from the left */
i__2 = a_subscr(i__, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = a_subscr(i__, i__);
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &z__1, &
a_ref(i__, i__ + 1), lda, &work[1]);
i__2 = a_subscr(i__, i__);
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
}
/* L10: */
}
return 0;
/* End of ZGEQR2 */
} /* zgeqr2_ */
/* Subroutine */ int zgelq2_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *work, 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
=======
ZGELQ2 computes an LQ factorization of a complex m by n matrix A:
A = L * Q.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the m by n matrix A.
On exit, the elements on and below the diagonal of the array
contain the m by min(m,n) lower trapezoidal matrix L (L is
lower triangular if m <= n); the elements above the diagonal,
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,M).
TAU (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) COMPLEX*16 array, dimension (M)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
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-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
A(i,i+1:n), and tau in TAU(i).
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i, k;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *,
integer *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGELQ2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i = 1; i <= k; ++i) {
/* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
*/
i__2 = *n - i + 1;
zlacgv_(&i__2, &A(i,i), lda);
i__2 = i + i * a_dim1;
alpha.r = A(i,i).r, alpha.i = A(i,i).i;
i__2 = *n - i + 1;
/* Computing MIN */
i__3 = i + 1;
zlarfg_(&i__2, &alpha, &A(i,min(i+1,*n)), lda, &TAU(i));
if (i < *m) {
/* Apply H(i) to A(i+1:m,i:n) from the right */
i__2 = i + i * a_dim1;
A(i,i).r = 1., A(i,i).i = 0.;
i__2 = *m - i;
i__3 = *n - i + 1;
zlarf_("Right", &i__2, &i__3, &A(i,i), lda, &TAU(i), &
A(i+1,i), lda, &WORK(1));
}
i__2 = i + i * a_dim1;
A(i,i).r = alpha.r, A(i,i).i = alpha.i;
i__2 = *n - i + 1;
zlacgv_(&i__2, &A(i,i), lda);
/* L10: */
}
return 0;
/* End of ZGELQ2 */
} /* zgelq2_ */
/* Subroutine */ int zgehd2_(integer *n, integer *ilo, integer *ihi,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__;
doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H */
/* by a unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= max(1,N). */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the n by n general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, 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). */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
zlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
/* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &z__1,
&a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
/* L10: */
}
return 0;
/* End of ZGEHD2 */
} /* zgehd2_ */
/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
integer *ldz, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *), d_cnjg(doublecomplex *,
doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
static doublecomplex temp;
static doublereal opst;
static integer i__, j, k, l, m;
static doublereal s;
static doublecomplex t, u, v[2], x, y;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal rtemp;
static integer i1, i2;
static doublereal rwork[1];
static doublecomplex t1;
static doublereal t2;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublecomplex v2;
static doublereal h10;
static doublecomplex h11;
static doublereal h21;
static doublecomplex h22;
static integer nh;
extern doublereal dlamch_(char *);
static integer nz;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static doublereal smlnum;
static doublecomplex h11s;
static integer itn, its;
static doublereal ulp;
static doublecomplex sum;
static doublereal tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK auxiliary routine (instrumented to count operations) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
ZLAHQR is an auxiliary routine called by ZHSEQR to update the
eigenvalues and Schur decomposition already computed by ZHSEQR, by
dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
Arguments
=========
WANTT (input) LOGICAL
= .TRUE. : the full Schur form T is required;
= .FALSE.: only eigenvalues are required.
WANTZ (input) LOGICAL
= .TRUE. : the matrix of Schur vectors Z is required;
= .FALSE.: Schur vectors are not required.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows and
columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
ZLAHQR works primarily with the Hessenberg submatrix in rows
and columns ILO to IHI, but applies transformations to all of
H if WANTT is .TRUE..
1 <= ILO <= max(1,IHI); IHI <= N.
H (input/output) COMPLEX*16 array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if WANTT is .TRUE., H is upper triangular in rows
and columns ILO:IHI, with any 2-by-2 diagonal blocks in
standard form. If WANTT is .FALSE., the contents of H are
unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX*16 array, dimension (N)
The computed eigenvalues ILO to IHI are stored in the
corresponding elements of W. If WANTT is .TRUE., the
eigenvalues are stored in the same order as on the diagonal
of the Schur form returned in H, with W(i) = H(i,i).
ILOZ (input) INTEGER
IHIZ (input) INTEGER
Specify the rows of Z to which transformations must be
applied if WANTZ is .TRUE..
1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
If WANTZ is .TRUE., on entry Z must contain the current
matrix Z of transformations accumulated by ZHSEQR, and on
exit Z has been updated; transformations are applied only to
the submatrix Z(ILOZ:IHIZ,ILO:IHI).
If WANTZ is .FALSE., Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = i, ZLAHQR failed to compute all the
eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1)
iterations; elements i+1:ihi of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* **
Initialize */
opst = 0.;
/* **
Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
ulp = dlamch_("Precision");
smlnum = dlamch_("Safe minimum") / ulp;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of 1. Each iteration of the loop works
with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L10:
if (i__ < *ilo) {
goto L130;
}
/* Perform QR iterations on rows and columns ILO to I until a
submatrix of order 1 splits off at the bottom because a
subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__4 = h___subscr(k, k);
tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h___ref(
k - 1, k - 1)), abs(d__2)) + ((d__3 = h__[i__4].r, abs(
d__3)) + (d__4 = d_imag(&h___ref(k, k)), abs(d__4)));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = zlanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0., h__[i__2].i = 0.;
}
/* Exit from loop if a submatrix of order 1 has split off. */
if (l >= i__) {
goto L120;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
i__2 = h___subscr(i__, i__ - 1);
s = (d__1 = h__[i__2].r, abs(d__1)) * .75;
i__2 = h___subscr(i__, i__);
z__1.r = s + h__[i__2].r, z__1.i = h__[i__2].i;
t.r = z__1.r, t.i = z__1.i;
/* **
Increment op count */
opst += 1;
/* ** */
} else {
/* Wilkinson's shift. */
i__2 = h___subscr(i__, i__);
t.r = h__[i__2].r, t.i = h__[i__2].i;
i__2 = h___subscr(i__ - 1, i__);
i__3 = h___subscr(i__, i__ - 1);
d__1 = h__[i__3].r;
z__1.r = d__1 * h__[i__2].r, z__1.i = d__1 * h__[i__2].i;
u.r = z__1.r, u.i = z__1.i;
/* **
Increment op count */
opst += 2;
/* ** */
if (u.r != 0. || u.i != 0.) {
i__2 = h___subscr(i__ - 1, i__ - 1);
z__2.r = h__[i__2].r - t.r, z__2.i = h__[i__2].i - t.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
x.r = z__1.r, x.i = z__1.i;
z__3.r = x.r * x.r - x.i * x.i, z__3.i = x.r * x.i + x.i *
x.r;
z__2.r = z__3.r + u.r, z__2.i = z__3.i + u.i;
z_sqrt(&z__1, &z__2);
y.r = z__1.r, y.i = z__1.i;
if (x.r * y.r + d_imag(&x) * d_imag(&y) < 0.) {
z__1.r = -y.r, z__1.i = -y.i;
y.r = z__1.r, y.i = z__1.i;
}
z__3.r = x.r + y.r, z__3.i = x.i + y.i;
zladiv_(&z__2, &u, &z__3);
z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i;
t.r = z__1.r, t.i = z__1.i;
/* **
Increment op count */
opst += 20;
/* ** */
}
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l + 1;
for (m = i__ - 1; m >= i__2; --m) {
/* Determine the effect of starting the single-shift QR
iteration at row M, and see if this would make H(M,M-1)
negligible. */
i__3 = h___subscr(m, m);
h11.r = h__[i__3].r, h11.i = h__[i__3].i;
i__3 = h___subscr(m + 1, m + 1);
h22.r = h__[i__3].r, h22.i = h__[i__3].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__3 = h___subscr(m + 1, m);
h21 = h__[i__3].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2))
+ abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
i__3 = h___subscr(m, m - 1);
h10 = h__[i__3].r;
tst1 = ((d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(
d__2))) * ((d__3 = h11.r, abs(d__3)) + (d__4 = d_imag(&
h11), abs(d__4)) + ((d__5 = h22.r, abs(d__5)) + (d__6 =
d_imag(&h22), abs(d__6))));
if ((d__1 = h10 * h21, abs(d__1)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
i__2 = h___subscr(l, l);
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = h___subscr(l + 1, l + 1);
h22.r = h__[i__2].r, h22.i = h__[i__2].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__2 = h___subscr(l + 1, l);
h21 = h__[i__2].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) +
abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
L50:
/* **
Increment op count */
opst += (i__ - m) * 14;
/* **
Single-shift QR step */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix.
V(2) is always real before the call to ZLARFG, and hence
after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
zcopy_(&c__2, &h___ref(k, k - 1), &c__1, v, &c__1);
}
zlarfg_(&c__2, v, &v[1], &c__1, &t1);
/* **
Increment op count */
opst += 38;
/* ** */
if (k > m) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = h___subscr(k + 1, k - 1);
h__[i__3].r = 0., h__[i__3].i = 0.;
}
v2.r = v[1].r, v2.i = v[1].i;
z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = z__1.r;
/* Apply G from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
d_cnjg(&z__3, &t1);
i__4 = h___subscr(k, j);
z__2.r = z__3.r * h__[i__4].r - z__3.i * h__[i__4].i, z__2.i =
z__3.r * h__[i__4].i + z__3.i * h__[i__4].r;
i__5 = h___subscr(k + 1, j);
z__4.r = t2 * h__[i__5].r, z__4.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = h___subscr(k, j);
i__5 = h___subscr(k, j);
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = h___subscr(k + 1, j);
i__5 = h___subscr(k + 1, j);
z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i +
sum.i * v2.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L60: */
}
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+2,I).
Computing MIN */
i__4 = k + 2;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
i__4 = h___subscr(j, k);
z__2.r = t1.r * h__[i__4].r - t1.i * h__[i__4].i, z__2.i =
t1.r * h__[i__4].i + t1.i * h__[i__4].r;
i__5 = h___subscr(j, k + 1);
z__3.r = t2 * h__[i__5].r, z__3.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = h___subscr(j, k);
i__5 = h___subscr(j, k);
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = h___subscr(j, k + 1);
i__5 = h___subscr(j, k + 1);
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L70: */
}
/* **
Increment op count
Computing MIN */
i__3 = 2, i__4 = i__ - k;
latime_1.ops += (i2 - i1 + 2 + min(i__3,i__4)) * 20;
/* ** */
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
i__4 = z___subscr(j, k);
z__2.r = t1.r * z__[i__4].r - t1.i * z__[i__4].i, z__2.i =
t1.r * z__[i__4].i + t1.i * z__[i__4].r;
i__5 = z___subscr(j, k + 1);
z__3.r = t2 * z__[i__5].r, z__3.i = t2 * z__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = z___subscr(j, k);
i__5 = z___subscr(j, k);
z__1.r = z__[i__5].r - sum.r, z__1.i = z__[i__5].i -
sum.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = z___subscr(j, k + 1);
i__5 = z___subscr(j, k + 1);
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i -
z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
/* L80: */
}
/* **
Increment op count */
latime_1.ops += nz * 20;
/* ** */
}
if (k == m && m > l) {
/* If the QR step was started at row M > L because two
consecutive small subdiagonals were found, then extra
scaling must be performed to ensure that H(M,M-1) remains
real. */
z__1.r = 1. - t1.r, z__1.i = 0. - t1.i;
temp.r = z__1.r, temp.i = z__1.i;
d__1 = z_abs(&temp);
z__1.r = temp.r / d__1, z__1.i = temp.i / d__1;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = h___subscr(m + 1, m);
i__4 = h___subscr(m + 1, m);
d_cnjg(&z__2, &temp);
z__1.r = h__[i__4].r * z__2.r - h__[i__4].i * z__2.i, z__1.i =
h__[i__4].r * z__2.i + h__[i__4].i * z__2.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
if (m + 2 <= i__) {
i__3 = h___subscr(m + 2, m + 1);
i__4 = h___subscr(m + 2, m + 1);
z__1.r = h__[i__4].r * temp.r - h__[i__4].i * temp.i,
z__1.i = h__[i__4].r * temp.i + h__[i__4].i *
temp.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
}
i__3 = i__;
for (j = m; j <= i__3; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__4 = i2 - j;
zscal_(&i__4, &temp, &h___ref(j, j + 1), ldh);
}
i__4 = j - i1;
d_cnjg(&z__1, &temp);
zscal_(&i__4, &z__1, &h___ref(i1, j), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 3) * 6;
/* ** */
if (*wantz) {
d_cnjg(&z__1, &temp);
zscal_(&nz, &z__1, &z___ref(*iloz, j), &c__1);
/* **
Increment op count */
opst += nz * 6;
/* ** */
}
}
/* L90: */
}
}
/* L100: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
rtemp = z_abs(&temp);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (*wantz) {
zscal_(&nz, &temp, &z___ref(*iloz, i__), &c__1);
/* **
Increment op count */
opst += nz * 6;
/* ** */
}
}
/* L110: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L120:
/* H(I,I-1) is negligible: one eigenvalue has converged. */
i__1 = i__;
i__2 = h___subscr(i__, i__);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
/* Decrement number of remaining iterations, and return to start of
the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L130:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
return 0;
/* End of ZLAHQR */
} /* zlahqr_ */
