int
f2c_cscal(integer* N,
complex* alpha,
complex* X, integer* incX)
{
cscal_(N, alpha, X, incX);
return 0;
}
/* Subroutine */
int cgbtf2_(integer *m, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
integer i__, j, km, jp, ju, kv;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *), cgeru_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *), cswap_( integer *, complex *, integer *, complex *, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*kl < 0)
{
*info = -3;
}
else if (*ku < 0)
{
*info = -4;
}
else if (*ldab < *kl + kv + 1)
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0)
{
return 0;
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero. */
i__1 = min(kv,*n);
for (j = *ku + 2;
j <= i__1;
++j)
{
i__2 = *kl;
for (i__ = kv - j + 2;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * ab_dim1;
ab[i__3].r = 0.f;
ab[i__3].i = 0.f; // , expr subst
/* L10: */
}
/* L20: */
}
/* JU is the index of the last column affected by the current stage */
/* of the factorization. */
ju = 1;
i__1 = min(*m,*n);
for (j = 1;
j <= i__1;
++j)
{
/* Set fill-in elements in column J+KV to zero. */
if (j + kv <= *n)
{
i__2 = *kl;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + (j + kv) * ab_dim1;
ab[i__3].r = 0.f;
ab[i__3].i = 0.f; // , expr subst
/* L30: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__2 = *kl;
i__3 = *m - j; // , expr subst
km = min(i__2,i__3);
i__2 = km + 1;
jp = icamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
ipiv[j] = jp + j - 1;
i__2 = kv + jp + j * ab_dim1;
if (ab[i__2].r != 0.f || ab[i__2].i != 0.f)
{
/* Computing MAX */
/* Computing MIN */
i__4 = j + *ku + jp - 1;
i__2 = ju;
i__3 = min(i__4,*n); // , expr subst
ju = max(i__2,i__3);
/* Apply interchange to columns J to JU. */
if (jp != 1)
{
i__2 = ju - j + 1;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 + j * ab_dim1], &i__4);
}
if (km > 0)
{
/* Compute multipliers. */
c_div(&q__1, &c_b1, &ab[kv + 1 + j * ab_dim1]);
cscal_(&km, &q__1, &ab[kv + 2 + j * ab_dim1], &c__1);
/* Update trailing submatrix within the band. */
if (ju > j)
{
i__2 = ju - j;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cgeru_(&km, &i__2, &q__1, &ab[kv + 2 + j * ab_dim1], & c__1, &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 + (j + 1) * ab_dim1], &i__4);
}
}
}
else
{
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0)
{
*info = j;
}
}
/* L40: */
}
return 0;
/* End of CGBTF2 */
}
/* Subroutine */ int cgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, complex *a, integer *lda, complex *w, complex *vl,
integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi,
real *scale, real *abnrm, real *rconde, real *rcondv, complex *work,
integer *lwork, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
complex q__1, q__2;
/* Local variables */
integer i__, k;
char job[1];
real scl, dum[1], eps;
complex tmp;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
integer icond;
logical scalea;
real cscale;
logical select[1];
real bignum;
integer minwrk, maxwrk;
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
real smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* 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. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, ie. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the Schur form of the balanced */
/* version of the matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX 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 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. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing 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 */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) REAL */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) REAL array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) REAL array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
/* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B', */
/* LWORK >= N*N+2*N. */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (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 or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of W */
/* contain eigenvalues which have converged. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -10;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -12;
}
/* 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 CHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
chseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
vr[vr_offset], ldvr, &work[1], &c_n1, info);
}
}
hswork = work[1].r;
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n << 1;
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 1;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
if (*lwork < minwrk && ! lquery) {
*info = -20;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = clange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
cgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = clange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* 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;
cgehrd_(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';
clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(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;
chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(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;
chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from CHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need N) */
ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[1], &
ierr);
}
/* Compute condition numbers if desired */
/* (CWorkspace: need N*N+2*N unless SENSE = 'E') */
/* (RWorkspace: need 2*N unless SENSE = 'E') */
if (! wntsnn) {
ctrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &rwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
cgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
csscal_(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 */
r__1 = vl[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vl[k + i__ * vl_dim1]);
rwork[k] = r__1 * r__1 + r__2 * r__2;
}
k = isamax_(n, &rwork[1], &c__1);
r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
r__1 = sqrt(rwork[k]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
r__1 = vl[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
cgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
csscal_(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 */
r__1 = vr[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vr[k + i__ * vr_dim1]);
rwork[k] = r__1 * r__1 + r__2 * r__2;
}
k = isamax_(n, &rwork[1], &c__1);
r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
r__1 = sqrt(rwork[k]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
r__1 = vr[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr);
}
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGEEVX */
} /* cgeevx_ */
int chgeqz_(char *job, char *compq, char *compz, int *n,
int *ilo, int *ihi, complex *h__, int *ldh, complex *t,
int *ldt, complex *alpha, complex *beta, complex *q, int *ldq,
complex *z__, int *ldz, complex *work, int *lwork, float *
rwork, int *info)
{
/* System generated locals */
int h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
float r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
double r_imag(complex *);
void c_div(complex *, complex *, complex *), pow_ci(complex *, complex *,
int *), c_sqrt(complex *, complex *);
/* Local variables */
float c__;
int j;
complex s, t1;
int jc, in;
complex u12;
int jr;
complex ad11, ad12, ad21, ad22;
int jch;
int ilq, ilz;
float ulp;
complex abi22;
float absb, atol, btol, temp;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *);
float temp2;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
complex ctemp;
int iiter, ilast, jiter;
float anorm, bnorm;
int maxit;
complex shift;
float tempr;
complex ctemp2, ctemp3;
int ilazr2;
float ascale, bscale;
complex signbc;
extern double slamch_(char *), clanhs_(char *, int *,
complex *, int *, float *);
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *);
float safmin;
extern int xerbla_(char *, int *);
complex eshift;
int ilschr;
int icompq, ilastm;
complex rtdisc;
int ischur;
int ilazro;
int icompz, ifirst, ifrstm, istart;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */
/* where H is an upper Hessenberg matrix and T is upper triangular, */
/* using the single-shift QZ method. */
/* Matrix pairs of this type are produced by the reduction to */
/* generalized upper Hessenberg form of a complex matrix pair (A,B): */
/* A = Q1*H*Z1**H, B = Q1*T*Z1**H, */
/* as computed by CGGHRD. */
/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
/* also reduced to generalized Schur form, */
/* H = Q*S*Z**H, T = Q*P*Z**H, */
/* where Q and Z are unitary matrices and S and P are upper triangular. */
/* Optionally, the unitary matrix Q from the generalized Schur */
/* factorization may be postmultiplied into an input matrix Q1, and the */
/* unitary matrix Z may be postmultiplied into an input matrix Z1. */
/* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced */
/* the matrix pair (A,B) to generalized Hessenberg form, then the output */
/* matrices Q1*Q and Z1*Z are the unitary factors from the generalized */
/* Schur factorization of (A,B): */
/* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. */
/* To avoid overflow, eigenvalues of the matrix pair (H,T) */
/* (equivalently, of (A,B)) are computed as a pair of complex values */
/* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an */
/* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */
/* A*x = lambda*B*x */
/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
/* alternate form of the GNEP */
/* mu*A*y = B*y. */
/* The values of alpha and beta for the i-th eigenvalue can be read */
/* directly from the generalized Schur form: alpha = S(i,i), */
/* beta = P(i,i). */
/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
/* pp. 241--256. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': Compute eigenvalues only; */
/* = 'S': Computer eigenvalues and the Schur form. */
/* COMPQ (input) CHARACTER*1 */
/* = 'N': Left Schur vectors (Q) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Q */
/* of left Schur vectors of (H,T) is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry and */
/* the product Q1*Q is returned. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Right Schur vectors (Z) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Z */
/* of right Schur vectors of (H,T) is returned; */
/* = 'V': Z must contain a unitary matrix Z1 on entry and */
/* the product Z1*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrices H, T, Q, and Z. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* ILO and IHI mark the rows and columns of H which are in */
/* Hessenberg form. It is assumed that A is already upper */
/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
/* H (input/output) COMPLEX array, dimension (LDH, N) */
/* On entry, the N-by-N upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper triangular */
/* matrix S from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of H matches that of S, but */
/* the rest of H is unspecified. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX( 1, N ). */
/* T (input/output) COMPLEX array, dimension (LDT, N) */
/* On entry, the N-by-N upper triangular matrix T. */
/* On exit, if JOB = 'S', T contains the upper triangular */
/* matrix P from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of T matches that of P, but */
/* the rest of T is unspecified. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= MAX( 1, N ). */
/* ALPHA (output) COMPLEX array, dimension (N) */
/* The complex scalars alpha that define the eigenvalues of */
/* GNEP. ALPHA(i) = S(i,i) in the generalized Schur */
/* factorization. */
/* BETA (output) COMPLEX array, dimension (N) */
/* The float non-negative scalars beta that define the */
/* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized */
/* Schur factorization. */
/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
/* represent the j-th eigenvalue of the matrix pair (A,B), in */
/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
/* Since either lambda or mu may overflow, they should not, */
/* in general, be computed. */
/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of left Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* left Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1. */
/* If COMPQ='V' or 'I', then LDQ >= N. */
/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of right Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* right Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If COMPZ='V' or 'I', then LDZ >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,N). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO+1,...,N should be correct. */
/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO-N+1,...,N should be correct. */
/* Further Details */
/* =============== */
/* We assume that complex ABS works as long as its value is less than */
/* overflow. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode JOB, COMPQ, COMPZ */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
if (lsame_(job, "E")) {
ilschr = FALSE;
ischur = 1;
} else if (lsame_(job, "S")) {
ilschr = TRUE;
ischur = 2;
} else {
ischur = 0;
}
if (lsame_(compq, "N")) {
ilq = FALSE;
icompq = 1;
} else if (lsame_(compq, "V")) {
ilq = TRUE;
icompq = 2;
} else if (lsame_(compq, "I")) {
ilq = TRUE;
icompq = 3;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE;
icompz = 1;
} else if (lsame_(compz, "V")) {
ilz = TRUE;
icompz = 2;
} else if (lsame_(compz, "I")) {
ilz = TRUE;
icompz = 3;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = MAX(1,*n);
work[1].r = (float) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (ischur == 0) {
*info = -1;
} else if (icompq == 0) {
*info = -2;
} else if (icompz == 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1) {
*info = -5;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -6;
} else if (*ldh < *n) {
*info = -8;
} else if (*ldt < *n) {
*info = -10;
} else if (*ldq < 1 || ilq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || ilz && *ldz < *n) {
*info = -16;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = slamch_("S");
ulp = slamch_("E") * slamch_("B");
anorm = clanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]);
bnorm = clanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * anorm;
atol = MAX(r__1,r__2);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * bnorm;
btol = MAX(r__1,r__2);
ascale = 1.f / MAX(safmin,anorm);
bscale = 1.f / MAX(safmin,bnorm);
/* Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L10: */
}
/* If IHI < ILO, skip QZ steps */
if (*ihi < *ilo) {
goto L190;
}
/* MAIN QZ ITERATION LOOP */
/* Initialize dynamic indices */
/* Eigenvalues ILAST+1:N have been found. */
/* Column operations modify rows IFRSTM:whatever */
/* Row operations modify columns whatever:ILASTM */
/* If only eigenvalues are being computed, then */
/* IFRSTM is the row of the last splitting row above row ILAST; */
/* this is always at least ILO. */
/* IITER counts iterations since the last eigenvalue was found, */
/* to tell when to use an extraordinary shift. */
/* MAXIT is the maximum number of QZ sweeps allowed. */
ilast = *ihi;
if (ilschr) {
ifrstm = 1;
ilastm = *n;
} else {
ifrstm = *ilo;
ilastm = *ihi;
}
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
maxit = (*ihi - *ilo + 1) * 30;
i__1 = maxit;
for (jiter = 1; jiter <= i__1; ++jiter) {
/* Check for too many iterations. */
if (jiter > maxit) {
goto L180;
}
/* Split the matrix if possible. */
/* Two tests: */
/* 1: H(j,j-1)=0 or j=ILO */
/* 2: T(j,j)=0 */
/* Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = ilast + (ilast - 1) * h_dim1;
if ((r__1 = h__[i__2].r, ABS(r__1)) + (r__2 = r_imag(&h__[ilast
+ (ilast - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
goto L60;
}
}
if (c_abs(&t[ilast + ilast * t_dim1]) <= btol) {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for H(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE;
} else {
i__3 = j + (j - 1) * h_dim1;
if ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j
+ (j - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__3 = j + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
ilazro = TRUE;
} else {
ilazro = FALSE;
}
}
/* Test 2: for T(j,j)=0 */
if (c_abs(&t[j + j * t_dim1]) < btol) {
i__3 = j + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE;
if (! ilazro) {
i__3 = j + (j - 1) * h_dim1;
i__4 = j + 1 + j * h_dim1;
i__5 = j + j * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&
h__[j + (j - 1) * h_dim1]), ABS(r__2))) * (
ascale * ((r__3 = h__[i__4].r, ABS(r__3)) + (
r__4 = r_imag(&h__[j + 1 + j * h_dim1]), ABS(
r__4)))) <= ((r__5 = h__[i__5].r, ABS(r__5)) + (
r__6 = r_imag(&h__[j + j * h_dim1]), ABS(r__6)))
* (ascale * atol)) {
ilazr2 = TRUE;
}
}
/* If both tests pass (1 & 2), i.e., the leading diagonal */
/* element of B in the block is zero, split a 1x1 block off */
/* at the top. (I.e., at the J-th row/column) The leading */
/* diagonal element of the remainder can also be zero, so */
/* this may have to be done repeatedly. */
if (ilazro || ilazr2) {
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, &
s, &h__[jch + jch * h_dim1]);
i__4 = jch + 1 + jch * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = ilastm - jch;
crot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
&s);
i__4 = ilastm - jch;
crot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
if (ilazr2) {
i__4 = jch + (jch - 1) * h_dim1;
i__5 = jch + (jch - 1) * h_dim1;
q__1.r = c__ * h__[i__5].r, q__1.i = c__ * h__[
i__5].i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
}
ilazr2 = FALSE;
i__4 = jch + 1 + (jch + 1) * t_dim1;
if ((r__1 = t[i__4].r, ABS(r__1)) + (r__2 = r_imag(&
t[jch + 1 + (jch + 1) * t_dim1]), ABS(r__2))
>= btol) {
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
/* Then process as in the case T(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + (jch + 1) * t_dim1;
ctemp.r = t[i__4].r, ctemp.i = t[i__4].i;
clartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], &
c__, &s, &t[jch + (jch + 1) * t_dim1]);
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
crot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
t[jch + 1 + (jch + 2) * t_dim1], ldt, &
c__, &s);
}
i__4 = ilastm - jch + 2;
crot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
&s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
i__4 = jch + 1 + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], &
c__, &s, &h__[jch + 1 + jch * h_dim1]);
i__4 = jch + 1 + (jch - 1) * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = jch + 1 - ifrstm;
crot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
;
i__4 = jch - ifrstm;
crot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
;
if (ilz) {
crot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
- 1) * z_dim1 + 1], &c__1, &c__, &s);
}
/* L30: */
}
goto L50;
}
} else if (ilazro) {
/* Only test 1 passed -- work on J:ILAST */
ifirst = j;
goto L70;
}
/* Neither test passed -- try next J */
/* L40: */
}
/* (Drop-through is "impossible") */
*info = (*n << 1) + 1;
goto L210;
/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
/* 1x1 block. */
L50:
i__2 = ilast + ilast * h_dim1;
ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i;
clartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
ilast + ilast * h_dim1]);
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = ilast - ifrstm;
crot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
ilast - 1) * h_dim1], &c__1, &c__, &s);
i__2 = ilast - ifrstm;
crot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
1) * t_dim1], &c__1, &c__, &s);
if (ilz) {
crot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
z_dim1 + 1], &c__1, &c__, &s);
}
/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = c_abs(&t[ilast + ilast * t_dim1]);
if (absb > safmin) {
i__2 = ilast + ilast * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = ilast + ilast * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = ilast - ifrstm;
cscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1);
i__2 = ilast + 1 - ifrstm;
cscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1);
} else {
i__2 = ilast + ilast * h_dim1;
i__3 = ilast + ilast * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1);
}
} else {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = ilast;
i__3 = ilast + ilast * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = ilast;
i__3 = ilast + ilast * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
if (! ilschr) {
ilastm = ilast;
if (ifrstm > ilast) {
ifrstm = *ilo;
}
}
goto L160;
/* QZ step */
/* This iteration only involves rows/columns IFIRST:ILAST. We */
/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
L70:
++iiter;
if (! ilschr) {
ifrstm = ifirst;
}
/* Compute the Shift. */
/* At this point, IFIRST < ILAST, and the diagonal elements of */
/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
/* magnitude) */
if (iiter / 10 * 10 != iiter) {
/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */
/* the bottom-right 2x2 block of A inv(B) which is nearest to */
/* the bottom-right element. */
/* We factor B as U*D, where U has unit diagonals, and */
/* compute (A*inv(D))*inv(U). */
i__2 = ilast - 1 + ilast * t_dim1;
q__2.r = bscale * t[i__2].r, q__2.i = bscale * t[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
u12.r = q__1.r, u12.i = q__1.i;
i__2 = ilast - 1 + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad11.r = q__1.r, ad11.i = q__1.i;
i__2 = ilast + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad21.r = q__1.r, ad21.i = q__1.i;
i__2 = ilast - 1 + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad12.r = q__1.r, ad12.i = q__1.i;
i__2 = ilast + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad22.r = q__1.r, ad22.i = q__1.i;
q__2.r = u12.r * ad21.r - u12.i * ad21.i, q__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
q__1.r = ad22.r - q__2.r, q__1.i = ad22.i - q__2.i;
abi22.r = q__1.r, abi22.i = q__1.i;
q__2.r = ad11.r + abi22.r, q__2.i = ad11.i + abi22.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
t1.r = q__1.r, t1.i = q__1.i;
pow_ci(&q__4, &t1, &c__2);
q__5.r = ad12.r * ad21.r - ad12.i * ad21.i, q__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
q__6.r = ad11.r * ad22.r - ad11.i * ad22.i, q__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
c_sqrt(&q__1, &q__2);
rtdisc.r = q__1.r, rtdisc.i = q__1.i;
q__1.r = t1.r - abi22.r, q__1.i = t1.i - abi22.i;
q__2.r = t1.r - abi22.r, q__2.i = t1.i - abi22.i;
temp = q__1.r * rtdisc.r + r_imag(&q__2) * r_imag(&rtdisc);
if (temp <= 0.f) {
q__1.r = t1.r + rtdisc.r, q__1.i = t1.i + rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
} else {
q__1.r = t1.r - rtdisc.r, q__1.i = t1.i - rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
}
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = ilast - 1 + ilast * h_dim1;
q__4.r = ascale * h__[i__2].r, q__4.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__5.r = bscale * t[i__3].r, q__5.i = bscale * t[i__3].i;
c_div(&q__3, &q__4, &q__5);
r_cnjg(&q__2, &q__3);
q__1.r = eshift.r + q__2.r, q__1.i = eshift.i + q__2.i;
eshift.r = q__1.r, eshift.i = q__1.i;
shift.r = eshift.r, shift.i = eshift.i;
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = j + j * h_dim1;
q__2.r = ascale * h__[i__3].r, q__2.i = ascale * h__[i__3].i;
i__4 = j + j * t_dim1;
q__4.r = bscale * t[i__4].r, q__4.i = bscale * t[i__4].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
temp = (r__1 = ctemp.r, ABS(r__1)) + (r__2 = r_imag(&ctemp),
ABS(r__2));
i__3 = j + 1 + j * h_dim1;
temp2 = ascale * ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&h__[j + 1 + j * h_dim1]), ABS(r__2)));
tempr = MAX(temp,temp2);
if (tempr < 1.f && tempr != 0.f) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = j + (j - 1) * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j + (
j - 1) * h_dim1]), ABS(r__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = ifirst + ifirst * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ifirst + ifirst * t_dim1;
q__4.r = bscale * t[i__3].r, q__4.i = bscale * t[i__3].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
L90:
/* Do an implicit-shift QZ sweep. */
/* Initial Q */
i__2 = istart + 1 + istart * h_dim1;
q__1.r = ascale * h__[i__2].r, q__1.i = ascale * h__[i__2].i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
clartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = j + (j - 1) * h_dim1;
ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i;
clartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &
h__[j + (j - 1) * h_dim1]);
i__3 = j + 1 + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = j + jc * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = j + 1 + jc * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = j + 1 + jc * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = j + 1 + jc * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = j + jc * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
i__4 = j + jc * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = j + 1 + jc * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
i__4 = j + 1 + jc * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = j + 1 + jc * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = j + jc * t_dim1;
t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + j * q_dim1;
q__2.r = c__ * q[i__4].r, q__2.i = c__ * q[i__4].i;
r_cnjg(&q__4, &s);
i__5 = jr + (j + 1) * q_dim1;
q__3.r = q__4.r * q[i__5].r - q__4.i * q[i__5].i, q__3.i =
q__4.r * q[i__5].i + q__4.i * q[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + (j + 1) * q_dim1;
q__3.r = -s.r, q__3.i = -s.i;
i__5 = jr + j * q_dim1;
q__2.r = q__3.r * q[i__5].r - q__3.i * q[i__5].i, q__2.i =
q__3.r * q[i__5].i + q__3.i * q[i__5].r;
i__6 = jr + (j + 1) * q_dim1;
q__4.r = c__ * q[i__6].r, q__4.i = c__ * q[i__6].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
q[i__4].r = q__1.r, q[i__4].i = q__1.i;
i__4 = jr + j * q_dim1;
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = j + 1 + (j + 1) * t_dim1;
ctemp.r = t[i__3].r, ctemp.i = t[i__3].i;
clartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
1) * t_dim1]);
i__3 = j + 1 + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Computing MIN */
i__4 = j + 2;
i__3 = MIN(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = jr + j * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = jr + j * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = jr + j * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = jr + j * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = jr + (j + 1) * t_dim1;
t[i__4].r = ctemp.r, t[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * z_dim1;
q__2.r = c__ * z__[i__4].r, q__2.i = c__ * z__[i__4].i;
i__5 = jr + j * z_dim1;
q__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, q__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * z_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * z_dim1;
q__2.r = q__3.r * z__[i__5].r - q__3.i * z__[i__5].i,
q__2.i = q__3.r * z__[i__5].i + q__3.i * z__[i__5]
.r;
i__6 = jr + j * z_dim1;
q__5.r = c__ * z__[i__6].r, q__5.i = c__ * z__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * z_dim1;
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
L160:
/* L170: */
;
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
goto L210;
/* Successful completion of all QZ steps */
L190:
/* Set Eigenvalues 1:ILO-1 */
i__1 = *ilo - 1;
for (j = 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
q__1.r = (float) (*n), q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
/* End of CHGEQZ */
} /* chgeqz_ */
/* Subroutine */ int clabrd_(integer *m, integer *n, integer *nb, complex *a,
integer *lda, real *d__, real *e, complex *tauq, complex *taup,
complex *x, integer *ldx, complex *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;
complex q__1;
/* Local variables */
integer i__;
complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemv_(char *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), clarfg_(integer *, complex *, complex *,
integer *, complex *), clacgv_(integer *, complex *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLABRD 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 CGEBRD */
/* 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 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) REAL array, dimension (NB) */
/* The diagonal elements of the first NB rows and columns of */
/* the reduced matrix. D(i) = A(i,i). */
/* E (output) REAL array, dimension (NB) */
/* The off-diagonal elements of the first NB rows and columns of */
/* the reduced matrix. */
/* TAUQ (output) COMPLEX array dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix Q. See Further Details. */
/* TAUP (output) COMPLEX array, dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix P. See Further Details. */
/* X (output) COMPLEX 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 array, dimension (LDY,NB) */
/* The n-by-nb matrix Y required to update the unreduced part */
/* of A. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= max(1,N). */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, and v and u are complex */
/* vectors. */
/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The elements of the vectors v and u together form the m-by-nb matrix */
/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
/* the transformation to the unreduced part of the matrix, using a block */
/* update of the form: A := A - V*Y' - X*U'. */
/* The contents of A on exit are illustrated by the following examples */
/* with nb = 2: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix which is unchanged, */
/* vi denotes an element of the vector defining H(i), and ui an element */
/* of the vector defining G(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */
i__2 = i__ - 1;
clacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + a_dim1], lda,
&y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
clacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + x_dim1], ldx,
&a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ *
a_dim1], &c__1);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
clarfg_(&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.f, a[i__2].i = 0.f;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + (
i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], &
c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ +
a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ +
x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
y[i__ * y_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[(i__ +
1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *n - i__;
cscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
clacgv_(&i__, &a[i__ + a_dim1], lda);
i__2 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__, &q__1, &y[i__ + 1 +
y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + (
i__ + 1) * a_dim1], lda);
clacgv_(&i__, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
clacgv_(&i__2, &x[i__ + x_dim1], ldx);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[(i__ +
1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &
a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ - 1;
clacgv_(&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;
clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
taup[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + (i__ + 1) * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__;
cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__
+ 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1
+ y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b1, &x[i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__, &q__1, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b1, &x[i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *m - i__;
cscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__;
clacgv_(&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;
clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + y_dim1], ldy,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1],
lda);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
clacgv_(&i__2, &x[i__ + x_dim1], ldx);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[i__ *
a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ +
i__ * a_dim1], lda);
i__2 = i__ - 1;
clacgv_(&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;
clarfg_(&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.f, a[i__2].i = 0.f;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ *
a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ +
y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 +
1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ *
x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *m - i__;
cscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__ + 1;
clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
/* Update A(i+1:m,i) */
i__2 = i__ - 1;
clacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 +
a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ +
1 + i__ * a_dim1], &c__1);
i__2 = i__ - 1;
clacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__, &q__1, &x[i__ + 1 +
x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[
i__ + 1 + i__ * a_dim1], &c__1);
/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1,
&tauq[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__;
i__3 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1]
, &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__;
cgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1
+ x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Conjugate transpose", &i__, &i__2, &q__1, &a[(i__ + 1)
* a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *n - i__;
cscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
} else {
i__2 = *n - i__ + 1;
clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
}
/* L20: */
}
}
return 0;
/* End of CLABRD */
} /* clabrd_ */
int cgbbrd_(char *vect, int *m, int *n, int *ncc,
int *kl, int *ku, complex *ab, int *ldab, float *d__,
float *e, complex *q, int *ldq, complex *pt, int *ldpt,
complex *c__, int *ldc, complex *work, float *rwork, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
int i__, j, l;
complex t;
int j1, j2, kb;
complex ra, rb;
float rc;
int kk, ml, nr, mu;
complex rs;
int kb1, ml0, mu0, klm, kun, nrt, klu1, inca;
float abst;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *), cscal_(int *,
complex *, complex *, int *);
extern int lsame_(char *, char *);
int wantb, wantc;
int minmn;
int wantq;
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *), xerbla_(char *, int
*), clargv_(int *, complex *, int *, complex *,
int *, float *, int *), clartv_(int *, complex *,
int *, complex *, int *, float *, complex *, int *);
int wantpt;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGBBRD reduces a complex general m-by-n band matrix A to float upper */
/* bidiagonal form B by a unitary transformation: Q' * A * P = B. */
/* The routine computes B, and optionally forms Q or P', or computes */
/* Q'*C for a given matrix C. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* Specifies whether or not the matrices Q and P' are to be */
/* formed. */
/* = 'N': do not form Q or P'; */
/* = 'Q': form Q only; */
/* = 'P': form P' only; */
/* = 'B': form both. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals of the matrix A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals of the matrix A. KU >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the m-by-n band matrix A, stored in rows 1 to */
/* KL+KU+1. The j-th column of A is stored in the j-th column of */
/* the array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for MAX(1,j-ku)<=i<=MIN(m,j+kl). */
/* On exit, A is overwritten by values generated during the */
/* reduction. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array A. LDAB >= KL+KU+1. */
/* D (output) REAL array, dimension (MIN(M,N)) */
/* The diagonal elements of the bidiagonal matrix B. */
/* E (output) REAL array, dimension (MIN(M,N)-1) */
/* The superdiagonal elements of the bidiagonal matrix B. */
/* Q (output) COMPLEX array, dimension (LDQ,M) */
/* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q. */
/* If VECT = 'N' or 'P', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= MAX(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */
/* PT (output) COMPLEX array, dimension (LDPT,N) */
/* If VECT = 'P' or 'B', the n-by-n unitary matrix P'. */
/* If VECT = 'N' or 'Q', the array PT is not referenced. */
/* LDPT (input) INTEGER */
/* The leading dimension of the array PT. */
/* LDPT >= MAX(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */
/* C (input/output) COMPLEX array, dimension (LDC,NCC) */
/* On entry, an m-by-ncc matrix C. */
/* On exit, C is overwritten by Q'*C. */
/* C is not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= MAX(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */
/* WORK (workspace) COMPLEX array, dimension (MAX(M,N)) */
/* RWORK (workspace) REAL array, dimension (MAX(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1;
pt -= pt_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
--rwork;
/* Function Body */
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < MAX(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < MAX(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < MAX(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
claset_("Full", m, m, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (wantpt) {
claset_("Full", n, n, &c_b1, &c_b2, &pt[pt_offset], ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = MIN(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */
/* first to lower bidiagonal form and then transform to upper */
/* bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied in */
/* vector operations of length NR over the index set J1:J2:KLU1. */
/* The complex sines of the plane rotations are stored in WORK, */
/* and the float cosines in RWORK. */
/* Computing MIN */
i__1 = *m - 1;
klm = MIN(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = MIN(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th column and i-th row of matrix to bidiagonal form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= i__2; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero elements */
/* which have been created below the band */
if (nr > 0) {
clargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca,
&work[j1], &kb1, &rwork[j1], &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= i__3; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) *
ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm
+ l - 1) * ab_dim1], &inca, &rwork[j1], &work[
j1], &kb1);
}
/* L10: */
}
if (ml > ml0) {
if (ml <= *m - i__ + 1) {
/* generate plane rotation to annihilate a(i+ml-1,i) */
/* within the band, and apply rotation from the left */
clartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku +
ml + i__ * ab_dim1], &rwork[i__ + ml - 1], &
work[i__ + ml - 1], &ra);
i__3 = *ku + ml - 1 + i__ * ab_dim1;
ab[i__3].r = ra.r, ab[i__3].i = ra.i;
if (i__ < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i__;
i__3 = MIN(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
crot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) *
ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__
+ 1) * ab_dim1], &i__7, &rwork[i__ + ml -
1], &work[i__ + ml - 1]);
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations in Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
{
r_cnjg(&q__1, &work[j]);
crot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j *
q_dim1 + 1], &c__1, &rwork[j], &q__1);
/* L20: */
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
crot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1]
, ldc, &rwork[j], &work[j]);
/* L30: */
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j-1,j+ku) above the band */
/* and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
i__5 = (j + kun) * ab_dim1 + 1;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
/* L40: */
}
/* generate plane rotations to annihilate nonzero elements */
/* which have been generated above the band */
if (nr > 0) {
clargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, &
work[j1 + kun], &kb1, &rwork[j1 + kun], &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= i__4; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], &
inca, &ab[l + (j1 + kun) * ab_dim1], &inca, &
rwork[j1 + kun], &work[j1 + kun], &kb1);
}
/* L50: */
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i,i+mu-1) */
/* within the band, and apply rotation from the right */
clartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1],
&ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1],
&rwork[i__ + mu - 1], &work[i__ + mu - 1], &
ra);
i__4 = *ku - mu + 3 + (i__ + mu - 2) * ab_dim1;
ab[i__4].r = ra.r, ab[i__4].i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i__;
i__4 = MIN(i__3,i__5);
crot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) *
ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu
- 1) * ab_dim1], &c__1, &rwork[i__ + mu - 1],
&work[i__ + mu - 1]);
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations in P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
r_cnjg(&q__1, &work[j + kun]);
crot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j +
kun + pt_dim1], ldpt, &rwork[j + kun], &q__1);
/* L60: */
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j+kl+ku,j+ku-1) below the */
/* band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
i__5 = klu1 + (j + kun) * ab_dim1;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form */
/* Transform lower bidiagonal form to upper bidiagonal by applying */
/* plane rotations from the left, overwriting superdiagonal */
/* elements on subdiagonal elements */
/* Computing MIN */
i__2 = *m - 1;
i__1 = MIN(i__2,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
clartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs,
&ra);
i__2 = i__ * ab_dim1 + 1;
ab[i__2].r = ra.r, ab[i__2].i = ra.i;
if (i__ < *n) {
i__2 = i__ * ab_dim1 + 2;
i__4 = (i__ + 1) * ab_dim1 + 1;
q__1.r = rs.r * ab[i__4].r - rs.i * ab[i__4].i, q__1.i = rs.r
* ab[i__4].i + rs.i * ab[i__4].r;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
i__2 = (i__ + 1) * ab_dim1 + 1;
i__4 = (i__ + 1) * ab_dim1 + 1;
q__1.r = rc * ab[i__4].r, q__1.i = rc * ab[i__4].i;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &rs);
crot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 +
1], &c__1, &rc, &q__1);
}
if (wantc) {
crot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1],
ldc, &rc, &rs);
}
/* L100: */
}
} else {
/* A has been reduced to complex upper bidiagonal form or is */
/* diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from the */
/* right */
i__1 = *ku + (*m + 1) * ab_dim1;
rb.r = ab[i__1].r, rb.i = ab[i__1].i;
for (i__ = *m; i__ >= 1; --i__) {
clartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra);
i__1 = *ku + 1 + i__ * ab_dim1;
ab[i__1].r = ra.r, ab[i__1].i = ra.i;
if (i__ > 1) {
r_cnjg(&q__3, &rs);
q__2.r = -q__3.r, q__2.i = -q__3.i;
i__1 = *ku + i__ * ab_dim1;
q__1.r = q__2.r * ab[i__1].r - q__2.i * ab[i__1].i,
q__1.i = q__2.r * ab[i__1].i + q__2.i * ab[i__1]
.r;
rb.r = q__1.r, rb.i = q__1.i;
i__1 = *ku + i__ * ab_dim1;
i__2 = *ku + i__ * ab_dim1;
q__1.r = rc * ab[i__2].r, q__1.i = rc * ab[i__2].i;
ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
}
if (wantpt) {
r_cnjg(&q__1, &rs);
crot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1],
ldpt, &rc, &q__1);
}
/* L110: */
}
}
}
/* Make diagonal and superdiagonal elements float, storing them in D */
/* and E */
i__1 = *ku + 1 + ab_dim1;
t.r = ab[i__1].r, t.i = ab[i__1].i;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
abst = c_abs(&t);
d__[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantq) {
cscal_(m, &t, &q[i__ * q_dim1 + 1], &c__1);
}
if (wantc) {
r_cnjg(&q__1, &t);
cscal_(ncc, &q__1, &c__[i__ + c_dim1], ldc);
}
if (i__ < minmn) {
if (*ku == 0 && *kl == 0) {
e[i__] = 0.f;
i__2 = (i__ + 1) * ab_dim1 + 1;
t.r = ab[i__2].r, t.i = ab[i__2].i;
} else {
if (*ku == 0) {
i__2 = i__ * ab_dim1 + 2;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
} else {
i__2 = *ku + (i__ + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
abst = c_abs(&t);
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantpt) {
cscal_(n, &t, &pt[i__ + 1 + pt_dim1], ldpt);
}
i__2 = *ku + 1 + (i__ + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i, q__1.i =
ab[i__2].r * q__2.i + ab[i__2].i * q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
}
/* L120: */
}
return 0;
/* End of CGBBRD */
} /* cgbbrd_ */
/*< subroutine csvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) >*/
/* Subroutine */ int csvdc_(complex *x, integer *ldx, integer *n, integer *p,
complex *s, complex *e, complex *u, integer *ldu, complex *v, integer
*ldv, complex *work, integer *job, integer *info)
{
/* System generated locals */
integer x_dim1, x_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3;
/* Builtin functions */
double r_imag(complex *), c_abs(complex *);
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
double sqrt(doublereal);
/* Local variables */
real b, c__, f, g;
integer i__, j, k, l=0, m;
complex r__, t;
real t1, el;
integer kk;
real cs;
integer ll, mm, ls=0;
real sl;
integer lu;
real sm, sn;
integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
real emm1, smm1;
integer kase, jobu, iter;
real test;
integer nctp1, nrtp1;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
real scale;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
real shift;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer maxit;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), csrot_(integer *, complex *,
integer *, complex *, integer *, real *, real *);
logical wantu, wantv;
extern /* Subroutine */ int srotg_(real *, real *, real *, real *);
real ztest;
extern doublereal scnrm2_(integer *, complex *, integer *);
/*< integer ldx,n,p,ldu,ldv,job,info >*/
/*< complex x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1) >*/
/* csvdc is a subroutine to reduce a complex nxp matrix x by */
/* unitary transformations u and v to diagonal form. the */
/* diagonal elements s(i) are the singular values of x. the */
/* columns of u are the corresponding left singular vectors, */
/* and the columns of v the right singular vectors. */
/* on entry */
/* x complex(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by csvdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix x. */
/* p integer. */
/* p is the number of columns of the matrix x. */
/* ldu integer. */
/* ldu is the leading dimension of the array u */
/* (see below). */
/* ldv integer. */
/* ldv is the leading dimension of the array v */
/* (see below). */
/* work complex(n). */
/* work is a scratch array. */
/* job integer. */
/* job controls the computation of the singular */
/* vectors. it has the decimal expansion ab */
/* with the following meaning */
/* a.eq.0 do not compute the left singular */
/* vectors. */
/* a.eq.1 return the n left singular vectors */
/* in u. */
/* a.ge.2 returns the first min(n,p) */
/* left singular vectors in u. */
/* b.eq.0 do not compute the right singular */
/* vectors. */
/* b.eq.1 return the right singular vectors */
/* in v. */
/* on return */
/* s complex(mm), where mm=min(n+1,p). */
/* the first min(n,p) entries of s contain the */
/* singular values of x arranged in descending */
/* order of magnitude. */
/* e complex(p). */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u complex(ldu,k), where ldu.ge.n. if joba.eq.1 then */
/* k.eq.n, if joba.ge.2 then */
/* k.eq.min(n,p). */
/* u contains the matrix of left singular vectors. */
/* u is not referenced if joba.eq.0. if n.le.p */
/* or if joba.gt.2, then u may be identified with x */
/* in the subroutine call. */
/* v complex(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if jobb.eq.0. if p.le.n, */
/* then v may be identified whth x in the */
/* subroutine call. */
/* info integer. */
/* the singular values (and their corresponding */
/* singular vectors) s(info+1),s(info+2),...,s(m) */
/* are correct (here m=min(n,p)). thus if */
/* info.eq.0, all the singular values and their */
/* vectors are correct. in any event, the matrix */
/* b = ctrans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (ctrans(u) */
/* is the conjugate-transpose of u). thus the */
/* singular values of x and b are the same. */
/* linpack. this version dated 03/19/79 . */
/* correction to shift calculation made 2/85. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* csvdc uses the following functions and subprograms. */
/* external csrot */
/* blas caxpy,cdotc,cscal,cswap,scnrm2,srotg */
/* fortran abs,aimag,amax1,cabs,cmplx */
/* fortran conjg,max0,min0,mod,real,sqrt */
/* internal variables */
/*< >*/
/*< complex cdotc,t,r >*/
/*< >*/
/*< logical wantu,wantv >*/
/*< complex csign,zdum,zdum1,zdum2 >*/
/*< real cabs1 >*/
/*< cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) >*/
/*< csign(zdum1,zdum2) = cabs(zdum1)*(zdum2/cabs(zdum2)) >*/
/* set the maximum number of iterations. */
/*< maxit = 1000 >*/
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--s;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
/* Function Body */
maxit = 1000;
/* determine what is to be computed. */
/*< wantu = .false. >*/
wantu = FALSE_;
/*< wantv = .false. >*/
wantv = FALSE_;
/*< jobu = mod(job,100)/10 >*/
jobu = *job % 100 / 10;
/*< ncu = n >*/
ncu = *n;
/*< if (jobu .gt. 1) ncu = min0(n,p) >*/
if (jobu > 1) {
ncu = min(*n,*p);
}
/*< if (jobu .ne. 0) wantu = .true. >*/
if (jobu != 0) {
wantu = TRUE_;
}
/*< if (mod(job,10) .ne. 0) wantv = .true. >*/
if (*job % 10 != 0) {
wantv = TRUE_;
}
/* reduce x to bidiagonal form, storing the diagonal elements */
/* in s and the super-diagonal elements in e. */
/*< info = 0 >*/
*info = 0;
/*< nct = min0(n-1,p) >*/
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/*< nrt = max0(0,min0(p-2,n)) >*/
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
/*< lu = max0(nct,nrt) >*/
lu = max(nct,nrt);
/*< if (lu .lt. 1) go to 170 >*/
if (lu < 1) {
goto L170;
}
/*< do 160 l = 1, lu >*/
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nct) go to 20 >*/
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
/*< s(l) = cmplx(scnrm2(n-l+1,x(l,l),1),0.0e0) >*/
i__2 = l;
i__3 = *n - l + 1;
r__1 = scnrm2_(&i__3, &x[l + l * x_dim1], &c__1);
q__1.r = r__1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 10 >*/
i__2 = l;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(r__2)
) == (float)0.) {
goto L10;
}
/*< if (cabs1(x(l,l)) .ne. 0.0e0) s(l) = csign(s(l),x(l,l)) >*/
i__2 = l + l * x_dim1;
if ((r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[l + l * x_dim1]
), dabs(r__2)) != (float)0.) {
i__3 = l;
r__3 = c_abs(&s[l]);
i__4 = l + l * x_dim1;
r__4 = c_abs(&x[l + l * x_dim1]);
q__2.r = x[i__4].r / r__4, q__2.i = x[i__4].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
s[i__3].r = q__1.r, s[i__3].i = q__1.i;
}
/*< call cscal(n-l+1,1.0e0/s(l),x(l,l),1) >*/
i__2 = *n - l + 1;
c_div(&q__1, &c_b8, &s[l]);
cscal_(&i__2, &q__1, &x[l + l * x_dim1], &c__1);
/*< x(l,l) = (1.0e0,0.0e0) + x(l,l) >*/
i__2 = l + l * x_dim1;
i__3 = l + l * x_dim1;
q__1.r = x[i__3].r + (float)1., q__1.i = x[i__3].i + (float)0.;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/*< 10 continue >*/
L10:
/*< s(l) = -s(l) >*/
i__2 = l;
i__3 = l;
q__1.r = -s[i__3].r, q__1.i = -s[i__3].i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< 20 continue >*/
L20:
/*< if (p .lt. lp1) go to 50 >*/
if (*p < lp1) {
goto L50;
}
/*< do 40 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< if (l .gt. nct) go to 30 >*/
if (l > nct) {
goto L30;
}
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 30 >*/
i__3 = l;
if ((r__1 = s[i__3].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(
r__2)) == (float)0.) {
goto L30;
}
/* apply the transformation. */
/*< t = -cdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) >*/
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &x[l + l * x_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(n-l+1,t,x(l,l),1,x(l,j),1) >*/
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
/*< 30 continue >*/
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
/*< e(j) = conjg(x(l,j)) >*/
i__3 = j;
r_cnjg(&q__1, &x[l + j * x_dim1]);
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
/*< 40 continue >*/
/* L40: */
}
/*< 50 continue >*/
L50:
/*< if (.not.wantu .or. l .gt. nct) go to 70 >*/
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
/*< do 60 i = l, n >*/
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
/*< u(i,l) = x(i,l) >*/
i__3 = i__ + l * u_dim1;
i__4 = i__ + l * x_dim1;
u[i__3].r = x[i__4].r, u[i__3].i = x[i__4].i;
/*< 60 continue >*/
/* L60: */
}
/*< 70 continue >*/
L70:
/*< if (l .gt. nrt) go to 150 >*/
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
/*< e(l) = cmplx(scnrm2(p-l,e(lp1),1),0.0e0) >*/
i__2 = l;
i__3 = *p - l;
r__1 = scnrm2_(&i__3, &e[lp1], &c__1);
q__1.r = r__1, q__1.i = (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (cabs1(e(l)) .eq. 0.0e0) go to 80 >*/
i__2 = l;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l]), dabs(r__2)
) == (float)0.) {
goto L80;
}
/*< if (cabs1(e(lp1)) .ne. 0.0e0) e(l) = csign(e(l),e(lp1)) >*/
i__2 = lp1;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[lp1]), dabs(
r__2)) != (float)0.) {
i__3 = l;
r__3 = c_abs(&e[l]);
i__4 = lp1;
r__4 = c_abs(&e[lp1]);
q__2.r = e[i__4].r / r__4, q__2.i = e[i__4].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
}
/*< call cscal(p-l,1.0e0/e(l),e(lp1),1) >*/
i__2 = *p - l;
c_div(&q__1, &c_b8, &e[l]);
cscal_(&i__2, &q__1, &e[lp1], &c__1);
/*< e(lp1) = (1.0e0,0.0e0) + e(lp1) >*/
i__2 = lp1;
i__3 = lp1;
q__1.r = e[i__3].r + (float)1., q__1.i = e[i__3].i + (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< 80 continue >*/
L80:
/*< e(l) = -conjg(e(l)) >*/
i__2 = l;
r_cnjg(&q__2, &e[l]);
q__1.r = -q__2.r, q__1.i = -q__2.i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (lp1 .gt. n .or. cabs1(e(l)) .eq. 0.0e0) go to 120 >*/
i__2 = l;
if (lp1 > *n || (r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l])
, dabs(r__2)) == (float)0.) {
goto L120;
}
/* apply the transformation. */
/*< do 90 i = lp1, n >*/
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< work(i) = (0.0e0,0.0e0) >*/
i__3 = i__;
work[i__3].r = (float)0., work[i__3].i = (float)0.;
/*< 90 continue >*/
/* L90: */
}
/*< do 100 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< call caxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) >*/
i__3 = *n - l;
caxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/*< 100 continue >*/
/* L100: */
}
/*< do 110 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< >*/
i__3 = *n - l;
i__4 = j;
q__3.r = -e[i__4].r, q__3.i = -e[i__4].i;
c_div(&q__2, &q__3, &e[lp1]);
r_cnjg(&q__1, &q__2);
caxpy_(&i__3, &q__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/*< 110 continue >*/
/* L110: */
}
/*< 120 continue >*/
L120:
/*< if (.not.wantv) go to 140 >*/
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
/*< do 130 i = lp1, p >*/
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< v(i,l) = e(i) >*/
i__3 = i__ + l * v_dim1;
i__4 = i__;
v[i__3].r = e[i__4].r, v[i__3].i = e[i__4].i;
/*< 130 continue >*/
/* L130: */
}
/*< 140 continue >*/
L140:
/*< 150 continue >*/
L150:
/*< 160 continue >*/
/* L160: */
;
}
/*< 170 continue >*/
L170:
/* set up the final bidiagonal matrix or order m. */
/*< m = min0(p,n+1) >*/
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
/*< nctp1 = nct + 1 >*/
nctp1 = nct + 1;
/*< nrtp1 = nrt + 1 >*/
nrtp1 = nrt + 1;
/*< if (nct .lt. p) s(nctp1) = x(nctp1,nctp1) >*/
if (nct < *p) {
i__1 = nctp1;
i__2 = nctp1 + nctp1 * x_dim1;
s[i__1].r = x[i__2].r, s[i__1].i = x[i__2].i;
}
/*< if (n .lt. m) s(m) = (0.0e0,0.0e0) >*/
if (*n < m) {
i__1 = m;
s[i__1].r = (float)0., s[i__1].i = (float)0.;
}
/*< if (nrtp1 .lt. m) e(nrtp1) = x(nrtp1,m) >*/
if (nrtp1 < m) {
i__1 = nrtp1;
i__2 = nrtp1 + m * x_dim1;
e[i__1].r = x[i__2].r, e[i__1].i = x[i__2].i;
}
/*< e(m) = (0.0e0,0.0e0) >*/
i__1 = m;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/* if required, generate u. */
/*< if (.not.wantu) go to 300 >*/
if (! wantu) {
goto L300;
}
/*< if (ncu .lt. nctp1) go to 200 >*/
if (ncu < nctp1) {
goto L200;
}
/*< do 190 j = nctp1, ncu >*/
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
/*< do 180 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,j) = (0.0e0,0.0e0) >*/
i__3 = i__ + j * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 180 continue >*/
/* L180: */
}
/*< u(j,j) = (1.0e0,0.0e0) >*/
i__2 = j + j * u_dim1;
u[i__2].r = (float)1., u[i__2].i = (float)0.;
/*< 190 continue >*/
/* L190: */
}
/*< 200 continue >*/
L200:
/*< if (nct .lt. 1) go to 290 >*/
if (nct < 1) {
goto L290;
}
/*< do 280 ll = 1, nct >*/
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = nct - ll + 1 >*/
l = nct - ll + 1;
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 250 >*/
i__2 = l;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(r__2)
) == (float)0.) {
goto L250;
}
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (ncu .lt. lp1) go to 220 >*/
if (ncu < lp1) {
goto L220;
}
/*< do 210 j = lp1, ncu >*/
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
/*< t = -cdotc(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) >*/
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &u[l + l * u_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(n-l+1,t,u(l,l),1,u(l,j),1) >*/
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/*< 210 continue >*/
/* L210: */
}
/*< 220 continue >*/
L220:
/*< call cscal(n-l+1,(-1.0e0,0.0e0),u(l,l),1) >*/
i__2 = *n - l + 1;
cscal_(&i__2, &c_b53, &u[l + l * u_dim1], &c__1);
/*< u(l,l) = (1.0e0,0.0e0) + u(l,l) >*/
i__2 = l + l * u_dim1;
i__3 = l + l * u_dim1;
q__1.r = u[i__3].r + (float)1., q__1.i = u[i__3].i + (float)0.;
u[i__2].r = q__1.r, u[i__2].i = q__1.i;
/*< lm1 = l - 1 >*/
lm1 = l - 1;
/*< if (lm1 .lt. 1) go to 240 >*/
if (lm1 < 1) {
goto L240;
}
/*< do 230 i = 1, lm1 >*/
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 230 continue >*/
/* L230: */
}
/*< 240 continue >*/
L240:
/*< go to 270 >*/
goto L270;
/*< 250 continue >*/
L250:
/*< do 260 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 260 continue >*/
/* L260: */
}
/*< u(l,l) = (1.0e0,0.0e0) >*/
i__2 = l + l * u_dim1;
u[i__2].r = (float)1., u[i__2].i = (float)0.;
/*< 270 continue >*/
L270:
/*< 280 continue >*/
/* L280: */
;
}
/*< 290 continue >*/
L290:
/*< 300 continue >*/
L300:
/* if it is required, generate v. */
/*< if (.not.wantv) go to 350 >*/
if (! wantv) {
goto L350;
}
/*< do 340 ll = 1, p >*/
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = p - ll + 1 >*/
l = *p - ll + 1;
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nrt) go to 320 >*/
if (l > nrt) {
goto L320;
}
/*< if (cabs1(e(l)) .eq. 0.0e0) go to 320 >*/
i__2 = l;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l]), dabs(r__2)
) == (float)0.) {
goto L320;
}
/*< do 310 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< t = -cdotc(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) >*/
i__3 = *p - l;
cdotc_(&q__3, &i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &v[lp1 + l * v_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) >*/
i__3 = *p - l;
caxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/*< 310 continue >*/
/* L310: */
}
/*< 320 continue >*/
L320:
/*< do 330 i = 1, p >*/
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< v(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * v_dim1;
v[i__3].r = (float)0., v[i__3].i = (float)0.;
/*< 330 continue >*/
/* L330: */
}
/*< v(l,l) = (1.0e0,0.0e0) >*/
i__2 = l + l * v_dim1;
v[i__2].r = (float)1., v[i__2].i = (float)0.;
/*< 340 continue >*/
/* L340: */
}
/*< 350 continue >*/
L350:
/* transform s and e so that they are real. */
/*< do 380 i = 1, m >*/
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< if (cabs1(s(i)) .eq. 0.0e0) go to 360 >*/
i__2 = i__;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[i__]), dabs(
r__2)) == (float)0.) {
goto L360;
}
/*< t = cmplx(cabs(s(i)),0.0e0) >*/
r__1 = c_abs(&s[i__]);
q__1.r = r__1, q__1.i = (float)0.;
t.r = q__1.r, t.i = q__1.i;
/*< r = s(i)/t >*/
c_div(&q__1, &s[i__], &t);
r__.r = q__1.r, r__.i = q__1.i;
/*< s(i) = t >*/
i__2 = i__;
s[i__2].r = t.r, s[i__2].i = t.i;
/*< if (i .lt. m) e(i) = e(i)/r >*/
if (i__ < m) {
i__2 = i__;
c_div(&q__1, &e[i__], &r__);
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
}
/*< if (wantu) call cscal(n,r,u(1,i),1) >*/
if (wantu) {
cscal_(n, &r__, &u[i__ * u_dim1 + 1], &c__1);
}
/*< 360 continue >*/
L360:
/* ...exit */
/*< if (i .eq. m) go to 390 >*/
if (i__ == m) {
goto L390;
}
/*< if (cabs1(e(i)) .eq. 0.0e0) go to 370 >*/
i__2 = i__;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[i__]), dabs(
r__2)) == (float)0.) {
goto L370;
}
/*< t = cmplx(cabs(e(i)),0.0e0) >*/
r__1 = c_abs(&e[i__]);
q__1.r = r__1, q__1.i = (float)0.;
t.r = q__1.r, t.i = q__1.i;
/*< r = t/e(i) >*/
c_div(&q__1, &t, &e[i__]);
r__.r = q__1.r, r__.i = q__1.i;
/*< e(i) = t >*/
i__2 = i__;
e[i__2].r = t.r, e[i__2].i = t.i;
/*< s(i+1) = s(i+1)*r >*/
i__2 = i__ + 1;
i__3 = i__ + 1;
q__1.r = s[i__3].r * r__.r - s[i__3].i * r__.i, q__1.i = s[i__3].r *
r__.i + s[i__3].i * r__.r;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (wantv) call cscal(p,r,v(1,i+1),1) >*/
if (wantv) {
cscal_(p, &r__, &v[(i__ + 1) * v_dim1 + 1], &c__1);
}
/*< 370 continue >*/
L370:
/*< 380 continue >*/
/* L380: */
;
}
/*< 390 continue >*/
L390:
/* main iteration loop for the singular values. */
/*< mm = m >*/
mm = m;
/*< iter = 0 >*/
iter = 0;
/*< 400 continue >*/
L400:
/* quit if all the singular values have been found. */
/* ...exit */
/*< if (m .eq. 0) go to 660 >*/
if (m == 0) {
goto L660;
}
/* if too many iterations have been performed, set */
/* flag and return. */
/*< if (iter .lt. maxit) go to 410 >*/
if (iter < maxit) {
goto L410;
}
/*< info = m >*/
*info = m;
/* ......exit */
/*< go to 660 >*/
goto L660;
/*< 410 continue >*/
L410:
/* this section of the program inspects for */
/* negligible elements in the s and e arrays. on */
/* completion the variables kase and l are set as follows. */
/* kase = 1 if s(m) and e(l-1) are negligible and l.lt.m */
/* kase = 2 if s(l) is negligible and l.lt.m */
/* kase = 3 if e(l-1) is negligible, l.lt.m, and */
/* s(l), ..., s(m) are not negligible (qr step). */
/* kase = 4 if e(m-1) is negligible (convergence). */
/*< do 430 ll = 1, m >*/
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = m - ll >*/
l = m - ll;
/* ...exit */
/*< if (l .eq. 0) go to 440 >*/
if (l == 0) {
goto L440;
}
/*< test = cabs(s(l)) + cabs(s(l+1)) >*/
test = c_abs(&s[l]) + c_abs(&s[l + 1]);
/*< ztest = test + cabs(e(l)) >*/
ztest = test + c_abs(&e[l]);
/*< if (ztest .ne. test) go to 420 >*/
if (ztest != test) {
goto L420;
}
/*< e(l) = (0.0e0,0.0e0) >*/
i__2 = l;
e[i__2].r = (float)0., e[i__2].i = (float)0.;
/* ......exit */
/*< go to 440 >*/
goto L440;
/*< 420 continue >*/
L420:
/*< 430 continue >*/
/* L430: */
;
}
/*< 440 continue >*/
L440:
/*< if (l .ne. m - 1) go to 450 >*/
if (l != m - 1) {
goto L450;
}
/*< kase = 4 >*/
kase = 4;
/*< go to 520 >*/
goto L520;
/*< 450 continue >*/
L450:
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< mp1 = m + 1 >*/
mp1 = m + 1;
/*< do 470 lls = lp1, mp1 >*/
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
/*< ls = m - lls + lp1 >*/
ls = m - lls + lp1;
/* ...exit */
/*< if (ls .eq. l) go to 480 >*/
if (ls == l) {
goto L480;
}
/*< test = 0.0e0 >*/
test = (float)0.;
/*< if (ls .ne. m) test = test + cabs(e(ls)) >*/
if (ls != m) {
test += c_abs(&e[ls]);
}
/*< if (ls .ne. l + 1) test = test + cabs(e(ls-1)) >*/
if (ls != l + 1) {
test += c_abs(&e[ls - 1]);
}
/*< ztest = test + cabs(s(ls)) >*/
ztest = test + c_abs(&s[ls]);
/*< if (ztest .ne. test) go to 460 >*/
if (ztest != test) {
goto L460;
}
/*< s(ls) = (0.0e0,0.0e0) >*/
i__2 = ls;
s[i__2].r = (float)0., s[i__2].i = (float)0.;
/* ......exit */
/*< go to 480 >*/
goto L480;
/*< 460 continue >*/
L460:
/*< 470 continue >*/
/* L470: */
;
}
/*< 480 continue >*/
L480:
/*< if (ls .ne. l) go to 490 >*/
if (ls != l) {
goto L490;
}
/*< kase = 3 >*/
kase = 3;
/*< go to 510 >*/
goto L510;
/*< 490 continue >*/
L490:
/*< if (ls .ne. m) go to 500 >*/
if (ls != m) {
goto L500;
}
/*< kase = 1 >*/
kase = 1;
/*< go to 510 >*/
goto L510;
/*< 500 continue >*/
L500:
/*< kase = 2 >*/
kase = 2;
/*< l = ls >*/
l = ls;
/*< 510 continue >*/
L510:
/*< 520 continue >*/
L520:
/*< l = l + 1 >*/
++l;
/* perform the task indicated by kase. */
/*< go to (530, 560, 580, 610), kase >*/
switch (kase) {
case 1: goto L530;
case 2: goto L560;
case 3: goto L580;
case 4: goto L610;
}
/* deflate negligible s(m). */
/*< 530 continue >*/
L530:
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< f = real(e(m-1)) >*/
i__1 = m - 1;
f = e[i__1].r;
/*< e(m-1) = (0.0e0,0.0e0) >*/
i__1 = m - 1;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/*< do 550 kk = l, mm1 >*/
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
/*< k = mm1 - kk + l >*/
k = mm1 - kk + l;
/*< t1 = real(s(k)) >*/
i__2 = k;
t1 = s[i__2].r;
/*< call srotg(t1,f,cs,sn) >*/
srotg_(&t1, &f, &cs, &sn);
/*< s(k) = cmplx(t1,0.0e0) >*/
i__2 = k;
q__1.r = t1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (k .eq. l) go to 540 >*/
if (k == l) {
goto L540;
}
/*< f = -sn*real(e(k-1)) >*/
i__2 = k - 1;
f = -sn * e[i__2].r;
/*< e(k-1) = cs*e(k-1) >*/
i__2 = k - 1;
i__3 = k - 1;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< 540 continue >*/
L540:
/*< if (wantv) call csrot(p,v(1,k),1,v(1,m),1,cs,sn) >*/
if (wantv) {
csrot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/*< 550 continue >*/
/* L550: */
}
/*< go to 650 >*/
goto L650;
/* split at negligible s(l). */
/*< 560 continue >*/
L560:
/*< f = real(e(l-1)) >*/
i__1 = l - 1;
f = e[i__1].r;
/*< e(l-1) = (0.0e0,0.0e0) >*/
i__1 = l - 1;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/*< do 570 k = l, m >*/
i__1 = m;
for (k = l; k <= i__1; ++k) {
/*< t1 = real(s(k)) >*/
i__2 = k;
t1 = s[i__2].r;
/*< call srotg(t1,f,cs,sn) >*/
srotg_(&t1, &f, &cs, &sn);
/*< s(k) = cmplx(t1,0.0e0) >*/
i__2 = k;
q__1.r = t1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< f = -sn*real(e(k)) >*/
i__2 = k;
f = -sn * e[i__2].r;
/*< e(k) = cs*e(k) >*/
i__2 = k;
i__3 = k;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (wantu) call csrot(n,u(1,k),1,u(1,l-1),1,cs,sn) >*/
if (wantu) {
csrot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 570 continue >*/
/* L570: */
}
/*< go to 650 >*/
goto L650;
/* perform one qr step. */
/*< 580 continue >*/
L580:
/* calculate the shift. */
/*< >*/
/* Computing MAX */
r__1 = c_abs(&s[m]), r__2 = c_abs(&s[m - 1]), r__1 = max(r__1,r__2), r__2
= c_abs(&e[m - 1]), r__1 = max(r__1,r__2), r__2 = c_abs(&s[l]),
r__1 = max(r__1,r__2), r__2 = c_abs(&e[l]);
scale = dmax(r__1,r__2);
/*< sm = real(s(m))/scale >*/
i__1 = m;
sm = s[i__1].r / scale;
/*< smm1 = real(s(m-1))/scale >*/
i__1 = m - 1;
smm1 = s[i__1].r / scale;
/*< emm1 = real(e(m-1))/scale >*/
i__1 = m - 1;
emm1 = e[i__1].r / scale;
/*< sl = real(s(l))/scale >*/
i__1 = l;
sl = s[i__1].r / scale;
/*< el = real(e(l))/scale >*/
i__1 = l;
el = e[i__1].r / scale;
/*< b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0e0 >*/
/* Computing 2nd power */
r__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + r__1 * r__1) / (float)2.;
/*< c = (sm*emm1)**2 >*/
/* Computing 2nd power */
r__1 = sm * emm1;
c__ = r__1 * r__1;
/*< shift = 0.0e0 >*/
shift = (float)0.;
/*< if (b .eq. 0.0e0 .and. c .eq. 0.0e0) go to 590 >*/
if (b == (float)0. && c__ == (float)0.) {
goto L590;
}
/*< shift = sqrt(b**2+c) >*/
/* Computing 2nd power */
r__1 = b;
shift = sqrt(r__1 * r__1 + c__);
/*< if (b .lt. 0.0e0) shift = -shift >*/
if (b < (float)0.) {
shift = -shift;
}
/*< shift = c/(b + shift) >*/
shift = c__ / (b + shift);
/*< 590 continue >*/
L590:
/*< f = (sl + sm)*(sl - sm) + shift >*/
f = (sl + sm) * (sl - sm) + shift;
/*< g = sl*el >*/
g = sl * el;
/* chase zeros. */
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< do 600 k = l, mm1 >*/
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
/*< call srotg(f,g,cs,sn) >*/
srotg_(&f, &g, &cs, &sn);
/*< if (k .ne. l) e(k-1) = cmplx(f,0.0e0) >*/
if (k != l) {
i__2 = k - 1;
q__1.r = f, q__1.i = (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
}
/*< f = cs*real(s(k)) + sn*real(e(k)) >*/
i__2 = k;
i__3 = k;
f = cs * s[i__2].r + sn * e[i__3].r;
/*< e(k) = cs*e(k) - sn*s(k) >*/
i__2 = k;
i__3 = k;
q__2.r = cs * e[i__3].r, q__2.i = cs * e[i__3].i;
i__4 = k;
q__3.r = sn * s[i__4].r, q__3.i = sn * s[i__4].i;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< g = sn*real(s(k+1)) >*/
i__2 = k + 1;
g = sn * s[i__2].r;
/*< s(k+1) = cs*s(k+1) >*/
i__2 = k + 1;
i__3 = k + 1;
q__1.r = cs * s[i__3].r, q__1.i = cs * s[i__3].i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (wantv) call csrot(p,v(1,k),1,v(1,k+1),1,cs,sn) >*/
if (wantv) {
csrot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
/*< call srotg(f,g,cs,sn) >*/
srotg_(&f, &g, &cs, &sn);
/*< s(k) = cmplx(f,0.0e0) >*/
i__2 = k;
q__1.r = f, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< f = cs*real(e(k)) + sn*real(s(k+1)) >*/
i__2 = k;
i__3 = k + 1;
f = cs * e[i__2].r + sn * s[i__3].r;
/*< s(k+1) = -sn*e(k) + cs*s(k+1) >*/
i__2 = k + 1;
r__1 = -sn;
i__3 = k;
q__2.r = r__1 * e[i__3].r, q__2.i = r__1 * e[i__3].i;
i__4 = k + 1;
q__3.r = cs * s[i__4].r, q__3.i = cs * s[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< g = sn*real(e(k+1)) >*/
i__2 = k + 1;
g = sn * e[i__2].r;
/*< e(k+1) = cs*e(k+1) >*/
i__2 = k + 1;
i__3 = k + 1;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< >*/
if (wantu && k < *n) {
csrot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 600 continue >*/
/* L600: */
}
/*< e(m-1) = cmplx(f,0.0e0) >*/
i__1 = m - 1;
q__1.r = f, q__1.i = (float)0.;
e[i__1].r = q__1.r, e[i__1].i = q__1.i;
/*< iter = iter + 1 >*/
++iter;
/*< go to 650 >*/
goto L650;
/* convergence. */
/*< 610 continue >*/
L610:
/* make the singular value positive */
/*< if (real(s(l)) .ge. 0.0e0) go to 620 >*/
i__1 = l;
if (s[i__1].r >= (float)0.) {
goto L620;
}
/*< s(l) = -s(l) >*/
i__1 = l;
i__2 = l;
q__1.r = -s[i__2].r, q__1.i = -s[i__2].i;
s[i__1].r = q__1.r, s[i__1].i = q__1.i;
/*< if (wantv) call cscal(p,(-1.0e0,0.0e0),v(1,l),1) >*/
if (wantv) {
cscal_(p, &c_b53, &v[l * v_dim1 + 1], &c__1);
}
/*< 620 continue >*/
L620:
/* order the singular value. */
/*< 630 if (l .eq. mm) go to 640 >*/
L630:
if (l == mm) {
goto L640;
}
/* ...exit */
/*< if (real(s(l)) .ge. real(s(l+1))) go to 640 >*/
i__1 = l;
i__2 = l + 1;
if (s[i__1].r >= s[i__2].r) {
goto L640;
}
/*< t = s(l) >*/
i__1 = l;
t.r = s[i__1].r, t.i = s[i__1].i;
/*< s(l) = s(l+1) >*/
i__1 = l;
i__2 = l + 1;
s[i__1].r = s[i__2].r, s[i__1].i = s[i__2].i;
/*< s(l+1) = t >*/
i__1 = l + 1;
s[i__1].r = t.r, s[i__1].i = t.i;
/*< >*/
if (wantv && l < *p) {
cswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
/*< >*/
if (wantu && l < *n) {
cswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
/*< l = l + 1 >*/
++l;
/*< go to 630 >*/
goto L630;
/*< 640 continue >*/
L640:
/*< iter = 0 >*/
iter = 0;
/*< m = m - 1 >*/
--m;
/*< 650 continue >*/
L650:
/*< go to 400 >*/
goto L400;
/*< 660 continue >*/
L660:
/*< return >*/
return 0;
/*< end >*/
} /* csvdc_ */
/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__,
integer *ldz, complex *work, integer *lwork, integer *info)
{
/* 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;
real r__1, r__2, r__3, r__4;
complex q__1;
char ch__1[2];
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static real unfl;
static complex temp;
static real ovfl, opst;
static integer i__, j, k, l;
static complex s[225] /* was [15][15] */;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static complex v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer itemp;
static real rtemp;
static integer i1, i2;
static logical initz, wantt, wantz;
static real rwork[1];
extern doublereal slapy2_(real *, real *);
static integer ii, nh;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
static integer nr, ns;
extern integer icamax_(integer *, complex *, integer *);
static integer nv;
extern doublereal slamch_(char *), clanhs_(char *, integer *,
complex *, integer *, real *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clahqr_(logical *, logical *, integer *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *, complex *,
integer *, integer *), clacpy_(char *, integer *, integer *,
complex *, integer *, complex *, integer *);
static complex vv[16];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int clarfx_(char *, integer *, integer *, complex
*, complex *, complex *, integer *, complex *), xerbla_(
char *, integer *);
static real smlnum;
static logical lquery;
static integer itn;
static complex tau;
static integer its;
static real ulp, tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define s_subscr(a_1,a_2) (a_2)*15 + a_1 - 16
#define s_ref(a_1,a_2) s[s_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
CHSEQR 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 CGEBAL, and then passed to CGEHRD
when the matrix output by CGEBAL 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 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 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 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 CUNGHR after
the call to CGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,N).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, CHSEQR failed to compute all the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
*info = 0;
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -10;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* **
Initialize */
opst = 0.f;
/* **
Initialize Z, if necessary */
if (initz) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by CGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = h___subscr(i__, j);
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
} else {
i1 = *ilo;
i2 = *ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (i__ < *ihi) {
i__2 = h___subscr(i__ + 1, i__);
i__3 = h___subscr(i__ + 1, i__);
q__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, q__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
/* **
Increment op count */
opst += (i2 - i1 + 2) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* L50: */
}
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
clahqr_(&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 = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L60:
if (i__ < *ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__5 = h___subscr(k, k);
tst1 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h___ref(
k - 1, k - 1)), dabs(r__2)) + ((r__3 = h__[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&h___ref(k, k)), dabs(r__4)));
if (tst1 == 0.f) {
i__3 = i__ - l + 1;
tst1 = clanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__3].r, dabs(r__1)) <= dmax(r__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L170;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
i__3 = ii;
i__5 = h___subscr(ii, ii - 1);
i__6 = h___subscr(ii, ii);
r__3 = ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 = h__[i__6]
.r, dabs(r__2))) * 1.5f;
w[i__3].r = r__3, w[i__3].i = 0.f;
/* L90: */
}
/* **
Increment op count */
opst += ns << 1;
/* ** */
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
clacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
clahqr_(&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 CLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = i__ - ns + ii;
i__5 = s_subscr(ii, ii);
w[i__3].r = s[i__5].r, w[i__3].i = s[i__5].i;
/* L100: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in W). The result is
stored in the local array V. */
v[0].r = 1.f, v[0].i = 0.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0.f, v[i__3].i = 0.f;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
ccopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
q__1.r = -w[i__5].r, q__1.i = -w[i__5].i;
cgemv_("No transpose", &i__3, &nv, &c_b2, &h___ref(l, l), ldh, vv,
&c__1, &q__1, v, &c__1);
++nv;
/* **
Increment op count */
opst = opst + (nv << 3) * (*n + 1) + (nv + 1) * 6;
/* **
Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = icamax_(&nv, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
i__3 = itemp - 1;
rtemp = (r__1 = v[i__3].r, dabs(r__1)) + (r__2 = r_imag(&v[itemp
- 1]), dabs(r__2));
if (rtemp == 0.f) {
v[0].r = 1.f, v[0].i = 0.f;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0.f, v[i__5].i = 0.f;
/* L120: */
}
} else {
rtemp = dmax(rtemp,smlnum);
r__1 = 1.f / rtemp;
csscal_(&nv, &r__1, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
}
/* L130: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__3,i__5);
if (k > l) {
ccopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
clarfg_(&nr, v, &v[1], &c__1, &tau);
/* **
Increment op count */
opst = opst + nr * 10 + 12;
/* ** */
if (k > l) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = i__;
for (ii = k + 1; ii <= i__3; ++ii) {
i__5 = h___subscr(ii, k - 1);
h__[i__5].r = 0.f, h__[i__5].i = 0.f;
/* L140: */
}
}
v[0].r = 1.f, v[0].i = 0.f;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
r_cnjg(&q__1, &tau);
clarfx_("Left", &nr, &i__3, v, &q__1, &h___ref(k, k), ldh, &work[
1]);
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i__) - i1 + 1;
clarfx_("Right", &i__3, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
/* **
Increment op count
Computing MIN */
i__3 = nr, i__5 = i__ - k;
latime_1.ops += ((nr << 2) - 2 << 2) * (i2 - i1 + 2 + min(i__3,
i__5));
/* ** */
if (wantz) {
/* Accumulate transformations in the matrix Z */
clarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
/* **
Increment op count */
latime_1.ops += ((nr << 2) - 2 << 2) * nh;
/* ** */
}
/* L150: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* 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. */
clahqr_(&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:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
return 0;
/* End of CHSEQR */
} /* chseqr_ */
/* Subroutine */ int clagsy_(integer *n, integer *k, real *d__, complex *a,
integer *lda, integer *iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
i__9;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
integer i__, j, ii, jj;
complex wa, wb;
real wn;
complex tau;
complex alpha;
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAGSY generates a complex symmetric matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with a random unitary matrix: */
/* A = U*D*U**T. The semi-bandwidth may then be reduced to k by */
/* additional unitary transformations. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* K (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= K <= N-1. */
/* D (input) REAL array, dimension (N) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) COMPLEX array, dimension (LDA,N) */
/* The generated n by n symmetric matrix A (the full matrix is */
/* stored). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= N. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CLAGSY", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* generate random reflection */
i__1 = *n - i__ + 1;
clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
r__1 = wn / c_abs(&work[1]);
q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i__;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
r__1 = q__1.r;
tau.r = r__1, tau.i = 0.f;
}
/* apply random reflection to A(i:n,i:n) from the left */
/* and the right */
/* compute y := tau * A * conjg(u) */
i__1 = *n - i__ + 1;
clacgv_(&i__1, &work[1], &c__1);
i__1 = *n - i__ + 1;
csymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *n - i__ + 1;
clacgv_(&i__1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = -0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__1 = *n - i__ + 1;
cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__1 = *n - i__ + 1;
caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
/* CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */
/* $ A( I, I ), LDA ) */
i__1 = *n;
for (jj = i__; jj <= i__1; ++jj) {
i__2 = *n;
for (ii = jj; ii <= i__2; ++ii) {
i__3 = ii + jj * a_dim1;
i__4 = ii + jj * a_dim1;
i__5 = ii - i__ + 1;
i__6 = *n + jj - i__ + 1;
q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[
i__5].i * work[i__6].r;
q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i;
i__7 = *n + ii - i__ + 1;
i__8 = jj - i__ + 1;
q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[
i__7].i * work[i__8].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L40: */
}
/* L50: */
}
/* L60: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i__ + 1;
wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]);
i__2 = *k + i__ + i__ * a_dim1;
q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *k + i__ + i__ * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *k - i__;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
r__1 = q__1.r;
tau.r = r__1, tau.i = 0.f;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
c_b1, &work[1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
q__1.r = -tau.r, q__1.i = -tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
/* compute y := tau * A * conjg(u) */
i__2 = *n - *k - i__ + 1;
clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
csymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *n - *k - i__ + 1;
clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = -0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__2 = *n - *k - i__ + 1;
cdotc_(&q__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - *k - i__ + 1;
caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
c__1);
/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
/* CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */
/* $ A( K+I, K+I ), LDA ) */
i__2 = *n;
for (jj = *k + i__; jj <= i__2; ++jj) {
i__3 = *n;
for (ii = jj; ii <= i__3; ++ii) {
i__4 = ii + jj * a_dim1;
i__5 = ii + jj * a_dim1;
i__6 = ii + i__ * a_dim1;
i__7 = jj - *k - i__ + 1;
q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i,
q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
i__7].r;
q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i;
i__8 = ii - *k - i__ + 1;
i__9 = jj + i__ * a_dim1;
q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i,
q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
i__9].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__4].r = q__1.r, a[i__4].i = q__1.i;
/* L70: */
}
/* L80: */
}
i__2 = *k + i__ + i__ * a_dim1;
q__1.r = -wa.r, q__1.i = -wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = *n;
for (j = *k + i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L90: */
}
/* L100: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * a_dim1;
i__4 = i__ + j * a_dim1;
a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
/* L110: */
}
/* L120: */
}
return 0;
/* End of CLAGSY */
} /* clagsy_ */
/* Subroutine */
int clarfgp_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *), c_abs(complex *);
/* Local variables */
integer j;
complex savealpha;
integer knt;
real beta;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
real alphi, alphr, xnorm;
extern real scnrm2_(integer *, complex *, integer *), slapy2_(real *, real *), slapy3_(real *, real *, real *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real bignum, smlnum;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f)
{
/* H = [1-alpha/f2c_abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0.f, tau->i = 0.f;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -alpha->r;
q__1.i = -alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.f;
}
}
else
{
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
smlnum = slamch_("S") / slamch_("E");
bignum = 1.f / smlnum;
knt = 0;
if (f2c_abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (f2c_abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
q__1.r = alphr;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
q__1.r = alpha->r + beta;
q__1.i = alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f)
{
beta = -beta;
q__2.r = -alpha->r;
q__2.i = -alpha->i; // , expr subst
q__1.r = q__2.r / beta;
q__1.i = q__2.i / beta; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = alphr / beta;
r__2 = -alphi / beta;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
r__1 = -alphr;
q__1.r = r__1;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
if (c_abs(tau) <= smlnum)
{
/* In the case where the computed TAU ends up being a denormalized number, */
/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */
/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */
/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */
/* (Thanks Pat. Thanks MathWorks.) */
alphr = savealpha.r;
alphi = r_imag(&savealpha);
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
tau->r = 0.f, tau->i = 0.f;
}
else
{
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -savealpha.r;
q__1.i = -savealpha.i; // , expr subst
beta = q__1.r;
}
}
else
{
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
cscal_(&i__1, alpha, &x[1], incx);
}
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1;
j <= i__1;
++j)
{
beta *= smlnum;
/* L20: */
}
alpha->r = beta, alpha->i = 0.f;
}
return 0;
/* End of CLARFGP */
}
/* Subroutine */
int clasyf_(char *uplo, integer *n, integer *nb, integer *kb, complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
integer j, k;
complex t, r1, d11, d21, d22;
integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
real alpha;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *), cgemm_(char *, char *, integer *, integer *, integer * , complex *, complex *, integer *, complex *, integer *, complex * , complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), ccopy_(integer *, complex *, integer *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *);
integer kstep;
real absakk;
extern integer icamax_(integer *, complex *, integer *);
real colmax, rowmax;
/* -- LAPACK computational routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2013 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
*info = 0;
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.f) + 1.f) / 8.f;
if (lsame_(uplo, "U"))
{
/* Factorize the trailing columns of A using the upper triangle */
/* of A and working backwards, and compute the matrix W = U12*D */
/* for use in updating A11 */
/* K is the main loop index, decreasing from N in steps of 1 or 2 */
/* KW is the column of W which corresponds to column K of A */
k = *n;
L10:
kw = *nb + k - *n;
/* Exit from loop */
if (k <= *n - *nb + 1 && *nb < *n || k < 1)
{
goto L30;
}
/* Copy column K of A to column KW of W and update it */
ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
if (k < *n)
{
i__1 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * w_dim1 + 1], &c__1);
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = k + kw * w_dim1;
absakk = (r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[k + kw * w_dim1]), f2c_abs(r__2));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value. */
/* Determine both COLMAX and IMAX. */
if (k > 1)
{
i__1 = k - 1;
imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = imax + kw * w_dim1;
colmax = (r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[imax + kw * w_dim1]), f2c_abs(r__2));
}
else
{
colmax = 0.f;
}
if (max(absakk,colmax) == 0.f)
{
/* Column K is zero or underflow: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
}
else
{
if (absakk >= alpha * colmax)
{
/* no interchange, use 1-by-1 pivot block */
kp = k;
}
else
{
/* Copy column IMAX to column KW-1 of W and update it */
ccopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = k - imax;
ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
if (k < *n)
{
i__1 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1);
}
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
i__1 = jmax + (kw - 1) * w_dim1;
rowmax = (r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[ jmax + (kw - 1) * w_dim1]), f2c_abs(r__2));
if (imax > 1)
{
i__1 = imax - 1;
jmax = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
/* Computing MAX */
i__1 = jmax + (kw - 1) * w_dim1;
r__3 = rowmax;
r__4 = (r__1 = w[i__1].r, f2c_abs(r__1)) + ( r__2 = r_imag(&w[jmax + (kw - 1) * w_dim1]), f2c_abs( r__2)); // , expr subst
rowmax = max(r__3,r__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax))
{
/* no interchange, use 1-by-1 pivot block */
kp = k;
}
else /* if(complicated condition) */
{
i__1 = imax + (kw - 1) * w_dim1;
if ((r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[ imax + (kw - 1) * w_dim1]), f2c_abs(r__2)) >= alpha * rowmax)
{
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
/* copy column KW-1 of W to column KW of W */
ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
}
else
{
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
/* ============================================================ */
/* KK is the column of A where pivoting step stopped */
kk = k - kstep + 1;
/* KKW is the column of W which corresponds to column KK of A */
kkw = *nb + kk - *n;
/* Interchange rows and columns KP and KK. */
/* Updated column KP is already stored in column KKW of W. */
if (kp != kk)
{
/* Copy non-updated column KK to column KP of submatrix A */
/* at step K. No need to copy element into column K */
/* (or K and K-1 for 2-by-2 pivot) of A, since these columns */
/* will be later overwritten. */
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kk - 1 - kp;
ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + 1) * a_dim1], lda);
if (kp > 1)
{
i__1 = kp - 1;
ccopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
}
/* Interchange rows KK and KP in last K+1 to N columns of A */
/* (columns K (or K and K-1 for 2-by-2 pivot) of A will be */
/* later overwritten). Interchange rows KK and KP */
/* in last KKW to NB columns of W. */
if (k < *n)
{
i__1 = *n - k;
cswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + 1) * a_dim1], lda);
}
i__1 = *n - kk + 1;
cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * w_dim1], ldw);
}
if (kstep == 1)
{
/* 1-by-1 pivot block D(k): column kw of W now holds */
/* W(kw) = U(k)*D(k), */
/* where U(k) is the k-th column of U */
/* Store subdiag. elements of column U(k) */
/* and 1-by-1 block D(k) in column k of A. */
/* NOTE: Diagonal element U(k,k) is a UNIT element */
/* and not stored. */
/* A(k,k) := D(k,k) = W(k,kw) */
/* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) */
ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & c__1);
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
r1.r = q__1.r;
r1.i = q__1.i; // , expr subst
i__1 = k - 1;
cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
}
else
{
/* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold */
/* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 */
/* block D(k-1:k,k-1:k) in columns k-1 and k of A. */
/* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT */
/* block and not stored. */
/* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) */
/* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = */
/* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) */
if (k > 2)
{
/* Compose the columns of the inverse of 2-by-2 pivot */
/* block D in the following way to reduce the number */
/* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by */
/* this inverse */
/* D**(-1) = ( d11 d21 )**(-1) = */
/* ( d21 d22 ) */
/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */
/* ( (-d21 ) ( d11 ) ) */
/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */
/* * ( ( d22/d21 ) ( -1 ) ) = */
/* ( ( -1 ) ( d11/d21 ) ) */
/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */
/* ( ( -1 ) ( D22 ) ) */
/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */
/* ( ( -1 ) ( D22 ) ) */
/* = D21 * ( ( D11 ) ( -1 ) ) */
/* ( ( -1 ) ( D22 ) ) */
i__1 = k - 1 + kw * w_dim1;
d21.r = w[i__1].r;
d21.i = w[i__1].i; // , expr subst
c_div(&q__1, &w[k + kw * w_dim1], &d21);
d11.r = q__1.r;
d11.i = q__1.i; // , expr subst
c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
d22.r = q__1.r;
d22.i = q__1.i; // , expr subst
q__3.r = d11.r * d22.r - d11.i * d22.i;
q__3.i = d11.r * d22.i + d11.i * d22.r; // , expr subst
q__2.r = q__3.r - 1.f;
q__2.i = q__3.i - 0.f; // , expr subst
c_div(&q__1, &c_b1, &q__2);
t.r = q__1.r;
t.i = q__1.i; // , expr subst
/* Update elements in columns A(k-1) and A(k) as */
/* dot products of rows of ( W(kw-1) W(kw) ) and columns */
/* of D**(-1) */
c_div(&q__1, &t, &d21);
d21.r = q__1.r;
d21.i = q__1.i; // , expr subst
i__1 = k - 2;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j + (k - 1) * a_dim1;
i__3 = j + (kw - 1) * w_dim1;
q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i;
q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; // , expr subst
i__4 = j + kw * w_dim1;
q__2.r = q__3.r - w[i__4].r;
q__2.i = q__3.i - w[i__4] .i; // , expr subst
q__1.r = d21.r * q__2.r - d21.i * q__2.i;
q__1.i = d21.r * q__2.i + d21.i * q__2.r; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
i__2 = j + k * a_dim1;
i__3 = j + kw * w_dim1;
q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i;
q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; // , expr subst
i__4 = j + (kw - 1) * w_dim1;
q__2.r = q__3.r - w[i__4].r;
q__2.i = q__3.i - w[i__4] .i; // , expr subst
q__1.r = d21.r * q__2.r - d21.i * q__2.i;
q__1.i = d21.r * q__2.i + d21.i * q__2.r; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
/* L20: */
}
}
/* Copy D(k) to A */
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (kw - 1) * w_dim1;
a[i__1].r = w[i__2].r;
a[i__1].i = w[i__2].i; // , expr subst
i__1 = k - 1 + k * a_dim1;
i__2 = k - 1 + kw * w_dim1;
a[i__1].r = w[i__2].r;
a[i__1].i = w[i__2].i; // , expr subst
i__1 = k + k * a_dim1;
i__2 = k + kw * w_dim1;
a[i__1].r = w[i__2].r;
a[i__1].i = w[i__2].i; // , expr subst
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1)
{
ipiv[k] = kp;
}
else
{
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
L30: /* Update the upper triangle of A11 (= A(1:k,1:k)) as */
/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */
/* computing blocks of NB columns at a time */
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1;
i__1 < 0 ? j >= 1 : j <= 1;
j += i__1)
{
/* Computing MIN */
i__2 = *nb;
i__3 = k - j + 1; // , expr subst
jb = min(i__2,i__3);
/* Update the upper triangle of the diagonal block */
i__2 = j + jb - 1;
for (jj = j;
jj <= i__2;
++jj)
{
i__3 = jj - j + 1;
i__4 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) * a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, &a[j + jj * a_dim1], &c__1);
/* L40: */
}
/* Update the rectangular superdiagonal block */
i__2 = j - 1;
i__3 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, &a[( k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda);
/* L50: */
}
/* Put U12 in standard form by partially undoing the interchanges */
/* in columns k+1:n looping backwards from k+1 to n */
j = k + 1;
L60: /* Undo the interchanges (if any) of rows JJ and JP at each */
/* step J */
/* (Here, J is a diagonal index) */
jj = j;
jp = ipiv[j];
if (jp < 0)
{
jp = -jp;
/* (Here, J is a diagonal index) */
++j;
}
/* (NOTE: Here, J is used to determine row length. Length N-J+1 */
/* of the rows to swap back doesn't include diagonal element) */
++j;
if (jp != jj && j <= *n)
{
i__1 = *n - j + 1;
cswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
}
if (j < *n)
{
goto L60;
}
/* Set KB to the number of columns factorized */
*kb = *n - k;
}
else
{
/* Factorize the leading columns of A using the lower triangle */
/* of A and working forwards, and compute the matrix W = L21*D */
/* for use in updating A22 */
/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
k = 1;
L70: /* Exit from loop */
if (k >= *nb && *nb < *n || k > *n)
{
goto L90;
}
/* Copy column K of A to column K of W and update it */
i__1 = *n - k + 1;
ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1);
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = k + k * w_dim1;
absakk = (r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[k + k * w_dim1]), f2c_abs(r__2));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value. */
/* Determine both COLMAX and IMAX. */
if (k < *n)
{
i__1 = *n - k;
imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
i__1 = imax + k * w_dim1;
colmax = (r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[imax + k * w_dim1]), f2c_abs(r__2));
}
else
{
colmax = 0.f;
}
if (max(absakk,colmax) == 0.f)
{
/* Column K is zero or underflow: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
}
else
{
if (absakk >= alpha * colmax)
{
/* no interchange, use 1-by-1 pivot block */
kp = k;
}
else
{
/* Copy column IMAX to column K+1 of W and update it */
i__1 = imax - k;
ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = *n - imax + 1;
ccopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + 1) * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * w_dim1], &c__1);
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) ;
i__1 = jmax + (k + 1) * w_dim1;
rowmax = (r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[ jmax + (k + 1) * w_dim1]), f2c_abs(r__2));
if (imax < *n)
{
i__1 = *n - imax;
jmax = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * w_dim1], &c__1);
/* Computing MAX */
i__1 = jmax + (k + 1) * w_dim1;
r__3 = rowmax;
r__4 = (r__1 = w[i__1].r, f2c_abs(r__1)) + ( r__2 = r_imag(&w[jmax + (k + 1) * w_dim1]), f2c_abs( r__2)); // , expr subst
rowmax = max(r__3,r__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax))
{
/* no interchange, use 1-by-1 pivot block */
kp = k;
}
else /* if(complicated condition) */
{
i__1 = imax + (k + 1) * w_dim1;
if ((r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[ imax + (k + 1) * w_dim1]), f2c_abs(r__2)) >= alpha * rowmax)
{
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
/* copy column K+1 of W to column K of W */
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * w_dim1], &c__1);
}
else
{
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
/* ============================================================ */
/* KK is the column of A where pivoting step stopped */
kk = k + kstep - 1;
/* Interchange rows and columns KP and KK. */
/* Updated column KP is already stored in column KK of W. */
if (kp != kk)
{
/* Copy non-updated column KK to column KP of submatrix A */
/* at step K. No need to copy element into column K */
/* (or K and K+1 for 2-by-2 pivot) of A, since these columns */
/* will be later overwritten. */
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp - kk - 1;
ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + 1) * a_dim1], lda);
if (kp < *n)
{
i__1 = *n - kp;
ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
/* Interchange rows KK and KP in first K-1 columns of A */
/* (columns K (or K and K+1 for 2-by-2 pivot) of A will be */
/* later overwritten). Interchange rows KK and KP */
/* in first KK columns of W. */
if (k > 1)
{
i__1 = k - 1;
cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
}
cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
}
if (kstep == 1)
{
/* 1-by-1 pivot block D(k): column k of W now holds */
/* W(k) = L(k)*D(k), */
/* where L(k) is the k-th column of L */
/* Store subdiag. elements of column L(k) */
/* and 1-by-1 block D(k) in column k of A. */
/* (NOTE: Diagonal element L(k,k) is a UNIT element */
/* and not stored) */
/* A(k,k) := D(k,k) = W(k,k) */
/* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) */
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & c__1);
if (k < *n)
{
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
r1.r = q__1.r;
r1.i = q__1.i; // , expr subst
i__1 = *n - k;
cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
}
else
{
/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
/* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 */
/* block D(k:k+1,k:k+1) in columns k and k+1 of A. */
/* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT */
/* block and not stored) */
/* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) */
/* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = */
/* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) */
if (k < *n - 1)
{
/* Compose the columns of the inverse of 2-by-2 pivot */
/* block D in the following way to reduce the number */
/* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by */
/* this inverse */
/* D**(-1) = ( d11 d21 )**(-1) = */
/* ( d21 d22 ) */
/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */
/* ( (-d21 ) ( d11 ) ) */
/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */
/* * ( ( d22/d21 ) ( -1 ) ) = */
/* ( ( -1 ) ( d11/d21 ) ) */
/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */
/* ( ( -1 ) ( D22 ) ) */
/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */
/* ( ( -1 ) ( D22 ) ) */
/* = D21 * ( ( D11 ) ( -1 ) ) */
/* ( ( -1 ) ( D22 ) ) */
i__1 = k + 1 + k * w_dim1;
d21.r = w[i__1].r;
d21.i = w[i__1].i; // , expr subst
c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
d11.r = q__1.r;
d11.i = q__1.i; // , expr subst
c_div(&q__1, &w[k + k * w_dim1], &d21);
d22.r = q__1.r;
d22.i = q__1.i; // , expr subst
q__3.r = d11.r * d22.r - d11.i * d22.i;
q__3.i = d11.r * d22.i + d11.i * d22.r; // , expr subst
q__2.r = q__3.r - 1.f;
q__2.i = q__3.i - 0.f; // , expr subst
c_div(&q__1, &c_b1, &q__2);
t.r = q__1.r;
t.i = q__1.i; // , expr subst
c_div(&q__1, &t, &d21);
d21.r = q__1.r;
d21.i = q__1.i; // , expr subst
/* Update elements in columns A(k) and A(k+1) as */
/* dot products of rows of ( W(k) W(k+1) ) and columns */
/* of D**(-1) */
i__1 = *n;
for (j = k + 2;
j <= i__1;
++j)
{
i__2 = j + k * a_dim1;
i__3 = j + k * w_dim1;
q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i;
q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; // , expr subst
i__4 = j + (k + 1) * w_dim1;
q__2.r = q__3.r - w[i__4].r;
q__2.i = q__3.i - w[i__4] .i; // , expr subst
q__1.r = d21.r * q__2.r - d21.i * q__2.i;
q__1.i = d21.r * q__2.i + d21.i * q__2.r; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
i__2 = j + (k + 1) * a_dim1;
i__3 = j + (k + 1) * w_dim1;
q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i;
q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; // , expr subst
i__4 = j + k * w_dim1;
q__2.r = q__3.r - w[i__4].r;
q__2.i = q__3.i - w[i__4] .i; // , expr subst
q__1.r = d21.r * q__2.r - d21.i * q__2.i;
q__1.i = d21.r * q__2.i + d21.i * q__2.r; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
/* L80: */
}
}
/* Copy D(k) to A */
i__1 = k + k * a_dim1;
i__2 = k + k * w_dim1;
a[i__1].r = w[i__2].r;
a[i__1].i = w[i__2].i; // , expr subst
i__1 = k + 1 + k * a_dim1;
i__2 = k + 1 + k * w_dim1;
a[i__1].r = w[i__2].r;
a[i__1].i = w[i__2].i; // , expr subst
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * w_dim1;
a[i__1].r = w[i__2].r;
a[i__1].i = w[i__2].i; // , expr subst
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1)
{
ipiv[k] = kp;
}
else
{
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L70;
L90: /* Update the lower triangle of A22 (= A(k:n,k:n)) as */
/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */
/* computing blocks of NB columns at a time */
i__1 = *n;
i__2 = *nb;
for (j = k;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Computing MIN */
i__3 = *nb;
i__4 = *n - j + 1; // , expr subst
jb = min(i__3,i__4);
/* Update the lower triangle of the diagonal block */
i__3 = j + jb - 1;
for (jj = j;
jj <= i__3;
++jj)
{
i__4 = j + jb - jj;
i__5 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1], lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] , &c__1);
/* L100: */
}
/* Update the rectangular subdiagonal block */
if (j + jb <= *n)
{
i__3 = *n - j - jb + 1;
i__4 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1, &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, &a[j + jb + j * a_dim1], lda);
}
/* L110: */
}
/* Put L21 in standard form by partially undoing the interchanges */
/* of rows in columns 1:k-1 looping backwards from k-1 to 1 */
j = k - 1;
L120: /* Undo the interchanges (if any) of rows JJ and JP at each */
/* step J */
/* (Here, J is a diagonal index) */
jj = j;
jp = ipiv[j];
if (jp < 0)
{
jp = -jp;
/* (Here, J is a diagonal index) */
--j;
}
/* (NOTE: Here, J is used to determine row length. Length J */
/* of the rows to swap back doesn't include diagonal element) */
--j;
if (jp != jj && j >= 1)
{
cswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
}
if (j > 1)
{
goto L120;
}
/* Set KB to the number of columns factorized */
*kb = k - 1;
}
return 0;
/* End of CLASYF */
}
/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__,
integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde,
complex *f, integer *ldf, real *scale, real *dif, complex *work,
integer *lwork, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTGSYL solves the generalized Sylvester equation:
A * R - L * B = scale * C (1)
D * R - L * E = scale * F
where R and L are unknown m-by-n matrices, (A, D), (B, E) and
(C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
respectively, with complex entries. A, B, D and E are upper
triangular (i.e., (A,D) and (B,E) in generalized Schur form).
The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
is an output scaling factor chosen to avoid overflow.
In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
is defined as
Z = [ kron(In, A) -kron(B', Im) ] (2)
[ kron(In, D) -kron(E', Im) ],
Here Ix is the identity matrix of size x and X' is the conjugate
transpose of X. Kron(X, Y) is the Kronecker product between the
matrices X and Y.
If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b
is solved for, which is equivalent to solve for R and L in
A' * R + D' * L = scale * C (3)
R * B' + L * E' = scale * -F
This case (TRANS = 'C') is used to compute an one-norm-based estimate
of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
and (B,E), using CLACON.
If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of
Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
reciprocal of the smallest singular value of Z.
This is a level-3 BLAS algorithm.
Arguments
=========
TRANS (input) CHARACTER*1
= 'N': solve the generalized sylvester equation (1).
= 'C': solve the "conjugate transposed" system (3).
IJOB (input) INTEGER
Specifies what kind of functionality to be performed.
=0: solve (1) only.
=1: The functionality of 0 and 3.
=2: The functionality of 0 and 4.
=3: Only an estimate of Dif[(A,D), (B,E)] is computed.
(look ahead strategy is used).
=4: Only an estimate of Dif[(A,D), (B,E)] is computed.
(CGECON on sub-systems is used).
Not referenced if TRANS = 'C'.
M (input) INTEGER
The order of the matrices A and D, and the row dimension of
the matrices C, F, R and L.
N (input) INTEGER
The order of the matrices B and E, and the column dimension
of the matrices C, F, R and L.
A (input) COMPLEX array, dimension (LDA, M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1, M).
B (input) COMPLEX array, dimension (LDB, N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1, N).
C (input/output) COMPLEX array, dimension (LDC, N)
On entry, C contains the right-hand-side of the first matrix
equation in (1) or (3).
On exit, if IJOB = 0, 1 or 2, C has been overwritten by
the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
the solution achieved during the computation of the
Dif-estimate.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1, M).
D (input) COMPLEX array, dimension (LDD, M)
The upper triangular matrix D.
LDD (input) INTEGER
The leading dimension of the array D. LDD >= max(1, M).
E (input) COMPLEX array, dimension (LDE, N)
The upper triangular matrix E.
LDE (input) INTEGER
The leading dimension of the array E. LDE >= max(1, N).
F (input/output) COMPLEX array, dimension (LDF, N)
On entry, F contains the right-hand-side of the second matrix
equation in (1) or (3).
On exit, if IJOB = 0, 1 or 2, F has been overwritten by
the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
the solution achieved during the computation of the
Dif-estimate.
LDF (input) INTEGER
The leading dimension of the array F. LDF >= max(1, M).
DIF (output) REAL
On exit DIF is the reciprocal of a lower bound of the
reciprocal of the Dif-function, i.e. DIF is an upper bound of
Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
SCALE (output) REAL
On exit SCALE is the scaling factor in (1) or (3).
If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
to a slightly perturbed system but the input matrices A, B,
D and E have not been changed. If SCALE = 0, R and L will
hold the solutions to the homogenious system with C = F = 0.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
IF IJOB = 0, WORK is not referenced. Otherwise,
LWORK (input) INTEGER
The dimension of the array WORK. LWORK > = 1.
If IJOB = 1 or 2 and TRANS = 'N', LWORK >= 2*M*N.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace) INTEGER array, dimension (M+N+2)
If IJOB = 0, IWORK is not referenced.
INFO (output) INTEGER
=0: successful exit
<0: If INFO = -i, the i-th argument had an illegal value.
>0: (A, D) and (B, E) have common or very close
eigenvalues.
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
[1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
for Solving the Generalized Sylvester Equation and Estimating the
Separation between Regular Matrix Pairs, Report UMINF - 93.23,
Department of Computing Science, Umea University, S-901 87 Umea,
Sweden, December 1993, Revised April 1994, Also as LAPACK Working
Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
No 1, 1996.
[2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
Appl., 15(4):1045-1060, 1994.
[3] B. Kagstrom and L. Westin, Generalized Schur Methods with
Condition Estimators for Solving the Generalized Sylvester
Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
July 1989, pp 745-751.
=====================================================================
Decode and test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c_n1 = -1;
static integer c__5 = 5;
static integer c__0 = 0;
static integer c__1 = 1;
static complex c_b16 = {0.f,0.f};
static complex c_b53 = {-1.f,0.f};
static complex c_b54 = {1.f,0.f};
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
i__4;
complex q__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real dsum;
static integer i__, j, k, p, q;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemm_(char *, char *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *);
extern logical lsame_(char *, char *);
static integer ifunc, linfo;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer lwmin;
static real scale2;
extern /* Subroutine */ int ctgsy2_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, real *, integer *);
static integer ie, je, mb, nb;
static real dscale;
static integer is, js, pq;
static real scaloc;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer iround;
static logical notran;
static integer isolve;
static logical lquery;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
#define d___subscr(a_1,a_2) (a_2)*d_dim1 + a_1
#define d___ref(a_1,a_2) d__[d___subscr(a_1,a_2)]
#define e_subscr(a_1,a_2) (a_2)*e_dim1 + a_1
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define f_subscr(a_1,a_2) (a_2)*f_dim1 + a_1
#define f_ref(a_1,a_2) f[f_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1 * 1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1 * 1;
f -= f_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
lquery = *lwork == -1;
if ((*ijob == 1 || *ijob == 2) && notran) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * *n;
lwmin = max(i__1,i__2);
} else {
lwmin = 1;
}
if (! notran && ! lsame_(trans, "C")) {
*info = -1;
} else if (*ijob < 0 || *ijob > 4) {
*info = -2;
} else if (*m <= 0) {
*info = -3;
} else if (*n <= 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*ldd < max(1,*m)) {
*info = -12;
} else if (*lde < max(1,*n)) {
*info = -14;
} else if (*ldf < max(1,*m)) {
*info = -16;
} else if (*lwork < lwmin && ! lquery) {
*info = -20;
}
if (*info == 0) {
work[1].r = (real) lwmin, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSYL", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Determine optimal block sizes MB and NB */
mb = ilaenv_(&c__2, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = ilaenv_(&c__5, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
isolve = 1;
ifunc = 0;
if (*ijob >= 3 && notran) {
ifunc = *ijob - 2;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L10: */
}
} else if (*ijob >= 1 && notran) {
isolve = 2;
}
if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
/* Use unblocked Level 2 solver */
i__1 = isolve;
for (iround = 1; iround <= i__1; ++iround) {
*scale = 1.f;
dscale = 0.f;
dsum = 1.f;
pq = *m * *n;
ctgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
&c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
lde, &f[f_offset], ldf, scale, &dsum, &dscale, info);
if (dscale != 0.f) {
if (*ijob == 1 || *ijob == 3) {
*dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
dsum));
} else {
*dif = sqrt((real) pq) / (dscale * sqrt(dsum));
}
}
if (isolve == 2 && iround == 1) {
ifunc = *ijob;
scale2 = *scale;
clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L20: */
}
} else if (isolve == 2 && iround == 2) {
clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
*scale = scale2;
}
/* L30: */
}
return 0;
}
/* Determine block structure of A */
p = 0;
i__ = 1;
L40:
if (i__ > *m) {
goto L50;
}
++p;
iwork[p] = i__;
i__ += mb;
if (i__ >= *m) {
goto L50;
}
goto L40;
L50:
iwork[p + 1] = *m + 1;
if (iwork[p] == iwork[p + 1]) {
--p;
}
/* Determine block structure of B */
q = p + 1;
j = 1;
L60:
if (j > *n) {
goto L70;
}
++q;
iwork[q] = j;
j += nb;
if (j >= *n) {
goto L70;
}
goto L60;
L70:
iwork[q + 1] = *n + 1;
if (iwork[q] == iwork[q + 1]) {
--q;
}
if (notran) {
i__1 = isolve;
for (iround = 1; iround <= i__1; ++iround) {
/* Solve (I, J) - subsystem
A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */
pq = 0;
*scale = 1.f;
dscale = 0.f;
dsum = 1.f;
i__2 = q;
for (j = p + 2; j <= i__2; ++j) {
js = iwork[j];
je = iwork[j + 1] - 1;
nb = je - js + 1;
for (i__ = p; i__ >= 1; --i__) {
is = iwork[i__];
ie = iwork[i__ + 1] - 1;
mb = ie - is + 1;
ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, &
b_ref(js, js), ldb, &c___ref(is, js), ldc, &
d___ref(is, is), ldd, &e_ref(js, js), lde, &f_ref(
is, js), ldf, &scaloc, &dsum, &dscale, &linfo);
if (linfo > 0) {
*info = linfo;
}
pq += mb * nb;
if (scaloc != 1.f) {
i__3 = js - 1;
for (k = 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L80: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(1, k), &c__1);
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(1, k), &c__1);
/* L90: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1);
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1);
/* L100: */
}
i__3 = *n;
for (k = je + 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L110: */
}
*scale *= scaloc;
}
/* Substitute R(I,J) and L(I,J) into remaining equation. */
if (i__ > 1) {
i__3 = is - 1;
cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &a_ref(1,
is), lda, &c___ref(is, js), ldc, &c_b54, &
c___ref(1, js), ldc);
i__3 = is - 1;
cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &d___ref(1,
is), ldd, &c___ref(is, js), ldc, &c_b54, &
f_ref(1, js), ldf);
}
if (j < q) {
i__3 = *n - je;
cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is,
js), ldf, &b_ref(js, je + 1), ldb, &c_b54, &
c___ref(is, je + 1), ldc);
i__3 = *n - je;
cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is,
js), ldf, &e_ref(js, je + 1), lde, &c_b54, &
f_ref(is, je + 1), ldf);
}
/* L120: */
}
/* L130: */
}
if (dscale != 0.f) {
if (*ijob == 1 || *ijob == 3) {
*dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
dsum));
} else {
*dif = sqrt((real) pq) / (dscale * sqrt(dsum));
}
}
if (isolve == 2 && iround == 1) {
ifunc = *ijob;
scale2 = *scale;
clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L140: */
}
} else if (isolve == 2 && iround == 2) {
clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
*scale = scale2;
}
/* L150: */
}
} else {
/* Solve transposed (I, J)-subsystem
A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J)
R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
for I = 1,2,..., P; J = Q, Q-1,..., 1 */
*scale = 1.f;
i__1 = p;
for (i__ = 1; i__ <= i__1; ++i__) {
is = iwork[i__];
ie = iwork[i__ + 1] - 1;
mb = ie - is + 1;
i__2 = p + 2;
for (j = q; j >= i__2; --j) {
js = iwork[j];
je = iwork[j + 1] - 1;
nb = je - js + 1;
ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, &b_ref(
js, js), ldb, &c___ref(is, js), ldc, &d___ref(is, is),
ldd, &e_ref(js, js), lde, &f_ref(is, js), ldf, &
scaloc, &dsum, &dscale, &linfo);
if (linfo > 0) {
*info = linfo;
}
if (scaloc != 1.f) {
i__3 = js - 1;
for (k = 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L160: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(1, k), &c__1);
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(1, k), &c__1);
/* L170: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1);
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1);
/* L180: */
}
i__3 = *n;
for (k = je + 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L190: */
}
*scale *= scaloc;
}
/* Substitute R(I,J) and L(I,J) into remaining equation. */
if (j > p + 2) {
i__3 = js - 1;
cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &c___ref(is, js)
, ldc, &b_ref(1, js), ldb, &c_b54, &f_ref(is, 1),
ldf);
i__3 = js - 1;
cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &f_ref(is, js),
ldf, &e_ref(1, js), lde, &c_b54, &f_ref(is, 1),
ldf);
}
if (i__ < p) {
i__3 = *m - ie;
cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &a_ref(is, ie +
1), lda, &c___ref(is, js), ldc, &c_b54, &c___ref(
ie + 1, js), ldc);
i__3 = *m - ie;
cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &d___ref(is, ie
+ 1), ldd, &f_ref(is, js), ldf, &c_b54, &c___ref(
ie + 1, js), ldc);
}
/* L200: */
}
/* L210: */
}
}
work[1].r = (real) lwmin, work[1].i = 0.f;
return 0;
/* End of CTGSYL */
} /* ctgsyl_ */
/* Subroutine */ int cgetf2_(integer *m, integer *n, complex *a, integer *lda,
integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
integer i__, j, jp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgeru_(integer *, integer *, complex *, complex *,
integer *, complex *, integer *, complex *, integer *);
real sfmin;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGETF2 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 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 = 1 + a_dim1;
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_("CGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = slamch_("S");
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 + icamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
i__2 = jp + j * a_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
cswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if (c_abs(&a[j + j * a_dim1]) >= sfmin) {
i__2 = *m - j;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
cscal_(&i__2, &q__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ + j * a_dim1;
c_div(&q__1, &a[j + i__ + j * a_dim1], &a[j + j *
a_dim1]);
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L20: */
}
}
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__2, &i__3, &q__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 CGETF2 */
} /* cgetf2_ */
/* Subroutine */ int ctrti2_(char *uplo, char *diag, integer *n, complex *a,
integer *lda, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CTRTI2 computes the inverse of a complex upper or lower triangular
matrix.
This is the Level 2 BLAS version of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, 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.
On exit, the (triangular) inverse of the original matrix, in
the same storage format.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
complex q__1;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer j;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
static logical nounit;
static complex ajj;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
i__2 = a_subscr(j, j);
c_div(&q__1, &c_b1, &a_ref(j, j));
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = a_subscr(j, j);
q__1.r = -a[i__2].r, q__1.i = -a[i__2].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = 0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
ctrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a_ref(1, j), &c__1);
i__2 = j - 1;
cscal_(&i__2, &ajj, &a_ref(1, j), &c__1);
/* L10: */
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
i__1 = a_subscr(j, j);
c_div(&q__1, &c_b1, &a_ref(j, j));
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = a_subscr(j, j);
q__1.r = -a[i__1].r, q__1.i = -a[i__1].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = 0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
ctrmv_("Lower", "No transpose", diag, &i__1, &a_ref(j + 1, j
+ 1), lda, &a_ref(j + 1, j), &c__1);
i__1 = *n - j;
cscal_(&i__1, &ajj, &a_ref(j + 1, j), &c__1);
}
/* L20: */
}
}
return 0;
/* End of CTRTI2 */
} /* ctrti2_ */
/* Subroutine */ int claror_(char *side, char *init, integer *m, integer *n,
complex *a, integer *lda, integer *iseed, complex *x, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1, q__2;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer kbeg, jcol;
static real xabs;
static integer irow, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cscal_(integer *, complex *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static complex csign;
static integer ixfrm, itype, nxfrm;
static real xnorm;
extern real scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), xerbla_(char *,
integer *);
static real factor;
static complex xnorms;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAROR pre- or post-multiplies an M by N matrix A by a random
unitary matrix U, overwriting A. A may optionally be
initialized to the identity matrix before multiplying by U.
U is generated using the method of G.W. Stewart
( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
(BLAS-2 version)
Arguments
=========
SIDE - CHARACTER*1
SIDE specifies whether A is multiplied on the left or right
by U.
SIDE = 'L' Multiply A on the left (premultiply) by U
SIDE = 'R' Multiply A on the right (postmultiply) by U*
SIDE = 'C' Multiply A on the left by U and the right by U*
SIDE = 'T' Multiply A on the left by U and the right by U'
Not modified.
INIT - CHARACTER*1
INIT specifies whether or not A should be initialized to
the identity matrix.
INIT = 'I' Initialize A to (a section of) the
identity matrix before applying U.
INIT = 'N' No initialization. Apply U to the
input matrix A.
INIT = 'I' may be used to generate square (i.e., unitary)
or rectangular orthogonal matrices (orthogonality being
in the sense of CDOTC):
For square matrices, M=N, and SIDE many be either 'L' or
'R'; the rows will be orthogonal to each other, as will the
columns.
For rectangular matrices where M < N, SIDE = 'R' will
produce a dense matrix whose rows will be orthogonal and
whose columns will not, while SIDE = 'L' will produce a
matrix whose rows will be orthogonal, and whose first M
columns will be orthogonal, the remaining columns being
zero.
For matrices where M > N, just use the previous
explaination, interchanging 'L' and 'R' and "rows" and
"columns".
Not modified.
M - INTEGER
Number of rows of A. Not modified.
N - INTEGER
Number of columns of A. Not modified.
A - COMPLEX array, dimension ( LDA, N )
Input and output array. Overwritten by U A ( if SIDE = 'L' )
or by A U ( if SIDE = 'R' )
or by U A U* ( if SIDE = 'C')
or by U A U' ( if SIDE = 'T') on exit.
LDA - INTEGER
Leading dimension of A. Must be at least MAX ( 1, M ).
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to CLAROR to continue the same random number
sequence.
Modified.
X - COMPLEX array, dimension ( 3*MAX( M, N ) )
Workspace. Of length:
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
Modified.
INFO - INTEGER
An error flag. It is set to:
0 if no error.
1 if CLARND returned a bad random number (installation
problem)
-1 if SIDE is not L, R, C, or T.
-3 if M is negative.
-4 if N is negative or if SIDE is C or T and N is not equal
to M.
-6 if LDA is less than M.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (lsame_(side, "L")) {
itype = 1;
} else if (lsame_(side, "R")) {
itype = 2;
} else if (lsame_(side, "C")) {
itype = 3;
} else if (lsame_(side, "T")) {
itype = 4;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (lsame_(init, "I")) {
claset_("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
}
/* If no rotation possible, still multiply by
a random complex number from the circle |x| = 1
2) Compute Rotation by computing Householder
Transformations H(2), H(3), ..., H(n). Note that the
order in which they are computed is irrelevant. */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
x[i__2].r = 0.f, x[i__2].i = 0.f;
/* L40: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
i__3 = j;
clarnd_(&q__1, &c__3, &iseed[1]);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L50: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = scnrm2_(&ixfrm, &x[kbeg], &c__1);
xabs = c_abs(&x[kbeg]);
if (xabs != 0.f) {
i__2 = kbeg;
q__1.r = x[i__2].r / xabs, q__1.i = x[i__2].i / xabs;
csign.r = q__1.r, csign.i = q__1.i;
} else {
csign.r = 1.f, csign.i = 0.f;
}
q__1.r = xnorm * csign.r, q__1.i = xnorm * csign.i;
xnorms.r = q__1.r, xnorms.i = q__1.i;
i__2 = nxfrm + kbeg;
q__1.r = -(doublereal)csign.r, q__1.i = -(doublereal)csign.i;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
factor = xnorm * (xnorm + xabs);
if (dabs(factor) < 1e-20f) {
*info = 1;
i__2 = -(*info);
xerbla_("CLAROR", &i__2);
return 0;
} else {
factor = 1.f / factor;
}
i__2 = kbeg;
i__3 = kbeg;
q__1.r = x[i__3].r + xnorms.r, q__1.i = x[i__3].i + xnorms.i;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3 || itype == 4) {
/* Apply H(k) on the left of A */
cgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
q__2.r = factor, q__2.i = 0.f;
q__1.r = -(doublereal)q__2.r, q__1.i = -(doublereal)q__2.i;
cgerc_(&ixfrm, n, &q__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype >= 2 && itype <= 4) {
/* Apply H(k)* (or H(k)') on the right of A */
if (itype == 4) {
clacgv_(&ixfrm, &x[kbeg], &c__1);
}
cgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
, &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
q__2.r = factor, q__2.i = 0.f;
q__1.r = -(doublereal)q__2.r, q__1.i = -(doublereal)q__2.i;
cgerc_(m, &ixfrm, &q__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L60: */
}
clarnd_(&q__1, &c__3, &iseed[1]);
x[1].r = q__1.r, x[1].i = q__1.i;
xabs = c_abs(&x[1]);
if (xabs != 0.f) {
q__1.r = x[1].r / xabs, q__1.i = x[1].i / xabs;
csign.r = q__1.r, csign.i = q__1.i;
} else {
csign.r = 1.f, csign.i = 0.f;
}
i__1 = nxfrm << 1;
x[i__1].r = csign.r, x[i__1].i = csign.i;
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3 || itype == 4) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
r_cnjg(&q__1, &x[nxfrm + irow]);
cscal_(n, &q__1, &a[irow + a_dim1], lda);
/* L70: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
cscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L80: */
}
}
if (itype == 4) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
r_cnjg(&q__1, &x[nxfrm + jcol]);
cscal_(m, &q__1, &a[jcol * a_dim1 + 1], &c__1);
/* L90: */
}
}
return 0;
/* End of CLAROR */
} /* claror_ */
/* Subroutine */ int cung2l_(integer *m, integer *n, integer *k, complex *a,
integer *lda, complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
integer i__, j, l, ii;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), clarf_(char *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, complex *),
xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CUNG2L generates an m by n complex matrix Q with orthonormal columns, */
/* which is defined as the last n columns of a product of k elementary */
/* reflectors of order m */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by CGEQLF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. M >= N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. N >= K >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the (n-k+i)-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* returned by CGEQLF in the last k columns of its array */
/* argument A. */
/* On exit, the m-by-n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= max(1,M). */
/* TAU (input) COMPLEX array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by CGEQLF. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *n > *m) {
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNG2L", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = 1; l <= i__2; ++l) {
i__3 = l + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
i__2 = *m - *n + j + j * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* L20: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *n - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
i__2 = *m - *n + ii + ii * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
i__2 = *m - *n + ii;
i__3 = ii - 1;
clarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
a[a_offset], lda, &work[1]);
i__2 = *m - *n + ii - 1;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cscal_(&i__2, &q__1, &a[ii * a_dim1 + 1], &c__1);
i__2 = *m - *n + ii + ii * a_dim1;
i__3 = i__;
q__1.r = 1.f - tau[i__3].r, q__1.i = 0.f - tau[i__3].i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m;
for (l = *m - *n + ii + 1; l <= i__2; ++l) {
i__3 = l + ii * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of CUNG2L */
} /* cung2l_ */
/* Subroutine */ int clahrd_(integer *n, integer *k, integer *nb, complex *a,
integer *lda, complex *tau, complex *t, integer *ldt, complex *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;
complex q__1;
/* Local variables */
integer i__;
complex ei;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemv_(char *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), ctrmv_(char *, char *, char *,
integer *, complex *, integer *, complex *, integer *), clarfg_(integer *, complex *, complex *, integer
*, complex *), clacgv_(integer *, complex *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAHRD 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 OBSOLETE auxiliary routine. */
/* This routine will be 'deprecated' in a future release. */
/* Please use the new routine CLAHR2 instead. */
/* 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 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 array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) COMPLEX array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) COMPLEX 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 = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(1:n,i) */
/* Compute i-th column of A - Y * V' */
i__2 = i__ - 1;
clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
i__2 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &a[*k
+ i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], &
c__1);
i__2 = i__ - 1;
clacgv_(&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;
ccopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
ctrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 +
a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
t[*nb * t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
ctrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
ctrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
caxpy_(&i__2, &q__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;
clarfg_(&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.f, a[i__2].i = 0.f;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i__ + 1;
cgemv_("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);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &t[i__ *
t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1);
cscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
/* Compute T(1:i,i) */
i__2 = i__ - 1;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cscal_(&i__2, &q__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
a[i__1].r = ei.r, a[i__1].i = ei.i;
return 0;
/* End of CLAHRD */
} /* clahrd_ */
/* Subroutine */ int clarge_(integer *n, complex *a, integer *lda, integer *
iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer i__;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
, integer *, integer *, complex *, complex *, integer *, complex *
, integer *, complex *, complex *, integer *);
extern doublereal scnrm2_(integer *, complex *, integer *);
static complex wa, wb;
static real wn;
extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
integer *, integer *, integer *, complex *);
static complex tau;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
/* -- LAPACK auxiliary test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLARGE pre- and post-multiplies a complex general n by n matrix A
with a random unitary matrix: A = U*D*U'.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the original n by n matrix A.
On exit, A is overwritten by U*A*U' for some random
unitary matrix U.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1,*n)) {
*info = -3;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CLARGE", &i__1);
return 0;
}
/* pre- and post-multiply A by random unitary matrix */
for (i__ = *n; i__ >= 1; --i__) {
/* generate random reflection */
i__1 = *n - i__ + 1;
clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
r__1 = wn / c_abs(&work[1]);
q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i__;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
r__1 = q__1.r;
tau.r = r__1, tau.i = 0.f;
}
/* multiply A(i:n,1:n) by random reflection from the left */
i__1 = *n - i__ + 1;
cgemv_("Conjugate transpose", &i__1, n, &c_b2, &a_ref(i__, 1), lda, &
work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *n - i__ + 1;
q__1.r = -tau.r, q__1.i = -tau.i;
cgerc_(&i__1, n, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &a_ref(
i__, 1), lda);
/* multiply A(1:n,i:n) by random reflection from the right */
i__1 = *n - i__ + 1;
cgemv_("No transpose", n, &i__1, &c_b2, &a_ref(1, i__), lda, &work[1],
&c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *n - i__ + 1;
q__1.r = -tau.r, q__1.i = -tau.i;
cgerc_(n, &i__1, &q__1, &work[*n + 1], &c__1, &work[1], &c__1, &a_ref(
1, i__), lda);
/* L10: */
}
return 0;
/* End of CLARGE */
} /* clarge_ */
/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
integer j, k;
complex ak, bk;
integer kp;
complex akm1, bkm1, akm1k;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
complex denom;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYTRS solves a system of linear equations A*X = B with a complex */
/* symmetric matrix A using the factorization A = U*D*U**T or */
/* A = L*D*L**T computed by CSYTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* 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 array, dimension (LDA,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by CSYTRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by CSYTRF. */
/* B (input/output) COMPLEX 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 .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*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_("CSYTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'. */
/* First solve U*D*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
--k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in columns K-1 and K of A. */
i__1 = k - 2;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
i__1 = k - 2;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k
- 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = k - 1 + k * a_dim1;
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a[k + k * a_dim1], &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b[k + j * b_dim1], &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = k - 1 + j * b_dim1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + j * b_dim1;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(U'(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[k *
a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
;
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
++k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[k *
a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
;
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[(k
+ 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'. */
/* First solve L*D*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 1 + k * a_dim1], &c__1, &b[
k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
++k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + k * a_dim1], &c__1, &b[
k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + (k + 1) * a_dim1], &
c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1],
ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = k + 1 + k * a_dim1;
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a[k + k * a_dim1], &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b[k + j * b_dim1], &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = k + j * b_dim1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + 1 + j * b_dim1;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L70: */
}
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(L'(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b1, &b[k
- 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of CSYTRS */
} /* csytrs_ */
/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
integer *kl, integer *ku, complex *ab, integer *ldab, real *d, real *
e, complex *q, integer *ldq, complex *pt, integer *ldpt, complex *c,
integer *ldc, complex *work, real *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGBBRD reduces a complex general m-by-n band matrix A to real upper
bidiagonal form B by a unitary transformation: Q' * A * P = B.
The routine computes B, and optionally forms Q or P', or computes
Q'*C for a given matrix C.
Arguments
=========
VECT (input) CHARACTER*1
Specifies whether or not the matrices Q and P' are to be
formed.
= 'N': do not form Q or P';
= 'Q': form Q only;
= 'P': form P' only;
= 'B': form both.
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
KL (input) INTEGER
The number of subdiagonals of the matrix A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals of the matrix A. KU >= 0.
AB (input/output) COMPLEX array, dimension (LDAB,N)
On entry, the m-by-n band matrix A, stored in rows 1 to
KL+KU+1. The j-th column of A is stored in the j-th column of
the array AB as follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
On exit, A is overwritten by values generated during the
reduction.
LDAB (input) INTEGER
The leading dimension of the array A. LDAB >= KL+KU+1.
D (output) REAL array, dimension (min(M,N))
The diagonal elements of the bidiagonal matrix B.
E (output) REAL array, dimension (min(M,N)-1)
The superdiagonal elements of the bidiagonal matrix B.
Q (output) COMPLEX array, dimension (LDQ,M)
If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
If VECT = 'N' or 'P', the array Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
PT (output) COMPLEX array, dimension (LDPT,N)
If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
If VECT = 'N' or 'Q', the array PT is not referenced.
LDPT (input) INTEGER
The leading dimension of the array PT.
LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
C (input/output) COMPLEX array, dimension (LDC,NCC)
On entry, an m-by-ncc matrix C.
On exit, C is overwritten by Q'*C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
WORK (workspace) COMPLEX array, dimension (max(M,N))
RWORK (workspace) REAL array, dimension (max(M,N))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
static integer inca;
static real abst;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
static integer i, j, l;
static complex t;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
static logical wantb, wantc;
static integer minmn;
static logical wantq;
static integer j1, j2, kb;
static complex ra;
static real rc;
static integer kk;
static complex rb;
static integer ml, nr, mu;
static complex rs;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*), clargv_(integer *, complex *, integer *, complex *,
integer *, real *, integer *), clartv_(integer *, complex *,
integer *, complex *, integer *, real *, complex *, integer *);
static integer kb1, ml0;
static logical wantpt;
static integer mu0, klm, kun, nrt, klu1;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define PT(I,J) pt[(I)-1 + ((J)-1)* ( *ldpt)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
claset_("Full", m, m, &c_b1, &c_b2, &Q(1,1), ldq);
}
if (wantpt) {
claset_("Full", n, n, &c_b1, &c_b2, &PT(1,1), ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = min(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
first to lower bidiagonal form and then transform to upper
bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied
in
vector operations of length NR over the index set J1:J2:KLU1
.
The complex sines of the plane rotations are stored in WORK,
and the real cosines in RWORK.
Computing MIN */
i__1 = *m - 1;
klm = min(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = min(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i = 1; i <= minmn; ++i) {
/* Reduce i-th column and i-th row of matrix to bidiagon
al form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= kb; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero
elements
which have been created below the band */
if (nr > 0) {
clargv_(&nr, &AB(klu1,j1-klm-1), &inca,
&WORK(j1), &kb1, &RWORK(j1), &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= kb; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &AB(klu1-l,j1-klm+l-1), &inca, &AB(klu1-l+1,j1-klm+l-1), &inca, &RWORK(j1), &WORK(
j1), &kb1);
}
/* L10: */
}
if (ml > ml0) {
if (ml <= *m - i + 1) {
/* generate plane rotation to annih
ilate a(i+ml-1,i)
within the band, and apply rotat
ion from the left */
clartg_(&AB(*ku+ml-1,i), &AB(*ku+ml,i), &RWORK(i + ml - 1), &WORK(i +
ml - 1), &ra);
i__3 = *ku + ml - 1 + i * ab_dim1;
AB(*ku+ml-1,i).r = ra.r, AB(*ku+ml-1,i).i = ra.i;
if (i < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i;
i__3 = min(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
crot_(&i__3, &AB(*ku+ml-2,i+1)
, &i__6, &AB(*ku+ml-1,i+1), &i__7, &RWORK(i + ml - 1), &
WORK(i + ml - 1));
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations i
n Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
r_cnjg(&q__1, &WORK(j));
crot_(m, &Q(1,j-1), &c__1, &Q(1,j), &c__1, &RWORK(j), &q__1);
/* L20: */
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
crot_(ncc, &C(j-1,1), ldc, &C(j,1),
ldc, &RWORK(j), &WORK(j));
/* L30: */
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of
the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {
/* create nonzero element a(j-1,j+ku) abov
e the band
and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = WORK(j).r * AB(1,j+kun).r - WORK(j).i * AB(1,j+kun).i, q__1.i = WORK(j).r * AB(1,j+kun).i +
WORK(j).i * AB(1,j+kun).r;
WORK(j+kun).r = q__1.r, WORK(j+kun).i = q__1.i;
i__5 = (j + kun) * ab_dim1 + 1;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = RWORK(j) * AB(1,j+kun).r, q__1.i = RWORK(j) *
AB(1,j+kun).i;
AB(1,j+kun).r = q__1.r, AB(1,j+kun).i = q__1.i;
/* L40: */
}
/* generate plane rotations to annihilate nonzero
elements
which have been generated above the band */
if (nr > 0) {
clargv_(&nr, &AB(1,j1+kun-1), &inca, &
WORK(j1 + kun), &kb1, &RWORK(j1 + kun), &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= kb; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &AB(l+1,j1+kun-1), &
inca, &AB(l,j1+kun), &inca, &
RWORK(j1 + kun), &WORK(j1 + kun), &kb1);
}
/* L50: */
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i + 1) {
/* generate plane rotation to annih
ilate a(i,i+mu-1)
within the band, and apply rotat
ion from the right */
clartg_(&AB(*ku-mu+3,i+mu-2), &
AB(*ku-mu+2,i+mu-1), &
RWORK(i + mu - 1), &WORK(i + mu - 1), &ra);
i__4 = *ku - mu + 3 + (i + mu - 2) * ab_dim1;
AB(*ku-mu+3,i+mu-2).r = ra.r, AB(*ku-mu+3,i+mu-2).i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i;
i__4 = min(i__3,i__5);
crot_(&i__4, &AB(*ku-mu+4,i+mu-2), &c__1, &AB(*ku-mu+3,i+mu-1), &c__1, &RWORK(i + mu - 1), &
WORK(i + mu - 1));
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations i
n P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
r_cnjg(&q__1, &WORK(j + kun));
crot_(n, &PT(j+kun-1,1), ldpt, &PT(j+kun,1), ldpt, &RWORK(j + kun), &q__1);
/* L60: */
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of
the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {
/* create nonzero element a(j+kl+ku,j+ku-1
) below the
band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = WORK(j+kun).r * AB(klu1,j+kun).r - WORK(j+kun).i * AB(klu1,j+kun).i, q__1.i = WORK(j+kun).r * AB(klu1,j+kun).i +
WORK(j+kun).i * AB(klu1,j+kun).r;
WORK(j+kb).r = q__1.r, WORK(j+kb).i = q__1.i;
i__5 = klu1 + (j + kun) * ab_dim1;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = RWORK(j+kun) * AB(klu1,j+kun).r, q__1.i = RWORK(j+kun) *
AB(klu1,j+kun).i;
AB(klu1,j+kun).r = q__1.r, AB(klu1,j+kun).i = q__1.i;
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form
Transform lower bidiagonal form to upper bidiagonal by apply
ing
plane rotations from the left, overwriting superdiagonal
elements on subdiagonal elements
Computing MIN */
i__2 = *m - 1;
i__1 = min(i__2,*n);
for (i = 1; i <= min(*m-1,*n); ++i) {
clartg_(&AB(1,i), &AB(2,i), &rc, &rs, &ra)
;
i__2 = i * ab_dim1 + 1;
AB(1,i).r = ra.r, AB(1,i).i = ra.i;
if (i < *n) {
i__2 = i * ab_dim1 + 2;
i__4 = (i + 1) * ab_dim1 + 1;
q__1.r = rs.r * AB(1,i+1).r - rs.i * AB(1,i+1).i, q__1.i = rs.r
* AB(1,i+1).i + rs.i * AB(1,i+1).r;
AB(2,i).r = q__1.r, AB(2,i).i = q__1.i;
i__2 = (i + 1) * ab_dim1 + 1;
i__4 = (i + 1) * ab_dim1 + 1;
q__1.r = rc * AB(1,i+1).r, q__1.i = rc * AB(1,i+1).i;
AB(1,i+1).r = q__1.r, AB(1,i+1).i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &rs);
crot_(m, &Q(1,i), &c__1, &Q(1,i+1),
&c__1, &rc, &q__1);
}
if (wantc) {
crot_(ncc, &C(i,1), ldc, &C(i+1,1), ldc, &rc,
&rs);
}
/* L100: */
}
} else {
/* A has been reduced to complex upper bidiagonal form or is
diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from
the
right */
i__1 = *ku + (*m + 1) * ab_dim1;
rb.r = AB(*ku,*m+1).r, rb.i = AB(*ku,*m+1).i;
for (i = *m; i >= 1; --i) {
clartg_(&AB(*ku+1,i), &rb, &rc, &rs, &ra);
i__1 = *ku + 1 + i * ab_dim1;
AB(*ku+1,i).r = ra.r, AB(*ku+1,i).i = ra.i;
if (i > 1) {
r_cnjg(&q__3, &rs);
q__2.r = -(doublereal)q__3.r, q__2.i = -(doublereal)
q__3.i;
i__1 = *ku + i * ab_dim1;
q__1.r = q__2.r * AB(*ku,i).r - q__2.i * AB(*ku,i).i,
q__1.i = q__2.r * AB(*ku,i).i + q__2.i * AB(*ku,i)
.r;
rb.r = q__1.r, rb.i = q__1.i;
i__1 = *ku + i * ab_dim1;
i__2 = *ku + i * ab_dim1;
q__1.r = rc * AB(*ku,i).r, q__1.i = rc * AB(*ku,i).i;
AB(*ku,i).r = q__1.r, AB(*ku,i).i = q__1.i;
}
if (wantpt) {
r_cnjg(&q__1, &rs);
crot_(n, &PT(i,1), ldpt, &PT(*m+1,1),
ldpt, &rc, &q__1);
}
/* L110: */
}
}
}
/* Make diagonal and superdiagonal elements real, storing them in D
and E */
i__1 = *ku + 1 + ab_dim1;
t.r = AB(*ku+1,1).r, t.i = AB(*ku+1,1).i;
i__1 = minmn;
for (i = 1; i <= minmn; ++i) {
abst = c_abs(&t);
D(i) = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantq) {
cscal_(m, &t, &Q(1,i), &c__1);
}
if (wantc) {
r_cnjg(&q__1, &t);
cscal_(ncc, &q__1, &C(i,1), ldc);
}
if (i < minmn) {
if (*ku == 0 && *kl == 0) {
E(i) = 0.f;
i__2 = (i + 1) * ab_dim1 + 1;
t.r = AB(1,i+1).r, t.i = AB(1,i+1).i;
} else {
if (*ku == 0) {
i__2 = i * ab_dim1 + 2;
r_cnjg(&q__2, &t);
q__1.r = AB(2,i).r * q__2.r - AB(2,i).i * q__2.i,
q__1.i = AB(2,i).r * q__2.i + AB(2,i).i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
} else {
i__2 = *ku + (i + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = AB(*ku,i+1).r * q__2.r - AB(*ku,i+1).i * q__2.i,
q__1.i = AB(*ku,i+1).r * q__2.i + AB(*ku,i+1).i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
abst = c_abs(&t);
E(i) = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantpt) {
cscal_(n, &t, &PT(i+1,1), ldpt);
}
i__2 = *ku + 1 + (i + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = AB(*ku+1,i+1).r * q__2.r - AB(*ku+1,i+1).i * q__2.i, q__1.i =
AB(*ku+1,i+1).r * q__2.i + AB(*ku+1,i+1).i * q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
}
/* L120: */
}
return 0;
/* End of CGBBRD */
} /* cgbbrd_ */
/* Subroutine */ int ctgsy2_(char *trans, integer *ijob, integer *m, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__,
integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde,
complex *f, integer *ldf, real *scale, real *rdsum, real *rdscal,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
i__4;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
integer i__, j, k;
complex z__[4] /* was [2][2] */, rhs[2];
integer ierr, ipiv[2], jpiv[2];
complex alpha;
real scaloc;
logical notran;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CTGSY2 solves the generalized Sylvester equation */
/* A * R - L * B = scale * C (1) */
/* D * R - L * E = scale * F */
/* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices, */
/* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */
/* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular */
/* (i.e., (A,D) and (B,E) in generalized Schur form). */
/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */
/* scaling factor chosen to avoid overflow. */
/* In matrix notation solving equation (1) corresponds to solve */
/* Zx = scale * b, where Z is defined as */
/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
/* [ kron(In, D) -kron(E', Im) ], */
/* Ik is the identity matrix of size k and X' is the transpose of X. */
/* kron(X, Y) is the Kronecker product between the matrices X and Y. */
/* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b */
/* is solved for, which is equivalent to solve for R and L in */
/* A' * R + D' * L = scale * C (3) */
/* R * B' + L * E' = scale * -F */
/* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */
/* = sigma_min(Z) using reverse communicaton with CLACON. */
/* CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL */
/* of an upper bound on the separation between to matrix pairs. Then */
/* the input (A, D), (B, E) are sub-pencils of two matrix pairs in */
/* CTGSYL. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N', solve the generalized Sylvester equation (1). */
/* = 'T': solve the 'transposed' system (3). */
/* IJOB (input) INTEGER */
/* Specifies what kind of functionality to be performed. */
/* =0: solve (1) only. */
/* =1: A contribution from this subsystem to a Frobenius */
/* norm-based estimate of the separation between two matrix */
/* pairs is computed. (look ahead strategy is used). */
/* =2: A contribution from this subsystem to a Frobenius */
/* norm-based estimate of the separation between two matrix */
/* pairs is computed. (SGECON on sub-systems is used.) */
/* Not referenced if TRANS = 'T'. */
/* M (input) INTEGER */
/* On entry, M specifies the order of A and D, and the row */
/* dimension of C, F, R and L. */
/* N (input) INTEGER */
/* On entry, N specifies the order of B and E, and the column */
/* dimension of C, F, R and L. */
/* A (input) COMPLEX array, dimension (LDA, M) */
/* On entry, A contains an upper triangular matrix. */
/* LDA (input) INTEGER */
/* The leading dimension of the matrix A. LDA >= max(1, M). */
/* B (input) COMPLEX array, dimension (LDB, N) */
/* On entry, B contains an upper triangular matrix. */
/* LDB (input) INTEGER */
/* The leading dimension of the matrix B. LDB >= max(1, N). */
/* C (input/output) COMPLEX array, dimension (LDC, N) */
/* On entry, C contains the right-hand-side of the first matrix */
/* equation in (1). */
/* On exit, if IJOB = 0, C has been overwritten by the solution */
/* R. */
/* LDC (input) INTEGER */
/* The leading dimension of the matrix C. LDC >= max(1, M). */
/* D (input) COMPLEX array, dimension (LDD, M) */
/* On entry, D contains an upper triangular matrix. */
/* LDD (input) INTEGER */
/* The leading dimension of the matrix D. LDD >= max(1, M). */
/* E (input) COMPLEX array, dimension (LDE, N) */
/* On entry, E contains an upper triangular matrix. */
/* LDE (input) INTEGER */
/* The leading dimension of the matrix E. LDE >= max(1, N). */
/* F (input/output) COMPLEX array, dimension (LDF, N) */
/* On entry, F contains the right-hand-side of the second matrix */
/* equation in (1). */
/* On exit, if IJOB = 0, F has been overwritten by the solution */
/* L. */
/* LDF (input) INTEGER */
/* The leading dimension of the matrix F. LDF >= max(1, M). */
/* SCALE (output) REAL */
/* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */
/* R and L (C and F on entry) will hold the solutions to a */
/* slightly perturbed system but the input matrices A, B, D and */
/* E have not been changed. If SCALE = 0, R and L will hold the */
/* solutions to the homogeneous system with C = F = 0. */
/* Normally, SCALE = 1. */
/* RDSUM (input/output) REAL */
/* On entry, the sum of squares of computed contributions to */
/* the Dif-estimate under computation by CTGSYL, where the */
/* scaling factor RDSCAL (see below) has been factored out. */
/* On exit, the corresponding sum of squares updated with the */
/* contributions from the current sub-system. */
/* If TRANS = 'T' RDSUM is not touched. */
/* NOTE: RDSUM only makes sense when CTGSY2 is called by */
/* CTGSYL. */
/* RDSCAL (input/output) REAL */
/* On entry, scaling factor used to prevent overflow in RDSUM. */
/* On exit, RDSCAL is updated w.r.t. the current contributions */
/* in RDSUM. */
/* If TRANS = 'T', RDSCAL is not touched. */
/* NOTE: RDSCAL only makes sense when CTGSY2 is called by */
/* CTGSYL. */
/* INFO (output) INTEGER */
/* On exit, if INFO is set to */
/* =0: Successful exit */
/* <0: If INFO = -i, input argument number i is illegal. */
/* >0: The matrix pairs (A, D) and (B, E) have common or very */
/* close eigenvalues. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* ===================================================================== */
/* Decode and test input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
*info = 0;
ierr = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "C")) {
*info = -1;
} else if (notran) {
if (*ijob < 0 || *ijob > 2) {
*info = -2;
}
}
if (*info == 0) {
if (*m <= 0) {
*info = -3;
} else if (*n <= 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*ldd < max(1,*m)) {
*info = -12;
} else if (*lde < max(1,*n)) {
*info = -14;
} else if (*ldf < max(1,*m)) {
*info = -16;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSY2", &i__1);
return 0;
}
if (notran) {
/* Solve (I, J) - system */
/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
*scale = 1.f;
scaloc = 1.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
for (i__ = *m; i__ >= 1; --i__) {
/* Build 2 by 2 system */
i__2 = i__ + i__ * a_dim1;
z__[0].r = a[i__2].r, z__[0].i = a[i__2].i;
i__2 = i__ + i__ * d_dim1;
z__[1].r = d__[i__2].r, z__[1].i = d__[i__2].i;
i__2 = j + j * b_dim1;
q__1.r = -b[i__2].r, q__1.i = -b[i__2].i;
z__[2].r = q__1.r, z__[2].i = q__1.i;
i__2 = j + j * e_dim1;
q__1.r = -e[i__2].r, q__1.i = -e[i__2].i;
z__[3].r = q__1.r, z__[3].i = q__1.i;
/* Set up right hand side(s) */
i__2 = i__ + j * c_dim1;
rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i;
i__2 = i__ + j * f_dim1;
rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i;
/* Solve Z * x = RHS */
cgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr);
if (ierr > 0) {
*info = ierr;
}
if (*ijob == 0) {
cgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc);
if (scaloc != 1.f) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1);
}
*scale *= scaloc;
}
} else {
clatdf_(ijob, &c__2, z__, &c__2, rhs, rdsum, rdscal, ipiv,
jpiv);
}
/* Unpack solution vector(s) */
i__2 = i__ + j * c_dim1;
c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i;
i__2 = i__ + j * f_dim1;
f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i;
/* Substitute R(I, J) and L(I, J) into remaining equation. */
if (i__ > 1) {
q__1.r = -rhs[0].r, q__1.i = -rhs[0].i;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = i__ - 1;
caxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &c__[j
* c_dim1 + 1], &c__1);
i__2 = i__ - 1;
caxpy_(&i__2, &alpha, &d__[i__ * d_dim1 + 1], &c__1, &f[j
* f_dim1 + 1], &c__1);
}
if (j < *n) {
i__2 = *n - j;
caxpy_(&i__2, &rhs[1], &b[j + (j + 1) * b_dim1], ldb, &
c__[i__ + (j + 1) * c_dim1], ldc);
i__2 = *n - j;
caxpy_(&i__2, &rhs[1], &e[j + (j + 1) * e_dim1], lde, &f[
i__ + (j + 1) * f_dim1], ldf);
}
}
}
} else {
/* Solve transposed (I, J) - system: */
/* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */
/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
*scale = 1.f;
scaloc = 1.f;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = *n; j >= 1; --j) {
/* Build 2 by 2 system Z' */
r_cnjg(&q__1, &a[i__ + i__ * a_dim1]);
z__[0].r = q__1.r, z__[0].i = q__1.i;
r_cnjg(&q__2, &b[j + j * b_dim1]);
q__1.r = -q__2.r, q__1.i = -q__2.i;
z__[1].r = q__1.r, z__[1].i = q__1.i;
r_cnjg(&q__1, &d__[i__ + i__ * d_dim1]);
z__[2].r = q__1.r, z__[2].i = q__1.i;
r_cnjg(&q__2, &e[j + j * e_dim1]);
q__1.r = -q__2.r, q__1.i = -q__2.i;
z__[3].r = q__1.r, z__[3].i = q__1.i;
/* Set up right hand side(s) */
i__2 = i__ + j * c_dim1;
rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i;
i__2 = i__ + j * f_dim1;
rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i;
/* Solve Z' * x = RHS */
cgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr);
if (ierr > 0) {
*info = ierr;
}
cgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc);
if (scaloc != 1.f) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1);
}
*scale *= scaloc;
}
/* Unpack solution vector(s) */
i__2 = i__ + j * c_dim1;
c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i;
i__2 = i__ + j * f_dim1;
f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i;
/* Substitute R(I, J) and L(I, J) into remaining equation. */
i__2 = j - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = i__ + k * f_dim1;
i__4 = i__ + k * f_dim1;
r_cnjg(&q__4, &b[k + j * b_dim1]);
q__3.r = rhs[0].r * q__4.r - rhs[0].i * q__4.i, q__3.i =
rhs[0].r * q__4.i + rhs[0].i * q__4.r;
q__2.r = f[i__4].r + q__3.r, q__2.i = f[i__4].i + q__3.i;
r_cnjg(&q__6, &e[k + j * e_dim1]);
q__5.r = rhs[1].r * q__6.r - rhs[1].i * q__6.i, q__5.i =
rhs[1].r * q__6.i + rhs[1].i * q__6.r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
f[i__3].r = q__1.r, f[i__3].i = q__1.i;
}
i__2 = *m;
for (k = i__ + 1; k <= i__2; ++k) {
i__3 = k + j * c_dim1;
i__4 = k + j * c_dim1;
r_cnjg(&q__4, &a[i__ + k * a_dim1]);
q__3.r = q__4.r * rhs[0].r - q__4.i * rhs[0].i, q__3.i =
q__4.r * rhs[0].i + q__4.i * rhs[0].r;
q__2.r = c__[i__4].r - q__3.r, q__2.i = c__[i__4].i -
q__3.i;
r_cnjg(&q__6, &d__[i__ + k * d_dim1]);
q__5.r = q__6.r * rhs[1].r - q__6.i * rhs[1].i, q__5.i =
q__6.r * rhs[1].i + q__6.i * rhs[1].r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
}
}
}
}
return 0;
/* End of CTGSY2 */
} /* ctgsy2_ */
/* Subroutine */ int cpst01_(char *uplo, integer *n, complex *a, integer *lda,
complex *afac, integer *ldafac, complex *perm, integer *ldperm,
integer *piv, real *rwork, real *resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1;
/* Local variables */
integer i__, j, k;
complex tc;
real tr, eps;
real anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPST01 reconstructs an Hermitian positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/* and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) COMPLEX array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L100: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0.f, afac[i__3].i = 0.f;
/* L110: */
}
/* L120: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = q__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
i__1 = k - 1;
ctrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L130: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0.f, afac[i__3].i = 0.f;
/* L140: */
}
/* L150: */
}
}
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
cher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
i__1 = k + k * afac_dim1;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
cscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L160: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
}
}
/* L170: */
}
/* L180: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
}
}
/* L190: */
}
/* L200: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
/* L210: */
}
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
perm[i__2].r = q__1.r, perm[i__2].i = q__1.i;
/* L220: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
perm[i__2].r = q__1.r, perm[i__2].i = q__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
/* L230: */
}
/* L240: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = clanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPST01 */
} /* cpst01_ */
/* Subroutine */ int ctrti2_(char *uplo, char *diag, integer *n, complex *a,
integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
complex q__1;
/* Local variables */
integer j;
complex ajj;
logical upper;
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CTRTI2 computes the inverse of a complex upper or lower triangular */
/* matrix. */
/* This is the Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, 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. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same storage format. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
i__2 = j + j * a_dim1;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j + j * a_dim1;
q__1.r = -a[i__2].r, q__1.i = -a[i__2].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = -0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
ctrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
cscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
i__1 = j + j * a_dim1;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = j + j * a_dim1;
q__1.r = -a[i__1].r, q__1.i = -a[i__1].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = -0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
ctrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
i__1 = *n - j;
cscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
}
}
}
return 0;
/* End of CTRTI2 */
} /* ctrti2_ */
/* Subroutine */ int clahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
double c_abs(complex *);
void c_sqrt(complex *, complex *), pow_ci(complex *, complex *, integer *)
;
/* Local variables */
integer i__, j, k, l, m;
real s;
complex t, u, v[2], x, y;
integer i1, i2;
complex t1;
real t2;
complex v2;
real aa, ab, ba, bb, h10;
complex h11;
real h21;
complex h22, sc;
integer nh, nz;
real sx;
integer jhi;
complex h11s;
integer jlo, its;
real ulp;
complex sum;
real tst;
complex temp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
real rtemp;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
real safmin, safmax, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAHQR is an auxiliary routine called by CHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by CHSEQR, 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). */
/* CLAHQR 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 array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO is zero and if WANTT is .TRUE., then H */
/* is upper triangular in rows and columns ILO:IHI. If INFO */
/* is zero and if WANTT is .FALSE., then the contents of H */
/* are unspecified on exit. The output state of H in case */
/* INF is positive is below under the description of INFO. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* W (output) COMPLEX 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 array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by CHSEQR, 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 */
/* .GT. 0: if INFO = i, CLAHQR failed to compute all the */
/* eigenvalues ILO to IHI in a total of 30 iterations */
/* per eigenvalue; elements i+1:ihi of W contain */
/* those eigenvalues which have been successfully */
/* computed. */
/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the */
/* eigenvalues of the upper Hessenberg matrix */
/* rows and columns ILO thorugh INFO of the final, */
/* output value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthognal matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) */
/* (regardless of the value of WANTT.) */
/* Further Details */
/* =============== */
/* 02-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* 12-04 Further modifications by */
/* Ralph Byers, University of Kansas, USA */
/* This is a modified version of CLAHQR from LAPACK version 3.0. */
/* It is (1) more robust against overflow and underflow and */
/* (2) adopts the more conservative Ahues & Tisseur stopping */
/* criterion (LAWN 122, 1997). */
/* ========================================================= */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
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;
}
/* ==== clear out the trash ==== */
i__1 = *ihi - 3;
for (j = *ilo; j <= i__1; ++j) {
i__2 = j + 2 + j * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = j + 3 + j * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
/* L10: */
}
if (*ilo <= *ihi - 2) {
i__1 = *ihi + (*ihi - 2) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
/* ==== ensure that subdiagonal entries are real ==== */
if (*wantt) {
jlo = 1;
jhi = *n;
} else {
jlo = *ilo;
jhi = *ihi;
}
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
if (r_imag(&h__[i__ + (i__ - 1) * h_dim1]) != 0.f) {
/* ==== The following redundant normalization */
/* . avoids problems with both gradual and */
/* . sudden underflow in ABS(H(I,I-1)) ==== */
i__2 = i__ + (i__ - 1) * h_dim1;
i__3 = i__ + (i__ - 1) * h_dim1;
r__3 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[i__
+ (i__ - 1) * h_dim1]), dabs(r__2));
q__1.r = h__[i__2].r / r__3, q__1.i = h__[i__2].i / r__3;
sc.r = q__1.r, sc.i = q__1.i;
r_cnjg(&q__2, &sc);
r__1 = c_abs(&sc);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sc.r = q__1.r, sc.i = q__1.i;
i__2 = i__ + (i__ - 1) * h_dim1;
r__1 = c_abs(&h__[i__ + (i__ - 1) * h_dim1]);
h__[i__2].r = r__1, h__[i__2].i = 0.f;
i__2 = jhi - i__ + 1;
cscal_(&i__2, &sc, &h__[i__ + i__ * h_dim1], ldh);
/* Computing MIN */
i__3 = jhi, i__4 = i__ + 1;
i__2 = min(i__3,i__4) - jlo + 1;
r_cnjg(&q__1, &sc);
cscal_(&i__2, &q__1, &h__[jlo + i__ * h_dim1], &c__1);
if (*wantz) {
i__2 = *ihiz - *iloz + 1;
r_cnjg(&q__1, &sc);
cscal_(&i__2, &q__1, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L20: */
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) 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;
}
/* 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;
L30:
if (i__ < *ilo) {
goto L150;
}
/* 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;
for (its = 0; its <= 30; ++its) {
/* Look for a single small subdiagonal element. */
i__1 = l + 1;
for (k = i__; k >= i__1; --k) {
i__2 = k + (k - 1) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k + (k
- 1) * h_dim1]), dabs(r__2)) <= smlnum) {
goto L50;
}
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
tst = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k -
1 + (k - 1) * h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3]
.r, dabs(r__3)) + (r__4 = r_imag(&h__[k + k * h_dim1]),
dabs(r__4)));
if (tst == 0.f) {
if (k - 2 >= *ilo) {
i__2 = k - 1 + (k - 2) * h_dim1;
tst += (r__1 = h__[i__2].r, dabs(r__1));
}
if (k + 1 <= *ihi) {
i__2 = k + 1 + k * h_dim1;
tst += (r__1 = h__[i__2].r, dabs(r__1));
}
}
/* ==== The following is a conservative small subdiagonal */
/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
/* . 1997). It has better mathematical foundation and */
/* . improves accuracy in some examples. ==== */
i__2 = k + (k - 1) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) <= ulp * tst) {
/* Computing MAX */
i__2 = k + (k - 1) * h_dim1;
i__3 = k - 1 + k * h_dim1;
r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ k * h_dim1]), dabs(r__4));
ab = dmax(r__5,r__6);
/* Computing MIN */
i__2 = k + (k - 1) * h_dim1;
i__3 = k - 1 + k * h_dim1;
r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ k * h_dim1]), dabs(r__4));
ba = dmin(r__5,r__6);
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
i__4 = k + k * h_dim1;
r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
aa = dmax(r__5,r__6);
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MIN */
i__4 = k + k * h_dim1;
r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
bb = dmin(r__5,r__6);
s = aa + ab;
/* Computing MAX */
r__1 = smlnum, r__2 = ulp * (bb * (aa / s));
if (ba * (ab / s) <= dmax(r__1,r__2)) {
goto L50;
}
}
/* L40: */
}
L50:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
i__1 = l + (l - 1) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
/* Exit from loop if a submatrix of order 1 has split off. */
if (l >= i__) {
goto L140;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10) {
/* Exceptional shift. */
i__1 = l + 1 + l * h_dim1;
s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
i__1 = l + l * h_dim1;
q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
t.r = q__1.r, t.i = q__1.i;
} else if (its == 20) {
/* Exceptional shift. */
i__1 = i__ + (i__ - 1) * h_dim1;
s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
i__1 = i__ + i__ * h_dim1;
q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
t.r = q__1.r, t.i = q__1.i;
} else {
/* Wilkinson's shift. */
i__1 = i__ + i__ * h_dim1;
t.r = h__[i__1].r, t.i = h__[i__1].i;
c_sqrt(&q__2, &h__[i__ - 1 + i__ * h_dim1]);
c_sqrt(&q__3, &h__[i__ + (i__ - 1) * h_dim1]);
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r *
q__3.i + q__2.i * q__3.r;
u.r = q__1.r, u.i = q__1.i;
s = (r__1 = u.r, dabs(r__1)) + (r__2 = r_imag(&u), dabs(r__2));
if (s != 0.f) {
i__1 = i__ - 1 + (i__ - 1) * h_dim1;
q__2.r = h__[i__1].r - t.r, q__2.i = h__[i__1].i - t.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
x.r = q__1.r, x.i = q__1.i;
sx = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x), dabs(r__2)
);
/* Computing MAX */
r__3 = s, r__4 = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x)
, dabs(r__2));
s = dmax(r__3,r__4);
q__5.r = x.r / s, q__5.i = x.i / s;
pow_ci(&q__4, &q__5, &c__2);
q__7.r = u.r / s, q__7.i = u.i / s;
pow_ci(&q__6, &q__7, &c__2);
q__3.r = q__4.r + q__6.r, q__3.i = q__4.i + q__6.i;
c_sqrt(&q__2, &q__3);
q__1.r = s * q__2.r, q__1.i = s * q__2.i;
y.r = q__1.r, y.i = q__1.i;
if (sx > 0.f) {
q__1.r = x.r / sx, q__1.i = x.i / sx;
q__2.r = x.r / sx, q__2.i = x.i / sx;
if (q__1.r * y.r + r_imag(&q__2) * r_imag(&y) < 0.f) {
q__3.r = -y.r, q__3.i = -y.i;
y.r = q__3.r, y.i = q__3.i;
}
}
q__4.r = x.r + y.r, q__4.i = x.i + y.i;
cladiv_(&q__3, &u, &q__4);
q__2.r = u.r * q__3.r - u.i * q__3.i, q__2.i = u.r * q__3.i +
u.i * q__3.r;
q__1.r = t.r - q__2.r, q__1.i = t.i - q__2.i;
t.r = q__1.r, t.i = q__1.i;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__1 = l + 1;
for (m = i__ - 1; m >= i__1; --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__2 = m + m * h_dim1;
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = m + 1 + (m + 1) * h_dim1;
h22.r = h__[i__2].r, h22.i = h__[i__2].i;
q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
h11s.r = q__1.r, h11s.i = q__1.i;
i__2 = m + 1 + m * h_dim1;
h21 = h__[i__2].r;
s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(
r__2)) + dabs(h21);
q__1.r = h11s.r / s, q__1.i = h11s.i / s;
h11s.r = q__1.r, h11s.i = q__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.f;
i__2 = m + (m - 1) * h_dim1;
h10 = h__[i__2].r;
if (dabs(h10) * dabs(h21) <= ulp * (((r__1 = h11s.r, dabs(r__1))
+ (r__2 = r_imag(&h11s), dabs(r__2))) * ((r__3 = h11.r,
dabs(r__3)) + (r__4 = r_imag(&h11), dabs(r__4)) + ((r__5 =
h22.r, dabs(r__5)) + (r__6 = r_imag(&h22), dabs(r__6)))))
) {
goto L70;
}
/* L60: */
}
i__1 = l + l * h_dim1;
h11.r = h__[i__1].r, h11.i = h__[i__1].i;
i__1 = l + 1 + (l + 1) * h_dim1;
h22.r = h__[i__1].r, h22.i = h__[i__1].i;
q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
h11s.r = q__1.r, h11s.i = q__1.i;
i__1 = l + 1 + l * h_dim1;
h21 = h__[i__1].r;
s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(r__2))
+ dabs(h21);
q__1.r = h11s.r / s, q__1.i = h11s.i / s;
h11s.r = q__1.r, h11s.i = q__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.f;
L70:
/* Single-shift QR step */
i__1 = i__ - 1;
for (k = m; k <= i__1; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. */
/* V(2) is always real before the call to CLARFG, and hence */
/* after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
ccopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
clarfg_(&c__2, v, &v[1], &c__1, &t1);
if (k > m) {
i__2 = k + (k - 1) * h_dim1;
h__[i__2].r = v[0].r, h__[i__2].i = v[0].i;
i__2 = k + 1 + (k - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
v2.r = v[1].r, v2.i = v[1].i;
q__1.r = t1.r * v2.r - t1.i * v2.i, q__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = q__1.r;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
r_cnjg(&q__3, &t1);
i__3 = k + j * h_dim1;
q__2.r = q__3.r * h__[i__3].r - q__3.i * h__[i__3].i, q__2.i =
q__3.r * h__[i__3].i + q__3.i * h__[i__3].r;
i__4 = k + 1 + j * h_dim1;
q__4.r = t2 * h__[i__4].r, q__4.i = t2 * h__[i__4].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = k + j * h_dim1;
i__4 = k + j * h_dim1;
q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
i__3 = k + 1 + j * h_dim1;
i__4 = k + 1 + j * h_dim1;
q__2.r = sum.r * v2.r - sum.i * v2.i, q__2.i = sum.r * v2.i +
sum.i * v2.r;
q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
/* L80: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+2,I). */
/* Computing MIN */
i__3 = k + 2;
i__2 = min(i__3,i__);
for (j = i1; j <= i__2; ++j) {
i__3 = j + k * h_dim1;
q__2.r = t1.r * h__[i__3].r - t1.i * h__[i__3].i, q__2.i =
t1.r * h__[i__3].i + t1.i * h__[i__3].r;
i__4 = j + (k + 1) * h_dim1;
q__3.r = t2 * h__[i__4].r, q__3.i = t2 * h__[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = j + k * h_dim1;
i__4 = j + k * h_dim1;
q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
i__3 = j + (k + 1) * h_dim1;
i__4 = j + (k + 1) * h_dim1;
r_cnjg(&q__3, &v2);
q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
q__3.i + sum.i * q__3.r;
q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
/* L90: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
i__3 = j + k * z_dim1;
q__2.r = t1.r * z__[i__3].r - t1.i * z__[i__3].i, q__2.i =
t1.r * z__[i__3].i + t1.i * z__[i__3].r;
i__4 = j + (k + 1) * z_dim1;
q__3.r = t2 * z__[i__4].r, q__3.i = t2 * z__[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = j + k * z_dim1;
i__4 = j + k * z_dim1;
q__1.r = z__[i__4].r - sum.r, q__1.i = z__[i__4].i -
sum.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
i__3 = j + (k + 1) * z_dim1;
i__4 = j + (k + 1) * z_dim1;
r_cnjg(&q__3, &v2);
q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
q__3.i + sum.i * q__3.r;
q__1.r = z__[i__4].r - q__2.r, q__1.i = z__[i__4].i -
q__2.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
/* L100: */
}
}
if (k == m && m > l) {
/* If the QR step was started at row M > L because two */
/* consecutive small subdiagonals were found, then extra */
/* scaling must be performed to ensure that H(M,M-1) remains */
/* real. */
q__1.r = 1.f - t1.r, q__1.i = 0.f - t1.i;
temp.r = q__1.r, temp.i = q__1.i;
r__1 = c_abs(&temp);
q__1.r = temp.r / r__1, q__1.i = temp.i / r__1;
temp.r = q__1.r, temp.i = q__1.i;
i__2 = m + 1 + m * h_dim1;
i__3 = m + 1 + m * h_dim1;
r_cnjg(&q__2, &temp);
q__1.r = h__[i__3].r * q__2.r - h__[i__3].i * q__2.i, q__1.i =
h__[i__3].r * q__2.i + h__[i__3].i * q__2.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
if (m + 2 <= i__) {
i__2 = m + 2 + (m + 1) * h_dim1;
i__3 = m + 2 + (m + 1) * h_dim1;
q__1.r = h__[i__3].r * temp.r - h__[i__3].i * temp.i,
q__1.i = h__[i__3].r * temp.i + h__[i__3].i *
temp.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
i__2 = i__;
for (j = m; j <= i__2; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__3 = i2 - j;
cscal_(&i__3, &temp, &h__[j + (j + 1) * h_dim1],
ldh);
}
i__3 = j - i1;
r_cnjg(&q__1, &temp);
cscal_(&i__3, &q__1, &h__[i1 + j * h_dim1], &c__1);
if (*wantz) {
r_cnjg(&q__1, &temp);
cscal_(&nz, &q__1, &z__[*iloz + j * z_dim1], &
c__1);
}
}
/* L110: */
}
}
/* L120: */
}
/* Ensure that H(I,I-1) is real. */
i__1 = i__ + (i__ - 1) * h_dim1;
temp.r = h__[i__1].r, temp.i = h__[i__1].i;
if (r_imag(&temp) != 0.f) {
rtemp = c_abs(&temp);
i__1 = i__ + (i__ - 1) * h_dim1;
h__[i__1].r = rtemp, h__[i__1].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__1 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__1, &q__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
}
i__1 = i__ - i1;
cscal_(&i__1, &temp, &h__[i1 + i__ * h_dim1], &c__1);
if (*wantz) {
cscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L130: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L140:
/* 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;
/* return to start of the main loop with new value of I. */
i__ = l - 1;
goto L30;
L150:
return 0;
/* End of CLAHQR */
} /* clahqr_ */
/* Subroutine */ int ctgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, complex *a, integer *lda, complex *b,
integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq,
complex *z__, integer *ldz, integer *m, real *pl, real *pr, real *
dif, complex *work, integer *lwork, integer *iwork, integer *liwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTGSEN reorders the generalized Schur decomposition of a complex
matrix pair (A, B) (in terms of an unitary equivalence trans-
formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
appears in the leading diagonal blocks of the pair (A,B). The leading
columns of Q and Z form unitary bases of the corresponding left and
right eigenspaces (deflating subspaces). (A, B) must be in
generalized Schur canonical form, that is, A and B are both upper
triangular.
CTGSEN also computes the generalized eigenvalues
w(j)= ALPHA(j) / BETA(j)
of the reordered matrix pair (A, B).
Optionally, the routine computes estimates of reciprocal condition
numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
(A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
between the matrix pairs (A11, B11) and (A22,B22) that correspond to
the selected cluster and the eigenvalues outside the cluster, resp.,
and norms of "projections" onto left and right eigenspaces w.r.t.
the selected cluster in the (1,1)-block.
Arguments
=========
IJOB (input) integer
Specifies whether condition numbers are required for the
cluster of eigenvalues (PL and PR) or the deflating subspaces
(Difu and Difl):
=0: Only reorder w.r.t. SELECT. No extras.
=1: Reciprocal of norms of "projections" onto left and right
eigenspaces w.r.t. the selected cluster (PL and PR).
=2: Upper bounds on Difu and Difl. F-norm-based estimate
(DIF(1:2)).
=3: Estimate of Difu and Difl. 1-norm-based estimate
(DIF(1:2)).
About 5 times as expensive as IJOB = 2.
=4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
version to get it all.
=5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
WANTQ (input) LOGICAL
.TRUE. : update the left transformation matrix Q;
.FALSE.: do not update Q.
WANTZ (input) LOGICAL
.TRUE. : update the right transformation matrix Z;
.FALSE.: do not update Z.
SELECT (input) LOGICAL array, dimension (N)
SELECT specifies the eigenvalues in the selected cluster. To
select an eigenvalue w(j), SELECT(j) must be set to
.TRUE..
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension(LDA,N)
On entry, the upper triangular matrix A, in generalized
Schur canonical form.
On exit, A is overwritten by the reordered matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension(LDB,N)
On entry, the upper triangular matrix B, in generalized
Schur canonical form.
On exit, B is overwritten by the reordered matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
ALPHA (output) COMPLEX array, dimension (N)
BETA (output) COMPLEX array, dimension (N)
The diagonal elements of A and B, respectively,
when the pair (A,B) has been reduced to generalized Schur
form. ALPHA(i)/BETA(i) i=1,...,N are the generalized
eigenvalues.
Q (input/output) COMPLEX array, dimension (LDQ,N)
On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
On exit, Q has been postmultiplied by the left unitary
transformation matrix which reorder (A, B); The leading M
columns of Q form orthonormal bases for the specified pair of
left eigenspaces (deflating subspaces).
If WANTQ = .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1.
If WANTQ = .TRUE., LDQ >= N.
Z (input/output) COMPLEX array, dimension (LDZ,N)
On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
On exit, Z has been postmultiplied by the left unitary
transformation matrix which reorder (A, B); The leading M
columns of Z form orthonormal bases for the specified pair of
left eigenspaces (deflating subspaces).
If WANTZ = .FALSE., Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1.
If WANTZ = .TRUE., LDZ >= N.
M (output) INTEGER
The dimension of the specified pair of left and right
eigenspaces, (deflating subspaces) 0 <= M <= N.
PL, PR (output) REAL
If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
reciprocal of the norm of "projections" onto left and right
eigenspace with respect to the selected cluster.
0 < PL, PR <= 1.
If M = 0 or M = N, PL = PR = 1.
If IJOB = 0, 2 or 3 PL, PR are not referenced.
DIF (output) REAL array, dimension (2).
If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
estimates of Difu and Difl, computed using reversed
communication with CLACON.
If M = 0 or N, DIF(1:2) = F-norm([A, B]).
If IJOB = 0 or 1, DIF is not referenced.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
IF IJOB = 0, WORK is not referenced. Otherwise,
on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 1
If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
If IJOB = 3 or 5, LWORK >= 4*M*(N-M)
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER, dimension (LIWORK)
IF IJOB = 0, IWORK is not referenced. Otherwise,
on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= 1.
If IJOB = 1, 2 or 4, LIWORK >= N+2;
If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
=0: Successful exit.
<0: If INFO = -i, the i-th argument had an illegal value.
=1: Reordering of (A, B) failed because the transformed
matrix pair (A, B) would be too far from generalized
Schur form; the problem is very ill-conditioned.
(A, B) may have been partially reordered.
If requested, 0 is returned in DIF(*), PL and PR.
Further Details
===============
CTGSEN first collects the selected eigenvalues by computing unitary
U and W that move them to the top left corner of (A, B). In other
words, the selected eigenvalues are the eigenvalues of (A11, B11) in
U'*(A, B)*W = (A11 A12) (B11 B12) n1
( 0 A22),( 0 B22) n2
n1 n2 n1 n2
where N = n1+n2 and U' means the conjugate transpose of U. The first
n1 columns of U and W span the specified pair of left and right
eigenspaces (deflating subspaces) of (A, B).
If (A, B) has been obtained from the generalized real Schur
decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
reordered generalized Schur form of (C, D) is given by
(C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
and the first n1 columns of Q*U and Z*W span the corresponding
deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
Note that if the selected eigenvalue is sufficiently ill-conditioned,
then its value may differ significantly from its value before
reordering.
The reciprocal condition numbers of the left and right eigenspaces
spanned by the first n1 columns of U and W (or Q*U and Z*W) may
be returned in DIF(1:2), corresponding to Difu and Difl, resp.
The Difu and Difl are defined as:
Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
and
Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
where sigma-min(Zu) is the smallest singular value of the
(2*n1*n2)-by-(2*n1*n2) matrix
Zu = [ kron(In2, A11) -kron(A22', In1) ]
[ kron(In2, B11) -kron(B22', In1) ].
Here, Inx is the identity matrix of size nx and A22' is the
transpose of A22. kron(X, Y) is the Kronecker product between
the matrices X and Y.
When DIF(2) is small, small changes in (A, B) can cause large changes
in the deflating subspace. An approximate (asymptotic) bound on the
maximum angular error in the computed deflating subspaces is
EPS * norm((A, B)) / DIF(2),
where EPS is the machine precision.
The reciprocal norm of the projectors on the left and right
eigenspaces associated with (A11, B11) may be returned in PL and PR.
They are computed as follows. First we compute L and R so that
P*(A, B)*Q is block diagonal, where
P = ( I -L ) n1 Q = ( I R ) n1
( 0 I ) n2 and ( 0 I ) n2
n1 n2 n1 n2
and (L, R) is the solution to the generalized Sylvester equation
A11*R - L*A22 = -A12
B11*R - L*B22 = -B12
Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
An approximate (asymptotic) bound on the average absolute error of
the selected eigenvalues is
EPS * norm((A, B)) / PL.
There are also global error bounds which valid for perturbations up
to a certain restriction: A lower bound (x) on the smallest
F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
(i.e. (A + E, B + F), is
x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
An approximate bound on x can be computed from DIF(1:2), PL and PR.
If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
(L', R') and unperturbed (L, R) left and right deflating subspaces
associated with the selected cluster in the (1,1)-blocks can be
bounded as
max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
See LAPACK User's Guide section 4.11 or the following references
for more information.
Note that if the default method for computing the Frobenius-norm-
based estimate DIF is not wanted (see CLATDF), then the parameter
IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF
(IJOB = 2 will be used)). See CTGSYL for more details.
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
References
==========
[1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
M.S. Moonen et al (eds), Linear Algebra for Large Scale and
Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
[2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
Eigenvalues of a Regular Matrix Pair (A, B) and Condition
Estimation: Theory, Algorithms and Software, Report
UMINF - 94.04, Department of Computing Science, Umea University,
S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
To appear in Numerical Algorithms, 1996.
[3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
for Solving the Generalized Sylvester Equation and Estimating the
Separation between Regular Matrix Pairs, Report UMINF - 93.23,
Department of Computing Science, Umea University, S-901 87 Umea,
Sweden, December 1993, Revised April 1994, Also as LAPACK working
Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
1996.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), c_abs(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer kase, ierr;
static real dsum;
static logical swap;
static integer i__, k;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static logical wantd;
static integer lwmin;
static logical wantp;
static integer n1, n2;
static logical wantd1, wantd2;
static real dscale;
static integer ks;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
extern doublereal slamch_(char *);
static real rdscal;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
static real safmin;
extern /* Subroutine */ int ctgexc_(logical *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, integer *, integer *, integer *), xerbla_(
char *, integer *), classq_(integer *, complex *, integer
*, real *, real *);
static integer liwmin;
extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, complex *, integer *, integer *, integer *);
static integer mn2;
static logical lquery;
static integer ijb;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (*ijob < 0 || *ijob > 5) {
*info = -1;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldq < 1 || *wantq && *ldq < *n) {
*info = -13;
} else if (*ldz < 1 || *wantz && *ldz < *n) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSEN", &i__1);
return 0;
}
ierr = 0;
wantp = *ijob == 1 || *ijob >= 4;
wantd1 = *ijob == 2 || *ijob == 4;
wantd2 = *ijob == 3 || *ijob == 5;
wantd = wantd1 || wantd2;
/* Set M to the dimension of the specified pair of deflating
subspaces. */
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = a_subscr(k, k);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = b_subscr(k, k);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
if (k < *n) {
if (select[k]) {
++(*m);
}
} else {
if (select[*n]) {
++(*m);
}
}
/* L10: */
}
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n + 2;
liwmin = max(i__1,i__2);
} else if (*ijob == 3 || *ijob == 5) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 2) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
*n + 2;
liwmin = max(i__1,i__2);
} else {
lwmin = 1;
liwmin = 1;
}
work[1].r = (real) lwmin, work[1].i = 0.f;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -21;
} else if (*liwork < liwmin && ! lquery) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSEN", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wantp) {
*pl = 1.f;
*pr = 1.f;
}
if (wantd) {
dscale = 0.f;
dsum = 1.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
classq_(n, &a_ref(1, i__), &c__1, &dscale, &dsum);
classq_(n, &b_ref(1, i__), &c__1, &dscale, &dsum);
/* L20: */
}
dif[1] = dscale * sqrt(dsum);
dif[2] = dif[1];
}
goto L70;
}
/* Get machine constant */
safmin = slamch_("S");
/* Collect the selected blocks at the top-left corner of (A, B). */
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
swap = select[k];
if (swap) {
++ks;
/* Swap the K-th block to position KS. Compute unitary Q
and Z that will swap adjacent diagonal blocks in (A, B). */
if (k != ks) {
ctgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
&q[q_offset], ldq, &z__[z_offset], ldz, &k, &ks, &
ierr);
}
if (ierr > 0) {
/* Swap is rejected: exit. */
*info = 1;
if (wantp) {
*pl = 0.f;
*pr = 0.f;
}
if (wantd) {
dif[1] = 0.f;
dif[2] = 0.f;
}
goto L70;
}
}
/* L30: */
}
if (wantp) {
/* Solve generalized Sylvester equation for R and L:
A11 * R - L * A22 = A12
B11 * R - L * B22 = B12 */
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
clacpy_("Full", &n1, &n2, &a_ref(1, i__), lda, &work[1], &n1);
clacpy_("Full", &n1, &n2, &b_ref(1, i__), ldb, &work[n1 * n2 + 1], &
n1);
ijb = 0;
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__), lda,
&work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__), ldb, &
work[n1 * n2 + 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1)
+ 1], &i__1, &iwork[1], &ierr);
/* Estimate the reciprocal of norms of "projections" onto
left and right eigenspaces */
rdscal = 0.f;
dsum = 1.f;
i__1 = n1 * n2;
classq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
*pl = rdscal * sqrt(dsum);
if (*pl == 0.f) {
*pl = 1.f;
} else {
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
}
rdscal = 0.f;
dsum = 1.f;
i__1 = n1 * n2;
classq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
*pr = rdscal * sqrt(dsum);
if (*pr == 0.f) {
*pr = 1.f;
} else {
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
}
}
if (wantd) {
/* Compute estimates Difu and Difl. */
if (wantd1) {
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 3;
/* Frobenius norm-based Difu estimate. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__),
lda, &work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__),
ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &work[(n1
* n2 << 1) + 1], &i__1, &iwork[1], &ierr);
/* Frobenius norm-based Difl estimate. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[a_offset],
lda, &work[1], &n2, &b_ref(i__, i__), ldb, &b[b_offset],
ldb, &work[n1 * n2 + 1], &n2, &dscale, &dif[2], &work[(n1
* n2 << 1) + 1], &i__1, &iwork[1], &ierr);
} else {
/* Compute 1-norm-based estimates of Difu and Difl using
reversed communication with CLACON. In each step a
generalized Sylvester equation or a transposed variant
is solved. */
kase = 0;
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 0;
mn2 = (n1 << 1) * n2;
/* 1-norm-based estimate of Difu. */
L40:
clacon_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(
i__, i__), lda, &work[1], &n1, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, &
dscale, &dif[1], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("C", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(
i__, i__), lda, &work[1], &n1, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, &
dscale, &dif[1], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
}
goto L40;
}
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
L50:
clacon_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b_ref(i__, i__),
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &
dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("C", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n2, &
dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
}
goto L50;
}
dif[2] = dscale / dif[2];
}
}
/* If B(K,K) is complex, make it real and positive (normalization
of the generalized Schur form) and Store the generalized
eigenvalues of reordered pair (A, B) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
dscale = c_abs(&b_ref(k, k));
if (dscale > safmin) {
i__2 = b_subscr(k, k);
q__2.r = b[i__2].r / dscale, q__2.i = b[i__2].i / dscale;
r_cnjg(&q__1, &q__2);
work[1].r = q__1.r, work[1].i = q__1.i;
i__2 = b_subscr(k, k);
q__1.r = b[i__2].r / dscale, q__1.i = b[i__2].i / dscale;
work[2].r = q__1.r, work[2].i = q__1.i;
i__2 = b_subscr(k, k);
b[i__2].r = dscale, b[i__2].i = 0.f;
i__2 = *n - k;
cscal_(&i__2, &work[1], &b_ref(k, k + 1), ldb);
i__2 = *n - k + 1;
cscal_(&i__2, &work[1], &a_ref(k, k), lda);
if (*wantq) {
cscal_(n, &work[2], &q_ref(1, k), &c__1);
}
} else {
i__2 = b_subscr(k, k);
b[i__2].r = 0.f, b[i__2].i = 0.f;
}
i__2 = k;
i__3 = a_subscr(k, k);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = b_subscr(k, k);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L60: */
}
L70:
work[1].r = (real) lwmin, work[1].i = 0.f;
iwork[1] = liwmin;
return 0;
/* End of CTGSEN */
} /* ctgsen_ */
/* Subroutine */ int chbtrd_(char *vect, char *uplo, integer *n, integer *kd,
complex *ab, integer *ldab, real *d__, real *e, complex *q, integer *
ldq, complex *work, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
real r__1;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
integer i__, j, k, l;
complex t;
integer i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt, kdm1, inca,
jend, lend, jinc;
real abst;
integer incx, last;
complex temp;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
integer j1end, j1inc;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
integer iqend;
extern logical lsame_(char *, char *);
logical initq, wantq, upper;
extern /* Subroutine */ int clar2v_(integer *, complex *, complex *,
complex *, integer *, real *, complex *, integer *), clacgv_(
integer *, complex *, integer *);
integer iqaend;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*), clargv_(integer *, complex *, integer *, complex *,
integer *, real *, integer *), clartv_(integer *, complex *,
integer *, complex *, integer *, real *, complex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHBTRD reduces a complex Hermitian band matrix A to real symmetric */
/* tridiagonal form T by a unitary similarity transformation: */
/* Q**H * A * Q = T. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* = 'N': do not form Q; */
/* = 'V': form Q; */
/* = 'U': update a matrix X, by forming X*Q. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the Hermitian band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, the diagonal elements of AB are overwritten by the */
/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */
/* elements on the first superdiagonal (if UPLO = 'U') or the */
/* first subdiagonal (if UPLO = 'L') are overwritten by the */
/* off-diagonal elements of T; the rest of AB is overwritten by */
/* values generated during the reduction. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* D (output) REAL array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T. */
/* E (output) REAL array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, if VECT = 'U', then Q must contain an N-by-N */
/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */
/* On exit: */
/* if VECT = 'V', Q contains the N-by-N unitary matrix Q; */
/* if VECT = 'U', Q contains the product X*Q; */
/* if VECT = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* Modified by Linda Kaufman, Bell Labs. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
initq = lsame_(vect, "V");
wantq = initq || lsame_(vect, "U");
upper = lsame_(uplo, "U");
kd1 = *kd + 1;
kdm1 = *kd - 1;
incx = *ldab - 1;
iqend = 1;
*info = 0;
if (! wantq && ! lsame_(vect, "N")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < kd1) {
*info = -6;
} else if (*ldq < max(1,*n) && wantq) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Initialize Q to the unit matrix, if needed */
if (initq) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
/* Wherever possible, plane rotations are generated and applied in */
/* vector operations of length NR over the index set J1:J2:KD1. */
/* The real cosines and complex sines of the plane rotations are */
/* stored in the arrays D and WORK. */
inca = kd1 * *ldab;
/* Computing MIN */
i__1 = *n - 1;
kdn = min(i__1,*kd);
if (upper) {
if (*kd > 1) {
/* Reduce to complex Hermitian tridiagonal form, working with */
/* the upper triangle */
nr = 0;
j1 = kdn + 2;
j2 = 1;
i__1 = kd1 + ab_dim1;
i__2 = kd1 + ab_dim1;
r__1 = ab[i__2].r;
ab[i__1].r = r__1, ab[i__1].i = 0.f;
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th row of matrix to tridiagonal form */
for (k = kdn + 1; k >= 2; --k) {
j1 += kdn;
j2 += kdn;
if (nr > 0) {
/* generate plane rotations to annihilate nonzero */
/* elements which have been created outside the band */
clargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, &
work[j1], &kd1, &d__[j1], &kd1);
/* apply rotations from the right */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr >= (*kd << 1) - 1) {
i__2 = *kd - 1;
for (l = 1; l <= i__2; ++l) {
clartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1],
&inca, &ab[l + j1 * ab_dim1], &inca, &
d__[j1], &work[j1], &kd1);
/* L10: */
}
} else {
jend = j1 + (nr - 1) * kd1;
i__2 = jend;
i__3 = kd1;
for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <=
i__2; jinc += i__3) {
crot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], &
c__1, &ab[jinc * ab_dim1 + 1], &c__1,
&d__[jinc], &work[jinc]);
/* L20: */
}
}
}
if (k > 2) {
if (k <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i,i+k-1) */
/* within the band */
clartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1]
, &ab[*kd - k + 2 + (i__ + k - 1) *
ab_dim1], &d__[i__ + k - 1], &work[i__ +
k - 1], &temp);
i__3 = *kd - k + 3 + (i__ + k - 2) * ab_dim1;
ab[i__3].r = temp.r, ab[i__3].i = temp.i;
/* apply rotation from the right */
i__3 = k - 3;
crot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) *
ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ +
k - 1) * ab_dim1], &c__1, &d__[i__ + k -
1], &work[i__ + k - 1]);
}
++nr;
j1 = j1 - kdn - 1;
}
/* apply plane rotations from both sides to diagonal */
/* blocks */
if (nr > 0) {
clar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 +
j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca,
&d__[j1], &work[j1], &kd1);
}
/* apply plane rotations from the left */
if (nr > 0) {
clacgv_(&nr, &work[j1], &kd1);
if ((*kd << 1) - 1 < nr) {
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
i__3 = *kd - 1;
for (l = 1; l <= i__3; ++l) {
if (j2 + l > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[*kd - l + (j1 + l) *
ab_dim1], &inca, &ab[*kd - l + 1
+ (j1 + l) * ab_dim1], &inca, &
d__[j1], &work[j1], &kd1);
}
/* L30: */
}
} else {
j1end = j1 + kd1 * (nr - 2);
if (j1end >= j1) {
i__3 = j1end;
i__2 = kd1;
for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <=
i__3; jin += i__2) {
i__4 = *kd - 1;
crot_(&i__4, &ab[*kd - 1 + (jin + 1) *
ab_dim1], &incx, &ab[*kd + (jin +
1) * ab_dim1], &incx, &d__[jin], &
work[jin]);
/* L40: */
}
}
/* Computing MIN */
i__2 = kdm1, i__3 = *n - j2;
lend = min(i__2,i__3);
last = j1end + kd1;
if (lend > 0) {
crot_(&lend, &ab[*kd - 1 + (last + 1) *
ab_dim1], &incx, &ab[*kd + (last + 1)
* ab_dim1], &incx, &d__[last], &work[
last]);
}
}
}
if (wantq) {
/* accumulate product of plane rotations in Q */
if (initq) {
/* take advantage of the fact that Q was */
/* initially the Identity matrix */
iqend = max(iqend,j2);
/* Computing MAX */
i__2 = 0, i__3 = k - 3;
i2 = max(i__2,i__3);
iqaend = i__ * *kd + 1;
if (k == 2) {
iqaend += *kd;
}
iqaend = min(iqaend,iqend);
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+= i__3) {
ibl = i__ - i2 / kdm1;
++i2;
/* Computing MAX */
i__4 = 1, i__5 = j - ibl;
iqb = max(i__4,i__5);
nq = iqaend + 1 - iqb;
/* Computing MIN */
i__4 = iqaend + *kd;
iqaend = min(i__4,iqend);
r_cnjg(&q__1, &work[j]);
crot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
&q[iqb + j * q_dim1], &c__1, &d__[j],
&q__1);
/* L50: */
}
} else {
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+= i__2) {
r_cnjg(&q__1, &work[j]);
crot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
j * q_dim1 + 1], &c__1, &d__[j], &
q__1);
/* L60: */
}
}
}
if (j2 + kdn > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 = j2 - kdn - 1;
}
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3)
{
/* create nonzero element a(j-1,j+kd) outside the band */
/* and store it in WORK */
i__4 = j + *kd;
i__5 = j;
i__6 = (j + *kd) * ab_dim1 + 1;
q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
ab[i__6].i, q__1.i = work[i__5].r * ab[i__6]
.i + work[i__5].i * ab[i__6].r;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
i__4 = (j + *kd) * ab_dim1 + 1;
i__5 = j;
i__6 = (j + *kd) * ab_dim1 + 1;
q__1.r = d__[i__5] * ab[i__6].r, q__1.i = d__[i__5] *
ab[i__6].i;
ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
/* L70: */
}
/* L80: */
}
/* L90: */
}
}
if (*kd > 0) {
/* make off-diagonal elements real and copy them to E */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = *kd + (i__ + 1) * ab_dim1;
t.r = ab[i__3].r, t.i = ab[i__3].i;
abst = c_abs(&t);
i__3 = *kd + (i__ + 1) * ab_dim1;
ab[i__3].r = abst, ab[i__3].i = 0.f;
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (i__ < *n - 1) {
i__3 = *kd + (i__ + 2) * ab_dim1;
i__2 = *kd + (i__ + 2) * ab_dim1;
q__1.r = ab[i__2].r * t.r - ab[i__2].i * t.i, q__1.i = ab[
i__2].r * t.i + ab[i__2].i * t.r;
ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &t);
cscal_(n, &q__1, &q[(i__ + 1) * q_dim1 + 1], &c__1);
}
/* L100: */
}
} else {
/* set E to zero if original matrix was diagonal */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = 0.f;
/* L110: */
}
}
/* copy diagonal elements to D */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = i__;
i__2 = kd1 + i__ * ab_dim1;
d__[i__3] = ab[i__2].r;
/* L120: */
}
} else {
if (*kd > 1) {
/* Reduce to complex Hermitian tridiagonal form, working with */
/* the lower triangle */
nr = 0;
j1 = kdn + 2;
j2 = 1;
i__1 = ab_dim1 + 1;
i__3 = ab_dim1 + 1;
r__1 = ab[i__3].r;
ab[i__1].r = r__1, ab[i__1].i = 0.f;
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th column of matrix to tridiagonal form */
for (k = kdn + 1; k >= 2; --k) {
j1 += kdn;
j2 += kdn;
if (nr > 0) {
/* generate plane rotations to annihilate nonzero */
/* elements which have been created outside the band */
clargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, &
work[j1], &kd1, &d__[j1], &kd1);
/* apply plane rotations from one side */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr > (*kd << 1) - 1) {
i__3 = *kd - 1;
for (l = 1; l <= i__3; ++l) {
clartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) *
ab_dim1], &inca, &ab[kd1 - l + 1 + (
j1 - kd1 + l) * ab_dim1], &inca, &d__[
j1], &work[j1], &kd1);
/* L130: */
}
} else {
jend = j1 + kd1 * (nr - 1);
i__3 = jend;
i__2 = kd1;
for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <=
i__3; jinc += i__2) {
crot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1]
, &incx, &ab[kd1 + (jinc - *kd) *
ab_dim1], &incx, &d__[jinc], &work[
jinc]);
/* L140: */
}
}
}
if (k > 2) {
if (k <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i+k-1,i) */
/* within the band */
clartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ *
ab_dim1], &d__[i__ + k - 1], &work[i__ +
k - 1], &temp);
i__2 = k - 1 + i__ * ab_dim1;
ab[i__2].r = temp.r, ab[i__2].i = temp.i;
/* apply rotation from the left */
i__2 = k - 3;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
crot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], &
i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], &
i__4, &d__[i__ + k - 1], &work[i__ + k -
1]);
}
++nr;
j1 = j1 - kdn - 1;
}
/* apply plane rotations from both sides to diagonal */
/* blocks */
if (nr > 0) {
clar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 *
ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], &
inca, &d__[j1], &work[j1], &kd1);
}
/* apply plane rotations from the right */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr > 0) {
clacgv_(&nr, &work[j1], &kd1);
if (nr > (*kd << 1) - 1) {
i__2 = *kd - 1;
for (l = 1; l <= i__2; ++l) {
if (j2 + l > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[l + 2 + (j1 - 1) *
ab_dim1], &inca, &ab[l + 1 + j1 *
ab_dim1], &inca, &d__[j1], &work[
j1], &kd1);
}
/* L150: */
}
} else {
j1end = j1 + kd1 * (nr - 2);
if (j1end >= j1) {
i__2 = j1end;
i__3 = kd1;
for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 :
j1inc <= i__2; j1inc += i__3) {
crot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 +
3], &c__1, &ab[j1inc * ab_dim1 +
2], &c__1, &d__[j1inc], &work[
j1inc]);
/* L160: */
}
}
/* Computing MIN */
i__3 = kdm1, i__2 = *n - j2;
lend = min(i__3,i__2);
last = j1end + kd1;
if (lend > 0) {
crot_(&lend, &ab[(last - 1) * ab_dim1 + 3], &
c__1, &ab[last * ab_dim1 + 2], &c__1,
&d__[last], &work[last]);
}
}
}
if (wantq) {
/* accumulate product of plane rotations in Q */
if (initq) {
/* take advantage of the fact that Q was */
/* initially the Identity matrix */
iqend = max(iqend,j2);
/* Computing MAX */
i__3 = 0, i__2 = k - 3;
i2 = max(i__3,i__2);
iqaend = i__ * *kd + 1;
if (k == 2) {
iqaend += *kd;
}
iqaend = min(iqaend,iqend);
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+= i__2) {
ibl = i__ - i2 / kdm1;
++i2;
/* Computing MAX */
i__4 = 1, i__5 = j - ibl;
iqb = max(i__4,i__5);
nq = iqaend + 1 - iqb;
/* Computing MIN */
i__4 = iqaend + *kd;
iqaend = min(i__4,iqend);
crot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
&q[iqb + j * q_dim1], &c__1, &d__[j],
&work[j]);
/* L170: */
}
} else {
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+= i__3) {
crot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
j * q_dim1 + 1], &c__1, &d__[j], &
work[j]);
/* L180: */
}
}
}
if (j2 + kdn > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 = j2 - kdn - 1;
}
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2)
{
/* create nonzero element a(j+kd,j-1) outside the */
/* band and store it in WORK */
i__4 = j + *kd;
i__5 = j;
i__6 = kd1 + j * ab_dim1;
q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
ab[i__6].i, q__1.i = work[i__5].r * ab[i__6]
.i + work[i__5].i * ab[i__6].r;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
i__4 = kd1 + j * ab_dim1;
i__5 = j;
i__6 = kd1 + j * ab_dim1;
q__1.r = d__[i__5] * ab[i__6].r, q__1.i = d__[i__5] *
ab[i__6].i;
ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
/* L190: */
}
/* L200: */
}
/* L210: */
}
}
if (*kd > 0) {
/* make off-diagonal elements real and copy them to E */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ * ab_dim1 + 2;
t.r = ab[i__2].r, t.i = ab[i__2].i;
abst = c_abs(&t);
i__2 = i__ * ab_dim1 + 2;
ab[i__2].r = abst, ab[i__2].i = 0.f;
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (i__ < *n - 1) {
i__2 = (i__ + 1) * ab_dim1 + 2;
i__3 = (i__ + 1) * ab_dim1 + 2;
q__1.r = ab[i__3].r * t.r - ab[i__3].i * t.i, q__1.i = ab[
i__3].r * t.i + ab[i__3].i * t.r;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
}
if (wantq) {
cscal_(n, &t, &q[(i__ + 1) * q_dim1 + 1], &c__1);
}
/* L220: */
}
} else {
/* set E to zero if original matrix was diagonal */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = 0.f;
/* L230: */
}
}
/* copy diagonal elements to D */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ * ab_dim1 + 1;
d__[i__2] = ab[i__3].r;
/* L240: */
}
}
return 0;
/* End of CHBTRD */
} /* chbtrd_ */
/* Subroutine */ int cung2l_(integer *m, integer *n, integer *k, complex *a,
integer *lda, complex *tau, complex *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CUNG2L generates an m by n complex matrix Q with orthonormal columns,
which is defined as the last n columns of a product of k elementary
reflectors of order m
Q = H(k) . . . H(2) H(1)
as returned by CGEQLF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q. M >= N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. N >= K >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the (n-k+i)-th column must contain the vector which
defines the elementary reflector H(i), for i = 1,2,...,k, as
returned by CGEQLF in the last k columns of its array
argument A.
On exit, the m-by-n matrix Q.
LDA (input) INTEGER
The first dimension of the array A. LDA >= max(1,M).
TAU (input) COMPLEX array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by CGEQLF.
WORK (workspace) COMPLEX array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument has an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
static integer i, j, l;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), clarf_(char *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, complex *);
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *n > *m) {
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNG2L", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k;
for (j = 1; j <= *n-*k; ++j) {
i__2 = *m;
for (l = 1; l <= *m; ++l) {
i__3 = l + j * a_dim1;
A(l,j).r = 0.f, A(l,j).i = 0.f;
/* L10: */
}
i__2 = *m - *n + j + j * a_dim1;
A(*m-*n+j,j).r = 1.f, A(*m-*n+j,j).i = 0.f;
/* L20: */
}
i__1 = *k;
for (i = 1; i <= *k; ++i) {
ii = *n - *k + i;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
i__2 = *m - *n + ii + ii * a_dim1;
A(*m-*n+ii,ii).r = 1.f, A(*m-*n+ii,ii).i = 0.f;
i__2 = *m - *n + ii;
i__3 = ii - 1;
clarf_("Left", &i__2, &i__3, &A(1,ii), &c__1, &TAU(i), &A(1,1), lda, &WORK(1));
i__2 = *m - *n + ii - 1;
i__3 = i;
q__1.r = -(doublereal)TAU(i).r, q__1.i = -(doublereal)TAU(i).i;
cscal_(&i__2, &q__1, &A(1,ii), &c__1);
i__2 = *m - *n + ii + ii * a_dim1;
i__3 = i;
q__1.r = 1.f - TAU(i).r, q__1.i = 0.f - TAU(i).i;
A(*m-*n+ii,ii).r = q__1.r, A(*m-*n+ii,ii).i = q__1.i;
/* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m;
for (l = *m - *n + ii + 1; l <= *m; ++l) {
i__3 = l + ii * a_dim1;
A(l,ii).r = 0.f, A(l,ii).i = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of CUNG2L */
} /* cung2l_ */
/* Subroutine */ int clagsy_(integer *n, integer *k, real *d, complex *a,
integer *lda, integer *iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
i__9;
doublereal d__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer i, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *);
static complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), csymv_(char *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
complex *, integer *);
extern real scnrm2_(integer *, complex *, integer *);
static integer ii, jj;
static complex wa, wb;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
static real wn;
extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
integer *, integer *, integer *, complex *);
static complex tau;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAGSY generates a complex symmetric matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U**T. The semi-bandwidth may then be reduced to k by
additional unitary transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) REAL array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX array, dimension (LDA,N)
The generated n by n symmetric matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CLAGSY", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = i + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
d__1 = wn / c_abs(&work[1]);
q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * conjg(u) */
i__1 = *n - i + 1;
clacgv_(&i__1, &work[1], &c__1);
i__1 = *n - i + 1;
csymv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
i__1 = *n - i + 1;
clacgv_(&i__1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__1 = *n - i + 1;
cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__1 = *n - i + 1;
caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n)
CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
$ A( I, I ), LDA ) */
i__1 = *n;
for (jj = i; jj <= i__1; ++jj) {
i__2 = *n;
for (ii = jj; ii <= i__2; ++ii) {
i__3 = ii + jj * a_dim1;
i__4 = ii + jj * a_dim1;
i__5 = ii - i + 1;
i__6 = *n + jj - i + 1;
q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[
i__5].i * work[i__6].r;
q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i;
i__7 = *n + ii - i + 1;
i__8 = jj - i + 1;
q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[
i__7].i * work[i__8].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L40: */
}
/* L50: */
}
/* L60: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = scnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / c_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *k + i + i * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *k - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1)
* a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[
1], &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1],
&c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * conjg(u) */
i__2 = *n - *k - i + 1;
clacgv_(&i__2, &a[*k + i + i * a_dim1], &c__1);
i__2 = *n - *k - i + 1;
csymv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *n - *k - i + 1;
clacgv_(&i__2, &a[*k + i + i * a_dim1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__2 = *n - *k - i + 1;
cdotc_(&q__4, &i__2, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - *k - i + 1;
caxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply symmetric rank-2 update to A(k+i:n,k+i:n)
CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
$ A( K+I, K+I ), LDA ) */
i__2 = *n;
for (jj = *k + i; jj <= i__2; ++jj) {
i__3 = *n;
for (ii = jj; ii <= i__3; ++ii) {
i__4 = ii + jj * a_dim1;
i__5 = ii + jj * a_dim1;
i__6 = ii + i * a_dim1;
i__7 = jj - *k - i + 1;
q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i,
q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
i__7].r;
q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i;
i__8 = ii - *k - i + 1;
i__9 = jj + i * a_dim1;
q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i,
q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
i__9].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__4].r = q__1.r, a[i__4].i = q__1.i;
/* L70: */
}
/* L80: */
}
i__2 = *k + i + i * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L90: */
}
/* L100: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = j + i * a_dim1;
i__4 = i + j * a_dim1;
a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
/* L110: */
}
/* L120: */
}
return 0;
/* End of CLAGSY */
} /* clagsy_ */
int cgeev_(char *jobvl, char *jobvr, int *n, complex *a,
int *lda, complex *w, complex *vl, int *ldvl, complex *vr,
int *ldvr, complex *work, int *lwork, float *rwork, int *
info)
{
/* System generated locals */
int a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
float r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
int i__, k, ihi;
float scl;
int ilo;
float dum[1], eps;
complex tmp;
int ibal;
char side[1];
float anrm;
int ierr, itau, iwrk, nout;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
extern double scnrm2_(int *, complex *, int *);
extern int cgebak_(char *, char *, int *, int *,
int *, float *, int *, complex *, int *, int *), cgebal_(char *, int *, complex *, int *,
int *, int *, float *, int *), slabad_(float *,
float *);
int scalea;
extern double clange_(char *, int *, int *, complex *,
int *, float *);
float cscale;
extern int cgehrd_(int *, int *, int *,
complex *, int *, complex *, complex *, int *, int *),
clascl_(char *, int *, int *, float *, float *, int *,
int *, complex *, int *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), clacpy_(char *, int *, int *, complex *, int *,
complex *, int *), xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
int select[1];
float bignum;
extern int isamax_(int *, float *, int *);
extern int chseqr_(char *, char *, int *, int *,
int *, complex *, int *, complex *, complex *, int *,
complex *, int *, int *), ctrevc_(char *,
char *, int *, int *, complex *, int *, complex *,
int *, complex *, int *, int *, int *, complex *,
float *, int *), cunghr_(int *, int *,
int *, complex *, int *, complex *, complex *, int *,
int *);
int minwrk, maxwrk;
int wantvl;
float smlnum;
int hswork, irwork;
int lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEEV 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 float. */
/* 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 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 array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX 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 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 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,2*N). */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (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 = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*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 float */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by CHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
c__0);
minwrk = *n << 1;
if (wantvl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
} else {
chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
}
hswork = work[1].r;
/* Computing MAX */
i__1 = MAX(maxwrk,hswork);
maxwrk = MAX(i__1,minwrk);
}
work[1].r = (float) maxwrk, work[1].i = 0.f;
if (*lwork < minwrk && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
ibal = 1;
cgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
/* 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;
cgehrd_(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';
clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(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;
chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(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;
chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from CHSEQR, 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;
ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork],
&ierr);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset],
ldvl, &ierr);
/* Normalize left eigenvectors and make largest component float */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
csscal_(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 */
r__1 = vl[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vl[k + i__ * vl_dim1]);
rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &rwork[irwork], &c__1);
r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
r__1 = sqrt(rwork[irwork + k - 1]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
r__1 = vl[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset],
ldvr, &ierr);
/* Normalize right eigenvectors and make largest component float */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
csscal_(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 */
r__1 = vr[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vr[k + i__ * vr_dim1]);
rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &rwork[irwork], &c__1);
r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
r__1 = sqrt(rwork[irwork + k - 1]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
r__1 = vr[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vr[i__2].r = q__1.r, vr[i__2].i = q__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);
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr);
}
}
work[1].r = (float) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGEEV */
} /* cgeev_ */
void cscal( int n, complex* alpha, complex *x, int incx)
{
cscal_(&n, alpha, x, &incx);
}
