#include "f2c.h"
/* Mod by jack to compile huge routine on 68000 compiler: */
#if defined(__MWERKS__) && !defined(__powerc)
#define BIGROUTINEHACK
#endif
#if defined(__MWERKS__) && defined(__powerc)
/* Some routines here are too big for optimizer level 4 */
#pragma optimization_level 1
#endif
static integer c__1 = 1;
static integer c__0 = 0;
static integer c__6 = 6;
static integer c__4 = 4;
static integer c__8 = 8;
static integer c_n1 = -1;
static integer c__65 = 65;
static integer c__15 = 15;
static integer c__3 = 3;
static integer c__2 = 2;
static logical c_false = FALSE_;
static doublereal c_b48 = 1.;
static doublereal c_b36 = .5;
static doublereal c_b15 = -.125;
static doublereal c_b71 = -1.;
static doublereal c_b78 = 0.;
static doublecomplex c_b5 = {1.,0.};
static doublecomplex c_b1a = {1.,0.};
static doublecomplex c_b2a = {0.,0.};
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
/* zlahrd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2
/* Subroutine */ int zlahrd_(n, k, nb, a, lda, tau, t, ldt, y, ldy)
integer *n, *k, *nb;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *t;
integer *ldt;
doublecomplex *y;
integer *ldy;
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
static integer i__;
extern /* Subroutine */ int zscal_(), zgemv_(), zcopy_(), zaxpy_(),
ztrmv_();
static doublecomplex ei;
extern /* Subroutine */ int zlarfg_(), zlacgv_();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)
*/
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by a unitary similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine
*/
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
*/
/* This is an auxiliary routine called by ZGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a
*/
/* product of elementary reflectors. The other columns of A are
*/
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX*16 array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further
*/
/* Details. */
/* T (output) COMPLEX*16 array, dimension (NB,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= max(1,N). */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors
*/
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix
*/
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an
*/
/* element of the vector defining H(i). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = t_dim1 + 1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = y_dim1 + 1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(1:n,i) */
/* Compute i-th column of A - Y * V' */
i__2 = i__ - 1;
zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
i__2 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &a[*k
+ i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], &
c__1, 12L);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
/* Apply I - V * T' * V' to this column (call it b) from
the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
*/
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
ztrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 +
a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1, 5L, 19L, 4L);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
t[*nb * t_dim1 + 1], &c__1, 19L);
/* w := T'*w */
i__2 = i__ - 1;
ztrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1, 5L, 19L, 8L);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
i__ * a_dim1], &c__1, 12L);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
ztrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1, 5L, 12L, 4L);
i__2 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
a[i__2].r = ei.r, a[i__2].i = ei.i;
}
/* Generate the elementary reflector H(i) to annihilate */
/* A(k+i+1:n,i) */
i__2 = *k + i__ + i__ * a_dim1;
ei.r = a[i__2].r, ei.i = a[i__2].i;
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
zlarfg_(&i__2, &ei, &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__])
;
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i__ + 1;
zgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ *
y_dim1 + 1], &c__1, 12L);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
i__ * t_dim1 + 1], &c__1, 19L);
i__2 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &t[i__ *
t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1, 12L);
zscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
/* Compute T(1:i,i) */
i__2 = i__ - 1;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1, 5L, 12L, 8L);
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
a[i__1].r = ei.r, a[i__1].i = ei.i;
return 0;
/* End of ZLAHRD */
} /* zlahrd_ */
/* zunmqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zunmqr_(side, trans, m, n, k, a, lda, tau, c__, ldc,
work, lwork, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *c__;
integer *ldc;
doublecomplex *work;
integer *lwork, *info;
ftnlen side_len;
ftnlen trans_len;
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat();
/* Local variables */
static logical left;
static integer i__;
static doublecomplex t[4160] /* was [65][64] */;
extern logical lsame_();
static integer nbmin, iinfo, i1, i2, i3, ib, ic, jc, nb, mi, ni;
extern /* Subroutine */ int zunm2r_();
static integer nq, nw;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zlarfb_();
static logical notran;
static integer ldwork;
extern /* Subroutine */ int zlarft_();
static integer iws;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNMQR 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 defined as the product of k */
/* elementary reflectors */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by ZGEQRF. 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**H from the Left; */
/* = 'R': apply Q or Q**H from the Right. */
/* 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. */
/* 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*16 array, dimension (LDA,K) */
/* The i-th column must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by
*/
/* ZGEQRF in the first k columns 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. */
/* If SIDE = 'L', LDA >= max(1,M); */
/* if SIDE = 'R', LDA >= max(1,N). */
/* TAU (input) COMPLEX*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGEQRF. */
/* C (input/output) COMPLEX*16 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/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C", 1L, 1L)) {
*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,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*lwork < max(1,nw)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNMQR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size. NB may be at most NBMAX, where NBMAX */
/* is used to define the local array T. */
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMQR", ch__1, m, n, k, &c_n1, 6L, 2L);
nb = min(i__1,i__2);
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMQR", ch__1, m, n, k, &c_n1,
6L, 2L);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
zunm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, 1L, 1L);
} else {
/* Use blocked code */
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
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) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1;
zlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], t, &c__65, 7L, 10L);
if (left) {
/* H or H' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H' */
zlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc *
c_dim1], ldc, &work[1], &ldwork, 1L, 1L, 7L, 10L);
/* L10: */
}
}
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZUNMQR */
} /* zunmqr_ */
/* zgeev.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zgeev_(jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,
work, lwork, rwork, info, jobvl_len, jobvr_len)
char *jobvl, *jobvr;
integer *n;
doublecomplex *a;
integer *lda;
doublecomplex *w, *vl;
integer *ldvl;
doublecomplex *vr;
integer *ldvr;
doublecomplex *work;
integer *lwork;
doublereal *rwork;
integer *info;
ftnlen jobvl_len;
ftnlen jobvr_len;
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(), d_imag();
void d_cnjg();
/* Local variables */
static integer ibal;
static char side[1];
static integer maxb;
static doublereal anrm;
static integer ierr, itau, iwrk, nout, i__, k;
extern logical lsame_();
extern /* Subroutine */ int zscal_(), dlabad_();
extern doublereal dznrm2_();
static logical scalea;
extern doublereal dlamch_();
static doublereal cscale;
extern /* Subroutine */ int zgebak_(), zgebal_();
extern integer idamax_();
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
static logical select[1];
extern /* Subroutine */ int zdscal_();
static doublereal bignum;
extern doublereal zlange_();
extern /* Subroutine */ int zgehrd_(), zlascl_(), zlacpy_();
static integer minwrk, maxwrk;
static logical wantvl;
static doublereal smlnum;
static integer hswork, irwork;
extern /* Subroutine */ int zhseqr_(), ztrevc_();
static logical wantvr;
extern /* Subroutine */ int zunghr_();
static integer ihi;
static doublereal scl;
static integer ilo;
static doublereal dum[1], eps;
static doublecomplex tmp;
/* -- LAPACK driver routine (version 2.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 */
/* ======= */
/* ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* W (output) COMPLEX*16 array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX*16 array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* u(j) = VL(:,j), the j-th column of VL. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) COMPLEX*16 array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* v(j) = VR(:,j), the j-th column of VR. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,2*N). */
/* For good performance, LWORK must generally be larger. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the
*/
/* eigenvalues, and no eigenvectors have been computed; */
/* elements and i+1:N of W contain eigenvalues which have
*/
/* converged. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = vl_dim1 + 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = vr_dim1 + 1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
wantvl = lsame_(jobvl, "V", 1L, 1L);
wantvr = lsame_(jobvr, "V", 1L, 1L);
if (! wantvl && ! lsame_(jobvl, "N", 1L, 1L)) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N", 1L, 1L)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -10;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace to real */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by ZHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &c__0,
6L, 1L);
if (! wantvl && ! wantvr) {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "ZHSEQR", "EN", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN */
/* Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "EN", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
maxwrk = max(maxwrk,hswork);
} else {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR",
" ", n, &c__1, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "ZHSEQR", "SV", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN */
/* Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SV", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = max(maxwrk,hswork), i__2 = *n << 1;
maxwrk = max(i__1,i__2);
}
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEEV ", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P", 1L);
smlnum = dlamch_("S", 1L);
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = zlange_("M", n, n, &a[a_offset], lda, dum, 1L);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr, 1L);
}
/* Balance the matrix */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
ibal = 1;
zgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr, 1L);
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl, 1L);
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
zunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info, 1L, 1L);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, 1L)
;
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr, 1L);
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
zunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info, 1L, 1L);
} else {
/* Compute eigenvalues only */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info, 1L, 1L);
}
/* If INFO > 0 from ZHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need 2*N) */
irwork = ibal + *n;
ztrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork],
&ierr, 1L, 1L);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
zgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset],
ldvl, &ierr, 1L, 1L);
/* Normalize left eigenvectors and make largest component real
*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vl_dim1;
/* Computing 2nd power */
d__1 = vl[i__3].r;
/* Computing 2nd power */
d__2 = d_imag(&vl[k + i__ * vl_dim1]);
rwork[irwork + k - 1] = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = idamax_(n, &rwork[irwork], &c__1);
d_cnjg(&z__2, &vl[k + i__ * vl_dim1]);
d__1 = sqrt(rwork[irwork + k - 1]);
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
tmp.r = z__1.r, tmp.i = z__1.i;
zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
d__1 = vl[i__3].r;
z__1.r = d__1, z__1.i = 0.;
vl[i__2].r = z__1.r, vl[i__2].i = z__1.i;
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
zgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset],
ldvr, &ierr, 1L, 1L);
/* Normalize right eigenvectors and make largest component real
*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vr_dim1;
/* Computing 2nd power */
d__1 = vr[i__3].r;
/* Computing 2nd power */
d__2 = d_imag(&vr[k + i__ * vr_dim1]);
rwork[irwork + k - 1] = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = idamax_(n, &rwork[irwork], &c__1);
d_cnjg(&z__2, &vr[k + i__ * vr_dim1]);
d__1 = sqrt(rwork[irwork + k - 1]);
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
tmp.r = z__1.r, tmp.i = z__1.i;
zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
d__1 = vr[i__3].r;
z__1.r = d__1, z__1.i = 0.;
vr[i__2].r = z__1.r, vr[i__2].i = z__1.i;
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr, 1L);
if (*info > 0) {
i__1 = ilo - 1;
zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr, 1L);
}
}
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZGEEV */
} /* zgeev_ */
/* zgetrf.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1a
/* Subroutine */ int zgetrf_(m, n, a, lda, ipiv, info)
integer *m, *n;
doublecomplex *a;
integer *lda, *ipiv, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Local variables */
static integer i__, j, iinfo;
extern /* Subroutine */ int zgemm_(), ztrsm_(), zgetf2_();
static integer jb, nb;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zlaswp_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGETRF computes an LU factorization of a general M-by-N matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 3 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*/
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used
*/
/* to solve a system of equations. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
/* 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_("ZGETRF", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "ZGETRF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
if (nb <= 1 || nb >= min(*m,*n)) {
/* Use unblocked code. */
zgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
} else {
/* Use blocked code. */
i__1 = min(*m,*n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = min(*m,*n) - j + 1;
jb = min(i__3,nb);
/* Factor diagonal and subdiagonal blocks and test for e
xact */
/* singularity. */
i__3 = *m - j + 1;
zgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
/* Adjust INFO and the pivot indices. */
if (*info == 0 && iinfo > 0) {
*info = iinfo + j - 1;
}
/* Computing MIN */
i__4 = *m, i__5 = j + jb - 1;
i__3 = min(i__4,i__5);
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = j - 1 + ipiv[i__];
/* L10: */
}
/* Apply interchanges to columns 1:J-1. */
i__3 = j - 1;
i__4 = j + jb - 1;
zlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
if (j + jb <= *n) {
/* Apply interchanges to columns J+JB:N. */
i__3 = *n - j - jb + 1;
i__4 = j + jb - 1;
zlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
ipiv[1], &c__1);
/* Compute block row of U. */
i__3 = *n - j - jb + 1;
ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
a_dim1], lda, 4L, 5L, 12L, 4L);
if (j + jb <= *m) {
/* Update trailing submatrix. */
i__3 = *m - j - jb + 1;
i__4 = *n - j - jb + 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "No transpose", &i__3, &i__4, &jb,
&z__1, &a[j + jb + j * a_dim1], lda, &a[j + (j +
jb) * a_dim1], lda, &c_b1, &a[j + jb + (j + jb) *
a_dim1], lda, 12L, 12L);
}
}
/* L20: */
}
}
return 0;
/* End of ZGETRF */
} /* zgetrf_ */
/* zlaset.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zlaset_(uplo, m, n, alpha, beta, a, lda, uplo_len)
char *uplo;
integer *m, *n;
doublecomplex *alpha, *beta, *a;
integer *lda;
ftnlen uplo_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j;
extern logical lsame_();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLASET initializes a 2-D array A to BETA on the diagonal and */
/* ALPHA on the offdiagonals. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies the part of the matrix A to be set. */
/* = 'U': Upper triangular part is set. The lower triangle
*/
/* is unchanged. */
/* = 'L': Lower triangular part is set. The upper triangle
*/
/* is unchanged. */
/* Otherwise: All of the matrix A is set. */
/* M (input) INTEGER */
/* On entry, M specifies the number of rows of A. */
/* N (input) INTEGER */
/* On entry, N specifies the number of columns of A. */
/* ALPHA (input) COMPLEX*16 */
/* All the offdiagonal array elements are set to ALPHA. */
/* BETA (input) COMPLEX*16 */
/* All the diagonal array elements are set to BETA. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; */
/* A(i,i) = BETA , 1 <= i <= min(m,n) */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
if (lsame_(uplo, "U", 1L, 1L)) {
/* Set the diagonal to BETA and the strictly upper triangular
*/
/* part of the array to ALPHA. */
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = alpha->r, a[i__3].i = alpha->i;
/* L10: */
}
/* L20: */
}
i__1 = min(*n,*m);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = beta->r, a[i__2].i = beta->i;
/* L30: */
}
} else if (lsame_(uplo, "L", 1L, 1L)) {
/* Set the diagonal to BETA and the strictly lower triangular
*/
/* part of the array to ALPHA. */
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = alpha->r, a[i__3].i = alpha->i;
/* L40: */
}
/* L50: */
}
i__1 = min(*n,*m);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = beta->r, a[i__2].i = beta->i;
/* L60: */
}
} else {
/* Set the array to BETA on the diagonal and ALPHA on the */
/* offdiagonal. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = alpha->r, a[i__3].i = alpha->i;
/* L70: */
}
/* L80: */
}
i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = beta->r, a[i__2].i = beta->i;
/* L90: */
}
}
return 0;
/* End of ZLASET */
} /* zlaset_ */
/* zlatrs.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b36
#undef c_b36
#endif
#define c_b36 c_b36
/* Subroutine */ int zlatrs_(uplo, trans, diag, normin, n, a, lda, x, scale,
cnorm, info, uplo_len, trans_len, diag_len, normin_len)
char *uplo, *trans, *diag, *normin;
integer *n;
doublecomplex *a;
integer *lda;
doublecomplex *x;
doublereal *scale, *cnorm;
integer *info;
ftnlen uplo_len;
ftnlen trans_len;
ftnlen diag_len;
ftnlen normin_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag();
void d_cnjg();
/* Local variables */
static integer jinc;
static doublereal xbnd;
static integer imax;
static doublereal tmax;
static doublecomplex tjjs;
static doublereal xmax, grow;
static integer i__, j;
extern /* Subroutine */ int dscal_();
extern logical lsame_();
static doublereal tscal;
static doublecomplex uscal;
static integer jlast;
static doublecomplex csumj;
extern /* Double Complex */ VOID zdotc_();
static logical upper;
extern /* Double Complex */ VOID zdotu_();
extern /* Subroutine */ int zaxpy_(), ztrsv_(), dlabad_();
extern doublereal dlamch_();
static doublereal xj;
extern integer idamax_();
extern /* Subroutine */ int xerbla_(), zdscal_();
static doublereal bignum;
extern integer izamax_();
extern /* Double Complex */ VOID zladiv_();
static logical notran;
static integer jfirst;
extern doublereal dzasum_();
static doublereal smlnum;
static logical nounit;
static doublereal rec, tjj;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the
*/
/* conjugate transpose of A, x and b are n-element vectors, and s is a */
/* scaling factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
*/
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
*/
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular.
*/
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of
*/
/* A is not referenced. If UPLO = 'L', the leading n by n lower
*/
/* triangular part of the array A contains the lower triangular
*/
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max (1,N). */
/* X (input/output) COMPLEX*16 array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) DOUBLE PRECISION */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0.
*/
/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column
*/
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
*/
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column
*/
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, ZTRSV
*/
/* is called, otherwise, specific code is used which checks for possible
*/
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm
*/
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop:
*/
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
*/
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
*/
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
nounit = lsame_(diag, "N", 1L, 1L);
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans,
"C", 1L, 1L)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", 1L, 1L)) {
*info = -3;
} else if (! lsame_(normin, "Y", 1L, 1L) && ! lsame_(normin, "N", 1L, 1L))
{
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATRS", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum", 12L);
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision", 9L);
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N", 1L, 1L)) {
/* Compute the 1-norm of each column, not including the diagona
l. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
/* L20: */
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is
*/
/* greater than BIGNUM/2. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine ZTRSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
d_imag(&x[j]) / 2., abs(d__2));
xmax = max(d__3,d__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,
j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...
,n}. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (cnorm[j] + 1.);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.) {
grow = 0.;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*/
xj = cnorm[j] + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(
j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
/* L70: */
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...
,n}. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on
*/
/* elements of X is not too small. */
ztrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, 1L, 1L,
1L);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5) {
/* Scale X so that its components are less than or equal
to */
/* BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if nec
essary. */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(
A(j,j))*BIGNUM */
/* to avoid overflow when dividi
ng by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.) {
/* Scale by 1/CNORM(j) to
avoid overflow when */
/* multiplying x(j) times
column j. */
rec /= cnorm[j];
}
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) =
1, and */
/* scale = 0, and compute a solution to
A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
/* L100: */
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when ad
ding a */
/* multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) *
A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = izamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) *
A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
}
/* L120: */
}
} else if (lsame_(trans, "T", 1L, 1L)) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot
product is 1, */
/* call ZDOTU to perform the dot product.
*/
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L130: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L140: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,
j) if 1/A(j,j) */
/* was not used to scale the dotproduct.
*/
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
/* Compute x(j) = x(j) / A(j,j), scalin
g if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)
))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and */
/* scale = 0 and compute a solut
ion to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
/* L150: */
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ i
f the dot */
/* product has already been divided by 1/A
(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
/* L170: */
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot
product is 1, */
/* call ZDOTC to perform the dot product.
*/
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L180: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L190: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,
j) if 1/A(j,j) */
/* was not used to scale the dotproduct.
*/
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
/* Compute x(j) = x(j) / A(j,j), scalin
g if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)
))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and */
/* scale = 0 and compute a solut
ion to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
/* L200: */
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ i
f the dot */
/* product has already been divided by 1/A
(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
/* L220: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of ZLATRS */
} /* zlatrs_ */
/* zlarfx.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2
/* Subroutine */ int zlarfx_(side, m, n, v, tau, c__, ldc, work, side_len)
char *side;
integer *m, *n;
doublecomplex *v, *tau, *c__;
integer *ldc;
doublecomplex *work;
ftnlen side_len;
{
/* System generated locals */
integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
i__9, i__10, i__11;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
z__11, z__12, z__13, z__14, z__15, z__16, z__17, z__18, z__19;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static integer j;
extern logical lsame_();
extern /* Subroutine */ int zgerc_(), zgemv_();
static doublecomplex t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4,
v5, v6, v7, v8, v9, t10, v10, sum;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARFX applies a complex elementary reflector H to a complex m by n */
/* matrix C, from either the left or the right. H is represented in the
*/
/* form */
/* H = I - tau * v * v' */
/* where tau is a complex scalar and v is a complex vector. */
/* If tau = 0, then H is taken to be the unit matrix */
/* This version uses inline code if H has order < 11. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* V (input) COMPLEX*16 array, dimension (M) if SIDE = 'L' */
/* or (N) if SIDE = 'R' */
/* The vector v in the representation of H. */
/* TAU (input) COMPLEX*16 */
/* The value tau in the representation of H. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the m by n matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*/
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDA >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* WORK is not referenced if H has order < 11. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
if (tau->r == 0. && tau->i == 0.) {
return 0;
}
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C, where H has order m. */
switch ((int)*m) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
#ifndef BIGROUTINEHACK
case 4: goto L70;
case 5: goto L90;
case 6: goto L110;
case 7: goto L130;
case 8: goto L150;
case 9: goto L170;
case 10: goto L190;
#endif /* BIGROUTINEHACK */
}
/* Code for general M */
/* w := C'*v */
zgemv_("Conjugate transpose", m, n, &c_b2, &c__[c_offset], ldc, &v[1],
&c__1, &c_b1, &work[1], &c__1, 19L);
/* C := C - tau * v * w' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, n, &z__1, &v[1], &c__1, &work[1], &c__1, &c__[c_offset],
ldc);
goto L410;
L10:
/* Special code for 1 x 1 Householder */
z__3.r = tau->r * v[1].r - tau->i * v[1].i, z__3.i = tau->r * v[1].i
+ tau->i * v[1].r;
d_cnjg(&z__4, &v[1]);
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i
+ z__3.i * z__4.r;
z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
t1.r = z__1.r, t1.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, z__1.i = t1.r *
c__[i__3].i + t1.i * c__[i__3].r;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L20: */
}
goto L410;
L30:
/* Special code for 2 x 2 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__2.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__3.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L40: */
}
goto L410;
L50:
/* Special code for 3 x 3 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
d_cnjg(&z__1, &v[3]);
v3.r = z__1.r, v3.i = z__1.i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__3.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__4.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = j * c_dim1 + 3;
z__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__5.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 3;
i__3 = j * c_dim1 + 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L60: */
}
goto L410;
#ifndef BIGROUTINEHACK
L70:
/* Special code for 4 x 4 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
d_cnjg(&z__1, &v[3]);
v3.r = z__1.r, v3.i = z__1.i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
d_cnjg(&z__1, &v[4]);
v4.r = z__1.r, v4.i = z__1.i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__4.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__5.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
i__4 = j * c_dim1 + 3;
z__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__6.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
i__5 = j * c_dim1 + 4;
z__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__7.i = v4.r *
c__[i__5].i + v4.i * c__[i__5].r;
z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 3;
i__3 = j * c_dim1 + 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 4;
i__3 = j * c_dim1 + 4;
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L80: */
}
goto L410;
L90:
/* Special code for 5 x 5 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
d_cnjg(&z__1, &v[3]);
v3.r = z__1.r, v3.i = z__1.i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
d_cnjg(&z__1, &v[4]);
v4.r = z__1.r, v4.i = z__1.i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
d_cnjg(&z__1, &v[5]);
v5.r = z__1.r, v5.i = z__1.i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__5.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__6.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__4 = j * c_dim1 + 3;
z__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__7.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
i__5 = j * c_dim1 + 4;
z__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__8.i = v4.r *
c__[i__5].i + v4.i * c__[i__5].r;
z__2.r = z__3.r + z__8.r, z__2.i = z__3.i + z__8.i;
i__6 = j * c_dim1 + 5;
z__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__9.i = v5.r *
c__[i__6].i + v5.i * c__[i__6].r;
z__1.r = z__2.r + z__9.r, z__1.i = z__2.i + z__9.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 3;
i__3 = j * c_dim1 + 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 4;
i__3 = j * c_dim1 + 4;
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 5;
i__3 = j * c_dim1 + 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L100: */
}
goto L410;
L110:
/* Special code for 6 x 6 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
d_cnjg(&z__1, &v[3]);
v3.r = z__1.r, v3.i = z__1.i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
d_cnjg(&z__1, &v[4]);
v4.r = z__1.r, v4.i = z__1.i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
d_cnjg(&z__1, &v[5]);
v5.r = z__1.r, v5.i = z__1.i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
d_cnjg(&z__1, &v[6]);
v6.r = z__1.r, v6.i = z__1.i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__6.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__7.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
i__4 = j * c_dim1 + 3;
z__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__8.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i;
i__5 = j * c_dim1 + 4;
z__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__9.i = v4.r *
c__[i__5].i + v4.i * c__[i__5].r;
z__3.r = z__4.r + z__9.r, z__3.i = z__4.i + z__9.i;
i__6 = j * c_dim1 + 5;
z__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__10.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__2.r = z__3.r + z__10.r, z__2.i = z__3.i + z__10.i;
i__7 = j * c_dim1 + 6;
z__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__11.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__1.r = z__2.r + z__11.r, z__1.i = z__2.i + z__11.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 3;
i__3 = j * c_dim1 + 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 4;
i__3 = j * c_dim1 + 4;
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 5;
i__3 = j * c_dim1 + 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 6;
i__3 = j * c_dim1 + 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L120: */
}
goto L410;
L130:
/* Special code for 7 x 7 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
d_cnjg(&z__1, &v[3]);
v3.r = z__1.r, v3.i = z__1.i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
d_cnjg(&z__1, &v[4]);
v4.r = z__1.r, v4.i = z__1.i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
d_cnjg(&z__1, &v[5]);
v5.r = z__1.r, v5.i = z__1.i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
d_cnjg(&z__1, &v[6]);
v6.r = z__1.r, v6.i = z__1.i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
d_cnjg(&z__1, &v[7]);
v7.r = z__1.r, v7.i = z__1.i;
d_cnjg(&z__2, &v7);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t7.r = z__1.r, t7.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__7.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__8.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__6.r = z__7.r + z__8.r, z__6.i = z__7.i + z__8.i;
i__4 = j * c_dim1 + 3;
z__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__9.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__5.r = z__6.r + z__9.r, z__5.i = z__6.i + z__9.i;
i__5 = j * c_dim1 + 4;
z__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__10.i = v4.r
* c__[i__5].i + v4.i * c__[i__5].r;
z__4.r = z__5.r + z__10.r, z__4.i = z__5.i + z__10.i;
i__6 = j * c_dim1 + 5;
z__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__11.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__3.r = z__4.r + z__11.r, z__3.i = z__4.i + z__11.i;
i__7 = j * c_dim1 + 6;
z__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__12.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__2.r = z__3.r + z__12.r, z__2.i = z__3.i + z__12.i;
i__8 = j * c_dim1 + 7;
z__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__13.i = v7.r
* c__[i__8].i + v7.i * c__[i__8].r;
z__1.r = z__2.r + z__13.r, z__1.i = z__2.i + z__13.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 3;
i__3 = j * c_dim1 + 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 4;
i__3 = j * c_dim1 + 4;
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 5;
i__3 = j * c_dim1 + 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 6;
i__3 = j * c_dim1 + 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 7;
i__3 = j * c_dim1 + 7;
z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
sum.i * t7.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L140: */
}
goto L410;
L150:
/* Special code for 8 x 8 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
d_cnjg(&z__1, &v[3]);
v3.r = z__1.r, v3.i = z__1.i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
d_cnjg(&z__1, &v[4]);
v4.r = z__1.r, v4.i = z__1.i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
d_cnjg(&z__1, &v[5]);
v5.r = z__1.r, v5.i = z__1.i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
d_cnjg(&z__1, &v[6]);
v6.r = z__1.r, v6.i = z__1.i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
d_cnjg(&z__1, &v[7]);
v7.r = z__1.r, v7.i = z__1.i;
d_cnjg(&z__2, &v7);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t7.r = z__1.r, t7.i = z__1.i;
d_cnjg(&z__1, &v[8]);
v8.r = z__1.r, v8.i = z__1.i;
d_cnjg(&z__2, &v8);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t8.r = z__1.r, t8.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__8.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__9.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i;
i__4 = j * c_dim1 + 3;
z__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__10.i = v3.r
* c__[i__4].i + v3.i * c__[i__4].r;
z__6.r = z__7.r + z__10.r, z__6.i = z__7.i + z__10.i;
i__5 = j * c_dim1 + 4;
z__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__11.i = v4.r
* c__[i__5].i + v4.i * c__[i__5].r;
z__5.r = z__6.r + z__11.r, z__5.i = z__6.i + z__11.i;
i__6 = j * c_dim1 + 5;
z__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__12.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__4.r = z__5.r + z__12.r, z__4.i = z__5.i + z__12.i;
i__7 = j * c_dim1 + 6;
z__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__13.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__3.r = z__4.r + z__13.r, z__3.i = z__4.i + z__13.i;
i__8 = j * c_dim1 + 7;
z__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__14.i = v7.r
* c__[i__8].i + v7.i * c__[i__8].r;
z__2.r = z__3.r + z__14.r, z__2.i = z__3.i + z__14.i;
i__9 = j * c_dim1 + 8;
z__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__15.i = v8.r
* c__[i__9].i + v8.i * c__[i__9].r;
z__1.r = z__2.r + z__15.r, z__1.i = z__2.i + z__15.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 3;
i__3 = j * c_dim1 + 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 4;
i__3 = j * c_dim1 + 4;
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 5;
i__3 = j * c_dim1 + 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 6;
i__3 = j * c_dim1 + 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 7;
i__3 = j * c_dim1 + 7;
z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
sum.i * t7.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 8;
i__3 = j * c_dim1 + 8;
z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
sum.i * t8.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L160: */
}
goto L410;
L170:
/* Special code for 9 x 9 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
d_cnjg(&z__1, &v[3]);
v3.r = z__1.r, v3.i = z__1.i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
d_cnjg(&z__1, &v[4]);
v4.r = z__1.r, v4.i = z__1.i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
d_cnjg(&z__1, &v[5]);
v5.r = z__1.r, v5.i = z__1.i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
d_cnjg(&z__1, &v[6]);
v6.r = z__1.r, v6.i = z__1.i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
d_cnjg(&z__1, &v[7]);
v7.r = z__1.r, v7.i = z__1.i;
d_cnjg(&z__2, &v7);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t7.r = z__1.r, t7.i = z__1.i;
d_cnjg(&z__1, &v[8]);
v8.r = z__1.r, v8.i = z__1.i;
d_cnjg(&z__2, &v8);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t8.r = z__1.r, t8.i = z__1.i;
d_cnjg(&z__1, &v[9]);
v9.r = z__1.r, v9.i = z__1.i;
d_cnjg(&z__2, &v9);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t9.r = z__1.r, t9.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__9.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__10.i = v2.r
* c__[i__3].i + v2.i * c__[i__3].r;
z__8.r = z__9.r + z__10.r, z__8.i = z__9.i + z__10.i;
i__4 = j * c_dim1 + 3;
z__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__11.i = v3.r
* c__[i__4].i + v3.i * c__[i__4].r;
z__7.r = z__8.r + z__11.r, z__7.i = z__8.i + z__11.i;
i__5 = j * c_dim1 + 4;
z__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__12.i = v4.r
* c__[i__5].i + v4.i * c__[i__5].r;
z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i;
i__6 = j * c_dim1 + 5;
z__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__13.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__5.r = z__6.r + z__13.r, z__5.i = z__6.i + z__13.i;
i__7 = j * c_dim1 + 6;
z__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__14.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__4.r = z__5.r + z__14.r, z__4.i = z__5.i + z__14.i;
i__8 = j * c_dim1 + 7;
z__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__15.i = v7.r
* c__[i__8].i + v7.i * c__[i__8].r;
z__3.r = z__4.r + z__15.r, z__3.i = z__4.i + z__15.i;
i__9 = j * c_dim1 + 8;
z__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__16.i = v8.r
* c__[i__9].i + v8.i * c__[i__9].r;
z__2.r = z__3.r + z__16.r, z__2.i = z__3.i + z__16.i;
i__10 = j * c_dim1 + 9;
z__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__17.i =
v9.r * c__[i__10].i + v9.i * c__[i__10].r;
z__1.r = z__2.r + z__17.r, z__1.i = z__2.i + z__17.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 3;
i__3 = j * c_dim1 + 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 4;
i__3 = j * c_dim1 + 4;
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 5;
i__3 = j * c_dim1 + 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 6;
i__3 = j * c_dim1 + 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 7;
i__3 = j * c_dim1 + 7;
z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
sum.i * t7.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 8;
i__3 = j * c_dim1 + 8;
z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
sum.i * t8.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 9;
i__3 = j * c_dim1 + 9;
z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i +
sum.i * t9.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L180: */
}
goto L410;
L190:
/* Special code for 10 x 10 Householder */
d_cnjg(&z__1, &v[1]);
v1.r = z__1.r, v1.i = z__1.i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
d_cnjg(&z__1, &v[2]);
v2.r = z__1.r, v2.i = z__1.i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
d_cnjg(&z__1, &v[3]);
v3.r = z__1.r, v3.i = z__1.i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
d_cnjg(&z__1, &v[4]);
v4.r = z__1.r, v4.i = z__1.i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
d_cnjg(&z__1, &v[5]);
v5.r = z__1.r, v5.i = z__1.i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
d_cnjg(&z__1, &v[6]);
v6.r = z__1.r, v6.i = z__1.i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
d_cnjg(&z__1, &v[7]);
v7.r = z__1.r, v7.i = z__1.i;
d_cnjg(&z__2, &v7);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t7.r = z__1.r, t7.i = z__1.i;
d_cnjg(&z__1, &v[8]);
v8.r = z__1.r, v8.i = z__1.i;
d_cnjg(&z__2, &v8);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t8.r = z__1.r, t8.i = z__1.i;
d_cnjg(&z__1, &v[9]);
v9.r = z__1.r, v9.i = z__1.i;
d_cnjg(&z__2, &v9);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t9.r = z__1.r, t9.i = z__1.i;
d_cnjg(&z__1, &v[10]);
v10.r = z__1.r, v10.i = z__1.i;
d_cnjg(&z__2, &v10);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t10.r = z__1.r, t10.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j * c_dim1 + 1;
z__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__10.i = v1.r
* c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j * c_dim1 + 2;
z__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__11.i = v2.r
* c__[i__3].i + v2.i * c__[i__3].r;
z__9.r = z__10.r + z__11.r, z__9.i = z__10.i + z__11.i;
i__4 = j * c_dim1 + 3;
z__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__12.i = v3.r
* c__[i__4].i + v3.i * c__[i__4].r;
z__8.r = z__9.r + z__12.r, z__8.i = z__9.i + z__12.i;
i__5 = j * c_dim1 + 4;
z__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__13.i = v4.r
* c__[i__5].i + v4.i * c__[i__5].r;
z__7.r = z__8.r + z__13.r, z__7.i = z__8.i + z__13.i;
i__6 = j * c_dim1 + 5;
z__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__14.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__6.r = z__7.r + z__14.r, z__6.i = z__7.i + z__14.i;
i__7 = j * c_dim1 + 6;
z__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__15.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__5.r = z__6.r + z__15.r, z__5.i = z__6.i + z__15.i;
i__8 = j * c_dim1 + 7;
z__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__16.i = v7.r
* c__[i__8].i + v7.i * c__[i__8].r;
z__4.r = z__5.r + z__16.r, z__4.i = z__5.i + z__16.i;
i__9 = j * c_dim1 + 8;
z__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__17.i = v8.r
* c__[i__9].i + v8.i * c__[i__9].r;
z__3.r = z__4.r + z__17.r, z__3.i = z__4.i + z__17.i;
i__10 = j * c_dim1 + 9;
z__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__18.i =
v9.r * c__[i__10].i + v9.i * c__[i__10].r;
z__2.r = z__3.r + z__18.r, z__2.i = z__3.i + z__18.i;
i__11 = j * c_dim1 + 10;
z__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, z__19.i =
v10.r * c__[i__11].i + v10.i * c__[i__11].r;
z__1.r = z__2.r + z__19.r, z__1.i = z__2.i + z__19.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j * c_dim1 + 1;
i__3 = j * c_dim1 + 1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 2;
i__3 = j * c_dim1 + 2;
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 3;
i__3 = j * c_dim1 + 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 4;
i__3 = j * c_dim1 + 4;
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 5;
i__3 = j * c_dim1 + 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 6;
i__3 = j * c_dim1 + 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 7;
i__3 = j * c_dim1 + 7;
z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
sum.i * t7.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 8;
i__3 = j * c_dim1 + 8;
z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
sum.i * t8.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 9;
i__3 = j * c_dim1 + 9;
z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i +
sum.i * t9.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j * c_dim1 + 10;
i__3 = j * c_dim1 + 10;
z__2.r = sum.r * t10.r - sum.i * t10.i, z__2.i = sum.r * t10.i +
sum.i * t10.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L200: */
}
#endif /* BIGROUTINEHACK */
goto L410;
} else {
/* Form C * H, where H has order n. */
switch ((int)*n) {
case 1: goto L210;
case 2: goto L230;
case 3: goto L250;
#ifndef BIGROUTINEHACK
case 4: goto L270;
case 5: goto L290;
case 6: goto L310;
case 7: goto L330;
case 8: goto L350;
case 9: goto L370;
case 10: goto L390;
#endif /* BIGROUTINEHACK */
}
/* Code for general N */
/* w := C * v */
zgemv_("No transpose", m, n, &c_b2, &c__[c_offset], ldc, &v[1], &c__1,
&c_b1, &work[1], &c__1, 12L);
/* C := C - tau * w * v' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, n, &z__1, &work[1], &c__1, &v[1], &c__1, &c__[c_offset],
ldc);
goto L410;
L210:
/* Special code for 1 x 1 Householder */
z__3.r = tau->r * v[1].r - tau->i * v[1].i, z__3.i = tau->r * v[1].i
+ tau->i * v[1].r;
d_cnjg(&z__4, &v[1]);
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i
+ z__3.i * z__4.r;
z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
t1.r = z__1.r, t1.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, z__1.i = t1.r *
c__[i__3].i + t1.i * c__[i__3].r;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L220: */
}
goto L410;
L230:
/* Special code for 2 x 2 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__2.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__3.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L240: */
}
goto L410;
L250:
/* Special code for 3 x 3 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
v3.r = v[3].r, v3.i = v[3].i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__3.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__4.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = j + c_dim1 * 3;
z__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__5.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 3;
i__3 = j + c_dim1 * 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L260: */
}
goto L410;
#ifndef BIGROUTINEHACK
L270:
/* Special code for 4 x 4 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
v3.r = v[3].r, v3.i = v[3].i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
v4.r = v[4].r, v4.i = v[4].i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__4.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__5.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
i__4 = j + c_dim1 * 3;
z__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__6.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
i__5 = j + (c_dim1 << 2);
z__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__7.i = v4.r *
c__[i__5].i + v4.i * c__[i__5].r;
z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 3;
i__3 = j + c_dim1 * 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 2);
i__3 = j + (c_dim1 << 2);
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L280: */
}
goto L410;
L290:
/* Special code for 5 x 5 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
v3.r = v[3].r, v3.i = v[3].i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
v4.r = v[4].r, v4.i = v[4].i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
v5.r = v[5].r, v5.i = v[5].i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__5.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__6.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__4 = j + c_dim1 * 3;
z__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__7.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
i__5 = j + (c_dim1 << 2);
z__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__8.i = v4.r *
c__[i__5].i + v4.i * c__[i__5].r;
z__2.r = z__3.r + z__8.r, z__2.i = z__3.i + z__8.i;
i__6 = j + c_dim1 * 5;
z__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__9.i = v5.r *
c__[i__6].i + v5.i * c__[i__6].r;
z__1.r = z__2.r + z__9.r, z__1.i = z__2.i + z__9.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 3;
i__3 = j + c_dim1 * 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 2);
i__3 = j + (c_dim1 << 2);
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 5;
i__3 = j + c_dim1 * 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L300: */
}
goto L410;
L310:
/* Special code for 6 x 6 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
v3.r = v[3].r, v3.i = v[3].i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
v4.r = v[4].r, v4.i = v[4].i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
v5.r = v[5].r, v5.i = v[5].i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
v6.r = v[6].r, v6.i = v[6].i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__6.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__7.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
i__4 = j + c_dim1 * 3;
z__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__8.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i;
i__5 = j + (c_dim1 << 2);
z__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__9.i = v4.r *
c__[i__5].i + v4.i * c__[i__5].r;
z__3.r = z__4.r + z__9.r, z__3.i = z__4.i + z__9.i;
i__6 = j + c_dim1 * 5;
z__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__10.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__2.r = z__3.r + z__10.r, z__2.i = z__3.i + z__10.i;
i__7 = j + c_dim1 * 6;
z__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__11.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__1.r = z__2.r + z__11.r, z__1.i = z__2.i + z__11.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 3;
i__3 = j + c_dim1 * 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 2);
i__3 = j + (c_dim1 << 2);
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 5;
i__3 = j + c_dim1 * 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 6;
i__3 = j + c_dim1 * 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L320: */
}
goto L410;
L330:
/* Special code for 7 x 7 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
v3.r = v[3].r, v3.i = v[3].i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
v4.r = v[4].r, v4.i = v[4].i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
v5.r = v[5].r, v5.i = v[5].i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
v6.r = v[6].r, v6.i = v[6].i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
v7.r = v[7].r, v7.i = v[7].i;
d_cnjg(&z__2, &v7);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t7.r = z__1.r, t7.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__7.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__8.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__6.r = z__7.r + z__8.r, z__6.i = z__7.i + z__8.i;
i__4 = j + c_dim1 * 3;
z__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__9.i = v3.r *
c__[i__4].i + v3.i * c__[i__4].r;
z__5.r = z__6.r + z__9.r, z__5.i = z__6.i + z__9.i;
i__5 = j + (c_dim1 << 2);
z__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__10.i = v4.r
* c__[i__5].i + v4.i * c__[i__5].r;
z__4.r = z__5.r + z__10.r, z__4.i = z__5.i + z__10.i;
i__6 = j + c_dim1 * 5;
z__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__11.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__3.r = z__4.r + z__11.r, z__3.i = z__4.i + z__11.i;
i__7 = j + c_dim1 * 6;
z__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__12.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__2.r = z__3.r + z__12.r, z__2.i = z__3.i + z__12.i;
i__8 = j + c_dim1 * 7;
z__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__13.i = v7.r
* c__[i__8].i + v7.i * c__[i__8].r;
z__1.r = z__2.r + z__13.r, z__1.i = z__2.i + z__13.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 3;
i__3 = j + c_dim1 * 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 2);
i__3 = j + (c_dim1 << 2);
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 5;
i__3 = j + c_dim1 * 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 6;
i__3 = j + c_dim1 * 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 7;
i__3 = j + c_dim1 * 7;
z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
sum.i * t7.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L340: */
}
goto L410;
L350:
/* Special code for 8 x 8 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
v3.r = v[3].r, v3.i = v[3].i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
v4.r = v[4].r, v4.i = v[4].i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
v5.r = v[5].r, v5.i = v[5].i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
v6.r = v[6].r, v6.i = v[6].i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
v7.r = v[7].r, v7.i = v[7].i;
d_cnjg(&z__2, &v7);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t7.r = z__1.r, t7.i = z__1.i;
v8.r = v[8].r, v8.i = v[8].i;
d_cnjg(&z__2, &v8);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t8.r = z__1.r, t8.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__8.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__9.i = v2.r *
c__[i__3].i + v2.i * c__[i__3].r;
z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i;
i__4 = j + c_dim1 * 3;
z__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__10.i = v3.r
* c__[i__4].i + v3.i * c__[i__4].r;
z__6.r = z__7.r + z__10.r, z__6.i = z__7.i + z__10.i;
i__5 = j + (c_dim1 << 2);
z__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__11.i = v4.r
* c__[i__5].i + v4.i * c__[i__5].r;
z__5.r = z__6.r + z__11.r, z__5.i = z__6.i + z__11.i;
i__6 = j + c_dim1 * 5;
z__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__12.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__4.r = z__5.r + z__12.r, z__4.i = z__5.i + z__12.i;
i__7 = j + c_dim1 * 6;
z__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__13.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__3.r = z__4.r + z__13.r, z__3.i = z__4.i + z__13.i;
i__8 = j + c_dim1 * 7;
z__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__14.i = v7.r
* c__[i__8].i + v7.i * c__[i__8].r;
z__2.r = z__3.r + z__14.r, z__2.i = z__3.i + z__14.i;
i__9 = j + (c_dim1 << 3);
z__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__15.i = v8.r
* c__[i__9].i + v8.i * c__[i__9].r;
z__1.r = z__2.r + z__15.r, z__1.i = z__2.i + z__15.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 3;
i__3 = j + c_dim1 * 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 2);
i__3 = j + (c_dim1 << 2);
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 5;
i__3 = j + c_dim1 * 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 6;
i__3 = j + c_dim1 * 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 7;
i__3 = j + c_dim1 * 7;
z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
sum.i * t7.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 3);
i__3 = j + (c_dim1 << 3);
z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
sum.i * t8.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L360: */
}
goto L410;
L370:
/* Special code for 9 x 9 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
v3.r = v[3].r, v3.i = v[3].i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
v4.r = v[4].r, v4.i = v[4].i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
v5.r = v[5].r, v5.i = v[5].i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
v6.r = v[6].r, v6.i = v[6].i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
v7.r = v[7].r, v7.i = v[7].i;
d_cnjg(&z__2, &v7);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t7.r = z__1.r, t7.i = z__1.i;
v8.r = v[8].r, v8.i = v[8].i;
d_cnjg(&z__2, &v8);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t8.r = z__1.r, t8.i = z__1.i;
v9.r = v[9].r, v9.i = v[9].i;
d_cnjg(&z__2, &v9);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t9.r = z__1.r, t9.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__9.i = v1.r *
c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__10.i = v2.r
* c__[i__3].i + v2.i * c__[i__3].r;
z__8.r = z__9.r + z__10.r, z__8.i = z__9.i + z__10.i;
i__4 = j + c_dim1 * 3;
z__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__11.i = v3.r
* c__[i__4].i + v3.i * c__[i__4].r;
z__7.r = z__8.r + z__11.r, z__7.i = z__8.i + z__11.i;
i__5 = j + (c_dim1 << 2);
z__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__12.i = v4.r
* c__[i__5].i + v4.i * c__[i__5].r;
z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i;
i__6 = j + c_dim1 * 5;
z__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__13.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__5.r = z__6.r + z__13.r, z__5.i = z__6.i + z__13.i;
i__7 = j + c_dim1 * 6;
z__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__14.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__4.r = z__5.r + z__14.r, z__4.i = z__5.i + z__14.i;
i__8 = j + c_dim1 * 7;
z__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__15.i = v7.r
* c__[i__8].i + v7.i * c__[i__8].r;
z__3.r = z__4.r + z__15.r, z__3.i = z__4.i + z__15.i;
i__9 = j + (c_dim1 << 3);
z__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__16.i = v8.r
* c__[i__9].i + v8.i * c__[i__9].r;
z__2.r = z__3.r + z__16.r, z__2.i = z__3.i + z__16.i;
i__10 = j + c_dim1 * 9;
z__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__17.i =
v9.r * c__[i__10].i + v9.i * c__[i__10].r;
z__1.r = z__2.r + z__17.r, z__1.i = z__2.i + z__17.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 3;
i__3 = j + c_dim1 * 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 2);
i__3 = j + (c_dim1 << 2);
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 5;
i__3 = j + c_dim1 * 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 6;
i__3 = j + c_dim1 * 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 7;
i__3 = j + c_dim1 * 7;
z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
sum.i * t7.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 3);
i__3 = j + (c_dim1 << 3);
z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
sum.i * t8.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 9;
i__3 = j + c_dim1 * 9;
z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i +
sum.i * t9.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L380: */
}
goto L410;
L390:
/* Special code for 10 x 10 Householder */
v1.r = v[1].r, v1.i = v[1].i;
d_cnjg(&z__2, &v1);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t1.r = z__1.r, t1.i = z__1.i;
v2.r = v[2].r, v2.i = v[2].i;
d_cnjg(&z__2, &v2);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t2.r = z__1.r, t2.i = z__1.i;
v3.r = v[3].r, v3.i = v[3].i;
d_cnjg(&z__2, &v3);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t3.r = z__1.r, t3.i = z__1.i;
v4.r = v[4].r, v4.i = v[4].i;
d_cnjg(&z__2, &v4);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t4.r = z__1.r, t4.i = z__1.i;
v5.r = v[5].r, v5.i = v[5].i;
d_cnjg(&z__2, &v5);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t5.r = z__1.r, t5.i = z__1.i;
v6.r = v[6].r, v6.i = v[6].i;
d_cnjg(&z__2, &v6);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t6.r = z__1.r, t6.i = z__1.i;
v7.r = v[7].r, v7.i = v[7].i;
d_cnjg(&z__2, &v7);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t7.r = z__1.r, t7.i = z__1.i;
v8.r = v[8].r, v8.i = v[8].i;
d_cnjg(&z__2, &v8);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t8.r = z__1.r, t8.i = z__1.i;
v9.r = v[9].r, v9.i = v[9].i;
d_cnjg(&z__2, &v9);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t9.r = z__1.r, t9.i = z__1.i;
v10.r = v[10].r, v10.i = v[10].i;
d_cnjg(&z__2, &v10);
z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ tau->i * z__2.r;
t10.r = z__1.r, t10.i = z__1.i;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + c_dim1;
z__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__10.i = v1.r
* c__[i__2].i + v1.i * c__[i__2].r;
i__3 = j + (c_dim1 << 1);
z__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__11.i = v2.r
* c__[i__3].i + v2.i * c__[i__3].r;
z__9.r = z__10.r + z__11.r, z__9.i = z__10.i + z__11.i;
i__4 = j + c_dim1 * 3;
z__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__12.i = v3.r
* c__[i__4].i + v3.i * c__[i__4].r;
z__8.r = z__9.r + z__12.r, z__8.i = z__9.i + z__12.i;
i__5 = j + (c_dim1 << 2);
z__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__13.i = v4.r
* c__[i__5].i + v4.i * c__[i__5].r;
z__7.r = z__8.r + z__13.r, z__7.i = z__8.i + z__13.i;
i__6 = j + c_dim1 * 5;
z__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__14.i = v5.r
* c__[i__6].i + v5.i * c__[i__6].r;
z__6.r = z__7.r + z__14.r, z__6.i = z__7.i + z__14.i;
i__7 = j + c_dim1 * 6;
z__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__15.i = v6.r
* c__[i__7].i + v6.i * c__[i__7].r;
z__5.r = z__6.r + z__15.r, z__5.i = z__6.i + z__15.i;
i__8 = j + c_dim1 * 7;
z__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__16.i = v7.r
* c__[i__8].i + v7.i * c__[i__8].r;
z__4.r = z__5.r + z__16.r, z__4.i = z__5.i + z__16.i;
i__9 = j + (c_dim1 << 3);
z__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__17.i = v8.r
* c__[i__9].i + v8.i * c__[i__9].r;
z__3.r = z__4.r + z__17.r, z__3.i = z__4.i + z__17.i;
i__10 = j + c_dim1 * 9;
z__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__18.i =
v9.r * c__[i__10].i + v9.i * c__[i__10].r;
z__2.r = z__3.r + z__18.r, z__2.i = z__3.i + z__18.i;
i__11 = j + c_dim1 * 10;
z__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, z__19.i =
v10.r * c__[i__11].i + v10.i * c__[i__11].r;
z__1.r = z__2.r + z__19.r, z__1.i = z__2.i + z__19.i;
sum.r = z__1.r, sum.i = z__1.i;
i__2 = j + c_dim1;
i__3 = j + c_dim1;
z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
sum.i * t1.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 1);
i__3 = j + (c_dim1 << 1);
z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
sum.i * t2.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 3;
i__3 = j + c_dim1 * 3;
z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
sum.i * t3.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 2);
i__3 = j + (c_dim1 << 2);
z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
sum.i * t4.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 5;
i__3 = j + c_dim1 * 5;
z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
sum.i * t5.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 6;
i__3 = j + c_dim1 * 6;
z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
sum.i * t6.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 7;
i__3 = j + c_dim1 * 7;
z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
sum.i * t7.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + (c_dim1 << 3);
i__3 = j + (c_dim1 << 3);
z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
sum.i * t8.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 9;
i__3 = j + c_dim1 * 9;
z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i +
sum.i * t9.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = j + c_dim1 * 10;
i__3 = j + c_dim1 * 10;
z__2.r = sum.r * t10.r - sum.i * t10.i, z__2.i = sum.r * t10.i +
sum.i * t10.r;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
/* L400: */
}
goto L410;
#endif /* BIGROUTINEHACK */
}
L410:
return 0;
/* End of ZLARFX */
} /* zlarfx_ */
/* zlacgv.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zlacgv_(n, x, incx)
integer *n;
doublecomplex *x;
integer *incx;
{
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static integer ioff, i__;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLACGV conjugates a complex vector of length N. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The length of the vector X. N >= 0. */
/* X (input/output) COMPLEX*16 array, dimension */
/* (1+(N-1)*abs(INCX)) */
/* On entry, the vector of length N to be conjugated. */
/* On exit, X is overwritten with conjg(X). */
/* INCX (input) INTEGER */
/* The spacing between successive elements of X. */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*incx == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d_cnjg(&z__1, &x[i__]);
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
/* L10: */
}
} else {
ioff = 1;
if (*incx < 0) {
ioff = 1 - (*n - 1) * *incx;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ioff;
d_cnjg(&z__1, &x[ioff]);
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
ioff += *incx;
/* L20: */
}
}
return 0;
/* End of ZLACGV */
} /* zlacgv_ */
/* zunglq.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zunglq_(m, n, k, a, lda, tau, work, lwork, info)
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, j, l, nbmin, iinfo, ib, nb;
extern /* Subroutine */ int zungl2_();
static integer ki, kk, nx;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zlarfb_();
static integer ldwork;
extern /* Subroutine */ int zlarft_();
static integer iws;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNGLQ 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 ZGELQF. */
/* 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*16 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 ZGELQF 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*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGELQF. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,M). */
/* For optimum performance LWORK >= M*NB, where NB is */
/* the optimal blocksize. */
/* 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
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;
} else if (*lwork < max(1,*m)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNGLQ", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "ZUNGLQ", " ", m, n, k, &c_n1, 6L, 1L);
nbmin = 2;
nx = 0;
iws = *m;
if (nb > 1 && nb < *k) {
/* Determine when to cross over from blocked to unblocked code.
*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGLQ", " ", m, n, k, &c_n1, 6L, 1L)
;
nx = max(i__1,i__2);
if (nx < *k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *m;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGLQ", " ", m, n, k, &c_n1,
6L, 1L);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < *k && nx < *k) {
/* Use blocked code after the last block. */
/* The first kk rows are handled by the block method. */
ki = (*k - nx - 1) / nb * nb;
/* Computing MIN */
i__1 = *k, i__2 = ki + nb;
kk = min(i__1,i__2);
/* Set A(kk+1:m,1:kk) to zero. */
i__1 = kk;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = kk + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
} else {
kk = 0;
}
/* Use unblocked code for the last or only block. */
if (kk < *m) {
i__1 = *m - kk;
i__2 = *n - kk;
i__3 = *k - kk;
zungl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
tau[kk + 1], &work[1], &iinfo);
}
if (kk > 0) {
/* Use blocked code */
i__1 = -nb;
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
/* Computing MIN */
i__2 = nb, i__3 = *k - i__ + 1;
ib = min(i__2,i__3);
if (i__ + ib <= *m) {
/* Form the triangular factor of the block reflec
tor */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__2 = *n - i__ + 1;
zlarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 7L);
/* Apply H' to A(i+ib:m,i:n) from the right */
i__2 = *m - i__ - ib + 1;
i__3 = *n - i__ + 1;
zlarfb_("Right", "Conjugate transpose", "Forward", "Rowwise",
&i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[
ib + 1], &ldwork, 5L, 19L, 7L, 7L);
}
/* Apply H' to columns i:n of current block */
i__2 = *n - i__ + 1;
zungl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo);
/* Set columns 1:i-1 of current block to zero */
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + ib - 1;
for (l = i__; l <= i__3; ++l) {
i__4 = l + j * a_dim1;
a[i__4].r = 0., a[i__4].i = 0.;
/* L30: */
}
/* L40: */
}
/* L50: */
}
}
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZUNGLQ */
} /* zunglq_ */
/* zlascl.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zlascl_(type__, kl, ku, cfrom, cto, m, n, a, lda, info,
type_len)
char *type__;
integer *kl, *ku;
doublereal *cfrom, *cto;
integer *m, *n;
doublecomplex *a;
integer *lda, *info;
ftnlen type_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Local variables */
static logical done;
static doublereal ctoc;
static integer i__, j;
extern logical lsame_();
static integer itype, k1, k2, k3, k4;
static doublereal cfrom1;
extern doublereal dlamch_();
static doublereal cfromc;
extern /* Subroutine */ int xerbla_();
static doublereal bignum, smlnum, mul, cto1;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLASCL multiplies the M by N complex matrix A by the real scalar */
/* CTO/CFROM. This is done without over/underflow as long as the final
*/
/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
*/
/* A may be full, upper triangular, lower triangular, upper Hessenberg,
*/
/* or banded. */
/* Arguments */
/* ========= */
/* TYPE (input) CHARACTER*1 */
/* TYPE indices the storage type of the input matrix. */
/* = 'G': A is a full matrix. */
/* = 'L': A is a lower triangular matrix. */
/* = 'U': A is an upper triangular matrix. */
/* = 'H': A is an upper Hessenberg matrix. */
/* = 'B': A is a symmetric band matrix with lower bandwidth KL
*/
/* and upper bandwidth KU and with the only the lower */
/* half stored. */
/* = 'Q': A is a symmetric band matrix with lower bandwidth KL
*/
/* and upper bandwidth KU and with the only the upper */
/* half stored. */
/* = 'Z': A is a band matrix with lower bandwidth KL and upper
*/
/* bandwidth KU. */
/* KL (input) INTEGER */
/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
/* 'Q' or 'Z'. */
/* KU (input) INTEGER */
/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
/* 'Q' or 'Z'. */
/* CFROM (input) DOUBLE PRECISION */
/* CTO (input) DOUBLE PRECISION */
/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
/* without over/underflow if the final result CTO*A(I,J)/CFROM */
/* can be represented without over/underflow. CFROM must be */
/* nonzero. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,M) */
/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
/* storage type. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* INFO (output) INTEGER */
/* 0 - successful exit */
/* <0 - if INFO = -i, the i-th argument had an illegal value. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
*info = 0;
if (lsame_(type__, "G", 1L, 1L)) {
itype = 0;
} else if (lsame_(type__, "L", 1L, 1L)) {
itype = 1;
} else if (lsame_(type__, "U", 1L, 1L)) {
itype = 2;
} else if (lsame_(type__, "H", 1L, 1L)) {
itype = 3;
} else if (lsame_(type__, "B", 1L, 1L)) {
itype = 4;
} else if (lsame_(type__, "Q", 1L, 1L)) {
itype = 5;
} else if (lsame_(type__, "Z", 1L, 1L)) {
itype = 6;
} else {
itype = -1;
}
if (itype == -1) {
*info = -1;
} else if (*cfrom == 0.) {
*info = -4;
} else if (*m < 0) {
*info = -6;
} else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
*info = -7;
} else if (itype <= 3 && *lda < max(1,*m)) {
*info = -9;
} else if (itype >= 4) {
/* Computing MAX */
i__1 = *m - 1;
if (*kl < 0 || *kl > max(i__1,0)) {
*info = -2;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = *n - 1;
if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
*kl != *ku) {
*info = -3;
} else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
*info = -9;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLASCL", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S", 1L);
bignum = 1. / smlnum;
cfromc = *cfrom;
ctoc = *cto;
L10:
cfrom1 = cfromc * smlnum;
cto1 = ctoc / bignum;
if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
mul = smlnum;
done = FALSE_;
cfromc = cfrom1;
} else if (abs(cto1) > abs(cfromc)) {
mul = bignum;
done = FALSE_;
ctoc = cto1;
} else {
mul = ctoc / cfromc;
done = TRUE_;
}
if (itype == 0) {
/* Full matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L20: */
}
/* L30: */
}
} else if (itype == 1) {
/* Lower triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L40: */
}
/* L50: */
}
} else if (itype == 2) {
/* Upper triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L60: */
}
/* L70: */
}
} else if (itype == 3) {
/* Upper Hessenberg matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j + 1;
i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L80: */
}
/* L90: */
}
} else if (itype == 4) {
/* Lower half of a symmetric band matrix */
k3 = *kl + 1;
k4 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = k3, i__4 = k4 - j;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L100: */
}
/* L110: */
}
} else if (itype == 5) {
/* Upper half of a symmetric band matrix */
k1 = *ku + 2;
k3 = *ku + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = k1 - j;
i__3 = k3;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
i__2 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L120: */
}
/* L130: */
}
} else if (itype == 6) {
/* Band matrix */
k1 = *kl + *ku + 2;
k2 = *kl + 1;
k3 = (*kl << 1) + *ku + 1;
k4 = *kl + *ku + 1 + *m;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = k1 - j;
/* Computing MIN */
i__4 = k3, i__5 = k4 - j;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L140: */
}
/* L150: */
}
}
if (! done) {
goto L10;
}
return 0;
/* End of ZLASCL */
} /* zlascl_ */
/* zungqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zungqr_(m, n, k, a, lda, tau, work, lwork, info)
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, j, l, nbmin, iinfo, ib, nb, ki, kk;
extern /* Subroutine */ int zung2r_();
static integer nx;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zlarfb_();
static integer ldwork;
extern /* Subroutine */ int zlarft_();
static integer iws;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNGQR 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 ZGEQRF. */
/* 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*16 array, dimension (LDA,N) */
/* On entry, the i-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as
*/
/* returned by ZGEQRF 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*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGEQRF. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
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;
} else if (*lwork < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNGQR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "ZUNGQR", " ", m, n, k, &c_n1, 6L, 1L);
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < *k) {
/* Determine when to cross over from blocked to unblocked code.
*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGQR", " ", m, n, k, &c_n1, 6L, 1L)
;
nx = max(i__1,i__2);
if (nx < *k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGQR", " ", m, n, k, &c_n1,
6L, 1L);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < *k && nx < *k) {
/* Use blocked code after the last block. */
/* The first kk columns are handled by the block method. */
ki = (*k - nx - 1) / nb * nb;
/* Computing MIN */
i__1 = *k, i__2 = ki + nb;
kk = min(i__1,i__2);
/* Set A(1:kk,kk+1:n) to zero. */
i__1 = *n;
for (j = kk + 1; j <= i__1; ++j) {
i__2 = kk;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
} else {
kk = 0;
}
/* Use unblocked code for the last or only block. */
if (kk < *n) {
i__1 = *m - kk;
i__2 = *n - kk;
i__3 = *k - kk;
zung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
tau[kk + 1], &work[1], &iinfo);
}
if (kk > 0) {
/* Use blocked code */
i__1 = -nb;
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
/* Computing MIN */
i__2 = nb, i__3 = *k - i__ + 1;
ib = min(i__2,i__3);
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflec
tor */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__2 = *m - i__ + 1;
zlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 10L);
/* Apply H to A(i:m,i+ib:n) from the left */
i__2 = *m - i__ + 1;
i__3 = *n - i__ - ib + 1;
zlarfb_("Left", "No transpose", "Forward", "Columnwise", &
i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
work[ib + 1], &ldwork, 4L, 12L, 7L, 10L);
}
/* Apply H to rows i:m of current block */
i__2 = *m - i__ + 1;
zung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo);
/* Set rows 1:i-1 of current block to zero */
i__2 = i__ + ib - 1;
for (j = i__; j <= i__2; ++j) {
i__3 = i__ - 1;
for (l = 1; l <= i__3; ++l) {
i__4 = l + j * a_dim1;
a[i__4].r = 0., a[i__4].i = 0.;
/* L30: */
}
/* L40: */
}
/* L50: */
}
}
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZUNGQR */
} /* zungqr_ */
/* zlarfb.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1a
/* Subroutine */ int zlarfb_(side, trans, direct, storev, m, n, k, v, ldv, t,
ldt, c__, ldc, work, ldwork, side_len, trans_len, direct_len,
storev_len)
char *side, *trans, *direct, *storev;
integer *m, *n, *k;
doublecomplex *v;
integer *ldv;
doublecomplex *t;
integer *ldt;
doublecomplex *c__;
integer *ldc;
doublecomplex *work;
integer *ldwork;
ftnlen side_len;
ftnlen trans_len;
ftnlen direct_len;
ftnlen storev_len;
{
/* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static integer i__, j;
extern logical lsame_();
extern /* Subroutine */ int zgemm_(), zcopy_(), ztrmm_(), zlacgv_();
static char transt[1];
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARFB applies a complex block reflector H or its transpose H' to a */
/* complex M-by-N matrix C, from either the left or the right. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply H or H' from the Left */
/* = 'R': apply H or H' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply H (No transpose) */
/* = 'C': apply H' (Conjugate transpose) */
/* DIRECT (input) CHARACTER*1 */
/* Indicates how H is formed from a product of elementary */
/* reflectors */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Indicates how the vectors which define the elementary */
/* reflectors are stored: */
/* = 'C': Columnwise */
/* = 'R': Rowwise */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* K (input) INTEGER */
/* The order of the matrix T (= the number of elementary */
/* reflectors whose product defines the block reflector). */
/* V (input) COMPLEX*16 array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,M) if STOREV = 'R' and SIDE = 'L'
*/
/* (LDV,N) if STOREV = 'R' and SIDE = 'R'
*/
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
/* if STOREV = 'R', LDV >= K. */
/* T (input) COMPLEX*16 array, dimension (LDT,K) */
/* The triangular K-by-K matrix T in the representation of the */
/* block reflector. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. */
/* If SIDE = 'L', LDWORK >= max(1,N); */
/* if SIDE = 'R', LDWORK >= max(1,M). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = v_dim1 + 1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = t_dim1 + 1;
t -= t_offset;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
work_dim1 = *ldwork;
work_offset = work_dim1 + 1;
work -= work_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (lsame_(trans, "N", 1L, 1L)) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(storev, "C", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
/* Let V = ( V1 ) (first K rows) */
/* ( V2 ) */
/* where V1 is unit lower triangular. */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in
WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
&c__1);
zlacgv_(n, &work[j * work_dim1 + 1], &c__1);
/* L10: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L,
12L, 4L);
if (*m > *k) {
/* W := W + C2'*V2 */
i__1 = *m - *k;
zgemm_("Conjugate transpose", "No transpose", n, k, &i__1,
&c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 +
v_dim1], ldv, &c_b1, &work[work_offset], ldwork,
19L, 12L);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - V * W' */
if (*m > *k) {
/* C2 := C2 - V2 * W' */
i__1 = *m - *k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, n, k,
&z__1, &v[*k + 1 + v_dim1], ldv, &work[
work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1]
, ldc, 12L, 19L);
}
/* W := W * V1' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork,
5L, 5L, 19L, 4L);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * c_dim1;
i__4 = j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L20: */
}
/* L30: */
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form C * H or C * H' where C = ( C1 C2 )
*/
/* W := C * V = (C1*V1 + C2*V2) (stored in WOR
K) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L40: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L,
12L, 4L);
if (*n > *k) {
/* W := W + C2 * V2 */
i__1 = *n - *k;
zgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1,
&c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 +
v_dim1], ldv, &c_b1, &work[work_offset], ldwork,
12L, 12L);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - W * V' */
if (*n > *k) {
/* C2 := C2 - W * V2' */
i__1 = *n - *k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", m, &i__1, k,
&z__1, &work[work_offset], ldwork, &v[*k + 1 +
v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1],
ldc, 12L, 19L);
}
/* W := W * V1' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork,
5L, 5L, 19L, 4L);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L50: */
}
/* L60: */
}
}
} else {
/* Let V = ( V1 ) */
/* ( V2 ) (last K rows) */
/* where V2 is unit upper triangular. */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in
WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
work_dim1 + 1], &c__1);
zlacgv_(n, &work[j * work_dim1 + 1], &c__1);
/* L70: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1,
&v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, 5L, 5L, 12L, 4L);
if (*m > *k) {
/* W := W + C1'*V1 */
i__1 = *m - *k;
zgemm_("Conjugate transpose", "No transpose", n, k, &i__1,
&c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork, 19L, 12L);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - V * W' */
if (*m > *k) {
/* C1 := C1 - V1 * W' */
i__1 = *m - *k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, n, k,
&z__1, &v[v_offset], ldv, &work[work_offset],
ldwork, &c_b1, &c__[c_offset], ldc, 12L, 19L);
}
/* W := W * V2' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k,
&c_b1, &v[*m - *k + 1 + v_dim1], ldv, &work[
work_offset], ldwork, 5L, 5L, 19L, 4L);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = *m - *k + j + i__ * c_dim1;
i__4 = *m - *k + j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L80: */
}
/* L90: */
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form C * H or C * H' where C = ( C1 C2 )
*/
/* W := C * V = (C1*V1 + C2*V2) (stored in WOR
K) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
j * work_dim1 + 1], &c__1);
/* L100: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1,
&v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, 5L, 5L, 12L, 4L);
if (*n > *k) {
/* W := W + C1 * V1 */
i__1 = *n - *k;
zgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1,
&c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &
work[work_offset], ldwork, 12L, 12L);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - W * V' */
if (*n > *k) {
/* C1 := C1 - W * V1' */
i__1 = *n - *k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", m, &i__1, k,
&z__1, &work[work_offset], ldwork, &v[v_offset],
ldv, &c_b1, &c__[c_offset], ldc, 12L, 19L);
}
/* W := W * V2' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k,
&c_b1, &v[*n - *k + 1 + v_dim1], ldv, &work[
work_offset], ldwork, 5L, 5L, 19L, 4L);
/* C2 := C2 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (*n - *k + j) * c_dim1;
i__4 = i__ + (*n - *k + j) * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L110: */
}
/* L120: */
}
}
}
} else if (lsame_(storev, "R", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
/* Let V = ( V1 V2 ) (V1: first K columns) */
/* where V1 is unit upper triangular. */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored i
n WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
&c__1);
zlacgv_(n, &work[j * work_dim1 + 1], &c__1);
/* L130: */
}
/* W := W * V1' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork,
5L, 5L, 19L, 4L);
if (*m > *k) {
/* W := W + C2'*V2' */
i__1 = *m - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", n, k,
&i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[(*k
+ 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset]
, ldwork, 19L, 19L);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - V' * W' */
if (*m > *k) {
/* C2 := C2 - V2' * W' */
i__1 = *m - *k;
z__1.r = -1., z__1.i = 0.;
zgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, n, k, &z__1, &v[(*k + 1) * v_dim1 + 1], ldv,
&work[work_offset], ldwork, &c_b1, &c__[*k + 1 +
c_dim1], ldc, 19L, 19L);
}
/* W := W * V1 */
ztrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L,
12L, 4L);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * c_dim1;
i__4 = j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L140: */
}
/* L150: */
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form C * H or C * H' where C = ( C1 C2 )
*/
/* W := C * V' = (C1*V1' + C2*V2') (stored in
WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L160: */
}
/* W := W * V1' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork,
5L, 5L, 19L, 4L);
if (*n > *k) {
/* W := W + C2 * V2' */
i__1 = *n - *k;
zgemm_("No transpose", "Conjugate transpose", m, k, &i__1,
&c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k
+ 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset]
, ldwork, 12L, 19L);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - W * V */
if (*n > *k) {
/* C2 := C2 - W * V2 */
i__1 = *n - *k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "No transpose", m, &i__1, k, &z__1,
&work[work_offset], ldwork, &v[(*k + 1) * v_dim1
+ 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1],
ldc, 12L, 12L);
}
/* W := W * V1 */
ztrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L,
12L, 4L);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L170: */
}
/* L180: */
}
}
} else {
/* Let V = ( V1 V2 ) (V2: last K columns) */
/* where V2 is unit lower triangular. */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored i
n WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
work_dim1 + 1], &c__1);
zlacgv_(n, &work[j * work_dim1 + 1], &c__1);
/* L190: */
}
/* W := W * V2' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k,
&c_b1, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork, 5L, 5L, 19L, 4L);
if (*m > *k) {
/* W := W + C1'*V1' */
i__1 = *m - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", n, k,
&i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork, 19L, 19L);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - V' * W' */
if (*m > *k) {
/* C1 := C1 - V1' * W' */
i__1 = *m - *k;
z__1.r = -1., z__1.i = 0.;
zgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, n, k, &z__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc,
19L, 19L);
}
/* W := W * V2 */
ztrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1,
&v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork, 5L, 5L, 12L, 4L);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = *m - *k + j + i__ * c_dim1;
i__4 = *m - *k + j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L200: */
}
/* L210: */
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form C * H or C * H' where C = ( C1 C2 )
*/
/* W := C * V' = (C1*V1' + C2*V2') (stored in
WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
j * work_dim1 + 1], &c__1);
/* L220: */
}
/* W := W * V2' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k,
&c_b1, &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork, 5L, 5L, 19L, 4L);
if (*n > *k) {
/* W := W + C1 * V1' */
i__1 = *n - *k;
zgemm_("No transpose", "Conjugate transpose", m, k, &i__1,
&c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork, 12L, 19L);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - W * V */
if (*n > *k) {
/* C1 := C1 - W * V1 */
i__1 = *n - *k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "No transpose", m, &i__1, k, &z__1,
&work[work_offset], ldwork, &v[v_offset], ldv, &
c_b1, &c__[c_offset], ldc, 12L, 12L);
}
/* W := W * V2 */
ztrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1,
&v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork, 5L, 5L, 12L, 4L);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (*n - *k + j) * c_dim1;
i__4 = i__ + (*n - *k + j) * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
}
}
return 0;
/* End of ZLARFB */
} /* zlarfb_ */
/* zungl2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zungl2_(m, n, k, a, lda, tau, work, info)
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static integer i__, j, l;
extern /* Subroutine */ int zscal_(), zlarf_(), xerbla_(), zlacgv_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNGL2 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 ZGELQF. */
/* 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*16 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 ZGELQF 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*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGELQF. */
/* WORK (workspace) COMPLEX*16 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 = a_dim1 + 1;
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_("ZUNGL2", &i__1, 6L);
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., a[i__3].i = 0.;
/* L10: */
}
if (j > *k && j <= *m) {
i__2 = j + j * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
}
/* 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__;
zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
if (i__ < *m) {
i__1 = i__ + i__ * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = *m - i__;
i__2 = *n - i__ + 1;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
z__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], 5L);
}
i__1 = *n - i__;
i__2 = i__;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zscal_(&i__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda);
i__1 = *n - i__;
zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
}
i__1 = i__ + i__ * a_dim1;
d_cnjg(&z__2, &tau[i__]);
z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Set A(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., a[i__2].i = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of ZUNGL2 */
} /* zungl2_ */
/* zlassq.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zlassq_(n, x, incx, scale, sumsq)
integer *n;
doublecomplex *x;
integer *incx;
doublereal *scale, *sumsq;
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double d_imag();
/* Local variables */
static doublereal temp1;
static integer ix;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLASSQ returns the values scl and ssq such that */
/* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */
/* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
*/
/* assumed to be at least unity and the value of ssq will then satisfy */
/* 1.0 .le. ssq .le. ( sumsq + 2*n ). */
/* scale is assumed to be non-negative and scl returns the value */
/* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
*/
/* i */
/* scale and sumsq must be supplied in SCALE and SUMSQ respectively. */
/* SCALE and SUMSQ are overwritten by scl and ssq respectively. */
/* The routine makes only one pass through the vector X. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of elements to be used from the vector X. */
/* X (input) DOUBLE PRECISION */
/* The vector x as described above. */
/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
/* INCX (input) INTEGER */
/* The increment between successive values of the vector X. */
/* INCX > 0. */
/* SCALE (input/output) DOUBLE PRECISION */
/* On entry, the value scale in the equation above. */
/* On exit, SCALE is overwritten with the value scl . */
/* SUMSQ (input/output) DOUBLE PRECISION */
/* On entry, the value sumsq in the equation above. */
/* On exit, SUMSQ is overwritten with the value ssq . */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n > 0) {
i__1 = (*n - 1) * *incx + 1;
i__2 = *incx;
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
i__3 = ix;
if (x[i__3].r != 0.) {
i__3 = ix;
temp1 = (d__1 = x[i__3].r, abs(d__1));
if (*scale < temp1) {
/* Computing 2nd power */
d__1 = *scale / temp1;
*sumsq = *sumsq * (d__1 * d__1) + 1;
*scale = temp1;
} else {
/* Computing 2nd power */
d__1 = temp1 / *scale;
*sumsq += d__1 * d__1;
}
}
if (d_imag(&x[ix]) != 0.) {
temp1 = (d__1 = d_imag(&x[ix]), abs(d__1));
if (*scale < temp1) {
/* Computing 2nd power */
d__1 = *scale / temp1;
*sumsq = *sumsq * (d__1 * d__1) + 1;
*scale = temp1;
} else {
/* Computing 2nd power */
d__1 = temp1 / *scale;
*sumsq += d__1 * d__1;
}
}
/* L10: */
}
}
return 0;
/* End of ZLASSQ */
} /* zlassq_ */
/* zhseqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2
/* Subroutine */ int zhseqr_(job, compz, n, ilo, ihi, h__, ldh, w, z__, ldz,
work, lwork, info, job_len, compz_len)
char *job, *compz;
integer *n, *ilo, *ihi;
doublecomplex *h__;
integer *ldh;
doublecomplex *w, *z__;
integer *ldz;
doublecomplex *work;
integer *lwork, *info;
ftnlen job_len;
ftnlen compz_len;
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4[2],
i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
char ch__1[2];
/* Builtin functions */
double d_imag();
void d_cnjg();
/* Subroutine */ int s_cat();
/* Local variables */
static integer maxb, ierr;
static doublereal unfl;
static doublecomplex temp;
static doublereal ovfl;
static integer i__, j, k, l;
static doublecomplex s[225] /* was [15][15] */, v[16];
extern logical lsame_();
extern /* Subroutine */ int zscal_();
static integer itemp;
static doublereal rtemp;
static integer i1, i2;
extern /* Subroutine */ int zgemv_();
static logical initz, wantt, wantz;
static doublereal rwork[1];
extern /* Subroutine */ int zcopy_();
extern doublereal dlapy2_();
extern /* Subroutine */ int dlabad_();
static integer ii, nh;
extern doublereal dlamch_();
static integer nr, ns, nv;
static doublecomplex vv[16];
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zdscal_(), zlarfg_();
extern integer izamax_();
extern doublereal zlanhs_();
extern /* Subroutine */ int zlahqr_(), zlacpy_(), zlaset_(), zlarfx_();
static doublereal smlnum;
static integer itn;
static doublecomplex tau;
static integer its;
static doublereal ulp, tst1;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHSEQR computes the eigenvalues of a complex upper Hessenberg */
/* matrix H, and, optionally, the matrices T and Z from the Schur */
/* decomposition H = Z T Z**H, where T is an upper triangular matrix */
/* (the Schur form), and Z is the unitary matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input unitary matrix Q, */
/* so that this routine can give the Schur factorization of a matrix A */
/* which has been reduced to the Hessenberg form H by the unitary */
/* matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': compute eigenvalues only; */
/* = 'S': compute eigenvalues and the Schur form T. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': no Schur vectors are computed; */
/* = 'I': Z is initialized to the unit matrix and the matrix Z */
/* of Schur vectors of H is returned; */
/* = 'V': Z must contain an unitary matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL, and then passed to CGEHRD */
/* when the matrix output by ZGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper triangular matrix
*/
/* T from the Schur decomposition (the Schur form). If */
/* JOB = 'E', the contents of H are unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* W (output) COMPLEX*16 array, dimension (N) */
/* The computed eigenvalues. If JOB = 'S', the eigenvalues are */
/* stored in the same order as on the diagonal of the Schur form
*/
/* returned in H, with W(i) = H(i,i). */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* If COMPZ = 'N': Z is not referenced. */
/* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z */
/* contains the unitary matrix Z of the Schur vectors of H. */
/* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, */
/* which is assumed to be equal to the unit matrix except for */
/* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. */
/* Normally Q is the unitary matrix generated by ZUNGHR after */
/* the call to ZGEHRD which formed the Hessenberg matrix H. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. */
/* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* LWORK (input) INTEGER */
/* This argument is currently redundant. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, ZHSEQR failed to compute all the */
/* eigenvalues in a total of 30*(IHI-ILO+1) iterations; */
/* elements 1:ilo-1 and i+1:n of W contain those */
/* eigenvalues which have been successfully computed. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = h_dim1 + 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = z_dim1 + 1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S", 1L, 1L);
initz = lsame_(compz, "I", 1L, 1L);
wantz = initz || lsame_(compz, "V", 1L, 1L);
*info = 0;
if (! lsame_(job, "E", 1L, 1L) && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N", 1L, 1L) && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHSEQR", &i__1, 6L);
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz, 4L);
}
/* Store the eigenvalues isolated by ZGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ + i__ * h_dim1;
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ + i__ * h_dim1;
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = *ilo + *ilo * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first */
/* subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * h_dim1;
h__[i__3].r = 0., h__[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are
*/
/* being computed, I1 and I2 are re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
} else {
i1 = *ilo;
i2 = *ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
i__2 = i__ + (i__ - 1) * h_dim1;
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = i__ + (i__ - 1) * h_dim1;
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h__[i1 + i__ * h_dim1], &c__1);
if (i__ < *ihi) {
i__2 = i__ + 1 + i__ * h_dim1;
i__3 = i__ + 1 + i__ * h_dim1;
z__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, z__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
}
if (wantz) {
zscal_(&nh, &temp, &z__[*ilo + i__ * z_dim1], &c__1);
}
}
/* L50: */
}
/* Determine the order of the multi-shift QR algorithm to be used. */
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, 2L);
ns = ilaenv_(&c__4, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, 2L);
maxb = ilaenv_(&c__8, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
zlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(2,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 1 < NS <= MAXB < NH. */
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum", 12L);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision", 9L);
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
*/
/* IHI to ILO in steps of at most MAXB. Each iteration of the loop */
/* works with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
*/
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L60:
if (i__ < *ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
*/
/* until a submatrix of order at most MAXB splits off at the bottom */
/* because a subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = k - 1 + (k - 1) * h_dim1;
i__5 = k + k * h_dim1;
tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[k -
1 + (k - 1) * h_dim1]), abs(d__2)) + ((d__3 = h__[i__5].r,
abs(d__3)) + (d__4 = d_imag(&h__[k + k * h_dim1]), abs(
d__4)));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = zlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, rwork,
1L);
}
i__3 = k + (k - 1) * h_dim1;
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = l + (l - 1) * h_dim1;
h__[i__2].r = 0., h__[i__2].i = 0.;
}
/* Exit from loop if a submatrix of order <= MAXB has split off
. */
if (l >= i__ - maxb + 1) {
goto L170;
}
/* Now the active submatrix is in rows and columns L to I. If
*/
/* eigenvalues only are being computed, only the active submatr
ix */
/* need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
i__3 = ii;
i__5 = ii + (ii - 1) * h_dim1;
i__6 = ii + ii * h_dim1;
d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = h__[i__6].r,
abs(d__2))) * 1.5;
w[i__3].r = d__3, w[i__3].i = 0.;
/* L90: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as
shifts. */
zlacpy_("Full", &ns, &ns, &h__[i__ - ns + 1 + (i__ - ns + 1) *
h_dim1], ldh, s, &c__15, 4L);
zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &w[i__ -
ns + 1], &c__1, &ns, &z__[z_offset], ldz, &ierr);
if (ierr > 0) {
/* If ZLAHQR failed to compute all NS eigenvalues
, use the */
/* unconverged diagonal elements as the remaining
shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = i__ - ns + ii;
i__5 = ii + ii * 15 - 16;
w[i__3].r = s[i__5].r, w[i__3].i = s[i__5].i;
/* L100: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
*/
/* where G is the Hessenberg submatrix H(L:I,L:I) and w is */
/* the vector of shifts (stored in W). The result is */
/* stored in the local array V. */
v[0].r = 1., v[0].i = 0.;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0., v[i__3].i = 0.;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
zcopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
z__1.r = -w[i__5].r, z__1.i = -w[i__5].i;
zgemv_("No transpose", &i__3, &nv, &c_b2, &h__[l + l * h_dim1],
ldh, vv, &c__1, &z__1, v, &c__1, 12L);
++nv;
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zer
o, */
/* reset it to the unit vector. */
itemp = izamax_(&nv, v, &c__1);
i__3 = itemp - 1;
rtemp = (d__1 = v[i__3].r, abs(d__1)) + (d__2 = d_imag(&v[itemp -
1]), abs(d__2));
if (rtemp == 0.) {
v[0].r = 1., v[0].i = 0.;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0., v[i__5].i = 0.;
/* L120: */
}
} else {
rtemp = max(rtemp,smlnum);
d__1 = 1. / rtemp;
zdscal_(&nv, &d__1, v, &c__1);
}
/* L130: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflect
ion G */
/* from the vector V and applies it from left and right
to H, */
/* thus creating a nonzero bulge below the subdiagonal.
*/
/* Each subsequent iteration determines a reflection G t
o */
/* restore the Hessenberg form in the (K-1)th column, an
d thus */
/* chases the bulge one step toward the bottom of the ac
tive */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__3 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__3,i__5);
if (k > l) {
zcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
zlarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
i__3 = k + (k - 1) * h_dim1;
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = i__;
for (ii = k + 1; ii <= i__3; ++ii) {
i__5 = ii + (k - 1) * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
/* L140: */
}
}
v[0].r = 1., v[0].i = 0.;
/* Apply G' from the left to transform the rows of the m
atrix */
/* in columns K to I2. */
i__3 = i2 - k + 1;
d_cnjg(&z__1, &tau);
zlarfx_("Left", &nr, &i__3, v, &z__1, &h__[k + k * h_dim1], ldh, &
work[1], 4L);
/* Apply G from the right to transform the columns of th
e */
/* matrix in rows I1 to min(K+NR,I). */
/* Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i__) - i1 + 1;
zlarfx_("Right", &i__3, &nr, v, &tau, &h__[i1 + k * h_dim1], ldh,
&work[1], 5L);
if (wantz) {
/* Accumulate transformations in the matrix Z */
zlarfx_("Right", &nh, &nr, v, &tau, &z__[*ilo + k * z_dim1],
ldz, &work[1], 5L);
}
/* L150: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = i__ + (i__ - 1) * h_dim1;
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = i__ + (i__ - 1) * h_dim1;
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h__[i1 + i__ * h_dim1], &c__1);
if (wantz) {
zscal_(&nh, &temp, &z__[*ilo + i__ * z_dim1], &c__1);
}
}
/* L160: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L170:
/* A submatrix of order <= MAXB in rows and columns L to I has split
*/
/* off. Use the double-shift QR algorithm to handle it. */
zlahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &w[1], ilo, ihi,
&z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L60;
L180:
return 0;
/* End of ZHSEQR */
} /* zhseqr_ */
/* zunm2r.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zunm2r_(side, trans, m, n, k, a, lda, tau, c__, ldc,
work, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *c__;
integer *ldc;
doublecomplex *work;
integer *info;
ftnlen side_len;
ftnlen trans_len;
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static logical left;
static doublecomplex taui;
static integer i__;
extern logical lsame_();
extern /* Subroutine */ int zlarf_();
static integer i1, i2, i3, ic, jc, mi, ni, nq;
extern /* Subroutine */ int xerbla_();
static logical notran;
static doublecomplex aii;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNM2R 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(1) H(2) . . . H(k) */
/* as returned by ZGEQRF. 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*16 array, dimension (LDA,K) */
/* The i-th column must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by
*/
/* ZGEQRF in the first k columns 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. */
/* If SIDE = 'L', LDA >= max(1,M); */
/* if SIDE = 'R', LDA >= max(1,N). */
/* TAU (input) COMPLEX*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGEQRF. */
/* C (input/output) COMPLEX*16 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*16 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 */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C", 1L, 1L)) {
*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,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNM2R", &i__1, 6L);
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) {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
} else {
d_cnjg(&z__1, &tau[i__]);
taui.r = z__1.r, taui.i = z__1.i;
}
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., a[i__3].i = 0.;
zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic
+ jc * c_dim1], ldc, &work[1], 1L);
i__3 = i__ + i__ * a_dim1;
a[i__3].r = aii.r, a[i__3].i = aii.i;
/* L10: */
}
return 0;
/* End of ZUNM2R */
} /* zunm2r_ */
/* zgesv.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zgesv_(n, nrhs, a, lda, ipiv, b, ldb, info)
integer *n, *nrhs;
doublecomplex *a;
integer *lda, *ipiv;
doublecomplex *b;
integer *ldb, *info;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int xerbla_(), zgetrf_(), zgetrs_();
/* -- LAPACK driver routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGESV computes the solution to a complex system of linear equations */
/* A * X = B, */
/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
/* The LU decomposition with partial pivoting and row interchanges is */
/* used to factor A as */
/* A = P * L * U, */
/* where P is a permutation matrix, L is unit lower triangular, and U is
*/
/* upper triangular. The factored form of A is then used to solve the */
/* system of equations A * X = B. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the N-by-N coefficient matrix A. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension (N) */
/* The pivot indices that define the permutation matrix P; */
/* row i of the matrix was interchanged with row IPIV(i). */
/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS matrix of right hand side matrix B. */
/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*/
/* has been completed, but the factor U is exactly */
/* singular, so the solution could not be computed. */
/* =====================================================================
*/
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGESV ", &i__1, 6L);
return 0;
}
/* Compute the LU factorization of A. */
zgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
zgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
b_offset], ldb, info, 12L);
}
return 0;
/* End of ZGESV */
} /* zgesv_ */
/* zungbr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zungbr_(vect, m, n, k, a, lda, tau, work, lwork, info,
vect_len)
char *vect;
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *lwork, *info;
ftnlen vect_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j;
extern logical lsame_();
static integer iinfo;
static logical wantq;
extern /* Subroutine */ int xerbla_(), zunglq_(), zungqr_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNGBR generates one of the complex unitary matrices Q or P**H */
/* determined by ZGEBRD when reducing a complex matrix A to bidiagonal */
/* form: A = Q * B * P**H. Q and P**H are defined as products of */
/* elementary reflectors H(i) or G(i) respectively. */
/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
/* is of order M: */
/* if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n */
/* columns of Q, where m >= n >= k; */
/* if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an */
/* M-by-M matrix. */
/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H */
/* is of order N: */
/* if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m
*/
/* rows of P**H, where n >= m >= k; */
/* if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as */
/* an N-by-N matrix. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* Specifies whether the matrix Q or the matrix P**H is */
/* required, as defined in the transformation applied by ZGEBRD:
*/
/* = 'Q': generate Q; */
/* = 'P': generate P**H. */
/* M (input) INTEGER */
/* The number of rows of the matrix Q or P**H to be returned. */
/* M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q or P**H to be returned.
*/
/* N >= 0. */
/* If VECT = 'Q', M >= N >= min(M,K); */
/* if VECT = 'P', N >= M >= min(N,K). */
/* K (input) INTEGER */
/* If VECT = 'Q', the number of columns in the original M-by-K */
/* matrix reduced by ZGEBRD. */
/* If VECT = 'P', the number of rows in the original K-by-N */
/* matrix reduced by ZGEBRD. */
/* K >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the vectors which define the elementary reflectors,
*/
/* as returned by ZGEBRD. */
/* On exit, the M-by-N matrix Q or P**H. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= M. */
/* TAU (input) COMPLEX*16 array, dimension */
/* (min(M,K)) if VECT = 'Q' */
/* (min(N,K)) if VECT = 'P' */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i) or G(i), which determines Q or P**H, as */
/* returned by ZGEBRD in its array argument TAUQ or TAUP. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
/* For optimum performance LWORK >= min(M,N)*NB, where NB */
/* is the optimal blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
wantq = lsame_(vect, "Q", 1L, 1L);
if (! wantq && ! lsame_(vect, "P", 1L, 1L)) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
*m > *n || *m < min(*n,*k))) {
*info = -3;
} else if (*k < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = min(*m,*n);
if (*lwork < max(i__1,i__2)) {
*info = -9;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNGBR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
if (wantq) {
/* Form Q, determined by a call to ZGEBRD to reduce an m-by-k
*/
/* matrix */
if (*m >= *k) {
/* If m >= k, assume m >= n >= k */
zungqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
} else {
/* If m < k, assume m = n */
/* Shift the vectors which define the elementary reflect
ors one */
/* column to the right, and set the first row and column
of Q */
/* to those of the unit matrix */
for (j = *m; j >= 2; --j) {
i__1 = j * a_dim1 + 1;
a[i__1].r = 0., a[i__1].i = 0.;
i__1 = *m;
for (i__ = j + 1; i__ <= i__1; ++i__) {
i__2 = i__ + j * a_dim1;
i__3 = i__ + (j - 1) * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
/* L10: */
}
/* L20: */
}
i__1 = a_dim1 + 1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = *m;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ + a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L30: */
}
if (*m > 1) {
/* Form Q(2:m,2:m) */
i__1 = *m - 1;
i__2 = *m - 1;
i__3 = *m - 1;
zungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
}
}
} else {
/* Form P', determined by a call to ZGEBRD to reduce a k-by-n
*/
/* matrix */
if (*k < *n) {
/* If k < n, assume k <= m <= n */
zunglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
} else {
/* If k >= n, assume m = n */
/* Shift the vectors which define the elementary reflect
ors one */
/* row downward, and set the first row and column of P'
to */
/* those of the unit matrix */
i__1 = a_dim1 + 1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ + a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L40: */
}
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
for (i__ = j - 1; i__ >= 2; --i__) {
i__2 = i__ + j * a_dim1;
i__3 = i__ - 1 + j * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
/* L50: */
}
i__2 = j * a_dim1 + 1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L60: */
}
if (*n > 1) {
/* Form P'(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
zunglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
}
}
}
return 0;
/* End of ZUNGBR */
} /* zungbr_ */
/* zgelq2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zgelq2_(m, n, a, lda, tau, work, info)
integer *m, *n;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, k;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(), xerbla_(), zlarfg_(), zlacgv_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGELQ2 computes an LQ factorization of a complex m by n matrix A: */
/* A = L * Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, the elements on and below the diagonal of the array
*/
/* contain the m by min(m,n) lower trapezoidal matrix L (L is */
/* lower triangular if m <= n); the elements above the diagonal,
*/
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */
/* A(i,i+1:n), and tau in TAU(i). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 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_("ZGELQ2", &i__1, 6L);
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;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, &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., a[i__2].i = 0.;
i__2 = *m - i__;
i__3 = *n - i__ + 1;
zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], 5L);
}
i__2 = i__ + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
/* L10: */
}
return 0;
/* End of ZGELQ2 */
} /* zgelq2_ */
/* zgehrd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2
/* Subroutine */ int zgehrd_(n, ilo, ihi, a, lda, tau, work, lwork, info)
integer *n, *ilo, *ihi;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
static integer i__;
static doublecomplex t[4160] /* was [65][64] */;
static integer nbmin, iinfo;
extern /* Subroutine */ int zgemm_(), zgehd2_();
static integer ib;
static doublecomplex ei;
static integer nb, nh, nx;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zlarfb_(), zlahrd_();
static integer ldwork, iws;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H
*/
/* by a unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the N-by-N general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, and the */
/* elements below the first subdiagonal, with the array TAU, */
/* represent the unitary matrix Q as a product of elementary */
/* reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
/* zero. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an
*/
/* element of the vector defining H(i). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
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;
} else if (*lwork < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEHRD", &i__1, 6L);
return 0;
}
/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L10: */
}
i__1 = *n - 1;
for (i__ = max(1,*ihi); i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L20: */
}
/* Quick return if possible */
nh = *ihi - *ilo + 1;
if (nh <= 1) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size. */
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1, 6L,
1L);
nb = min(i__1,i__2);
nbmin = 2;
iws = 1;
if (nb > 1 && nb < nh) {
/* Determine when to cross over from blocked to unblocked code
*/
/* (last block is always handled by unblocked code). */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEHRD", " ", n, ilo, ihi, &c_n1,
6L, 1L);
nx = max(i__1,i__2);
if (nx < nh) {
/* Determine if workspace is large enough for blocked co
de. */
iws = *n * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: deter
mine the */
/* minimum value of NB, and reduce NB or force us
e of */
/* unblocked code. */
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEHRD", " ", n, ilo, ihi, &
c_n1, 6L, 1L);
nbmin = max(i__1,i__2);
if (*lwork >= *n * nbmin) {
nb = *lwork / *n;
} else {
nb = 1;
}
}
}
}
ldwork = *n;
if (nb < nbmin || nb >= nh) {
/* Use unblocked code below */
i__ = *ilo;
} else {
/* Use blocked code */
i__1 = *ihi - 1 - nx;
i__2 = nb;
for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *ihi - i__;
ib = min(i__3,i__4);
/* Reduce columns i:i+ib-1 to Hessenberg form, returning
the */
/* matrices V and T of the block reflector H = I - V*T*V
' */
/* which performs the reduction, and also the matrix Y =
A*V*T */
zlahrd_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
c__65, &work[1], &ldwork);
/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from
the */
/* right, computing A := A - Y * V'. V(i+ib,ib-1) must
be set */
/* to 1. */
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
ei.r = a[i__3].r, ei.i = a[i__3].i;
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = 1., a[i__3].i = 0.;
i__3 = *ihi - i__ - ib + 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, &
z__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda,
&c_b2, &a[(i__ + ib) * a_dim1 + 1], lda, 12L, 19L);
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = ei.r, a[i__3].i = ei.i;
/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from
the */
/* left */
i__3 = *ihi - i__;
i__4 = *n - i__ - ib + 1;
zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", &
i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &
c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &
ldwork, 4L, 19L, 7L, 10L);
/* L30: */
}
}
/* Use unblocked code to reduce the rest of the matrix */
zgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZGEHRD */
} /* zgehrd_ */
/* zgebd2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zgebd2_(m, n, a, lda, d__, e, tauq, taup, work, info)
integer *m, *n;
doublecomplex *a;
integer *lda;
doublereal *d__, *e;
doublecomplex *tauq, *taup, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(), xerbla_(), zlarfg_(), zlacgv_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEBD2 reduces a complex general m by n matrix A to upper or lower */
/* real bidiagonal form B by a unitary transformation: Q' * A * P = B. */
/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, */
/* if m >= n, the diagonal and the first superdiagonal are */
/* overwritten with the upper bidiagonal matrix B; the */
/* elements below the diagonal, with the array TAUQ, represent
*/
/* the unitary matrix Q as a product of elementary */
/* reflectors, and the elements above the first superdiagonal,
*/
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors; */
/* if m < n, the diagonal and the first subdiagonal are */
/* overwritten with the lower bidiagonal matrix B; the */
/* elements below the first subdiagonal, with the array TAUQ,
*/
/* represent the unitary matrix Q as a product of */
/* elementary reflectors, and the elements above the diagonal,
*/
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
/* The off-diagonal elements of the bidiagonal matrix B: */
/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
/* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix Q. See Further Details. */
/* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix P. See Further Details. */
/* WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* If m >= n, */
/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, and v and u are complex */
/* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */
/* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
*/
/* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, */
/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, v and u are complex vectors;
*/
/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
*/
/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
*/
/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The contents of A on exit are illustrated by the following examples:
*/
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
/* ( v1 v2 v3 v4 v5 ) */
/* where d and e denote diagonal and off-diagonal elements of B, vi */
/* denotes an element of the vector defining H(i), and ui an element of
*/
/* the vector defining G(i). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 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_("ZGEBD2", &i__1, 6L);
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+
1:m,i) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1, &
tauq[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply H(i)' to A(i:m,i+1:n) from the left */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tauq[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1,
&a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L);
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
if (i__ < *n) {
/* Generate elementary reflector G(i) to annihila
te */
/* A(i,i+2:n) */
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, &
taup[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + (i__ + 1) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__;
zlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1], 5L);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + (i__ + 1) * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.;
} else {
i__2 = i__;
taup[i__2].r = 0., taup[i__2].i = 0.;
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector G(i) to annihilate A(i,
i+1:n) */
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, &
taup[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply G(i) to A(i+1:m,i:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
/* Computing MIN */
i__4 = i__ + 1;
zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &taup[
i__], &a[min(i__4,*m) + i__ * a_dim1], lda, &work[1], 5L);
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
if (i__ < *m) {
/* Generate elementary reflector H(i) to annihila
te */
/* A(i+2:m,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1,
&tauq[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply H(i)' to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__;
i__3 = *n - i__;
d_cnjg(&z__1, &tauq[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
c__1, &z__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &
work[1], 4L);
i__2 = i__ + 1 + i__ * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.;
} else {
i__2 = i__;
tauq[i__2].r = 0., tauq[i__2].i = 0.;
}
/* L20: */
}
}
return 0;
/* End of ZGEBD2 */
} /* zgebd2_ */
/* zdrot.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zdrot_(n, cx, incx, cy, incy, c__, s)
integer *n;
doublecomplex *cx;
integer *incx;
doublecomplex *cy;
integer *incy;
doublereal *c__, *s;
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublecomplex z__1, z__2, z__3;
/* Local variables */
static integer i__;
static doublecomplex ctemp;
static integer ix, iy;
/* applies a plane rotation, where the cos and sin (c and s) are real
*/
/* and the vectors cx and cy are complex. */
/* jack dongarra, linpack, 3/11/78. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* =====================================================================
*/
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--cy;
--cx;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (*incx == 1 && *incy == 1) {
goto L20;
}
/* code for unequal increments or equal increments not equal */
/* to 1 */
ix = 1;
iy = 1;
if (*incx < 0) {
ix = (-(*n) + 1) * *incx + 1;
}
if (*incy < 0) {
iy = (-(*n) + 1) * *incy + 1;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ix;
z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i;
i__3 = iy;
z__3.r = *s * cy[i__3].r, z__3.i = *s * cy[i__3].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__2 = iy;
i__3 = iy;
z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i;
i__4 = ix;
z__3.r = *s * cx[i__4].r, z__3.i = *s * cx[i__4].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
cy[i__2].r = z__1.r, cy[i__2].i = z__1.i;
i__2 = ix;
cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
ix += *incx;
iy += *incy;
/* L10: */
}
return 0;
/* code for both increments equal to 1 */
L20:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i;
i__3 = i__;
z__3.r = *s * cy[i__3].r, z__3.i = *s * cy[i__3].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__2 = i__;
i__3 = i__;
z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i;
i__4 = i__;
z__3.r = *s * cx[i__4].r, z__3.i = *s * cx[i__4].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
cy[i__2].r = z__1.r, cy[i__2].i = z__1.i;
i__2 = i__;
cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
/* L30: */
}
return 0;
} /* zdrot_ */
/* zlarft.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2a
/* Subroutine */ int zlarft_(direct, storev, n, k, v, ldv, tau, t, ldt,
direct_len, storev_len)
char *direct, *storev;
integer *n, *k;
doublecomplex *v;
integer *ldv;
doublecomplex *tau, *t;
integer *ldt;
ftnlen direct_len;
ftnlen storev_len;
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
static integer i__, j;
extern logical lsame_();
extern /* Subroutine */ int zgemv_(), ztrmv_(), zlacgv_();
static doublecomplex vii;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARFT forms the triangular factor T of a complex block reflector H */
/* of order n, which is defined as a product of k elementary reflectors.
*/
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*/
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*/
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) COMPLEX*16 array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*/
/* TAU (input) COMPLEX*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) COMPLEX*16 array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*/
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* The shape of the matrix V and the storage of the vectors which define
*/
/* the H(i) is best illustrated by the following example with n = 5 and
*/
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*/
/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*/
/* ( v1 1 ) ( 1 v2 v2 v2 )
*/
/* ( v1 v2 1 ) ( 1 v3 v3 )
*/
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*/
/* V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*/
/* ( v1 v2 v3 ) ( v2 v2 v2 1 )
*/
/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*/
/* ( 1 v3 ) */
/* ( 1 ) */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = v_dim1 + 1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = t_dim1 + 1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
if (tau[i__2].r == 0. && tau[i__2].i == 0.) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = j + i__ * t_dim1;
t[i__3].r = 0., t[i__3].i = 0.;
/* L10: */
}
} else {
/* general case */
i__2 = i__ + i__ * v_dim1;
vii.r = v[i__2].r, vii.i = v[i__2].i;
i__2 = i__ + i__ * v_dim1;
v[i__2].r = 1., v[i__2].i = 0.;
if (lsame_(storev, "C", 1L, 1L)) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)'
* V(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
i__4 = i__;
z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &v[i__
+ v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, &
c_b2, &t[i__ * t_dim1 + 1], &c__1, 19L);
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) *
V(i,i:n)' */
if (i__ < *n) {
i__2 = *n - i__;
zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
}
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
i__4 = i__;
z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i;
zgemv_("No transpose", &i__2, &i__3, &z__1, &v[i__ *
v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
c_b2, &t[i__ * t_dim1 + 1], &c__1, 12L);
if (i__ < *n) {
i__2 = *n - i__;
zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
}
}
i__2 = i__ + i__ * v_dim1;
v[i__2].r = vii.r, v[i__2].i = vii.i;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, 5L, 12L,
8L);
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
}
/* L20: */
}
} else {
for (i__ = *k; i__ >= 1; --i__) {
i__1 = i__;
if (tau[i__1].r == 0. && tau[i__1].i == 0.) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
i__2 = j + i__ * t_dim1;
t[i__2].r = 0., t[i__2].i = 0.;
/* L30: */
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, "C", 1L, 1L)) {
i__1 = *n - *k + i__ + i__ * v_dim1;
vii.r = v[i__1].r, vii.i = v[i__1].i;
i__1 = *n - *k + i__ + i__ * v_dim1;
v[i__1].r = 1., v[i__1].i = 0.;
/* T(i+1:k,i) := */
/* - tau(i) * V(1:n-k+i,i+1
:k)' * V(1:n-k+i,i) */
i__1 = *n - *k + i__;
i__2 = *k - i__;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &v[
(i__ + 1) * v_dim1 + 1], ldv, &v[i__ * v_dim1
+ 1], &c__1, &c_b2, &t[i__ + 1 + i__ * t_dim1]
, &c__1, 19L);
i__1 = *n - *k + i__ + i__ * v_dim1;
v[i__1].r = vii.r, v[i__1].i = vii.i;
} else {
i__1 = i__ + (*n - *k + i__) * v_dim1;
vii.r = v[i__1].r, vii.i = v[i__1].i;
i__1 = i__ + (*n - *k + i__) * v_dim1;
v[i__1].r = 1., v[i__1].i = 0.;
/* T(i+1:k,i) := */
/* - tau(i) * V(i+1:k,1:n-k
+i) * V(i,1:n-k+i)' */
i__1 = *n - *k + i__ - 1;
zlacgv_(&i__1, &v[i__ + v_dim1], ldv);
i__1 = *k - i__;
i__2 = *n - *k + i__;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zgemv_("No transpose", &i__1, &i__2, &z__1, &v[i__ +
1 + v_dim1], ldv, &v[i__ + v_dim1], ldv, &
c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1, 12L);
i__1 = *n - *k + i__ - 1;
zlacgv_(&i__1, &v[i__ + v_dim1], ldv);
i__1 = i__ + (*n - *k + i__) * v_dim1;
v[i__1].r = vii.r, v[i__1].i = vii.i;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,
i) */
i__1 = *k - i__;
ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1, 5L, 12L, 8L);
}
i__1 = i__ + i__ * t_dim1;
i__2 = i__;
t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
}
/* L40: */
}
}
return 0;
/* End of ZLARFT */
} /* zlarft_ */
/* zunghr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zunghr_(n, ilo, ihi, a, lda, tau, work, lwork, info)
integer *n, *ilo, *ihi;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, j, iinfo, nh;
extern /* Subroutine */ int xerbla_(), zungqr_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNGHR generates a complex unitary matrix Q which is defined as the */
/* product of IHI-ILO elementary reflectors of order N, as returned by */
/* ZGEHRD: */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix Q. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* ILO and IHI must have the same values as in the previous call
*/
/* of ZGEHRD. Q is equal to the unit matrix except in the */
/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the vectors which define the elementary reflectors,
*/
/* as returned by ZGEHRD. */
/* On exit, the N-by-N unitary matrix Q. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (input) COMPLEX*16 array, dimension (N-1) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGEHRD. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= IHI-ILO. */
/* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */
/* the optimal blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
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;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *ihi - *ilo;
if (*lwork < max(i__1,i__2)) {
*info = -8;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNGHR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Shift the vectors which define the elementary reflectors one */
/* column to the right, and set the first ilo and the last n-ihi */
/* rows and columns to those of the unit matrix */
i__1 = *ilo + 1;
for (j = *ihi; j >= i__1; --j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
i__2 = *ihi;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + (j - 1) * a_dim1;
a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
/* L20: */
}
i__2 = *n;
for (i__ = *ihi + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
i__1 = *ilo;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
i__2 = j + j * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L60: */
}
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L70: */
}
i__2 = j + j * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L80: */
}
nh = *ihi - *ilo;
if (nh > 0) {
/* Generate Q(ilo+1:ihi,ilo+1:ihi) */
zungqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[*
ilo], &work[1], lwork, &iinfo);
}
return 0;
/* End of ZUNGHR */
} /* zunghr_ */
/* zgehd2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zgehd2_(n, ilo, ihi, a, lda, tau, work, info)
integer *n, *ilo, *ihi;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(), xerbla_(), zlarfg_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
*/
/* by a unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= max(1,N). */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the n by n general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, and the */
/* elements below the first subdiagonal, with the array TAU, */
/* represent the unitary matrix Q as a product of elementary */
/* reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an
*/
/* element of the vector defining H(i). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEHD2", &i__1, 6L);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*/
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
zlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1], 5L);
/* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &z__1,
&a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], 4L);
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
/* L10: */
}
return 0;
/* End of ZGEHD2 */
} /* zgehd2_ */
/* zladiv.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Double Complex */ VOID zladiv_( ret_val, x, y)
doublecomplex * ret_val;
doublecomplex *x, *y;
{
/* System generated locals */
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag();
/* Local variables */
static doublereal zi;
extern /* Subroutine */ int dladiv_();
static doublereal zr;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
*/
/* will not overflow on an intermediary step unless the results */
/* overflows. */
/* Arguments */
/* ========= */
/* X (input) COMPLEX*16 */
/* Y (input) COMPLEX*16 */
/* The complex scalars X and Y. */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
d__1 = x->r;
d__2 = d_imag(x);
d__3 = y->r;
d__4 = d_imag(y);
dladiv_(&d__1, &d__2, &d__3, &d__4, &zr, &zi);
z__1.r = zr, z__1.i = zi;
ret_val->r = z__1.r, ret_val->i = z__1.i;
return ;
/* End of ZLADIV */
} /* zladiv_ */
/* zgebrd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1a
/* Subroutine */ int zgebrd_(m, n, a, lda, d__, e, tauq, taup, work, lwork,
info)
integer *m, *n;
doublecomplex *a;
integer *lda;
doublereal *d__, *e;
doublecomplex *tauq, *taup, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Local variables */
static integer i__, j, nbmin, iinfo, minmn;
extern /* Subroutine */ int zgemm_(), zgebd2_();
static integer nb, nx;
static doublereal ws;
extern /* Subroutine */ int xerbla_(), zlabrd_();
extern integer ilaenv_();
static integer ldwrkx, ldwrky;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEBRD reduces a general complex M-by-N matrix A to upper or lower */
/* bidiagonal form B by a unitary transformation: Q**H * A * P = B. */
/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N general matrix to be reduced. */
/* On exit, */
/* if m >= n, the diagonal and the first superdiagonal are */
/* overwritten with the upper bidiagonal matrix B; the */
/* elements below the diagonal, with the array TAUQ, represent
*/
/* the unitary matrix Q as a product of elementary */
/* reflectors, and the elements above the first superdiagonal,
*/
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors; */
/* if m < n, the diagonal and the first subdiagonal are */
/* overwritten with the lower bidiagonal matrix B; the */
/* elements below the first subdiagonal, with the array TAUQ,
*/
/* represent the unitary matrix Q as a product of */
/* elementary reflectors, and the elements above the diagonal,
*/
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
/* The off-diagonal elements of the bidiagonal matrix B: */
/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
/* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix Q. See Further Details. */
/* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix P. See Further Details. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,M,N). */
/* For optimum performance LWORK >= (M+N)*NB, where NB */
/* is the optimal blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* 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, and 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 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;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*lwork < max(i__1,*n)) {
*info = -10;
}
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZGEBRD", &i__1, 6L);
return 0;
}
/* Quick return if possible */
minmn = min(*m,*n);
if (minmn == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
ws = (doublereal) max(*m,*n);
ldwrkx = *m;
ldwrky = *n;
/* Set the block size NB and the crossover point NX. */
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEBRD", " ", m, n, &c_n1, &c_n1, 6L, 1L)
;
nb = max(i__1,i__2);
if (nb > 1 && nb < minmn) {
/* Determine when to switch from blocked to unblocked code. */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEBRD", " ", m, n, &c_n1, &c_n1,
6L, 1L);
nx = max(i__1,i__2);
if (nx < minmn) {
ws = (doublereal) ((*m + *n) * nb);
if ((doublereal) (*lwork) < ws) {
/* Not enough work space for the optimal NB, cons
ider using */
/* a smaller block size. */
nbmin = ilaenv_(&c__2, "ZGEBRD", " ", m, n, &c_n1, &c_n1, 6L,
1L);
if (*lwork >= (*m + *n) * nbmin) {
nb = *lwork / (*m + *n);
} else {
nb = 1;
nx = minmn;
}
}
}
} else {
nx = minmn;
}
i__1 = minmn - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Reduce rows and columns i:i+ib-1 to bidiagonal form and retu
rn */
/* the matrices X and Y which are needed to update the unreduce
d */
/* part of the matrix */
i__3 = *m - i__ + 1;
i__4 = *n - i__ + 1;
zlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[
i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx
* nb + 1], &ldwrky);
/* Update the trailing submatrix A(i+ib:m,i+ib:n), using */
/* an update of the form A := A - V*Y' - X*U' */
i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", &i__3, &i__4, &nb, &
z__1, &a[i__ + nb + i__ * a_dim1], lda, &work[ldwrkx * nb +
nb + 1], &ldwrky, &c_b1, &a[i__ + nb + (i__ + nb) * a_dim1],
lda, 12L, 19L);
i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &z__1, &
work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, &
c_b1, &a[i__ + nb + (i__ + nb) * a_dim1], lda, 12L, 12L);
/* Copy diagonal and off-diagonal elements of B back into A */
if (*m >= *n) {
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
i__4 = j + j * a_dim1;
i__5 = j;
a[i__4].r = d__[i__5], a[i__4].i = 0.;
i__4 = j + (j + 1) * a_dim1;
i__5 = j;
a[i__4].r = e[i__5], a[i__4].i = 0.;
/* L10: */
}
} else {
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
i__4 = j + j * a_dim1;
i__5 = j;
a[i__4].r = d__[i__5], a[i__4].i = 0.;
i__4 = j + 1 + j * a_dim1;
i__5 = j;
a[i__4].r = e[i__5], a[i__4].i = 0.;
/* L20: */
}
}
/* L30: */
}
/* Use unblocked code to reduce the remainder of the matrix */
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
zgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
tauq[i__], &taup[i__], &work[1], &iinfo);
work[1].r = ws, work[1].i = 0.;
return 0;
/* End of ZGEBRD */
} /* zgebrd_ */
/* zgeqr2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zgeqr2_(m, n, a, lda, tau, work, info)
integer *m, *n;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static integer i__, k;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(), xerbla_(), zlarfg_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEQR2 computes a QR factorization of a complex m by n matrix A: */
/* A = Q * R. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, the elements on and above the diagonal of the array
*/
/* contain the min(m,n) by n upper trapezoidal matrix R (R is */
/* upper triangular if m >= n); the elements below the diagonal,
*/
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*/
/* and tau in TAU(i). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQR2", &i__1, 6L);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*/
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1]
, &c__1, &tau[i__]);
if (i__ < *n) {
/* Apply H(i)' 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;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1,
&a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
}
/* L10: */
}
return 0;
/* End of ZGEQR2 */
} /* zgeqr2_ */
/* zgetf2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1a
/* Subroutine */ int zgetf2_(m, n, a, lda, ipiv, info)
integer *m, *n;
doublecomplex *a;
integer *lda, *ipiv, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void z_div();
/* Local variables */
static integer j;
extern /* Subroutine */ int zscal_(), zgeru_(), zswap_();
static integer jp;
extern /* Subroutine */ int xerbla_();
extern integer izamax_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGETF2 computes an LU factorization of a general m-by-n matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used
*/
/* to solve a system of equations. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
/* 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_("ZGETF2", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + izamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
i__2 = jp + j * a_dim1;
if (a[i__2].r != 0. || a[i__2].i != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
zswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
i__2 = *m - j;
z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
zscal_(&i__2, &z__1, &a[j + 1 + j * a_dim1], &c__1);
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
z__1.r = -1., z__1.i = 0.;
zgeru_(&i__2, &i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &a[j +
(j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda)
;
}
/* L10: */
}
return 0;
/* End of ZGETF2 */
} /* zgetf2_ */
/* zgetrs.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1a
/* Subroutine */ int zgetrs_(trans, n, nrhs, a, lda, ipiv, b, ldb, info,
trans_len)
char *trans;
integer *n, *nrhs;
doublecomplex *a;
integer *lda, *ipiv;
doublecomplex *b;
integer *ldb, *info;
ftnlen trans_len;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_();
extern /* Subroutine */ int ztrsm_(), xerbla_();
static logical notran;
extern /* Subroutine */ int zlaswp_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGETRS solves a system of linear equations */
/* A * X = B, A**T * X = B, or A**H * X = B */
/* with a general N-by-N matrix A using the LU factorization computed */
/* by ZGETRF. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The factors L and U from the factorization A = P*L*U */
/* as computed by ZGETRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from ZGETRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* 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 parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N", 1L, 1L);
if (! notran && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L,
1L)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGETRS", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (notran) {
/* Solve A * X = B. */
/* Apply row interchanges to the right hand sides. */
zlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
/* Solve L*X = B, overwriting B with X. */
ztrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b1, &a[
a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 4L);
/* Solve U*X = B, overwriting B with X. */
ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &
a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 8L);
} else {
/* Solve A**T * X = B or A**H * X = B. */
/* Solve U'*X = B, overwriting B with X. */
ztrsm_("Left", "Upper", trans, "Non-unit", n, nrhs, &c_b1, &a[
a_offset], lda, &b[b_offset], ldb, 4L, 5L, 1L, 8L);
/* Solve L'*X = B, overwriting B with X. */
ztrsm_("Left", "Lower", trans, "Unit", n, nrhs, &c_b1, &a[a_offset],
lda, &b[b_offset], ldb, 4L, 5L, 1L, 4L);
/* Apply row interchanges to the solution vectors. */
zlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
}
return 0;
/* End of ZGETRS */
} /* zgetrs_ */
/* zlasr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zlasr_(side, pivot, direct, m, n, c__, s, a, lda,
side_len, pivot_len, direct_len)
char *side, *pivot, *direct;
integer *m, *n;
doublereal *c__, *s;
doublecomplex *a;
integer *lda;
ftnlen side_len;
ftnlen pivot_len;
ftnlen direct_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1, z__2, z__3;
/* Local variables */
static integer info;
static doublecomplex temp;
static integer i__, j;
extern logical lsame_();
static doublereal ctemp, stemp;
extern /* Subroutine */ int xerbla_();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLASR performs the transformation */
/* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) */
/* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) */
/* where A is an m by n complex matrix and P is an orthogonal matrix, */
/* consisting of a sequence of plane rotations determined by the */
/* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
*/
/* and z = n when SIDE = 'R' or 'r' ): */
/* When DIRECT = 'F' or 'f' ( Forward sequence ) then */
/* P = P( z - 1 )*...*P( 2 )*P( 1 ), */
/* and when DIRECT = 'B' or 'b' ( Backward sequence ) then */
/* P = P( 1 )*P( 2 )*...*P( z - 1 ), */
/* where P( k ) is a plane rotation matrix for the following planes: */
/* when PIVOT = 'V' or 'v' ( Variable pivot ), */
/* the plane ( k, k + 1 ) */
/* when PIVOT = 'T' or 't' ( Top pivot ), */
/* the plane ( 1, k + 1 ) */
/* when PIVOT = 'B' or 'b' ( Bottom pivot ), */
/* the plane ( k, z ) */
/* c( k ) and s( k ) must contain the cosine and sine that define the
*/
/* matrix P( k ). The two by two plane rotation part of the matrix */
/* P( k ), R( k ), is assumed to be of the form */
/* R( k ) = ( c( k ) s( k ) ). */
/* ( -s( k ) c( k ) ) */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* Specifies whether the plane rotation matrix P is applied to */
/* A on the left or the right. */
/* = 'L': Left, compute A := P*A */
/* = 'R': Right, compute A:= A*P' */
/* DIRECT (input) CHARACTER*1 */
/* Specifies whether P is a forward or backward sequence of */
/* plane rotations. */
/* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) */
/* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) */
/* PIVOT (input) CHARACTER*1 */
/* Specifies the plane for which P(k) is a plane rotation */
/* matrix. */
/* = 'V': Variable pivot, the plane (k,k+1) */
/* = 'T': Top pivot, the plane (1,k+1) */
/* = 'B': Bottom pivot, the plane (k,z) */
/* M (input) INTEGER */
/* The number of rows of the matrix A. If m <= 1, an immediate
*/
/* return is effected. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. If n <= 1, an */
/* immediate return is effected. */
/* C, S (input) DOUBLE PRECISION arrays, dimension */
/* (M-1) if SIDE = 'L' */
/* (N-1) if SIDE = 'R' */
/* c(k) and s(k) contain the cosine and sine that define the */
/* matrix P(k). The two by two plane rotation part of the */
/* matrix P(k), R(k), is assumed to be of the form */
/* R( k ) = ( c( k ) s( k ) ). */
/* ( -s( k ) c( k ) ) */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* The m by n matrix A. On exit, A is overwritten by P*A if */
/* SIDE = 'R' or by A*P' if SIDE = 'L'. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--c__;
--s;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
info = 0;
if (! (lsame_(side, "L", 1L, 1L) || lsame_(side, "R", 1L, 1L))) {
info = 1;
} else if (! (lsame_(pivot, "V", 1L, 1L) || lsame_(pivot, "T", 1L, 1L) ||
lsame_(pivot, "B", 1L, 1L))) {
info = 2;
} else if (! (lsame_(direct, "F", 1L, 1L) || lsame_(direct, "B", 1L, 1L)))
{
info = 3;
} else if (*m < 0) {
info = 4;
} else if (*n < 0) {
info = 5;
} else if (*lda < max(1,*m)) {
info = 9;
}
if (info != 0) {
xerbla_("ZLASR ", &info, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
if (lsame_(side, "L", 1L, 1L)) {
/* Form P * A */
if (lsame_(pivot, "V", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + 1 + i__ * a_dim1;
temp.r = a[i__3].r, temp.i = a[i__3].i;
i__3 = j + 1 + i__ * a_dim1;
z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
i__4 = j + i__ * a_dim1;
z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[
i__4].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = j + i__ * a_dim1;
z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
i__4 = j + i__ * a_dim1;
z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[
i__4].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L10: */
}
}
/* L20: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *m - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = j + 1 + i__ * a_dim1;
temp.r = a[i__2].r, temp.i = a[i__2].i;
i__2 = j + 1 + i__ * a_dim1;
z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
i__3 = j + i__ * a_dim1;
z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[
i__3].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = j + i__ * a_dim1;
z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
i__3 = j + i__ * a_dim1;
z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[
i__3].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L30: */
}
}
/* L40: */
}
}
} else if (lsame_(pivot, "T", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *m;
for (j = 2; j <= i__1; ++j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * a_dim1;
temp.r = a[i__3].r, temp.i = a[i__3].i;
i__3 = j + i__ * a_dim1;
z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
i__4 = i__ * a_dim1 + 1;
z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[
i__4].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = i__ * a_dim1 + 1;
z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
i__4 = i__ * a_dim1 + 1;
z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[
i__4].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L50: */
}
}
/* L60: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *m; j >= 2; --j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = j + i__ * a_dim1;
temp.r = a[i__2].r, temp.i = a[i__2].i;
i__2 = j + i__ * a_dim1;
z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
i__3 = i__ * a_dim1 + 1;
z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[
i__3].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = i__ * a_dim1 + 1;
z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
i__3 = i__ * a_dim1 + 1;
z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[
i__3].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L70: */
}
}
/* L80: */
}
}
} else if (lsame_(pivot, "B", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * a_dim1;
temp.r = a[i__3].r, temp.i = a[i__3].i;
i__3 = j + i__ * a_dim1;
i__4 = *m + i__ * a_dim1;
z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[
i__4].i;
z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = *m + i__ * a_dim1;
i__4 = *m + i__ * a_dim1;
z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[
i__4].i;
z__3.r = stemp * temp.r, z__3.i = stemp * temp.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L90: */
}
}
/* L100: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *m - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = j + i__ * a_dim1;
temp.r = a[i__2].r, temp.i = a[i__2].i;
i__2 = j + i__ * a_dim1;
i__3 = *m + i__ * a_dim1;
z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[
i__3].i;
z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = *m + i__ * a_dim1;
i__3 = *m + i__ * a_dim1;
z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[
i__3].i;
z__3.r = stemp * temp.r, z__3.i = stemp * temp.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L110: */
}
}
/* L120: */
}
}
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form A * P' */
if (lsame_(pivot, "V", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (j + 1) * a_dim1;
temp.r = a[i__3].r, temp.i = a[i__3].i;
i__3 = i__ + (j + 1) * a_dim1;
z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
i__4 = i__ + j * a_dim1;
z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[
i__4].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = i__ + j * a_dim1;
z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
i__4 = i__ + j * a_dim1;
z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[
i__4].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L130: */
}
}
/* L140: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *n - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + (j + 1) * a_dim1;
temp.r = a[i__2].r, temp.i = a[i__2].i;
i__2 = i__ + (j + 1) * a_dim1;
z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
i__3 = i__ + j * a_dim1;
z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[
i__3].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = i__ + j * a_dim1;
z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
i__3 = i__ + j * a_dim1;
z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[
i__3].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L150: */
}
}
/* L160: */
}
}
} else if (lsame_(pivot, "T", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
temp.r = a[i__3].r, temp.i = a[i__3].i;
i__3 = i__ + j * a_dim1;
z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
i__4 = i__ + a_dim1;
z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[
i__4].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = i__ + a_dim1;
z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
i__4 = i__ + a_dim1;
z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[
i__4].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L170: */
}
}
/* L180: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *n; j >= 2; --j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + j * a_dim1;
temp.r = a[i__2].r, temp.i = a[i__2].i;
i__2 = i__ + j * a_dim1;
z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
i__3 = i__ + a_dim1;
z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[
i__3].i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = i__ + a_dim1;
z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
i__3 = i__ + a_dim1;
z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[
i__3].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L190: */
}
}
/* L200: */
}
}
} else if (lsame_(pivot, "B", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
temp.r = a[i__3].r, temp.i = a[i__3].i;
i__3 = i__ + j * a_dim1;
i__4 = i__ + *n * a_dim1;
z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[
i__4].i;
z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = i__ + *n * a_dim1;
i__4 = i__ + *n * a_dim1;
z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[
i__4].i;
z__3.r = stemp * temp.r, z__3.i = stemp * temp.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L210: */
}
}
/* L220: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *n - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + j * a_dim1;
temp.r = a[i__2].r, temp.i = a[i__2].i;
i__2 = i__ + j * a_dim1;
i__3 = i__ + *n * a_dim1;
z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[
i__3].i;
z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = i__ + *n * a_dim1;
i__3 = i__ + *n * a_dim1;
z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[
i__3].i;
z__3.r = stemp * temp.r, z__3.i = stemp * temp.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
z__3.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L230: */
}
}
/* L240: */
}
}
}
}
return 0;
/* End of ZLASR */
} /* zlasr_ */
/* zgelss.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2
#ifdef c_b78
#undef c_b78
#endif
#define c_b78 c_b78
/* Subroutine */ int zgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work,
lwork, rwork, info)
integer *m, *n, *nrhs;
doublecomplex *a;
integer *lda;
doublecomplex *b;
integer *ldb;
doublereal *s, *rcond;
integer *rank;
doublecomplex *work;
integer *lwork;
doublereal *rwork;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static doublereal anrm, bnrm;
static integer itau;
static doublecomplex vdum[1];
static integer i__, iascl, ibscl, chunk;
static doublereal sfmin;
static integer minmn;
extern /* Subroutine */ int zgemm_();
static integer maxmn, itaup, itauq, mnthr;
extern /* Subroutine */ int zgemv_();
static integer iwork;
extern /* Subroutine */ int zcopy_(), dlabad_();
static integer bl, ie, il;
extern doublereal dlamch_();
static integer mm;
extern /* Subroutine */ int dlascl_(), dlaset_(), xerbla_(), zgebrd_();
extern integer ilaenv_();
extern doublereal zlange_();
static doublereal bignum;
extern /* Subroutine */ int zgelqf_(), zlascl_(), zgeqrf_(), zdrscl_();
static integer ldwork;
extern /* Subroutine */ int zlacpy_(), zlaset_(), zbdsqr_();
static integer minwrk, maxwrk;
extern /* Subroutine */ int zungbr_();
static doublereal smlnum;
static integer irwork;
extern /* Subroutine */ int zunmbr_(), zunmlq_(), zunmqr_();
static doublereal eps, thr;
/* -- LAPACK driver routine (version 2.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 */
/* ======= */
/* ZGELSS computes the minimum norm solution to a complex linear */
/* least squares problem: */
/* Minimize 2-norm(| b - A*x |). */
/* using the singular value decomposition (SVD) of A. A is an M-by-N */
/* matrix which may be rank-deficient. */
/* Several right hand side vectors b and solution vectors x can be */
/* handled in a single call; they are stored as the columns of the */
/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
*/
/* X. */
/* The effective rank of A is determined by treating as zero those */
/* singular values which are less than RCOND times the largest singular
*/
/* value. */
/* 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. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the first min(m,n) rows of A are overwritten with */
/* its right singular vectors, stored rowwise. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* On entry, the M-by-NRHS right hand side matrix B. */
/* On exit, B is overwritten by the N-by-NRHS solution matrix X.
*/
/* If m >= n and RANK = n, the residual sum-of-squares for */
/* the solution in the i-th column is given by the sum of */
/* squares of elements n+1:m in that column. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,M,N). */
/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The singular values of A in decreasing order. */
/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
/* RCOND (input) DOUBLE PRECISION */
/* RCOND is used to determine the effective rank of A. */
/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
/* If RCOND < 0, machine precision is used instead. */
/* RANK (output) INTEGER */
/* The effective rank of A, i.e., the number of singular values
*/
/* which are greater than RCOND*S(1). */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 1, and also: */
/* LWORK >= 2*min(M,N) + max(M,N,NRHS) */
/* For good performance, LWORK should generally be larger. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)-1)
*/
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: the algorithm for computing the SVD failed to converge;
*/
/* if INFO = i, i off-diagonal elements of an intermediate
*/
/* bidiagonal form did not converge to zero. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
--s;
--work;
--rwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, "ZGELSS", " ", m, n, nrhs, &c_n1, 6L, 1L);
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
*info = -7;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace refers */
/* to real workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = 0;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns */
/* Space needed for ZBDSQR is BDSPAC = 5*N-1 */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "ZUNMQR", "LT",
m, nrhs, n, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined */
/* Space needed for ZBDSQR is BDSPC = 7*N+12 */
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1,
"ZGEBRD", " ", &mm, n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1, "ZUNMBR",
"QLC", &mm, nrhs, n, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUN\
GBR", "P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
minwrk = (*n << 1) + max(*nrhs,*m);
}
if (*n > *m) {
minwrk = (*m << 1) + max(*nrhs,*n);
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more colu
mns */
/* than rows */
/* Space needed for ZBDSQR is BDSPAC = 5*M-1 */
maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1,
&c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + *nrhs * ilaenv_(&
c__1, "ZUNMBR", "QLC", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m - 1) * ilaenv_(&
c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "ZUNMLQ",
"LT", n, nrhs, m, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - underdetermined */
/* Space needed for ZBDSQR is BDSPAC = 5*M-1 */
maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "ZGEBRD",
" ", m, n, &c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1,
"ZUNMBR", "QLT", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR"
, "P", m, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
}
}
minwrk = max(minwrk,1);
maxwrk = max(minwrk,maxwrk);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGELSS", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
eps = dlamch_("P", 1L);
sfmin = dlamch_("S", 1L);
smlnum = sfmin / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1], 1L);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info, 1L);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info, 1L);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb, 1L);
dlaset_("F", &minmn, &c__1, &c_b78, &c_b78, &s[1], &minmn, 1L);
*rank = 0;
goto L70;
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1], 1L);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info, 1L);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info, 1L);
ibscl = 2;
}
/* Overdetermined case */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns */
mm = *n;
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1,
info);
/* Multiply B by transpose(Q) */
/* (CWorkspace: need N+NRHS, prefer N+NRHS*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L);
/* Zero out below R */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda,
1L);
}
}
ie = 1;
itauq = 1;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in A */
/* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */
/* (RWorkspace: need N) */
i__1 = *lwork - iwork + 1;
zgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &
work[itaup], &work[iwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R
*/
/* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
&b[b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L, 1L);
/* Generate right bidiagonalizing vectors of R in A */
/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &
i__1, info, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration */
/* multiply B by transpose of left singular vectors */
/* compute right singular vectors in A */
/* (CWorkspace: none) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], lda,
vdum, &c__1, &b[b_offset], ldb, &rwork[irwork], info, 1L);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values */
/* Computing MAX */
d__1 = *rcond * s[1];
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * s[1];
thr = max(d__1,sfmin);
}
*rank = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] > thr) {
zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb,
1L);
}
/* L10: */
}
/* Multiply B by right singular vectors */
/* (CWorkspace: need N, prefer N*NRHS) */
/* (RWorkspace: none) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
zgemm_("C", "N", n, nrhs, n, &c_b2, &a[a_offset], lda, &b[
b_offset], ldb, &c_b1, &work[1], ldb, 1L, 1L);
zlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb, 1L);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = *nrhs - i__ + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", n, &bl, n, &c_b2, &a[a_offset], lda, &b[
b_offset], ldb, &c_b1, &work[1], n, 1L, 1L);
zlacpy_("G", n, &bl, &work[1], n, &b[b_offset], ldb, 1L);
/* L20: */
}
} else {
zgemv_("C", n, n, &c_b2, &a[a_offset], lda, &b[b_offset], &c__1, &
c_b1, &work[1], &c__1, 1L);
zcopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
}
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
if (*n >= mnthr && *lwork >= *m * 3 + *m * *m + max(i__2,i__1)) {
/* Underdetermined case, M much less than N */
/* Path 2a - underdetermined, with many more columns than r
ows */
/* and sufficient workspace for an efficient algorithm */
ldwork = *m;
/* Computing MAX */
i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
if (*lwork >= *m * 3 + *m * *lda + max(i__2,i__1)) {
ldwork = *lda;
}
itau = 1;
iwork = *m + 1;
/* Compute A=L*Q */
/* (CWorkspace: need 2*M, prefer M+M*NB) */
/* (RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2,
info);
il = iwork;
/* Copy L to WORK(IL), zeroing out above it */
zlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork, 1L);
i__2 = *m - 1;
i__1 = *m - 1;
zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &work[il + ldwork], &
ldwork, 1L);
ie = 1;
itauq = il + ldwork * *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IL) */
/* (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq],
&work[itaup], &work[iwork], &i__2, info);
/* Multiply B by transpose of left bidiagonalizing vectors
of L */
/* (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB)
*/
/* (RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[
itauq], &b[b_offset], ldb, &work[iwork], &i__2, info, 1L,
1L, 1L);
/* Generate right bidiagonalizing vectors of R in WORK(IL)
*/
/* (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */
/* (RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[
iwork], &i__2, info, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration, computing right singula
r */
/* vectors of L in WORK(IL) and multiplying B by transpose
of */
/* left singular vectors */
/* (CWorkspace: need M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, &c__0, nrhs, &s[1], &rwork[ie], &work[il], &
ldwork, &a[a_offset], lda, &b[b_offset], ldb, &rwork[
irwork], info, 1L);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values */
/* Computing MAX */
d__1 = *rcond * s[1];
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * s[1];
thr = max(d__1,sfmin);
}
*rank = 0;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (s[i__] > thr) {
zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1],
ldb, 1L);
}
/* L30: */
}
iwork = il + *m * ldwork;
/* Multiply B by right singular vectors of L in WORK(IL) */
/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS) */
/* (RWorkspace: none) */
if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
zgemm_("C", "N", m, nrhs, m, &c_b2, &work[il], &ldwork, &b[
b_offset], ldb, &c_b1, &work[iwork], ldb, 1L, 1L);
zlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb,
1L);
} else if (*nrhs > 1) {
chunk = (*lwork - iwork + 1) / *m;
i__2 = *nrhs;
i__1 = chunk;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
i__1) {
/* Computing MIN */
i__3 = *nrhs - i__ + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", m, &bl, m, &c_b2, &work[il], &ldwork, &b[
i__ * b_dim1 + 1], ldb, &c_b1, &work[iwork], n,
1L, 1L);
zlacpy_("G", m, &bl, &work[iwork], n, &b[b_offset], ldb,
1L);
/* L40: */
}
} else {
zgemv_("C", m, m, &c_b2, &work[il], &ldwork, &b[b_dim1 + 1], &
c__1, &c_b1, &work[iwork], &c__1, 1L);
zcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1);
}
/* Zero out below first M rows of B */
i__1 = *n - *m;
zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb,
1L);
iwork = itau + *m;
/* Multiply transpose(Q) by B */
/* (CWorkspace: need M+NRHS, prefer M+NHRS*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L);
} else {
/* Path 2 - remaining underdetermined cases */
ie = 1;
itauq = 1;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A */
/* (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB) */
/* (RWorkspace: need N) */
i__1 = *lwork - iwork + 1;
zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
&work[itaup], &work[iwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors
*/
/* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq]
, &b[b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L,
1L);
/* Generate right bidiagonalizing vectors in A */
/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
iwork], &i__1, info, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration, */
/* computing right singular vectors of A in A and */
/* multiplying B by transpose of left singular vectors
*/
/* (CWorkspace: none) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("L", m, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset],
lda, vdum, &c__1, &b[b_offset], ldb, &rwork[irwork], info,
1L);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values */
/* Computing MAX */
d__1 = *rcond * s[1];
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * s[1];
thr = max(d__1,sfmin);
}
*rank = 0;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] > thr) {
zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1],
ldb, 1L);
}
/* L50: */
}
/* Multiply B by right singular vectors of A */
/* (CWorkspace: need N, prefer N*NRHS) */
/* (RWorkspace: none) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
zgemm_("C", "N", n, nrhs, m, &c_b2, &a[a_offset], lda, &b[
b_offset], ldb, &c_b1, &work[1], ldb, 1L, 1L);
zlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb, 1L);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
i__2) {
/* Computing MIN */
i__3 = *nrhs - i__ + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", n, &bl, m, &c_b2, &a[a_offset], lda, &b[
i__ * b_dim1 + 1], ldb, &c_b1, &work[1], n, 1L,
1L);
zlacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1],
ldb, 1L);
/* L60: */
}
} else {
zgemv_("C", m, n, &c_b2, &a[a_offset], lda, &b[b_offset], &
c__1, &c_b1, &work[1], &c__1, 1L);
zcopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
}
}
}
/* Undo scaling */
if (iascl == 1) {
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info, 1L);
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, info, 1L);
} else if (iascl == 2) {
zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info, 1L);
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, info, 1L);
}
if (ibscl == 1) {
zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, 1L);
} else if (ibscl == 2) {
zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, 1L);
}
L70:
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZGELSS */
} /* zgelss_ */
/* zbdsqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b15
#undef c_b15
#endif
#define c_b15 c_b15
#ifdef c_b48
#undef c_b48
#endif
#define c_b48 c_b48
#ifdef c_b71
#undef c_b71
#endif
#define c_b71 c_b71
/* Subroutine */ int zbdsqr_(uplo, n, ncvt, nru, ncc, d__, e, vt, ldvt, u,
ldu, c__, ldc, rwork, info, uplo_len)
char *uplo;
integer *n, *ncvt, *nru, *ncc;
doublereal *d__, *e;
doublecomplex *vt;
integer *ldvt;
doublecomplex *u;
integer *ldu;
doublecomplex *c__;
integer *ldc;
doublereal *rwork;
integer *info;
ftnlen uplo_len;
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(), sqrt(), d_sign();
/* Local variables */
static doublereal abse;
static integer idir;
static doublereal abss;
static integer oldm;
static doublereal cosl;
static integer isub, iter;
static doublereal unfl, sinl, cosr, smin, smax, sinr;
static integer irot;
extern /* Subroutine */ int dlas2_();
static doublereal f, g, h__;
static integer i__, j, m;
static doublereal r__;
extern logical lsame_();
static doublereal oldcs;
static integer oldll;
static doublereal shift, sigmn, oldsn;
static integer maxit;
static doublereal sminl, sigmx;
static integer iuplo;
extern /* Subroutine */ int zlasr_(), zdrot_(), zswap_(), dlasq1_(),
dlasv2_();
static doublereal cs;
static integer ll;
extern doublereal dlamch_();
static doublereal sn, mu;
extern /* Subroutine */ int dlartg_(), xerbla_(), zdscal_();
static doublereal sminoa, thresh;
static logical rotate;
static doublereal sminlo;
static integer nm1;
static doublereal tolmul;
static integer nm12, nm13, lll;
static doublereal eps, sll, tol;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZBDSQR computes the singular value decomposition (SVD) of a real */
/* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' */
/* denotes the transpose of P), where S is a diagonal matrix with */
/* non-negative diagonal elements (the singular values of B), and Q */
/* and P are orthogonal matrices. */
/* The routine computes S, and optionally computes U * Q, P' * VT, */
/* or Q' * C, for given complex input matrices U, VT, and C. */
/* See "Computing Small Singular Values of Bidiagonal Matrices With */
/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
/* no. 5, pp. 873-912, Sept 1990) and */
/* "Accurate singular values and differential qd algorithms," by */
/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
/* Department, University of California at Berkeley, July 1992 */
/* for a detailed description of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal; */
/* = 'L': B is lower bidiagonal. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* NCVT (input) INTEGER */
/* The number of columns of the matrix VT. NCVT >= 0. */
/* NRU (input) INTEGER */
/* The number of rows of the matrix U. NRU >= 0. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B.
*/
/* On exit, if INFO=0, the singular values of B in decreasing */
/* order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the elements of E contain the */
/* offdiagonal elements of of the bidiagonal matrix whose SVD */
/* is desired. On normal exit (INFO = 0), E is destroyed. */
/* If the algorithm does not converge (INFO > 0), D and E */
/* will contain the diagonal and superdiagonal elements of a */
/* bidiagonal matrix orthogonally equivalent to the one given */
/* as input. E(N) is used for workspace. */
/* VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) */
/* On entry, an N-by-NCVT matrix VT. */
/* On exit, VT is overwritten by P' * VT. */
/* VT is not referenced if NCVT = 0. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. */
/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
/* U (input/output) COMPLEX*16 array, dimension (LDU, N) */
/* On entry, an NRU-by-N matrix U. */
/* On exit, U is overwritten by U * Q. */
/* U is not referenced if NRU = 0. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,NRU). */
/* C (input/output) COMPLEX*16 array, dimension (LDC, NCC) */
/* On entry, an N-by-NCC matrix C. */
/* On exit, C is overwritten by Q' * C. */
/* C is not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* 2*N if only singular values wanted (NCVT = NRU = NCC = 0)
*/
/* max( 1, 4*N-4 ) otherwise */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm did not converge; D and E contain the */
/* elements of a bidiagonal matrix which is orthogonally */
/* similar to the input matrix B; if INFO = i, i */
/* elements of E have not converged to zero. */
/* Internal Parameters */
/* =================== */
/* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) */
/* TOLMUL controls the convergence criterion of the QR loop. */
/* If it is positive, TOLMUL*EPS is the desired relative */
/* precision in the computed singular values. */
/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
/* desired absolute accuracy in the computed singular */
/* values (corresponds to relative accuracy */
/* abs(TOLMUL*EPS) in the largest singular value. */
/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
/* between 10 (for fast convergence) and .1/EPS */
/* (for there to be some accuracy in the results). */
/* Default is to lose at either one eighth or 2 of the */
/* available decimal digits in each computed singular value */
/* (whichever is smaller). */
/* MAXITR INTEGER, default = 6 */
/* MAXITR controls the maximum number of passes of the */
/* algorithm through its inner loop. The algorithms stops */
/* (and so fails to converge) if the number of passes */
/* through the inner loop exceeds MAXITR*N**2. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = vt_dim1 + 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = u_dim1 + 1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--rwork;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U", 1L, 1L)) {
iuplo = 1;
}
if (lsame_(uplo, "L", 1L, 1L)) {
iuplo = 2;
}
if (iuplo == 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZBDSQR", &i__1, 6L);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L150;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &rwork[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
/* Get machine constants */
eps = dlamch_("Epsilon", 7L);
unfl = dlamch_("Safe minimum", 12L);
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
if (iuplo == 2) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
rwork[i__] = cs;
rwork[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
zlasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset],
ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
zlasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[
c_offset], ldc, 1L, 1L, 1L);
}
}
/* Compute singular values to relative accuracy TOL */
/* (By setting TOL to be negative, algorithm will compute */
/* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*/
/* Computing MAX */
/* Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = (d__1 = d__[*n], abs(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__3 = smax, d__4 = (d__1 = d__[i__], abs(d__1)), d__3 = max(d__3,
d__4), d__4 = (d__2 = e[i__], abs(d__2));
smax = max(d__3,d__4);
/* L20: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L40;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__1 = d__[i__], abs(d__1)) * (mu / (mu + (d__2 = e[i__ - 1]
, abs(d__2))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L40;
}
/* L30: */
}
L40:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired */
/* Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values */
/* (MAXIT is the maximum number of passes through the inner */
/* loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L50:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L150;
}
if (iter > maxit) {
goto L190;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
if (ll == 0) {
goto L80;
}
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L70;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L60: */
}
L70:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop
*/
--m;
goto L50;
}
L80:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
zdrot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
cosr, &sinr);
}
if (*nru > 0) {
zdrot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
c__1, &cosl, &sinl);
}
if (*ncc > 0) {
zdrot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
cosl, &sinl);
}
m += -2;
goto L50;
}
/* If working on new submatrix, choose shift direction */
/* (from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
/* Chase bulge from top (big end) to bottom (small end)
*/
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end)
*/
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction */
/* First apply standard test to bottom of matrix */
if ((d__1 = e[m - 1], abs(d__1)) <= abs(tol) * (d__2 = d__[m], abs(
d__2)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)
{
e[m - 1] = 0.;
goto L50;
}
if (tol >= 0.) {
/* If relative accuracy desired, */
/* apply convergence criterion forward */
mu = (d__1 = d__[ll], abs(d__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L50;
}
sminlo = sminl;
mu = (d__1 = d__[lll + 1], abs(d__1)) * (mu / (mu + (d__2 = e[
lll], abs(d__2))));
sminl = min(sminl,mu);
/* L90: */
}
}
} else {
/* Run convergence test in backward direction */
/* First apply standard test to top of matrix */
if ((d__1 = e[ll], abs(d__1)) <= abs(tol) * (d__2 = d__[ll], abs(d__2)
) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
e[ll] = 0.;
goto L50;
}
if (tol >= 0.) {
/* If relative accuracy desired, */
/* apply convergence criterion backward */
mu = (d__1 = d__[m], abs(d__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L50;
}
sminlo = sminl;
mu = (d__1 = d__[lll], abs(d__1)) * (mu / (mu + (d__2 = e[lll]
, abs(d__2))));
sminl = min(sminl,mu);
/* L100: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative */
/* accuracy, and if so set the shift to zero. */
/* Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector upda
tes */
cs = 1.;
oldcs = 1.;
d__1 = d__[ll] * cs;
dlartg_(&d__1, &e[ll], &cs, &sn, &r__);
d__1 = oldcs * r__;
d__2 = d__[ll + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[ll]);
rwork[1] = cs;
rwork[nm1 + 1] = sn;
rwork[nm12 + 1] = oldcs;
rwork[nm13 + 1] = oldsn;
irot = 1;
i__1 = m - 1;
for (i__ = ll + 1; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
e[i__ - 1] = oldsn * r__;
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
++irot;
rwork[irot] = cs;
rwork[irot + nm1] = sn;
rwork[irot + nm12] = oldcs;
rwork[irot + nm13] = oldsn;
/* L110: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[
ll + vt_dim1], ldvt, 1L, 1L, 1L);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u[ll * u_dim1 + 1], ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c__[ll + c_dim1], ldc, 1L, 1L, 1L);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector upda
tes */
cs = 1.;
oldcs = 1.;
d__1 = d__[m] * cs;
dlartg_(&d__1, &e[m - 1], &cs, &sn, &r__);
d__1 = oldcs * r__;
d__2 = d__[m - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[m]);
rwork[m - ll] = cs;
rwork[m - ll + nm1] = -sn;
rwork[m - ll + nm12] = oldcs;
rwork[m - ll + nm13] = -oldsn;
irot = m - ll;
i__1 = ll + 1;
for (i__ = m - 1; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
e[i__] = oldsn * r__;
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
--irot;
rwork[irot] = cs;
rwork[irot + nm1] = -sn;
rwork[irot + nm12] = oldcs;
rwork[irot + nm13] = -oldsn;
/* L120: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt[ll + vt_dim1], ldvt, 1L, 1L, 1L);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
ll * u_dim1 + 1], ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
ll + c_dim1], ldc, 1L, 1L, 1L);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector upda
tes */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b48, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
dlartg_(&f, &g, &cosr, &sinr, &r__);
f = cosr * d__[ll] + sinr * e[ll];
e[ll] = cosr * e[ll] - sinr * d__[ll];
g = sinr * d__[ll + 1];
d__[ll + 1] = cosr * d__[ll + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[ll] = r__;
f = cosl * e[ll] + sinl * d__[ll + 1];
d__[ll + 1] = cosl * d__[ll + 1] - sinl * e[ll];
g = sinl * e[ll + 1];
e[ll + 1] = cosl * e[ll + 1];
rwork[1] = cosr;
rwork[nm1 + 1] = sinr;
rwork[nm12 + 1] = cosl;
rwork[nm13 + 1] = sinl;
irot = 1;
i__1 = m - 2;
for (i__ = ll + 1; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
e[i__ - 1] = r__;
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
++irot;
rwork[irot] = cosr;
rwork[irot + nm1] = sinr;
rwork[irot + nm12] = cosl;
rwork[irot + nm13] = sinl;
/* L130: */
}
dlartg_(&f, &g, &cosr, &sinr, &r__);
e[m - 2] = r__;
f = cosr * d__[m - 1] + sinr * e[m - 1];
e[m - 1] = cosr * e[m - 1] - sinr * d__[m - 1];
g = sinr * d__[m];
d__[m] = cosr * d__[m];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[m - 1] = r__;
f = cosl * e[m - 1] + sinl * d__[m];
d__[m] = cosl * d__[m] - sinl * e[m - 1];
++irot;
rwork[irot] = cosr;
rwork[irot + nm1] = sinr;
rwork[irot + nm12] = cosl;
rwork[irot + nm13] = sinl;
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[
ll + vt_dim1], ldvt, 1L, 1L, 1L);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u[ll * u_dim1 + 1], ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c__[ll + c_dim1], ldc, 1L, 1L, 1L);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector upda
tes */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b48, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
dlartg_(&f, &g, &cosr, &sinr, &r__);
f = cosr * d__[m] + sinr * e[m - 1];
e[m - 1] = cosr * e[m - 1] - sinr * d__[m];
g = sinr * d__[m - 1];
d__[m - 1] = cosr * d__[m - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[m] = r__;
f = cosl * e[m - 1] + sinl * d__[m - 1];
d__[m - 1] = cosl * d__[m - 1] - sinl * e[m - 1];
g = sinl * e[m - 2];
e[m - 2] = cosl * e[m - 2];
rwork[m - ll] = cosr;
rwork[m - ll + nm1] = -sinr;
rwork[m - ll + nm12] = cosl;
rwork[m - ll + nm13] = -sinl;
irot = m - ll;
i__1 = ll + 2;
for (i__ = m - 1; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
e[i__] = r__;
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
--irot;
rwork[irot] = cosr;
rwork[irot + nm1] = -sinr;
rwork[irot + nm12] = cosl;
rwork[irot + nm13] = -sinl;
/* L140: */
}
dlartg_(&f, &g, &cosr, &sinr, &r__);
e[ll + 1] = r__;
f = cosr * d__[ll + 1] + sinr * e[ll];
e[ll] = cosr * e[ll] - sinr * d__[ll + 1];
g = sinr * d__[ll];
d__[ll] = cosr * d__[ll];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[ll + 1] = r__;
f = cosl * e[ll] + sinl * d__[ll];
d__[ll] = cosl * d__[ll] - sinl * e[ll];
--irot;
rwork[irot] = cosr;
rwork[irot + nm1] = -sinr;
rwork[irot + nm12] = cosl;
rwork[irot + nm13] = -sinl;
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt[ll + vt_dim1], ldvt, 1L, 1L, 1L);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
ll * u_dim1 + 1], ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
ll + c_dim1], ldc, 1L, 1L, 1L);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L50;
/* All singular values converged, so make them positive */
L150:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
zdscal_(ncvt, &c_b71, &vt[i__ + vt_dim1], ldvt);
}
}
/* L160: */
}
/* Sort the singular values into decreasing order (insertion sort on
*/
/* singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L170: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
zswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
vt_dim1], ldvt);
}
if (*nru > 0) {
zswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
u_dim1 + 1], &c__1);
}
if (*ncc > 0) {
zswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
c_dim1], ldc);
}
}
/* L180: */
}
goto L210;
/* Maximum number of iterations exceeded, failure to converge */
L190:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L200: */
}
L210:
return 0;
/* End of ZBDSQR */
} /* zbdsqr_ */
/* zlarfg.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b5
#undef c_b5
#endif
#define c_b5 c_b5
/* Subroutine */ int zlarfg_(n, alpha, x, incx, tau)
integer *n;
doublecomplex *alpha, *x;
integer *incx;
doublecomplex *tau;
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(), d_sign();
/* Local variables */
static doublereal beta;
static integer j;
static doublereal alphi, alphr;
extern /* Subroutine */ int zscal_();
static doublereal xnorm;
extern doublereal dlapy3_(), dznrm2_(), dlamch_();
static doublereal safmin;
extern /* Subroutine */ int zdscal_();
static doublereal rsafmn;
extern /* Double Complex */ VOID zladiv_();
static integer knt;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARFG generates a complex elementary reflector H of order n, such */
/* that */
/* H' * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, with beta real, and x is an */
/* (n-1)-element complex vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a complex scalar and v is a complex (n-1)-element */
/* vector. Note that H is not hermitian. */
/* If the elements of x are all zero and alpha is real, then tau = 0 */
/* and H is taken to be the unit matrix. */
/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) COMPLEX*16 */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) COMPLEX*16 array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) COMPLEX*16 */
/* The value tau. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0. && alphi == 0.) {
/* H = I */
tau->r = 0., tau->i = 0.;
} else {
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
safmin = dlamch_("S", 1L) / dlamch_("E", 1L);
rsafmn = 1. / safmin;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute
them */
knt = 0;
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy
*/
alpha->r = beta, alpha->i = 0.;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
z__1.r = safmin * alpha->r, z__1.i = safmin * alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
/* L20: */
}
} else {
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
alpha->r = beta, alpha->i = 0.;
}
}
return 0;
/* End of ZLARFG */
} /* zlarfg_ */
/* zlarf.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1a
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2a
/* Subroutine */ int zlarf_(side, m, n, v, incv, tau, c__, ldc, work,
side_len)
char *side;
integer *m, *n;
doublecomplex *v;
integer *incv;
doublecomplex *tau, *c__;
integer *ldc;
doublecomplex *work;
ftnlen side_len;
{
/* System generated locals */
integer c_dim1, c_offset;
doublecomplex z__1;
/* Local variables */
extern logical lsame_();
extern /* Subroutine */ int zgerc_(), zgemv_();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARF applies a complex elementary reflector H to a complex M-by-N */
/* matrix C, from either the left or the right. H is represented in the
*/
/* form */
/* H = I - tau * v * v' */
/* where tau is a complex scalar and v is a complex vector. */
/* If tau = 0, then H is taken to be the unit matrix. */
/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead
*/
/* tau. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* V (input) COMPLEX*16 array, dimension */
/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
/* The vector v in the representation of H. V is not used if */
/* TAU = 0. */
/* INCV (input) INTEGER */
/* The increment between elements of v. INCV <> 0. */
/* TAU (input) COMPLEX*16 */
/* The value tau in the representation of H. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*/
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C */
if (tau->r != 0. || tau->i != 0.) {
/* w := C' * v */
zgemv_("Conjugate transpose", m, n, &c_b1, &c__[c_offset], ldc, &
v[1], incv, &c_b2, &work[1], &c__1, 19L);
/* C := C - v * w' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
ldc);
}
} else {
/* Form C * H */
if (tau->r != 0. || tau->i != 0.) {
/* w := C * v */
zgemv_("No transpose", m, n, &c_b1, &c__[c_offset], ldc, &v[1],
incv, &c_b2, &work[1], &c__1, 12L);
/* C := C - w * v' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, n, &z__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
ldc);
}
}
return 0;
/* End of ZLARF */
} /* zlarf_ */
/* zgelqf.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zgelqf_(m, n, a, lda, tau, work, lwork, info)
integer *m, *n;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, k, nbmin, iinfo;
extern /* Subroutine */ int zgelq2_();
static integer ib, nb, nx;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zlarfb_();
static integer ldwork;
extern /* Subroutine */ int zlarft_();
static integer iws;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGELQF computes an LQ factorization of a complex M-by-N matrix A: */
/* A = L * Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the elements on and below the diagonal of the array
*/
/* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
/* lower triangular if m <= n); the elements above the diagonal,
*/
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,M). */
/* For optimum performance LWORK >= M*NB, where NB is the */
/* optimal blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* 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). */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 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;
} else if (*lwork < max(1,*m)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGELQF", &i__1, 6L);
return 0;
}
/* Quick return if possible */
k = min(*m,*n);
if (k == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
nbmin = 2;
nx = 0;
iws = *m;
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code.
*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "ZGELQF", " ", m, n, &c_n1, &c_n1, 6L,
1L);
nx = max(i__1,i__2);
if (nx < k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *m;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZGELQF", " ", m, n, &c_n1, &
c_n1, 6L, 1L);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Compute the LQ factorization of the current block */
/* A(i:i+ib-1,i:n) */
i__3 = *n - i__ + 1;
zgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo);
if (i__ + ib <= *m) {
/* Form the triangular factor of the block reflec
tor */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *n - i__ + 1;
zlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 7L);
/* Apply H to A(i+ib:m,i:n) from the right */
i__3 = *m - i__ - ib + 1;
i__4 = *n - i__ + 1;
zlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3,
&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
1], &ldwork, 5L, 12L, 7L, 7L);
}
/* L10: */
}
} else {
i__ = 1;
}
/* Use unblocked code to factor the last or only block. */
if (i__ <= k) {
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
zgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
}
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZGELQF */
} /* zgelqf_ */
/* zgebal.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zgebal_(job, n, a, lda, ilo, ihi, scale, info, job_len)
char *job;
integer *n;
doublecomplex *a;
integer *lda, *ilo, *ihi;
doublereal *scale;
integer *info;
ftnlen job_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(), z_abs();
/* Local variables */
static integer iexc;
static doublereal c__, f, g;
static integer i__, j, k, l, m;
static doublereal r__, s;
extern logical lsame_();
extern /* Subroutine */ int zswap_();
static doublereal sfmin1, sfmin2, sfmax1, sfmax2, ca, ra;
extern doublereal dlamch_();
extern /* Subroutine */ int xerbla_(), zdscal_();
extern integer izamax_();
static logical noconv;
static integer ica, ira;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEBAL balances a general complex matrix A. This involves, first, */
/* permuting A by a similarity transformation to isolate eigenvalues */
/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
/* diagonal; and second, applying a diagonal similarity transformation */
/* to rows and columns ILO to IHI to make the rows and columns as */
/* close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrix, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A: */
/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
/* for i = 1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to integers such that on exit */
/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied to */
/* A. If P(j) is the index of the row and column interchanged */
/* with row and column j and D(j) is the scaling factor */
/* applied to row and column j, then */
/* SCALE(j) = P(j) for j = 1,...,ILO-1 */
/* = D(j) for j = ILO,...,IHI */
/* = P(j) for j = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The permutations consist of row and column interchanges which put */
/* the matrix in the form */
/* ( T1 X Y ) */
/* P A P = ( 0 B Z ) */
/* ( 0 0 T2 ) */
/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
/* along the diagonal. The column indices ILO and IHI mark the starting
*/
/* and ending columns of the submatrix B. Balancing consists of applying
*/
/* a diagonal similarity transformation inv(D) * B * D to make the */
/* 1-norms of each row of B and its corresponding column nearly equal. */
/* The output matrix is */
/* ( T1 X*D Y ) */
/* ( 0 inv(D)*B*D inv(D)*Z ). */
/* ( 0 0 T2 ) */
/* Information about the permutations P and the diagonal matrix D is */
/* returned in the vector SCALE. */
/* This subroutine is based on the EISPACK routine CBAL. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--scale;
/* Function Body */
*info = 0;
if (! lsame_(job, "N", 1L, 1L) && ! lsame_(job, "P", 1L, 1L) && ! lsame_(
job, "S", 1L, 1L) && ! lsame_(job, "B", 1L, 1L)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEBAL", &i__1, 6L);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (lsame_(job, "N", 1L, 1L)) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S", 1L, 1L)) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (doublereal) j;
if (j == m) {
goto L30;
}
zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
zswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch ((int)iexc) {
case 1: goto L40;
case 2: goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
i__2 = j + i__ * a_dim1;
if (a[i__2].r != 0. || d_imag(&a[j + i__ * a_dim1]) != 0.) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
i__3 = i__ + j * a_dim1;
if (a[i__3].r != 0. || d_imag(&a[i__ + j * a_dim1]) != 0.) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L130: */
}
if (lsame_(job, "P", 1L, 1L)) {
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
sfmin1 = dlamch_("S", 1L) / dlamch_("P", 1L);
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 10.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.;
r__ = 0.;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
i__3 = j + i__ * a_dim1;
c__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j + i__ *
a_dim1]), abs(d__2));
i__3 = i__ + j * a_dim1;
r__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
a_dim1]), abs(d__2));
L150:
;
}
ica = izamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = z_abs(&a[ica + i__ * a_dim1]);
i__2 = *n - k + 1;
ira = izamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = z_abs(&a[i__ + (ira + k - 1) * a_dim1]);
/* Guard against zero C or R due to underflow. */
if (c__ == 0. || r__ == 0.) {
goto L200;
}
g = r__ / 10.;
f = 1.;
s = c__ + r__;
L160:
/* Computing MAX */
d__1 = max(f,c__);
/* Computing MIN */
d__2 = min(r__,g);
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
goto L170;
}
f *= 10.;
c__ *= 10.;
ca *= 10.;
r__ /= 10.;
g /= 10.;
ra /= 10.;
goto L160;
L170:
g = c__ / 10.;
L180:
/* Computing MIN */
d__1 = min(f,c__), d__1 = min(d__1,g);
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
goto L190;
}
f /= 10.;
c__ /= 10.;
g /= 10.;
ca /= 10.;
r__ *= 10.;
ra *= 10.;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95) {
goto L200;
}
if (f < 1. && scale[i__] < 1.) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1. && scale[i__] > 1.) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
zdscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
zdscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of ZGEBAL */
} /* zgebal_ */
/* zunmlq.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zunmlq_(side, trans, m, n, k, a, lda, tau, c__, ldc,
work, lwork, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *c__;
integer *ldc;
doublecomplex *work;
integer *lwork, *info;
ftnlen side_len;
ftnlen trans_len;
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat();
/* Local variables */
static logical left;
static integer i__;
static doublecomplex t[4160] /* was [65][64] */;
extern logical lsame_();
static integer nbmin, iinfo, i1, i2, i3, ib, ic, jc, nb, mi, ni;
extern /* Subroutine */ int zunml2_();
static integer nq, nw;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zlarfb_();
static logical notran;
static integer ldwork;
extern /* Subroutine */ int zlarft_();
static char transt[1];
static integer iws;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNMLQ 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 defined as the product of k */
/* elementary reflectors */
/* Q = H(k)' . . . H(2)' H(1)' */
/* as returned by ZGELQF. 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**H from the Left; */
/* = 'R': apply Q or Q**H from the Right. */
/* 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. */
/* 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*16 array, dimension */
/* (LDA,M) if SIDE = 'L', */
/* (LDA,N) if SIDE = 'R' */
/* The i-th row must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by
*/
/* ZGELQF 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*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGELQF. */
/* C (input/output) COMPLEX*16 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/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C", 1L, 1L)) {
*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;
} else if (*lwork < max(1,nw)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNMLQ", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size. NB may be at most NBMAX, where NBMAX */
/* is used to define the local array T. */
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMLQ", ch__1, m, n, k, &c_n1, 6L, 2L);
nb = min(i__1,i__2);
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMLQ", ch__1, m, n, k, &c_n1,
6L, 2L);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
zunml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, 1L, 1L);
} else {
/* Use blocked code */
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
if (notran) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1;
zlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1],
lda, &tau[i__], t, &c__65, 7L, 7L);
if (left) {
/* H or H' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H' */
zlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__
+ i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1],
ldc, &work[1], &ldwork, 1L, 1L, 7L, 7L);
/* L10: */
}
}
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZUNMLQ */
} /* zunmlq_ */
/* zgebak.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zgebak_(job, side, n, ilo, ihi, scale, m, v, ldv, info,
job_len, side_len)
char *job, *side;
integer *n, *ilo, *ihi;
doublereal *scale;
integer *m;
doublecomplex *v;
integer *ldv, *info;
ftnlen job_len;
ftnlen side_len;
{
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
static integer i__, k;
static doublereal s;
extern logical lsame_();
static logical leftv;
extern /* Subroutine */ int zswap_();
static integer ii;
extern /* Subroutine */ int xerbla_(), zdscal_();
static logical rightv;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEBAK forms the right or left eigenvectors of a complex general */
/* matrix by backward transformation on the computed eigenvectors of the
*/
/* balanced matrix output by ZGEBAL. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the type of backward transformation required: */
/* = 'N', do nothing, return immediately; */
/* = 'P', do backward transformation for permutation only; */
/* = 'S', do backward transformation for scaling only; */
/* = 'B', do backward transformations for both permutation and */
/* scaling. */
/* JOB must be the same as the argument JOB supplied to ZGEBAL.
*/
/* SIDE (input) CHARACTER*1 */
/* = 'R': V contains right eigenvectors; */
/* = 'L': V contains left eigenvectors. */
/* N (input) INTEGER */
/* The number of rows of the matrix V. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* The integers ILO and IHI determined by ZGEBAL. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* SCALE (input) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutation and scaling factors, as returned */
/* by ZGEBAL. */
/* M (input) INTEGER */
/* The number of columns of the matrix V. M >= 0. */
/* V (input/output) COMPLEX*16 array, dimension (LDV,M) */
/* On entry, the matrix of right or left eigenvectors to be */
/* transformed, as returned by ZHSEIN or ZTREVC. */
/* On exit, V is overwritten by the transformed eigenvectors. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,N). */
/* 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 .. */
/* Decode and Test the input parameters */
/* Parameter adjustments */
--scale;
v_dim1 = *ldv;
v_offset = v_dim1 + 1;
v -= v_offset;
/* Function Body */
rightv = lsame_(side, "R", 1L, 1L);
leftv = lsame_(side, "L", 1L, 1L);
*info = 0;
if (! lsame_(job, "N", 1L, 1L) && ! lsame_(job, "P", 1L, 1L) && ! lsame_(
job, "S", 1L, 1L) && ! lsame_(job, "B", 1L, 1L)) {
*info = -1;
} else if (! rightv && ! leftv) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*m < 0) {
*info = -7;
} else if (*ldv < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEBAK", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (lsame_(job, "N", 1L, 1L)) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
/* Backward balance */
if (lsame_(job, "S", 1L, 1L) || lsame_(job, "B", 1L, 1L)) {
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = scale[i__];
zdscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L10: */
}
}
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = 1. / scale[i__];
zdscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L20: */
}
}
}
/* Backward permutation */
/* For I = ILO-1 step -1 until 1, */
/* IHI+1 step 1 until N do -- */
L30:
if (lsame_(job, "P", 1L, 1L) || lsame_(job, "B", 1L, 1L)) {
if (rightv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L40;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L40;
}
zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L40:
;
}
}
if (leftv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L50;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L50;
}
zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L50:
;
}
}
}
return 0;
/* End of ZGEBAK */
} /* zgebak_ */
/* zlabrd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2
/* Subroutine */ int zlabrd_(m, n, nb, a, lda, d__, e, tauq, taup, x, ldx, y,
ldy)
integer *m, *n, *nb;
doublecomplex *a;
integer *lda;
doublereal *d__, *e;
doublecomplex *tauq, *taup, *x;
integer *ldx;
doublecomplex *y;
integer *ldy;
{
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern /* Subroutine */ int zscal_(), zgemv_(), zlarfg_(), zlacgv_();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLABRD reduces the first NB rows and columns of a complex general */
/* m by n matrix A to upper or lower real bidiagonal form by a unitary */
/* transformation Q' * A * P, and returns the matrices X and Y which */
/* are needed to apply the transformation to the unreduced part of A. */
/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
*/
/* bidiagonal form. */
/* This is an auxiliary routine called by ZGEBRD */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. */
/* NB (input) INTEGER */
/* The number of leading rows and columns of A to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, the first NB rows and columns of the matrix are */
/* overwritten; the rest of the array is unchanged. */
/* If m >= n, elements on and below the diagonal in the first NB
*/
/* columns, with the array TAUQ, represent the unitary */
/* matrix Q as a product of elementary reflectors; and */
/* elements above the diagonal in the first NB rows, with the
*/
/* array TAUP, represent the unitary matrix P as a product */
/* of elementary reflectors. */
/* If m < n, elements below the diagonal in the first NB */
/* columns, with the array TAUQ, represent the unitary */
/* matrix Q as a product of elementary reflectors, and */
/* elements on and above the diagonal in the first NB rows, */
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* D (output) DOUBLE PRECISION array, dimension (NB) */
/* The diagonal elements of the first NB rows and columns of */
/* the reduced matrix. D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (NB) */
/* The off-diagonal elements of the first NB rows and columns of
*/
/* the reduced matrix. */
/* TAUQ (output) COMPLEX*16 array dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix Q. See Further Details. */
/* TAUP (output) COMPLEX*16 array, dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix P. See Further Details. */
/* X (output) COMPLEX*16 array, dimension (LDX,NB) */
/* The m-by-nb matrix X required to update the unreduced part */
/* of A. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,M). */
/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
/* The n-by-nb matrix Y required to update the unreduced part */
/* of A. */
/* LDY (output) INTEGER */
/* The leading dimension of the array Y. LDY >= max(1,N). */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, and v and u are complex */
/* vectors. */
/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The elements of the vectors v and u together form the m-by-nb matrix
*/
/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply
*/
/* the transformation to the unreduced part of the matrix, using a block
*/
/* update of the form: A := A - V*Y' - X*U'. */
/* The contents of A on exit are illustrated by the following examples */
/* with nb = 2: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix which is unchanged,
*/
/* vi denotes an element of the vector defining H(i), and ui an element
*/
/* of the vector defining G(i). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
x_dim1 = *ldx;
x_offset = x_dim1 + 1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = y_dim1 + 1;
y -= y_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda,
&y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], &
c__1, 12L);
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + x_dim1], ldx,
&a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ *
a_dim1], &c__1, 12L);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1, &
tauq[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
if (i__ < *n) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + (
i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], &
c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1, 19L);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ +
a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
y[i__ * y_dim1 + 1], &c__1, 19L);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
i__ + 1 + i__ * y_dim1], &c__1, 12L);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ +
x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
y[i__ * y_dim1 + 1], &c__1, 19L);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ +
1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1, 19L);
i__2 = *n - i__;
zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
zlacgv_(&i__, &a[i__ + a_dim1], lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &y[i__ + 1 +
y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + (
i__ + 1) * a_dim1], lda, 12L);
zlacgv_(&i__, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ +
1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &
a[i__ + (i__ + 1) * a_dim1], lda, 19L);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
/* Generate reflection P(i) to annihilate A(i,i+2
:n) */
i__2 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, &
taup[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + (i__ + 1) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__
+ 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1
+ y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b1, &x[i__ * x_dim1 + 1], &c__1, 19L);
i__2 = *m - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b1, &x[i__ * x_dim1 + 1], &c__1, 12L);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = *m - i__;
zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i,i:n) */
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + y_dim1], ldy,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1],
lda, 12L);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[i__ *
a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ +
i__ * a_dim1], lda, 19L);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
/* Generate reflection P(i) to annihilate A(i,i+1:n) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, &
taup[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
if (i__ < *m) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ *
a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ +
y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
i__ * x_dim1 + 1], &c__1, 19L);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 +
1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ *
x_dim1 + 1], &c__1, 12L);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = *m - i__;
zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
/* Update A(i+1:m,i) */
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ +
1 + i__ * a_dim1], &c__1, 12L);
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &x[i__ + 1 +
x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[
i__ + 1 + i__ * a_dim1], &c__1, 12L);
/* Generate reflection Q(i) to annihilate A(i+2:m
,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1,
&tauq[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1]
, &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1,
19L);
i__2 = *m - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &y[i__ * y_dim1 + 1], &c__1, 19L);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
i__ + 1 + i__ * y_dim1], &c__1, 12L);
i__2 = *m - i__;
zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1
+ x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &y[i__ * y_dim1 + 1], &c__1, 19L);
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &i__, &i__2, &z__1, &a[(i__ + 1)
* a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1, 19L);
i__2 = *n - i__;
zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
} else {
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
}
/* L20: */
}
}
return 0;
/* End of ZLABRD */
} /* zlabrd_ */
/* zgesvd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b1
#undef c_b1
#endif
#define c_b1 c_b1
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2
/* Subroutine */ int zgesvd_(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt,
work, lwork, rwork, info, jobu_len, jobvt_len)
char *jobu, *jobvt;
integer *m, *n;
doublecomplex *a;
integer *lda;
doublereal *s;
doublecomplex *u;
integer *ldu;
doublecomplex *vt;
integer *ldvt;
doublecomplex *work;
integer *lwork;
doublereal *rwork;
integer *info;
ftnlen jobu_len;
ftnlen jobvt_len;
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2],
i__2, i__3, i__4;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat();
double sqrt();
/* Local variables */
static doublecomplex cdum[1];
static integer iscl;
static doublereal anrm;
static integer ierr, itau, ncvt, nrvt, i__;
extern logical lsame_();
static integer chunk, minmn;
extern /* Subroutine */ int zgemm_();
static integer wrkbl, itaup, itauq, mnthr, iwork;
static logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs;
static integer ie;
extern doublereal dlamch_();
static integer ir, iu;
extern /* Subroutine */ int dlascl_(), xerbla_(), zgebrd_();
extern integer ilaenv_();
extern doublereal zlange_();
static doublereal bignum;
extern /* Subroutine */ int zgelqf_(), zlascl_(), zgeqrf_(), zlacpy_(),
zlaset_();
static integer ldwrkr;
extern /* Subroutine */ int zbdsqr_();
static integer minwrk, ldwrku, maxwrk;
extern /* Subroutine */ int zungbr_();
static doublereal smlnum;
static integer irwork;
extern /* Subroutine */ int zunmbr_(), zunglq_();
static logical wntuas, wntvas;
extern /* Subroutine */ int zungqr_();
static integer blk, ncu;
static doublereal dum[1], eps;
static integer nru;
/* -- LAPACK driver routine (version 2.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 */
/* ======= */
/* ZGESVD computes the singular value decomposition (SVD) of a complex */
/* M-by-N matrix A, optionally computing the left and/or right singular
*/
/* vectors. The SVD is written */
/* A = U * SIGMA * conjugate-transpose(V) */
/* where SIGMA is an M-by-N matrix which is zero except for its */
/* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and */
/* V is an N-by-N unitary matrix. The diagonal elements of SIGMA */
/* are the singular values of A; they are real and non-negative, and */
/* are returned in descending order. The first min(m,n) columns of */
/* U and V are the left and right singular vectors of A. */
/* Note that the routine returns V**H, not V. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* Specifies options for computing all or part of the matrix U:
*/
/* = 'A': all M columns of U are returned in array U: */
/* = 'S': the first min(m,n) columns of U (the left singular */
/* vectors) are returned in the array U; */
/* = 'O': the first min(m,n) columns of U (the left singular */
/* vectors) are overwritten on the array A; */
/* = 'N': no columns of U (no left singular vectors) are */
/* computed. */
/* JOBVT (input) CHARACTER*1 */
/* Specifies options for computing all or part of the matrix */
/* V**H: */
/* = 'A': all N rows of V**H are returned in the array VT; */
/* = 'S': the first min(m,n) rows of V**H (the right singular */
/* vectors) are returned in the array VT; */
/* = 'O': the first min(m,n) rows of V**H (the right singular */
/* vectors) are overwritten on the array A; */
/* = 'N': no rows of V**H (no right singular vectors) are */
/* computed. */
/* JOBVT and JOBU cannot both be 'O'. */
/* M (input) INTEGER */
/* The number of rows of the input matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the input matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, */
/* if JOBU = 'O', A is overwritten with the first min(m,n) */
/* columns of U (the left singular vectors, */
/* stored columnwise); */
/* if JOBVT = 'O', A is overwritten with the first min(m,n) */
/* rows of V**H (the right singular vectors, */
/* stored rowwise); */
/* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */
/* are destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The singular values of A, sorted so that S(i) >= S(i+1). */
/* U (output) COMPLEX*16 array, dimension (LDU,UCOL) */
/* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */
/* If JOBU = 'A', U contains the M-by-M unitary matrix U; */
/* if JOBU = 'S', U contains the first min(m,n) columns of U */
/* (the left singular vectors, stored columnwise); */
/* if JOBU = 'N' or 'O', U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= 1; if */
/* JOBU = 'S' or 'A', LDU >= M. */
/* VT (output) COMPLEX*16 array, dimension (LDVT,N) */
/* If JOBVT = 'A', VT contains the N-by-N unitary matrix */
/* V**H; */
/* if JOBVT = 'S', VT contains the first min(m,n) rows of */
/* V**H (the right singular vectors, stored rowwise); */
/* if JOBVT = 'N' or 'O', VT is not referenced. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= 1; if */
/* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 1. */
/* LWORK >= 2*MIN(M,N)+MAX(M,N). */
/* For good performance, LWORK should generally be larger. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(3*min(M,N),5*min(M,N)-4)) */
/* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the */
/* unconverged superdiagonal elements of an upper bidiagonal */
/* matrix B whose diagonal is in S (not necessarily sorted). */
/* B satisfies A = U * B * VT, so it has the same singular */
/* values as A, and singular vectors related by U and VT. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if ZBDSQR did not converge, INFO specifies how many */
/* superdiagonals of an intermediate bidiagonal form B */
/* did not converge to zero. See the description of RWORK
*/
/* above for details. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--s;
u_dim1 = *ldu;
u_offset = u_dim1 + 1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = vt_dim1 + 1;
vt -= vt_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = jobu;
i__1[1] = 1, a__1[1] = jobvt;
s_cat(ch__1, a__1, i__1, &c__2, 2L);
mnthr = ilaenv_(&c__6, "ZGESVD", ch__1, m, n, &c__0, &c__0, 6L, 2L);
wntua = lsame_(jobu, "A", 1L, 1L);
wntus = lsame_(jobu, "S", 1L, 1L);
wntuas = wntua || wntus;
wntuo = lsame_(jobu, "O", 1L, 1L);
wntun = lsame_(jobu, "N", 1L, 1L);
wntva = lsame_(jobvt, "A", 1L, 1L);
wntvs = lsame_(jobvt, "S", 1L, 1L);
wntvas = wntva || wntvs;
wntvo = lsame_(jobvt, "O", 1L, 1L);
wntvn = lsame_(jobvt, "N", 1L, 1L);
minwrk = 1;
if (! (wntua || wntus || wntuo || wntun)) {
*info = -1;
} else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else if (*ldu < 1 || wntuas && *ldu < *m) {
*info = -9;
} else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) {
*info = -11;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace to */
/* real workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV.) */
if (*info == 0 && *lwork >= 1 && *m > 0 && *n > 0) {
if (*m >= *n) {
/* Space needed for ZBDSQR is BDSPAC = MAX( 3*N, 5*N-4 )
*/
if (*m >= mnthr) {
if (wntun) {
/* Path 1 (M much larger than N, JOBU='N')
*/
maxwrk = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = maxwrk, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
if (wntvo || wntvas) {
/* Computing MAX */
i__2 = maxwrk, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&
c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
minwrk = *n * 3;
maxwrk = max(minwrk,maxwrk);
} else if (wntuo && wntvn) {
/* Path 2 (M much larger than N, JOBU='O',
JOBVT='N') */
wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n;
maxwrk = max(i__2,i__3);
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
} else if (wntuo && wntvas) {
/* Path 3 (M much larger than N, JOBU='O',
JOBVT='S' or */
/* 'A') */
wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n;
maxwrk = max(i__2,i__3);
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
} else if (wntus && wntvn) {
/* Path 4 (M much larger than N, JOBU='S',
JOBVT='N') */
wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = *n * *n + wrkbl;
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
} else if (wntus && wntvo) {
/* Path 5 (M much larger than N, JOBU='S',
JOBVT='O') */
wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = (*n << 1) * *n + wrkbl;
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
} else if (wntus && wntvas) {
/* Path 6 (M much larger than N, JOBU='S',
JOBVT='S' or */
/* 'A') */
wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = *n * *n + wrkbl;
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
} else if (wntua && wntvn) {
/* Path 7 (M much larger than N, JOBU='A',
JOBVT='N') */
wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR",
" ", m, m, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = *n * *n + wrkbl;
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
} else if (wntua && wntvo) {
/* Path 8 (M much larger than N, JOBU='A',
JOBVT='O') */
wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR",
" ", m, m, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = (*n << 1) * *n + wrkbl;
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
} else if (wntua && wntvas) {
/* Path 9 (M much larger than N, JOBU='A',
JOBVT='S' or */
/* 'A') */
wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR",
" ", m, m, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = *n * *n + wrkbl;
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
}
} else {
/* Path 10 (M at least N, but not much larger) */
maxwrk = (*n << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD",
" ", m, n, &c_n1, &c_n1, 6L, 1L);
if (wntus || wntuo) {
/* Computing MAX */
i__2 = maxwrk, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "Q", m, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
if (wntua) {
/* Computing MAX */
i__2 = maxwrk, i__3 = (*n << 1) + *m * ilaenv_(&c__1,
"ZUNGBR", "Q", m, m, n, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
if (! wntvn) {
/* Computing MAX */
i__2 = maxwrk, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&
c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
minwrk = (*n << 1) + *m;
maxwrk = max(minwrk,maxwrk);
}
} else {
/* Space needed for ZBDSQR is BDSPAC = MAX( 3*M, 5*M-4 )
*/
if (*n >= mnthr) {
if (wntvn) {
/* Path 1t(N much larger than M, JOBVT='N'
) */
maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = maxwrk, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
if (wntuo || wntuas) {
/* Computing MAX */
i__2 = maxwrk, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
"ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
minwrk = *m * 3;
maxwrk = max(minwrk,maxwrk);
} else if (wntvo && wntun) {
/* Path 2t(N much larger than M, JOBU='N',
JOBVT='O') */
wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n;
maxwrk = max(i__2,i__3);
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
} else if (wntvo && wntuas) {
/* Path 3t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='O') */
wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
"ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n;
maxwrk = max(i__2,i__3);
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
} else if (wntvs && wntun) {
/* Path 4t(N much larger than M, JOBU='N',
JOBVT='S') */
wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = *m * *m + wrkbl;
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
} else if (wntvs && wntuo) {
/* Path 5t(N much larger than M, JOBU='O',
JOBVT='S') */
wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
"ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = (*m << 1) * *m + wrkbl;
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
} else if (wntvs && wntuas) {
/* Path 6t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='S') */
wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
"ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = *m * *m + wrkbl;
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
} else if (wntva && wntun) {
/* Path 7t(N much larger than M, JOBU='N',
JOBVT='A') */
wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ",
" ", n, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = *m * *m + wrkbl;
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
} else if (wntva && wntuo) {
/* Path 8t(N much larger than M, JOBU='O',
JOBVT='A') */
wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ",
" ", n, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
"ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = (*m << 1) * *m + wrkbl;
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
} else if (wntva && wntuas) {
/* Path 9t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='A') */
wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ",
" ", n, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
"ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
"ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
maxwrk = *m * *m + wrkbl;
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
}
} else {
/* Path 10t(N greater than M, but not much larger
) */
maxwrk = (*m << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD",
" ", m, n, &c_n1, &c_n1, 6L, 1L);
if (wntvs || wntvo) {
/* Computing MAX */
i__2 = maxwrk, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
"ZUNGBR", "P", m, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
if (wntva) {
/* Computing MAX */
i__2 = maxwrk, i__3 = (*m << 1) + *n * ilaenv_(&c__1,
"ZUNGBR", "P", n, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
if (! wntun) {
/* Computing MAX */
i__2 = maxwrk, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&
c__1, "ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
minwrk = (*m << 1) + *n;
maxwrk = max(minwrk,maxwrk);
}
}
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -13;
}
if (*info != 0) {
i__2 = -(*info);
xerbla_("ZGESVD", &i__2, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
if (*lwork >= 1) {
work[1].r = 1., work[1].i = 0.;
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P", 1L);
smlnum = sqrt(dlamch_("S", 1L)) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = zlange_("M", m, n, &a[a_offset], lda, dum, 1L);
iscl = 0;
if (anrm > 0. && anrm < smlnum) {
iscl = 1;
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
ierr, 1L);
} else if (anrm > bignum) {
iscl = 1;
zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
ierr, 1L);
}
if (*m >= *n) {
/* A has at least as many rows as columns. If A has sufficientl
y */
/* more rows than columns, first reduce using the QR */
/* decomposition (if sufficient workspace available) */
if (*m >= mnthr) {
if (wntun) {
/* Path 1 (M much larger than N, JOBU='N') */
/* No left singular vectors to be computed */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: need 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
i__2, &ierr);
/* Zero out below R */
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 + 2], lda,
1L);
ie = 1;
itauq = 1;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in A */
/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
itauq], &work[itaup], &work[iwork], &i__2, &ierr);
ncvt = 0;
if (wntvo || wntvas) {
/* If right singular vectors desired, gene
rate P'. */
/* (CWorkspace: need 3*N-1, prefer 2*N+(N-
1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &
work[iwork], &i__2, &ierr, 1L);
ncvt = *n;
}
irwork = ie + *n;
/* Perform bidiagonal QR iteration, computing rig
ht */
/* singular vectors of A in A if desired */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &rwork[ie], &a[
a_offset], lda, cdum, &c__1, cdum, &c__1, &rwork[
irwork], info, 1L);
/* If right singular vectors desired in VT, copy
them there */
if (wntvas) {
zlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
}
} else if (wntuo && wntvn) {
/* Path 2 (M much larger than N, JOBU='O', JOBVT=
'N') */
/* N left singular vectors to be overwritten on A
and */
/* no right singular vectors to be computed */
if (*lwork >= *n * *n + *n * 3) {
/* Sufficient workspace for a fast algorit
hm */
ir = 1;
/* Computing MAX */
i__2 = wrkbl, i__3 = *lda * *n;
if (*lwork >= max(i__2,i__3) + *lda * *n) {
/* WORK(IU) is LDA by N, WORK(IR) i
s LDA by N */
ldwrku = *lda;
ldwrkr = *lda;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = wrkbl, i__3 = *lda * *n;
if (*lwork >= max(i__2,i__3) + *n * *n) {
/* WORK(IU) is LDA by N, WORK(I
R) is N by N */
ldwrku = *lda;
ldwrkr = *n;
} else {
/* WORK(IU) is LDWRKU by N, WOR
K(IR) is N by N */
ldwrku = (*lwork - *n * *n) / *n;
ldwrkr = *n;
}
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (CWorkspace: need N*N+2*N, prefer N*N+N
+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__2, &ierr);
/* Copy R to WORK(IR) and zero out below i
t */
zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr,
1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1], &
ldwrkr, 1L);
/* Generate Q in A */
/* (CWorkspace: need N*N+2*N, prefer N*N+N
+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IR) */
/* (CWorkspace: need N*N+3*N, prefer N*N+2
*N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &i__2, &
ierr);
/* Generate left vectors bidiagonalizing R
*/
/* (CWorkspace: need N*N+3*N, prefer N*N+2
*N+N*NB) */
/* (RWorkspace: need 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of R in WORK(IR) */
/* (CWorkspace: need N*N) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie], cdum,
&c__1, &work[ir], &ldwrkr, cdum, &c__1, &rwork[
irwork], info, 1L);
iu = itauq;
/* Multiply Q in A by left singular vector
s of R in */
/* WORK(IR), storing result in WORK(IU) an
d copying to A */
/* (CWorkspace: need N*N+N, prefer N*N+M*N
) */
/* (RWorkspace: 0) */
i__2 = *m;
i__3 = ldwrku;
for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
i__3) {
/* Computing MIN */
i__4 = *m - i__ + 1;
chunk = min(i__4,ldwrku);
zgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1]
, lda, &work[ir], &ldwrkr, &c_b1, &work[iu], &
ldwrku, 1L, 1L);
zlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
a_dim1], lda, 1L);
/* L10: */
}
} else {
/* Insufficient workspace for a fast algor
ithm */
ie = 1;
itauq = 1;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize A */
/* (CWorkspace: need 2*N+M, prefer 2*N+(M+
N)*NB) */
/* (RWorkspace: N) */
i__3 = *lwork - iwork + 1;
zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
itauq], &work[itaup], &work[iwork], &i__3, &ierr);
/* Generate left vectors bidiagonalizing A
*/
/* (CWorkspace: need 3*N, prefer 2*N+N*NB)
*/
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
work[iwork], &i__3, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of A in A */
/* (CWorkspace: need 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie], cdum,
&c__1, &a[a_offset], lda, cdum, &c__1, &rwork[
irwork], info, 1L);
}
} else if (wntuo && wntvas) {
/* Path 3 (M much larger than N, JOBU='O', JOBVT=
'S' or 'A') */
/* N left singular vectors to be overwritten on A
and */
/* N right singular vectors to be computed in VT
*/
if (*lwork >= *n * *n + *n * 3) {
/* Sufficient workspace for a fast algorit
hm */
ir = 1;
/* Computing MAX */
i__3 = wrkbl, i__2 = *lda * *n;
if (*lwork >= max(i__3,i__2) + *lda * *n) {
/* WORK(IU) is LDA by N and WORK(IR
) is LDA by N */
ldwrku = *lda;
ldwrkr = *lda;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__3 = wrkbl, i__2 = *lda * *n;
if (*lwork >= max(i__3,i__2) + *n * *n) {
/* WORK(IU) is LDA by N and WOR
K(IR) is N by N */
ldwrku = *lda;
ldwrkr = *n;
} else {
/* WORK(IU) is LDWRKU by N and
WORK(IR) is N by N */
ldwrku = (*lwork - *n * *n) / *n;
ldwrkr = *n;
}
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (CWorkspace: need N*N+2*N, prefer N*N+N
+N*NB) */
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__3, &ierr);
/* Copy R to VT, zeroing out below it */
zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
i__3 = *n - 1;
i__2 = *n - 1;
zlaset_("L", &i__3, &i__2, &c_b1, &c_b1, &vt[vt_dim1 + 2],
ldvt, 1L);
/* Generate Q in A */
/* (CWorkspace: need N*N+2*N, prefer N*N+N
+N*NB) */
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__3, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in VT, copying result t
o WORK(IR) */
/* (CWorkspace: need N*N+3*N, prefer N*N+2
*N+2*N*NB) */
/* (RWorkspace: need N) */
i__3 = *lwork - iwork + 1;
zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &i__3, &
ierr);
zlacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], &
ldwrkr, 1L);
/* Generate left vectors bidiagonalizing R
in WORK(IR) */
/* (CWorkspace: need N*N+3*N, prefer N*N+2
*N+N*NB) */
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
work[iwork], &i__3, &ierr, 1L);
/* Generate right vectors bidiagonalizing
R in VT */
/* (CWorkspace: need N*N+3*N-1, prefer N*N
+2*N+(N-1)*NB) */
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
&work[iwork], &i__3, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of R in WORK(IR) and c
omputing right */
/* singular vectors of R in VT */
/* (CWorkspace: need N*N) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &work[ir], &ldwrkr, cdum, &c__1,
&rwork[irwork], info, 1L);
iu = itauq;
/* Multiply Q in A by left singular vector
s of R in */
/* WORK(IR), storing result in WORK(IU) an
d copying to A */
/* (CWorkspace: need N*N+N, prefer N*N+M*N
) */
/* (RWorkspace: 0) */
i__3 = *m;
i__2 = ldwrku;
for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
i__2) {
/* Computing MIN */
i__4 = *m - i__ + 1;
chunk = min(i__4,ldwrku);
zgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1]
, lda, &work[ir], &ldwrkr, &c_b1, &work[iu], &
ldwrku, 1L, 1L);
zlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
a_dim1], lda, 1L);
/* L20: */
}
} else {
/* Insufficient workspace for a fast algor
ithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R */
/* (CWorkspace: need 2*N, prefer N+N*NB)
*/
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__2, &ierr);
/* Copy R to VT, zeroing out below it */
zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[vt_dim1 + 2],
ldvt, 1L);
/* Generate Q in A */
/* (CWorkspace: need 2*N, prefer N+N*NB)
*/
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in VT */
/* (CWorkspace: need 3*N, prefer 2*N+2*N*N
B) */
/* (RWorkspace: N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &i__2, &
ierr);
/* Multiply Q in A by left vectors bidiago
nalizing R */
/* (CWorkspace: need 2*N+M, prefer 2*N+M*N
B) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &
work[itauq], &a[a_offset], lda, &work[iwork], &
i__2, &ierr, 1L, 1L, 1L);
/* Generate right vectors bidiagonalizing
R in VT */
/* (CWorkspace: need 3*N-1, prefer 2*N+(N-
1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of A in A and computin
g right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1,
&rwork[irwork], info, 1L);
}
} else if (wntus) {
if (wntvn) {
/* Path 4 (M much larger than N, JOBU='S',
JOBVT='N') */
/* N left singular vectors to be computed
in U and */
/* no right singular vectors to be compute
d */
if (*lwork >= *n * *n + *n * 3) {
/* Sufficient workspace for a fast
algorithm */
ir = 1;
if (*lwork >= wrkbl + *lda * *n) {
/* WORK(IR) is LDA by N */
ldwrkr = *lda;
} else {
/* WORK(IR) is N by N */
ldwrkr = *n;
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (CWorkspace: need N*N+2*N, prefe
r N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy R to WORK(IR), zeroing out
below it */
zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
ldwrkr, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1]
, &ldwrkr, 1L);
/* Generate Q in A */
/* (CWorkspace: need N*N+2*N, prefe
r N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IR) */
/* (CWorkspace: need N*N+3*N, prefe
r N*N+2*N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Generate left vectors bidiagonal
izing R in WORK(IR) */
/* (CWorkspace: need N*N+3*N, prefe
r N*N+2*N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IR
) */
/* (CWorkspace: need N*N) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie],
cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1,
&rwork[irwork], info, 1L);
/* Multiply Q in A by left singular
vectors of R in */
/* WORK(IR), storing result in U */
/* (CWorkspace: need N*N) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
work[ir], &ldwrkr, &c_b1, &u[u_offset], ldu,
1L, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Zero out below R in A */
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
2], lda, 1L);
/* Bidiagonalize R in A */
/* (CWorkspace: need 3*N, prefer 2*
N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left vectors
bidiagonalizing R */
/* (CWorkspace: need 2*N+M, prefer
2*N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie],
cdum, &c__1, &u[u_offset], ldu, cdum, &c__1, &
rwork[irwork], info, 1L);
}
} else if (wntvo) {
/* Path 5 (M much larger than N, JOBU='S',
JOBVT='O') */
/* N left singular vectors to be computed
in U and */
/* N right singular vectors to be overwrit
ten on A */
if (*lwork >= (*n << 1) * *n + *n * 3) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + (*lda << 1) * *n) {
/* WORK(IU) is LDA by N and
WORK(IR) is LDA by N */
ldwrku = *lda;
ir = iu + ldwrku * *n;
ldwrkr = *lda;
} else if (*lwork >= wrkbl + (*lda + *n) * *n) {
/* WORK(IU) is LDA by N and
WORK(IR) is N by N */
ldwrku = *lda;
ir = iu + ldwrku * *n;
ldwrkr = *n;
} else {
/* WORK(IU) is N by N and WO
RK(IR) is N by N */
ldwrku = *n;
ir = iu + ldwrku * *n;
ldwrkr = *n;
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (CWorkspace: need 2*N*N+2*N, pre
fer 2*N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy R to WORK(IU), zeroing out
below it */
zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
, &ldwrku, 1L);
/* Generate Q in A */
/* (CWorkspace: need 2*N*N+2*N, pre
fer 2*N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IU), cop
ying result to */
/* WORK(IR) */
/* (CWorkspace: need 2*N*N+3*N,
*/
/* prefer 2*N*N+2*N+2*
N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
zlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
ldwrkr, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IU) */
/* (CWorkspace: need 2*N*N+3*N, pre
fer 2*N*N+2*N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IR) */
/* (CWorkspace: need 2*N*N+3*N-1,
*/
/* prefer 2*N*N+2*N+(N
-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IU
) and computing */
/* right singular vectors of R in W
ORK(IR) */
/* (CWorkspace: need 2*N*N) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &work[
ir], &ldwrkr, &work[iu], &ldwrku, cdum, &c__1,
&rwork[irwork], info, 1L);
/* Multiply Q in A by left singular
vectors of R in */
/* WORK(IU), storing result in U */
/* (CWorkspace: need N*N) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
work[iu], &ldwrku, &c_b1, &u[u_offset], ldu,
1L, 1L);
/* Copy right singular vectors of R
to A */
/* (CWorkspace: need N*N) */
/* (RWorkspace: 0) */
zlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
lda, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Zero out below R in A */
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
2], lda, 1L);
/* Bidiagonalize R in A */
/* (CWorkspace: need 3*N, prefer 2*
N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left vectors
bidiagonalizing R */
/* (CWorkspace: need 2*N+M, prefer
2*N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
/* Generate right vectors bidiagona
lizing R in A */
/* (CWorkspace: need 3*N-1, prefer
2*N+(N-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in A */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &a[
a_offset], lda, &u[u_offset], ldu, cdum, &
c__1, &rwork[irwork], info, 1L);
}
} else if (wntvas) {
/* Path 6 (M much larger than N, JOBU='S',
JOBVT='S' */
/* or 'A') */
/* N left singular vectors to be computed
in U and */
/* N right singular vectors to be computed
in VT */
if (*lwork >= *n * *n + *n * 3) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + *lda * *n) {
/* WORK(IU) is LDA by N */
ldwrku = *lda;
} else {
/* WORK(IU) is N by N */
ldwrku = *n;
}
itau = iu + ldwrku * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (CWorkspace: need N*N+2*N, prefe
r N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy R to WORK(IU), zeroing out
below it */
zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
, &ldwrku, 1L);
/* Generate Q in A */
/* (CWorkspace: need N*N+2*N, prefe
r N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IU), cop
ying result to VT */
/* (CWorkspace: need N*N+3*N, prefe
r N*N+2*N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
zlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
ldvt, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IU) */
/* (CWorkspace: need N*N+3*N, prefe
r N*N+2*N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate right bidiagonalizing v
ectors in VT */
/* (CWorkspace: need N*N+3*N-1,
*/
/* prefer N*N+2*N+(N-1
)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
itaup], &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IU
) and computing */
/* right singular vectors of R in V
T */
/* (CWorkspace: need N*N) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &work[iu], &ldwrku, cdum, &
c__1, &rwork[irwork], info, 1L);
/* Multiply Q in A by left singular
vectors of R in */
/* WORK(IU), storing result in U */
/* (CWorkspace: need N*N) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
work[iu], &ldwrku, &c_b1, &u[u_offset], ldu,
1L, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy R to VT, zeroing out below
it */
zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[vt_dim1
+ 2], ldvt, 1L);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in VT */
/* (CWorkspace: need 3*N, prefer 2*
N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie],
&work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left bidiagon
alizing vectors */
/* in VT */
/* (CWorkspace: need 2*N+M, prefer
2*N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
&work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
/* Generate right bidiagonalizing v
ectors in VT */
/* (CWorkspace: need 3*N-1, prefer
2*N+(N-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
itaup], &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, cdum, &
c__1, &rwork[irwork], info, 1L);
}
}
} else if (wntua) {
if (wntvn) {
/* Path 7 (M much larger than N, JOBU='A',
JOBVT='N') */
/* M left singular vectors to be computed
in U and */
/* no right singular vectors to be compute
d */
/* Computing MAX */
i__2 = *n + *m, i__3 = *n * 3;
if (*lwork >= *n * *n + max(i__2,i__3)) {
/* Sufficient workspace for a fast
algorithm */
ir = 1;
if (*lwork >= wrkbl + *lda * *n) {
/* WORK(IR) is LDA by N */
ldwrkr = *lda;
} else {
/* WORK(IR) is N by N */
ldwrkr = *n;
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need N*N+2*N, prefe
r N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Copy R to WORK(IR), zeroing out
below it */
zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
ldwrkr, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1]
, &ldwrkr, 1L);
/* Generate Q in U */
/* (CWorkspace: need N*N+N+M, prefe
r N*N+N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IR) */
/* (CWorkspace: need N*N+3*N, prefe
r N*N+2*N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Generate left bidiagonalizing ve
ctors in WORK(IR) */
/* (CWorkspace: need N*N+3*N, prefe
r N*N+2*N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IR
) */
/* (CWorkspace: need N*N) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie],
cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1,
&rwork[irwork], info, 1L);
/* Multiply Q in U by left singular
vectors of R in */
/* WORK(IR), storing result in A */
/* (CWorkspace: need N*N) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
work[ir], &ldwrkr, &c_b1, &a[a_offset], lda,
1L, 1L);
/* Copy left singular vectors of A
from A to U */
zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (CWorkspace: need N+M, prefer N+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Zero out below R in A */
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
2], lda, 1L);
/* Bidiagonalize R in A */
/* (CWorkspace: need 3*N, prefer 2*
N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left bidiagon
alizing vectors */
/* in A */
/* (CWorkspace: need 2*N+M, prefer
2*N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie],
cdum, &c__1, &u[u_offset], ldu, cdum, &c__1, &
rwork[irwork], info, 1L);
}
} else if (wntvo) {
/* Path 8 (M much larger than N, JOBU='A',
JOBVT='O') */
/* M left singular vectors to be computed
in U and */
/* N right singular vectors to be overwrit
ten on A */
/* Computing MAX */
i__2 = *n + *m, i__3 = *n * 3;
if (*lwork >= (*n << 1) * *n + max(i__2,i__3)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + (*lda << 1) * *n) {
/* WORK(IU) is LDA by N and
WORK(IR) is LDA by N */
ldwrku = *lda;
ir = iu + ldwrku * *n;
ldwrkr = *lda;
} else if (*lwork >= wrkbl + (*lda + *n) * *n) {
/* WORK(IU) is LDA by N and
WORK(IR) is N by N */
ldwrku = *lda;
ir = iu + ldwrku * *n;
ldwrkr = *n;
} else {
/* WORK(IU) is N by N and WO
RK(IR) is N by N */
ldwrku = *n;
ir = iu + ldwrku * *n;
ldwrkr = *n;
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need 2*N*N+2*N, pre
fer 2*N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (CWorkspace: need 2*N*N+N+M, pre
fer 2*N*N+N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy R to WORK(IU), zeroing out
below it */
zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
, &ldwrku, 1L);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IU), cop
ying result to */
/* WORK(IR) */
/* (CWorkspace: need 2*N*N+3*N,
*/
/* prefer 2*N*N+2*N+2*
N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
zlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
ldwrkr, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IU) */
/* (CWorkspace: need 2*N*N+3*N, pre
fer 2*N*N+2*N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IR) */
/* (CWorkspace: need 2*N*N+3*N-1,
*/
/* prefer 2*N*N+2*N+(N
-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IU
) and computing */
/* right singular vectors of R in W
ORK(IR) */
/* (CWorkspace: need 2*N*N) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &work[
ir], &ldwrkr, &work[iu], &ldwrku, cdum, &c__1,
&rwork[irwork], info, 1L);
/* Multiply Q in U by left singular
vectors of R in */
/* WORK(IU), storing result in A */
/* (CWorkspace: need N*N) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
work[iu], &ldwrku, &c_b1, &a[a_offset], lda,
1L, 1L);
/* Copy left singular vectors of A
from A to U */
zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Copy right singular vectors of R
from WORK(IR) to A */
zlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
lda, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (CWorkspace: need N+M, prefer N+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Zero out below R in A */
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
2], lda, 1L);
/* Bidiagonalize R in A */
/* (CWorkspace: need 3*N, prefer 2*
N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left bidiagon
alizing vectors */
/* in A */
/* (CWorkspace: need 2*N+M, prefer
2*N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
/* Generate right bidiagonalizing v
ectors in A */
/* (CWorkspace: need 3*N-1, prefer
2*N+(N-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in A */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &a[
a_offset], lda, &u[u_offset], ldu, cdum, &
c__1, &rwork[irwork], info, 1L);
}
} else if (wntvas) {
/* Path 9 (M much larger than N, JOBU='A',
JOBVT='S' */
/* or 'A') */
/* M left singular vectors to be computed
in U and */
/* N right singular vectors to be computed
in VT */
/* Computing MAX */
i__2 = *n + *m, i__3 = *n * 3;
if (*lwork >= *n * *n + max(i__2,i__3)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + *lda * *n) {
/* WORK(IU) is LDA by N */
ldwrku = *lda;
} else {
/* WORK(IU) is N by N */
ldwrku = *n;
}
itau = iu + ldwrku * *n;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need N*N+2*N, prefe
r N*N+N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (CWorkspace: need N*N+N+M, prefe
r N*N+N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy R to WORK(IU), zeroing out
below it */
zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
, &ldwrku, 1L);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IU), cop
ying result to VT */
/* (CWorkspace: need N*N+3*N, prefe
r N*N+2*N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
zlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
ldvt, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IU) */
/* (CWorkspace: need N*N+3*N, prefe
r N*N+2*N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate right bidiagonalizing v
ectors in VT */
/* (CWorkspace: need N*N+3*N-1,
*/
/* prefer N*N+2*N+(N-1
)*NB) */
/* (RWorkspace: need 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
itaup], &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IU
) and computing */
/* right singular vectors of R in V
T */
/* (CWorkspace: need N*N) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &work[iu], &ldwrku, cdum, &
c__1, &rwork[irwork], info, 1L);
/* Multiply Q in U by left singular
vectors of R in */
/* WORK(IU), storing result in A */
/* (CWorkspace: need N*N) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
work[iu], &ldwrku, &c_b1, &a[a_offset], lda,
1L, 1L);
/* Copy left singular vectors of A
from A to U */
zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (CWorkspace: need 2*N, prefer N+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (CWorkspace: need N+M, prefer N+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy R from A to VT, zeroing out
below it */
zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[vt_dim1
+ 2], ldvt, 1L);
ie = 1;
itauq = itau;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in VT */
/* (CWorkspace: need 3*N, prefer 2*
N+2*N*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie],
&work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left bidiagon
alizing vectors */
/* in VT */
/* (CWorkspace: need 2*N+M, prefer
2*N+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
&work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
/* Generate right bidiagonalizing v
ectors in VT */
/* (CWorkspace: need 3*N-1, prefer
2*N+(N-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
itaup], &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, cdum, &
c__1, &rwork[irwork], info, 1L);
}
}
}
} else {
/* M .LT. MNTHR */
/* Path 10 (M at least N, but not much larger) */
/* Reduce to bidiagonal form without QR decomposition */
ie = 1;
itauq = 1;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize A */
/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
/* (RWorkspace: need N) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
&work[itaup], &work[iwork], &i__2, &ierr);
if (wntuas) {
/* If left singular vectors desired in U, copy re
sult to U */
/* and generate left bidiagonalizing vectors in U
*/
/* (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB)
*/
/* (RWorkspace: 0) */
zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L);
if (wntus) {
ncu = *n;
}
if (wntua) {
ncu = *m;
}
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], &
work[iwork], &i__2, &ierr, 1L);
}
if (wntvas) {
/* If right singular vectors desired in VT, copy
result to */
/* VT and generate right bidiagonalizing vectors
in VT */
/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*/
/* (RWorkspace: 0) */
zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt,
1L);
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
work[iwork], &i__2, &ierr, 1L);
}
if (wntuo) {
/* If left singular vectors desired in A, generat
e left */
/* bidiagonalizing vectors in A */
/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
iwork], &i__2, &ierr, 1L);
}
if (wntvo) {
/* If right singular vectors desired in A, genera
te right */
/* bidiagonalizing vectors in A */
/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*/
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[
iwork], &i__2, &ierr, 1L);
}
irwork = ie + *n;
if (wntuas || wntuo) {
nru = *m;
}
if (wntun) {
nru = 0;
}
if (wntvas || wntvo) {
ncvt = *n;
}
if (wntvn) {
ncvt = 0;
}
if (! wntuo && ! wntvo) {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in U and computing right
singular */
/* vectors in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, cdum, &c__1, &
rwork[irwork], info, 1L);
} else if (! wntuo && wntvo) {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in U and computing right
singular */
/* vectors in A */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &a[
a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
rwork[irwork], info, 1L);
} else {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in A and computing right
singular */
/* vectors in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, &
rwork[irwork], info, 1L);
}
}
} else {
/* A has more columns than rows. If A has sufficiently more */
/* columns than rows, first reduce using the LQ decomposition (
if */
/* sufficient workspace available) */
if (*n >= mnthr) {
if (wntvn) {
/* Path 1t(N much larger than M, JOBVT='N') */
/* No right singular vectors to be computed */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q */
/* (CWorkspace: need 2*M, prefer M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
i__2, &ierr);
/* Zero out above L */
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1]
, lda, 1L);
ie = 1;
itauq = 1;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in A */
/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &work[
itauq], &work[itaup], &work[iwork], &i__2, &ierr);
if (wntuo || wntuas) {
/* If left singular vectors desired, gener
ate Q */
/* (CWorkspace: need 3*M, prefer 2*M+M*NB)
*/
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &
work[iwork], &i__2, &ierr, 1L);
}
irwork = ie + *m;
nru = 0;
if (wntuo || wntuas) {
nru = *m;
}
/* Perform bidiagonal QR iteration, computing lef
t singular */
/* vectors of A in A if desired */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &rwork[ie], cdum, &
c__1, &a[a_offset], lda, cdum, &c__1, &rwork[irwork],
info, 1L);
/* If left singular vectors desired in U, copy th
em there */
if (wntuas) {
zlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu,
1L);
}
} else if (wntvo && wntun) {
/* Path 2t(N much larger than M, JOBU='N', JOBVT=
'O') */
/* M right singular vectors to be overwritten on
A and */
/* no left singular vectors to be computed */
if (*lwork >= *m * *m + *m * 3) {
/* Sufficient workspace for a fast algorit
hm */
ir = 1;
/* Computing MAX */
i__2 = wrkbl, i__3 = *lda * *n;
if (*lwork >= max(i__2,i__3) + *lda * *m) {
/* WORK(IU) is LDA by N and WORK(IR
) is LDA by M */
ldwrku = *lda;
chunk = *n;
ldwrkr = *lda;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = wrkbl, i__3 = *lda * *n;
if (*lwork >= max(i__2,i__3) + *m * *m) {
/* WORK(IU) is LDA by N and WOR
K(IR) is M by M */
ldwrku = *lda;
chunk = *n;
ldwrkr = *m;
} else {
/* WORK(IU) is M by CHUNK and W
ORK(IR) is M by M */
ldwrku = *m;
chunk = (*lwork - *m * *m) / *m;
ldwrkr = *m;
}
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (CWorkspace: need M*M+2*M, prefer M*M+M
+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__2, &ierr);
/* Copy L to WORK(IR) and zero out above i
t */
zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr,
1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
ldwrkr], &ldwrkr, 1L);
/* Generate Q in A */
/* (CWorkspace: need M*M+2*M, prefer M*M+M
+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IR) */
/* (CWorkspace: need M*M+3*M, prefer M*M+2
*M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &i__2, &
ierr);
/* Generate right vectors bidiagonalizing
L */
/* (CWorkspace: need M*M+3*M-1, prefer M*M
+2*M+(M-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration, comput
ing right */
/* singular vectors of L in WORK(IR) */
/* (CWorkspace: need M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &work[
ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &rwork[
irwork], info, 1L);
iu = itauq;
/* Multiply right singular vectors of L in
WORK(IR) by Q */
/* in A, storing result in WORK(IU) and co
pying to A */
/* (CWorkspace: need M*M+M, prefer M*M+M*N
) */
/* (RWorkspace: 0) */
i__2 = *n;
i__3 = chunk;
for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
i__3) {
/* Computing MIN */
i__4 = *n - i__ + 1;
blk = min(i__4,chunk);
zgemm_("N", "N", m, &blk, m, &c_b2, &work[ir], &
ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b1, &
work[iu], &ldwrku, 1L, 1L);
zlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
a_dim1 + 1], lda, 1L);
/* L30: */
}
} else {
/* Insufficient workspace for a fast algor
ithm */
ie = 1;
itauq = 1;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A */
/* (CWorkspace: need 2*M+N, prefer 2*M+(M+
N)*NB) */
/* (RWorkspace: need M) */
i__3 = *lwork - iwork + 1;
zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
itauq], &work[itaup], &work[iwork], &i__3, &ierr);
/* Generate right vectors bidiagonalizing
A */
/* (CWorkspace: need 3*M, prefer 2*M+M*NB)
*/
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
work[iwork], &i__3, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration, comput
ing right */
/* singular vectors of A in A */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("L", m, n, &c__0, &c__0, &s[1], &rwork[ie], &a[
a_offset], lda, cdum, &c__1, cdum, &c__1, &rwork[
irwork], info, 1L);
}
} else if (wntvo && wntuas) {
/* Path 3t(N much larger than M, JOBU='S' or 'A',
JOBVT='O') */
/* M right singular vectors to be overwritten on
A and */
/* M left singular vectors to be computed in U */
if (*lwork >= *m * *m + *m * 3) {
/* Sufficient workspace for a fast algorit
hm */
ir = 1;
/* Computing MAX */
i__3 = wrkbl, i__2 = *lda * *n;
if (*lwork >= max(i__3,i__2) + *lda * *m) {
/* WORK(IU) is LDA by N and WORK(IR
) is LDA by M */
ldwrku = *lda;
chunk = *n;
ldwrkr = *lda;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__3 = wrkbl, i__2 = *lda * *n;
if (*lwork >= max(i__3,i__2) + *m * *m) {
/* WORK(IU) is LDA by N and WOR
K(IR) is M by M */
ldwrku = *lda;
chunk = *n;
ldwrkr = *m;
} else {
/* WORK(IU) is M by CHUNK and W
ORK(IR) is M by M */
ldwrku = *m;
chunk = (*lwork - *m * *m) / *m;
ldwrkr = *m;
}
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (CWorkspace: need M*M+2*M, prefer M*M+M
+M*NB) */
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__3, &ierr);
/* Copy L to U, zeroing about above it */
zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu,
1L);
i__3 = *m - 1;
i__2 = *m - 1;
zlaset_("U", &i__3, &i__2, &c_b1, &c_b1, &u[(u_dim1 << 1)
+ 1], ldu, 1L);
/* Generate Q in A */
/* (CWorkspace: need M*M+2*M, prefer M*M+M
+M*NB) */
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
iwork], &i__3, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in U, copying result to
WORK(IR) */
/* (CWorkspace: need M*M+3*M, prefer M*M+2
*M+2*M*NB) */
/* (RWorkspace: need M) */
i__3 = *lwork - iwork + 1;
zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &work[
itauq], &work[itaup], &work[iwork], &i__3, &ierr);
zlacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr,
1L);
/* Generate right vectors bidiagonalizing
L in WORK(IR) */
/* (CWorkspace: need M*M+3*M-1, prefer M*M
+2*M+(M-1)*NB) */
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
work[iwork], &i__3, &ierr, 1L);
/* Generate left vectors bidiagonalizing L
in U */
/* (CWorkspace: need M*M+3*M, prefer M*M+2
*M+M*NB) */
/* (RWorkspace: 0) */
i__3 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
work[iwork], &i__3, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of L in U, and computi
ng right */
/* singular vectors of L in WORK(IR) */
/* (CWorkspace: need M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[ir],
&ldwrkr, &u[u_offset], ldu, cdum, &c__1, &rwork[
irwork], info, 1L);
iu = itauq;
/* Multiply right singular vectors of L in
WORK(IR) by Q */
/* in A, storing result in WORK(IU) and co
pying to A */
/* (CWorkspace: need M*M+M, prefer M*M+M*N
)) */
/* (RWorkspace: 0) */
i__3 = *n;
i__2 = chunk;
for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
i__2) {
/* Computing MIN */
i__4 = *n - i__ + 1;
blk = min(i__4,chunk);
zgemm_("N", "N", m, &blk, m, &c_b2, &work[ir], &
ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b1, &
work[iu], &ldwrku, 1L, 1L);
zlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
a_dim1 + 1], lda, 1L);
/* L40: */
}
} else {
/* Insufficient workspace for a fast algor
ithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q */
/* (CWorkspace: need 2*M, prefer M+M*NB)
*/
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__2, &ierr);
/* Copy L to U, zeroing out above it */
zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu,
1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 << 1)
+ 1], ldu, 1L);
/* Generate Q in A */
/* (CWorkspace: need 2*M, prefer M+M*NB)
*/
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in U */
/* (CWorkspace: need 3*M, prefer 2*M+2*M*N
B) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &work[
itauq], &work[itaup], &work[iwork], &i__2, &ierr);
/* Multiply right vectors bidiagonalizing
L by Q in A */
/* (CWorkspace: need 2*M+N, prefer 2*M+N*N
B) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &work[
itaup], &a[a_offset], lda, &work[iwork], &i__2, &
ierr, 1L, 1L, 1L);
/* Generate left vectors bidiagonalizing L
in U */
/* (CWorkspace: need 3*M, prefer 2*M+M*NB)
*/
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of A in U and computin
g right */
/* singular vectors of A in A */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &a[
a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
rwork[irwork], info, 1L);
}
} else if (wntvs) {
if (wntun) {
/* Path 4t(N much larger than M, JOBU='N',
JOBVT='S') */
/* M right singular vectors to be computed
in VT and */
/* no left singular vectors to be computed
*/
if (*lwork >= *m * *m + *m * 3) {
/* Sufficient workspace for a fast
algorithm */
ir = 1;
if (*lwork >= wrkbl + *lda * *m) {
/* WORK(IR) is LDA by M */
ldwrkr = *lda;
} else {
/* WORK(IR) is M by M */
ldwrkr = *m;
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (CWorkspace: need M*M+2*M, prefe
r M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy L to WORK(IR), zeroing out
above it */
zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
ldwrkr, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
ldwrkr], &ldwrkr, 1L);
/* Generate Q in A */
/* (CWorkspace: need M*M+2*M, prefe
r M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IR) */
/* (CWorkspace: need M*M+3*M, prefe
r M*M+2*M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Generate right vectors bidiagona
lizing L in */
/* WORK(IR) */
/* (CWorkspace: need M*M+3*M, prefe
r M*M+2*M+(M-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right */
/* singular vectors of L in WORK(IR
) */
/* (CWorkspace: need M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &
work[ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &
rwork[irwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IR) by */
/* Q in A, storing result in VT */
/* (CWorkspace: need M*M) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, m, &c_b2, &work[ir], &ldwrkr, &
a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt,
1L, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy result to VT */
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Zero out above L in A */
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
1) + 1], lda, 1L);
/* Bidiagonalize L in A */
/* (CWorkspace: need 3*M, prefer 2*
M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right vectors bidiagona
lizing L by Q in VT */
/* (CWorkspace: need 2*M+N, prefer
2*M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, n, &c__0, &c__0, &s[1], &rwork[ie], &
vt[vt_offset], ldvt, cdum, &c__1, cdum, &c__1,
&rwork[irwork], info, 1L);
}
} else if (wntuo) {
/* Path 5t(N much larger than M, JOBU='O',
JOBVT='S') */
/* M right singular vectors to be computed
in VT and */
/* M left singular vectors to be overwritt
en on A */
if (*lwork >= (*m << 1) * *m + *m * 3) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + (*lda << 1) * *m) {
/* WORK(IU) is LDA by M and
WORK(IR) is LDA by M */
ldwrku = *lda;
ir = iu + ldwrku * *m;
ldwrkr = *lda;
} else if (*lwork >= wrkbl + (*lda + *m) * *m) {
/* WORK(IU) is LDA by M and
WORK(IR) is M by M */
ldwrku = *lda;
ir = iu + ldwrku * *m;
ldwrkr = *m;
} else {
/* WORK(IU) is M by M and WO
RK(IR) is M by M */
ldwrku = *m;
ir = iu + ldwrku * *m;
ldwrkr = *m;
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (CWorkspace: need 2*M*M+2*M, pre
fer 2*M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy L to WORK(IU), zeroing out
below it */
zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
ldwrku], &ldwrku, 1L);
/* Generate Q in A */
/* (CWorkspace: need 2*M*M+2*M, pre
fer 2*M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IU), cop
ying result to */
/* WORK(IR) */
/* (CWorkspace: need 2*M*M+3*M,
*/
/* prefer 2*M*M+2*M+2*
M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
zlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
ldwrkr, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IU) */
/* (CWorkspace: need 2*M*M+3*M-1,
*/
/* prefer 2*M*M+2*M+(M
-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IR) */
/* (CWorkspace: need 2*M*M+3*M, pre
fer 2*M*M+2*M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of L in WORK(IR
) and computing */
/* right singular vectors of L in W
ORK(IU) */
/* (CWorkspace: need 2*M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
iu], &ldwrku, &work[ir], &ldwrkr, cdum, &c__1,
&rwork[irwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IU) by */
/* Q in A, storing result in VT */
/* (CWorkspace: need M*M) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt,
1L, 1L);
/* Copy left singular vectors of L
to A */
/* (CWorkspace: need M*M) */
/* (RWorkspace: 0) */
zlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
lda, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Zero out above L in A */
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
1) + 1], lda, 1L);
/* Bidiagonalize L in A */
/* (CWorkspace: need 3*M, prefer 2*
M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right vectors bidiagona
lizing L by Q in VT */
/* (CWorkspace: need 2*M+N, prefer
2*M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
/* Generate left bidiagonalizing ve
ctors of L in A */
/* (CWorkspace: need 3*M, prefer 2*
M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in A and c
omputing right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, cdum, &
c__1, &rwork[irwork], info, 1L);
}
} else if (wntuas) {
/* Path 6t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='S') */
/* M right singular vectors to be computed
in VT and */
/* M left singular vectors to be computed
in U */
if (*lwork >= *m * *m + *m * 3) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + *lda * *m) {
/* WORK(IU) is LDA by N */
ldwrku = *lda;
} else {
/* WORK(IU) is LDA by M */
ldwrku = *m;
}
itau = iu + ldwrku * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (CWorkspace: need M*M+2*M, prefe
r M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy L to WORK(IU), zeroing out
above it */
zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
ldwrku], &ldwrku, 1L);
/* Generate Q in A */
/* (CWorkspace: need M*M+2*M, prefe
r M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IU), cop
ying result to U */
/* (CWorkspace: need M*M+3*M, prefe
r M*M+2*M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
zlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
ldu, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IU) */
/* (CWorkspace: need M*M+3*M-1,
*/
/* prefer M*M+2*M+(M-1
)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate left bidiagonalizing ve
ctors in U */
/* (CWorkspace: need M*M+3*M, prefe
r M*M+2*M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of L in U and c
omputing right */
/* singular vectors of L in WORK(IU
) */
/* (CWorkspace: need M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
iu], &ldwrku, &u[u_offset], ldu, cdum, &c__1,
&rwork[irwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IU) by */
/* Q in A, storing result in VT */
/* (CWorkspace: need M*M) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt,
1L, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy L to U, zeroing out above i
t */
zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 <<
1) + 1], ldu, 1L);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in U */
/* (CWorkspace: need 3*M, prefer 2*
M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right bidiagonalizing v
ectors in U by Q */
/* in VT */
/* (CWorkspace: need 2*M+N, prefer
2*M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
/* Generate left bidiagonalizing ve
ctors in U */
/* (CWorkspace: need 3*M, prefer 2*
M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, cdum, &
c__1, &rwork[irwork], info, 1L);
}
}
} else if (wntva) {
if (wntun) {
/* Path 7t(N much larger than M, JOBU='N',
JOBVT='A') */
/* N right singular vectors to be computed
in VT and */
/* no left singular vectors to be computed
*/
/* Computing MAX */
i__2 = *n + *m, i__3 = *m * 3;
if (*lwork >= *m * *m + max(i__2,i__3)) {
/* Sufficient workspace for a fast
algorithm */
ir = 1;
if (*lwork >= wrkbl + *lda * *m) {
/* WORK(IR) is LDA by M */
ldwrkr = *lda;
} else {
/* WORK(IR) is M by M */
ldwrkr = *m;
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (CWorkspace: need M*M+2*M, prefe
r M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Copy L to WORK(IR), zeroing out
above it */
zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
ldwrkr, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
ldwrkr], &ldwrkr, 1L);
/* Generate Q in VT */
/* (CWorkspace: need M*M+M+N, prefe
r M*M+M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IR) */
/* (CWorkspace: need M*M+3*M, prefe
r M*M+2*M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Generate right bidiagonalizing v
ectors in WORK(IR) */
/* (CWorkspace: need M*M+3*M-1,
*/
/* prefer M*M+2*M+(M-1
)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right */
/* singular vectors of L in WORK(IR
) */
/* (CWorkspace: need M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &
work[ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &
rwork[irwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IR) by */
/* Q in VT, storing result in A */
/* (CWorkspace: need M*M) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, m, &c_b2, &work[ir], &ldwrkr, &
vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda,
1L, 1L);
/* Copy right singular vectors of A
from A to VT */
zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (CWorkspace: need M+N, prefer M+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Zero out above L in A */
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
1) + 1], lda, 1L);
/* Bidiagonalize L in A */
/* (CWorkspace: need 3*M, prefer 2*
M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right bidiagonalizing v
ectors in A by Q */
/* in VT */
/* (CWorkspace: need 2*M+N, prefer
2*M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, n, &c__0, &c__0, &s[1], &rwork[ie], &
vt[vt_offset], ldvt, cdum, &c__1, cdum, &c__1,
&rwork[irwork], info, 1L);
}
} else if (wntuo) {
/* Path 8t(N much larger than M, JOBU='O',
JOBVT='A') */
/* N right singular vectors to be computed
in VT and */
/* M left singular vectors to be overwritt
en on A */
/* Computing MAX */
i__2 = *n + *m, i__3 = *m * 3;
if (*lwork >= (*m << 1) * *m + max(i__2,i__3)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + (*lda << 1) * *m) {
/* WORK(IU) is LDA by M and
WORK(IR) is LDA by M */
ldwrku = *lda;
ir = iu + ldwrku * *m;
ldwrkr = *lda;
} else if (*lwork >= wrkbl + (*lda + *m) * *m) {
/* WORK(IU) is LDA by M and
WORK(IR) is M by M */
ldwrku = *lda;
ir = iu + ldwrku * *m;
ldwrkr = *m;
} else {
/* WORK(IU) is M by M and WO
RK(IR) is M by M */
ldwrku = *m;
ir = iu + ldwrku * *m;
ldwrkr = *m;
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (CWorkspace: need 2*M*M+2*M, pre
fer 2*M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (CWorkspace: need 2*M*M+M+N, pre
fer 2*M*M+M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy L to WORK(IU), zeroing out
above it */
zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
ldwrku], &ldwrku, 1L);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IU), cop
ying result to */
/* WORK(IR) */
/* (CWorkspace: need 2*M*M+3*M,
*/
/* prefer 2*M*M+2*M+2*
M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
zlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
ldwrkr, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IU) */
/* (CWorkspace: need 2*M*M+3*M-1,
*/
/* prefer 2*M*M+2*M+(M
-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IR) */
/* (CWorkspace: need 2*M*M+3*M, pre
fer 2*M*M+2*M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of L in WORK(IR
) and computing */
/* right singular vectors of L in W
ORK(IU) */
/* (CWorkspace: need 2*M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
iu], &ldwrku, &work[ir], &ldwrkr, cdum, &c__1,
&rwork[irwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IU) by */
/* Q in VT, storing result in A */
/* (CWorkspace: need M*M) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda,
1L, 1L);
/* Copy right singular vectors of A
from A to VT */
zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Copy left singular vectors of A
from WORK(IR) to A */
zlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
lda, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (CWorkspace: need M+N, prefer M+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Zero out above L in A */
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
1) + 1], lda, 1L);
/* Bidiagonalize L in A */
/* (CWorkspace: need 3*M, prefer 2*
M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right bidiagonalizing v
ectors in A by Q */
/* in VT */
/* (CWorkspace: need 2*M+N, prefer
2*M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
/* Generate left bidiagonalizing ve
ctors in A */
/* (CWorkspace: need 3*M, prefer 2*
M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in A and c
omputing right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, cdum, &
c__1, &rwork[irwork], info, 1L);
}
} else if (wntuas) {
/* Path 9t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='A') */
/* N right singular vectors to be computed
in VT and */
/* M left singular vectors to be computed
in U */
/* Computing MAX */
i__2 = *n + *m, i__3 = *m * 3;
if (*lwork >= *m * *m + max(i__2,i__3)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + *lda * *m) {
/* WORK(IU) is LDA by M */
ldwrku = *lda;
} else {
/* WORK(IU) is M by M */
ldwrku = *m;
}
itau = iu + ldwrku * *m;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (CWorkspace: need M*M+2*M, prefe
r M*M+M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (CWorkspace: need M*M+M+N, prefe
r M*M+M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy L to WORK(IU), zeroing out
above it */
zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
ldwrku], &ldwrku, 1L);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IU), cop
ying result to U */
/* (CWorkspace: need M*M+3*M, prefe
r M*M+2*M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
zlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
ldu, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IU) */
/* (CWorkspace: need M*M+3*M, prefe
r M*M+2*M+(M-1)*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate left bidiagonalizing ve
ctors in U */
/* (CWorkspace: need M*M+3*M, prefe
r M*M+2*M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of L in U and c
omputing right */
/* singular vectors of L in WORK(IU
) */
/* (CWorkspace: need M*M) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
iu], &ldwrku, &u[u_offset], ldu, cdum, &c__1,
&rwork[irwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IU) by */
/* Q in VT, storing result in A */
/* (CWorkspace: need M*M) */
/* (RWorkspace: 0) */
zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda,
1L, 1L);
/* Copy right singular vectors of A
from A to VT */
zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (CWorkspace: need 2*M, prefer M+
M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (CWorkspace: need M+N, prefer M+
N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy L to U, zeroing out above i
t */
zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 <<
1) + 1], ldu, 1L);
ie = 1;
itauq = itau;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in U */
/* (CWorkspace: need 3*M, prefer 2*
M+2*M*NB) */
/* (RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right bidiagonalizing v
ectors in U by Q */
/* in VT */
/* (CWorkspace: need 2*M+N, prefer
2*M+N*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
/* Generate left bidiagonalizing ve
ctors in U */
/* (CWorkspace: need 3*M, prefer 2*
M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, cdum, &
c__1, &rwork[irwork], info, 1L);
}
}
}
} else {
/* N .LT. MNTHR */
/* Path 10t(N greater than M, but not much larger) */
/* Reduce to bidiagonal form without LQ decomposition */
ie = 1;
itauq = 1;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A */
/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
/* (RWorkspace: M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
&work[itaup], &work[iwork], &i__2, &ierr);
if (wntuas) {
/* If left singular vectors desired in U, copy re
sult to U */
/* and generate left bidiagonalizing vectors in U
*/
/* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
*/
/* (RWorkspace: 0) */
zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu, 1L);
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
iwork], &i__2, &ierr, 1L);
}
if (wntvas) {
/* If right singular vectors desired in VT, copy
result to */
/* VT and generate right bidiagonalizing vectors
in VT */
/* (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB
) */
/* (RWorkspace: 0) */
zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt,
1L);
if (wntva) {
nrvt = *n;
}
if (wntvs) {
nrvt = *m;
}
i__2 = *lwork - iwork + 1;
zungbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup],
&work[iwork], &i__2, &ierr, 1L);
}
if (wntuo) {
/* If left singular vectors desired in A, generat
e left */
/* bidiagonalizing vectors in A */
/* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
*/
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[
iwork], &i__2, &ierr, 1L);
}
if (wntvo) {
/* If right singular vectors desired in A, genera
te right */
/* bidiagonalizing vectors in A */
/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
/* (RWorkspace: 0) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
iwork], &i__2, &ierr, 1L);
}
irwork = ie + *m;
if (wntuas || wntuo) {
nru = *m;
}
if (wntun) {
nru = 0;
}
if (wntvas || wntvo) {
ncvt = *n;
}
if (wntvn) {
ncvt = 0;
}
if (! wntuo && ! wntvo) {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in U and computing right
singular */
/* vectors in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, cdum, &c__1, &
rwork[irwork], info, 1L);
} else if (! wntuo && wntvo) {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in U and computing right
singular */
/* vectors in A */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &a[
a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
rwork[irwork], info, 1L);
} else {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in A and computing right
singular */
/* vectors in VT */
/* (CWorkspace: 0) */
/* (RWorkspace: need BDSPAC) */
zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, &
rwork[irwork], info, 1L);
}
}
}
/* Undo scaling if necessary */
if (iscl == 1) {
if (anrm > bignum) {
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, &ierr, 1L);
}
if (*info != 0 && anrm > bignum) {
i__2 = minmn - 1;
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &rwork[
ie], &minmn, &ierr, 1L);
}
if (anrm < smlnum) {
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, &ierr, 1L);
}
if (*info != 0 && anrm < smlnum) {
i__2 = minmn - 1;
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &rwork[
ie], &minmn, &ierr, 1L);
}
}
/* Return optimal workspace in WORK(1) */
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZGESVD */
} /* zgesvd_ */
/* zlaswp.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zlaswp_(n, a, lda, k1, k2, ipiv, incx)
integer *n;
doublecomplex *a;
integer *lda, *k1, *k2, *ipiv, *incx;
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
/* Local variables */
static integer i__;
extern /* Subroutine */ int zswap_();
static integer ip, ix;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLASWP performs a series of row interchanges on the matrix A. */
/* One row interchange is initiated for each of rows K1 through K2 of A.
*/
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the matrix of column dimension N to which the row */
/* interchanges will be applied. */
/* On exit, the permuted matrix. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* K1 (input) INTEGER */
/* The first element of IPIV for which a row interchange will */
/* be done. */
/* K2 (input) INTEGER */
/* The last element of IPIV for which a row interchange will */
/* be done. */
/* IPIV (input) INTEGER array, dimension (M*abs(INCX)) */
/* The vector of pivot indices. Only the elements in positions
*/
/* K1 through K2 of IPIV are accessed. */
/* IPIV(K) = L implies rows K and L are to be interchanged. */
/* INCX (input) INTEGER */
/* The increment between successive values of IPIV. If IPIV */
/* is negative, the pivots are applied in reverse order. */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Interchange row I with row IPIV(I) for each of rows K1 through K2.
*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
/* Function Body */
if (*incx == 0) {
return 0;
}
if (*incx > 0) {
ix = *k1;
} else {
ix = (1 - *k2) * *incx + 1;
}
if (*incx == 1) {
i__1 = *k2;
for (i__ = *k1; i__ <= i__1; ++i__) {
ip = ipiv[i__];
if (ip != i__) {
zswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda);
}
/* L10: */
}
} else if (*incx > 1) {
i__1 = *k2;
for (i__ = *k1; i__ <= i__1; ++i__) {
ip = ipiv[ix];
if (ip != i__) {
zswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda);
}
ix += *incx;
/* L20: */
}
} else if (*incx < 0) {
i__1 = *k1;
for (i__ = *k2; i__ >= i__1; --i__) {
ip = ipiv[ix];
if (ip != i__) {
zswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda);
}
ix += *incx;
/* L30: */
}
}
return 0;
/* End of ZLASWP */
} /* zlaswp_ */
/* zlanhs.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
doublereal zlanhs_(norm, n, a, lda, work, norm_len)
char *norm;
integer *n;
doublecomplex *a;
integer *lda;
doublereal *work;
ftnlen norm_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(), sqrt();
/* Local variables */
static integer i__, j;
static doublereal scale;
extern logical lsame_();
static doublereal value;
extern /* Subroutine */ int zlassq_();
static doublereal sum;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANHS returns the value of the one norm, or the Frobenius norm, or
*/
/* the infinity norm, or the element of largest absolute value of a
*/
/* Hessenberg matrix A. */
/* Description */
/* =========== */
/* ZLANHS returns the value */
/* ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum),
*/
/* normI denotes the infinity norm of a matrix (maximum row sum) and
*/
/* normF denotes the Frobenius norm of a matrix (square root of sum of
*/
/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in ZLANHS as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, ZLANHS is */
/* set to zero. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The n by n upper Hessenberg matrix A; the part of A below the
*/
/* first sub-diagonal is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(N,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M", 1L, 1L)) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
value = max(d__1,d__2);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += z_abs(&a[i__ + j * a_dim1]);
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I", 1L, 1L)) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += z_abs(&a[i__ + j * a_dim1]);
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANHS */
} /* zlanhs_ */
/* zunmbr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zunmbr_(vect, side, trans, m, n, k, a, lda, tau, c__,
ldc, work, lwork, info, vect_len, side_len, trans_len)
char *vect, *side, *trans;
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *c__;
integer *ldc;
doublecomplex *work;
integer *lwork, *info;
ftnlen vect_len;
ftnlen side_len;
ftnlen trans_len;
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
static logical left;
extern logical lsame_();
static integer iinfo, i1, i2, mi, ni, nq, nw;
extern /* Subroutine */ int xerbla_();
static logical notran, applyq;
static char transt[1];
extern /* Subroutine */ int zunmlq_(), zunmqr_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* If VECT = 'Q', ZUNMBR 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 */
/* If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C
*/
/* with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': P * C C * P */
/* TRANS = 'C': P**H * C C * P**H */
/* Here Q and P**H are the unitary matrices determined by ZGEBRD when */
/* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q */
/* and P**H are defined as products of elementary reflectors H(i) and */
/* G(i) respectively. */
/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */
/* order of the unitary matrix Q or P**H that is applied. */
/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */
/* if nq >= k, Q = H(1) H(2) . . . H(k); */
/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */
/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */
/* if k < nq, P = G(1) G(2) . . . G(k); */
/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* = 'Q': apply Q or Q**H; */
/* = 'P': apply P or P**H. */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q, Q**H, P or P**H from the Left; */
/* = 'R': apply Q, Q**H, P or P**H from the Right. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q or P; */
/* = 'C': Conjugate transpose, apply Q**H or P**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. */
/* K (input) INTEGER */
/* If VECT = 'Q', the number of columns in the original */
/* matrix reduced by ZGEBRD. */
/* If VECT = 'P', the number of rows in the original */
/* matrix reduced by ZGEBRD. */
/* K >= 0. */
/* A (input) COMPLEX*16 array, dimension */
/* (LDA,min(nq,K)) if VECT = 'Q' */
/* (LDA,nq) if VECT = 'P' */
/* The vectors which define the elementary reflectors H(i) and */
/* G(i), whose products determine the matrices Q and P, as */
/* returned by ZGEBRD. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If VECT = 'Q', LDA >= max(1,nq); */
/* if VECT = 'P', LDA >= max(1,min(nq,K)). */
/* TAU (input) COMPLEX*16 array, dimension (min(nq,K)) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i) or G(i) which determines Q or P, as returned */
/* by ZGEBRD in the array argument TAUQ or TAUP. */
/* C (input/output) COMPLEX*16 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 */
/* or P*C or P**H*C or C*P or C*P**H. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
applyq = lsame_(vect, "Q", 1L, 1L);
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q or P and NW is the minimum dimension of WORK
*/
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! applyq && ! lsame_(vect, "P", 1L, 1L)) {
*info = -1;
} else if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -2;
} else if (! notran && ! lsame_(trans, "C", 1L, 1L)) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*k < 0) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = min(nq,*k);
if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -11;
} else if (*lwork < max(1,nw)) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNMBR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
work[1].r = 1., work[1].i = 0.;
if (*m == 0 || *n == 0) {
return 0;
}
if (applyq) {
/* Apply Q */
if (nq >= *k) {
/* Q was determined by a call to ZGEBRD with nq >= k */
zunmqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], lwork, &iinfo, 1L, 1L);
} else if (nq > 1) {
/* Q was determined by a call to ZGEBRD with nq < k */
if (left) {
mi = *m - 1;
ni = *n;
i1 = 2;
i2 = 1;
} else {
mi = *m;
ni = *n - 1;
i1 = 1;
i2 = 2;
}
i__1 = nq - 1;
zunmqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1]
, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo,
1L, 1L);
}
} else {
/* Apply P */
if (notran) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (nq > *k) {
/* P was determined by a call to ZGEBRD with nq > k */
zunmlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], lwork, &iinfo, 1L, 1L);
} else if (nq > 1) {
/* P was determined by a call to ZGEBRD with nq <= k */
if (left) {
mi = *m - 1;
ni = *n;
i1 = 2;
i2 = 1;
} else {
mi = *m;
ni = *n - 1;
i1 = 1;
i2 = 2;
}
i__1 = nq - 1;
zunmlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
&tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
iinfo, 1L, 1L);
}
}
return 0;
/* End of ZUNMBR */
} /* zunmbr_ */
/* zlange.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
doublereal zlange_(norm, m, n, a, lda, work, norm_len)
char *norm;
integer *m, *n;
doublecomplex *a;
integer *lda;
doublereal *work;
ftnlen norm_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(), sqrt();
/* Local variables */
static integer i__, j;
static doublereal scale;
extern logical lsame_();
static doublereal value;
extern /* Subroutine */ int zlassq_();
static doublereal sum;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANGE returns the value of the one norm, or the Frobenius norm, or
*/
/* the infinity norm, or the element of largest absolute value of a
*/
/* complex matrix A. */
/* Description */
/* =========== */
/* ZLANGE returns the value */
/* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum),
*/
/* normI denotes the infinity norm of a matrix (maximum row sum) and
*/
/* normF denotes the Frobenius norm of a matrix (square root of sum of
*/
/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in ZLANGE as described */
/* above. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. When M = 0, */
/* ZLANGE is set to zero. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. When N = 0,
*/
/* ZLANGE is set to zero. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(M,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0) {
value = 0.;
} else if (lsame_(norm, "M", 1L, 1L)) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
value = max(d__1,d__2);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += z_abs(&a[i__ + j * a_dim1]);
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I", 1L, 1L)) {
/* Find normI(A). */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += z_abs(&a[i__ + j * a_dim1]);
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANGE */
} /* zlange_ */
/* zung2r.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zung2r_(m, n, k, a, lda, tau, work, info)
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Local variables */
static integer i__, j, l;
extern /* Subroutine */ int zscal_(), zlarf_(), xerbla_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNG2R 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 ZGEQRF. */
/* 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*16 array, dimension (LDA,N) */
/* On entry, the i-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as
*/
/* returned by ZGEQRF 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*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGEQRF. */
/* WORK (workspace) COMPLEX*16 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 = a_dim1 + 1;
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_("ZUNG2R", &i__1, 6L);
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., a[i__3].i = 0.;
/* L10: */
}
i__2 = j + j * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L20: */
}
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., a[i__1].i = 0.;
i__1 = *m - i__ + 1;
i__2 = *n - i__;
zlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L);
}
if (i__ < *m) {
i__1 = *m - i__;
i__2 = i__;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zscal_(&i__1, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
}
i__1 = i__ + i__ * a_dim1;
i__2 = i__;
z__1.r = 1. - tau[i__2].r, z__1.i = 0. - tau[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__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., a[i__2].i = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of ZUNG2R */
} /* zung2r_ */
/* zlacpy.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zlacpy_(uplo, m, n, a, lda, b, ldb, uplo_len)
char *uplo;
integer *m, *n;
doublecomplex *a;
integer *lda;
doublecomplex *b;
integer *ldb;
ftnlen uplo_len;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, j;
extern logical lsame_();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLACPY copies all or part of a two-dimensional matrix A to another */
/* matrix B. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies the part of the matrix A to be copied to B. */
/* = 'U': Upper triangular part */
/* = 'L': Lower triangular part */
/* Otherwise: All of the matrix A */
/* 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) COMPLEX*16 array, dimension (LDA,N) */
/* The m by n matrix A. If UPLO = 'U', only the upper trapezium
*/
/* is accessed; if UPLO = 'L', only the lower trapezium is */
/* accessed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (output) COMPLEX*16 array, dimension (LDB,N) */
/* On exit, B = A in the locations specified by UPLO. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,M). */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
/* Function Body */
if (lsame_(uplo, "U", 1L, 1L)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ + j * a_dim1;
b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
/* L10: */
}
/* L20: */
}
} else if (lsame_(uplo, "L", 1L, 1L)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ + j * a_dim1;
b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
/* L30: */
}
/* L40: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ + j * a_dim1;
b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
/* L50: */
}
/* L60: */
}
}
return 0;
/* End of ZLACPY */
} /* zlacpy_ */
/* zdrscl.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zdrscl_(n, sa, sx, incx)
integer *n;
doublereal *sa;
doublecomplex *sx;
integer *incx;
{
static doublereal cden;
static logical done;
static doublereal cnum, cden1, cnum1;
extern /* Subroutine */ int dlabad_();
extern doublereal dlamch_();
extern /* Subroutine */ int zdscal_();
static doublereal bignum, smlnum, mul;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRSCL multiplies an n-element complex vector x by the real scalar */
/* 1/a. This is done without overflow or underflow as long as */
/* the final result x/a does not overflow or underflow. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of components of the vector x. */
/* SA (input) DOUBLE PRECISION */
/* The scalar a which is used to divide each component of x. */
/* SA must be >= 0, or the subroutine will divide by zero. */
/* SX (input/output) COMPLEX*16 array, dimension */
/* (1+(N-1)*abs(INCX)) */
/* The n-element vector x. */
/* INCX (input) INTEGER */
/* The increment between successive values of the vector SX. */
/* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
*/
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--sx;
/* Function Body */
if (*n <= 0) {
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S", 1L);
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Initialize the denominator to SA and the numerator to 1. */
cden = *sa;
cnum = 1.;
L10:
cden1 = cden * smlnum;
cnum1 = cnum / bignum;
if (abs(cden1) > abs(cnum) && cnum != 0.) {
/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*/
mul = smlnum;
done = FALSE_;
cden = cden1;
} else if (abs(cnum1) > abs(cden)) {
/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*/
mul = bignum;
done = FALSE_;
cnum = cnum1;
} else {
/* Multiply X by CNUM / CDEN and return. */
mul = cnum / cden;
done = TRUE_;
}
/* Scale the vector X by MUL */
zdscal_(n, &mul, &sx[1], incx);
if (! done) {
goto L10;
}
return 0;
/* End of ZDRSCL */
} /* zdrscl_ */
/* zunml2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int zunml2_(side, trans, m, n, k, a, lda, tau, c__, ldc,
work, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *c__;
integer *ldc;
doublecomplex *work;
integer *info;
ftnlen side_len;
ftnlen trans_len;
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg();
/* Local variables */
static logical left;
static doublecomplex taui;
static integer i__;
extern logical lsame_();
extern /* Subroutine */ int zlarf_();
static integer i1, i2, i3, ic, jc, mi, ni, nq;
extern /* Subroutine */ int xerbla_(), zlacgv_();
static logical notran;
static doublecomplex aii;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNML2 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 ZGELQF. 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*16 array, dimension */
/* (LDA,M) if SIDE = 'L', */
/* (LDA,N) if SIDE = 'R' */
/* The i-th row must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by
*/
/* ZGELQF 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*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGELQF. */
/* C (input/output) COMPLEX*16 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*16 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 */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C", 1L, 1L)) {
*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_("ZUNML2", &i__1, 6L);
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) {
d_cnjg(&z__1, &tau[i__]);
taui.r = z__1.r, taui.i = z__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__;
zlacgv_(&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., a[i__3].i = 0.;
zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &taui, &c__[ic +
jc * c_dim1], ldc, &work[1], 1L);
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__;
zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
}
/* L10: */
}
return 0;
/* End of ZUNML2 */
} /* zunml2_ */
/* zgeqrf.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zgeqrf_(m, n, a, lda, tau, work, lwork, info)
integer *m, *n;
doublecomplex *a;
integer *lda;
doublecomplex *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, k, nbmin, iinfo;
extern /* Subroutine */ int zgeqr2_();
static integer ib, nb, nx;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int zlarfb_();
static integer ldwork;
extern /* Subroutine */ int zlarft_();
static integer iws;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEQRF computes a QR factorization of a complex M-by-N matrix A: */
/* A = Q * R. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the elements on and above the diagonal of the array
*/
/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
/* upper triangular if m >= n); the elements below the diagonal,
*/
/* with the array TAU, represent the unitary matrix Q as a */
/* product of min(m,n) elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is */
/* the optimal blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* 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). */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 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;
} else if (*lwork < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQRF", &i__1, 6L);
return 0;
}
/* Quick return if possible */
k = min(*m,*n);
if (k == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code.
*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", m, n, &c_n1, &c_n1, 6L,
1L);
nx = max(i__1,i__2);
if (nx < k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", m, n, &c_n1, &
c_n1, 6L, 1L);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Compute the QR factorization of the current block */
/* A(i:m,i:i+ib-1) */
i__3 = *m - i__ + 1;
zgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo);
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflec
tor */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *m - i__ + 1;
zlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 10L);
/* Apply H' to A(i:m,i+ib:n) from the left */
i__3 = *m - i__ + 1;
i__4 = *n - i__ - ib + 1;
zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise"
, &i__3, &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &
work[1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda,
&work[ib + 1], &ldwork, 4L, 19L, 7L, 10L);
}
/* L10: */
}
} else {
i__ = 1;
}
/* Use unblocked code to factor the last or only block. */
if (i__ <= k) {
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
zgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
}
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZGEQRF */
} /* zgeqrf_ */
/* zlahqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int zlahqr_(wantt, wantz, n, ilo, ihi, h__, ldh, w, iloz,
ihiz, z__, ldz, info)
logical *wantt, *wantz;
integer *n, *ilo, *ihi;
doublecomplex *h__;
integer *ldh;
doublecomplex *w;
integer *iloz, *ihiz;
doublecomplex *z__;
integer *ldz, *info;
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag();
void z_sqrt(), d_cnjg();
/* Local variables */
static doublereal unfl, ovfl;
static doublecomplex temp;
static integer i__, j, k, l, m;
static doublereal s;
static doublecomplex t, u, v[2], x, y;
extern /* Subroutine */ int zscal_();
static doublereal rtemp;
static integer i1, i2;
static doublereal rwork[1];
static doublecomplex t1;
static doublereal t2;
extern /* Subroutine */ int zcopy_();
static doublecomplex v2;
extern doublereal dlapy2_();
extern /* Subroutine */ int dlabad_();
static doublereal h10;
static doublecomplex h11;
static doublereal h21;
static doublecomplex h22;
static integer nh;
extern doublereal dlamch_();
static integer nz;
extern /* Subroutine */ int zlarfg_();
extern /* Double Complex */ VOID zladiv_();
extern doublereal zlanhs_();
static doublereal smlnum;
static doublecomplex h11s;
static integer itn, its;
static doublereal ulp;
static doublecomplex sum;
static doublereal tst1;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAHQR is an auxiliary routine called by ZHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by ZHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
*/
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows and
*/
/* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
*/
/* ZLAHQR works primarily with the Hessenberg submatrix in rows
*/
/* and columns ILO to IHI, but applies transformations to all of
*/
/* H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if WANTT is .TRUE., H is upper triangular in rows */
/* and columns ILO:IHI, with any 2-by-2 diagonal blocks in */
/* standard form. If WANTT is .FALSE., the contents of H are */
/* unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* W (output) COMPLEX*16 array, dimension (N) */
/* The computed eigenvalues ILO to IHI are stored in the */
/* corresponding elements of W. If WANTT is .TRUE., the */
/* eigenvalues are stored in the same order as on the diagonal */
/* of the Schur form returned in H, with W(i) = H(i,i). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by ZHSEQR, and on */
/* exit Z has been updated; transformations are applied only to
*/
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: if INFO = i, ZLAHQR failed to compute all the */
/* eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1) */
/* iterations; elements i+1:ihi of W contain those */
/* eigenvalues which have been successfully computed. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = h_dim1 + 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = z_dim1 + 1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = *ilo + *ilo * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum", 12L);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision", 9L);
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are
*/
/* being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
*/
/* IHI to ILO in steps of 1. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
*/
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L10:
if (i__ < *ilo) {
goto L130;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = k - 1 + (k - 1) * h_dim1;
i__4 = k + k * h_dim1;
tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[k -
1 + (k - 1) * h_dim1]), abs(d__2)) + ((d__3 = h__[i__4].r,
abs(d__3)) + (d__4 = d_imag(&h__[k + k * h_dim1]), abs(
d__4)));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = zlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, rwork,
1L);
}
i__3 = k + (k - 1) * h_dim1;
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
i__2 = l + (l - 1) * h_dim1;
h__[i__2].r = 0., h__[i__2].i = 0.;
}
/* Exit from loop if a submatrix of order 1 has split off. */
if (l >= i__) {
goto L120;
}
/* Now the active submatrix is in rows and columns L to I. If
*/
/* eigenvalues only are being computed, only the active submatr
ix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
i__2 = i__ + (i__ - 1) * h_dim1;
i__3 = i__ - 1 + (i__ - 2) * h_dim1;
d__3 = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 = h__[i__3].r, abs(
d__2));
t.r = d__3, t.i = 0.;
} else {
/* Wilkinson's shift. */
i__2 = i__ + i__ * h_dim1;
t.r = h__[i__2].r, t.i = h__[i__2].i;
i__2 = i__ - 1 + i__ * h_dim1;
i__3 = i__ + (i__ - 1) * h_dim1;
d__1 = h__[i__3].r;
z__1.r = d__1 * h__[i__2].r, z__1.i = d__1 * h__[i__2].i;
u.r = z__1.r, u.i = z__1.i;
if (u.r != 0. || u.i != 0.) {
i__2 = i__ - 1 + (i__ - 1) * h_dim1;
z__2.r = h__[i__2].r - t.r, z__2.i = h__[i__2].i - t.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
x.r = z__1.r, x.i = z__1.i;
z__3.r = x.r * x.r - x.i * x.i, z__3.i = x.r * x.i + x.i *
x.r;
z__2.r = z__3.r + u.r, z__2.i = z__3.i + u.i;
z_sqrt(&z__1, &z__2);
y.r = z__1.r, y.i = z__1.i;
if (x.r * y.r + d_imag(&x) * d_imag(&y) < 0.) {
z__1.r = -y.r, z__1.i = -y.i;
y.r = z__1.r, y.i = z__1.i;
}
z__3.r = x.r + y.r, z__3.i = x.i + y.i;
zladiv_(&z__2, &u, &z__3);
z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i;
t.r = z__1.r, t.i = z__1.i;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l;
for (m = i__ - 1; m >= i__2; --m) {
/* Determine the effect of starting the single-shift QR
*/
/* iteration at row M, and see if this would make H(M,M-
1) */
/* negligible. */
i__3 = m + m * h_dim1;
h11.r = h__[i__3].r, h11.i = h__[i__3].i;
i__3 = m + 1 + (m + 1) * h_dim1;
h22.r = h__[i__3].r, h22.i = h__[i__3].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__3 = m + 1 + m * h_dim1;
h21 = h__[i__3].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2))
+ abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
if (m == l) {
goto L50;
}
i__3 = m + (m - 1) * h_dim1;
h10 = h__[i__3].r;
tst1 = ((d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(
d__2))) * ((d__3 = h11.r, abs(d__3)) + (d__4 = d_imag(&
h11), abs(d__4)) + ((d__5 = h22.r, abs(d__5)) + (d__6 =
d_imag(&h22), abs(d__6))));
if ((d__1 = h10 * h21, abs(d__1)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* Single-shift QR step */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflect
ion G */
/* from the vector V and applies it from left and right
to H, */
/* thus creating a nonzero bulge below the subdiagonal.
*/
/* Each subsequent iteration determines a reflection G t
o */
/* restore the Hessenberg form in the (K-1)th column, an
d thus */
/* chases the bulge one step toward the bottom of the ac
tive */
/* submatrix. */
/* V(2) is always real before the call to ZLARFG, and he
nce */
/* after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
zcopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
zlarfg_(&c__2, v, &v[1], &c__1, &t1);
if (k > m) {
i__3 = k + (k - 1) * h_dim1;
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = k + 1 + (k - 1) * h_dim1;
h__[i__3].r = 0., h__[i__3].i = 0.;
}
v2.r = v[1].r, v2.i = v[1].i;
z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = z__1.r;
/* Apply G from the left to transform the rows of the ma
trix */
/* in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
d_cnjg(&z__3, &t1);
i__4 = k + j * h_dim1;
z__2.r = z__3.r * h__[i__4].r - z__3.i * h__[i__4].i, z__2.i =
z__3.r * h__[i__4].i + z__3.i * h__[i__4].r;
i__5 = k + 1 + j * h_dim1;
z__4.r = t2 * h__[i__5].r, z__4.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = k + j * h_dim1;
i__5 = k + j * h_dim1;
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = k + 1 + j * h_dim1;
i__5 = k + 1 + j * h_dim1;
z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i +
sum.i * v2.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L60: */
}
/* Apply G from the right to transform the columns of th
e */
/* matrix in rows I1 to min(K+2,I). */
/* Computing MIN */
i__4 = k + 2;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
i__4 = j + k * h_dim1;
z__2.r = t1.r * h__[i__4].r - t1.i * h__[i__4].i, z__2.i =
t1.r * h__[i__4].i + t1.i * h__[i__4].r;
i__5 = j + (k + 1) * h_dim1;
z__3.r = t2 * h__[i__5].r, z__3.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = j + k * h_dim1;
i__5 = j + k * h_dim1;
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = j + (k + 1) * h_dim1;
i__5 = j + (k + 1) * h_dim1;
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L70: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
i__4 = j + k * z_dim1;
z__2.r = t1.r * z__[i__4].r - t1.i * z__[i__4].i, z__2.i =
t1.r * z__[i__4].i + t1.i * z__[i__4].r;
i__5 = j + (k + 1) * z_dim1;
z__3.r = t2 * z__[i__5].r, z__3.i = t2 * z__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = j + k * z_dim1;
i__5 = j + k * z_dim1;
z__1.r = z__[i__5].r - sum.r, z__1.i = z__[i__5].i -
sum.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = j + (k + 1) * z_dim1;
i__5 = j + (k + 1) * z_dim1;
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i -
z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
/* L80: */
}
}
if (k == m && m > l) {
/* If the QR step was started at row M > L becaus
e two */
/* consecutive small subdiagonals were found, the
n extra */
/* scaling must be performed to ensure that H(M,M
-1) remains */
/* real. */
z__1.r = 1. - t1.r, z__1.i = 0. - t1.i;
temp.r = z__1.r, temp.i = z__1.i;
d__2 = temp.r;
d__3 = d_imag(&temp);
d__1 = dlapy2_(&d__2, &d__3);
z__1.r = temp.r / d__1, z__1.i = temp.i / d__1;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = m + 1 + m * h_dim1;
i__4 = m + 1 + m * h_dim1;
d_cnjg(&z__2, &temp);
z__1.r = h__[i__4].r * z__2.r - h__[i__4].i * z__2.i, z__1.i =
h__[i__4].r * z__2.i + h__[i__4].i * z__2.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
if (m + 2 <= i__) {
i__3 = m + 2 + (m + 1) * h_dim1;
i__4 = m + 2 + (m + 1) * h_dim1;
z__1.r = h__[i__4].r * temp.r - h__[i__4].i * temp.i,
z__1.i = h__[i__4].r * temp.i + h__[i__4].i *
temp.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
}
i__3 = i__;
for (j = m; j <= i__3; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__4 = i2 - j;
zscal_(&i__4, &temp, &h__[j + (j + 1) * h_dim1],
ldh);
}
i__4 = j - i1;
d_cnjg(&z__1, &temp);
zscal_(&i__4, &z__1, &h__[i1 + j * h_dim1], &c__1);
if (*wantz) {
d_cnjg(&z__1, &temp);
zscal_(&nz, &z__1, &z__[*iloz + j * z_dim1], &
c__1);
}
}
/* L90: */
}
}
/* L100: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = i__ + (i__ - 1) * h_dim1;
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = i__ + (i__ - 1) * h_dim1;
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h__[i1 + i__ * h_dim1], &c__1);
if (*wantz) {
zscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L110: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L120:
/* H(I,I-1) is negligible: one eigenvalue has converged. */
i__1 = i__;
i__2 = i__ + i__ * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L130:
return 0;
/* End of ZLAHQR */
} /* zlahqr_ */
/* ztrevc.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b2
#undef c_b2
#endif
#define c_b2 c_b2
/* Subroutine */ int ztrevc_(side, howmny, select, n, t, ldt, vl, ldvl, vr,
ldvr, mm, m, work, rwork, info, side_len, howmny_len)
char *side, *howmny;
logical *select;
integer *n;
doublecomplex *t;
integer *ldt;
doublecomplex *vl;
integer *ldvl;
doublecomplex *vr;
integer *ldvr, *mm, *m;
doublecomplex *work;
doublereal *rwork;
integer *info;
ftnlen side_len;
ftnlen howmny_len;
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag();
void d_cnjg();
/* Local variables */
static logical allv;
static doublereal unfl, ovfl, smin;
static logical over;
static integer i__, j, k;
static doublereal scale;
extern logical lsame_();
static doublereal remax;
static logical leftv, bothv;
extern /* Subroutine */ int zgemv_();
static logical somev;
extern /* Subroutine */ int zcopy_(), dlabad_();
static integer ii, ki;
extern doublereal dlamch_();
static integer is;
extern /* Subroutine */ int xerbla_(), zdscal_();
extern integer izamax_();
static logical rightv;
extern doublereal dzasum_();
static doublereal smlnum;
extern /* Subroutine */ int zlatrs_();
static doublereal ulp;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTREVC computes some or all of the right and/or left eigenvectors of
*/
/* a complex upper triangular matrix T. */
/* The right eigenvector x and the left eigenvector y of T corresponding
*/
/* to an eigenvalue w are defined by: */
/* T*x = w*x, y'*T = w*y' */
/* where y' denotes the conjugate transpose of the vector y. */
/* If all eigenvectors are requested, the routine may either return the
*/
/* matrices X and/or Y of right or left eigenvectors of T, or the */
/* products Q*X and/or Q*Y, where Q is an input unitary */
/* matrix. If T was obtained from the Schur factorization of an */
/* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of */
/* right or left eigenvectors of A. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'R': compute right eigenvectors only; */
/* = 'L': compute left eigenvectors only; */
/* = 'B': compute both right and left eigenvectors. */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute all right and/or left eigenvectors; */
/* = 'B': compute all right and/or left eigenvectors, */
/* and backtransform them using the input matrices */
/* supplied in VR and/or VL; */
/* = 'S': compute selected right and/or left eigenvectors, */
/* specified by the logical array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
/* computed. */
/* If HOWMNY = 'A' or 'B', SELECT is not referenced. */
/* To select the eigenvector corresponding to the j-th */
/* eigenvalue, SELECT(j) must be set to .TRUE.. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) COMPLEX*16 array, dimension (LDT,N) */
/* The upper triangular matrix T. T is modified, but restored */
/* on exit. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) */
/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
/* Schur vectors returned by ZHSEQR). */
/* On exit, if SIDE = 'L' or 'B', VL contains: */
/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
/* if HOWMNY = 'B', the matrix Q*Y; */
/* if HOWMNY = 'S', the left eigenvectors of T specified by */
/* SELECT, stored consecutively in the columns
*/
/* of VL, in the same order as their */
/* eigenvalues. */
/* If SIDE = 'R', VL is not referenced. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= max(1,N) if */
/* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */
/* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) */
/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
/* Schur vectors returned by ZHSEQR). */
/* On exit, if SIDE = 'R' or 'B', VR contains: */
/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
/* if HOWMNY = 'B', the matrix Q*X; */
/* if HOWMNY = 'S', the right eigenvectors of T specified by */
/* SELECT, stored consecutively in the columns
*/
/* of VR, in the same order as their */
/* eigenvalues. */
/* If SIDE = 'L', VR is not referenced. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= max(1,N) if */
/* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */
/* MM (input) INTEGER */
/* The number of columns in the arrays VL and/or VR. MM >= M. */
/* M (output) INTEGER */
/* The number of columns in the arrays VL and/or VR actually */
/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
/* is set to N. Each selected eigenvector occupies one */
/* column. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The algorithm used in this program is basically backward (forward) */
/* substitution, with scaling to make the the code robust against */
/* possible overflow. */
/* Each eigenvector is normalized so that the element of largest */
/* magnitude has magnitude 1; here the magnitude of a complex number */
/* (x,y) is taken to be |x| + |y|. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = t_dim1 + 1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = vl_dim1 + 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = vr_dim1 + 1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
bothv = lsame_(side, "B", 1L, 1L);
rightv = lsame_(side, "R", 1L, 1L) || bothv;
leftv = lsame_(side, "L", 1L, 1L) || bothv;
allv = lsame_(howmny, "A", 1L, 1L);
over = lsame_(howmny, "B", 1L, 1L) || lsame_(howmny, "O", 1L, 1L);
somev = lsame_(howmny, "S", 1L, 1L);
/* Set M to the number of columns required to store the selected */
/* eigenvectors. */
if (somev) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! allv && ! over && ! somev) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTREVC", &i__1, 6L);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = dlamch_("Safe minimum", 12L);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision", 9L);
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + *n;
i__3 = i__ + i__ * t_dim1;
work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
/* L20: */
}
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
rwork[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
rwork[j] = dzasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/* L30: */
}
if (rightv) {
/* Compute right eigenvectors. */
is = *m;
for (ki = *n; ki >= 1; --ki) {
if (somev) {
if (! select[ki]) {
goto L80;
}
}
/* Computing MAX */
i__1 = ki + ki * t_dim1;
d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&t[
ki + ki * t_dim1]), abs(d__2)));
smin = max(d__3,smlnum);
work[1].r = 1., work[1].i = 0.;
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = k + ki * t_dim1;
z__1.r = -t[i__3].r, z__1.i = -t[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L40: */
}
/* Solve the triangular system: */
/* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * t_dim1;
i__3 = k + k * t_dim1;
i__4 = ki + ki * t_dim1;
z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = z__1.r, t[i__2].i = z__1.i;
i__2 = k + k * t_dim1;
if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[k + k *
t_dim1]), abs(d__2)) < smin) {
i__3 = k + k * t_dim1;
t[i__3].r = smin, t[i__3].i = 0.;
}
/* L50: */
}
if (ki > 1) {
i__1 = ki - 1;
zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
t_offset], ldt, &work[1], &scale, &rwork[1], info, 5L,
12L, 8L, 1L);
i__1 = ki;
work[i__1].r = scale, work[i__1].i = 0.;
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over) {
zcopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
ii = izamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
i__1 = ii + is * vr_dim1;
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr[ii + is * vr_dim1]), abs(d__2)));
zdscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
i__2 = k + is * vr_dim1;
vr[i__2].r = 0., vr[i__2].i = 0.;
/* L60: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &z__1, &vr[ki * vr_dim1 + 1], &c__1,
1L);
}
ii = izamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
i__1 = ii + ki * vr_dim1;
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr[ii + ki * vr_dim1]), abs(d__2)));
zdscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
}
/* Set back the original diagonal elements of T. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * t_dim1;
i__3 = k + *n;
t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
/* L70: */
}
--is;
L80:
;
}
}
if (leftv) {
/* Compute left eigenvectors. */
is = 1;
i__1 = *n;
for (ki = 1; ki <= i__1; ++ki) {
if (somev) {
if (! select[ki]) {
goto L130;
}
}
/* Computing MAX */
i__2 = ki + ki * t_dim1;
d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[
ki + ki * t_dim1]), abs(d__2)));
smin = max(d__3,smlnum);
i__2 = *n;
work[i__2].r = 1., work[i__2].i = 0.;
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k;
d_cnjg(&z__2, &t[ki + k * t_dim1]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
/* Solve the triangular system: */
/* (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k + k * t_dim1;
i__4 = k + k * t_dim1;
i__5 = ki + ki * t_dim1;
z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = z__1.r, t[i__3].i = z__1.i;
i__3 = k + k * t_dim1;
if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[k + k *
t_dim1]), abs(d__2)) < smin) {
i__4 = k + k * t_dim1;
t[i__4].r = smin, t[i__4].i = 0.;
}
/* L100: */
}
if (ki < *n) {
i__2 = *n - ki;
zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki +
1], &scale, &rwork[1], info, 5L, 19L, 8L, 1L);
i__2 = ki;
work[i__2].r = scale, work[i__2].i = 0.;
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over) {
i__2 = *n - ki + 1;
zcopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1)
;
i__2 = *n - ki + 1;
ii = izamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
i__2 = ii + is * vl_dim1;
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl[ii + is * vl_dim1]), abs(d__2)));
i__2 = *n - ki + 1;
zdscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = k + is * vl_dim1;
vl[i__3].r = 0., vl[i__3].i = 0.;
/* L110: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1],
ldvl, &work[ki + 1], &c__1, &z__1, &vl[ki *
vl_dim1 + 1], &c__1, 1L);
}
ii = izamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
i__2 = ii + ki * vl_dim1;
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl[ii + ki * vl_dim1]), abs(d__2)));
zdscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
}
/* Set back the original diagonal elements of T. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k + k * t_dim1;
i__4 = k + *n;
t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
/* L120: */
}
++is;
L130:
;
}
}
return 0;
/* End of ZTREVC */
} /* ztrevc_ */
syntax highlighted by Code2HTML, v. 0.9.1