/* 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_ */
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_ */
/* 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_ */
