/* Subroutine */ int ctrexc_(char *compq, integer *n, complex *t, integer *
ldt, complex *q, integer *ldq, integer *ifst, integer *ilst, integer *
info, ftnlen compq_len)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer k, m1, m2, m3;
static real cs;
static complex t11, t22, sn, temp;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical wantq;
extern /* Subroutine */ int clartg_(complex *, complex *, real *, complex
*, complex *), xerbla_(char *, integer *, ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTREXC reorders the Schur factorization of a complex matrix */
/* A = Q*T*Q**H, so that the diagonal element of T with row index IFST */
/* is moved to row ILST. */
/* The Schur form T is reordered by a unitary similarity transformation */
/* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by */
/* postmultplying it with Z. */
/* Arguments */
/* ========= */
/* COMPQ (input) CHARACTER*1 */
/* = 'V': update the matrix Q of Schur vectors; */
/* = 'N': do not update Q. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) COMPLEX array, dimension (LDT,N) */
/* On entry, the upper triangular matrix T. */
/* On exit, the reordered upper triangular matrix. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
/* unitary transformation matrix Z which reorders T. */
/* If COMPQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N). */
/* IFST (input) INTEGER */
/* ILST (input) INTEGER */
/* Specify the reordering of the diagonal elements of T: */
/* The element with row index IFST is moved to row ILST by a */
/* sequence of transpositions between adjacent elements. */
/* 1 <= IFST <= N; 1 <= ILST <= N. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters. */
/* Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
*info = 0;
wantq = lsame_(compq, "V", (ftnlen)1, (ftnlen)1);
if (! lsame_(compq, "N", (ftnlen)1, (ftnlen)1) && ! wantq) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldt < max(1,*n)) {
*info = -4;
} else if (*ldq < 1 || wantq && *ldq < max(1,*n)) {
*info = -6;
} else if (*ifst < 1 || *ifst > *n) {
*info = -7;
} else if (*ilst < 1 || *ilst > *n) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTREXC", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 1 || *ifst == *ilst) {
return 0;
}
if (*ifst < *ilst) {
/* Move the IFST-th diagonal element forward down the diagonal. */
m1 = 0;
m2 = -1;
m3 = 1;
} else {
/* Move the IFST-th diagonal element backward up the diagonal. */
m1 = -1;
m2 = 0;
m3 = -1;
}
i__1 = *ilst + m2;
i__2 = m3;
for (k = *ifst + m1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
/* Interchange the k-th and (k+1)-th diagonal elements. */
i__3 = k + k * t_dim1;
t11.r = t[i__3].r, t11.i = t[i__3].i;
i__3 = k + 1 + (k + 1) * t_dim1;
t22.r = t[i__3].r, t22.i = t[i__3].i;
/* Determine the transformation to perform the interchange. */
q__1.r = t22.r - t11.r, q__1.i = t22.i - t11.i;
clartg_(&t[k + (k + 1) * t_dim1], &q__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (k + 2 <= *n) {
i__3 = *n - k - 1;
crot_(&i__3, &t[k + (k + 2) * t_dim1], ldt, &t[k + 1 + (k + 2) *
t_dim1], ldt, &cs, &sn);
}
i__3 = k - 1;
r_cnjg(&q__1, &sn);
crot_(&i__3, &t[k * t_dim1 + 1], &c__1, &t[(k + 1) * t_dim1 + 1], &
c__1, &cs, &q__1);
i__3 = k + k * t_dim1;
t[i__3].r = t22.r, t[i__3].i = t22.i;
i__3 = k + 1 + (k + 1) * t_dim1;
t[i__3].r = t11.r, t[i__3].i = t11.i;
if (wantq) {
/* Accumulate transformation in the matrix Q. */
r_cnjg(&q__1, &sn);
crot_(n, &q[k * q_dim1 + 1], &c__1, &q[(k + 1) * q_dim1 + 1], &
c__1, &cs, &q__1);
}
/* L10: */
}
return 0;
/* End of CTREXC */
} /* ctrexc_ */
int cgbbrd_(char *vect, int *m, int *n, int *ncc,
int *kl, int *ku, complex *ab, int *ldab, float *d__,
float *e, complex *q, int *ldq, complex *pt, int *ldpt,
complex *c__, int *ldc, complex *work, float *rwork, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
int i__, j, l;
complex t;
int j1, j2, kb;
complex ra, rb;
float rc;
int kk, ml, nr, mu;
complex rs;
int kb1, ml0, mu0, klm, kun, nrt, klu1, inca;
float abst;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *), cscal_(int *,
complex *, complex *, int *);
extern int lsame_(char *, char *);
int wantb, wantc;
int minmn;
int wantq;
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *), xerbla_(char *, int
*), clargv_(int *, complex *, int *, complex *,
int *, float *, int *), clartv_(int *, complex *,
int *, complex *, int *, float *, complex *, int *);
int wantpt;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGBBRD reduces a complex general m-by-n band matrix A to float upper */
/* bidiagonal form B by a unitary transformation: Q' * A * P = B. */
/* The routine computes B, and optionally forms Q or P', or computes */
/* Q'*C for a given matrix C. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* Specifies whether or not the matrices Q and P' are to be */
/* formed. */
/* = 'N': do not form Q or P'; */
/* = 'Q': form Q only; */
/* = 'P': form P' only; */
/* = 'B': form both. */
/* 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. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals of the matrix A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals of the matrix A. KU >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the m-by-n band matrix A, stored in rows 1 to */
/* KL+KU+1. The j-th column of A is stored in the j-th column of */
/* the array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for MAX(1,j-ku)<=i<=MIN(m,j+kl). */
/* On exit, A is overwritten by values generated during the */
/* reduction. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array A. LDAB >= KL+KU+1. */
/* D (output) REAL array, dimension (MIN(M,N)) */
/* The diagonal elements of the bidiagonal matrix B. */
/* E (output) REAL array, dimension (MIN(M,N)-1) */
/* The superdiagonal elements of the bidiagonal matrix B. */
/* Q (output) COMPLEX array, dimension (LDQ,M) */
/* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q. */
/* If VECT = 'N' or 'P', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= MAX(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */
/* PT (output) COMPLEX array, dimension (LDPT,N) */
/* If VECT = 'P' or 'B', the n-by-n unitary matrix P'. */
/* If VECT = 'N' or 'Q', the array PT is not referenced. */
/* LDPT (input) INTEGER */
/* The leading dimension of the array PT. */
/* LDPT >= MAX(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */
/* C (input/output) COMPLEX array, dimension (LDC,NCC) */
/* On entry, an m-by-ncc matrix C. */
/* On exit, C is overwritten by Q'*C. */
/* C is not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= MAX(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */
/* WORK (workspace) COMPLEX array, dimension (MAX(M,N)) */
/* RWORK (workspace) REAL array, dimension (MAX(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1;
pt -= pt_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
--rwork;
/* Function Body */
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < MAX(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < MAX(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < MAX(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
claset_("Full", m, m, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (wantpt) {
claset_("Full", n, n, &c_b1, &c_b2, &pt[pt_offset], ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = MIN(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */
/* first to lower bidiagonal form and then transform to upper */
/* bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied in */
/* vector operations of length NR over the index set J1:J2:KLU1. */
/* The complex sines of the plane rotations are stored in WORK, */
/* and the float cosines in RWORK. */
/* Computing MIN */
i__1 = *m - 1;
klm = MIN(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = MIN(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th column and i-th row of matrix to bidiagonal form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= i__2; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero elements */
/* which have been created below the band */
if (nr > 0) {
clargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca,
&work[j1], &kb1, &rwork[j1], &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= i__3; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) *
ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm
+ l - 1) * ab_dim1], &inca, &rwork[j1], &work[
j1], &kb1);
}
/* L10: */
}
if (ml > ml0) {
if (ml <= *m - i__ + 1) {
/* generate plane rotation to annihilate a(i+ml-1,i) */
/* within the band, and apply rotation from the left */
clartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku +
ml + i__ * ab_dim1], &rwork[i__ + ml - 1], &
work[i__ + ml - 1], &ra);
i__3 = *ku + ml - 1 + i__ * ab_dim1;
ab[i__3].r = ra.r, ab[i__3].i = ra.i;
if (i__ < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i__;
i__3 = MIN(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
crot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) *
ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__
+ 1) * ab_dim1], &i__7, &rwork[i__ + ml -
1], &work[i__ + ml - 1]);
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations in Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
{
r_cnjg(&q__1, &work[j]);
crot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j *
q_dim1 + 1], &c__1, &rwork[j], &q__1);
/* L20: */
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
crot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1]
, ldc, &rwork[j], &work[j]);
/* L30: */
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j-1,j+ku) above the band */
/* and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
i__5 = (j + kun) * ab_dim1 + 1;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
/* L40: */
}
/* generate plane rotations to annihilate nonzero elements */
/* which have been generated above the band */
if (nr > 0) {
clargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, &
work[j1 + kun], &kb1, &rwork[j1 + kun], &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= i__4; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], &
inca, &ab[l + (j1 + kun) * ab_dim1], &inca, &
rwork[j1 + kun], &work[j1 + kun], &kb1);
}
/* L50: */
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i,i+mu-1) */
/* within the band, and apply rotation from the right */
clartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1],
&ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1],
&rwork[i__ + mu - 1], &work[i__ + mu - 1], &
ra);
i__4 = *ku - mu + 3 + (i__ + mu - 2) * ab_dim1;
ab[i__4].r = ra.r, ab[i__4].i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i__;
i__4 = MIN(i__3,i__5);
crot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) *
ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu
- 1) * ab_dim1], &c__1, &rwork[i__ + mu - 1],
&work[i__ + mu - 1]);
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations in P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
r_cnjg(&q__1, &work[j + kun]);
crot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j +
kun + pt_dim1], ldpt, &rwork[j + kun], &q__1);
/* L60: */
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j+kl+ku,j+ku-1) below the */
/* band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
i__5 = klu1 + (j + kun) * ab_dim1;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form */
/* Transform lower bidiagonal form to upper bidiagonal by applying */
/* plane rotations from the left, overwriting superdiagonal */
/* elements on subdiagonal elements */
/* Computing MIN */
i__2 = *m - 1;
i__1 = MIN(i__2,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
clartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs,
&ra);
i__2 = i__ * ab_dim1 + 1;
ab[i__2].r = ra.r, ab[i__2].i = ra.i;
if (i__ < *n) {
i__2 = i__ * ab_dim1 + 2;
i__4 = (i__ + 1) * ab_dim1 + 1;
q__1.r = rs.r * ab[i__4].r - rs.i * ab[i__4].i, q__1.i = rs.r
* ab[i__4].i + rs.i * ab[i__4].r;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
i__2 = (i__ + 1) * ab_dim1 + 1;
i__4 = (i__ + 1) * ab_dim1 + 1;
q__1.r = rc * ab[i__4].r, q__1.i = rc * ab[i__4].i;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &rs);
crot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 +
1], &c__1, &rc, &q__1);
}
if (wantc) {
crot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1],
ldc, &rc, &rs);
}
/* L100: */
}
} else {
/* A has been reduced to complex upper bidiagonal form or is */
/* diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from the */
/* right */
i__1 = *ku + (*m + 1) * ab_dim1;
rb.r = ab[i__1].r, rb.i = ab[i__1].i;
for (i__ = *m; i__ >= 1; --i__) {
clartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra);
i__1 = *ku + 1 + i__ * ab_dim1;
ab[i__1].r = ra.r, ab[i__1].i = ra.i;
if (i__ > 1) {
r_cnjg(&q__3, &rs);
q__2.r = -q__3.r, q__2.i = -q__3.i;
i__1 = *ku + i__ * ab_dim1;
q__1.r = q__2.r * ab[i__1].r - q__2.i * ab[i__1].i,
q__1.i = q__2.r * ab[i__1].i + q__2.i * ab[i__1]
.r;
rb.r = q__1.r, rb.i = q__1.i;
i__1 = *ku + i__ * ab_dim1;
i__2 = *ku + i__ * ab_dim1;
q__1.r = rc * ab[i__2].r, q__1.i = rc * ab[i__2].i;
ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
}
if (wantpt) {
r_cnjg(&q__1, &rs);
crot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1],
ldpt, &rc, &q__1);
}
/* L110: */
}
}
}
/* Make diagonal and superdiagonal elements float, storing them in D */
/* and E */
i__1 = *ku + 1 + ab_dim1;
t.r = ab[i__1].r, t.i = ab[i__1].i;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
abst = c_abs(&t);
d__[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantq) {
cscal_(m, &t, &q[i__ * q_dim1 + 1], &c__1);
}
if (wantc) {
r_cnjg(&q__1, &t);
cscal_(ncc, &q__1, &c__[i__ + c_dim1], ldc);
}
if (i__ < minmn) {
if (*ku == 0 && *kl == 0) {
e[i__] = 0.f;
i__2 = (i__ + 1) * ab_dim1 + 1;
t.r = ab[i__2].r, t.i = ab[i__2].i;
} else {
if (*ku == 0) {
i__2 = i__ * ab_dim1 + 2;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
} else {
i__2 = *ku + (i__ + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
abst = c_abs(&t);
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantpt) {
cscal_(n, &t, &pt[i__ + 1 + pt_dim1], ldpt);
}
i__2 = *ku + 1 + (i__ + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i, q__1.i =
ab[i__2].r * q__2.i + ab[i__2].i * q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
}
/* L120: */
}
return 0;
/* End of CGBBRD */
} /* cgbbrd_ */
int chgeqz_(char *job, char *compq, char *compz, int *n,
int *ilo, int *ihi, complex *h__, int *ldh, complex *t,
int *ldt, complex *alpha, complex *beta, complex *q, int *ldq,
complex *z__, int *ldz, complex *work, int *lwork, float *
rwork, int *info)
{
/* System generated locals */
int h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
float r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
double r_imag(complex *);
void c_div(complex *, complex *, complex *), pow_ci(complex *, complex *,
int *), c_sqrt(complex *, complex *);
/* Local variables */
float c__;
int j;
complex s, t1;
int jc, in;
complex u12;
int jr;
complex ad11, ad12, ad21, ad22;
int jch;
int ilq, ilz;
float ulp;
complex abi22;
float absb, atol, btol, temp;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *);
float temp2;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
complex ctemp;
int iiter, ilast, jiter;
float anorm, bnorm;
int maxit;
complex shift;
float tempr;
complex ctemp2, ctemp3;
int ilazr2;
float ascale, bscale;
complex signbc;
extern double slamch_(char *), clanhs_(char *, int *,
complex *, int *, float *);
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *);
float safmin;
extern int xerbla_(char *, int *);
complex eshift;
int ilschr;
int icompq, ilastm;
complex rtdisc;
int ischur;
int ilazro;
int icompz, ifirst, ifrstm, istart;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */
/* where H is an upper Hessenberg matrix and T is upper triangular, */
/* using the single-shift QZ method. */
/* Matrix pairs of this type are produced by the reduction to */
/* generalized upper Hessenberg form of a complex matrix pair (A,B): */
/* A = Q1*H*Z1**H, B = Q1*T*Z1**H, */
/* as computed by CGGHRD. */
/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
/* also reduced to generalized Schur form, */
/* H = Q*S*Z**H, T = Q*P*Z**H, */
/* where Q and Z are unitary matrices and S and P are upper triangular. */
/* Optionally, the unitary matrix Q from the generalized Schur */
/* factorization may be postmultiplied into an input matrix Q1, and the */
/* unitary matrix Z may be postmultiplied into an input matrix Z1. */
/* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced */
/* the matrix pair (A,B) to generalized Hessenberg form, then the output */
/* matrices Q1*Q and Z1*Z are the unitary factors from the generalized */
/* Schur factorization of (A,B): */
/* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. */
/* To avoid overflow, eigenvalues of the matrix pair (H,T) */
/* (equivalently, of (A,B)) are computed as a pair of complex values */
/* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an */
/* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */
/* A*x = lambda*B*x */
/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
/* alternate form of the GNEP */
/* mu*A*y = B*y. */
/* The values of alpha and beta for the i-th eigenvalue can be read */
/* directly from the generalized Schur form: alpha = S(i,i), */
/* beta = P(i,i). */
/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
/* pp. 241--256. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': Compute eigenvalues only; */
/* = 'S': Computer eigenvalues and the Schur form. */
/* COMPQ (input) CHARACTER*1 */
/* = 'N': Left Schur vectors (Q) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Q */
/* of left Schur vectors of (H,T) is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry and */
/* the product Q1*Q is returned. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Right Schur vectors (Z) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Z */
/* of right Schur vectors of (H,T) is returned; */
/* = 'V': Z must contain a unitary matrix Z1 on entry and */
/* the product Z1*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrices H, T, Q, and Z. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* ILO and IHI mark the rows and columns of H which are in */
/* Hessenberg form. It is assumed that A is already upper */
/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
/* H (input/output) COMPLEX array, dimension (LDH, N) */
/* On entry, the N-by-N upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper triangular */
/* matrix S from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of H matches that of S, but */
/* the rest of H is unspecified. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX( 1, N ). */
/* T (input/output) COMPLEX array, dimension (LDT, N) */
/* On entry, the N-by-N upper triangular matrix T. */
/* On exit, if JOB = 'S', T contains the upper triangular */
/* matrix P from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of T matches that of P, but */
/* the rest of T is unspecified. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= MAX( 1, N ). */
/* ALPHA (output) COMPLEX array, dimension (N) */
/* The complex scalars alpha that define the eigenvalues of */
/* GNEP. ALPHA(i) = S(i,i) in the generalized Schur */
/* factorization. */
/* BETA (output) COMPLEX array, dimension (N) */
/* The float non-negative scalars beta that define the */
/* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized */
/* Schur factorization. */
/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
/* represent the j-th eigenvalue of the matrix pair (A,B), in */
/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
/* Since either lambda or mu may overflow, they should not, */
/* in general, be computed. */
/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of left Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* left Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1. */
/* If COMPQ='V' or 'I', then LDQ >= N. */
/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of right Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* right Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If COMPZ='V' or 'I', then LDZ >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,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. */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO+1,...,N should be correct. */
/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO-N+1,...,N should be correct. */
/* Further Details */
/* =============== */
/* We assume that complex ABS works as long as its value is less than */
/* overflow. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode JOB, COMPQ, COMPZ */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
if (lsame_(job, "E")) {
ilschr = FALSE;
ischur = 1;
} else if (lsame_(job, "S")) {
ilschr = TRUE;
ischur = 2;
} else {
ischur = 0;
}
if (lsame_(compq, "N")) {
ilq = FALSE;
icompq = 1;
} else if (lsame_(compq, "V")) {
ilq = TRUE;
icompq = 2;
} else if (lsame_(compq, "I")) {
ilq = TRUE;
icompq = 3;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE;
icompz = 1;
} else if (lsame_(compz, "V")) {
ilz = TRUE;
icompz = 2;
} else if (lsame_(compz, "I")) {
ilz = TRUE;
icompz = 3;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = MAX(1,*n);
work[1].r = (float) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (ischur == 0) {
*info = -1;
} else if (icompq == 0) {
*info = -2;
} else if (icompz == 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1) {
*info = -5;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -6;
} else if (*ldh < *n) {
*info = -8;
} else if (*ldt < *n) {
*info = -10;
} else if (*ldq < 1 || ilq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || ilz && *ldz < *n) {
*info = -16;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = slamch_("S");
ulp = slamch_("E") * slamch_("B");
anorm = clanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]);
bnorm = clanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * anorm;
atol = MAX(r__1,r__2);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * bnorm;
btol = MAX(r__1,r__2);
ascale = 1.f / MAX(safmin,anorm);
bscale = 1.f / MAX(safmin,bnorm);
/* Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L10: */
}
/* If IHI < ILO, skip QZ steps */
if (*ihi < *ilo) {
goto L190;
}
/* MAIN QZ ITERATION LOOP */
/* Initialize dynamic indices */
/* Eigenvalues ILAST+1:N have been found. */
/* Column operations modify rows IFRSTM:whatever */
/* Row operations modify columns whatever:ILASTM */
/* If only eigenvalues are being computed, then */
/* IFRSTM is the row of the last splitting row above row ILAST; */
/* this is always at least ILO. */
/* IITER counts iterations since the last eigenvalue was found, */
/* to tell when to use an extraordinary shift. */
/* MAXIT is the maximum number of QZ sweeps allowed. */
ilast = *ihi;
if (ilschr) {
ifrstm = 1;
ilastm = *n;
} else {
ifrstm = *ilo;
ilastm = *ihi;
}
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
maxit = (*ihi - *ilo + 1) * 30;
i__1 = maxit;
for (jiter = 1; jiter <= i__1; ++jiter) {
/* Check for too many iterations. */
if (jiter > maxit) {
goto L180;
}
/* Split the matrix if possible. */
/* Two tests: */
/* 1: H(j,j-1)=0 or j=ILO */
/* 2: T(j,j)=0 */
/* Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = ilast + (ilast - 1) * h_dim1;
if ((r__1 = h__[i__2].r, ABS(r__1)) + (r__2 = r_imag(&h__[ilast
+ (ilast - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
goto L60;
}
}
if (c_abs(&t[ilast + ilast * t_dim1]) <= btol) {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for H(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE;
} else {
i__3 = j + (j - 1) * h_dim1;
if ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j
+ (j - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__3 = j + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
ilazro = TRUE;
} else {
ilazro = FALSE;
}
}
/* Test 2: for T(j,j)=0 */
if (c_abs(&t[j + j * t_dim1]) < btol) {
i__3 = j + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE;
if (! ilazro) {
i__3 = j + (j - 1) * h_dim1;
i__4 = j + 1 + j * h_dim1;
i__5 = j + j * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&
h__[j + (j - 1) * h_dim1]), ABS(r__2))) * (
ascale * ((r__3 = h__[i__4].r, ABS(r__3)) + (
r__4 = r_imag(&h__[j + 1 + j * h_dim1]), ABS(
r__4)))) <= ((r__5 = h__[i__5].r, ABS(r__5)) + (
r__6 = r_imag(&h__[j + j * h_dim1]), ABS(r__6)))
* (ascale * atol)) {
ilazr2 = TRUE;
}
}
/* If both tests pass (1 & 2), i.e., the leading diagonal */
/* element of B in the block is zero, split a 1x1 block off */
/* at the top. (I.e., at the J-th row/column) The leading */
/* diagonal element of the remainder can also be zero, so */
/* this may have to be done repeatedly. */
if (ilazro || ilazr2) {
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, &
s, &h__[jch + jch * h_dim1]);
i__4 = jch + 1 + jch * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = ilastm - jch;
crot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
&s);
i__4 = ilastm - jch;
crot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
if (ilazr2) {
i__4 = jch + (jch - 1) * h_dim1;
i__5 = jch + (jch - 1) * h_dim1;
q__1.r = c__ * h__[i__5].r, q__1.i = c__ * h__[
i__5].i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
}
ilazr2 = FALSE;
i__4 = jch + 1 + (jch + 1) * t_dim1;
if ((r__1 = t[i__4].r, ABS(r__1)) + (r__2 = r_imag(&
t[jch + 1 + (jch + 1) * t_dim1]), ABS(r__2))
>= btol) {
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
/* Then process as in the case T(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + (jch + 1) * t_dim1;
ctemp.r = t[i__4].r, ctemp.i = t[i__4].i;
clartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], &
c__, &s, &t[jch + (jch + 1) * t_dim1]);
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
crot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
t[jch + 1 + (jch + 2) * t_dim1], ldt, &
c__, &s);
}
i__4 = ilastm - jch + 2;
crot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
&s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
i__4 = jch + 1 + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], &
c__, &s, &h__[jch + 1 + jch * h_dim1]);
i__4 = jch + 1 + (jch - 1) * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = jch + 1 - ifrstm;
crot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
;
i__4 = jch - ifrstm;
crot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
;
if (ilz) {
crot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
- 1) * z_dim1 + 1], &c__1, &c__, &s);
}
/* L30: */
}
goto L50;
}
} else if (ilazro) {
/* Only test 1 passed -- work on J:ILAST */
ifirst = j;
goto L70;
}
/* Neither test passed -- try next J */
/* L40: */
}
/* (Drop-through is "impossible") */
*info = (*n << 1) + 1;
goto L210;
/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
/* 1x1 block. */
L50:
i__2 = ilast + ilast * h_dim1;
ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i;
clartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
ilast + ilast * h_dim1]);
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = ilast - ifrstm;
crot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
ilast - 1) * h_dim1], &c__1, &c__, &s);
i__2 = ilast - ifrstm;
crot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
1) * t_dim1], &c__1, &c__, &s);
if (ilz) {
crot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
z_dim1 + 1], &c__1, &c__, &s);
}
/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = c_abs(&t[ilast + ilast * t_dim1]);
if (absb > safmin) {
i__2 = ilast + ilast * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = ilast + ilast * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = ilast - ifrstm;
cscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1);
i__2 = ilast + 1 - ifrstm;
cscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1);
} else {
i__2 = ilast + ilast * h_dim1;
i__3 = ilast + ilast * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1);
}
} else {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = ilast;
i__3 = ilast + ilast * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = ilast;
i__3 = ilast + ilast * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
if (! ilschr) {
ilastm = ilast;
if (ifrstm > ilast) {
ifrstm = *ilo;
}
}
goto L160;
/* QZ step */
/* This iteration only involves rows/columns IFIRST:ILAST. We */
/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
L70:
++iiter;
if (! ilschr) {
ifrstm = ifirst;
}
/* Compute the Shift. */
/* At this point, IFIRST < ILAST, and the diagonal elements of */
/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
/* magnitude) */
if (iiter / 10 * 10 != iiter) {
/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */
/* the bottom-right 2x2 block of A inv(B) which is nearest to */
/* the bottom-right element. */
/* We factor B as U*D, where U has unit diagonals, and */
/* compute (A*inv(D))*inv(U). */
i__2 = ilast - 1 + ilast * t_dim1;
q__2.r = bscale * t[i__2].r, q__2.i = bscale * t[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
u12.r = q__1.r, u12.i = q__1.i;
i__2 = ilast - 1 + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad11.r = q__1.r, ad11.i = q__1.i;
i__2 = ilast + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad21.r = q__1.r, ad21.i = q__1.i;
i__2 = ilast - 1 + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad12.r = q__1.r, ad12.i = q__1.i;
i__2 = ilast + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad22.r = q__1.r, ad22.i = q__1.i;
q__2.r = u12.r * ad21.r - u12.i * ad21.i, q__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
q__1.r = ad22.r - q__2.r, q__1.i = ad22.i - q__2.i;
abi22.r = q__1.r, abi22.i = q__1.i;
q__2.r = ad11.r + abi22.r, q__2.i = ad11.i + abi22.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
t1.r = q__1.r, t1.i = q__1.i;
pow_ci(&q__4, &t1, &c__2);
q__5.r = ad12.r * ad21.r - ad12.i * ad21.i, q__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
q__6.r = ad11.r * ad22.r - ad11.i * ad22.i, q__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
c_sqrt(&q__1, &q__2);
rtdisc.r = q__1.r, rtdisc.i = q__1.i;
q__1.r = t1.r - abi22.r, q__1.i = t1.i - abi22.i;
q__2.r = t1.r - abi22.r, q__2.i = t1.i - abi22.i;
temp = q__1.r * rtdisc.r + r_imag(&q__2) * r_imag(&rtdisc);
if (temp <= 0.f) {
q__1.r = t1.r + rtdisc.r, q__1.i = t1.i + rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
} else {
q__1.r = t1.r - rtdisc.r, q__1.i = t1.i - rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
}
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = ilast - 1 + ilast * h_dim1;
q__4.r = ascale * h__[i__2].r, q__4.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__5.r = bscale * t[i__3].r, q__5.i = bscale * t[i__3].i;
c_div(&q__3, &q__4, &q__5);
r_cnjg(&q__2, &q__3);
q__1.r = eshift.r + q__2.r, q__1.i = eshift.i + q__2.i;
eshift.r = q__1.r, eshift.i = q__1.i;
shift.r = eshift.r, shift.i = eshift.i;
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = j + j * h_dim1;
q__2.r = ascale * h__[i__3].r, q__2.i = ascale * h__[i__3].i;
i__4 = j + j * t_dim1;
q__4.r = bscale * t[i__4].r, q__4.i = bscale * t[i__4].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
temp = (r__1 = ctemp.r, ABS(r__1)) + (r__2 = r_imag(&ctemp),
ABS(r__2));
i__3 = j + 1 + j * h_dim1;
temp2 = ascale * ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&h__[j + 1 + j * h_dim1]), ABS(r__2)));
tempr = MAX(temp,temp2);
if (tempr < 1.f && tempr != 0.f) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = j + (j - 1) * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j + (
j - 1) * h_dim1]), ABS(r__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = ifirst + ifirst * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ifirst + ifirst * t_dim1;
q__4.r = bscale * t[i__3].r, q__4.i = bscale * t[i__3].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
L90:
/* Do an implicit-shift QZ sweep. */
/* Initial Q */
i__2 = istart + 1 + istart * h_dim1;
q__1.r = ascale * h__[i__2].r, q__1.i = ascale * h__[i__2].i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
clartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = j + (j - 1) * h_dim1;
ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i;
clartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &
h__[j + (j - 1) * h_dim1]);
i__3 = j + 1 + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = j + jc * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = j + 1 + jc * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = j + 1 + jc * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = j + 1 + jc * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = j + jc * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
i__4 = j + jc * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = j + 1 + jc * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
i__4 = j + 1 + jc * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = j + 1 + jc * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = j + jc * t_dim1;
t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + j * q_dim1;
q__2.r = c__ * q[i__4].r, q__2.i = c__ * q[i__4].i;
r_cnjg(&q__4, &s);
i__5 = jr + (j + 1) * q_dim1;
q__3.r = q__4.r * q[i__5].r - q__4.i * q[i__5].i, q__3.i =
q__4.r * q[i__5].i + q__4.i * q[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + (j + 1) * q_dim1;
q__3.r = -s.r, q__3.i = -s.i;
i__5 = jr + j * q_dim1;
q__2.r = q__3.r * q[i__5].r - q__3.i * q[i__5].i, q__2.i =
q__3.r * q[i__5].i + q__3.i * q[i__5].r;
i__6 = jr + (j + 1) * q_dim1;
q__4.r = c__ * q[i__6].r, q__4.i = c__ * q[i__6].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
q[i__4].r = q__1.r, q[i__4].i = q__1.i;
i__4 = jr + j * q_dim1;
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = j + 1 + (j + 1) * t_dim1;
ctemp.r = t[i__3].r, ctemp.i = t[i__3].i;
clartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
1) * t_dim1]);
i__3 = j + 1 + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Computing MIN */
i__4 = j + 2;
i__3 = MIN(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = jr + j * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = jr + j * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = jr + j * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = jr + j * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = jr + (j + 1) * t_dim1;
t[i__4].r = ctemp.r, t[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * z_dim1;
q__2.r = c__ * z__[i__4].r, q__2.i = c__ * z__[i__4].i;
i__5 = jr + j * z_dim1;
q__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, q__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * z_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * z_dim1;
q__2.r = q__3.r * z__[i__5].r - q__3.i * z__[i__5].i,
q__2.i = q__3.r * z__[i__5].i + q__3.i * z__[i__5]
.r;
i__6 = jr + j * z_dim1;
q__5.r = c__ * z__[i__6].r, q__5.i = c__ * z__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * z_dim1;
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
L160:
/* L170: */
;
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
goto L210;
/* Successful completion of all QZ steps */
L190:
/* Set Eigenvalues 1:ILO-1 */
i__1 = *ilo - 1;
for (j = 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
q__1.r = (float) (*n), q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
/* End of CHGEQZ */
} /* chgeqz_ */
/* Subroutine */ int chbtrd_(char *vect, char *uplo, integer *n, integer *kd,
complex *ab, integer *ldab, real *d__, real *e, complex *q, integer *
ldq, complex *work, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
real r__1;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
integer i__, j, k, l;
complex t;
integer i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt, kdm1, inca,
jend, lend, jinc;
real abst;
integer incx, last;
complex temp;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
integer j1end, j1inc;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
integer iqend;
extern logical lsame_(char *, char *);
logical initq, wantq, upper;
extern /* Subroutine */ int clar2v_(integer *, complex *, complex *,
complex *, integer *, real *, complex *, integer *), clacgv_(
integer *, complex *, integer *);
integer iqaend;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*), clargv_(integer *, complex *, integer *, complex *,
integer *, real *, integer *), clartv_(integer *, complex *,
integer *, complex *, integer *, real *, complex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHBTRD reduces a complex Hermitian band matrix A to real symmetric */
/* tridiagonal form T by a unitary similarity transformation: */
/* Q**H * A * Q = T. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* = 'N': do not form Q; */
/* = 'V': form Q; */
/* = 'U': update a matrix X, by forming X*Q. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the Hermitian band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, the diagonal elements of AB are overwritten by the */
/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */
/* elements on the first superdiagonal (if UPLO = 'U') or the */
/* first subdiagonal (if UPLO = 'L') are overwritten by the */
/* off-diagonal elements of T; the rest of AB is overwritten by */
/* values generated during the reduction. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* D (output) REAL array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T. */
/* E (output) REAL array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, if VECT = 'U', then Q must contain an N-by-N */
/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */
/* On exit: */
/* if VECT = 'V', Q contains the N-by-N unitary matrix Q; */
/* if VECT = 'U', Q contains the product X*Q; */
/* if VECT = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* Modified by Linda Kaufman, Bell Labs. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
initq = lsame_(vect, "V");
wantq = initq || lsame_(vect, "U");
upper = lsame_(uplo, "U");
kd1 = *kd + 1;
kdm1 = *kd - 1;
incx = *ldab - 1;
iqend = 1;
*info = 0;
if (! wantq && ! lsame_(vect, "N")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < kd1) {
*info = -6;
} else if (*ldq < max(1,*n) && wantq) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Initialize Q to the unit matrix, if needed */
if (initq) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
/* Wherever possible, plane rotations are generated and applied in */
/* vector operations of length NR over the index set J1:J2:KD1. */
/* The real cosines and complex sines of the plane rotations are */
/* stored in the arrays D and WORK. */
inca = kd1 * *ldab;
/* Computing MIN */
i__1 = *n - 1;
kdn = min(i__1,*kd);
if (upper) {
if (*kd > 1) {
/* Reduce to complex Hermitian tridiagonal form, working with */
/* the upper triangle */
nr = 0;
j1 = kdn + 2;
j2 = 1;
i__1 = kd1 + ab_dim1;
i__2 = kd1 + ab_dim1;
r__1 = ab[i__2].r;
ab[i__1].r = r__1, ab[i__1].i = 0.f;
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th row of matrix to tridiagonal form */
for (k = kdn + 1; k >= 2; --k) {
j1 += kdn;
j2 += kdn;
if (nr > 0) {
/* generate plane rotations to annihilate nonzero */
/* elements which have been created outside the band */
clargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, &
work[j1], &kd1, &d__[j1], &kd1);
/* apply rotations from the right */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr >= (*kd << 1) - 1) {
i__2 = *kd - 1;
for (l = 1; l <= i__2; ++l) {
clartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1],
&inca, &ab[l + j1 * ab_dim1], &inca, &
d__[j1], &work[j1], &kd1);
/* L10: */
}
} else {
jend = j1 + (nr - 1) * kd1;
i__2 = jend;
i__3 = kd1;
for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <=
i__2; jinc += i__3) {
crot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], &
c__1, &ab[jinc * ab_dim1 + 1], &c__1,
&d__[jinc], &work[jinc]);
/* L20: */
}
}
}
if (k > 2) {
if (k <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i,i+k-1) */
/* within the band */
clartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1]
, &ab[*kd - k + 2 + (i__ + k - 1) *
ab_dim1], &d__[i__ + k - 1], &work[i__ +
k - 1], &temp);
i__3 = *kd - k + 3 + (i__ + k - 2) * ab_dim1;
ab[i__3].r = temp.r, ab[i__3].i = temp.i;
/* apply rotation from the right */
i__3 = k - 3;
crot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) *
ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ +
k - 1) * ab_dim1], &c__1, &d__[i__ + k -
1], &work[i__ + k - 1]);
}
++nr;
j1 = j1 - kdn - 1;
}
/* apply plane rotations from both sides to diagonal */
/* blocks */
if (nr > 0) {
clar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 +
j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca,
&d__[j1], &work[j1], &kd1);
}
/* apply plane rotations from the left */
if (nr > 0) {
clacgv_(&nr, &work[j1], &kd1);
if ((*kd << 1) - 1 < nr) {
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
i__3 = *kd - 1;
for (l = 1; l <= i__3; ++l) {
if (j2 + l > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[*kd - l + (j1 + l) *
ab_dim1], &inca, &ab[*kd - l + 1
+ (j1 + l) * ab_dim1], &inca, &
d__[j1], &work[j1], &kd1);
}
/* L30: */
}
} else {
j1end = j1 + kd1 * (nr - 2);
if (j1end >= j1) {
i__3 = j1end;
i__2 = kd1;
for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <=
i__3; jin += i__2) {
i__4 = *kd - 1;
crot_(&i__4, &ab[*kd - 1 + (jin + 1) *
ab_dim1], &incx, &ab[*kd + (jin +
1) * ab_dim1], &incx, &d__[jin], &
work[jin]);
/* L40: */
}
}
/* Computing MIN */
i__2 = kdm1, i__3 = *n - j2;
lend = min(i__2,i__3);
last = j1end + kd1;
if (lend > 0) {
crot_(&lend, &ab[*kd - 1 + (last + 1) *
ab_dim1], &incx, &ab[*kd + (last + 1)
* ab_dim1], &incx, &d__[last], &work[
last]);
}
}
}
if (wantq) {
/* accumulate product of plane rotations in Q */
if (initq) {
/* take advantage of the fact that Q was */
/* initially the Identity matrix */
iqend = max(iqend,j2);
/* Computing MAX */
i__2 = 0, i__3 = k - 3;
i2 = max(i__2,i__3);
iqaend = i__ * *kd + 1;
if (k == 2) {
iqaend += *kd;
}
iqaend = min(iqaend,iqend);
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+= i__3) {
ibl = i__ - i2 / kdm1;
++i2;
/* Computing MAX */
i__4 = 1, i__5 = j - ibl;
iqb = max(i__4,i__5);
nq = iqaend + 1 - iqb;
/* Computing MIN */
i__4 = iqaend + *kd;
iqaend = min(i__4,iqend);
r_cnjg(&q__1, &work[j]);
crot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
&q[iqb + j * q_dim1], &c__1, &d__[j],
&q__1);
/* L50: */
}
} else {
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+= i__2) {
r_cnjg(&q__1, &work[j]);
crot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
j * q_dim1 + 1], &c__1, &d__[j], &
q__1);
/* L60: */
}
}
}
if (j2 + kdn > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 = j2 - kdn - 1;
}
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3)
{
/* create nonzero element a(j-1,j+kd) outside the band */
/* and store it in WORK */
i__4 = j + *kd;
i__5 = j;
i__6 = (j + *kd) * ab_dim1 + 1;
q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
ab[i__6].i, q__1.i = work[i__5].r * ab[i__6]
.i + work[i__5].i * ab[i__6].r;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
i__4 = (j + *kd) * ab_dim1 + 1;
i__5 = j;
i__6 = (j + *kd) * ab_dim1 + 1;
q__1.r = d__[i__5] * ab[i__6].r, q__1.i = d__[i__5] *
ab[i__6].i;
ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
/* L70: */
}
/* L80: */
}
/* L90: */
}
}
if (*kd > 0) {
/* make off-diagonal elements real and copy them to E */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = *kd + (i__ + 1) * ab_dim1;
t.r = ab[i__3].r, t.i = ab[i__3].i;
abst = c_abs(&t);
i__3 = *kd + (i__ + 1) * ab_dim1;
ab[i__3].r = abst, ab[i__3].i = 0.f;
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (i__ < *n - 1) {
i__3 = *kd + (i__ + 2) * ab_dim1;
i__2 = *kd + (i__ + 2) * ab_dim1;
q__1.r = ab[i__2].r * t.r - ab[i__2].i * t.i, q__1.i = ab[
i__2].r * t.i + ab[i__2].i * t.r;
ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &t);
cscal_(n, &q__1, &q[(i__ + 1) * q_dim1 + 1], &c__1);
}
/* L100: */
}
} else {
/* set E to zero if original matrix was diagonal */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = 0.f;
/* L110: */
}
}
/* copy diagonal elements to D */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = i__;
i__2 = kd1 + i__ * ab_dim1;
d__[i__3] = ab[i__2].r;
/* L120: */
}
} else {
if (*kd > 1) {
/* Reduce to complex Hermitian tridiagonal form, working with */
/* the lower triangle */
nr = 0;
j1 = kdn + 2;
j2 = 1;
i__1 = ab_dim1 + 1;
i__3 = ab_dim1 + 1;
r__1 = ab[i__3].r;
ab[i__1].r = r__1, ab[i__1].i = 0.f;
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th column of matrix to tridiagonal form */
for (k = kdn + 1; k >= 2; --k) {
j1 += kdn;
j2 += kdn;
if (nr > 0) {
/* generate plane rotations to annihilate nonzero */
/* elements which have been created outside the band */
clargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, &
work[j1], &kd1, &d__[j1], &kd1);
/* apply plane rotations from one side */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr > (*kd << 1) - 1) {
i__3 = *kd - 1;
for (l = 1; l <= i__3; ++l) {
clartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) *
ab_dim1], &inca, &ab[kd1 - l + 1 + (
j1 - kd1 + l) * ab_dim1], &inca, &d__[
j1], &work[j1], &kd1);
/* L130: */
}
} else {
jend = j1 + kd1 * (nr - 1);
i__3 = jend;
i__2 = kd1;
for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <=
i__3; jinc += i__2) {
crot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1]
, &incx, &ab[kd1 + (jinc - *kd) *
ab_dim1], &incx, &d__[jinc], &work[
jinc]);
/* L140: */
}
}
}
if (k > 2) {
if (k <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i+k-1,i) */
/* within the band */
clartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ *
ab_dim1], &d__[i__ + k - 1], &work[i__ +
k - 1], &temp);
i__2 = k - 1 + i__ * ab_dim1;
ab[i__2].r = temp.r, ab[i__2].i = temp.i;
/* apply rotation from the left */
i__2 = k - 3;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
crot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], &
i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], &
i__4, &d__[i__ + k - 1], &work[i__ + k -
1]);
}
++nr;
j1 = j1 - kdn - 1;
}
/* apply plane rotations from both sides to diagonal */
/* blocks */
if (nr > 0) {
clar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 *
ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], &
inca, &d__[j1], &work[j1], &kd1);
}
/* apply plane rotations from the right */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr > 0) {
clacgv_(&nr, &work[j1], &kd1);
if (nr > (*kd << 1) - 1) {
i__2 = *kd - 1;
for (l = 1; l <= i__2; ++l) {
if (j2 + l > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[l + 2 + (j1 - 1) *
ab_dim1], &inca, &ab[l + 1 + j1 *
ab_dim1], &inca, &d__[j1], &work[
j1], &kd1);
}
/* L150: */
}
} else {
j1end = j1 + kd1 * (nr - 2);
if (j1end >= j1) {
i__2 = j1end;
i__3 = kd1;
for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 :
j1inc <= i__2; j1inc += i__3) {
crot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 +
3], &c__1, &ab[j1inc * ab_dim1 +
2], &c__1, &d__[j1inc], &work[
j1inc]);
/* L160: */
}
}
/* Computing MIN */
i__3 = kdm1, i__2 = *n - j2;
lend = min(i__3,i__2);
last = j1end + kd1;
if (lend > 0) {
crot_(&lend, &ab[(last - 1) * ab_dim1 + 3], &
c__1, &ab[last * ab_dim1 + 2], &c__1,
&d__[last], &work[last]);
}
}
}
if (wantq) {
/* accumulate product of plane rotations in Q */
if (initq) {
/* take advantage of the fact that Q was */
/* initially the Identity matrix */
iqend = max(iqend,j2);
/* Computing MAX */
i__3 = 0, i__2 = k - 3;
i2 = max(i__3,i__2);
iqaend = i__ * *kd + 1;
if (k == 2) {
iqaend += *kd;
}
iqaend = min(iqaend,iqend);
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+= i__2) {
ibl = i__ - i2 / kdm1;
++i2;
/* Computing MAX */
i__4 = 1, i__5 = j - ibl;
iqb = max(i__4,i__5);
nq = iqaend + 1 - iqb;
/* Computing MIN */
i__4 = iqaend + *kd;
iqaend = min(i__4,iqend);
crot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
&q[iqb + j * q_dim1], &c__1, &d__[j],
&work[j]);
/* L170: */
}
} else {
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+= i__3) {
crot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
j * q_dim1 + 1], &c__1, &d__[j], &
work[j]);
/* L180: */
}
}
}
if (j2 + kdn > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 = j2 - kdn - 1;
}
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2)
{
/* create nonzero element a(j+kd,j-1) outside the */
/* band and store it in WORK */
i__4 = j + *kd;
i__5 = j;
i__6 = kd1 + j * ab_dim1;
q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
ab[i__6].i, q__1.i = work[i__5].r * ab[i__6]
.i + work[i__5].i * ab[i__6].r;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
i__4 = kd1 + j * ab_dim1;
i__5 = j;
i__6 = kd1 + j * ab_dim1;
q__1.r = d__[i__5] * ab[i__6].r, q__1.i = d__[i__5] *
ab[i__6].i;
ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
/* L190: */
}
/* L200: */
}
/* L210: */
}
}
if (*kd > 0) {
/* make off-diagonal elements real and copy them to E */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ * ab_dim1 + 2;
t.r = ab[i__2].r, t.i = ab[i__2].i;
abst = c_abs(&t);
i__2 = i__ * ab_dim1 + 2;
ab[i__2].r = abst, ab[i__2].i = 0.f;
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (i__ < *n - 1) {
i__2 = (i__ + 1) * ab_dim1 + 2;
i__3 = (i__ + 1) * ab_dim1 + 2;
q__1.r = ab[i__3].r * t.r - ab[i__3].i * t.i, q__1.i = ab[
i__3].r * t.i + ab[i__3].i * t.r;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
}
if (wantq) {
cscal_(n, &t, &q[(i__ + 1) * q_dim1 + 1], &c__1);
}
/* L220: */
}
} else {
/* set E to zero if original matrix was diagonal */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = 0.f;
/* L230: */
}
}
/* copy diagonal elements to D */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ * ab_dim1 + 1;
d__[i__2] = ab[i__3].r;
/* L240: */
}
}
return 0;
/* End of CHBTRD */
} /* chbtrd_ */
/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
integer *kl, integer *ku, complex *ab, integer *ldab, real *d, real *
e, complex *q, integer *ldq, complex *pt, integer *ldpt, complex *c,
integer *ldc, complex *work, real *rwork, 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
=======
CGBBRD reduces a complex general m-by-n band matrix A to real upper
bidiagonal form B by a unitary transformation: Q' * A * P = B.
The routine computes B, and optionally forms Q or P', or computes
Q'*C for a given matrix C.
Arguments
=========
VECT (input) CHARACTER*1
Specifies whether or not the matrices Q and P' are to be
formed.
= 'N': do not form Q or P';
= 'Q': form Q only;
= 'P': form P' only;
= 'B': form both.
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.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
KL (input) INTEGER
The number of subdiagonals of the matrix A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals of the matrix A. KU >= 0.
AB (input/output) COMPLEX array, dimension (LDAB,N)
On entry, the m-by-n band matrix A, stored in rows 1 to
KL+KU+1. The j-th column of A is stored in the j-th column of
the array AB as follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
On exit, A is overwritten by values generated during the
reduction.
LDAB (input) INTEGER
The leading dimension of the array A. LDAB >= KL+KU+1.
D (output) REAL array, dimension (min(M,N))
The diagonal elements of the bidiagonal matrix B.
E (output) REAL array, dimension (min(M,N)-1)
The superdiagonal elements of the bidiagonal matrix B.
Q (output) COMPLEX array, dimension (LDQ,M)
If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
If VECT = 'N' or 'P', the array Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
PT (output) COMPLEX array, dimension (LDPT,N)
If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
If VECT = 'N' or 'Q', the array PT is not referenced.
LDPT (input) INTEGER
The leading dimension of the array PT.
LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
C (input/output) COMPLEX array, dimension (LDC,NCC)
On entry, an m-by-ncc matrix C.
On exit, C is overwritten by Q'*C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
WORK (workspace) COMPLEX array, dimension (max(M,N))
RWORK (workspace) REAL array, dimension (max(M,N))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
static integer inca;
static real abst;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
static integer i, j, l;
static complex t;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
static logical wantb, wantc;
static integer minmn;
static logical wantq;
static integer j1, j2, kb;
static complex ra;
static real rc;
static integer kk;
static complex rb;
static integer ml, nr, mu;
static complex rs;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*), clargv_(integer *, complex *, integer *, complex *,
integer *, real *, integer *), clartv_(integer *, complex *,
integer *, complex *, integer *, real *, complex *, integer *);
static integer kb1, ml0;
static logical wantpt;
static integer mu0, klm, kun, nrt, klu1;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define PT(I,J) pt[(I)-1 + ((J)-1)* ( *ldpt)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
claset_("Full", m, m, &c_b1, &c_b2, &Q(1,1), ldq);
}
if (wantpt) {
claset_("Full", n, n, &c_b1, &c_b2, &PT(1,1), ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = min(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
first to lower bidiagonal form and then transform to upper
bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied
in
vector operations of length NR over the index set J1:J2:KLU1
.
The complex sines of the plane rotations are stored in WORK,
and the real cosines in RWORK.
Computing MIN */
i__1 = *m - 1;
klm = min(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = min(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i = 1; i <= minmn; ++i) {
/* Reduce i-th column and i-th row of matrix to bidiagon
al form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= kb; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero
elements
which have been created below the band */
if (nr > 0) {
clargv_(&nr, &AB(klu1,j1-klm-1), &inca,
&WORK(j1), &kb1, &RWORK(j1), &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= kb; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &AB(klu1-l,j1-klm+l-1), &inca, &AB(klu1-l+1,j1-klm+l-1), &inca, &RWORK(j1), &WORK(
j1), &kb1);
}
/* L10: */
}
if (ml > ml0) {
if (ml <= *m - i + 1) {
/* generate plane rotation to annih
ilate a(i+ml-1,i)
within the band, and apply rotat
ion from the left */
clartg_(&AB(*ku+ml-1,i), &AB(*ku+ml,i), &RWORK(i + ml - 1), &WORK(i +
ml - 1), &ra);
i__3 = *ku + ml - 1 + i * ab_dim1;
AB(*ku+ml-1,i).r = ra.r, AB(*ku+ml-1,i).i = ra.i;
if (i < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i;
i__3 = min(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
crot_(&i__3, &AB(*ku+ml-2,i+1)
, &i__6, &AB(*ku+ml-1,i+1), &i__7, &RWORK(i + ml - 1), &
WORK(i + ml - 1));
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations i
n Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
r_cnjg(&q__1, &WORK(j));
crot_(m, &Q(1,j-1), &c__1, &Q(1,j), &c__1, &RWORK(j), &q__1);
/* L20: */
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
crot_(ncc, &C(j-1,1), ldc, &C(j,1),
ldc, &RWORK(j), &WORK(j));
/* L30: */
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of
the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {
/* create nonzero element a(j-1,j+ku) abov
e the band
and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = WORK(j).r * AB(1,j+kun).r - WORK(j).i * AB(1,j+kun).i, q__1.i = WORK(j).r * AB(1,j+kun).i +
WORK(j).i * AB(1,j+kun).r;
WORK(j+kun).r = q__1.r, WORK(j+kun).i = q__1.i;
i__5 = (j + kun) * ab_dim1 + 1;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = RWORK(j) * AB(1,j+kun).r, q__1.i = RWORK(j) *
AB(1,j+kun).i;
AB(1,j+kun).r = q__1.r, AB(1,j+kun).i = q__1.i;
/* L40: */
}
/* generate plane rotations to annihilate nonzero
elements
which have been generated above the band */
if (nr > 0) {
clargv_(&nr, &AB(1,j1+kun-1), &inca, &
WORK(j1 + kun), &kb1, &RWORK(j1 + kun), &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= kb; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &AB(l+1,j1+kun-1), &
inca, &AB(l,j1+kun), &inca, &
RWORK(j1 + kun), &WORK(j1 + kun), &kb1);
}
/* L50: */
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i + 1) {
/* generate plane rotation to annih
ilate a(i,i+mu-1)
within the band, and apply rotat
ion from the right */
clartg_(&AB(*ku-mu+3,i+mu-2), &
AB(*ku-mu+2,i+mu-1), &
RWORK(i + mu - 1), &WORK(i + mu - 1), &ra);
i__4 = *ku - mu + 3 + (i + mu - 2) * ab_dim1;
AB(*ku-mu+3,i+mu-2).r = ra.r, AB(*ku-mu+3,i+mu-2).i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i;
i__4 = min(i__3,i__5);
crot_(&i__4, &AB(*ku-mu+4,i+mu-2), &c__1, &AB(*ku-mu+3,i+mu-1), &c__1, &RWORK(i + mu - 1), &
WORK(i + mu - 1));
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations i
n P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
r_cnjg(&q__1, &WORK(j + kun));
crot_(n, &PT(j+kun-1,1), ldpt, &PT(j+kun,1), ldpt, &RWORK(j + kun), &q__1);
/* L60: */
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of
the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {
/* create nonzero element a(j+kl+ku,j+ku-1
) below the
band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = WORK(j+kun).r * AB(klu1,j+kun).r - WORK(j+kun).i * AB(klu1,j+kun).i, q__1.i = WORK(j+kun).r * AB(klu1,j+kun).i +
WORK(j+kun).i * AB(klu1,j+kun).r;
WORK(j+kb).r = q__1.r, WORK(j+kb).i = q__1.i;
i__5 = klu1 + (j + kun) * ab_dim1;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = RWORK(j+kun) * AB(klu1,j+kun).r, q__1.i = RWORK(j+kun) *
AB(klu1,j+kun).i;
AB(klu1,j+kun).r = q__1.r, AB(klu1,j+kun).i = q__1.i;
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form
Transform lower bidiagonal form to upper bidiagonal by apply
ing
plane rotations from the left, overwriting superdiagonal
elements on subdiagonal elements
Computing MIN */
i__2 = *m - 1;
i__1 = min(i__2,*n);
for (i = 1; i <= min(*m-1,*n); ++i) {
clartg_(&AB(1,i), &AB(2,i), &rc, &rs, &ra)
;
i__2 = i * ab_dim1 + 1;
AB(1,i).r = ra.r, AB(1,i).i = ra.i;
if (i < *n) {
i__2 = i * ab_dim1 + 2;
i__4 = (i + 1) * ab_dim1 + 1;
q__1.r = rs.r * AB(1,i+1).r - rs.i * AB(1,i+1).i, q__1.i = rs.r
* AB(1,i+1).i + rs.i * AB(1,i+1).r;
AB(2,i).r = q__1.r, AB(2,i).i = q__1.i;
i__2 = (i + 1) * ab_dim1 + 1;
i__4 = (i + 1) * ab_dim1 + 1;
q__1.r = rc * AB(1,i+1).r, q__1.i = rc * AB(1,i+1).i;
AB(1,i+1).r = q__1.r, AB(1,i+1).i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &rs);
crot_(m, &Q(1,i), &c__1, &Q(1,i+1),
&c__1, &rc, &q__1);
}
if (wantc) {
crot_(ncc, &C(i,1), ldc, &C(i+1,1), ldc, &rc,
&rs);
}
/* L100: */
}
} else {
/* A has been reduced to complex upper bidiagonal form or is
diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from
the
right */
i__1 = *ku + (*m + 1) * ab_dim1;
rb.r = AB(*ku,*m+1).r, rb.i = AB(*ku,*m+1).i;
for (i = *m; i >= 1; --i) {
clartg_(&AB(*ku+1,i), &rb, &rc, &rs, &ra);
i__1 = *ku + 1 + i * ab_dim1;
AB(*ku+1,i).r = ra.r, AB(*ku+1,i).i = ra.i;
if (i > 1) {
r_cnjg(&q__3, &rs);
q__2.r = -(doublereal)q__3.r, q__2.i = -(doublereal)
q__3.i;
i__1 = *ku + i * ab_dim1;
q__1.r = q__2.r * AB(*ku,i).r - q__2.i * AB(*ku,i).i,
q__1.i = q__2.r * AB(*ku,i).i + q__2.i * AB(*ku,i)
.r;
rb.r = q__1.r, rb.i = q__1.i;
i__1 = *ku + i * ab_dim1;
i__2 = *ku + i * ab_dim1;
q__1.r = rc * AB(*ku,i).r, q__1.i = rc * AB(*ku,i).i;
AB(*ku,i).r = q__1.r, AB(*ku,i).i = q__1.i;
}
if (wantpt) {
r_cnjg(&q__1, &rs);
crot_(n, &PT(i,1), ldpt, &PT(*m+1,1),
ldpt, &rc, &q__1);
}
/* L110: */
}
}
}
/* Make diagonal and superdiagonal elements real, storing them in D
and E */
i__1 = *ku + 1 + ab_dim1;
t.r = AB(*ku+1,1).r, t.i = AB(*ku+1,1).i;
i__1 = minmn;
for (i = 1; i <= minmn; ++i) {
abst = c_abs(&t);
D(i) = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantq) {
cscal_(m, &t, &Q(1,i), &c__1);
}
if (wantc) {
r_cnjg(&q__1, &t);
cscal_(ncc, &q__1, &C(i,1), ldc);
}
if (i < minmn) {
if (*ku == 0 && *kl == 0) {
E(i) = 0.f;
i__2 = (i + 1) * ab_dim1 + 1;
t.r = AB(1,i+1).r, t.i = AB(1,i+1).i;
} else {
if (*ku == 0) {
i__2 = i * ab_dim1 + 2;
r_cnjg(&q__2, &t);
q__1.r = AB(2,i).r * q__2.r - AB(2,i).i * q__2.i,
q__1.i = AB(2,i).r * q__2.i + AB(2,i).i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
} else {
i__2 = *ku + (i + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = AB(*ku,i+1).r * q__2.r - AB(*ku,i+1).i * q__2.i,
q__1.i = AB(*ku,i+1).r * q__2.i + AB(*ku,i+1).i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
abst = c_abs(&t);
E(i) = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantpt) {
cscal_(n, &t, &PT(i+1,1), ldpt);
}
i__2 = *ku + 1 + (i + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = AB(*ku+1,i+1).r * q__2.r - AB(*ku+1,i+1).i * q__2.i, q__1.i =
AB(*ku+1,i+1).r * q__2.i + AB(*ku+1,i+1).i * q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
}
/* L120: */
}
return 0;
/* End of CGBBRD */
} /* cgbbrd_ */
/* Subroutine */ int cgghrd_(char *compq, char *compz, integer *n, integer *
ilo, integer *ihi, complex *a, integer *lda, complex *b, integer *ldb,
complex *q, integer *ldq, complex *z__, integer *ldz, integer *info,
ftnlen compq_len, ftnlen compz_len)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static real c__;
static complex s;
static logical ilq, ilz;
static integer jcol;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
static integer jrow;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static complex ctemp;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *, ftnlen), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*, ftnlen);
static integer icompq, icompz;
/* -- 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 */
/* ======= */
/* CGGHRD reduces a pair of complex matrices (A,B) to generalized upper */
/* Hessenberg form using unitary transformations, where A is a */
/* general matrix and B is upper triangular: Q' * A * Z = H and */
/* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, */
/* and Q and Z are unitary, and ' means conjugate transpose. */
/* The unitary matrices Q and Z are determined as products of Givens */
/* rotations. They may either be formed explicitly, or they may be */
/* postmultiplied into input matrices Q1 and Z1, so that */
/* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' */
/* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' */
/* Arguments */
/* ========= */
/* COMPQ (input) CHARACTER*1 */
/* = 'N': do not compute Q; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* unitary matrix Q is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry, */
/* and the product Q1*Q is returned. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': do not compute Q; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* unitary matrix Q is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry, */
/* and the product Q1*Q is returned. */
/* N (input) INTEGER */
/* The order of the matrices A and B. 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 CGGBAL; otherwise they should be set */
/* to 1 and N respectively. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) COMPLEX 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 */
/* rest is set to zero. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB, N) */
/* On entry, the N-by-N upper triangular matrix B. */
/* On exit, the upper triangular matrix T = Q' B Z. The */
/* elements below the diagonal are set to zero. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
/* If COMPQ='N': Q is not referenced. */
/* If COMPQ='I': on entry, Q need not be set, and on exit it */
/* contains the unitary matrix Q, where Q' */
/* is the product of the Givens transformations */
/* which are applied to A and B on the left. */
/* If COMPQ='V': on entry, Q must contain a unitary matrix */
/* Q1, and on exit this is overwritten by Q1*Q. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */
/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
/* If COMPZ='N': Z is not referenced. */
/* If COMPZ='I': on entry, Z need not be set, and on exit it */
/* contains the unitary matrix Z, which is */
/* the product of the Givens transformations */
/* which are applied to A and B on the right. */
/* If COMPZ='V': on entry, Z must contain a unitary matrix */
/* Z1, and on exit this is overwritten by Z1*Z. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. */
/* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* This routine reduces A to Hessenberg and B to triangular form by */
/* an unblocked reduction, as described in _Matrix_Computations_, */
/* by Golub and van Loan (Johns Hopkins Press). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode COMPQ */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
if (lsame_(compq, "N", (ftnlen)1, (ftnlen)1)) {
ilq = FALSE_;
icompq = 1;
} else if (lsame_(compq, "V", (ftnlen)1, (ftnlen)1)) {
ilq = TRUE_;
icompq = 2;
} else if (lsame_(compq, "I", (ftnlen)1, (ftnlen)1)) {
ilq = TRUE_;
icompq = 3;
} else {
icompq = 0;
}
/* Decode COMPZ */
if (lsame_(compz, "N", (ftnlen)1, (ftnlen)1)) {
ilz = FALSE_;
icompz = 1;
} else if (lsame_(compz, "V", (ftnlen)1, (ftnlen)1)) {
ilz = TRUE_;
icompz = 2;
} else if (lsame_(compz, "I", (ftnlen)1, (ftnlen)1)) {
ilz = TRUE_;
icompz = 3;
} else {
icompz = 0;
}
/* Test the input parameters. */
*info = 0;
if (icompq <= 0) {
*info = -1;
} else if (icompz <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1) {
*info = -4;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (ilq && *ldq < *n || *ldq < 1) {
*info = -11;
} else if (ilz && *ldz < *n || *ldz < 1) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGHRD", &i__1, (ftnlen)6);
return 0;
}
/* Initialize Q and Z if desired. */
if (icompq == 3) {
claset_("Full", n, n, &c_b2, &c_b1, &q[q_offset], ldq, (ftnlen)4);
}
if (icompz == 3) {
claset_("Full", n, n, &c_b2, &c_b1, &z__[z_offset], ldz, (ftnlen)4);
}
/* Quick return if possible */
if (*n <= 1) {
return 0;
}
/* Zero out lower triangle of B */
i__1 = *n - 1;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = jcol + 1; jrow <= i__2; ++jrow) {
i__3 = jrow + jcol * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
/* Reduce A and B */
i__1 = *ihi - 2;
for (jcol = *ilo; jcol <= i__1; ++jcol) {
i__2 = jcol + 2;
for (jrow = *ihi; jrow >= i__2; --jrow) {
/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */
i__3 = jrow - 1 + jcol * a_dim1;
ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
clartg_(&ctemp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 +
jcol * a_dim1]);
i__3 = jrow + jcol * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = *n - jcol;
crot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + (
jcol + 1) * a_dim1], lda, &c__, &s);
i__3 = *n + 2 - jrow;
crot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + (
jrow - 1) * b_dim1], ldb, &c__, &s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1
+ 1], &c__1, &c__, &q__1);
}
/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */
i__3 = jrow + jrow * b_dim1;
ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
clartg_(&ctemp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow
+ jrow * b_dim1]);
i__3 = jrow + (jrow - 1) * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
crot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 +
1], &c__1, &c__, &s);
i__3 = jrow - 1;
crot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1
+ 1], &c__1, &c__, &s);
if (ilz) {
crot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) *
z_dim1 + 1], &c__1, &c__, &s);
}
/* L30: */
}
/* L40: */
}
return 0;
/* End of CGGHRD */
} /* cgghrd_ */
/* Subroutine */ int ctgsja_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, integer *k, integer *l, complex *a, integer *
lda, complex *b, integer *ldb, real *tola, real *tolb, real *alpha,
real *beta, complex *u, integer *ldu, complex *v, integer *ldv,
complex *q, integer *ldq, complex *work, integer *ncycle, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
real r__1;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real a1, b1, a3, b3;
complex a2, b2;
real csq, csu, csv;
complex snq;
real rwk;
complex snu, snv;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
real gamma;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
logical initq, initu, initv, wantq, upper;
real error, ssmin;
logical wantu, wantv;
extern /* Subroutine */ int clags2_(logical *, real *, complex *, real *,
real *, complex *, real *, real *, complex *, real *, complex *,
real *, complex *), clapll_(integer *, complex *, integer *,
complex *, integer *, real *), csscal_(integer *, real *, complex
*, integer *);
integer kcycle;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), xerbla_(char *,
integer *), slartg_(real *, real *, real *, real *, real *
);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTGSJA computes the generalized singular value decomposition (GSVD) */
/* of two complex upper triangular (or trapezoidal) matrices A and B. */
/* On entry, it is assumed that matrices A and B have the following */
/* forms, which may be obtained by the preprocessing subroutine CGGSVP */
/* from a general M-by-N matrix A and P-by-N matrix B: */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
/* L ( 0 0 A23 ) */
/* M-K-L ( 0 0 0 ) */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
/* M-K ( 0 0 A23 ) */
/* N-K-L K L */
/* B = L ( 0 0 B13 ) */
/* P-L ( 0 0 0 ) */
/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
/* On exit, */
/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
/* where U, V and Q are unitary matrices, Z' denotes the conjugate */
/* transpose of Z, R is a nonsingular upper triangular matrix, and D1 */
/* and D2 are ``diagonal'' matrices, which are of the following */
/* structures: */
/* If M-K-L >= 0, */
/* K L */
/* D1 = K ( I 0 ) */
/* L ( 0 C ) */
/* M-K-L ( 0 0 ) */
/* K L */
/* D2 = L ( 0 S ) */
/* P-L ( 0 0 ) */
/* N-K-L K L */
/* ( 0 R ) = K ( 0 R11 R12 ) K */
/* L ( 0 0 R22 ) L */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
/* C**2 + S**2 = I. */
/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
/* If M-K-L < 0, */
/* K M-K K+L-M */
/* D1 = K ( I 0 0 ) */
/* M-K ( 0 C 0 ) */
/* K M-K K+L-M */
/* D2 = M-K ( 0 S 0 ) */
/* K+L-M ( 0 0 I ) */
/* P-L ( 0 0 0 ) */
/* N-K-L K M-K K+L-M */
/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
/* M-K ( 0 0 R22 R23 ) */
/* K+L-M ( 0 0 0 R33 ) */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
/* S = diag( BETA(K+1), ... , BETA(M) ), */
/* C**2 + S**2 = I. */
/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
/* ( 0 R22 R23 ) */
/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
/* The computation of the unitary transformation matrices U, V or Q */
/* is optional. These matrices may either be formed explicitly, or they */
/* may be postmultiplied into input matrices U1, V1, or Q1. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* = 'U': U must contain a unitary matrix U1 on entry, and */
/* the product U1*U is returned; */
/* = 'I': U is initialized to the unit matrix, and the */
/* unitary matrix U is returned; */
/* = 'N': U is not computed. */
/* JOBV (input) CHARACTER*1 */
/* = 'V': V must contain a unitary matrix V1 on entry, and */
/* the product V1*V is returned; */
/* = 'I': V is initialized to the unit matrix, and the */
/* unitary matrix V is returned; */
/* = 'N': V is not computed. */
/* JOBQ (input) CHARACTER*1 */
/* = 'Q': Q must contain a unitary matrix Q1 on entry, and */
/* the product Q1*Q is returned; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* unitary matrix Q is returned; */
/* = 'N': Q is not computed. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. P >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* K (input) INTEGER */
/* L (input) INTEGER */
/* K and L specify the subblocks in the input matrices A and B: */
/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N) */
/* of A and B, whose GSVD is going to be computed by CTGSJA. */
/* See Further details. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
/* matrix R or part of R. See Purpose for details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) COMPLEX array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
/* a part of R. See Purpose for details. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* TOLA (input) REAL */
/* TOLB (input) REAL */
/* TOLA and TOLB are the convergence criteria for the Jacobi- */
/* Kogbetliantz iteration procedure. Generally, they are the */
/* same as used in the preprocessing step, say */
/* TOLA = MAX(M,N)*norm(A)*MACHEPS, */
/* TOLB = MAX(P,N)*norm(B)*MACHEPS. */
/* ALPHA (output) REAL array, dimension (N) */
/* BETA (output) REAL array, dimension (N) */
/* On exit, ALPHA and BETA contain the generalized singular */
/* value pairs of A and B; */
/* ALPHA(1:K) = 1, */
/* BETA(1:K) = 0, */
/* and if M-K-L >= 0, */
/* ALPHA(K+1:K+L) = diag(C), */
/* BETA(K+1:K+L) = diag(S), */
/* or if M-K-L < 0, */
/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
/* Furthermore, if K+L < N, */
/* ALPHA(K+L+1:N) = 0 */
/* BETA(K+L+1:N) = 0. */
/* U (input/output) COMPLEX array, dimension (LDU,M) */
/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
/* the unitary matrix returned by CGGSVP). */
/* On exit, */
/* if JOBU = 'I', U contains the unitary matrix U; */
/* if JOBU = 'U', U contains the product U1*U. */
/* If JOBU = 'N', U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M) if */
/* JOBU = 'U'; LDU >= 1 otherwise. */
/* V (input/output) COMPLEX array, dimension (LDV,P) */
/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
/* the unitary matrix returned by CGGSVP). */
/* On exit, */
/* if JOBV = 'I', V contains the unitary matrix V; */
/* if JOBV = 'V', V contains the product V1*V. */
/* If JOBV = 'N', V is not referenced. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,P) if */
/* JOBV = 'V'; LDV >= 1 otherwise. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
/* the unitary matrix returned by CGGSVP). */
/* On exit, */
/* if JOBQ = 'I', Q contains the unitary matrix Q; */
/* if JOBQ = 'Q', Q contains the product Q1*Q. */
/* If JOBQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N) if */
/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* NCYCLE (output) INTEGER */
/* The number of cycles required for convergence. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1: the procedure does not converge after MAXIT cycles. */
/* Internal Parameters */
/* =================== */
/* MAXIT INTEGER */
/* MAXIT specifies the total loops that the iterative procedure */
/* may take. If after MAXIT cycles, the routine fails to */
/* converge, we return INFO = 1. */
/* Further Details */
/* =============== */
/* CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
/* matrix B13 to the form: */
/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
/* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate */
/* transpose of Z. C1 and S1 are diagonal matrices satisfying */
/* C1**2 + S1**2 = I, */
/* and R1 is an L-by-L nonsingular upper triangular matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alpha;
--beta;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
initu = lsame_(jobu, "I");
wantu = initu || lsame_(jobu, "U");
initv = lsame_(jobv, "I");
wantv = initv || lsame_(jobv, "V");
initq = lsame_(jobq, "I");
wantq = initq || lsame_(jobq, "Q");
*info = 0;
if (! (initu || wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (initv || wantv || lsame_(jobv, "N")))
{
*info = -2;
} else if (! (initq || wantq || lsame_(jobq, "N")))
{
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -10;
} else if (*ldb < max(1,*p)) {
*info = -12;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -18;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -20;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -22;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSJA", &i__1);
return 0;
}
/* Initialize U, V and Q, if necessary */
if (initu) {
claset_("Full", m, m, &c_b1, &c_b2, &u[u_offset], ldu);
}
if (initv) {
claset_("Full", p, p, &c_b1, &c_b2, &v[v_offset], ldv);
}
if (initq) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
/* Loop until convergence */
upper = FALSE_;
for (kcycle = 1; kcycle <= 40; ++kcycle) {
upper = ! upper;
i__1 = *l - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l;
for (j = i__ + 1; j <= i__2; ++j) {
a1 = 0.f;
a2.r = 0.f, a2.i = 0.f;
a3 = 0.f;
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
a1 = a[i__3].r;
}
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + j) * a_dim1;
a3 = a[i__3].r;
}
i__3 = i__ + (*n - *l + i__) * b_dim1;
b1 = b[i__3].r;
i__3 = j + (*n - *l + j) * b_dim1;
b3 = b[i__3].r;
if (upper) {
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + j) * a_dim1;
a2.r = a[i__3].r, a2.i = a[i__3].i;
}
i__3 = i__ + (*n - *l + j) * b_dim1;
b2.r = b[i__3].r, b2.i = b[i__3].i;
} else {
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + i__) * a_dim1;
a2.r = a[i__3].r, a2.i = a[i__3].i;
}
i__3 = j + (*n - *l + i__) * b_dim1;
b2.r = b[i__3].r, b2.i = b[i__3].i;
}
clags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
csv, &snv, &csq, &snq);
/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
if (*k + j <= *m) {
r_cnjg(&q__1, &snu);
crot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ i__ + (*n - *l + 1) * a_dim1], lda, &csu, &q__1)
;
}
/* Update I-th and J-th rows of matrix B: V'*B */
r_cnjg(&q__1, &snv);
crot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
l + 1) * b_dim1], ldb, &csv, &q__1);
/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
/* A and B: A*Q and B*Q */
/* Computing MIN */
i__4 = *k + *l;
i__3 = min(i__4,*m);
crot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
crot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
i__) * b_dim1 + 1], &c__1, &csq, &snq);
if (upper) {
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + j) * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
i__3 = i__ + (*n - *l + j) * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
} else {
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + i__) * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
i__3 = j + (*n - *l + i__) * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
}
/* Ensure that the diagonal elements of A and B are real. */
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
i__4 = *k + i__ + (*n - *l + i__) * a_dim1;
r__1 = a[i__4].r;
a[i__3].r = r__1, a[i__3].i = 0.f;
}
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + j) * a_dim1;
i__4 = *k + j + (*n - *l + j) * a_dim1;
r__1 = a[i__4].r;
a[i__3].r = r__1, a[i__3].i = 0.f;
}
i__3 = i__ + (*n - *l + i__) * b_dim1;
i__4 = i__ + (*n - *l + i__) * b_dim1;
r__1 = b[i__4].r;
b[i__3].r = r__1, b[i__3].i = 0.f;
i__3 = j + (*n - *l + j) * b_dim1;
i__4 = j + (*n - *l + j) * b_dim1;
r__1 = b[i__4].r;
b[i__3].r = r__1, b[i__3].i = 0.f;
/* Update unitary matrices U, V, Q, if desired. */
if (wantu && *k + j <= *m) {
crot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
u_dim1 + 1], &c__1, &csu, &snu);
}
if (wantv) {
crot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
&c__1, &csv, &snv);
}
if (wantq) {
crot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
}
/* L10: */
}
/* L20: */
}
if (! upper) {
/* The matrices A13 and B13 were lower triangular at the start */
/* of the cycle, and are now upper triangular. */
/* Convergence test: test the parallelism of the corresponding */
/* rows of A and B. */
error = 0.f;
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l - i__ + 1;
ccopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
work[1], &c__1);
i__2 = *l - i__ + 1;
ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
l + 1], &c__1);
i__2 = *l - i__ + 1;
clapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
error = dmax(error,ssmin);
/* L30: */
}
if (dabs(error) <= dmin(*tola,*tolb)) {
goto L50;
}
}
/* End of cycle loop */
/* L40: */
}
/* The algorithm has not converged after MAXIT cycles. */
*info = 1;
goto L100;
L50:
/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
/* Compute the generalized singular value pairs (ALPHA, BETA), and */
/* set the triangular matrix R to array A. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
alpha[i__] = 1.f;
beta[i__] = 0.f;
/* L60: */
}
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *k + i__ + (*n - *l + i__) * a_dim1;
a1 = a[i__2].r;
i__2 = i__ + (*n - *l + i__) * b_dim1;
b1 = b[i__2].r;
if (a1 != 0.f) {
gamma = b1 / a1;
if (gamma < 0.f) {
i__2 = *l - i__ + 1;
csscal_(&i__2, &c_b39, &b[i__ + (*n - *l + i__) * b_dim1],
ldb);
if (wantv) {
csscal_(p, &c_b39, &v[i__ * v_dim1 + 1], &c__1);
}
}
r__1 = dabs(gamma);
slartg_(&r__1, &c_b42, &beta[*k + i__], &alpha[*k + i__], &rwk);
if (alpha[*k + i__] >= beta[*k + i__]) {
i__2 = *l - i__ + 1;
r__1 = 1.f / alpha[*k + i__];
csscal_(&i__2, &r__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
lda);
} else {
i__2 = *l - i__ + 1;
r__1 = 1.f / beta[*k + i__];
csscal_(&i__2, &r__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
;
i__2 = *l - i__ + 1;
ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ i__ + (*n - *l + i__) * a_dim1], lda);
}
} else {
alpha[*k + i__] = 0.f;
beta[*k + i__] = 1.f;
i__2 = *l - i__ + 1;
ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
i__ + (*n - *l + i__) * a_dim1], lda);
}
/* L70: */
}
/* Post-assignment */
i__1 = *k + *l;
for (i__ = *m + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.f;
beta[i__] = 1.f;
/* L80: */
}
if (*k + *l < *n) {
i__1 = *n;
for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.f;
beta[i__] = 0.f;
/* L90: */
}
}
L100:
*ncycle = kcycle;
return 0;
/* End of CTGSJA */
} /* ctgsja_ */
int cgghrd_(char *compq, char *compz, int *n, int *
ilo, int *ihi, complex *a, int *lda, complex *b, int *ldb,
complex *q, int *ldq, complex *z__, int *ldz, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
float c__;
complex s;
int ilq, ilz;
int jcol;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *);
int jrow;
extern int lsame_(char *, char *);
complex ctemp;
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *), xerbla_(char *, int
*);
int icompq, icompz;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGHRD reduces a pair of complex matrices (A,B) to generalized upper */
/* Hessenberg form using unitary transformations, where A is a */
/* general matrix and B is upper triangular. The form of the generalized */
/* eigenvalue problem is */
/* A*x = lambda*B*x, */
/* and B is typically made upper triangular by computing its QR */
/* factorization and moving the unitary matrix Q to the left side */
/* of the equation. */
/* This subroutine simultaneously reduces A to a Hessenberg matrix H: */
/* Q**H*A*Z = H */
/* and transforms B to another upper triangular matrix T: */
/* Q**H*B*Z = T */
/* in order to reduce the problem to its standard form */
/* H*y = lambda*T*y */
/* where y = Z**H*x. */
/* The unitary matrices Q and Z are determined as products of Givens */
/* rotations. They may either be formed explicitly, or they may be */
/* postmultiplied into input matrices Q1 and Z1, so that */
/* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H */
/* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H */
/* If Q1 is the unitary matrix from the QR factorization of B in the */
/* original equation A*x = lambda*B*x, then CGGHRD reduces the original */
/* problem to generalized Hessenberg form. */
/* Arguments */
/* ========= */
/* COMPQ (input) CHARACTER*1 */
/* = 'N': do not compute Q; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* unitary matrix Q is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry, */
/* and the product Q1*Q is returned. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': do not compute Q; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* unitary matrix Q is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry, */
/* and the product Q1*Q is returned. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* ILO and IHI mark the rows and columns of A which are to be */
/* reduced. 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 CGGBAL; otherwise they */
/* should be set to 1 and N respectively. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) COMPLEX 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 */
/* rest is set to zero. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB, N) */
/* On entry, the N-by-N upper triangular matrix B. */
/* On exit, the upper triangular matrix T = Q**H B Z. The */
/* elements below the diagonal are set to zero. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
/* On entry, if COMPQ = 'V', the unitary matrix Q1, typically */
/* from the QR factorization of B. */
/* On exit, if COMPQ='I', the unitary matrix Q, and if */
/* COMPQ = 'V', the product Q1*Q. */
/* Not referenced if COMPQ='N'. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */
/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Z1. */
/* On exit, if COMPZ='I', the unitary matrix Z, and if */
/* COMPZ = 'V', the product Z1*Z. */
/* Not referenced if COMPZ='N'. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. */
/* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* This routine reduces A to Hessenberg and B to triangular form by */
/* an unblocked reduction, as described in _Matrix_Computations_, */
/* by Golub and van Loan (Johns Hopkins Press). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode COMPQ */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
if (lsame_(compq, "N")) {
ilq = FALSE;
icompq = 1;
} else if (lsame_(compq, "V")) {
ilq = TRUE;
icompq = 2;
} else if (lsame_(compq, "I")) {
ilq = TRUE;
icompq = 3;
} else {
icompq = 0;
}
/* Decode COMPZ */
if (lsame_(compz, "N")) {
ilz = FALSE;
icompz = 1;
} else if (lsame_(compz, "V")) {
ilz = TRUE;
icompz = 2;
} else if (lsame_(compz, "I")) {
ilz = TRUE;
icompz = 3;
} else {
icompz = 0;
}
/* Test the input parameters. */
*info = 0;
if (icompq <= 0) {
*info = -1;
} else if (icompz <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1) {
*info = -4;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -5;
} else if (*lda < MAX(1,*n)) {
*info = -7;
} else if (*ldb < MAX(1,*n)) {
*info = -9;
} else if (ilq && *ldq < *n || *ldq < 1) {
*info = -11;
} else if (ilz && *ldz < *n || *ldz < 1) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGHRD", &i__1);
return 0;
}
/* Initialize Q and Z if desired. */
if (icompq == 3) {
claset_("Full", n, n, &c_b2, &c_b1, &q[q_offset], ldq);
}
if (icompz == 3) {
claset_("Full", n, n, &c_b2, &c_b1, &z__[z_offset], ldz);
}
/* Quick return if possible */
if (*n <= 1) {
return 0;
}
/* Zero out lower triangle of B */
i__1 = *n - 1;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = jcol + 1; jrow <= i__2; ++jrow) {
i__3 = jrow + jcol * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
/* Reduce A and B */
i__1 = *ihi - 2;
for (jcol = *ilo; jcol <= i__1; ++jcol) {
i__2 = jcol + 2;
for (jrow = *ihi; jrow >= i__2; --jrow) {
/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */
i__3 = jrow - 1 + jcol * a_dim1;
ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
clartg_(&ctemp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 +
jcol * a_dim1]);
i__3 = jrow + jcol * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = *n - jcol;
crot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + (
jcol + 1) * a_dim1], lda, &c__, &s);
i__3 = *n + 2 - jrow;
crot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + (
jrow - 1) * b_dim1], ldb, &c__, &s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1
+ 1], &c__1, &c__, &q__1);
}
/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */
i__3 = jrow + jrow * b_dim1;
ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
clartg_(&ctemp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow
+ jrow * b_dim1]);
i__3 = jrow + (jrow - 1) * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
crot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 +
1], &c__1, &c__, &s);
i__3 = jrow - 1;
crot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1
+ 1], &c__1, &c__, &s);
if (ilz) {
crot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) *
z_dim1 + 1], &c__1, &c__, &s);
}
/* L30: */
}
/* L40: */
}
return 0;
/* End of CGGHRD */
} /* cgghrd_ */
