/* 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 claein_(logical *rightv, logical *noinit, integer *n, complex *h__, integer *ldh, complex *w, complex *v, complex *b, integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CLAEIN uses inverse iteration to find a right or left eigenvector corresponding to the eigenvalue W of a complex upper Hessenberg matrix H. Arguments ========= RIGHTV (input) LOGICAL = .TRUE. : compute right eigenvector; = .FALSE.: compute left eigenvector. NOINIT (input) LOGICAL = .TRUE. : no initial vector supplied in V = .FALSE.: initial vector supplied in V. N (input) INTEGER The order of the matrix H. N >= 0. H (input) COMPLEX array, dimension (LDH,N) The upper Hessenberg matrix H. LDH (input) INTEGER The leading dimension of the array H. LDH >= max(1,N). W (input) COMPLEX The eigenvalue of H whose corresponding right or left eigenvector is to be computed. V (input/output) COMPLEX array, dimension (N) On entry, if NOINIT = .FALSE., V must contain a starting vector for inverse iteration; otherwise V need not be set. On exit, V contains the computed eigenvector, normalized so that the component of largest magnitude has magnitude 1; here the magnitude of a complex number (x,y) is taken to be |x| + |y|. B (workspace) COMPLEX array, dimension (LDB,N) LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). RWORK (workspace) REAL array, dimension (N) EPS3 (input) REAL A small machine-dependent value which is used to perturb close eigenvalues, and to replace zero pivots. SMLNUM (input) REAL A machine-dependent value close to the underflow threshold. INFO (output) INTEGER = 0: successful exit = 1: inverse iteration did not converge; V is set to the last iterate. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer b_dim1, b_offset, h_dim1, h_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; /* Builtin functions */ double sqrt(doublereal), r_imag(complex *); /* Local variables */ static integer ierr; static complex temp; static integer i__, j; static real scale; static complex x; static char trans[1]; static real rtemp, rootn, vnorm; extern doublereal scnrm2_(integer *, complex *, integer *); static complex ei, ej; extern integer icamax_(integer *, complex *, integer *); extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *), clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *); extern doublereal scasum_(integer *, complex *, integer *); static char normin[1]; static real nrmsml, growto; static integer its; #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 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)] h_dim1 = *ldh; h_offset = 1 + h_dim1 * 1; h__ -= h_offset; --v; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --rwork; /* Function Body */ *info = 0; /* GROWTO is the threshold used in the acceptance test for an eigenvector. */ rootn = sqrt((real) (*n)); growto = .1f / rootn; /* Computing MAX */ r__1 = 1.f, r__2 = *eps3 * rootn; nrmsml = dmax(r__1,r__2) * *smlnum; /* Form B = H - W*I (except that the subdiagonal elements are not stored). */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = h___subscr(i__, j); b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i; /* L10: */ } i__2 = b_subscr(j, j); i__3 = h___subscr(j, j); q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L20: */ } if (*noinit) { /* Initialize V. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; v[i__2].r = *eps3, v[i__2].i = 0.f; /* L30: */ } } else { /* Scale supplied initial vector. */ vnorm = scnrm2_(n, &v[1], &c__1); r__1 = *eps3 * rootn / dmax(vnorm,nrmsml); csscal_(n, &r__1, &v[1], &c__1); } if (*rightv) { /* LU decomposition with partial pivoting of B, replacing zero pivots by EPS3. */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = h___subscr(i__ + 1, i__); ei.r = h__[i__2].r, ei.i = h__[i__2].i; i__2 = b_subscr(i__, i__); if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__, i__)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4 = r_imag(&ei), dabs(r__4))) { /* Interchange rows and eliminate. */ cladiv_(&q__1, &b_ref(i__, i__), &ei); x.r = q__1.r, x.i = q__1.i; i__2 = b_subscr(i__, i__); b[i__2].r = ei.r, b[i__2].i = ei.i; i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { i__3 = b_subscr(i__ + 1, j); temp.r = b[i__3].r, temp.i = b[i__3].i; i__3 = b_subscr(i__ + 1, j); i__4 = b_subscr(i__, j); q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r * temp.i + x.i * temp.r; q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; i__3 = b_subscr(i__, j); b[i__3].r = temp.r, b[i__3].i = temp.i; /* L40: */ } } else { /* Eliminate without interchange. */ i__2 = b_subscr(i__, i__); if (b[i__2].r == 0.f && b[i__2].i == 0.f) { i__3 = b_subscr(i__, i__); b[i__3].r = *eps3, b[i__3].i = 0.f; } cladiv_(&q__1, &ei, &b_ref(i__, i__)); x.r = q__1.r, x.i = q__1.i; if (x.r != 0.f || x.i != 0.f) { i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { i__3 = b_subscr(i__ + 1, j); i__4 = b_subscr(i__ + 1, j); i__5 = b_subscr(i__, j); q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i = x.r * b[i__5].i + x.i * b[i__5].r; q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L50: */ } } } /* L60: */ } i__1 = b_subscr(*n, *n); if (b[i__1].r == 0.f && b[i__1].i == 0.f) { i__2 = b_subscr(*n, *n); b[i__2].r = *eps3, b[i__2].i = 0.f; } *(unsigned char *)trans = 'N'; } else { /* UL decomposition with partial pivoting of B, replacing zero pivots by EPS3. */ for (j = *n; j >= 2; --j) { i__1 = h___subscr(j, j - 1); ej.r = h__[i__1].r, ej.i = h__[i__1].i; i__1 = b_subscr(j, j); if ((r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)), dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4 = r_imag( &ej), dabs(r__4))) { /* Interchange columns and eliminate. */ cladiv_(&q__1, &b_ref(j, j), &ej); x.r = q__1.r, x.i = q__1.i; i__1 = b_subscr(j, j); b[i__1].r = ej.r, b[i__1].i = ej.i; i__1 = j - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j - 1); temp.r = b[i__2].r, temp.i = b[i__2].i; i__2 = b_subscr(i__, j - 1); i__3 = b_subscr(i__, j); q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r * temp.i + x.i * temp.r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(i__, j); b[i__2].r = temp.r, b[i__2].i = temp.i; /* L70: */ } } else { /* Eliminate without interchange. */ i__1 = b_subscr(j, j); if (b[i__1].r == 0.f && b[i__1].i == 0.f) { i__2 = b_subscr(j, j); b[i__2].r = *eps3, b[i__2].i = 0.f; } cladiv_(&q__1, &ej, &b_ref(j, j)); x.r = q__1.r, x.i = q__1.i; if (x.r != 0.f || x.i != 0.f) { i__1 = j - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j - 1); i__3 = b_subscr(i__, j - 1); i__4 = b_subscr(i__, j); q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i = x.r * b[i__4].i + x.i * b[i__4].r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L80: */ } } } /* L90: */ } i__1 = b_subscr(1, 1); if (b[i__1].r == 0.f && b[i__1].i == 0.f) { i__2 = b_subscr(1, 1); b[i__2].r = *eps3, b[i__2].i = 0.f; } *(unsigned char *)trans = 'C'; } *(unsigned char *)normin = 'N'; i__1 = *n; for (its = 1; its <= i__1; ++its) { /* Solve U*x = scale*v for a right eigenvector or U'*x = scale*v for a left eigenvector, overwriting x on v. */ clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1] , &scale, &rwork[1], &ierr); *(unsigned char *)normin = 'Y'; /* Test for sufficient growth in the norm of v. */ vnorm = scasum_(n, &v[1], &c__1); if (vnorm >= growto * scale) { goto L120; } /* Choose new orthogonal starting vector and try again. */ rtemp = *eps3 / (rootn + 1.f); v[1].r = *eps3, v[1].i = 0.f; i__2 = *n; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = i__; v[i__3].r = rtemp, v[i__3].i = 0.f; /* L100: */ } i__2 = *n - its + 1; i__3 = *n - its + 1; r__1 = *eps3 * rootn; q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i; v[i__2].r = q__1.r, v[i__2].i = q__1.i; /* L110: */ } /* Failure to find eigenvector in N iterations. */ *info = 1; L120: /* Normalize eigenvector. */ i__ = icamax_(n, &v[1], &c__1); i__1 = i__; r__3 = 1.f / ((r__1 = v[i__1].r, dabs(r__1)) + (r__2 = r_imag(&v[i__]), dabs(r__2))); csscal_(n, &r__3, &v[1], &c__1); return 0; /* End of CLAEIN */ } /* claein_ */
/* Subroutine */ int zchkhs_(integer *nsizes, integer *nn, integer *ntypes, logical *dotype, integer *iseed, doublereal *thresh, integer *nounit, doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *t1, doublecomplex *t2, doublecomplex *u, integer *ldu, doublecomplex * z__, doublecomplex *uz, doublecomplex *w1, doublecomplex *w3, doublecomplex *evectl, doublecomplex *evectr, doublecomplex *evecty, doublecomplex *evectx, doublecomplex *uu, doublecomplex *tau, doublecomplex *work, integer *nwork, doublereal *rwork, integer * iwork, logical *select, doublereal *result, integer *info) { /* Initialized data */ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 }; static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 }; static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 }; static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 }; /* Format strings */ static char fmt_9999[] = "(\002 ZCHKHS: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED=" "(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9998[] = "(\002 ZCHKHS: \002,a,\002 Eigenvectors from" " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of " "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002," "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9997[] = "(\002 ZCHKHS: Selected \002,a,\002 Eigenvector" "s from \002,a,\002 do not match other eigenvectors \002,9x,\002N=" "\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5," "\002)\002)"; /* System generated locals */ integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1, evectr_offset, evectx_dim1, evectx_offset, evecty_dim1, evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1, t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1, uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2; doublecomplex z__1; /* Builtin functions */ double sqrt(doublereal); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); double z_abs(doublecomplex *); /* Local variables */ static doublereal cond; static integer jcol, nmax; static doublereal unfl, ovfl, temp1, temp2; static integer i__, j, k, n; static logical badnn, match; static integer imode; static doublereal dumma[4]; static integer iinfo; static doublereal conds; extern /* Subroutine */ int zget10_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, doublereal *); static doublereal aninv, anorm; extern /* Subroutine */ int zget22_(char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static integer nmats, jsize, nerrs, itype, jtype, ntest, n1; extern /* Subroutine */ int zhst01_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *); static doublereal rtulp; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); static integer jj, in; extern doublereal dlamch_(char *); static doublecomplex cdumma[4]; static integer idumma[1]; extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *); static integer ioldsd[4]; extern /* Subroutine */ int xerbla_(char *, integer *), zgehrd_( integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), dlasum_( char *, integer *, integer *, integer *), zlatme_(integer *, char *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, char *, char *, char *, char *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *), zhsein_(char *, char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * , integer *, doublecomplex *, doublereal *, integer *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatmr_( integer *, integer *, char *, integer *, char *, doublecomplex *, integer *, doublereal *, doublecomplex *, char *, char *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *, doublereal *, char *, integer *, integer *, integer *, doublereal *, doublereal *, char *, doublecomplex *, integer *, integer *, integer *); static doublereal rtunfl, rtovfl, rtulpi, ulpinv; static integer mtypes, ntestt; extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, char *, doublecomplex *, integer *, doublecomplex *, integer *), ztrevc_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, doublecomplex *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer * ), zunmhr_(char *, char *, integer *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); static integer ihi, ilo; static doublereal ulp; /* Fortran I/O blocks */ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___38 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___40 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___41 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___42 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___47 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___49 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___50 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___54 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___55 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___56 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___57 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___58 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___59 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___60 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___61 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___62 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___63 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___64 = { 0, 0, 0, fmt_9999, 0 }; #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 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 u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1 #define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)] #define uu_subscr(a_1,a_2) (a_2)*uu_dim1 + a_1 #define uu_ref(a_1,a_2) uu[uu_subscr(a_1,a_2)] #define evectl_subscr(a_1,a_2) (a_2)*evectl_dim1 + a_1 #define evectl_ref(a_1,a_2) evectl[evectl_subscr(a_1,a_2)] #define evectr_subscr(a_1,a_2) (a_2)*evectr_dim1 + a_1 #define evectr_ref(a_1,a_2) evectr[evectr_subscr(a_1,a_2)] /* -- LAPACK test 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 ======= ZCHKHS checks the nonsymmetric eigenvalue problem routines. ZGEHRD factors A as U H U' , where ' means conjugate transpose, H is hessenberg, and U is unitary. ZUNGHR generates the unitary matrix U. ZUNMHR multiplies a matrix by the unitary matrix U. ZHSEQR factors H as Z T Z' , where Z is unitary and T is upper triangular. It also computes the eigenvalues, w(1), ..., w(n); we define a diagonal matrix W whose (diagonal) entries are the eigenvalues. ZTREVC computes the left eigenvector matrix L and the right eigenvector matrix R for the matrix T. The columns of L are the complex conjugates of the left eigenvectors of T. The columns of R are the right eigenvectors of T. L is lower triangular, and R is upper triangular. ZHSEIN computes the left eigenvector matrix Y and the right eigenvector matrix X for the matrix H. The columns of Y are the complex conjugates of the left eigenvectors of H. The columns of X are the right eigenvectors of H. Y is lower triangular, and X is upper triangular. When ZCHKHS is called, a number of matrix "sizes" ("n's") and a number of matrix "types" are specified. For each size ("n") and each type of matrix, one matrix will be generated and used to test the nonsymmetric eigenroutines. For each matrix, 14 tests will be performed: (1) | A - U H U**H | / ( |A| n ulp ) (2) | I - UU**H | / ( n ulp ) (3) | H - Z T Z**H | / ( |H| n ulp ) (4) | I - ZZ**H | / ( n ulp ) (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) (6) | I - UZ (UZ)**H | / ( n ulp ) (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) (9) | TR - RW | / ( |T| |R| ulp ) (10) | L**H T - W**H L | / ( |T| |L| ulp ) (11) | HX - XW | / ( |H| |X| ulp ) (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) (13) | AX - XW | / ( |A| |X| ulp ) (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) The "sizes" are specified by an array NN(1:NSIZES); the value of each element NN(j) specifies one size. The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. Currently, the list of possible types is: (1) The zero matrix. (2) The identity matrix. (3) A (transposed) Jordan block, with 1's on the diagonal. (4) A diagonal matrix with evenly spaced entries 1, ..., ULP and random complex angles. (ULP = (first number larger than 1) - 1 ) (5) A diagonal matrix with geometrically spaced entries 1, ..., ULP and random complex angles. (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP and random complex angles. (7) Same as (4), but multiplied by SQRT( overflow threshold ) (8) Same as (4), but multiplied by SQRT( underflow threshold ) (9) A matrix of the form U' T U, where U is unitary and T has evenly spaced entries 1, ..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (10) A matrix of the form U' T U, where U is unitary and T has geometrically spaced entries 1, ..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (11) A matrix of the form U' T U, where U is unitary and T has "clustered" entries 1, ULP,..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (12) A matrix of the form U' T U, where U is unitary and T has complex eigenvalues randomly chosen from ULP < |z| < 1 and random O(1) entries in the upper triangle. (13) A matrix of the form X' T X, where X has condition SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (14) A matrix of the form X' T X, where X has condition SQRT( ULP ) and T has geometrically spaced entries 1, ..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (15) A matrix of the form X' T X, where X has condition SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (16) A matrix of the form X' T X, where X has condition SQRT( ULP ) and T has complex eigenvalues randomly chosen from ULP < |z| < 1 and random O(1) entries in the upper triangle. (17) Same as (16), but multiplied by SQRT( overflow threshold ) (18) Same as (16), but multiplied by SQRT( underflow threshold ) (19) Nonsymmetric matrix with random entries chosen from |z| < 1 (20) Same as (19), but multiplied by SQRT( overflow threshold ) (21) Same as (19), but multiplied by SQRT( underflow threshold ) Arguments ========== NSIZES - INTEGER The number of sizes of matrices to use. If it is zero, ZCHKHS does nothing. It must be at least zero. Not modified. NN - INTEGER array, dimension (NSIZES) An array containing the sizes to be used for the matrices. Zero values will be skipped. The values must be at least zero. Not modified. NTYPES - INTEGER The number of elements in DOTYPE. If it is zero, ZCHKHS does nothing. It must be at least zero. If it is MAXTYP+1 and NSIZES is 1, then an additional type, MAXTYP+1 is defined, which is to use whatever matrix is in A. This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . Not modified. DOTYPE - LOGICAL array, dimension (NTYPES) If DOTYPE(j) is .TRUE., then for each size in NN a matrix of that size and of type j will be generated. If NTYPES is smaller than the maximum number of types defined (PARAMETER MAXTYP), then types NTYPES+1 through MAXTYP will not be generated. If NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) will be ignored. 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 ZCHKHS to continue the same random number sequence. Modified. THRESH - DOUBLE PRECISION A test will count as "failed" if the "error", computed as described above, exceeds THRESH. Note that the error is scaled to be O(1), so THRESH should be a reasonably small multiple of 1, e.g., 10 or 100. In particular, it should not depend on the precision (single vs. double) or the size of the matrix. It must be at least zero. Not modified. NOUNIT - INTEGER The FORTRAN unit number for printing out error messages (e.g., if a routine returns IINFO not equal to 0.) Not modified. A - COMPLEX*16 array, dimension (LDA,max(NN)) Used to hold the matrix whose eigenvalues are to be computed. On exit, A contains the last matrix actually used. Modified. LDA - INTEGER The leading dimension of A, H, T1 and T2. It must be at least 1 and at least max( NN ). Not modified. H - COMPLEX*16 array, dimension (LDA,max(NN)) The upper hessenberg matrix computed by ZGEHRD. On exit, H contains the Hessenberg form of the matrix in A. Modified. T1 - COMPLEX*16 array, dimension (LDA,max(NN)) The Schur (="quasi-triangular") matrix computed by ZHSEQR if Z is computed. On exit, T1 contains the Schur form of the matrix in A. Modified. T2 - COMPLEX*16 array, dimension (LDA,max(NN)) The Schur matrix computed by ZHSEQR when Z is not computed. This should be identical to T1. Modified. LDU - INTEGER The leading dimension of U, Z, UZ and UU. It must be at least 1 and at least max( NN ). Not modified. U - COMPLEX*16 array, dimension (LDU,max(NN)) The unitary matrix computed by ZGEHRD. Modified. Z - COMPLEX*16 array, dimension (LDU,max(NN)) The unitary matrix computed by ZHSEQR. Modified. UZ - COMPLEX*16 array, dimension (LDU,max(NN)) The product of U times Z. Modified. W1 - COMPLEX*16 array, dimension (max(NN)) The eigenvalues of A, as computed by a full Schur decomposition H = Z T Z'. On exit, W1 contains the eigenvalues of the matrix in A. Modified. W3 - COMPLEX*16 array, dimension (max(NN)) The eigenvalues of A, as computed by a partial Schur decomposition (Z not computed, T only computed as much as is necessary for determining eigenvalues). On exit, W3 contains the eigenvalues of the matrix in A, possibly perturbed by ZHSEIN. Modified. EVECTL - COMPLEX*16 array, dimension (LDU,max(NN)) The conjugate transpose of the (upper triangular) left eigenvector matrix for the matrix in T1. Modified. EVEZTR - COMPLEX*16 array, dimension (LDU,max(NN)) The (upper triangular) right eigenvector matrix for the matrix in T1. Modified. EVECTY - COMPLEX*16 array, dimension (LDU,max(NN)) The conjugate transpose of the left eigenvector matrix for the matrix in H. Modified. EVECTX - COMPLEX*16 array, dimension (LDU,max(NN)) The right eigenvector matrix for the matrix in H. Modified. UU - COMPLEX*16 array, dimension (LDU,max(NN)) Details of the unitary matrix computed by ZGEHRD. Modified. TAU - COMPLEX*16 array, dimension (max(NN)) Further details of the unitary matrix computed by ZGEHRD. Modified. WORK - COMPLEX*16 array, dimension (NWORK) Workspace. Modified. NWORK - INTEGER The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. RWORK - DOUBLE PRECISION array, dimension (max(NN)) Workspace. Could be equivalenced to IWORK, but not SELECT. Modified. IWORK - INTEGER array, dimension (max(NN)) Workspace. Modified. SELECT - LOGICAL array, dimension (max(NN)) Workspace. Could be equivalenced to IWORK, but not RWORK. Modified. RESULT - DOUBLE PRECISION array, dimension (14) The values computed by the fourteen tests described above. The values are currently limited to 1/ulp, to avoid overflow. Modified. INFO - INTEGER If 0, then everything ran OK. -1: NSIZES < 0 -2: Some NN(j) < 0 -3: NTYPES < 0 -6: THRESH < 0 -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). -14: LDU < 1 or LDU < NMAX. -26: NWORK too small. If ZLATMR, CLATMS, or CLATME returns an error code, the absolute value of it is returned. If 1, then ZHSEQR could not find all the shifts. If 2, then the EISPACK code (for small blocks) failed. If >2, then 30*N iterations were not enough to find an eigenvalue or to decompose the problem. Modified. ----------------------------------------------------------------------- Some Local Variables and Parameters: ---- ----- --------- --- ---------- ZERO, ONE Real 0 and 1. MAXTYP The number of types defined. MTEST The number of tests defined: care must be taken that (1) the size of RESULT, (2) the number of tests actually performed, and (3) MTEST agree. NTEST The number of tests performed on this matrix so far. This should be less than MTEST, and equal to it by the last test. It will be less if any of the routines being tested indicates that it could not compute the matrices that would be tested. NMAX Largest value in NN. NMATS The number of matrices generated so far. NERRS The number of tests which have exceeded THRESH so far (computed by DLAFTS). COND, CONDS, IMODE Values to be passed to the matrix generators. ANORM Norm of A; passed to matrix generators. OVFL, UNFL Overflow and underflow thresholds. ULP, ULPINV Finest relative precision and its inverse. RTOVFL, RTUNFL, RTULP, RTULPI Square roots of the previous 4 values. The following four arrays decode JTYPE: KTYPE(j) The general type (1-10) for type "j". KMODE(j) The MODE value to be passed to the matrix generator for type "j". KMAGN(j) The order of magnitude ( O(1), O(overflow^(1/2) ), O(underflow^(1/2) ) KCONDS(j) Selects whether CONDS is to be 1 or 1/sqrt(ulp). (0 means irrelevant.) ===================================================================== Parameter adjustments */ --nn; --dotype; --iseed; t2_dim1 = *lda; t2_offset = 1 + t2_dim1 * 1; t2 -= t2_offset; t1_dim1 = *lda; t1_offset = 1 + t1_dim1 * 1; t1 -= t1_offset; h_dim1 = *lda; h_offset = 1 + h_dim1 * 1; h__ -= h_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; uu_dim1 = *ldu; uu_offset = 1 + uu_dim1 * 1; uu -= uu_offset; evectx_dim1 = *ldu; evectx_offset = 1 + evectx_dim1 * 1; evectx -= evectx_offset; evecty_dim1 = *ldu; evecty_offset = 1 + evecty_dim1 * 1; evecty -= evecty_offset; evectr_dim1 = *ldu; evectr_offset = 1 + evectr_dim1 * 1; evectr -= evectr_offset; evectl_dim1 = *ldu; evectl_offset = 1 + evectl_dim1 * 1; evectl -= evectl_offset; uz_dim1 = *ldu; uz_offset = 1 + uz_dim1 * 1; uz -= uz_offset; z_dim1 = *ldu; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; u_dim1 = *ldu; u_offset = 1 + u_dim1 * 1; u -= u_offset; --w1; --w3; --tau; --work; --rwork; --iwork; --select; --result; /* Function Body Check for errors */ ntestt = 0; *info = 0; badnn = FALSE_; nmax = 0; i__1 = *nsizes; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = nmax, i__3 = nn[j]; nmax = max(i__2,i__3); if (nn[j] < 0) { badnn = TRUE_; } /* L10: */ } /* Check for errors */ if (*nsizes < 0) { *info = -1; } else if (badnn) { *info = -2; } else if (*ntypes < 0) { *info = -3; } else if (*thresh < 0.) { *info = -6; } else if (*lda <= 1 || *lda < nmax) { *info = -9; } else if (*ldu <= 1 || *ldu < nmax) { *info = -14; } else if ((nmax << 2) * nmax + 2 > *nwork) { *info = -26; } if (*info != 0) { i__1 = -(*info); xerbla_("ZCHKHS", &i__1); return 0; } /* Quick return if possible */ if (*nsizes == 0 || *ntypes == 0) { return 0; } /* More important constants */ unfl = dlamch_("Safe minimum"); ovfl = dlamch_("Overflow"); dlabad_(&unfl, &ovfl); ulp = dlamch_("Epsilon") * dlamch_("Base"); ulpinv = 1. / ulp; rtunfl = sqrt(unfl); rtovfl = sqrt(ovfl); rtulp = sqrt(ulp); rtulpi = 1. / rtulp; /* Loop over sizes, types */ nerrs = 0; nmats = 0; i__1 = *nsizes; for (jsize = 1; jsize <= i__1; ++jsize) { n = nn[jsize]; n1 = max(1,n); aninv = 1. / (doublereal) n1; if (*nsizes != 1) { mtypes = min(21,*ntypes); } else { mtypes = min(22,*ntypes); } i__2 = mtypes; for (jtype = 1; jtype <= i__2; ++jtype) { if (! dotype[jtype]) { goto L250; } ++nmats; ntest = 0; /* Save ISEED in case of an error. */ for (j = 1; j <= 4; ++j) { ioldsd[j - 1] = iseed[j]; /* L20: */ } /* Initialize RESULT */ for (j = 1; j <= 14; ++j) { result[j] = 0.; /* L30: */ } /* Compute "A" Control parameters: KMAGN KCONDS KMODE KTYPE =1 O(1) 1 clustered 1 zero =2 large large clustered 2 identity =3 small exponential Jordan =4 arithmetic diagonal, (w/ eigenvalues) =5 random log hermitian, w/ eigenvalues =6 random general, w/ eigenvalues =7 random diagonal =8 random hermitian =9 random general =10 random triangular */ if (mtypes > 21) { goto L100; } itype = ktype[jtype - 1]; imode = kmode[jtype - 1]; /* Compute norm */ switch (kmagn[jtype - 1]) { case 1: goto L40; case 2: goto L50; case 3: goto L60; } L40: anorm = 1.; goto L70; L50: anorm = rtovfl * ulp * aninv; goto L70; L60: anorm = rtunfl * n * ulpinv; goto L70; L70: zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda); iinfo = 0; cond = ulpinv; /* Special Matrices */ if (itype == 1) { /* Zero */ iinfo = 0; } else if (itype == 2) { /* Identity */ i__3 = n; for (jcol = 1; jcol <= i__3; ++jcol) { i__4 = a_subscr(jcol, jcol); a[i__4].r = anorm, a[i__4].i = 0.; /* L80: */ } } else if (itype == 3) { /* Jordan Block */ i__3 = n; for (jcol = 1; jcol <= i__3; ++jcol) { i__4 = a_subscr(jcol, jcol); a[i__4].r = anorm, a[i__4].i = 0.; if (jcol > 1) { i__4 = a_subscr(jcol, jcol - 1); a[i__4].r = 1., a[i__4].i = 0.; } /* L90: */ } } else if (itype == 4) { /* Diagonal Matrix, [Eigen]values Specified */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, & c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[ 1], &iinfo); } else if (itype == 5) { /* Hermitian, eigenvalues specified */ zlatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond, &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], & iinfo); } else if (itype == 6) { /* General, eigenvalues specified */ if (kconds[jtype - 1] == 1) { conds = 1.; } else if (kconds[jtype - 1] == 2) { conds = rtulpi; } else { conds = 0.; } zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2, " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n, &anorm, &a[a_offset], lda, &work[n + 1], &iinfo); } else if (itype == 7) { /* Diagonal, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, & c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[ 1], &iinfo); } else if (itype == 8) { /* Hermitian, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, & c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); } else if (itype == 9) { /* General, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, & c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); } else if (itype == 10) { /* Triangular, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, & c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); } else { iinfo = 1; } if (iinfo != 0) { io___35.ciunit = *nounit; s_wsfe(&io___35); do_fio(&c__1, "Generator", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); return 0; } L100: /* Call ZGEHRD to compute H and U, do tests. */ zlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda); ntest = 1; ilo = 1; ihi = n; i__3 = *nwork - n; zgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n + 1], &i__3, &iinfo); if (iinfo != 0) { result[1] = ulpinv; io___38.ciunit = *nounit; s_wsfe(&io___38); do_fio(&c__1, "ZGEHRD", (ftnlen)6); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } i__3 = n - 1; for (j = 1; j <= i__3; ++j) { i__4 = uu_subscr(j + 1, j); uu[i__4].r = 0., uu[i__4].i = 0.; i__4 = n; for (i__ = j + 2; i__ <= i__4; ++i__) { i__5 = u_subscr(i__, j); i__6 = h___subscr(i__, j); u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i; i__5 = uu_subscr(i__, j); i__6 = h___subscr(i__, j); uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i; i__5 = h___subscr(i__, j); h__[i__5].r = 0., h__[i__5].i = 0.; /* L110: */ } /* L120: */ } zcopy_(&n, &work[1], &c__1, &tau[1], &c__1); i__3 = *nwork - n; zunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1], &i__3, &iinfo); ntest = 2; zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, & u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]); /* Call ZHSEQR to compute T1, T2 and Z, do tests. Eigenvalues only (W3) */ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda); ntest = 3; result[3] = ulpinv; zhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], & uz[uz_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0) { io___40.ciunit = *nounit; s_wsfe(&io___40); do_fio(&c__1, "ZHSEQR(E)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); if (iinfo <= n + 2) { *info = abs(iinfo); goto L240; } } /* Eigenvalues (W1) and Full Schur Form (T2) */ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda); zhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], & uz[uz_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0 && iinfo <= n + 2) { io___41.ciunit = *nounit; s_wsfe(&io___41); do_fio(&c__1, "ZHSEQR(S)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } /* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda); zlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu); zhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], & uz[uz_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0 && iinfo <= n + 2) { io___42.ciunit = *nounit; s_wsfe(&io___42); do_fio(&c__1, "ZHSEQR(V)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } /* Compute Z = U' UZ */ zgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[ uz_offset], ldu, &c_b1, &z__[z_offset], ldu); ntest = 8; /* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) and 4: | I - Z Z' | / ( n ulp ) */ zhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda, &z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[ 3]); /* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) and 6: | I - UZ (UZ)' | / ( n ulp ) */ zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, & uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5] ); /* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */ zget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1] , &rwork[1], &result[7]); /* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */ temp1 = 0.; temp2 = 0.; i__3 = n; for (j = 1; j <= i__3; ++j) { /* Computing MAX */ d__1 = temp1, d__2 = z_abs(&w1[j]), d__1 = max(d__1,d__2), d__2 = z_abs(&w3[j]); temp1 = max(d__1,d__2); /* Computing MAX */ i__4 = j; i__5 = j; z__1.r = w1[i__4].r - w3[i__5].r, z__1.i = w1[i__4].i - w3[ i__5].i; d__1 = temp2, d__2 = z_abs(&z__1); temp2 = max(d__1,d__2); /* L130: */ } /* Computing MAX */ d__1 = unfl, d__2 = ulp * max(temp1,temp2); result[8] = temp2 / max(d__1,d__2); /* Compute the Left and Right Eigenvectors of T Compute the Right eigenvector Matrix: */ ntest = 9; result[9] = ulpinv; /* Select every other eigenvector */ i__3 = n; for (j = 1; j <= i__3; ++j) { select[j] = FALSE_; /* L140: */ } i__3 = n; for (j = 1; j <= i__3; j += 2) { select[j] = TRUE_; /* L150: */ } ztrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda, cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[ 1], &rwork[1], &iinfo); if (iinfo != 0) { io___47.ciunit = *nounit; s_wsfe(&io___47); do_fio(&c__1, "ZTREVC(R,A)", (ftnlen)11); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } /* Test 9: | TR - RW | / ( |T| |R| ulp ) */ zget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[ evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma); result[9] = dumma[0]; if (dumma[1] > *thresh) { io___49.ciunit = *nounit; s_wsfe(&io___49); do_fio(&c__1, "Right", (ftnlen)5); do_fio(&c__1, "ZTREVC", (ftnlen)6); do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Compute selected right eigenvectors and confirm that they agree with previous right eigenvectors */ ztrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda, cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[ 1], &rwork[1], &iinfo); if (iinfo != 0) { io___50.ciunit = *nounit; s_wsfe(&io___50); do_fio(&c__1, "ZTREVC(R,S)", (ftnlen)11); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } k = 1; match = TRUE_; i__3 = n; for (j = 1; j <= i__3; ++j) { if (select[j]) { i__4 = n; for (jj = 1; jj <= i__4; ++jj) { i__5 = evectr_subscr(jj, j); i__6 = evectl_subscr(jj, k); if (evectr[i__5].r != evectl[i__6].r || evectr[i__5] .i != evectl[i__6].i) { match = FALSE_; goto L180; } /* L160: */ } ++k; } /* L170: */ } L180: if (! match) { io___54.ciunit = *nounit; s_wsfe(&io___54); do_fio(&c__1, "Right", (ftnlen)5); do_fio(&c__1, "ZTREVC", (ftnlen)6); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Compute the Left eigenvector Matrix: */ ntest = 10; result[10] = ulpinv; ztrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, & evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1] , &rwork[1], &iinfo); if (iinfo != 0) { io___55.ciunit = *nounit; s_wsfe(&io___55); do_fio(&c__1, "ZTREVC(L,A)", (ftnlen)11); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } /* Test 10: | LT - WL | / ( |T| |L| ulp ) */ zget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[ evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[ 2]); result[10] = dumma[2]; if (dumma[3] > *thresh) { io___56.ciunit = *nounit; s_wsfe(&io___56); do_fio(&c__1, "Left", (ftnlen)4); do_fio(&c__1, "ZTREVC", (ftnlen)6); do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Compute selected left eigenvectors and confirm that they agree with previous left eigenvectors */ ztrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, & evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1] , &rwork[1], &iinfo); if (iinfo != 0) { io___57.ciunit = *nounit; s_wsfe(&io___57); do_fio(&c__1, "ZTREVC(L,S)", (ftnlen)11); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } k = 1; match = TRUE_; i__3 = n; for (j = 1; j <= i__3; ++j) { if (select[j]) { i__4 = n; for (jj = 1; jj <= i__4; ++jj) { i__5 = evectl_subscr(jj, j); i__6 = evectr_subscr(jj, k); if (evectl[i__5].r != evectr[i__6].r || evectl[i__5] .i != evectr[i__6].i) { match = FALSE_; goto L210; } /* L190: */ } ++k; } /* L200: */ } L210: if (! match) { io___58.ciunit = *nounit; s_wsfe(&io___58); do_fio(&c__1, "Left", (ftnlen)4); do_fio(&c__1, "ZTREVC", (ftnlen)6); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Call ZHSEIN for Right eigenvectors of H, do test 11 */ ntest = 11; result[11] = ulpinv; i__3 = n; for (j = 1; j <= i__3; ++j) { select[j] = TRUE_; /* L220: */ } zhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset], lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, & n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], & iinfo); if (iinfo != 0) { io___59.ciunit = *nounit; s_wsfe(&io___59); do_fio(&c__1, "ZHSEIN(R)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); if (iinfo < 0) { goto L240; } } else { /* Test 11: | HX - XW | / ( |H| |X| ulp ) (from inverse iteration) */ zget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[ evectx_offset], ldu, &w3[1], &work[1], &rwork[1], dumma); if (dumma[0] < ulpinv) { result[11] = dumma[0] * aninv; } if (dumma[1] > *thresh) { io___60.ciunit = *nounit; s_wsfe(&io___60); do_fio(&c__1, "Right", (ftnlen)5); do_fio(&c__1, "ZHSEIN", (ftnlen)6); do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof( doublereal)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); } } /* Call ZHSEIN for Left eigenvectors of H, do test 12 */ ntest = 12; result[12] = ulpinv; i__3 = n; for (j = 1; j <= i__3; ++j) { select[j] = TRUE_; /* L230: */ } zhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset], lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, & n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], & iinfo); if (iinfo != 0) { io___61.ciunit = *nounit; s_wsfe(&io___61); do_fio(&c__1, "ZHSEIN(L)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); if (iinfo < 0) { goto L240; } } else { /* Test 12: | YH - WY | / ( |H| |Y| ulp ) (from inverse iteration) */ zget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[ evecty_offset], ldu, &w3[1], &work[1], &rwork[1], & dumma[2]); if (dumma[2] < ulpinv) { result[12] = dumma[2] * aninv; } if (dumma[3] > *thresh) { io___62.ciunit = *nounit; s_wsfe(&io___62); do_fio(&c__1, "Left", (ftnlen)4); do_fio(&c__1, "ZHSEIN", (ftnlen)6); do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof( doublereal)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); } } /* Call ZUNMHR for Right eigenvectors of A, do test 13 */ ntest = 13; result[13] = ulpinv; zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset] , ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0) { io___63.ciunit = *nounit; s_wsfe(&io___63); do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); if (iinfo < 0) { goto L240; } } else { /* Test 13: | AX - XW | / ( |A| |X| ulp ) (from inverse iteration) */ zget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[ evectx_offset], ldu, &w3[1], &work[1], &rwork[1], dumma); if (dumma[0] < ulpinv) { result[13] = dumma[0] * aninv; } } /* Call ZUNMHR for Left eigenvectors of A, do test 14 */ ntest = 14; result[14] = ulpinv; zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset] , ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0) { io___64.ciunit = *nounit; s_wsfe(&io___64); do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); if (iinfo < 0) { goto L240; } } else { /* Test 14: | YA - WY | / ( |A| |Y| ulp ) (from inverse iteration) */ zget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[ evecty_offset], ldu, &w3[1], &work[1], &rwork[1], & dumma[2]); if (dumma[2] < ulpinv) { result[14] = dumma[2] * aninv; } } /* End of Loop -- Check for RESULT(j) > THRESH */ L240: ntestt += ntest; dlafts_("ZHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh, nounit, &nerrs); L250: ; } /* L260: */ } /* Summary */ dlasum_("ZHS", nounit, &nerrs, &ntestt); return 0; /* End of ZCHKHS */ } /* zchkhs_ */
/* Subroutine */ int zhsein_(char *side, char *eigsrc, char *initv, logical * select, integer *n, doublecomplex *h__, integer *ldh, doublecomplex * w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork, integer *ifaill, integer *ifailr, 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 ======= ZHSEIN uses inverse iteration to find specified right and/or left eigenvectors of a complex upper Hessenberg matrix H. The right eigenvector x and the left eigenvector y of the matrix H corresponding to an eigenvalue w are defined by: H * x = w * x, y**h * H = w * y**h where y**h denotes the conjugate transpose of the vector y. Arguments ========= SIDE (input) CHARACTER*1 = 'R': compute right eigenvectors only; = 'L': compute left eigenvectors only; = 'B': compute both right and left eigenvectors. EIGSRC (input) CHARACTER*1 Specifies the source of eigenvalues supplied in W: = 'Q': the eigenvalues were found using ZHSEQR; thus, if H has zero subdiagonal elements, and so is block-triangular, then the j-th eigenvalue can be assumed to be an eigenvalue of the block containing the j-th row/column. This property allows ZHSEIN to perform inverse iteration on just one diagonal block. = 'N': no assumptions are made on the correspondence between eigenvalues and diagonal blocks. In this case, ZHSEIN must always perform inverse iteration using the whole matrix H. INITV (input) CHARACTER*1 = 'N': no initial vectors are supplied; = 'U': user-supplied initial vectors are stored in the arrays VL and/or VR. SELECT (input) LOGICAL array, dimension (N) Specifies the eigenvectors to be computed. To select the eigenvector corresponding to the eigenvalue W(j), SELECT(j) must be set to .TRUE.. N (input) INTEGER The order of the matrix H. N >= 0. H (input) COMPLEX*16 array, dimension (LDH,N) The upper Hessenberg matrix H. LDH (input) INTEGER The leading dimension of the array H. LDH >= max(1,N). W (input/output) COMPLEX*16 array, dimension (N) On entry, the eigenvalues of H. On exit, the real parts of W may have been altered since close eigenvalues are perturbed slightly in searching for independent eigenvectors. VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must contain starting vectors for the inverse iteration for the left eigenvectors; the starting vector for each eigenvector must be in the same column in which the eigenvector will be stored. On exit, if SIDE = 'L' or 'B', the left eigenvectors specified by SELECT will be stored consecutively in the columns of VL, in the same order as their eigenvalues. If SIDE = 'R', VL is not referenced. LDVL (input) INTEGER The leading dimension of the array VL. LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must contain starting vectors for the inverse iteration for the right eigenvectors; the starting vector for each eigenvector must be in the same column in which the eigenvector will be stored. On exit, if SIDE = 'R' or 'B', the right eigenvectors specified by SELECT will be stored consecutively in the columns of VR, in the same order as their eigenvalues. If SIDE = 'L', VR is not referenced. LDVR (input) INTEGER The leading dimension of the array VR. LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. MM (input) INTEGER The number of columns in the arrays VL and/or VR. MM >= M. M (output) INTEGER The number of columns in the arrays VL and/or VR required to store the eigenvectors (= the number of .TRUE. elements in SELECT). WORK (workspace) COMPLEX*16 array, dimension (N*N) RWORK (workspace) DOUBLE PRECISION array, dimension (N) IFAILL (output) INTEGER array, dimension (MM) If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left eigenvector in the i-th column of VL (corresponding to the eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the eigenvector converged satisfactorily. If SIDE = 'R', IFAILL is not referenced. IFAILR (output) INTEGER array, dimension (MM) If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right eigenvector in the i-th column of VR (corresponding to the eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the eigenvector converged satisfactorily. If SIDE = 'L', IFAILR is not referenced. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, i is the number of eigenvectors which failed to converge; see IFAILL and IFAILR for further details. Further Details =============== Each eigenvector is normalized so that the element of largest magnitude has magnitude 1; here the magnitude of a complex number (x,y) is taken to be |x|+|y|. ===================================================================== Decode and test the input parameters. Parameter adjustments */ /* Table of constant values */ static logical c_false = FALSE_; static logical c_true = TRUE_; /* System generated locals */ integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3; doublereal d__1, d__2; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static doublereal unfl; static integer i__, k; extern logical lsame_(char *, char *); static integer iinfo; static logical leftv, bothv; static doublereal hnorm; static integer kl; extern doublereal dlamch_(char *); static integer kr, ks; static doublecomplex wk; extern /* Subroutine */ int xerbla_(char *, integer *), zlaein_( logical *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *, integer *); extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, doublereal *); static logical noinit; static integer ldwork; static logical rightv, fromqr; static doublereal smlnum; static integer kln; static doublereal ulp, eps3; #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 vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] --select; h_dim1 = *ldh; h_offset = 1 + h_dim1 * 1; h__ -= h_offset; --w; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; --work; --rwork; --ifaill; --ifailr; /* Function Body */ bothv = lsame_(side, "B"); rightv = lsame_(side, "R") || bothv; leftv = lsame_(side, "L") || bothv; fromqr = lsame_(eigsrc, "Q"); noinit = lsame_(initv, "N"); /* Set M to the number of columns required to store the selected eigenvectors. */ *m = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (select[k]) { ++(*m); } /* L10: */ } *info = 0; if (! rightv && ! leftv) { *info = -1; } else if (! fromqr && ! lsame_(eigsrc, "N")) { *info = -2; } else if (! noinit && ! lsame_(initv, "U")) { *info = -3; } else if (*n < 0) { *info = -5; } else if (*ldh < max(1,*n)) { *info = -7; } else if (*ldvl < 1 || leftv && *ldvl < *n) { *info = -10; } else if (*ldvr < 1 || rightv && *ldvr < *n) { *info = -12; } else if (*mm < *m) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHSEIN", &i__1); return 0; } /* Quick return if possible. */ if (*n == 0) { return 0; } /* Set machine-dependent constants. */ unfl = dlamch_("Safe minimum"); ulp = dlamch_("Precision"); smlnum = unfl * (*n / ulp); ldwork = *n; kl = 1; kln = 0; if (fromqr) { kr = 0; } else { kr = *n; } ks = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (select[k]) { /* Compute eigenvector(s) corresponding to W(K). */ if (fromqr) { /* If affiliation of eigenvalues is known, check whether the matrix splits. Determine KL and KR such that 1 <= KL <= K <= KR <= N and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or KR = N). Then inverse iteration can be performed with the submatrix H(KL:N,KL:N) for a left eigenvector, and with the submatrix H(1:KR,1:KR) for a right eigenvector. */ i__2 = kl + 1; for (i__ = k; i__ >= i__2; --i__) { i__3 = h___subscr(i__, i__ - 1); if (h__[i__3].r == 0. && h__[i__3].i == 0.) { goto L30; } /* L20: */ } L30: kl = i__; if (k > kr) { i__2 = *n - 1; for (i__ = k; i__ <= i__2; ++i__) { i__3 = h___subscr(i__ + 1, i__); if (h__[i__3].r == 0. && h__[i__3].i == 0.) { goto L50; } /* L40: */ } L50: kr = i__; } } if (kl != kln) { kln = kl; /* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it has not ben computed before. */ i__2 = kr - kl + 1; hnorm = zlanhs_("I", &i__2, &h___ref(kl, kl), ldh, &rwork[1]); if (hnorm > 0.) { eps3 = hnorm * ulp; } else { eps3 = smlnum; } } /* Perturb eigenvalue if it is close to any previous selected eigenvalues affiliated to the submatrix H(KL:KR,KL:KR). Close roots are modified by EPS3. */ i__2 = k; wk.r = w[i__2].r, wk.i = w[i__2].i; L60: i__2 = kl; for (i__ = k - 1; i__ >= i__2; --i__) { i__3 = i__; z__2.r = w[i__3].r - wk.r, z__2.i = w[i__3].i - wk.i; z__1.r = z__2.r, z__1.i = z__2.i; if (select[i__] && (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)) < eps3) { z__1.r = wk.r + eps3, z__1.i = wk.i; wk.r = z__1.r, wk.i = z__1.i; goto L60; } /* L70: */ } i__2 = k; w[i__2].r = wk.r, w[i__2].i = wk.i; if (leftv) { /* Compute left eigenvector. */ i__2 = *n - kl + 1; zlaein_(&c_false, &noinit, &i__2, &h___ref(kl, kl), ldh, &wk, &vl_ref(kl, ks), &work[1], &ldwork, &rwork[1], &eps3, &smlnum, &iinfo); if (iinfo > 0) { ++(*info); ifaill[ks] = k; } else { ifaill[ks] = 0; } i__2 = kl - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = vl_subscr(i__, ks); vl[i__3].r = 0., vl[i__3].i = 0.; /* L80: */ } } if (rightv) { /* Compute right eigenvector. */ zlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wk, & vr_ref(1, ks), &work[1], &ldwork, &rwork[1], &eps3, & smlnum, &iinfo); if (iinfo > 0) { ++(*info); ifailr[ks] = k; } else { ifailr[ks] = 0; } i__2 = *n; for (i__ = kr + 1; i__ <= i__2; ++i__) { i__3 = vr_subscr(i__, ks); vr[i__3].r = 0., vr[i__3].i = 0.; /* L90: */ } } ++ks; } /* L100: */ } return 0; /* End of ZHSEIN */ } /* zhsein_ */
/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *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, i__5; doublereal d__1, d__2, d__3, d__4, d__5, d__6; doublecomplex z__1, z__2, z__3, z__4; /* Builtin functions */ double d_imag(doublecomplex *); void z_sqrt(doublecomplex *, doublecomplex *), d_cnjg(doublecomplex *, doublecomplex *); double z_abs(doublecomplex *); /* Local variables */ static doublecomplex temp; static doublereal opst; static integer i__, j, k, l, m; static doublereal s; static doublecomplex t, u, v[2], x, y; extern /* Subroutine */ int zscal_(integer *, doublecomplex *, doublecomplex *, integer *); static doublereal rtemp; static integer i1, i2; static doublereal rwork[1]; static doublecomplex t1; static doublereal t2; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); static doublecomplex v2; static doublereal h10; static doublecomplex h11; static doublereal h21; static doublecomplex h22; static integer nh; extern doublereal dlamch_(char *); static integer nz; extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *); extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, doublereal *); static doublereal smlnum; static doublecomplex h11s; static integer itn, its; static doublereal ulp; static doublecomplex sum; static doublereal 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 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 auxiliary routine (instrumented to count operations) -- 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 ======= ZLAHQR is an auxiliary routine called by ZHSEQR to update the eigenvalues and Schur decomposition already computed by ZHSEQR, by dealing with the Hessenberg submatrix in rows and columns ILO to IHI. Arguments ========= WANTT (input) LOGICAL = .TRUE. : the full Schur form T is required; = .FALSE.: only eigenvalues are required. WANTZ (input) LOGICAL = .TRUE. : the matrix of Schur vectors Z is required; = .FALSE.: Schur vectors are not required. N (input) INTEGER The order of the matrix H. N >= 0. ILO (input) INTEGER IHI (input) INTEGER It is assumed that H is already upper triangular in rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). ZLAHQR works primarily with the Hessenberg submatrix in rows and columns ILO to IHI, but applies transformations to all of H if WANTT is .TRUE.. 1 <= ILO <= max(1,IHI); IHI <= N. H (input/output) COMPLEX*16 array, dimension (LDH,N) On entry, the upper Hessenberg matrix H. On exit, if WANTT is .TRUE., H is upper triangular in rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in standard form. If WANTT is .FALSE., the contents of H are unspecified on exit. LDH (input) INTEGER The leading dimension of the array H. LDH >= max(1,N). W (output) COMPLEX*16 array, dimension (N) The computed eigenvalues ILO to IHI are stored in the corresponding elements of W. If WANTT is .TRUE., the eigenvalues are stored in the same order as on the diagonal of the Schur form returned in H, with W(i) = H(i,i). ILOZ (input) INTEGER IHIZ (input) INTEGER Specify the rows of Z to which transformations must be applied if WANTZ is .TRUE.. 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. Z (input/output) COMPLEX*16 array, dimension (LDZ,N) If WANTZ is .TRUE., on entry Z must contain the current matrix Z of transformations accumulated by ZHSEQR, and on exit Z has been updated; transformations are applied only to the submatrix Z(ILOZ:IHIZ,ILO:IHI). If WANTZ is .FALSE., Z is not referenced. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= max(1,N). INFO (output) INTEGER = 0: successful exit > 0: if INFO = i, ZLAHQR failed to compute all the eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1) iterations; elements i+1:ihi of W contain those eigenvalues which have been successfully computed. ===================================================================== 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; /* Function Body */ *info = 0; /* ** Initialize */ opst = 0.; /* ** 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; } nh = *ihi - *ilo + 1; nz = *ihiz - *iloz + 1; /* Set machine-dependent constants for the stopping criterion. If norm(H) <= sqrt(OVFL), overflow should not occur. */ ulp = dlamch_("Precision"); smlnum = dlamch_("Safe minimum") / ulp; /* I1 and I2 are the indices of the first row and last column of H to which transformations must be applied. If eigenvalues only are being computed, I1 and I2 are set inside the main loop. */ if (*wantt) { i1 = 1; i2 = *n; } /* ITN is the total number of QR iterations allowed. */ itn = nh * 30; /* The main loop begins here. I is the loop index and decreases from IHI to ILO in steps of 1. Each iteration of the loop works with the active submatrix in rows and columns L to I. Eigenvalues I+1 to IHI have already converged. Either L = ILO, or H(L,L-1) is negligible so that the matrix splits. */ i__ = *ihi; L10: if (i__ < *ilo) { goto L130; } /* Perform QR iterations on rows and columns ILO to I until a submatrix of order 1 splits off at the bottom because a subdiagonal element has become negligible. */ l = *ilo; i__1 = itn; for (its = 0; its <= i__1; ++its) { /* Look for a single small subdiagonal element. */ i__2 = l + 1; for (k = i__; k >= i__2; --k) { i__3 = h___subscr(k - 1, k - 1); i__4 = h___subscr(k, k); tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h___ref( k - 1, k - 1)), abs(d__2)) + ((d__3 = h__[i__4].r, abs( d__3)) + (d__4 = d_imag(&h___ref(k, k)), abs(d__4))); if (tst1 == 0.) { i__3 = i__ - l + 1; tst1 = zlanhs_("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 */ d__2 = ulp * tst1; if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) { goto L30; } /* L20: */ } L30: 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., h__[i__2].i = 0.; } /* Exit from loop if a submatrix of order 1 has split off. */ if (l >= i__) { goto L120; } /* Now the active submatrix is in rows and columns L to I. If eigenvalues only are being computed, only the active submatrix need be transformed. */ if (! (*wantt)) { i1 = l; i2 = i__; } if (its == 10 || its == 20) { /* Exceptional shift. */ i__2 = h___subscr(i__, i__ - 1); s = (d__1 = h__[i__2].r, abs(d__1)) * .75; i__2 = h___subscr(i__, i__); z__1.r = s + h__[i__2].r, z__1.i = h__[i__2].i; t.r = z__1.r, t.i = z__1.i; /* ** Increment op count */ opst += 1; /* ** */ } else { /* Wilkinson's shift. */ i__2 = h___subscr(i__, i__); t.r = h__[i__2].r, t.i = h__[i__2].i; i__2 = h___subscr(i__ - 1, i__); i__3 = h___subscr(i__, i__ - 1); d__1 = h__[i__3].r; z__1.r = d__1 * h__[i__2].r, z__1.i = d__1 * h__[i__2].i; u.r = z__1.r, u.i = z__1.i; /* ** Increment op count */ opst += 2; /* ** */ if (u.r != 0. || u.i != 0.) { i__2 = h___subscr(i__ - 1, i__ - 1); z__2.r = h__[i__2].r - t.r, z__2.i = h__[i__2].i - t.i; z__1.r = z__2.r * .5, z__1.i = z__2.i * .5; x.r = z__1.r, x.i = z__1.i; z__3.r = x.r * x.r - x.i * x.i, z__3.i = x.r * x.i + x.i * x.r; z__2.r = z__3.r + u.r, z__2.i = z__3.i + u.i; z_sqrt(&z__1, &z__2); y.r = z__1.r, y.i = z__1.i; if (x.r * y.r + d_imag(&x) * d_imag(&y) < 0.) { z__1.r = -y.r, z__1.i = -y.i; y.r = z__1.r, y.i = z__1.i; } z__3.r = x.r + y.r, z__3.i = x.i + y.i; zladiv_(&z__2, &u, &z__3); z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i; t.r = z__1.r, t.i = z__1.i; /* ** Increment op count */ opst += 20; /* ** */ } } /* Look for two consecutive small subdiagonal elements. */ i__2 = l + 1; for (m = i__ - 1; m >= i__2; --m) { /* Determine the effect of starting the single-shift QR iteration at row M, and see if this would make H(M,M-1) negligible. */ i__3 = h___subscr(m, m); h11.r = h__[i__3].r, h11.i = h__[i__3].i; i__3 = h___subscr(m + 1, m + 1); h22.r = h__[i__3].r, h22.i = h__[i__3].i; z__1.r = h11.r - t.r, z__1.i = h11.i - t.i; h11s.r = z__1.r, h11s.i = z__1.i; i__3 = h___subscr(m + 1, m); h21 = h__[i__3].r; s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) + abs(h21); z__1.r = h11s.r / s, z__1.i = h11s.i / s; h11s.r = z__1.r, h11s.i = z__1.i; h21 /= s; v[0].r = h11s.r, v[0].i = h11s.i; v[1].r = h21, v[1].i = 0.; i__3 = h___subscr(m, m - 1); h10 = h__[i__3].r; tst1 = ((d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs( d__2))) * ((d__3 = h11.r, abs(d__3)) + (d__4 = d_imag(& h11), abs(d__4)) + ((d__5 = h22.r, abs(d__5)) + (d__6 = d_imag(&h22), abs(d__6)))); if ((d__1 = h10 * h21, abs(d__1)) <= ulp * tst1) { goto L50; } /* L40: */ } i__2 = h___subscr(l, l); h11.r = h__[i__2].r, h11.i = h__[i__2].i; i__2 = h___subscr(l + 1, l + 1); h22.r = h__[i__2].r, h22.i = h__[i__2].i; z__1.r = h11.r - t.r, z__1.i = h11.i - t.i; h11s.r = z__1.r, h11s.i = z__1.i; i__2 = h___subscr(l + 1, l); h21 = h__[i__2].r; s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) + abs(h21); z__1.r = h11s.r / s, z__1.i = h11s.i / s; h11s.r = z__1.r, h11s.i = z__1.i; h21 /= s; v[0].r = h11s.r, v[0].i = h11s.i; v[1].r = h21, v[1].i = 0.; L50: /* ** Increment op count */ opst += (i__ - m) * 14; /* ** Single-shift QR step */ i__2 = i__ - 1; for (k = m; 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. V(2) is always real before the call to ZLARFG, and hence after the call T2 ( = T1*V(2) ) is also real. */ if (k > m) { zcopy_(&c__2, &h___ref(k, k - 1), &c__1, v, &c__1); } zlarfg_(&c__2, v, &v[1], &c__1, &t1); /* ** Increment op count */ opst += 38; /* ** */ if (k > m) { i__3 = h___subscr(k, k - 1); h__[i__3].r = v[0].r, h__[i__3].i = v[0].i; i__3 = h___subscr(k + 1, k - 1); h__[i__3].r = 0., h__[i__3].i = 0.; } v2.r = v[1].r, v2.i = v[1].i; z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i * v2.r; t2 = z__1.r; /* Apply G from the left to transform the rows of the matrix in columns K to I2. */ i__3 = i2; for (j = k; j <= i__3; ++j) { d_cnjg(&z__3, &t1); i__4 = h___subscr(k, j); z__2.r = z__3.r * h__[i__4].r - z__3.i * h__[i__4].i, z__2.i = z__3.r * h__[i__4].i + z__3.i * h__[i__4].r; i__5 = h___subscr(k + 1, j); z__4.r = t2 * h__[i__5].r, z__4.i = t2 * h__[i__5].i; z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; sum.r = z__1.r, sum.i = z__1.i; i__4 = h___subscr(k, j); i__5 = h___subscr(k, j); z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i; h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; i__4 = h___subscr(k + 1, j); i__5 = h___subscr(k + 1, j); z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i + sum.i * v2.r; z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i; h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; /* L60: */ } /* Apply G from the right to transform the columns of the matrix in rows I1 to min(K+2,I). Computing MIN */ i__4 = k + 2; i__3 = min(i__4,i__); for (j = i1; j <= i__3; ++j) { i__4 = h___subscr(j, k); z__2.r = t1.r * h__[i__4].r - t1.i * h__[i__4].i, z__2.i = t1.r * h__[i__4].i + t1.i * h__[i__4].r; i__5 = h___subscr(j, k + 1); z__3.r = t2 * h__[i__5].r, z__3.i = t2 * h__[i__5].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; sum.r = z__1.r, sum.i = z__1.i; i__4 = h___subscr(j, k); i__5 = h___subscr(j, k); z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i; h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; i__4 = h___subscr(j, k + 1); i__5 = h___subscr(j, k + 1); d_cnjg(&z__3, &v2); z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r * z__3.i + sum.i * z__3.r; z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i; h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; /* L70: */ } /* ** Increment op count Computing MIN */ i__3 = 2, i__4 = i__ - k; latime_1.ops += (i2 - i1 + 2 + min(i__3,i__4)) * 20; /* ** */ if (*wantz) { /* Accumulate transformations in the matrix Z */ i__3 = *ihiz; for (j = *iloz; j <= i__3; ++j) { i__4 = z___subscr(j, k); z__2.r = t1.r * z__[i__4].r - t1.i * z__[i__4].i, z__2.i = t1.r * z__[i__4].i + t1.i * z__[i__4].r; i__5 = z___subscr(j, k + 1); z__3.r = t2 * z__[i__5].r, z__3.i = t2 * z__[i__5].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; sum.r = z__1.r, sum.i = z__1.i; i__4 = z___subscr(j, k); i__5 = z___subscr(j, k); z__1.r = z__[i__5].r - sum.r, z__1.i = z__[i__5].i - sum.i; z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; i__4 = z___subscr(j, k + 1); i__5 = z___subscr(j, k + 1); d_cnjg(&z__3, &v2); z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r * z__3.i + sum.i * z__3.r; z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i - z__2.i; z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; /* L80: */ } /* ** Increment op count */ latime_1.ops += nz * 20; /* ** */ } 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. */ z__1.r = 1. - t1.r, z__1.i = 0. - t1.i; temp.r = z__1.r, temp.i = z__1.i; d__1 = z_abs(&temp); z__1.r = temp.r / d__1, z__1.i = temp.i / d__1; temp.r = z__1.r, temp.i = z__1.i; i__3 = h___subscr(m + 1, m); i__4 = h___subscr(m + 1, m); d_cnjg(&z__2, &temp); z__1.r = h__[i__4].r * z__2.r - h__[i__4].i * z__2.i, z__1.i = h__[i__4].r * z__2.i + h__[i__4].i * z__2.r; h__[i__3].r = z__1.r, h__[i__3].i = z__1.i; if (m + 2 <= i__) { i__3 = h___subscr(m + 2, m + 1); i__4 = h___subscr(m + 2, m + 1); z__1.r = h__[i__4].r * temp.r - h__[i__4].i * temp.i, z__1.i = h__[i__4].r * temp.i + h__[i__4].i * temp.r; h__[i__3].r = z__1.r, h__[i__3].i = z__1.i; } i__3 = i__; for (j = m; j <= i__3; ++j) { if (j != m + 1) { if (i2 > j) { i__4 = i2 - j; zscal_(&i__4, &temp, &h___ref(j, j + 1), ldh); } i__4 = j - i1; d_cnjg(&z__1, &temp); zscal_(&i__4, &z__1, &h___ref(i1, j), &c__1); /* ** Increment op count */ opst += (i2 - i1 + 3) * 6; /* ** */ if (*wantz) { d_cnjg(&z__1, &temp); zscal_(&nz, &z__1, &z___ref(*iloz, j), &c__1); /* ** Increment op count */ opst += nz * 6; /* ** */ } } /* L90: */ } } /* L100: */ } /* 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 (d_imag(&temp) != 0.) { rtemp = z_abs(&temp); i__2 = h___subscr(i__, i__ - 1); h__[i__2].r = rtemp, h__[i__2].i = 0.; z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp; temp.r = z__1.r, temp.i = z__1.i; if (i2 > i__) { i__2 = i2 - i__; d_cnjg(&z__1, &temp); zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh); } i__2 = i__ - i1; zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1); /* ** Increment op count */ opst += (i2 - i1 + 1) * 6; /* ** */ if (*wantz) { zscal_(&nz, &temp, &z___ref(*iloz, i__), &c__1); /* ** Increment op count */ opst += nz * 6; /* ** */ } } /* L110: */ } /* Failure to converge in remaining number of iterations */ *info = i__; return 0; L120: /* H(I,I-1) is negligible: one eigenvalue has converged. */ i__1 = i__; i__2 = h___subscr(i__, i__); w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i; /* Decrement number of remaining iterations, and return to start of the main loop with new value of I. */ itn -= its; i__ = l - 1; goto L10; L130: /* ** Compute final op count */ latime_1.ops += opst; /* ** */ return 0; /* End of ZLAHQR */ } /* zlahqr_ */