/* Subroutine */ int cgelq2_(integer *m, integer *n, complex *a, integer *lda,
complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, k;
complex alpha;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
clacgv_(integer *, complex *, integer *), clarfp_(integer *,
complex *, complex *, integer *, complex *), xerbla_(char *,
integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGELQ2 computes an LQ factorization of a complex m by n matrix A: */
/* A = L * Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, the elements on and below the diagonal of the array */
/* contain the m by min(m,n) lower trapezoidal matrix L (L is */
/* lower triangular if m <= n); the elements above the diagonal, */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */
/* A(i,i+1:n), and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGELQ2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
clarfp_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &tau[i__]
);
if (i__ < *m) {
/* Apply H(i) to A(i+1:m,i:n) from the right */
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
i__2 = *m - i__;
i__3 = *n - i__ + 1;
clarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
}
i__2 = i__ + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
i__2 = *n - i__ + 1;
clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
/* L10: */
}
return 0;
/* End of CGELQ2 */
} /* cgelq2_ */
/* Subroutine */ int cupmtr_(char *side, char *uplo, char *trans, integer *m,
integer *n, complex *ap, complex *tau, complex *c__, integer *ldc,
complex *work, integer *info, ftnlen side_len, ftnlen uplo_len,
ftnlen trans_len)
{
/* System generated locals */
integer c_dim1, c_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer i__, i1, i2, i3, ic, jc, ii, mi, ni, nq;
static complex aii;
static logical left;
static complex taui;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static logical notran, forwrd;
/* -- 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 */
/* ======= */
/* CUPMTR overwrites the general complex M-by-N matrix C with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'C': Q**H * C C * Q**H */
/* where Q is a complex unitary matrix of order nq, with nq = m if */
/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
/* nq-1 elementary reflectors, as returned by CHPTRD using packed */
/* storage: */
/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q**H from the Left; */
/* = 'R': apply Q or Q**H from the Right. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangular packed storage used in previous */
/* call to CHPTRD; */
/* = 'L': Lower triangular packed storage used in previous */
/* call to CHPTRD. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q; */
/* = 'C': Conjugate transpose, apply Q**H. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* AP (input) COMPLEX array, dimension */
/* (M*(M+1)/2) if SIDE = 'L' */
/* (N*(N+1)/2) if SIDE = 'R' */
/* The vectors which define the elementary reflectors, as */
/* returned by CHPTRD. AP is modified by the routine but */
/* restored on exit. */
/* TAU (input) COMPLEX array, dimension (M-1) if SIDE = 'L' */
/* or (N-1) if SIDE = 'R' */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by CHPTRD. */
/* C (input/output) COMPLEX array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX array, dimension */
/* (N) if SIDE = 'L' */
/* (M) if SIDE = 'R' */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--ap;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! notran && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*ldc < max(1,*m)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUPMTR", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
if (upper) {
/* Q was determined by a call to CHPTRD with UPLO = 'U' */
forwrd = left && notran || ! left && ! notran;
if (forwrd) {
i1 = 1;
i2 = nq - 1;
i3 = 1;
ii = 2;
} else {
i1 = nq - 1;
i2 = 1;
i3 = -1;
ii = nq * (nq + 1) / 2 - 1;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) or H(i)' is applied to C(1:i,1:n) */
mi = i__;
} else {
/* H(i) or H(i)' is applied to C(1:m,1:i) */
ni = i__;
}
/* Apply H(i) or H(i)' */
if (notran) {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
} else {
r_cnjg(&q__1, &tau[i__]);
taui.r = q__1.r, taui.i = q__1.i;
}
i__3 = ii;
aii.r = ap[i__3].r, aii.i = ap[i__3].i;
i__3 = ii;
ap[i__3].r = 1.f, ap[i__3].i = 0.f;
clarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &taui, &c__[
c_offset], ldc, &work[1], (ftnlen)1);
i__3 = ii;
ap[i__3].r = aii.r, ap[i__3].i = aii.i;
if (forwrd) {
ii = ii + i__ + 2;
} else {
ii = ii - i__ - 1;
}
/* L10: */
}
} else {
/* Q was determined by a call to CHPTRD with UPLO = 'L'. */
forwrd = left && ! notran || ! left && notran;
if (forwrd) {
i1 = 1;
i2 = nq - 1;
i3 = 1;
ii = 2;
} else {
i1 = nq - 1;
i2 = 1;
i3 = -1;
ii = nq * (nq + 1) / 2 - 1;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__2 = i2;
i__1 = i3;
for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
i__3 = ii;
aii.r = ap[i__3].r, aii.i = ap[i__3].i;
i__3 = ii;
ap[i__3].r = 1.f, ap[i__3].i = 0.f;
if (left) {
/* H(i) or H(i)' is applied to C(i+1:m,1:n) */
mi = *m - i__;
ic = i__ + 1;
} else {
/* H(i) or H(i)' is applied to C(1:m,i+1:n) */
ni = *n - i__;
jc = i__ + 1;
}
/* Apply H(i) or H(i)' */
if (notran) {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
} else {
r_cnjg(&q__1, &tau[i__]);
taui.r = q__1.r, taui.i = q__1.i;
}
clarf_(side, &mi, &ni, &ap[ii], &c__1, &taui, &c__[ic + jc *
c_dim1], ldc, &work[1], (ftnlen)1);
i__3 = ii;
ap[i__3].r = aii.r, ap[i__3].i = aii.i;
if (forwrd) {
ii = ii + nq - i__ + 1;
} else {
ii = ii - nq + i__ - 2;
}
/* L20: */
}
}
return 0;
/* End of CUPMTR */
} /* cupmtr_ */
/* Subroutine */ int cgerq2_(integer *m, integer *n, complex *a, integer *lda,
complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer i__, k;
static complex alpha;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *, ftnlen),
clarfg_(integer *, complex *, complex *, integer *, complex *),
clacgv_(integer *, complex *, integer *), 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 */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGERQ2 computes an RQ factorization of a complex m by n matrix A: */
/* A = R * Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, if m <= n, the upper triangle of the subarray */
/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */
/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
/* contain the m by n upper trapezoidal matrix R; the remaining */
/* elements, with the array TAU, represent the unitary matrix */
/* Q as a product of elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */
/* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGERQ2", &i__1, (ftnlen)6);
return 0;
}
k = min(*m,*n);
for (i__ = k; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* A(m-k+i,1:n-k+i-1) */
i__1 = *n - k + i__;
clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
i__1 = *n - k + i__;
clarfg_(&i__1, &alpha, &a[*m - k + i__ + a_dim1], lda, &tau[i__]);
/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = 1.f, a[i__1].i = 0.f;
i__1 = *m - k + i__ - 1;
i__2 = *n - k + i__;
clarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[
i__], &a[a_offset], lda, &work[1], (ftnlen)5);
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = alpha.r, a[i__1].i = alpha.i;
i__1 = *n - k + i__ - 1;
clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
/* L10: */
}
return 0;
/* End of CGERQ2 */
} /* cgerq2_ */
/* Subroutine */ int cgelq2_(integer *m, integer *n, complex *a, integer *lda,
complex *tau, complex *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGELQ2 computes an LQ factorization of a complex m by n matrix A:
A = L * Q.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the m by n matrix A.
On exit, the elements on and below the diagonal of the array
contain the m by min(m,n) lower trapezoidal matrix L (L is
lower triangular if m <= n); the elements above the diagonal,
with the array TAU, represent the unitary matrix Q as a
product of elementary reflectors (see Further Details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) COMPLEX array, dimension (M)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
A(i,i+1:n), and tau in TAU(i).
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i, k;
static complex alpha;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
clarfg_(integer *, complex *, complex *, integer *, complex *),
clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
*);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGELQ2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i = 1; i <= k; ++i) {
/* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
*/
i__2 = *n - i + 1;
clacgv_(&i__2, &A(i,i), lda);
i__2 = i + i * a_dim1;
alpha.r = A(i,i).r, alpha.i = A(i,i).i;
i__2 = *n - i + 1;
/* Computing MIN */
i__3 = i + 1;
clarfg_(&i__2, &alpha, &A(i,min(i+1,*n)), lda, &TAU(i));
if (i < *m) {
/* Apply H(i) to A(i+1:m,i:n) from the right */
i__2 = i + i * a_dim1;
A(i,i).r = 1.f, A(i,i).i = 0.f;
i__2 = *m - i;
i__3 = *n - i + 1;
clarf_("Right", &i__2, &i__3, &A(i,i), lda, &TAU(i), &
A(i+1,i), lda, &WORK(1));
}
i__2 = i + i * a_dim1;
A(i,i).r = alpha.r, A(i,i).i = alpha.i;
i__2 = *n - i + 1;
clacgv_(&i__2, &A(i,i), lda);
/* L10: */
}
return 0;
/* End of CGELQ2 */
} /* cgelq2_ */
/* Subroutine */ int claqr2_(logical *wantt, logical *wantz, integer *n,
integer *ktop, integer *kbot, integer *nw, complex *h__, integer *ldh,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh,
complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv,
complex *work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
complex s;
integer jw;
real foo;
integer kln;
complex tau;
integer knt;
real ulp;
integer lwk1, lwk2;
complex beta;
integer kcol, info, ifst, ilst, ltop, krow;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
cgemm_(char *, char *, integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer
*, complex *, integer *);
integer infqr, kwtop;
extern /* Subroutine */ int slabad_(real *, real *), cgehrd_(integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, integer *), clarfg_(integer *, complex *, complex *,
integer *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clahqr_(logical *, logical *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
integer *, complex *, integer *, integer *), clacpy_(char *,
integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex
*, complex *, integer *);
real safmin, safmax;
extern /* Subroutine */ int ctrexc_(char *, integer *, complex *, integer
*, complex *, integer *, integer *, integer *, integer *),
cunmhr_(char *, char *, integer *, integer *, integer *, integer
*, complex *, integer *, complex *, complex *, integer *, complex
*, integer *, integer *);
real smlnum;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* -- April 2009 -- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* This subroutine is identical to CLAQR3 except that it avoids */
/* recursion by calling CLAHQR instead of CLAQR4. */
/* ****************************************************************** */
/* Aggressive early deflation: */
/* This subroutine accepts as input an upper Hessenberg matrix */
/* H and performs an unitary similarity transformation */
/* designed to detect and deflate fully converged eigenvalues from */
/* a trailing principal submatrix. On output H has been over- */
/* written by a new Hessenberg matrix that is a perturbation of */
/* an unitary similarity transformation of H. It is to be */
/* hoped that the final version of H has many zero subdiagonal */
/* entries. */
/* ****************************************************************** */
/* WANTT (input) LOGICAL */
/* If .TRUE., then the Hessenberg matrix H is fully updated */
/* so that the triangular Schur factor may be */
/* computed (in cooperation with the calling subroutine). */
/* If .FALSE., then only enough of H is updated to preserve */
/* the eigenvalues. */
/* WANTZ (input) LOGICAL */
/* If .TRUE., then the unitary matrix Z is updated so */
/* so that the unitary Schur factor may be computed */
/* (in cooperation with the calling subroutine). */
/* If .FALSE., then Z is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix H and (if WANTZ is .TRUE.) the */
/* order of the unitary matrix Z. */
/* KTOP (input) INTEGER */
/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
/* KBOT and KTOP together determine an isolated block */
/* along the diagonal of the Hessenberg matrix. */
/* KBOT (input) INTEGER */
/* It is assumed without a check that either */
/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
/* determine an isolated block along the diagonal of the */
/* Hessenberg matrix. */
/* NW (input) INTEGER */
/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
/* H (input/output) COMPLEX array, dimension (LDH,N) */
/* On input the initial N-by-N section of H stores the */
/* Hessenberg matrix undergoing aggressive early deflation. */
/* On output H has been transformed by a unitary */
/* similarity transformation, perturbed, and the returned */
/* to Hessenberg form that (it is to be hoped) has some */
/* zero subdiagonal entries. */
/* LDH (input) integer */
/* Leading dimension of H just as declared in the calling */
/* subroutine. N .LE. LDH */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
/* IF WANTZ is .TRUE., then on output, the unitary */
/* similarity transformation mentioned above has been */
/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ is .FALSE., then Z is unreferenced. */
/* LDZ (input) integer */
/* The leading dimension of Z just as declared in the */
/* calling subroutine. 1 .LE. LDZ. */
/* NS (output) integer */
/* The number of unconverged (ie approximate) eigenvalues */
/* returned in SR and SI that may be used as shifts by the */
/* calling subroutine. */
/* ND (output) integer */
/* The number of converged eigenvalues uncovered by this */
/* subroutine. */
/* SH (output) COMPLEX array, dimension KBOT */
/* On output, approximate eigenvalues that may */
/* be used for shifts are stored in SH(KBOT-ND-NS+1) */
/* through SR(KBOT-ND). Converged eigenvalues are */
/* stored in SH(KBOT-ND+1) through SH(KBOT). */
/* V (workspace) COMPLEX array, dimension (LDV,NW) */
/* An NW-by-NW work array. */
/* LDV (input) integer scalar */
/* The leading dimension of V just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* NH (input) integer scalar */
/* The number of columns of T. NH.GE.NW. */
/* T (workspace) COMPLEX array, dimension (LDT,NW) */
/* LDT (input) integer */
/* The leading dimension of T just as declared in the */
/* calling subroutine. NW .LE. LDT */
/* NV (input) integer */
/* The number of rows of work array WV available for */
/* workspace. NV.GE.NW. */
/* WV (workspace) COMPLEX array, dimension (LDWV,NW) */
/* LDWV (input) integer */
/* The leading dimension of W just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* WORK (workspace) COMPLEX array, dimension LWORK. */
/* On exit, WORK(1) is set to an estimate of the optimal value */
/* of LWORK for the given values of N, NW, KTOP and KBOT. */
/* LWORK (input) integer */
/* The dimension of the work array WORK. LWORK = 2*NW */
/* suffices, but greater efficiency may result from larger */
/* values of LWORK. */
/* If LWORK = -1, then a workspace query is assumed; CLAQR2 */
/* only estimates the optimal workspace size for the given */
/* values of N, NW, KTOP and KBOT. The estimate is returned */
/* in WORK(1). No error message related to LWORK is issued */
/* by XERBLA. Neither H nor Z are accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sh;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
/* ==== Workspace query call to CGEHRD ==== */
i__1 = jw - 1;
cgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
c_n1, &info);
lwk1 = (integer) work[1].r;
/* ==== Workspace query call to CUNMHR ==== */
i__1 = jw - 1;
cunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1].r;
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
r__1 = (real) lwkopt;
q__1.r = r__1, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1].r = 1.f, work[1].i = 0.f;
if (*ktop > *kbot) {
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1) {
return 0;
}
/* ==== Machine constants ==== */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s.r = 0.f, s.i = 0.f;
} else {
i__1 = kwtop + (kwtop - 1) * h_dim1;
s.r = h__[i__1].r, s.i = h__[i__1].i;
}
if (*kbot == kwtop) {
/* ==== 1-by-1 deflation window: not much to do ==== */
i__1 = kwtop;
i__2 = kwtop + kwtop * h_dim1;
sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i;
*ns = 1;
*nd = 0;
/* Computing MAX */
i__1 = kwtop + kwtop * h_dim1;
r__5 = smlnum, r__6 = ulp * ((r__1 = h__[i__1].r, dabs(r__1)) + (r__2
= r_imag(&h__[kwtop + kwtop * h_dim1]), dabs(r__2)));
if ((r__3 = s.r, dabs(r__3)) + (r__4 = r_imag(&s), dabs(r__4)) <=
dmax(r__5,r__6)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
i__1 = kwtop + (kwtop - 1) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
}
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
clacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
ccopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
i__3);
claset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
clahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[kwtop],
&c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
i__1 = jw;
for (knt = infqr + 1; knt <= i__1; ++knt) {
/* ==== Small spike tip deflation test ==== */
i__2 = *ns + *ns * t_dim1;
foo = (r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[*ns + *ns *
t_dim1]), dabs(r__2));
if (foo == 0.f) {
foo = (r__1 = s.r, dabs(r__1)) + (r__2 = r_imag(&s), dabs(r__2));
}
i__2 = *ns * v_dim1 + 1;
/* Computing MAX */
r__5 = smlnum, r__6 = ulp * foo;
if (((r__1 = s.r, dabs(r__1)) + (r__2 = r_imag(&s), dabs(r__2))) * ((
r__3 = v[i__2].r, dabs(r__3)) + (r__4 = r_imag(&v[*ns *
v_dim1 + 1]), dabs(r__4))) <= dmax(r__5,r__6)) {
/* ==== One more converged eigenvalue ==== */
--(*ns);
} else {
/* ==== One undeflatable eigenvalue. Move it up out of the */
/* . way. (CTREXC can not fail in this case.) ==== */
ifst = *ns;
ctrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &
ilst, &info);
++ilst;
}
/* L10: */
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0) {
s.r = 0.f, s.i = 0.f;
}
if (*ns < jw) {
/* ==== sorting the diagonal of T improves accuracy for */
/* . graded matrices. ==== */
i__1 = *ns;
for (i__ = infqr + 1; i__ <= i__1; ++i__) {
ifst = i__;
i__2 = *ns;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + j * t_dim1;
i__4 = ifst + ifst * t_dim1;
if ((r__1 = t[i__3].r, dabs(r__1)) + (r__2 = r_imag(&t[j + j *
t_dim1]), dabs(r__2)) > (r__3 = t[i__4].r, dabs(r__3)
) + (r__4 = r_imag(&t[ifst + ifst * t_dim1]), dabs(
r__4))) {
ifst = j;
}
/* L20: */
}
ilst = i__;
if (ifst != ilst) {
ctrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &info);
}
/* L30: */
}
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__1 = jw;
for (i__ = infqr + 1; i__ <= i__1; ++i__) {
i__2 = kwtop + i__ - 1;
i__3 = i__ + i__ * t_dim1;
sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i;
/* L40: */
}
if (*ns < jw || s.r == 0.f && s.i == 0.f) {
if (*ns > 1 && (s.r != 0.f || s.i != 0.f)) {
/* ==== Reflect spike back into lower triangle ==== */
ccopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
i__1 = *ns;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
r_cnjg(&q__1, &work[i__]);
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L50: */
}
beta.r = work[1].r, beta.i = work[1].i;
clarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1].r = 1.f, work[1].i = 0.f;
i__1 = jw - 2;
i__2 = jw - 2;
claset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
r_cnjg(&q__1, &tau);
clarf_("L", ns, &jw, &work[1], &c__1, &q__1, &t[t_offset], ldt, &
work[jw + 1]);
clarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
clarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
work[jw + 1]);
i__1 = *lwork - jw;
cgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
, &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1) {
i__1 = kwtop + (kwtop - 1) * h_dim1;
r_cnjg(&q__2, &v[v_dim1 + 1]);
q__1.r = s.r * q__2.r - s.i * q__2.i, q__1.i = s.r * q__2.i + s.i
* q__2.r;
h__[i__1].r = q__1.r, h__[i__1].i = q__1.i;
}
clacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
, ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
ccopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
&i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && (s.r != 0.f || s.i != 0.f)) {
i__1 = *lwork - jw;
cunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3,i__4);
cgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop *
h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset],
ldwv);
clacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
h_dim1], ldh);
/* L60: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1) {
/* Computing MIN */
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3,i__4);
cgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, &
h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset],
ldt);
clacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
h_dim1], ldh);
/* L70: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3,i__4);
cgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop *
z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset]
, ldwv);
clacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
kwtop * z_dim1], ldz);
/* L80: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting */
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
r__1 = (real) lwkopt;
q__1.r = r__1, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
/* ==== End of CLAQR2 ==== */
return 0;
} /* claqr2_ */
/* Subroutine */
int cunbdb1_(integer *m, integer *p, integer *q, complex * x11, integer *ldx11, complex *x21, integer *ldx21, real *theta, real * phi, complex *taup1, complex *taup2, complex *tauq1, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
integer x11_dim1, x11_offset, x21_dim1, x21_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1;
/* Builtin functions */
double atan2(doublereal, doublereal), cos(doublereal), sin(doublereal);
void r_cnjg(complex *, complex *);
double sqrt(doublereal);
/* Local variables */
integer lworkmin, lworkopt;
real c__;
integer i__;
real s;
integer childinfo;
extern /* Subroutine */
int clarf_(char *, integer *, integer *, complex * , integer *, complex *, complex *, integer *, complex *);
integer ilarf, llarf;
extern /* Subroutine */
int csrot_(integer *, complex *, integer *, complex *, integer *, real *, real *);
extern real scnrm2_(integer *, complex *, integer *, complex *, integer *) ;
extern /* Subroutine */
int clacgv_(integer *, complex *, integer *), xerbla_(char *, integer *);
logical lquery;
extern /* Subroutine */
int cunbdb5_(integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *);
integer iorbdb5, lorbdb5;
extern /* Subroutine */
int clarfgp_(integer *, complex *, complex *, integer *, complex *);
/* -- LAPACK computational routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* July 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ==================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Function .. */
/* .. */
/* .. Executable Statements .. */
/* Test input arguments */
/* Parameter adjustments */
x11_dim1 = *ldx11;
x11_offset = 1 + x11_dim1;
x11 -= x11_offset;
x21_dim1 = *ldx21;
x21_offset = 1 + x21_dim1;
x21 -= x21_offset;
--theta;
--phi;
--taup1;
--taup2;
--tauq1;
--work;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
if (*m < 0)
{
*info = -1;
}
else if (*p < *q || *m - *p < *q)
{
*info = -2;
}
else if (*q < 0 || *m - *q < *q)
{
*info = -3;
}
else if (*ldx11 < max(1,*p))
{
*info = -5;
}
else /* if(complicated condition) */
{
/* Computing MAX */
i__1 = 1;
i__2 = *m - *p; // , expr subst
if (*ldx21 < max(i__1,i__2))
{
*info = -7;
}
}
/* Compute workspace */
if (*info == 0)
{
ilarf = 2;
/* Computing MAX */
i__1 = *p - 1, i__2 = *m - *p - 1;
i__1 = max(i__1,i__2);
i__2 = *q - 1; // ; expr subst
llarf = max(i__1,i__2);
iorbdb5 = 2;
lorbdb5 = *q - 2;
/* Computing MAX */
i__1 = ilarf + llarf - 1;
i__2 = iorbdb5 + lorbdb5 - 1; // , expr subst
lworkopt = max(i__1,i__2);
lworkmin = lworkopt;
work[1].r = (real) lworkopt;
work[1].i = 0.f; // , expr subst
if (*lwork < lworkmin && ! lquery)
{
*info = -14;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CUNBDB1", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Reduce columns 1, ..., Q of X11 and X21 */
i__1 = *q;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = *p - i__ + 1;
clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + 1 + i__ * x11_dim1], &c__1, &taup1[i__]);
i__2 = *m - *p - i__ + 1;
clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + 1 + i__ * x21_dim1], &c__1, &taup2[i__]);
theta[i__] = atan2((real) x21[i__ + i__ * x21_dim1].r, (real) x11[i__ + i__ * x11_dim1].r);
c__ = cos(theta[i__]);
s = sin(theta[i__]);
i__2 = i__ + i__ * x11_dim1;
x11[i__2].r = 1.f;
x11[i__2].i = 0.f; // , expr subst
i__2 = i__ + i__ * x21_dim1;
x21[i__2].r = 1.f;
x21[i__2].i = 0.f; // , expr subst
i__2 = *p - i__ + 1;
i__3 = *q - i__;
r_cnjg(&q__1, &taup1[i__]);
clarf_("L", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], &c__1, &q__1, & x11[i__ + (i__ + 1) * x11_dim1], ldx11, &work[ilarf]);
i__2 = *m - *p - i__ + 1;
i__3 = *q - i__;
r_cnjg(&q__1, &taup2[i__]);
clarf_("L", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], &c__1, &q__1, & x21[i__ + (i__ + 1) * x21_dim1], ldx21, &work[ilarf]);
if (i__ < *q)
{
i__2 = *q - i__;
csrot_(&i__2, &x11[i__ + (i__ + 1) * x11_dim1], ldx11, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, &c__, &s);
i__2 = *q - i__;
clacgv_(&i__2, &x21[i__ + (i__ + 1) * x21_dim1], ldx21);
i__2 = *q - i__;
clarfgp_(&i__2, &x21[i__ + (i__ + 1) * x21_dim1], &x21[i__ + (i__ + 2) * x21_dim1], ldx21, &tauq1[i__]);
i__2 = i__ + (i__ + 1) * x21_dim1;
s = x21[i__2].r;
i__2 = i__ + (i__ + 1) * x21_dim1;
x21[i__2].r = 1.f;
x21[i__2].i = 0.f; // , expr subst
i__2 = *p - i__;
i__3 = *q - i__;
clarf_("R", &i__2, &i__3, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, &tauq1[i__], &x11[i__ + 1 + (i__ + 1) * x11_dim1], ldx11, &work[ilarf]);
i__2 = *m - *p - i__;
i__3 = *q - i__;
clarf_("R", &i__2, &i__3, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, &tauq1[i__], &x21[i__ + 1 + (i__ + 1) * x21_dim1], ldx21, &work[ilarf]);
i__2 = *q - i__;
clacgv_(&i__2, &x21[i__ + (i__ + 1) * x21_dim1], ldx21);
i__2 = *p - i__;
/* Computing 2nd power */
r__1 = scnrm2_(&i__2, &x11[i__ + 1 + (i__ + 1) * x11_dim1], &c__1, &x11[i__ + 1 + (i__ + 1) * x11_dim1], &c__1);
i__3 = *m - *p - i__;
/* Computing 2nd power */
r__2 = scnrm2_(&i__3, &x21[i__ + 1 + (i__ + 1) * x21_dim1], &c__1, &x21[i__ + 1 + (i__ + 1) * x21_dim1], &c__1);
c__ = sqrt(r__1 * r__1 + r__2 * r__2);
phi[i__] = atan2(s, c__);
i__2 = *p - i__;
i__3 = *m - *p - i__;
i__4 = *q - i__ - 1;
cunbdb5_(&i__2, &i__3, &i__4, &x11[i__ + 1 + (i__ + 1) * x11_dim1] , &c__1, &x21[i__ + 1 + (i__ + 1) * x21_dim1], &c__1, & x11[i__ + 1 + (i__ + 2) * x11_dim1], ldx11, &x21[i__ + 1 + (i__ + 2) * x21_dim1], ldx21, &work[iorbdb5], &lorbdb5, &childinfo);
}
}
return 0;
/* End of CUNBDB1 */
}
/* Subroutine */ int cunml2_(char *side, char *trans, integer *m, integer *n,
integer *k, complex *a, integer *lda, complex *tau, complex *c__,
integer *ldc, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
complex aii;
logical left;
complex taui;
logical notran;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CUNML2 overwrites the general complex m-by-n matrix C with */
/* Q * C if SIDE = 'L' and TRANS = 'N', or */
/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
/* C * Q if SIDE = 'R' and TRANS = 'N', or */
/* C * Q' if SIDE = 'R' and TRANS = 'C', */
/* where Q is a complex unitary matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(k)' . . . H(2)' H(1)' */
/* as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n */
/* if SIDE = 'R'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q' from the Left */
/* = 'R': apply Q or Q' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply Q (No transpose) */
/* = 'C': apply Q' (Conjugate transpose) */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines */
/* the matrix Q. */
/* If SIDE = 'L', M >= K >= 0; */
/* if SIDE = 'R', N >= K >= 0. */
/* A (input) COMPLEX array, dimension */
/* (LDA,M) if SIDE = 'L', */
/* (LDA,N) if SIDE = 'R' */
/* The i-th row must contain the vector which defines the */
/* CGELQF in the first k rows of its array argument A. */
/* A is modified by the routine but restored on exit. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,K). */
/* TAU (input) COMPLEX array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by CGELQF. */
/* C (input/output) COMPLEX array, dimension (LDC,N) */
/* On entry, the m-by-n matrix C. */
/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX array, dimension */
/* (N) if SIDE = 'L', */
/* (M) if SIDE = 'R' */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,*k)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNML2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) or H(i)' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H(i) or H(i)' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H(i) or H(i)' */
if (notran) {
r_cnjg(&q__1, &tau[i__]);
taui.r = q__1.r, taui.i = q__1.i;
} else {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
}
if (i__ < nq) {
i__3 = nq - i__;
clacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
}
i__3 = i__ + i__ * a_dim1;
aii.r = a[i__3].r, aii.i = a[i__3].i;
i__3 = i__ + i__ * a_dim1;
a[i__3].r = 1.f, a[i__3].i = 0.f;
clarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &taui, &c__[ic +
jc * c_dim1], ldc, &work[1]);
i__3 = i__ + i__ * a_dim1;
a[i__3].r = aii.r, a[i__3].i = aii.i;
if (i__ < nq) {
i__3 = nq - i__;
clacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
}
}
return 0;
/* End of CUNML2 */
} /* cunml2_ */
/* Subroutine */
int cgeqr2p_(integer *m, integer *n, complex *a, integer * lda, complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, k;
complex alpha;
extern /* Subroutine */
int clarf_(char *, integer *, integer *, complex * , integer *, complex *, complex *, integer *, complex *), xerbla_(char *, integer *), clarfgp_(integer *, complex *, complex *, integer *, complex *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*m))
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGEQR2P", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
clarfgp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1], &c__1, &tau[i__]);
if (i__ < *n)
{
/* Apply H(i)**H to A(i:m,i+1:n) from the left */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
i__2 = *m - i__ + 1;
i__3 = *n - i__;
r_cnjg(&q__1, &tau[i__]);
clarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &q__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = alpha.r;
a[i__2].i = alpha.i; // , expr subst
}
/* L10: */
}
return 0;
/* End of CGEQR2P */
}
int cgeql2_(int *m, int *n, complex *a, int *lda,
complex *tau, complex *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
int i__, k;
complex alpha;
extern int clarf_(char *, int *, int *, complex *
, int *, complex *, complex *, int *, complex *),
clarfp_(int *, complex *, complex *, int *, complex *),
xerbla_(char *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEQL2 computes a QL factorization of a complex m by n matrix A: */
/* A = Q * L. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, if m >= n, the lower triangle of the subarray */
/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */
/* if m <= n, the elements on and below the (n-m)-th */
/* superdiagonal contain the m by n lower trapezoidal matrix L; */
/* the remaining elements, with the array TAU, represent the */
/* unitary matrix Q as a product of elementary reflectors */
/* (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,M). */
/* TAU (output) COMPLEX array, dimension (MIN(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* 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 */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(k) . . . H(2) H(1), where k = MIN(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEQL2", &i__1);
return 0;
}
k = MIN(*m,*n);
for (i__ = k; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:m-k+i-1,n-k+i) */
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
i__1 = *m - k + i__;
clarfp_(&i__1, &alpha, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &tau[
i__]);
/* Apply H(i)' to A(1:m-k+i,1:n-k+i-1) from the left */
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = 1.f, a[i__1].i = 0.f;
i__1 = *m - k + i__;
i__2 = *n - k + i__ - 1;
r_cnjg(&q__1, &tau[i__]);
clarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &
q__1, &a[a_offset], lda, &work[1]);
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = alpha.r, a[i__1].i = alpha.i;
/* L10: */
}
return 0;
/* End of CGEQL2 */
} /* cgeql2_ */
/* Subroutine */ int cqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, complex *a, integer *lda, complex *b,
integer *ldb, real *s, integer *rank, real *norma, real *normb,
integer *iseed, complex *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1;
/* Local variables */
integer j, mn;
real eps;
integer info;
real temp;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), clarf_(char *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *);
extern doublereal sasum_(integer *, real *, integer *);
real dummy[1];
extern doublereal scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), xerbla_(char *, integer *);
real bignum;
extern /* Subroutine */ int claror_(char *, char *, integer *, integer *,
complex *, integer *, integer *, complex *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), clarnv_(integer *, integer *, integer *, complex *),
slascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, real *, integer *, integer *);
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CQRT15 generates a matrix with full or deficient rank and of various */
/* norms. */
/* Arguments */
/* ========= */
/* SCALE (input) INTEGER */
/* SCALE = 1: normally scaled matrix */
/* SCALE = 2: matrix scaled up */
/* SCALE = 3: matrix scaled down */
/* RKSEL (input) INTEGER */
/* RKSEL = 1: full rank matrix */
/* RKSEL = 2: rank-deficient matrix */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* N (input) INTEGER */
/* The number of columns of A. */
/* NRHS (input) INTEGER */
/* The number of columns of B. */
/* A (output) COMPLEX array, dimension (LDA,N) */
/* The M-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* B (output) COMPLEX array, dimension (LDB, NRHS) */
/* A matrix that is in the range space of matrix A. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. */
/* S (output) REAL array, dimension MIN(M,N) */
/* Singular values of A. */
/* RANK (output) INTEGER */
/* number of nonzero singular values of A. */
/* NORMA (output) REAL */
/* one-norm norm of A. */
/* NORMB (output) REAL */
/* one-norm norm of B. */
/* ISEED (input/output) integer array, dimension (4) */
/* seed for random number generator. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* length of work space required. */
/* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--s;
--iseed;
--work;
/* Function Body */
mn = min(*m,*n);
/* Computing MAX */
i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ *m;
if (*lwork < max(i__1,i__2)) {
xerbla_("CQRT15", &c__16);
return 0;
}
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
eps = slamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1.f / smlnum;
/* Determine rank and (unscaled) singular values */
if (*rksel == 1) {
*rank = mn;
} else if (*rksel == 2) {
*rank = mn * 3 / 4;
i__1 = mn;
for (j = *rank + 1; j <= i__1; ++j) {
s[j] = 0.f;
/* L10: */
}
} else {
xerbla_("CQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.f;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = slarnd_(&c__1, &iseed[1]);
if (temp > .1f) {
s[j] = dabs(temp);
} else {
goto L20;
}
/* L30: */
}
slaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
clarnv_(&c__2, &iseed[1], m, &work[1]);
r__1 = 1.f / scnrm2_(m, &work[1], &c__1);
csscal_(m, &r__1, &work[1], &c__1);
claset_("Full", m, rank, &c_b1, &c_b2, &a[a_offset], lda);
clarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
work[*m + 1]);
/* workspace used: m+mn */
/* Generate consistent rhs in the range space of A */
i__1 = *rank * *nrhs;
clarnv_(&c__2, &iseed[1], &i__1, &work[1]);
cgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b2, &a[
a_offset], lda, &work[1], rank, &c_b1, &b[b_offset], ldb);
/* work space used: <= mn *nrhs */
/* generate (unscaled) matrix A */
i__1 = *rank;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &s[j], &a[j * a_dim1 + 1], &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
claset_("Full", m, &i__1, &c_b1, &c_b1, &a[(*rank + 1) * a_dim1 +
1], lda);
}
claror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
1], &work[1], &info);
} else {
/* work space used 2*n+m */
/* Generate null matrix and rhs */
i__1 = mn;
for (j = 1; j <= i__1; ++j) {
s[j] = 0.f;
/* L50: */
}
claset_("Full", m, n, &c_b1, &c_b1, &a[a_offset], lda);
claset_("Full", m, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
}
/* Scale the matrix */
if (*scale != 1) {
*norma = clange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.f) {
if (*scale == 2) {
/* matrix scaled up */
clascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
clascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
clascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
clascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("CQRT15", &c__1);
return 0;
}
}
}
*norma = sasum_(&mn, &s[1], &c__1);
*normb = clange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of CQRT15 */
} /* cqrt15_ */
/* Subroutine */ int cgeqpf_(integer *m, integer *n, complex *a, integer *lda,
integer *jpvt, complex *tau, complex *work, real *rwork, integer *
info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
This routine is deprecated and has been replaced by routine CGEQP3.
CGEQPF computes a QR factorization with column pivoting of a
complex M-by-N matrix A: A*P = Q*R.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the upper triangle of the array contains the
min(M,N)-by-N upper triangular matrix R; the elements
below the diagonal, together with the array TAU,
represent the unitary matrix Q as a product of
min(m,n) elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
to the front of A*P (a leading column); if JPVT(i) = 0,
the i-th column of A is a free column.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
TAU (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors.
WORK (workspace) COMPLEX array, dimension (N)
RWORK (workspace) REAL array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(n)
Each H(i) has the form
H = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
The matrix P is represented in jpvt as follows: If
jpvt(j) = i
then the jth column of P is the ith canonical unit vector.
=====================================================================
Test the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static real temp, temp2;
static integer i__, j;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
cswap_(integer *, complex *, integer *, complex *, integer *);
static integer itemp;
extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *);
extern doublereal scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *);
static integer ma, mn;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *), xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
static complex aii;
static integer pvt;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--jpvt;
--tau;
--work;
--rwork;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (jpvt[i__] != 0) {
if (i__ != itemp) {
cswap_(m, &a_ref(1, i__), &c__1, &a_ref(1, itemp), &c__1);
jpvt[i__] = jpvt[itemp];
jpvt[itemp] = i__;
} else {
jpvt[i__] = i__;
}
++itemp;
} else {
jpvt[i__] = i__;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
cgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
if (ma < *n) {
i__1 = *n - ma;
cunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
, lda, &tau[1], &a_ref(1, ma + 1), lda, &work[1], info);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of
work store the exact column norms. */
i__1 = *n;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
i__2 = *m - itemp;
rwork[i__] = scnrm2_(&i__2, &a_ref(itemp + 1, i__), &c__1);
rwork[*n + i__] = rwork[i__];
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + isamax_(&i__2, &rwork[i__], &c__1);
if (pvt != i__) {
cswap_(m, &a_ref(1, pvt), &c__1, &a_ref(1, i__), &c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
rwork[pvt] = rwork[i__];
rwork[*n + pvt] = rwork[*n + i__];
}
/* Generate elementary reflector H(i) */
i__2 = a_subscr(i__, i__);
aii.r = a[i__2].r, aii.i = a[i__2].i;
/* Computing MIN */
i__2 = i__ + 1;
i__3 = *m - i__ + 1;
clarfg_(&i__3, &aii, &a_ref(min(i__2,*m), i__), &c__1, &tau[i__]);
i__2 = a_subscr(i__, i__);
a[i__2].r = aii.r, a[i__2].i = aii.i;
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = a_subscr(i__, i__);
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = a_subscr(i__, i__);
a[i__2].r = 1.f, a[i__2].i = 0.f;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
r_cnjg(&q__1, &tau[i__]);
clarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &q__1, &
a_ref(i__, i__ + 1), lda, &work[1]);
i__2 = a_subscr(i__, i__);
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (rwork[j] != 0.f) {
/* Computing 2nd power */
r__1 = c_abs(&a_ref(i__, j)) / rwork[j];
temp = 1.f - r__1 * r__1;
temp = dmax(temp,0.f);
/* Computing 2nd power */
r__1 = rwork[j] / rwork[*n + j];
temp2 = temp * .05f * (r__1 * r__1) + 1.f;
if (temp2 == 1.f) {
if (*m - i__ > 0) {
i__3 = *m - i__;
rwork[j] = scnrm2_(&i__3, &a_ref(i__ + 1, j), &
c__1);
rwork[*n + j] = rwork[j];
} else {
rwork[j] = 0.f;
rwork[*n + j] = 0.f;
}
} else {
rwork[j] *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of CGEQPF */
} /* cgeqpf_ */
/* Subroutine */ int cung2r_(integer *m, integer *n, integer *k, complex *a,
integer *lda, complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
integer i__, j, l;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CUNG2R generates an m by n complex matrix Q with orthonormal columns, */
/* which is defined as the first n columns of a product of k elementary */
/* reflectors of order m */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by CGEQRF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. M >= N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. N >= K >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the i-th column must contain the vector which */
/* returned by CGEQRF in the first k columns of its array */
/* argument A. */
/* On exit, the m by n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= max(1,M). */
/* TAU (input) COMPLEX array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by CGEQRF. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *n > *m) {
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNG2R", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns k+1:n to columns of the unit matrix */
i__1 = *n;
for (j = *k + 1; j <= i__1; ++j) {
i__2 = *m;
for (l = 1; l <= i__2; ++l) {
i__3 = l + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
i__2 = j + j * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
}
for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i) to A(i:m,i:n) from the left */
if (i__ < *n) {
i__1 = i__ + i__ * a_dim1;
a[i__1].r = 1.f, a[i__1].i = 0.f;
i__1 = *m - i__ + 1;
i__2 = *n - i__;
clarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
}
if (i__ < *m) {
i__1 = *m - i__;
i__2 = i__;
q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i;
cscal_(&i__1, &q__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
}
i__1 = i__ + i__ * a_dim1;
i__2 = i__;
q__1.r = 1.f - tau[i__2].r, q__1.i = 0.f - tau[i__2].i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
/* Set A(1:i-1,i) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
i__2 = l + i__ * a_dim1;
a[i__2].r = 0.f, a[i__2].i = 0.f;
}
}
return 0;
/* End of CUNG2R */
} /* cung2r_ */
/* Subroutine */
int cungr2_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1, q__2;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, l, ii;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *), clarf_(char *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *), clacgv_(integer *, complex *, integer *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < *m)
{
*info = -2;
}
else if (*k < 0 || *k > *m)
{
*info = -3;
}
else if (*lda < max(1,*m))
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CUNGR2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0)
{
return 0;
}
if (*k < *m)
{
/* Initialise rows 1:m-k to rows of the unit matrix */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m - *k;
for (l = 1;
l <= i__2;
++l)
{
i__3 = l + j * a_dim1;
a[i__3].r = 0.f;
a[i__3].i = 0.f; // , expr subst
/* L10: */
}
if (j > *n - *m && j <= *n - *k)
{
i__2 = *m - *n + j + j * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
}
/* L20: */
}
}
i__1 = *k;
for (i__ = 1;
i__ <= i__1;
++i__)
{
ii = *m - *k + i__;
/* Apply H(i)**H to A(1:m-k+i,1:n-k+i) from the right */
i__2 = *n - *m + ii - 1;
clacgv_(&i__2, &a[ii + a_dim1], lda);
i__2 = ii + (*n - *m + ii) * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
i__2 = ii - 1;
i__3 = *n - *m + ii;
r_cnjg(&q__1, &tau[i__]);
clarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &q__1, &a[ a_offset], lda, &work[1]);
i__2 = *n - *m + ii - 1;
i__3 = i__;
q__1.r = -tau[i__3].r;
q__1.i = -tau[i__3].i; // , expr subst
cscal_(&i__2, &q__1, &a[ii + a_dim1], lda);
i__2 = *n - *m + ii - 1;
clacgv_(&i__2, &a[ii + a_dim1], lda);
i__2 = ii + (*n - *m + ii) * a_dim1;
r_cnjg(&q__2, &tau[i__]);
q__1.r = 1.f - q__2.r;
q__1.i = 0.f - q__2.i; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
/* Set A(m-k+i,n-k+i+1:n) to zero */
i__2 = *n;
for (l = *n - *m + ii + 1;
l <= i__2;
++l)
{
i__3 = ii + l * a_dim1;
a[i__3].r = 0.f;
a[i__3].i = 0.f; // , expr subst
/* L30: */
}
/* L40: */
}
return 0;
/* End of CUNGR2 */
}
/* Subroutine */ int cungl2_(integer *m, integer *n, integer *k, complex *a,
integer *lda, complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1, q__2;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, l;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), clarf_(char *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, complex *),
clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
*);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, */
/* which is defined as the first m rows of a product of k elementary */
/* reflectors of order n */
/* Q = H(k)' . . . H(2)' H(1)' */
/* as returned by CGELQF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. N >= M. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the i-th row must contain the vector which defines */
/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
/* by CGELQF in the first k rows of its array argument A. */
/* On exit, the m by n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= max(1,M). */
/* TAU (input) COMPLEX array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by CGELQF. */
/* WORK (workspace) COMPLEX array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNGL2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows k+1:m to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = *k + 1; l <= i__2; ++l) {
i__3 = l + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
if (j > *k && j <= *m) {
i__2 = j + j * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
}
/* L20: */
}
}
for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i)' to A(i:m,i:n) from the right */
if (i__ < *n) {
i__1 = *n - i__;
clacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
if (i__ < *m) {
i__1 = i__ + i__ * a_dim1;
a[i__1].r = 1.f, a[i__1].i = 0.f;
i__1 = *m - i__;
i__2 = *n - i__ + 1;
r_cnjg(&q__1, &tau[i__]);
clarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
q__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
}
i__1 = *n - i__;
i__2 = i__;
q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i;
cscal_(&i__1, &q__1, &a[i__ + (i__ + 1) * a_dim1], lda);
i__1 = *n - i__;
clacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
}
i__1 = i__ + i__ * a_dim1;
r_cnjg(&q__2, &tau[i__]);
q__1.r = 1.f - q__2.r, q__1.i = 0.f - q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
/* Set A(i,1:i-1,i) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
i__2 = i__ + l * a_dim1;
a[i__2].r = 0.f, a[i__2].i = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of CUNGL2 */
} /* cungl2_ */
/* Subroutine */ int cung2l_(integer *m, integer *n, integer *k, complex *a,
integer *lda, complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
integer i__, j, l, ii;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), clarf_(char *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, complex *),
xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CUNG2L generates an m by n complex matrix Q with orthonormal columns, */
/* which is defined as the last n columns of a product of k elementary */
/* reflectors of order m */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by CGEQLF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. M >= N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. N >= K >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the (n-k+i)-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* returned by CGEQLF in the last k columns of its array */
/* argument A. */
/* On exit, the m-by-n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= max(1,M). */
/* TAU (input) COMPLEX array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by CGEQLF. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *n > *m) {
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNG2L", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = 1; l <= i__2; ++l) {
i__3 = l + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
i__2 = *m - *n + j + j * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* L20: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *n - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
i__2 = *m - *n + ii + ii * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
i__2 = *m - *n + ii;
i__3 = ii - 1;
clarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
a[a_offset], lda, &work[1]);
i__2 = *m - *n + ii - 1;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cscal_(&i__2, &q__1, &a[ii * a_dim1 + 1], &c__1);
i__2 = *m - *n + ii + ii * a_dim1;
i__3 = i__;
q__1.r = 1.f - tau[i__3].r, q__1.i = 0.f - tau[i__3].i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m;
for (l = *m - *n + ii + 1; l <= i__2; ++l) {
i__3 = l + ii * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of CUNG2L */
} /* cung2l_ */
/* Subroutine */ int cgeqr2_(integer *m, integer *n, complex *a, integer *lda,
complex *tau, complex *work, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGEQR2 computes a QR factorization of a complex m by n matrix A:
A = Q * R.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the m by n matrix A.
On exit, the elements on and above the diagonal of the array
contain the min(m,n) by n upper trapezoidal matrix R (R is
upper triangular if m >= n); the elements below the diagonal,
with the array TAU, represent the unitary matrix Q as a
product of elementary reflectors (see Further Details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
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
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(k), where k = min(m,n).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
and tau in TAU(i).
=====================================================================
Test the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer i__, k;
static complex alpha;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
clarfg_(integer *, complex *, complex *, integer *, complex *),
xerbla_(char *, integer *);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEQR2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
Computing MIN */
i__2 = i__ + 1;
i__3 = *m - i__ + 1;
clarfg_(&i__3, &a_ref(i__, i__), &a_ref(min(i__2,*m), i__), &c__1, &
tau[i__]);
if (i__ < *n) {
/* Apply H(i)' to A(i:m,i+1:n) from the left */
i__2 = a_subscr(i__, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = a_subscr(i__, i__);
a[i__2].r = 1.f, a[i__2].i = 0.f;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
r_cnjg(&q__1, &tau[i__]);
clarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &q__1, &
a_ref(i__, i__ + 1), lda, &work[1]);
i__2 = a_subscr(i__, i__);
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
}
/* L10: */
}
return 0;
/* End of CGEQR2 */
} /* cgeqr2_ */
/* Subroutine */ int claqp2_(integer *m, integer *n, integer *offset, complex
*a, integer *lda, integer *jpvt, complex *tau, real *vn1, real *vn2,
complex *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static integer i__, j, mn;
static complex aii;
static integer pvt;
static real temp, temp2;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *, ftnlen);
static integer offpi;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
static integer itemp;
extern doublereal scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *);
extern integer isamax_(integer *, real *, integer *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAQP2 computes a QR factorization with column pivoting of */
/* the block A(OFFSET+1:M,1:N). */
/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* OFFSET (input) INTEGER */
/* The number of rows of the matrix A that must be pivoted */
/* but no factorized. OFFSET >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
/* the triangular factor obtained; the elements in block */
/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
/* array TAU, represent the orthogonal matrix Q as a product of */
/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(i) = 0, */
/* the i-th column of A is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* TAU (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) REAL array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) REAL array, dimension (N) */
/* The vector with the exact column norms. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *m - *offset;
mn = min(i__1,*n);
/* Compute factorization. */
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
offpi = *offset + i__;
/* Determine ith pivot column and swap if necessary. */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + isamax_(&i__2, &vn1[i__], &c__1);
if (pvt != i__) {
cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
vn1[pvt] = vn1[i__];
vn2[pvt] = vn2[i__];
}
/* Generate elementary reflector H(i). */
if (offpi < *m) {
i__2 = *m - offpi + 1;
clarfg_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
a_dim1], &c__1, &tau[i__]);
} else {
clarfg_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
c__1, &tau[i__]);
}
if (i__ < *n) {
/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
i__2 = offpi + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = offpi + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
i__2 = *m - offpi + 1;
i__3 = *n - i__;
r_cnjg(&q__1, &tau[i__]);
clarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
q__1, &a[offpi + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4);
i__2 = offpi + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms. */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (vn1[j] != 0.f) {
/* Computing 2nd power */
r__1 = c_abs(&a[offpi + j * a_dim1]) / vn1[j];
temp = 1.f - r__1 * r__1;
temp = dmax(temp,0.f);
/* Computing 2nd power */
r__1 = vn1[j] / vn2[j];
temp2 = temp * .05f * (r__1 * r__1) + 1.f;
if (temp2 == 1.f) {
if (offpi < *m) {
i__3 = *m - offpi;
vn1[j] = scnrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
c__1);
vn2[j] = vn1[j];
} else {
vn1[j] = 0.f;
vn2[j] = 0.f;
}
} else {
vn1[j] *= sqrt(temp);
}
}
/* L10: */
}
/* L20: */
}
return 0;
/* End of CLAQP2 */
} /* claqp2_ */
/* Subroutine */ int cgebd2_(integer *m, integer *n, complex *a, integer *lda,
real *d__, real *e, complex *tauq, complex *taup, complex *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__;
complex alpha;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
clarfg_(integer *, complex *, complex *, integer *, complex *),
clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
*);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEBD2 reduces a complex general m by n matrix A to upper or lower */
/* real bidiagonal form B by a unitary transformation: Q' * A * P = B. */
/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, */
/* if m >= n, the diagonal and the first superdiagonal are */
/* overwritten with the upper bidiagonal matrix B; the */
/* elements below the diagonal, with the array TAUQ, represent */
/* the unitary matrix Q as a product of elementary */
/* reflectors, and the elements above the first superdiagonal, */
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors; */
/* if m < n, the diagonal and the first subdiagonal are */
/* overwritten with the lower bidiagonal matrix B; the */
/* elements below the first subdiagonal, with the array TAUQ, */
/* represent the unitary matrix Q as a product of */
/* elementary reflectors, and the elements above the diagonal, */
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* D (output) REAL array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B: */
/* D(i) = A(i,i). */
/* E (output) REAL array, dimension (min(M,N)-1) */
/* The off-diagonal elements of the bidiagonal matrix B: */
/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
/* TAUQ (output) COMPLEX array dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix Q. See Further Details. */
/* TAUP (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix P. See Further Details. */
/* WORK (workspace) COMPLEX array, dimension (max(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* If m >= n, */
/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, and v and u are complex */
/* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */
/* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */
/* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, */
/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, v and u are complex vectors; */
/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The contents of A on exit are illustrated by the following examples: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
/* ( v1 v2 v3 v4 v5 ) */
/* where d and e denote diagonal and off-diagonal elements of B, vi */
/* denotes an element of the vector defining H(i), and ui an element of */
/* the vector defining G(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CGEBD2", &i__1);
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &
tauq[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply H(i)' to A(i:m,i+1:n) from the left */
if (i__ < *n) {
i__2 = *m - i__ + 1;
i__3 = *n - i__;
r_cnjg(&q__1, &tauq[i__]);
clarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
q__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
}
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.f;
if (i__ < *n) {
/* Generate elementary reflector G(i) to annihilate */
/* A(i,i+2:n) */
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
taup[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + (i__ + 1) * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__;
clarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1]);
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + (i__ + 1) * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.f;
} else {
i__2 = i__;
taup[i__2].r = 0.f, taup[i__2].i = 0.f;
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
taup[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply G(i) to A(i+1:m,i:n) from the right */
if (i__ < *m) {
i__2 = *m - i__;
i__3 = *n - i__ + 1;
clarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
}
i__2 = *n - i__ + 1;
clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.f;
if (i__ < *m) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:m,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1,
&tauq[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply H(i)' to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__;
i__3 = *n - i__;
r_cnjg(&q__1, &tauq[i__]);
clarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
c__1, &q__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &
work[1]);
i__2 = i__ + 1 + i__ * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.f;
} else {
i__2 = i__;
tauq[i__2].r = 0.f, tauq[i__2].i = 0.f;
}
/* L20: */
}
}
return 0;
/* End of CGEBD2 */
} /* cgebd2_ */
/* Subroutine */ int cung2l_(integer *m, integer *n, integer *k, complex *a,
integer *lda, complex *tau, complex *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CUNG2L generates an m by n complex matrix Q with orthonormal columns,
which is defined as the last n columns of a product of k elementary
reflectors of order m
Q = H(k) . . . H(2) H(1)
as returned by CGEQLF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q. M >= N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. N >= K >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the (n-k+i)-th column must contain the vector which
defines the elementary reflector H(i), for i = 1,2,...,k, as
returned by CGEQLF in the last k columns of its array
argument A.
On exit, the m-by-n matrix Q.
LDA (input) INTEGER
The first dimension of the array A. LDA >= max(1,M).
TAU (input) COMPLEX array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by CGEQLF.
WORK (workspace) COMPLEX array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument has an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
static integer i, j, l;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), clarf_(char *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, complex *);
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *n > *m) {
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNG2L", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k;
for (j = 1; j <= *n-*k; ++j) {
i__2 = *m;
for (l = 1; l <= *m; ++l) {
i__3 = l + j * a_dim1;
A(l,j).r = 0.f, A(l,j).i = 0.f;
/* L10: */
}
i__2 = *m - *n + j + j * a_dim1;
A(*m-*n+j,j).r = 1.f, A(*m-*n+j,j).i = 0.f;
/* L20: */
}
i__1 = *k;
for (i = 1; i <= *k; ++i) {
ii = *n - *k + i;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
i__2 = *m - *n + ii + ii * a_dim1;
A(*m-*n+ii,ii).r = 1.f, A(*m-*n+ii,ii).i = 0.f;
i__2 = *m - *n + ii;
i__3 = ii - 1;
clarf_("Left", &i__2, &i__3, &A(1,ii), &c__1, &TAU(i), &A(1,1), lda, &WORK(1));
i__2 = *m - *n + ii - 1;
i__3 = i;
q__1.r = -(doublereal)TAU(i).r, q__1.i = -(doublereal)TAU(i).i;
cscal_(&i__2, &q__1, &A(1,ii), &c__1);
i__2 = *m - *n + ii + ii * a_dim1;
i__3 = i;
q__1.r = 1.f - TAU(i).r, q__1.i = 0.f - TAU(i).i;
A(*m-*n+ii,ii).r = q__1.r, A(*m-*n+ii,ii).i = q__1.i;
/* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m;
for (l = *m - *n + ii + 1; l <= *m; ++l) {
i__3 = l + ii * a_dim1;
A(l,ii).r = 0.f, A(l,ii).i = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of CUNG2L */
} /* cung2l_ */
/* Subroutine */ int cgebd2_(integer *m, integer *n, complex *a, integer *lda,
real *d__, real *e, complex *tauq, complex *taup, complex *work,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGEBD2 reduces a complex general m by n matrix A to upper or lower
real bidiagonal form B by a unitary transformation: Q' * A * P = B.
If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
Arguments
=========
M (input) INTEGER
The number of rows in the matrix A. M >= 0.
N (input) INTEGER
The number of columns in the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the m by n general matrix to be reduced.
On exit,
if m >= n, the diagonal and the first superdiagonal are
overwritten with the upper bidiagonal matrix B; the
elements below the diagonal, with the array TAUQ, represent
the unitary matrix Q as a product of elementary
reflectors, and the elements above the first superdiagonal,
with the array TAUP, represent the unitary matrix P as
a product of elementary reflectors;
if m < n, the diagonal and the first subdiagonal are
overwritten with the lower bidiagonal matrix B; the
elements below the first subdiagonal, with the array TAUQ,
represent the unitary matrix Q as a product of
elementary reflectors, and the elements above the diagonal,
with the array TAUP, represent the unitary matrix P as
a product of elementary reflectors.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
D (output) REAL array, dimension (min(M,N))
The diagonal elements of the bidiagonal matrix B:
D(i) = A(i,i).
E (output) REAL array, dimension (min(M,N)-1)
The off-diagonal elements of the bidiagonal matrix B:
if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
TAUQ (output) COMPLEX array dimension (min(M,N))
The scalar factors of the elementary reflectors which
represent the unitary matrix Q. See Further Details.
TAUP (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors which
represent the unitary matrix P. See Further Details.
WORK (workspace) COMPLEX array, dimension (max(M,N))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The matrices Q and P are represented as products of elementary
reflectors:
If m >= n,
Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
Each H(i) and G(i) has the form:
H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
where tauq and taup are complex scalars, and v and u are complex
vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
If m < n,
Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
Each H(i) and G(i) has the form:
H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
where tauq and taup are complex scalars, v and u are complex vectors;
v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
tauq is stored in TAUQ(i) and taup in TAUP(i).
The contents of A on exit are illustrated by the following examples:
m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
( v1 v2 v3 v4 v5 )
where d and e denote diagonal and off-diagonal elements of B, vi
denotes an element of the vector defining H(i), and ui an element of
the vector defining G(i).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer i__;
static complex alpha;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
clarfg_(integer *, complex *, complex *, integer *, complex *),
clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
*);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CGEBD2", &i__1);
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = a_subscr(i__, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/* Computing MIN */
i__2 = i__ + 1;
i__3 = *m - i__ + 1;
clarfg_(&i__3, &alpha, &a_ref(min(i__2,*m), i__), &c__1, &tauq[
i__]);
i__2 = i__;
d__[i__2] = alpha.r;
i__2 = a_subscr(i__, i__);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply H(i)' to A(i:m,i+1:n) from the left */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
r_cnjg(&q__1, &tauq[i__]);
clarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &q__1, &
a_ref(i__, i__ + 1), lda, &work[1]);
i__2 = a_subscr(i__, i__);
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.f;
if (i__ < *n) {
/* Generate elementary reflector G(i) to annihilate
A(i,i+2:n) */
i__2 = *n - i__;
clacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = a_subscr(i__, i__ + 1);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/* Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
clarfg_(&i__3, &alpha, &a_ref(i__, min(i__2,*n)), lda, &taup[
i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = a_subscr(i__, i__ + 1);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__;
clarf_("Right", &i__2, &i__3, &a_ref(i__, i__ + 1), lda, &
taup[i__], &a_ref(i__ + 1, i__ + 1), lda, &work[1]);
i__2 = *n - i__;
clacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = a_subscr(i__, i__ + 1);
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.f;
} else {
i__2 = i__;
taup[i__2].r = 0.f, taup[i__2].i = 0.f;
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
clacgv_(&i__2, &a_ref(i__, i__), lda);
i__2 = a_subscr(i__, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/* Computing MIN */
i__2 = i__ + 1;
i__3 = *n - i__ + 1;
clarfg_(&i__3, &alpha, &a_ref(i__, min(i__2,*n)), lda, &taup[i__])
;
i__2 = i__;
d__[i__2] = alpha.r;
i__2 = a_subscr(i__, i__);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply G(i) to A(i+1:m,i:n) from the right
Computing MIN */
i__2 = i__ + 1;
i__3 = *m - i__;
i__4 = *n - i__ + 1;
clarf_("Right", &i__3, &i__4, &a_ref(i__, i__), lda, &taup[i__], &
a_ref(min(i__2,*m), i__), lda, &work[1]);
i__2 = *n - i__ + 1;
clacgv_(&i__2, &a_ref(i__, i__), lda);
i__2 = a_subscr(i__, i__);
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.f;
if (i__ < *m) {
/* Generate elementary reflector H(i) to annihilate
A(i+2:m,i) */
i__2 = a_subscr(i__ + 1, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/* Computing MIN */
i__2 = i__ + 2;
i__3 = *m - i__;
clarfg_(&i__3, &alpha, &a_ref(min(i__2,*m), i__), &c__1, &
tauq[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = a_subscr(i__ + 1, i__);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply H(i)' to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__;
i__3 = *n - i__;
r_cnjg(&q__1, &tauq[i__]);
clarf_("Left", &i__2, &i__3, &a_ref(i__ + 1, i__), &c__1, &
q__1, &a_ref(i__ + 1, i__ + 1), lda, &work[1]);
i__2 = a_subscr(i__ + 1, i__);
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.f;
} else {
i__2 = i__;
tauq[i__2].r = 0.f, tauq[i__2].i = 0.f;
}
/* L20: */
}
}
return 0;
/* End of CGEBD2 */
} /* cgebd2_ */
/* Subroutine */ int cgeql2_(integer *m, integer *n, complex *a, integer *lda,
complex *tau, complex *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGEQL2 computes a QL factorization of a complex m by n matrix A:
A = Q * L.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the m by n matrix A.
On exit, if m >= n, the lower triangle of the subarray
A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
if m <= n, the elements on and below the (n-m)-th
superdiagonal contain the m by n lower trapezoidal matrix L;
the remaining elements, with the array TAU, represent the
unitary matrix Q as a product of elementary reflectors
(see Further Details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
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
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(k) . . . H(2) H(1), where k = min(m,n).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
A(1:m-k+i-1,n-k+i), and tau in TAU(i).
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer i, k;
static complex alpha;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
clarfg_(integer *, complex *, complex *, integer *, complex *),
xerbla_(char *, integer *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEQL2", &i__1);
return 0;
}
k = min(*m,*n);
for (i = k; i >= 1; --i) {
/* Generate elementary reflector H(i) to annihilate
A(1:m-k+i-1,n-k+i) */
i__1 = *m - k + i + (*n - k + i) * a_dim1;
alpha.r = A(*m-k+i,*n-k+i).r, alpha.i = A(*m-k+i,*n-k+i).i;
i__1 = *m - k + i;
clarfg_(&i__1, &alpha, &A(1,*n-k+i), &c__1, &TAU(i));
/* Apply H(i)' to A(1:m-k+i,1:n-k+i-1) from the left */
i__1 = *m - k + i + (*n - k + i) * a_dim1;
A(*m-k+i,*n-k+i).r = 1.f, A(*m-k+i,*n-k+i).i = 0.f;
i__1 = *m - k + i;
i__2 = *n - k + i - 1;
r_cnjg(&q__1, &TAU(i));
clarf_("Left", &i__1, &i__2, &A(1,*n-k+i), &c__1, &
q__1, &A(1,1), lda, &WORK(1));
i__1 = *m - k + i + (*n - k + i) * a_dim1;
A(*m-k+i,*n-k+i).r = alpha.r, A(*m-k+i,*n-k+i).i = alpha.i;
/* L10: */
}
return 0;
/* End of CGEQL2 */
} /* cgeql2_ */
/* Subroutine */ int cgehd2_(integer *n, integer *ilo, integer *ihi, complex *
a, integer *lda, complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
integer i__;
complex alpha;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CGEHD2 reduces a complex general matrix A to upper Hessenberg form H */
/* by a unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to CGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= max(1,N). */
/* 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 */
/* elements below the first subdiagonal, with the array TAU, */
/* represent the unitary matrix Q as a product of elementary */
/* reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* 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 */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
clarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
/* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
r_cnjg(&q__1, &tau[i__]);
clarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &q__1,
&a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
}
return 0;
/* End of CGEHD2 */
} /* cgehd2_ */