/* Subroutine */ int cgeevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, complex *a, integer *lda, complex *w, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi, real *scale, real *abnrm, real *rconde, real *rcondv, complex *work, integer *lwork, real *rwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3; real r__1, r__2; complex q__1, q__2; /* Local variables */ integer i__, k; char job[1]; real scl, dum[1], eps; complex tmp; char side[1]; real anrm; integer ierr, itau, iwrk, nout; integer icond; logical scalea; real cscale; logical select[1]; real bignum; integer minwrk, maxwrk; logical wantvl, wntsnb; integer hswork; logical wntsne; real smlnum; logical lquery, wantvr, wntsnn, wntsnv; /* -- LAPACK driver routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the */ /* eigenvalues and, optionally, the left and/or right eigenvectors. */ /* Optionally also, it computes a balancing transformation to improve */ /* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */ /* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */ /* (RCONDE), and reciprocal condition numbers for the right */ /* eigenvectors (RCONDV). */ /* The right eigenvector v(j) of A satisfies */ /* A * v(j) = lambda(j) * v(j) */ /* where lambda(j) is its eigenvalue. */ /* The left eigenvector u(j) of A satisfies */ /* u(j)**H * A = lambda(j) * u(j)**H */ /* where u(j)**H denotes the conjugate transpose of u(j). */ /* The computed eigenvectors are normalized to have Euclidean norm */ /* equal to 1 and largest component real. */ /* Balancing a matrix means permuting the rows and columns to make it */ /* more nearly upper triangular, and applying a diagonal similarity */ /* transformation D * A * D**(-1), where D is a diagonal matrix, to */ /* make its rows and columns closer in norm and the condition numbers */ /* of its eigenvalues and eigenvectors smaller. The computed */ /* reciprocal condition numbers correspond to the balanced matrix. */ /* Permuting rows and columns will not change the condition numbers */ /* (in exact arithmetic) but diagonal scaling will. For further */ /* explanation of balancing, see section 4.10.2 of the LAPACK */ /* Users' Guide. */ /* Arguments */ /* ========= */ /* BALANC (input) CHARACTER*1 */ /* Indicates how the input matrix should be diagonally scaled */ /* and/or permuted to improve the conditioning of its */ /* eigenvalues. */ /* = 'N': Do not diagonally scale or permute; */ /* = 'P': Perform permutations to make the matrix more nearly */ /* upper triangular. Do not diagonally scale; */ /* = 'S': Diagonally scale the matrix, ie. replace A by */ /* D*A*D**(-1), where D is a diagonal matrix chosen */ /* to make the rows and columns of A more equal in */ /* norm. Do not permute; */ /* = 'B': Both diagonally scale and permute A. */ /* Computed reciprocal condition numbers will be for the matrix */ /* after balancing and/or permuting. Permuting does not change */ /* condition numbers (in exact arithmetic), but balancing does. */ /* JOBVL (input) CHARACTER*1 */ /* = 'N': left eigenvectors of A are not computed; */ /* = 'V': left eigenvectors of A are computed. */ /* If SENSE = 'E' or 'B', JOBVL must = 'V'. */ /* JOBVR (input) CHARACTER*1 */ /* = 'N': right eigenvectors of A are not computed; */ /* = 'V': right eigenvectors of A are computed. */ /* If SENSE = 'E' or 'B', JOBVR must = 'V'. */ /* SENSE (input) CHARACTER*1 */ /* Determines which reciprocal condition numbers are computed. */ /* = 'N': None are computed; */ /* = 'E': Computed for eigenvalues only; */ /* = 'V': Computed for right eigenvectors only; */ /* = 'B': Computed for eigenvalues and right eigenvectors. */ /* If SENSE = 'E' or 'B', both left and right eigenvectors */ /* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the N-by-N matrix A. */ /* On exit, A has been overwritten. If JOBVL = 'V' or */ /* JOBVR = 'V', A contains the Schur form of the balanced */ /* version of the matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* W (output) COMPLEX array, dimension (N) */ /* W contains the computed eigenvalues. */ /* VL (output) COMPLEX array, dimension (LDVL,N) */ /* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ /* after another in the columns of VL, in the same order */ /* as their eigenvalues. */ /* If JOBVL = 'N', VL is not referenced. */ /* u(j) = VL(:,j), the j-th column of VL. */ /* LDVL (input) INTEGER */ /* The leading dimension of the array VL. LDVL >= 1; if */ /* JOBVL = 'V', LDVL >= N. */ /* VR (output) COMPLEX array, dimension (LDVR,N) */ /* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ /* after another in the columns of VR, in the same order */ /* as their eigenvalues. */ /* If JOBVR = 'N', VR is not referenced. */ /* v(j) = VR(:,j), the j-th column of VR. */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. LDVR >= 1; if */ /* JOBVR = 'V', LDVR >= N. */ /* ILO (output) INTEGER */ /* IHI (output) INTEGER */ /* ILO and IHI are integer values determined when A was */ /* balanced. The balanced A(i,j) = 0 if I > J and */ /* SCALE (output) REAL array, dimension (N) */ /* Details of the permutations and scaling factors applied */ /* when balancing A. If P(j) is the index of the row and column */ /* interchanged with row and column j, and D(j) is the scaling */ /* factor applied to row and column j, then */ /* The order in which the interchanges are made is N to IHI+1, */ /* then 1 to ILO-1. */ /* ABNRM (output) REAL */ /* The one-norm of the balanced matrix (the maximum */ /* of the sum of absolute values of elements of any column). */ /* RCONDE (output) REAL array, dimension (N) */ /* RCONDE(j) is the reciprocal condition number of the j-th */ /* eigenvalue. */ /* RCONDV (output) REAL array, dimension (N) */ /* RCONDV(j) is the reciprocal condition number of the j-th */ /* right eigenvector. */ /* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. If SENSE = 'N' or 'E', */ /* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B', */ /* LWORK >= N*N+2*N. */ /* For good performance, LWORK must generally be larger. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* RWORK (workspace) REAL array, dimension (2*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: if INFO = i, the QR algorithm failed to compute all the */ /* eigenvalues, and no eigenvectors or condition numbers */ /* have been computed; elements 1:ILO-1 and i+1:N of W */ /* contain eigenvalues which have converged. */ /* ===================================================================== */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --w; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; --scale; --rconde; --rcondv; --work; --rwork; /* Function Body */ *info = 0; lquery = *lwork == -1; wantvl = lsame_(jobvl, "V"); wantvr = lsame_(jobvr, "V"); wntsnn = lsame_(sense, "N"); wntsne = lsame_(sense, "E"); wntsnv = lsame_(sense, "V"); wntsnb = lsame_(sense, "B"); if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") || lsame_(balanc, "B"))) { *info = -1; } else if (! wantvl && ! lsame_(jobvl, "N")) { *info = -2; } else if (! wantvr && ! lsame_(jobvr, "N")) { *info = -3; } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb) && ! (wantvl && wantvr)) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*n)) { *info = -7; } else if (*ldvl < 1 || wantvl && *ldvl < *n) { *info = -10; } else if (*ldvr < 1 || wantvr && *ldvr < *n) { *info = -12; } /* Compute workspace */ /* (Note: Comments in the code beginning "Workspace:" describe the */ /* minimal amount of workspace needed at that point in the code, */ /* as well as the preferred amount for good performance. */ /* CWorkspace refers to complex workspace, and RWorkspace to real */ /* workspace. NB refers to the optimal block size for the */ /* immediately following subroutine, as returned by ILAENV. */ /* HSWORK refers to the workspace preferred by CHSEQR, as */ /* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ /* the worst case.) */ if (*info == 0) { if (*n == 0) { minwrk = 1; maxwrk = 1; } else { maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, & c__0); if (wantvl) { chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[1], &c_n1, info); } else if (wantvr) { chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[1], &c_n1, info); } else { if (wntsnn) { chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], & vr[vr_offset], ldvr, &work[1], &c_n1, info); } else { chseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], & vr[vr_offset], ldvr, &work[1], &c_n1, info); } } hswork = work[1].r; if (! wantvl && ! wantvr) { minwrk = *n << 1; if (! (wntsnn || wntsne)) { /* Computing MAX */ i__1 = minwrk, i__2 = *n * *n + (*n << 1); minwrk = max(i__1,i__2); } maxwrk = max(maxwrk,hswork); if (! (wntsnn || wntsne)) { /* Computing MAX */ i__1 = maxwrk, i__2 = *n * *n + (*n << 1); maxwrk = max(i__1,i__2); } } else { minwrk = *n << 1; if (! (wntsnn || wntsne)) { /* Computing MAX */ i__1 = minwrk, i__2 = *n * *n + (*n << 1); minwrk = max(i__1,i__2); } maxwrk = max(maxwrk,hswork); /* Computing MAX */ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR", " ", n, &c__1, n, &c_n1); maxwrk = max(i__1,i__2); if (! (wntsnn || wntsne)) { /* Computing MAX */ i__1 = maxwrk, i__2 = *n * *n + (*n << 1); maxwrk = max(i__1,i__2); } /* Computing MAX */ i__1 = maxwrk, i__2 = *n << 1; maxwrk = max(i__1,i__2); } maxwrk = max(maxwrk,minwrk); } work[1].r = (real) maxwrk, work[1].i = 0.f; if (*lwork < minwrk && ! lquery) { *info = -20; } } if (*info != 0) { i__1 = -(*info); xerbla_("CGEEVX", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Get machine constants */ eps = slamch_("P"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = sqrt(smlnum) / eps; bignum = 1.f / smlnum; /* Scale A if max element outside range [SMLNUM,BIGNUM] */ icond = 0; anrm = clange_("M", n, n, &a[a_offset], lda, dum); scalea = FALSE_; if (anrm > 0.f && anrm < smlnum) { scalea = TRUE_; cscale = smlnum; } else if (anrm > bignum) { scalea = TRUE_; cscale = bignum; } if (scalea) { clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & ierr); } /* Balance the matrix and compute ABNRM */ cgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr); *abnrm = clange_("1", n, n, &a[a_offset], lda, dum); if (scalea) { dum[0] = *abnrm; slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, & ierr); *abnrm = dum[0]; } /* Reduce to upper Hessenberg form */ /* (CWorkspace: need 2*N, prefer N+N*NB) */ /* (RWorkspace: none) */ itau = 1; iwrk = itau + *n; i__1 = *lwork - iwrk + 1; cgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, & ierr); if (wantvl) { /* Want left eigenvectors */ /* Copy Householder vectors to VL */ *(unsigned char *)side = 'L'; clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) ; /* Generate unitary matrix in VL */ /* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwrk + 1; cunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], & i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VL */ /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[iwrk], &i__1, info); if (wantvr) { /* Want left and right eigenvectors */ /* Copy Schur vectors to VR */ *(unsigned char *)side = 'B'; clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); } } else if (wantvr) { /* Want right eigenvectors */ /* Copy Householder vectors to VR */ *(unsigned char *)side = 'R'; clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) ; /* Generate unitary matrix in VR */ /* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwrk + 1; cunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], & i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VR */ /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info); } else { /* Compute eigenvalues only */ /* If condition numbers desired, compute Schur form */ if (wntsnn) { *(unsigned char *)job = 'E'; } else { *(unsigned char *)job = 'S'; } /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; chseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info); } /* If INFO > 0 from CHSEQR, then quit */ if (*info > 0) { goto L50; } if (wantvl || wantvr) { /* Compute left and/or right eigenvectors */ /* (CWorkspace: need 2*N) */ /* (RWorkspace: need N) */ ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[1], & ierr); } /* Compute condition numbers if desired */ /* (CWorkspace: need N*N+2*N unless SENSE = 'E') */ /* (RWorkspace: need 2*N unless SENSE = 'E') */ if (! wntsnn) { ctrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout, &work[iwrk], n, &rwork[1], &icond); } if (wantvl) { /* Undo balancing of left eigenvectors */ cgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl, &ierr); /* Normalize left eigenvectors and make largest component real */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + i__ * vl_dim1; /* Computing 2nd power */ r__1 = vl[i__3].r; /* Computing 2nd power */ r__2 = r_imag(&vl[k + i__ * vl_dim1]); rwork[k] = r__1 * r__1 + r__2 * r__2; } k = isamax_(n, &rwork[1], &c__1); r_cnjg(&q__2, &vl[k + i__ * vl_dim1]); r__1 = sqrt(rwork[k]); q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1; tmp.r = q__1.r, tmp.i = q__1.i; cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1); i__2 = k + i__ * vl_dim1; i__3 = k + i__ * vl_dim1; r__1 = vl[i__3].r; q__1.r = r__1, q__1.i = 0.f; vl[i__2].r = q__1.r, vl[i__2].i = q__1.i; } } if (wantvr) { /* Undo balancing of right eigenvectors */ cgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr, &ierr); /* Normalize right eigenvectors and make largest component real */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + i__ * vr_dim1; /* Computing 2nd power */ r__1 = vr[i__3].r; /* Computing 2nd power */ r__2 = r_imag(&vr[k + i__ * vr_dim1]); rwork[k] = r__1 * r__1 + r__2 * r__2; } k = isamax_(n, &rwork[1], &c__1); r_cnjg(&q__2, &vr[k + i__ * vr_dim1]); r__1 = sqrt(rwork[k]); q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1; tmp.r = q__1.r, tmp.i = q__1.i; cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1); i__2 = k + i__ * vr_dim1; i__3 = k + i__ * vr_dim1; r__1 = vr[i__3].r; q__1.r = r__1, q__1.i = 0.f; vr[i__2].r = q__1.r, vr[i__2].i = q__1.i; } } /* Undo scaling if necessary */ L50: if (scalea) { i__1 = *n - *info; /* Computing MAX */ i__3 = *n - *info; i__2 = max(i__3,1); clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1] , &i__2, &ierr); if (*info == 0) { if ((wntsnv || wntsnb) && icond == 0) { slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[ 1], n, &ierr); } } else { i__1 = *ilo - 1; clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n, &ierr); } } work[1].r = (real) maxwrk, work[1].i = 0.f; return 0; /* End of CGEEVX */ } /* cgeevx_ */
int cgeev_(char *jobvl, char *jobvr, int *n, complex *a, int *lda, complex *w, complex *vl, int *ldvl, complex *vr, int *ldvr, complex *work, int *lwork, float *rwork, int * info) { /* System generated locals */ int a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3; float r__1, r__2; complex q__1, q__2; /* Builtin functions */ double sqrt(double), r_imag(complex *); void r_cnjg(complex *, complex *); /* Local variables */ int i__, k, ihi; float scl; int ilo; float dum[1], eps; complex tmp; int ibal; char side[1]; float anrm; int ierr, itau, iwrk, nout; extern int cscal_(int *, complex *, complex *, int *); extern int lsame_(char *, char *); extern double scnrm2_(int *, complex *, int *); extern int cgebak_(char *, char *, int *, int *, int *, float *, int *, complex *, int *, int *), cgebal_(char *, int *, complex *, int *, int *, int *, float *, int *), slabad_(float *, float *); int scalea; extern double clange_(char *, int *, int *, complex *, int *, float *); float cscale; extern int cgehrd_(int *, int *, int *, complex *, int *, complex *, complex *, int *, int *), clascl_(char *, int *, int *, float *, float *, int *, int *, complex *, int *, int *); extern double slamch_(char *); extern int csscal_(int *, float *, complex *, int *), clacpy_(char *, int *, int *, complex *, int *, complex *, int *), xerbla_(char *, int *); extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); int select[1]; float bignum; extern int isamax_(int *, float *, int *); extern int chseqr_(char *, char *, int *, int *, int *, complex *, int *, complex *, complex *, int *, complex *, int *, int *), ctrevc_(char *, char *, int *, int *, complex *, int *, complex *, int *, complex *, int *, int *, int *, complex *, float *, int *), cunghr_(int *, int *, int *, complex *, int *, complex *, complex *, int *, int *); int minwrk, maxwrk; int wantvl; float smlnum; int hswork, irwork; int lquery, wantvr; /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the */ /* eigenvalues and, optionally, the left and/or right eigenvectors. */ /* The right eigenvector v(j) of A satisfies */ /* A * v(j) = lambda(j) * v(j) */ /* where lambda(j) is its eigenvalue. */ /* The left eigenvector u(j) of A satisfies */ /* u(j)**H * A = lambda(j) * u(j)**H */ /* where u(j)**H denotes the conjugate transpose of u(j). */ /* The computed eigenvectors are normalized to have Euclidean norm */ /* equal to 1 and largest component float. */ /* Arguments */ /* ========= */ /* JOBVL (input) CHARACTER*1 */ /* = 'N': left eigenvectors of A are not computed; */ /* = 'V': left eigenvectors of are computed. */ /* JOBVR (input) CHARACTER*1 */ /* = 'N': right eigenvectors of A are not computed; */ /* = 'V': right eigenvectors of A are computed. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the N-by-N matrix A. */ /* On exit, A has been overwritten. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= MAX(1,N). */ /* W (output) COMPLEX array, dimension (N) */ /* W contains the computed eigenvalues. */ /* VL (output) COMPLEX array, dimension (LDVL,N) */ /* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ /* after another in the columns of VL, in the same order */ /* as their eigenvalues. */ /* If JOBVL = 'N', VL is not referenced. */ /* u(j) = VL(:,j), the j-th column of VL. */ /* LDVL (input) INTEGER */ /* The leading dimension of the array VL. LDVL >= 1; if */ /* JOBVL = 'V', LDVL >= N. */ /* VR (output) COMPLEX array, dimension (LDVR,N) */ /* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ /* after another in the columns of VR, in the same order */ /* as their eigenvalues. */ /* If JOBVR = 'N', VR is not referenced. */ /* v(j) = VR(:,j), the j-th column of VR. */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. LDVR >= 1; if */ /* JOBVR = 'V', LDVR >= N. */ /* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= MAX(1,2*N). */ /* For good performance, LWORK must generally be larger. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* RWORK (workspace) REAL array, dimension (2*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: if INFO = i, the QR algorithm failed to compute all the */ /* eigenvalues, and no eigenvectors have been computed; */ /* elements and i+1:N of W contain eigenvalues which have */ /* converged. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --w; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; --work; --rwork; /* Function Body */ *info = 0; lquery = *lwork == -1; wantvl = lsame_(jobvl, "V"); wantvr = lsame_(jobvr, "V"); if (! wantvl && ! lsame_(jobvl, "N")) { *info = -1; } else if (! wantvr && ! lsame_(jobvr, "N")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < MAX(1,*n)) { *info = -5; } else if (*ldvl < 1 || wantvl && *ldvl < *n) { *info = -8; } else if (*ldvr < 1 || wantvr && *ldvr < *n) { *info = -10; } /* Compute workspace */ /* (Note: Comments in the code beginning "Workspace:" describe the */ /* minimal amount of workspace needed at that point in the code, */ /* as well as the preferred amount for good performance. */ /* CWorkspace refers to complex workspace, and RWorkspace to float */ /* workspace. NB refers to the optimal block size for the */ /* immediately following subroutine, as returned by ILAENV. */ /* HSWORK refers to the workspace preferred by CHSEQR, as */ /* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ /* the worst case.) */ if (*info == 0) { if (*n == 0) { minwrk = 1; maxwrk = 1; } else { maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, & c__0); minwrk = *n << 1; if (wantvl) { /* Computing MAX */ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR", " ", n, &c__1, n, &c_n1); maxwrk = MAX(i__1,i__2); chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[1], &c_n1, info); } else if (wantvr) { /* Computing MAX */ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR", " ", n, &c__1, n, &c_n1); maxwrk = MAX(i__1,i__2); chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[1], &c_n1, info); } else { chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[1], &c_n1, info); } hswork = work[1].r; /* Computing MAX */ i__1 = MAX(maxwrk,hswork); maxwrk = MAX(i__1,minwrk); } work[1].r = (float) maxwrk, work[1].i = 0.f; if (*lwork < minwrk && ! lquery) { *info = -12; } } if (*info != 0) { i__1 = -(*info); xerbla_("CGEEV ", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Get machine constants */ eps = slamch_("P"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = sqrt(smlnum) / eps; bignum = 1.f / smlnum; /* Scale A if max element outside range [SMLNUM,BIGNUM] */ anrm = clange_("M", n, n, &a[a_offset], lda, dum); scalea = FALSE; if (anrm > 0.f && anrm < smlnum) { scalea = TRUE; cscale = smlnum; } else if (anrm > bignum) { scalea = TRUE; cscale = bignum; } if (scalea) { clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & ierr); } /* Balance the matrix */ /* (CWorkspace: none) */ /* (RWorkspace: need N) */ ibal = 1; cgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr); /* Reduce to upper Hessenberg form */ /* (CWorkspace: need 2*N, prefer N+N*NB) */ /* (RWorkspace: none) */ itau = 1; iwrk = itau + *n; i__1 = *lwork - iwrk + 1; cgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &ierr); if (wantvl) { /* Want left eigenvectors */ /* Copy Householder vectors to VL */ *(unsigned char *)side = 'L'; clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) ; /* Generate unitary matrix in VL */ /* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwrk + 1; cunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VL */ /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[iwrk], &i__1, info); if (wantvr) { /* Want left and right eigenvectors */ /* Copy Schur vectors to VR */ *(unsigned char *)side = 'B'; clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); } } else if (wantvr) { /* Want right eigenvectors */ /* Copy Householder vectors to VR */ *(unsigned char *)side = 'R'; clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) ; /* Generate unitary matrix in VR */ /* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwrk + 1; cunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VR */ /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info); } else { /* Compute eigenvalues only */ /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; chseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info); } /* If INFO > 0 from CHSEQR, then quit */ if (*info > 0) { goto L50; } if (wantvl || wantvr) { /* Compute left and/or right eigenvectors */ /* (CWorkspace: need 2*N) */ /* (RWorkspace: need 2*N) */ irwork = ibal + *n; ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork], &ierr); } if (wantvl) { /* Undo balancing of left eigenvectors */ /* (CWorkspace: none) */ /* (RWorkspace: need N) */ cgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset], ldvl, &ierr); /* Normalize left eigenvectors and make largest component float */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + i__ * vl_dim1; /* Computing 2nd power */ r__1 = vl[i__3].r; /* Computing 2nd power */ r__2 = r_imag(&vl[k + i__ * vl_dim1]); rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2; /* L10: */ } k = isamax_(n, &rwork[irwork], &c__1); r_cnjg(&q__2, &vl[k + i__ * vl_dim1]); r__1 = sqrt(rwork[irwork + k - 1]); q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1; tmp.r = q__1.r, tmp.i = q__1.i; cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1); i__2 = k + i__ * vl_dim1; i__3 = k + i__ * vl_dim1; r__1 = vl[i__3].r; q__1.r = r__1, q__1.i = 0.f; vl[i__2].r = q__1.r, vl[i__2].i = q__1.i; /* L20: */ } } if (wantvr) { /* Undo balancing of right eigenvectors */ /* (CWorkspace: none) */ /* (RWorkspace: need N) */ cgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset], ldvr, &ierr); /* Normalize right eigenvectors and make largest component float */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + i__ * vr_dim1; /* Computing 2nd power */ r__1 = vr[i__3].r; /* Computing 2nd power */ r__2 = r_imag(&vr[k + i__ * vr_dim1]); rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2; /* L30: */ } k = isamax_(n, &rwork[irwork], &c__1); r_cnjg(&q__2, &vr[k + i__ * vr_dim1]); r__1 = sqrt(rwork[irwork + k - 1]); q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1; tmp.r = q__1.r, tmp.i = q__1.i; cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1); i__2 = k + i__ * vr_dim1; i__3 = k + i__ * vr_dim1; r__1 = vr[i__3].r; q__1.r = r__1, q__1.i = 0.f; vr[i__2].r = q__1.r, vr[i__2].i = q__1.i; /* L40: */ } } /* Undo scaling if necessary */ L50: if (scalea) { i__1 = *n - *info; /* Computing MAX */ i__3 = *n - *info; i__2 = MAX(i__3,1); clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1] , &i__2, &ierr); if (*info > 0) { i__1 = ilo - 1; clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n, &ierr); } } work[1].r = (float) maxwrk, work[1].i = 0.f; return 0; /* End of CGEEV */ } /* cgeev_ */
/* Subroutine */ int cchkhs_(integer *nsizes, integer *nn, integer *ntypes, logical *dotype, integer *iseed, real *thresh, integer *nounit, complex *a, integer *lda, complex *h__, complex *t1, complex *t2, complex *u, integer *ldu, complex *z__, complex *uz, complex *w1, complex *w3, complex *evectl, complex *evectr, complex *evecty, complex *evectx, complex *uu, complex *tau, complex *work, integer * nwork, real *rwork, integer *iwork, logical *select, real *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 CCHKHS: \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 CCHKHS: \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 CCHKHS: 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; real r__1, r__2; complex q__1; /* Local variables */ integer i__, j, k, n, n1, jj, in, ihi, ilo; real ulp, cond; integer jcol, nmax; real unfl, ovfl, temp1, temp2; logical badnn; extern /* Subroutine */ int cget10_(integer *, integer *, complex *, integer *, complex *, integer *, complex *, real *, real *), cget22_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, real *, real *), cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); logical match; integer imode; extern /* Subroutine */ int chst01_(integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *); real dumma[4]; integer iinfo; real conds, aninv, anorm; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); integer nmats, jsize, nerrs, itype, jtype, ntest; real rtulp; extern /* Subroutine */ int slabad_(real *, real *), cgehrd_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), clatme_(integer *, char *, integer *, complex *, integer *, real *, complex *, char *, char *, char *, char *, real *, integer *, real *, integer *, integer *, real *, complex *, integer *, complex *, integer *); complex cdumma[4]; extern doublereal slamch_(char *); extern /* Subroutine */ int chsein_(char *, char *, char *, logical *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *, integer *, complex *, real *, integer *, integer *, integer *), clacpy_( char *, integer *, integer *, complex *, integer *, complex *, integer *); integer idumma[1]; extern /* Subroutine */ int claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *); integer ioldsd[4]; extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_( integer *, integer *, char *, integer *, char *, complex *, integer *, real *, complex *, char *, char *, complex *, integer * , real *, complex *, integer *, real *, char *, integer *, integer *, integer *, real *, real *, char *, complex *, integer * , integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *, real *, integer *, real *, real *, integer *, integer *, char *, complex *, integer *, complex *, integer *), chseqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *), ctrevc_(char *, char *, logical *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *, integer *, complex *, real *, integer *), cunghr_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), cunmhr_(char *, char *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *), slafts_(char *, integer *, integer *, integer *, integer *, real *, integer *, real *, integer *, integer *), slasum_(char *, integer *, integer *, integer *); real rtunfl, rtovfl, rtulpi, ulpinv; integer mtypes, ntestt; /* 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 }; /* -- LAPACK test routine (version 3.1.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* February 2007 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CCHKHS checks the nonsymmetric eigenvalue problem routines. */ /* CGEHRD factors A as U H U' , where ' means conjugate */ /* transpose, H is hessenberg, and U is unitary. */ /* CUNGHR generates the unitary matrix U. */ /* CUNMHR multiplies a matrix by the unitary matrix U. */ /* CHSEQR 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. */ /* CTREVC 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. */ /* CHSEIN 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 CCHKHS 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, */ /* CCHKHS 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, CCHKHS */ /* 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 CCHKHS to continue the same random number */ /* sequence. */ /* Modified. */ /* THRESH - REAL */ /* 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 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 array, dimension (LDA,max(NN)) */ /* The upper hessenberg matrix computed by CGEHRD. On exit, */ /* H contains the Hessenberg form of the matrix in A. */ /* Modified. */ /* T1 - COMPLEX array, dimension (LDA,max(NN)) */ /* The Schur (="quasi-triangular") matrix computed by CHSEQR */ /* if Z is computed. On exit, T1 contains the Schur form of */ /* the matrix in A. */ /* Modified. */ /* T2 - COMPLEX array, dimension (LDA,max(NN)) */ /* The Schur matrix computed by CHSEQR 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 array, dimension (LDU,max(NN)) */ /* The unitary matrix computed by CGEHRD. */ /* Modified. */ /* Z - COMPLEX array, dimension (LDU,max(NN)) */ /* The unitary matrix computed by CHSEQR. */ /* Modified. */ /* UZ - COMPLEX array, dimension (LDU,max(NN)) */ /* The product of U times Z. */ /* Modified. */ /* W1 - COMPLEX 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 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 CHSEIN. */ /* Modified. */ /* EVECTL - COMPLEX array, dimension (LDU,max(NN)) */ /* The conjugate transpose of the (upper triangular) left */ /* eigenvector matrix for the matrix in T1. */ /* Modified. */ /* EVECTR - COMPLEX array, dimension (LDU,max(NN)) */ /* The (upper triangular) right eigenvector matrix for the */ /* matrix in T1. */ /* Modified. */ /* EVECTY - COMPLEX array, dimension (LDU,max(NN)) */ /* The conjugate transpose of the left eigenvector matrix */ /* for the matrix in H. */ /* Modified. */ /* EVECTX - COMPLEX array, dimension (LDU,max(NN)) */ /* The right eigenvector matrix for the matrix in H. */ /* Modified. */ /* UU - COMPLEX array, dimension (LDU,max(NN)) */ /* Details of the unitary matrix computed by CGEHRD. */ /* Modified. */ /* TAU - COMPLEX array, dimension (max(NN)) */ /* Further details of the unitary matrix computed by CGEHRD. */ /* Modified. */ /* WORK - COMPLEX array, dimension (NWORK) */ /* Workspace. */ /* Modified. */ /* NWORK - INTEGER */ /* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */ /* RWORK - REAL 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 - REAL 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 CLATMR, CLATMS, or CLATME returns an error code, the */ /* absolute value of it is returned. */ /* If 1, then CHSEQR 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 SLAFTS). */ /* 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.) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Data statements .. */ /* Parameter adjustments */ --nn; --dotype; --iseed; t2_dim1 = *lda; t2_offset = 1 + t2_dim1; t2 -= t2_offset; t1_dim1 = *lda; t1_offset = 1 + t1_dim1; t1 -= t1_offset; h_dim1 = *lda; h_offset = 1 + h_dim1; h__ -= h_offset; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; uu_dim1 = *ldu; uu_offset = 1 + uu_dim1; uu -= uu_offset; evectx_dim1 = *ldu; evectx_offset = 1 + evectx_dim1; evectx -= evectx_offset; evecty_dim1 = *ldu; evecty_offset = 1 + evecty_dim1; evecty -= evecty_offset; evectr_dim1 = *ldu; evectr_offset = 1 + evectr_dim1; evectr -= evectr_offset; evectl_dim1 = *ldu; evectl_offset = 1 + evectl_dim1; evectl -= evectl_offset; uz_dim1 = *ldu; uz_offset = 1 + uz_dim1; uz -= uz_offset; z_dim1 = *ldu; z_offset = 1 + z_dim1; z__ -= z_offset; u_dim1 = *ldu; u_offset = 1 + u_dim1; u -= u_offset; --w1; --w3; --tau; --work; --rwork; --iwork; --select; --result; /* Function Body */ /* .. */ /* .. Executable Statements .. */ /* 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.f) { *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_("CCHKHS", &i__1); return 0; } /* Quick return if possible */ if (*nsizes == 0 || *ntypes == 0) { return 0; } /* More important constants */ unfl = slamch_("Safe minimum"); ovfl = slamch_("Overflow"); slabad_(&unfl, &ovfl); ulp = slamch_("Epsilon") * slamch_("Base"); ulpinv = 1.f / ulp; rtunfl = sqrt(unfl); rtovfl = sqrt(ovfl); rtulp = sqrt(ulp); rtulpi = 1.f / 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.f / (real) 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.f; /* 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.f; goto L70; L50: anorm = rtovfl * ulp * aninv; goto L70; L60: anorm = rtunfl * n * ulpinv; goto L70; L70: claset_("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 = jcol + jcol * a_dim1; a[i__4].r = anorm, a[i__4].i = 0.f; /* L80: */ } } else if (itype == 3) { /* Jordan Block */ i__3 = n; for (jcol = 1; jcol <= i__3; ++jcol) { i__4 = jcol + jcol * a_dim1; a[i__4].r = anorm, a[i__4].i = 0.f; if (jcol > 1) { i__4 = jcol + (jcol - 1) * a_dim1; a[i__4].r = 1.f, a[i__4].i = 0.f; } /* L90: */ } } else if (itype == 4) { /* Diagonal Matrix, [Eigen]values Specified */ clatmr_(&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 */ clatms_(&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.f; } else if (kconds[jtype - 1] == 2) { conds = rtulpi; } else { conds = 0.f; } clatme_(&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 */ clatmr_(&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 */ clatmr_(&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 */ clatmr_(&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 */ clatmr_(&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 CGEHRD to compute H and U, do tests. */ clacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda); ntest = 1; ilo = 1; ihi = n; i__3 = *nwork - n; cgehrd_(&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, "CGEHRD", (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 = j + 1 + j * uu_dim1; uu[i__4].r = 0.f, uu[i__4].i = 0.f; i__4 = n; for (i__ = j + 2; i__ <= i__4; ++i__) { i__5 = i__ + j * u_dim1; i__6 = i__ + j * h_dim1; u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i; i__5 = i__ + j * uu_dim1; i__6 = i__ + j * h_dim1; uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i; i__5 = i__ + j * h_dim1; h__[i__5].r = 0.f, h__[i__5].i = 0.f; /* L110: */ } /* L120: */ } i__3 = n - 1; ccopy_(&i__3, &work[1], &c__1, &tau[1], &c__1); i__3 = *nwork - n; cunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1], &i__3, &iinfo); ntest = 2; chst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, & u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]); /* Call CHSEQR to compute T1, T2 and Z, do tests. */ /* Eigenvalues only (W3) */ clacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda); ntest = 3; result[3] = ulpinv; chseqr_("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, "CHSEQR(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) */ clacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda); chseqr_("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, "CHSEQR(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) */ clacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda); clacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu); chseqr_("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, "CHSEQR(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 */ cgemm_("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 ) */ chst01_(&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 ) */ chst01_(&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 ) */ cget10_(&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.f; temp2 = 0.f; i__3 = n; for (j = 1; j <= i__3; ++j) { /* Computing MAX */ r__1 = temp1, r__2 = c_abs(&w1[j]), r__1 = max(r__1,r__2), r__2 = c_abs(&w3[j]); temp1 = dmax(r__1,r__2); /* Computing MAX */ i__4 = j; i__5 = j; q__1.r = w1[i__4].r - w3[i__5].r, q__1.i = w1[i__4].i - w3[ i__5].i; r__1 = temp2, r__2 = c_abs(&q__1); temp2 = dmax(r__1,r__2); /* L130: */ } /* Computing MAX */ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2); result[8] = temp2 / dmax(r__1,r__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: */ } ctrevc_("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, "CTREVC(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 ) */ cget22_("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, "CTREVC", (ftnlen)6); do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real)); 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 */ ctrevc_("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, "CTREVC(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 = jj + j * evectr_dim1; i__6 = jj + k * evectl_dim1; 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, "CTREVC", (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; ctrevc_("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, "CTREVC(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 ) */ cget22_("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, "CTREVC", (ftnlen)6); do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real)); 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 */ ctrevc_("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, "CTREVC(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 = jj + j * evectl_dim1; i__6 = jj + k * evectr_dim1; 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, "CTREVC", (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 CHSEIN 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: */ } chsein_("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, "CHSEIN(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) */ cget22_("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, "CHSEIN", (ftnlen)6); do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real)); 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 CHSEIN 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: */ } chsein_("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, "CHSEIN(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) */ cget22_("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, "CHSEIN", (ftnlen)6); do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real)); 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 CUNMHR for Right eigenvectors of A, do test 13 */ ntest = 13; result[13] = ulpinv; cunmhr_("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, "CUNMHR(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) */ cget22_("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 CUNMHR for Left eigenvectors of A, do test 14 */ ntest = 14; result[14] = ulpinv; cunmhr_("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, "CUNMHR(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) */ cget22_("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; slafts_("CHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh, nounit, &nerrs); L250: ; } /* L260: */ } /* Summary */ slasum_("CHS", nounit, &nerrs, &ntestt); return 0; /* End of CCHKHS */ } /* cchkhs_ */