int dtrsen_(char *job, char *compq, int *select, int *n, double *t, int *ldt, double *q, int *ldq, double *wr, double *wi, int *m, double *s, double *sep, double *work, int *lwork, int *iwork, int * liwork, int *info) { /* System generated locals */ int q_dim1, q_offset, t_dim1, t_offset, i__1, i__2; double d__1, d__2; /* Builtin functions */ double sqrt(double); /* Local variables */ int k, n1, n2, kk, nn, ks; double est; int kase; int pair; int ierr; int swap; double scale; extern int lsame_(char *, char *); int isave[3], lwmin; int wantq, wants; double rnorm; extern int dlacn2_(int *, double *, double *, int *, double *, int *, int *); extern double dlange_(char *, int *, int *, double *, int *, double *); extern int dlacpy_(char *, int *, int *, double *, int *, double *, int *), xerbla_(char *, int *); int wantbh; extern int dtrexc_(char *, int *, double *, int *, double *, int *, int *, int *, double *, int *); int liwmin; int wantsp, lquery; extern int dtrsyl_(char *, char *, int *, int *, int *, double *, int *, double *, int *, double *, int *, double *, int *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DTRSEN reorders the float Schur factorization of a float matrix */ /* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */ /* the leading diagonal blocks of the upper quasi-triangular matrix T, */ /* and the leading columns of Q form an orthonormal basis of the */ /* corresponding right invariant subspace. */ /* Optionally the routine computes the reciprocal condition numbers of */ /* the cluster of eigenvalues and/or the invariant subspace. */ /* T must be in Schur canonical form (as returned by DHSEQR), that is, */ /* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ /* 2-by-2 diagonal block has its diagonal elemnts equal and its */ /* off-diagonal elements of opposite sign. */ /* Arguments */ /* ========= */ /* JOB (input) CHARACTER*1 */ /* Specifies whether condition numbers are required for the */ /* cluster of eigenvalues (S) or the invariant subspace (SEP): */ /* = 'N': none; */ /* = 'E': for eigenvalues only (S); */ /* = 'V': for invariant subspace only (SEP); */ /* = 'B': for both eigenvalues and invariant subspace (S and */ /* SEP). */ /* COMPQ (input) CHARACTER*1 */ /* = 'V': update the matrix Q of Schur vectors; */ /* = 'N': do not update Q. */ /* SELECT (input) LOGICAL array, dimension (N) */ /* SELECT specifies the eigenvalues in the selected cluster. To */ /* select a float eigenvalue w(j), SELECT(j) must be set to */ /* .TRUE.. To select a complex conjugate pair of eigenvalues */ /* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ /* either SELECT(j) or SELECT(j+1) or both must be set to */ /* .TRUE.; a complex conjugate pair of eigenvalues must be */ /* either both included in the cluster or both excluded. */ /* N (input) INTEGER */ /* The order of the matrix T. N >= 0. */ /* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */ /* On entry, the upper quasi-triangular matrix T, in Schur */ /* canonical form. */ /* On exit, T is overwritten by the reordered matrix T, again in */ /* Schur canonical form, with the selected eigenvalues in the */ /* leading diagonal blocks. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= MAX(1,N). */ /* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ /* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ /* On exit, if COMPQ = 'V', Q has been postmultiplied by the */ /* orthogonal transformation matrix which reorders T; the */ /* leading M columns of Q form an orthonormal basis for the */ /* specified invariant subspace. */ /* If COMPQ = 'N', Q is not referenced. */ /* LDQ (input) INTEGER */ /* The leading dimension of the array Q. */ /* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */ /* WR (output) DOUBLE PRECISION array, dimension (N) */ /* WI (output) DOUBLE PRECISION array, dimension (N) */ /* The float and imaginary parts, respectively, of the reordered */ /* eigenvalues of T. The eigenvalues are stored in the same */ /* order as on the diagonal of T, with WR(i) = T(i,i) and, if */ /* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */ /* WI(i+1) = -WI(i). Note that if a complex eigenvalue is */ /* sufficiently ill-conditioned, then its value may differ */ /* significantly from its value before reordering. */ /* M (output) INTEGER */ /* The dimension of the specified invariant subspace. */ /* 0 < = M <= N. */ /* S (output) DOUBLE PRECISION */ /* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */ /* condition number for the selected cluster of eigenvalues. */ /* S cannot underestimate the true reciprocal condition number */ /* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */ /* If JOB = 'N' or 'V', S is not referenced. */ /* SEP (output) DOUBLE PRECISION */ /* If JOB = 'V' or 'B', SEP is the estimated reciprocal */ /* condition number of the specified invariant subspace. If */ /* M = 0 or N, SEP = norm(T). */ /* If JOB = 'N' or 'E', SEP is not referenced. */ /* WORK (workspace/output) DOUBLE PRECISION 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 JOB = 'N', LWORK >= MAX(1,N); */ /* if JOB = 'E', LWORK >= MAX(1,M*(N-M)); */ /* if JOB = 'V' or 'B', LWORK >= MAX(1,2*M*(N-M)). */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */ /* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ /* LIWORK (input) INTEGER */ /* The dimension of the array IWORK. */ /* If JOB = 'N' or 'E', LIWORK >= 1; */ /* if JOB = 'V' or 'B', LIWORK >= MAX(1,M*(N-M)). */ /* If LIWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the optimal size of the IWORK array, */ /* returns this value as the first entry of the IWORK array, and */ /* no error message related to LIWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* = 1: reordering of T failed because some eigenvalues are too */ /* close to separate (the problem is very ill-conditioned); */ /* T may have been partially reordered, and WR and WI */ /* contain the eigenvalues in the same order as in T; S and */ /* SEP (if requested) are set to zero. */ /* Further Details */ /* =============== */ /* DTRSEN first collects the selected eigenvalues by computing an */ /* orthogonal transformation Z to move them to the top left corner of T. */ /* In other words, the selected eigenvalues are the eigenvalues of T11 */ /* in: */ /* Z'*T*Z = ( T11 T12 ) n1 */ /* ( 0 T22 ) n2 */ /* n1 n2 */ /* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns */ /* of Z span the specified invariant subspace of T. */ /* If T has been obtained from the float Schur factorization of a matrix */ /* A = Q*T*Q', then the reordered float Schur factorization of A is given */ /* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span */ /* the corresponding invariant subspace of A. */ /* The reciprocal condition number of the average of the eigenvalues of */ /* T11 may be returned in S. S lies between 0 (very badly conditioned) */ /* and 1 (very well conditioned). It is computed as follows. First we */ /* compute R so that */ /* P = ( I R ) n1 */ /* ( 0 0 ) n2 */ /* n1 n2 */ /* is the projector on the invariant subspace associated with T11. */ /* R is the solution of the Sylvester equation: */ /* T11*R - R*T22 = T12. */ /* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */ /* the two-norm of M. Then S is computed as the lower bound */ /* (1 + F-norm(R)**2)**(-1/2) */ /* on the reciprocal of 2-norm(P), the true reciprocal condition number. */ /* S cannot underestimate 1 / 2-norm(P) by more than a factor of */ /* sqrt(N). */ /* An approximate error bound for the computed average of the */ /* eigenvalues of T11 is */ /* EPS * norm(T) / S */ /* where EPS is the machine precision. */ /* The reciprocal condition number of the right invariant subspace */ /* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */ /* SEP is defined as the separation of T11 and T22: */ /* sep( T11, T22 ) = sigma-MIN( C ) */ /* where sigma-MIN(C) is the smallest singular value of the */ /* n1*n2-by-n1*n2 matrix */ /* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */ /* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */ /* product. We estimate sigma-MIN(C) by the reciprocal of an estimate of */ /* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */ /* cannot differ from sigma-MIN(C) by more than a factor of sqrt(n1*n2). */ /* When SEP is small, small changes in T can cause large changes in */ /* the invariant subspace. An approximate bound on the maximum angular */ /* error in the computed right invariant subspace is */ /* EPS * norm(T) / SEP */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and test the input parameters */ /* Parameter adjustments */ --select; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; --wr; --wi; --work; --iwork; /* Function Body */ wantbh = lsame_(job, "B"); wants = lsame_(job, "E") || wantbh; wantsp = lsame_(job, "V") || wantbh; wantq = lsame_(compq, "V"); *info = 0; lquery = *lwork == -1; if (! lsame_(job, "N") && ! wants && ! wantsp) { *info = -1; } else if (! lsame_(compq, "N") && ! wantq) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*ldt < MAX(1,*n)) { *info = -6; } else if (*ldq < 1 || wantq && *ldq < *n) { *info = -8; } else { /* Set M to the dimension of the specified invariant subspace, */ /* and test LWORK and LIWORK. */ *m = 0; pair = FALSE; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (pair) { pair = FALSE; } else { if (k < *n) { if (t[k + 1 + k * t_dim1] == 0.) { if (select[k]) { ++(*m); } } else { pair = TRUE; if (select[k] || select[k + 1]) { *m += 2; } } } else { if (select[*n]) { ++(*m); } } } /* L10: */ } n1 = *m; n2 = *n - *m; nn = n1 * n2; if (wantsp) { /* Computing MAX */ i__1 = 1, i__2 = nn << 1; lwmin = MAX(i__1,i__2); liwmin = MAX(1,nn); } else if (lsame_(job, "N")) { lwmin = MAX(1,*n); liwmin = 1; } else if (lsame_(job, "E")) { lwmin = MAX(1,nn); liwmin = 1; } if (*lwork < lwmin && ! lquery) { *info = -15; } else if (*liwork < liwmin && ! lquery) { *info = -17; } } if (*info == 0) { work[1] = (double) lwmin; iwork[1] = liwmin; } if (*info != 0) { i__1 = -(*info); xerbla_("DTRSEN", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible. */ if (*m == *n || *m == 0) { if (wants) { *s = 1.; } if (wantsp) { *sep = dlange_("1", n, n, &t[t_offset], ldt, &work[1]); } goto L40; } /* Collect the selected blocks at the top-left corner of T. */ ks = 0; pair = FALSE; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (pair) { pair = FALSE; } else { swap = select[k]; if (k < *n) { if (t[k + 1 + k * t_dim1] != 0.) { pair = TRUE; swap = swap || select[k + 1]; } } if (swap) { ++ks; /* Swap the K-th block to position KS. */ ierr = 0; kk = k; if (k != ks) { dtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, & kk, &ks, &work[1], &ierr); } if (ierr == 1 || ierr == 2) { /* Blocks too close to swap: exit. */ *info = 1; if (wants) { *s = 0.; } if (wantsp) { *sep = 0.; } goto L40; } if (pair) { ++ks; } } } /* L20: */ } if (wants) { /* Solve Sylvester equation for R: */ /* T11*R - R*T22 = scale*T12 */ dlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1); dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr); /* Estimate the reciprocal of the condition number of the cluster */ /* of eigenvalues. */ rnorm = dlange_("F", &n1, &n2, &work[1], &n1, &work[1]); if (rnorm == 0.) { *s = 1.; } else { *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm)); } } if (wantsp) { /* Estimate sep(T11,T22). */ est = 0.; kase = 0; L30: dlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave); if (kase != 0) { if (kase == 1) { /* Solve T11*R - R*T22 = scale*X. */ dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & ierr); } else { /* Solve T11'*R - R*T22' = scale*X. */ dtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & ierr); } goto L30; } *sep = scale / est; } L40: /* Store the output eigenvalues in WR and WI. */ i__1 = *n; for (k = 1; k <= i__1; ++k) { wr[k] = t[k + k * t_dim1]; wi[k] = 0.; /* L50: */ } i__1 = *n - 1; for (k = 1; k <= i__1; ++k) { if (t[k + 1 + k * t_dim1] != 0.) { wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], ABS(d__1))) * sqrt(( d__2 = t[k + 1 + k * t_dim1], ABS(d__2))); wi[k + 1] = -wi[k]; } /* L60: */ } work[1] = (double) lwmin; iwork[1] = liwmin; return 0; /* End of DTRSEN */ } /* dtrsen_ */
int main(void) { /* Local scalars */ char compq, compq_i; lapack_int n, n_i; lapack_int ldt, ldt_i; lapack_int ldt_r; lapack_int ldq, ldq_i; lapack_int ldq_r; lapack_int ifst, ifst_i, ifst_save; lapack_int ilst, ilst_i, ilst_save; lapack_int info, info_i; lapack_int i; int failed; /* Local arrays */ double *t = NULL, *t_i = NULL; double *q = NULL, *q_i = NULL; double *work = NULL, *work_i = NULL; double *t_save = NULL; double *q_save = NULL; double *t_r = NULL; double *q_r = NULL; /* Iniitialize the scalar parameters */ init_scalars_dtrexc( &compq, &n, &ldt, &ldq, &ifst, &ilst ); ldt_r = n+2; ldq_r = n+2; compq_i = compq; n_i = n; ldt_i = ldt; ldq_i = ldq; ifst_i = ifst_save = ifst; ilst_i = ilst_save = ilst; /* Allocate memory for the LAPACK routine arrays */ t = (double *)LAPACKE_malloc( ldt*n * sizeof(double) ); q = (double *)LAPACKE_malloc( ldq*n * sizeof(double) ); work = (double *)LAPACKE_malloc( n * sizeof(double) ); /* Allocate memory for the C interface function arrays */ t_i = (double *)LAPACKE_malloc( ldt*n * sizeof(double) ); q_i = (double *)LAPACKE_malloc( ldq*n * sizeof(double) ); work_i = (double *)LAPACKE_malloc( n * sizeof(double) ); /* Allocate memory for the backup arrays */ t_save = (double *)LAPACKE_malloc( ldt*n * sizeof(double) ); q_save = (double *)LAPACKE_malloc( ldq*n * sizeof(double) ); /* Allocate memory for the row-major arrays */ t_r = (double *)LAPACKE_malloc( n*(n+2) * sizeof(double) ); q_r = (double *)LAPACKE_malloc( n*(n+2) * sizeof(double) ); /* Initialize input arrays */ init_t( ldt*n, t ); init_q( ldq*n, q ); init_work( n, work ); /* Backup the ouptut arrays */ for( i = 0; i < ldt*n; i++ ) { t_save[i] = t[i]; } for( i = 0; i < ldq*n; i++ ) { q_save[i] = q[i]; } /* Call the LAPACK routine */ dtrexc_( &compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, work, &info ); /* Initialize input data, call the column-major middle-level * interface to LAPACK routine and check the results */ ifst_i = ifst_save; ilst_i = ilst_save; for( i = 0; i < ldt*n; i++ ) { t_i[i] = t_save[i]; } for( i = 0; i < ldq*n; i++ ) { q_i[i] = q_save[i]; } for( i = 0; i < n; i++ ) { work_i[i] = work[i]; } info_i = LAPACKE_dtrexc_work( LAPACK_COL_MAJOR, compq_i, n_i, t_i, ldt_i, q_i, ldq_i, &ifst_i, &ilst_i, work_i ); failed = compare_dtrexc( t, t_i, q, q_i, ifst, ifst_i, ilst, ilst_i, info, info_i, compq, ldq, ldt, n ); if( failed == 0 ) { printf( "PASSED: column-major middle-level interface to dtrexc\n" ); } else { printf( "FAILED: column-major middle-level interface to dtrexc\n" ); } /* Initialize input data, call the column-major high-level * interface to LAPACK routine and check the results */ ifst_i = ifst_save; ilst_i = ilst_save; for( i = 0; i < ldt*n; i++ ) { t_i[i] = t_save[i]; } for( i = 0; i < ldq*n; i++ ) { q_i[i] = q_save[i]; } for( i = 0; i < n; i++ ) { work_i[i] = work[i]; } info_i = LAPACKE_dtrexc( LAPACK_COL_MAJOR, compq_i, n_i, t_i, ldt_i, q_i, ldq_i, &ifst_i, &ilst_i ); failed = compare_dtrexc( t, t_i, q, q_i, ifst, ifst_i, ilst, ilst_i, info, info_i, compq, ldq, ldt, n ); if( failed == 0 ) { printf( "PASSED: column-major high-level interface to dtrexc\n" ); } else { printf( "FAILED: column-major high-level interface to dtrexc\n" ); } /* Initialize input data, call the row-major middle-level * interface to LAPACK routine and check the results */ ifst_i = ifst_save; ilst_i = ilst_save; for( i = 0; i < ldt*n; i++ ) { t_i[i] = t_save[i]; } for( i = 0; i < ldq*n; i++ ) { q_i[i] = q_save[i]; } for( i = 0; i < n; i++ ) { work_i[i] = work[i]; } LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, t_i, ldt, t_r, n+2 ); if( LAPACKE_lsame( compq, 'v' ) ) { LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, q_i, ldq, q_r, n+2 ); } info_i = LAPACKE_dtrexc_work( LAPACK_ROW_MAJOR, compq_i, n_i, t_r, ldt_r, q_r, ldq_r, &ifst_i, &ilst_i, work_i ); LAPACKE_dge_trans( LAPACK_ROW_MAJOR, n, n, t_r, n+2, t_i, ldt ); if( LAPACKE_lsame( compq, 'v' ) ) { LAPACKE_dge_trans( LAPACK_ROW_MAJOR, n, n, q_r, n+2, q_i, ldq ); } failed = compare_dtrexc( t, t_i, q, q_i, ifst, ifst_i, ilst, ilst_i, info, info_i, compq, ldq, ldt, n ); if( failed == 0 ) { printf( "PASSED: row-major middle-level interface to dtrexc\n" ); } else { printf( "FAILED: row-major middle-level interface to dtrexc\n" ); } /* Initialize input data, call the row-major high-level * interface to LAPACK routine and check the results */ ifst_i = ifst_save; ilst_i = ilst_save; for( i = 0; i < ldt*n; i++ ) { t_i[i] = t_save[i]; } for( i = 0; i < ldq*n; i++ ) { q_i[i] = q_save[i]; } for( i = 0; i < n; i++ ) { work_i[i] = work[i]; } /* Init row_major arrays */ LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, t_i, ldt, t_r, n+2 ); if( LAPACKE_lsame( compq, 'v' ) ) { LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, q_i, ldq, q_r, n+2 ); } info_i = LAPACKE_dtrexc( LAPACK_ROW_MAJOR, compq_i, n_i, t_r, ldt_r, q_r, ldq_r, &ifst_i, &ilst_i ); LAPACKE_dge_trans( LAPACK_ROW_MAJOR, n, n, t_r, n+2, t_i, ldt ); if( LAPACKE_lsame( compq, 'v' ) ) { LAPACKE_dge_trans( LAPACK_ROW_MAJOR, n, n, q_r, n+2, q_i, ldq ); } failed = compare_dtrexc( t, t_i, q, q_i, ifst, ifst_i, ilst, ilst_i, info, info_i, compq, ldq, ldt, n ); if( failed == 0 ) { printf( "PASSED: row-major high-level interface to dtrexc\n" ); } else { printf( "FAILED: row-major high-level interface to dtrexc\n" ); } /* Release memory */ if( t != NULL ) { LAPACKE_free( t ); } if( t_i != NULL ) { LAPACKE_free( t_i ); } if( t_r != NULL ) { LAPACKE_free( t_r ); } if( t_save != NULL ) { LAPACKE_free( t_save ); } if( q != NULL ) { LAPACKE_free( q ); } if( q_i != NULL ) { LAPACKE_free( q_i ); } if( q_r != NULL ) { LAPACKE_free( q_r ); } if( q_save != NULL ) { LAPACKE_free( q_save ); } if( work != NULL ) { LAPACKE_free( work ); } if( work_i != NULL ) { LAPACKE_free( work_i ); } return 0; }
/* Subroutine */ int dget36_(doublereal *rmax, integer *lmax, integer *ninfo, integer *knt, integer *nin) { /* System generated locals */ integer i__1, i__2; /* Builtin functions */ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), e_rsle(void); double d_sign(doublereal *, doublereal *); /* Local variables */ integer i__, j, n; doublereal q[100] /* was [10][10] */, t1[100] /* was [10][10] */, t2[100] /* was [10][10] */; integer loc; doublereal eps, res, tmp[100] /* was [10][10] */; integer ifst, ilst; doublereal work[200]; integer info1, info2, ifst1, ifst2, ilst1, ilst2; extern /* Subroutine */ int dhst01_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *); extern doublereal dlamch_(char *); extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), dtrexc_(char *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *); integer ifstsv; doublereal result[2]; integer ilstsv; /* Fortran I/O blocks */ static cilist io___2 = { 0, 0, 0, 0, 0 }; static cilist io___7 = { 0, 0, 0, 0, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or */ /* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, DLAEXC */ /* computes an orthogonal matrix Q such that */ /* Q' * T1 * Q = T2 */ /* and where one of the diagonal blocks of T1 (the one at row IFST) has */ /* been moved to position ILST. */ /* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */ /* is in Schur form, and that the final position of the IFST block is */ /* ILST (within +-1). */ /* The test matrices are read from a file with logical unit number NIN. */ /* Arguments */ /* ========== */ /* RMAX (output) DOUBLE PRECISION */ /* Value of the largest test ratio. */ /* LMAX (output) INTEGER */ /* Example number where largest test ratio achieved. */ /* NINFO (output) INTEGER array, dimension (3) */ /* NINFO(J) is the number of examples where INFO=J. */ /* KNT (output) INTEGER */ /* Total number of examples tested. */ /* NIN (input) INTEGER */ /* Input logical unit number. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --ninfo; /* Function Body */ eps = dlamch_("P"); *rmax = 0.; *lmax = 0; *knt = 0; ninfo[1] = 0; ninfo[2] = 0; ninfo[3] = 0; /* Read input data until N=0 */ L10: io___2.ciunit = *nin; s_rsle(&io___2); do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer)); do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer)); do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer)); e_rsle(); if (n == 0) { return 0; } ++(*knt); i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___7.ciunit = *nin; s_rsle(&io___7); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__5, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen) sizeof(doublereal)); } e_rsle(); /* L20: */ } dlacpy_("F", &n, &n, tmp, &c__10, t1, &c__10); dlacpy_("F", &n, &n, tmp, &c__10, t2, &c__10); ifstsv = ifst; ilstsv = ilst; ifst1 = ifst; ilst1 = ilst; ifst2 = ifst; ilst2 = ilst; res = 0.; /* Test without accumulating Q */ dlaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10); dtrexc_("N", &n, t1, &c__10, q, &c__10, &ifst1, &ilst1, work, &info1); i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = n; for (j = 1; j <= i__2; ++j) { if (i__ == j && q[i__ + j * 10 - 11] != 1.) { res += 1. / eps; } if (i__ != j && q[i__ + j * 10 - 11] != 0.) { res += 1. / eps; } /* L30: */ } /* L40: */ } /* Test with accumulating Q */ dlaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10); dtrexc_("V", &n, t2, &c__10, q, &c__10, &ifst2, &ilst2, work, &info2); /* Compare T1 with T2 */ i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = n; for (j = 1; j <= i__2; ++j) { if (t1[i__ + j * 10 - 11] != t2[i__ + j * 10 - 11]) { res += 1. / eps; } /* L50: */ } /* L60: */ } if (ifst1 != ifst2) { res += 1. / eps; } if (ilst1 != ilst2) { res += 1. / eps; } if (info1 != info2) { res += 1. / eps; } /* Test for successful reordering of T2 */ if (info2 != 0) { ++ninfo[info2]; } else { if ((i__1 = ifst2 - ifstsv, abs(i__1)) > 1) { res += 1. / eps; } if ((i__1 = ilst2 - ilstsv, abs(i__1)) > 1) { res += 1. / eps; } } /* Test for small residual, and orthogonality of Q */ dhst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200, result); res = res + result[0] + result[1]; /* Test for T2 being in Schur form */ loc = 1; L70: if (t2[loc + 1 + loc * 10 - 11] != 0.) { /* 2 by 2 block */ if (t2[loc + (loc + 1) * 10 - 11] == 0. || t2[loc + loc * 10 - 11] != t2[loc + 1 + (loc + 1) * 10 - 11] || d_sign(&c_b22, &t2[loc + (loc + 1) * 10 - 11]) == d_sign(&c_b22, &t2[loc + 1 + loc * 10 - 11])) { res += 1. / eps; } i__1 = n; for (i__ = loc + 2; i__ <= i__1; ++i__) { if (t2[i__ + loc * 10 - 11] != 0.) { res += 1. / res; } if (t2[i__ + (loc + 1) * 10 - 11] != 0.) { res += 1. / res; } /* L80: */ } loc += 2; } else { /* 1 by 1 block */ i__1 = n; for (i__ = loc + 1; i__ <= i__1; ++i__) { if (t2[i__ + loc * 10 - 11] != 0.) { res += 1. / res; } /* L90: */ } ++loc; } if (loc < n) { goto L70; } if (res > *rmax) { *rmax = res; *lmax = *knt; } goto L10; /* End of DGET36 */ } /* dget36_ */
/* Subroutine */ int dlaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer * ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz, integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal * v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer * nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork) { /* System generated locals */ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2, d__3, d__4, d__5, d__6; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k; doublereal s, aa, bb, cc, dd, cs, sn; integer jw; doublereal evi, evk, foo; integer kln; doublereal tau, ulp; integer lwk1, lwk2; doublereal beta; integer kend, kcol, info, ifst, ilst, ltop, krow; extern /* Subroutine */ int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *), dgemm_(char *, char *, integer *, integer * , integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); logical bulge; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); integer infqr, kwtop; extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlabad_( doublereal *, doublereal *); extern doublereal dlamch_(char *); extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); doublereal safmin; extern /* Subroutine */ int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); doublereal safmax; extern /* Subroutine */ int dorghr_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dtrexc_(char *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *); logical sorted; doublereal smlnum; integer lwkopt; /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* This subroutine is identical to DLAQR3 except that it avoids */ /* recursion by calling DLAHQR instead of DLAQR4. */ /* ****************************************************************** */ /* Aggressive early deflation: */ /* This subroutine accepts as input an upper Hessenberg matrix */ /* H and performs an orthogonal similarity transformation */ /* designed to detect and deflate fully converged eigenvalues from */ /* a trailing principal submatrix. On output H has been over- */ /* written by a new Hessenberg matrix that is a perturbation of */ /* an orthogonal similarity transformation of H. It is to be */ /* hoped that the final version of H has many zero subdiagonal */ /* entries. */ /* ****************************************************************** */ /* WANTT (input) LOGICAL */ /* If .TRUE., then the Hessenberg matrix H is fully updated */ /* so that the quasi-triangular Schur factor may be */ /* computed (in cooperation with the calling subroutine). */ /* If .FALSE., then only enough of H is updated to preserve */ /* the eigenvalues. */ /* WANTZ (input) LOGICAL */ /* If .TRUE., then the orthogonal matrix Z is updated so */ /* so that the orthogonal Schur factor may be computed */ /* (in cooperation with the calling subroutine). */ /* If .FALSE., then Z is not referenced. */ /* N (input) INTEGER */ /* The order of the matrix H and (if WANTZ is .TRUE.) the */ /* order of the orthogonal matrix Z. */ /* KTOP (input) INTEGER */ /* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ /* KBOT and KTOP together determine an isolated block */ /* along the diagonal of the Hessenberg matrix. */ /* KBOT (input) INTEGER */ /* It is assumed without a check that either */ /* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ /* determine an isolated block along the diagonal of the */ /* Hessenberg matrix. */ /* NW (input) INTEGER */ /* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */ /* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ /* On input the initial N-by-N section of H stores the */ /* Hessenberg matrix undergoing aggressive early deflation. */ /* On output H has been transformed by an orthogonal */ /* similarity transformation, perturbed, and the returned */ /* to Hessenberg form that (it is to be hoped) has some */ /* zero subdiagonal entries. */ /* LDH (input) integer */ /* Leading dimension of H just as declared in the calling */ /* subroutine. N .LE. LDH */ /* ILOZ (input) INTEGER */ /* IHIZ (input) INTEGER */ /* Specify the rows of Z to which transformations must be */ /* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */ /* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */ /* IF WANTZ is .TRUE., then on output, the orthogonal */ /* similarity transformation mentioned above has been */ /* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */ /* If WANTZ is .FALSE., then Z is unreferenced. */ /* LDZ (input) integer */ /* The leading dimension of Z just as declared in the */ /* calling subroutine. 1 .LE. LDZ. */ /* NS (output) integer */ /* The number of unconverged (ie approximate) eigenvalues */ /* returned in SR and SI that may be used as shifts by the */ /* calling subroutine. */ /* ND (output) integer */ /* The number of converged eigenvalues uncovered by this */ /* subroutine. */ /* SR (output) DOUBLE PRECISION array, dimension KBOT */ /* SI (output) DOUBLE PRECISION array, dimension KBOT */ /* On output, the real and imaginary parts of approximate */ /* eigenvalues that may be used for shifts are stored in */ /* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ /* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ /* The real and imaginary parts of converged eigenvalues */ /* are stored in SR(KBOT-ND+1) through SR(KBOT) and */ /* SI(KBOT-ND+1) through SI(KBOT), respectively. */ /* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) */ /* An NW-by-NW work array. */ /* LDV (input) integer scalar */ /* The leading dimension of V just as declared in the */ /* calling subroutine. NW .LE. LDV */ /* NH (input) integer scalar */ /* The number of columns of T. NH.GE.NW. */ /* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) */ /* LDT (input) integer */ /* The leading dimension of T just as declared in the */ /* calling subroutine. NW .LE. LDT */ /* NV (input) integer */ /* The number of rows of work array WV available for */ /* workspace. NV.GE.NW. */ /* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) */ /* LDWV (input) integer */ /* The leading dimension of W just as declared in the */ /* calling subroutine. NW .LE. LDV */ /* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. */ /* On exit, WORK(1) is set to an estimate of the optimal value */ /* of LWORK for the given values of N, NW, KTOP and KBOT. */ /* LWORK (input) integer */ /* The dimension of the work array WORK. LWORK = 2*NW */ /* suffices, but greater efficiency may result from larger */ /* values of LWORK. */ /* If LWORK = -1, then a workspace query is assumed; DLAQR2 */ /* only estimates the optimal workspace size for the given */ /* values of N, NW, KTOP and KBOT. The estimate is returned */ /* in WORK(1). No error message related to LWORK is issued */ /* by XERBLA. Neither H nor Z are accessed. */ /* ================================================================ */ /* Based on contributions by */ /* Karen Braman and Ralph Byers, Department of Mathematics, */ /* University of Kansas, USA */ /* ================================================================ */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* ==== Estimate optimal workspace. ==== */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --sr; --si; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; wv_dim1 = *ldwv; wv_offset = 1 + wv_dim1; wv -= wv_offset; --work; /* Function Body */ /* Computing MIN */ i__1 = *nw, i__2 = *kbot - *ktop + 1; jw = min(i__1,i__2); if (jw <= 2) { lwkopt = 1; } else { /* ==== Workspace query call to DGEHRD ==== */ i__1 = jw - 1; dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info); lwk1 = (integer) work[1]; /* ==== Workspace query call to DORGHR ==== */ i__1 = jw - 1; dorghr_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info); lwk2 = (integer) work[1]; /* ==== Optimal workspace ==== */ lwkopt = jw + max(lwk1,lwk2); } /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { work[1] = (doublereal) lwkopt; return 0; } /* ==== Nothing to do ... */ /* ... for an empty active block ... ==== */ *ns = 0; *nd = 0; if (*ktop > *kbot) { return 0; } /* ... nor for an empty deflation window. ==== */ if (*nw < 1) { return 0; } /* ==== Machine constants ==== */ safmin = dlamch_("SAFE MINIMUM"); safmax = 1. / safmin; dlabad_(&safmin, &safmax); ulp = dlamch_("PRECISION"); smlnum = safmin * ((doublereal) (*n) / ulp); /* ==== Setup deflation window ==== */ /* Computing MIN */ i__1 = *nw, i__2 = *kbot - *ktop + 1; jw = min(i__1,i__2); kwtop = *kbot - jw + 1; if (kwtop == *ktop) { s = 0.; } else { s = h__[kwtop + (kwtop - 1) * h_dim1]; } if (*kbot == kwtop) { /* ==== 1-by-1 deflation window: not much to do ==== */ sr[kwtop] = h__[kwtop + kwtop * h_dim1]; si[kwtop] = 0.; *ns = 1; *nd = 0; /* Computing MAX */ d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs( d__1)); if (abs(s) <= max(d__2,d__3)) { *ns = 0; *nd = 1; if (kwtop > *ktop) { h__[kwtop + (kwtop - 1) * h_dim1] = 0.; } } return 0; } /* ==== Convert to spike-triangular form. (In case of a */ /* . rare QR failure, this routine continues to do */ /* . aggressive early deflation using that part of */ /* . the deflation window that converged using INFQR */ /* . here and there to keep track.) ==== */ dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt); i__1 = jw - 1; i__2 = *ldh + 1; i__3 = *ldt + 1; dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3); dlaset_("A", &jw, &jw, &c_b10, &c_b11, &v[v_offset], ldv); dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); /* ==== DTREXC needs a clean margin near the diagonal ==== */ i__1 = jw - 3; for (j = 1; j <= i__1; ++j) { t[j + 2 + j * t_dim1] = 0.; t[j + 3 + j * t_dim1] = 0.; /* L10: */ } if (jw > 2) { t[jw + (jw - 2) * t_dim1] = 0.; } /* ==== Deflation detection loop ==== */ *ns = jw; ilst = infqr + 1; L20: if (ilst <= *ns) { if (*ns == 1) { bulge = FALSE_; } else { bulge = t[*ns + (*ns - 1) * t_dim1] != 0.; } /* ==== Small spike tip test for deflation ==== */ if (! bulge) { /* ==== Real eigenvalue ==== */ foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1)); if (foo == 0.) { foo = abs(s); } /* Computing MAX */ d__2 = smlnum, d__3 = ulp * foo; if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2,d__3)) { /* ==== Deflatable ==== */ --(*ns); } else { /* ==== Undeflatable. Move it up out of the way. */ /* . (DTREXC can not fail in this case.) ==== */ ifst = *ns; dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); ++ilst; } } else { /* ==== Complex conjugate pair ==== */ foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[* ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[* ns - 1 + *ns * t_dim1], abs(d__2))); if (foo == 0.) { foo = abs(s); } /* Computing MAX */ d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 = s * v[(*ns - 1) * v_dim1 + 1], abs(d__2)); /* Computing MAX */ d__5 = smlnum, d__6 = ulp * foo; if (max(d__3,d__4) <= max(d__5,d__6)) { /* ==== Deflatable ==== */ *ns += -2; } else { /* ==== Undflatable. Move them up out of the way. */ /* . Fortunately, DTREXC does the right thing with */ /* . ILST in case of a rare exchange failure. ==== */ ifst = *ns; dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); ilst += 2; } } /* ==== End deflation detection loop ==== */ goto L20; } /* ==== Return to Hessenberg form ==== */ if (*ns == 0) { s = 0.; } if (*ns < jw) { /* ==== sorting diagonal blocks of T improves accuracy for */ /* . graded matrices. Bubble sort deals well with */ /* . exchange failures. ==== */ sorted = FALSE_; i__ = *ns + 1; L30: if (sorted) { goto L50; } sorted = TRUE_; kend = i__ - 1; i__ = infqr + 1; if (i__ == *ns) { k = i__ + 1; } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { k = i__ + 1; } else { k = i__ + 2; } L40: if (k <= kend) { if (k == i__ + 1) { evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1)); } else { evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 = t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 = t[i__ + (i__ + 1) * t_dim1], abs(d__2))); } if (k == kend) { evk = (d__1 = t[k + k * t_dim1], abs(d__1)); } else if (t[k + 1 + k * t_dim1] == 0.) { evk = (d__1 = t[k + k * t_dim1], abs(d__1)); } else { evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[ k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k + (k + 1) * t_dim1], abs(d__2))); } if (evi >= evk) { i__ = k; } else { sorted = FALSE_; ifst = i__; ilst = k; dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); if (info == 0) { i__ = ilst; } else { i__ = k; } } if (i__ == kend) { k = i__ + 1; } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { k = i__ + 1; } else { k = i__ + 2; } goto L40; } goto L30; L50: ; } /* ==== Restore shift/eigenvalue array from T ==== */ i__ = jw; L60: if (i__ >= infqr + 1) { if (i__ == infqr + 1) { sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; si[kwtop + i__ - 1] = 0.; --i__; } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) { sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; si[kwtop + i__ - 1] = 0.; --i__; } else { aa = t[i__ - 1 + (i__ - 1) * t_dim1]; cc = t[i__ + (i__ - 1) * t_dim1]; bb = t[i__ - 1 + i__ * t_dim1]; dd = t[i__ + i__ * t_dim1]; dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & sn); i__ += -2; } goto L60; } if (*ns < jw || s == 0.) { if (*ns > 1 && s != 0.) { /* ==== Reflect spike back into lower triangle ==== */ dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); beta = work[1]; dlarfg_(ns, &beta, &work[2], &c__1, &tau); work[1] = 1.; i__1 = jw - 2; i__2 = jw - 2; dlaset_("L", &i__1, &i__2, &c_b10, &c_b10, &t[t_dim1 + 3], ldt); dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]); i__1 = *lwork - jw; dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info); } /* ==== Copy updated reduced window into place ==== */ if (kwtop > 1) { h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; } dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] , ldh); i__1 = jw - 1; i__2 = *ldt + 1; i__3 = *ldh + 1; dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3); /* ==== Accumulate orthogonal matrix in order update */ /* . H and Z, if requested. (A modified version */ /* . of DORGHR that accumulates block Householder */ /* . transformations into V directly might be */ /* . marginally more efficient than the following.) ==== */ if (*ns > 1 && s != 0.) { i__1 = *lwork - jw; dorghr_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info); dgemm_("N", "N", &jw, ns, ns, &c_b11, &v[v_offset], ldv, &t[ t_offset], ldt, &c_b10, &wv[wv_offset], ldwv); dlacpy_("A", &jw, ns, &wv[wv_offset], ldwv, &v[v_offset], ldv); } /* ==== Update vertical slab in H ==== */ if (*wantt) { ltop = 1; } else { ltop = *ktop; } i__1 = kwtop - 1; i__2 = *nv; for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) { /* Computing MIN */ i__3 = *nv, i__4 = kwtop - krow; kln = min(i__3,i__4); dgemm_("N", "N", &kln, &jw, &jw, &c_b11, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b10, &wv[wv_offset], ldwv); dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh); /* L70: */ } /* ==== Update horizontal slab in H ==== */ if (*wantt) { i__2 = *n; i__1 = *nh; for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; kcol += i__1) { /* Computing MIN */ i__3 = *nh, i__4 = *n - kcol + 1; kln = min(i__3,i__4); dgemm_("C", "N", &jw, &kln, &jw, &c_b11, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b10, &t[t_offset], ldt); dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh); /* L80: */ } } /* ==== Update vertical slab in Z ==== */ if (*wantz) { i__1 = *ihiz; i__2 = *nv; for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) { /* Computing MIN */ i__3 = *nv, i__4 = *ihiz - krow + 1; kln = min(i__3,i__4); dgemm_("N", "N", &kln, &jw, &jw, &c_b11, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b10, &wv[ wv_offset], ldwv); dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz); /* L90: */ } } } /* ==== Return the number of deflations ... ==== */ *nd = jw - *ns; /* ==== ... and the number of shifts. (Subtracting */ /* . INFQR from the spike length takes care */ /* . of the case of a rare QR failure while */ /* . calculating eigenvalues of the deflation */ /* . window.) ==== */ *ns -= infqr; /* ==== Return optimal workspace. ==== */ work[1] = (doublereal) lwkopt; /* ==== End of DLAQR2 ==== */ return 0; } /* dlaqr2_ */
/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select, integer *n, doublereal *t, integer *ldt, doublereal *vl, integer * ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep, integer *mm, integer *m, doublereal *work, integer *ldwork, integer * iwork, integer *info) { /* System generated locals */ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, work_dim1, work_offset, i__1, i__2; doublereal d__1, d__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k, n2; doublereal cs; integer nn, ks; doublereal sn, mu, eps, est; integer kase; doublereal cond; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); logical pair; integer ierr; doublereal dumm, prod; integer ifst; doublereal lnrm; integer ilst; doublereal rnrm; extern doublereal dnrm2_(integer *, doublereal *, integer *); doublereal prod1, prod2, scale, delta; extern logical lsame_(char *, char *); integer isave[3]; logical wants; doublereal dummy[1]; extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *); extern doublereal dlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); extern doublereal dlamch_(char *); extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *); doublereal bignum; logical wantbh; extern /* Subroutine */ int dlaqtr_(logical *, logical *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *), dtrexc_(char *, integer * , doublereal *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *); logical somcon; doublereal smlnum; logical wantsp; /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and test the input parameters */ /* Parameter adjustments */ --select; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; --s; --sep; work_dim1 = *ldwork; work_offset = 1 + work_dim1; work -= work_offset; --iwork; /* Function Body */ wantbh = lsame_(job, "B"); wants = lsame_(job, "E") || wantbh; wantsp = lsame_(job, "V") || wantbh; somcon = lsame_(howmny, "S"); *info = 0; if (! wants && ! wantsp) { *info = -1; } else if (! lsame_(howmny, "A") && ! somcon) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*ldt < max(1,*n)) { *info = -6; } else if (*ldvl < 1 || wants && *ldvl < *n) { *info = -8; } else if (*ldvr < 1 || wants && *ldvr < *n) { *info = -10; } else { /* Set M to the number of eigenpairs for which condition numbers */ /* are required, and test MM. */ if (somcon) { *m = 0; pair = FALSE_; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (pair) { pair = FALSE_; } else { if (k < *n) { if (t[k + 1 + k * t_dim1] == 0.) { if (select[k]) { ++(*m); } } else { pair = TRUE_; if (select[k] || select[k + 1]) { *m += 2; } } } else { if (select[*n]) { ++(*m); } } } /* L10: */ } } else { *m = *n; } if (*mm < *m) { *info = -13; } else if (*ldwork < 1 || wantsp && *ldwork < *n) { *info = -16; } } if (*info != 0) { i__1 = -(*info); xerbla_("DTRSNA", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (*n == 1) { if (somcon) { if (! select[1]) { return 0; } } if (wants) { s[1] = 1.; } if (wantsp) { sep[1] = (d__1 = t[t_dim1 + 1], abs(d__1)); } return 0; } /* Get machine constants */ eps = dlamch_("P"); smlnum = dlamch_("S") / eps; bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); ks = 0; pair = FALSE_; i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */ if (pair) { pair = FALSE_; goto L60; } else { if (k < *n) { pair = t[k + 1 + k * t_dim1] != 0.; } } /* Determine whether condition numbers are required for the k-th */ /* eigenpair. */ if (somcon) { if (pair) { if (! select[k] && ! select[k + 1]) { goto L60; } } else { if (! select[k]) { goto L60; } } } ++ks; if (wants) { /* Compute the reciprocal condition number of the k-th */ /* eigenvalue. */ if (! pair) { /* Real eigenvalue. */ prod = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 + 1], &c__1); rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); s[ks] = abs(prod) / (rnrm * lnrm); } else { /* Complex eigenvalue. */ prod1 = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 + 1], &c__1); prod1 += ddot_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], &c__1); prod2 = ddot_(n, &vl[ks * vl_dim1 + 1], &c__1, &vr[(ks + 1) * vr_dim1 + 1], &c__1); prod2 -= ddot_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1, &vr[ks * vr_dim1 + 1], &c__1); d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); rnrm = dlapy2_(&d__1, &d__2); d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); lnrm = dlapy2_(&d__1, &d__2); cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm); s[ks] = cond; s[ks + 1] = cond; } } if (wantsp) { /* Estimate the reciprocal condition number of the k-th */ /* eigenvector. */ /* Copy the matrix T to the array WORK and swap the diagonal */ /* block beginning at T(k,k) to the (1,1) position. */ dlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], ldwork); ifst = k; ilst = 1; dtrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, & ifst, &ilst, &work[(*n + 1) * work_dim1 + 1], &ierr); if (ierr == 1 || ierr == 2) { /* Could not swap because blocks not well separated */ scale = 1.; est = bignum; } else { /* Reordering successful */ if (work[work_dim1 + 2] == 0.) { /* Form C = T22 - lambda*I in WORK(2:N,2:N). */ i__2 = *n; for (i__ = 2; i__ <= i__2; ++i__) { work[i__ + i__ * work_dim1] -= work[work_dim1 + 1]; /* L20: */ } n2 = 1; nn = *n - 1; } else { /* Triangularize the 2 by 2 block by unitary */ /* transformation U = [ cs i*ss ] */ /* [ i*ss cs ]. */ /* such that the (1,1) position of WORK is complex */ /* eigenvalue lambda with positive imaginary part. (2,2) */ /* position of WORK is the complex eigenvalue lambda */ /* with negative imaginary part. */ mu = sqrt((d__1 = work[(work_dim1 << 1) + 1], abs(d__1))) * sqrt((d__2 = work[work_dim1 + 2], abs(d__2))); delta = dlapy2_(&mu, &work[work_dim1 + 2]); cs = mu / delta; sn = -work[work_dim1 + 2] / delta; /* Form */ /* C**T = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] */ /* [ mu ] */ /* [ .. ] */ /* [ .. ] */ /* [ mu ] */ /* where C**T is transpose of matrix C, */ /* and RWORK is stored starting in the N+1-st column of */ /* WORK. */ i__2 = *n; for (j = 3; j <= i__2; ++j) { work[j * work_dim1 + 2] = cs * work[j * work_dim1 + 2] ; work[j + j * work_dim1] -= work[work_dim1 + 1]; /* L30: */ } work[(work_dim1 << 1) + 2] = 0.; work[(*n + 1) * work_dim1 + 1] = mu * 2.; i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { work[i__ + (*n + 1) * work_dim1] = sn * work[(i__ + 1) * work_dim1 + 1]; /* L40: */ } n2 = 2; nn = *n - 1 << 1; } /* Estimate norm(inv(C**T)) */ est = 0.; kase = 0; L50: dlacn2_(&nn, &work[(*n + 2) * work_dim1 + 1], &work[(*n + 4) * work_dim1 + 1], &iwork[1], &est, &kase, isave); if (kase != 0) { if (kase == 1) { if (n2 == 1) { /* Real eigenvalue: solve C**T*x = scale*c. */ i__2 = *n - 1; dlaqtr_(&c_true, &c_true, &i__2, &work[(work_dim1 << 1) + 2], ldwork, dummy, &dumm, &scale, &work[(*n + 4) * work_dim1 + 1], &work[(* n + 6) * work_dim1 + 1], &ierr); } else { /* Complex eigenvalue: solve */ /* C**T*(p+iq) = scale*(c+id) in real arithmetic. */ i__2 = *n - 1; dlaqtr_(&c_true, &c_false, &i__2, &work[( work_dim1 << 1) + 2], ldwork, &work[(*n + 1) * work_dim1 + 1], &mu, &scale, &work[(* n + 4) * work_dim1 + 1], &work[(*n + 6) * work_dim1 + 1], &ierr); } } else { if (n2 == 1) { /* Real eigenvalue: solve C*x = scale*c. */ i__2 = *n - 1; dlaqtr_(&c_false, &c_true, &i__2, &work[( work_dim1 << 1) + 2], ldwork, dummy, & dumm, &scale, &work[(*n + 4) * work_dim1 + 1], &work[(*n + 6) * work_dim1 + 1], & ierr); } else { /* Complex eigenvalue: solve */ /* C*(p+iq) = scale*(c+id) in real arithmetic. */ i__2 = *n - 1; dlaqtr_(&c_false, &c_false, &i__2, &work[( work_dim1 << 1) + 2], ldwork, &work[(*n + 1) * work_dim1 + 1], &mu, &scale, &work[(* n + 4) * work_dim1 + 1], &work[(*n + 6) * work_dim1 + 1], &ierr); } } goto L50; } } sep[ks] = scale / max(est,smlnum); if (pair) { sep[ks + 1] = sep[ks]; } } if (pair) { ++ks; } L60: ; } return 0; /* End of DTRSNA */ }
/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select, integer *n, doublereal *t, integer *ldt, doublereal *vl, integer * ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep, integer *mm, integer *m, doublereal *work, integer *ldwork, integer * iwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= DTRSNA estimates reciprocal condition numbers for specified eigenvalues and/or right eigenvectors of a real upper quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q orthogonal). T must be in Schur canonical form (as returned by DHSEQR), that is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its diagonal elements equal and its off-diagonal elements of opposite sign. Arguments ========= JOB (input) CHARACTER*1 Specifies whether condition numbers are required for eigenvalues (S) or eigenvectors (SEP): = 'E': for eigenvalues only (S); = 'V': for eigenvectors only (SEP); = 'B': for both eigenvalues and eigenvectors (S and SEP). HOWMNY (input) CHARACTER*1 = 'A': compute condition numbers for all eigenpairs; = 'S': compute condition numbers for selected eigenpairs specified by the array SELECT. SELECT (input) LOGICAL array, dimension (N) If HOWMNY = 'S', SELECT specifies the eigenpairs for which condition numbers are required. To select condition numbers for the eigenpair corresponding to a real eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select condition numbers corresponding to a complex conjugate pair of eigenvalues w(j) and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be set to .TRUE.. If HOWMNY = 'A', SELECT is not referenced. N (input) INTEGER The order of the matrix T. N >= 0. T (input) DOUBLE PRECISION array, dimension (LDT,N) The upper quasi-triangular matrix T, in Schur canonical form. LDT (input) INTEGER The leading dimension of the array T. LDT >= max(1,N). VL (input) DOUBLE PRECISION array, dimension (LDVL,M) If JOB = 'E' or 'B', VL must contain left eigenvectors of T (or of any Q*T*Q**T with Q orthogonal), corresponding to the eigenpairs specified by HOWMNY and SELECT. The eigenvectors must be stored in consecutive columns of VL, as returned by DHSEIN or DTREVC. If JOB = 'V', VL is not referenced. LDVL (input) INTEGER The leading dimension of the array VL. LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. VR (input) DOUBLE PRECISION array, dimension (LDVR,M) If JOB = 'E' or 'B', VR must contain right eigenvectors of T (or of any Q*T*Q**T with Q orthogonal), corresponding to the eigenpairs specified by HOWMNY and SELECT. The eigenvectors must be stored in consecutive columns of VR, as returned by DHSEIN or DTREVC. If JOB = 'V', VR is not referenced. LDVR (input) INTEGER The leading dimension of the array VR. LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. S (output) DOUBLE PRECISION array, dimension (MM) If JOB = 'E' or 'B', the reciprocal condition numbers of the selected eigenvalues, stored in consecutive elements of the array. For a complex conjugate pair of eigenvalues two consecutive elements of S are set to the same value. Thus S(j), SEP(j), and the j-th columns of VL and VR all correspond to the same eigenpair (but not in general the j-th eigenpair, unless all eigenpairs are selected). If JOB = 'V', S is not referenced. SEP (output) DOUBLE PRECISION array, dimension (MM) If JOB = 'V' or 'B', the estimated reciprocal condition numbers of the selected eigenvectors, stored in consecutive elements of the array. For a complex eigenvector two consecutive elements of SEP are set to the same value. If the eigenvalues cannot be reordered to compute SEP(j), SEP(j) is set to 0; this can only occur when the true value would be very small anyway. If JOB = 'E', SEP is not referenced. MM (input) INTEGER The number of elements in the arrays S (if JOB = 'E' or 'B') and/or SEP (if JOB = 'V' or 'B'). MM >= M. M (output) INTEGER The number of elements of the arrays S and/or SEP actually used to store the estimated condition numbers. If HOWMNY = 'A', M is set to N. WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+1) If JOB = 'E', WORK is not referenced. LDWORK (input) INTEGER The leading dimension of the array WORK. LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. IWORK (workspace) INTEGER array, dimension (N) If JOB = 'E', IWORK is not referenced. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value Further Details =============== The reciprocal of the condition number of an eigenvalue lambda is defined as S(lambda) = |v'*u| / (norm(u)*norm(v)) where u and v are the right and left eigenvectors of T corresponding to lambda; v' denotes the conjugate-transpose of v, and norm(u) denotes the Euclidean norm. These reciprocal condition numbers always lie between zero (very badly conditioned) and one (very well conditioned). If n = 1, S(lambda) is defined to be 1. An approximate error bound for a computed eigenvalue W(i) is given by EPS * norm(T) / S(i) where EPS is the machine precision. The reciprocal of the condition number of the right eigenvector u corresponding to lambda is defined as follows. Suppose T = ( lambda c ) ( 0 T22 ) Then the reciprocal condition number is SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) where sigma-min denotes the smallest singular value. We approximate the smallest singular value by the reciprocal of an estimate of the one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is defined to be abs(T(1,1)). An approximate error bound for a computed right eigenvector VR(i) is given by EPS * norm(T) / SEP(i) ===================================================================== Decode and test the input parameters Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; static logical c_true = TRUE_; static logical c_false = FALSE_; /* System generated locals */ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, work_dim1, work_offset, i__1, i__2; doublereal d__1, d__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer kase; static doublereal cond; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); static logical pair; static integer ierr; static doublereal dumm, prod; static integer ifst; static doublereal lnrm; static integer ilst; static doublereal rnrm; extern doublereal dnrm2_(integer *, doublereal *, integer *); static doublereal prod1, prod2; static integer i, j, k; static doublereal scale, delta; extern logical lsame_(char *, char *); static logical wants; static doublereal dummy[1]; static integer n2; extern doublereal dlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); static doublereal cs; extern doublereal dlamch_(char *); static integer nn, ks; extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); static doublereal sn, mu; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *); static doublereal bignum; static logical wantbh; extern /* Subroutine */ int dlaqtr_(logical *, logical *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *), dtrexc_(char *, integer * , doublereal *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *); static logical somcon; static doublereal smlnum; static logical wantsp; static doublereal eps, est; #define DUMMY(I) dummy[(I)] #define SELECT(I) select[(I)-1] #define S(I) s[(I)-1] #define SEP(I) sep[(I)-1] #define IWORK(I) iwork[(I)-1] #define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)] #define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)] #define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)] #define WORK(I,J) work[(I)-1 + ((J)-1)* ( *ldwork)] wantbh = lsame_(job, "B"); wants = lsame_(job, "E") || wantbh; wantsp = lsame_(job, "V") || wantbh; somcon = lsame_(howmny, "S"); *info = 0; if (! wants && ! wantsp) { *info = -1; } else if (! lsame_(howmny, "A") && ! somcon) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*ldt < max(1,*n)) { *info = -6; } else if (*ldvl < 1 || wants && *ldvl < *n) { *info = -8; } else if (*ldvr < 1 || wants && *ldvr < *n) { *info = -10; } else { /* Set M to the number of eigenpairs for which condition number s are required, and test MM. */ if (somcon) { *m = 0; pair = FALSE_; i__1 = *n; for (k = 1; k <= *n; ++k) { if (pair) { pair = FALSE_; } else { if (k < *n) { if (T(k+1,k) == 0.) { if (SELECT(k)) { ++(*m); } } else { pair = TRUE_; if (SELECT(k) || SELECT(k + 1)) { *m += 2; } } } else { if (SELECT(*n)) { ++(*m); } } } /* L10: */ } } else { *m = *n; } if (*mm < *m) { *info = -13; } else if (*ldwork < 1 || wantsp && *ldwork < *n) { *info = -16; } } if (*info != 0) { i__1 = -(*info); xerbla_("DTRSNA", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (*n == 1) { if (somcon) { if (! SELECT(1)) { return 0; } } if (wants) { S(1) = 1.; } if (wantsp) { SEP(1) = (d__1 = T(1,1), abs(d__1)); } return 0; } /* Get machine constants */ eps = dlamch_("P"); smlnum = dlamch_("S") / eps; bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); ks = 0; pair = FALSE_; i__1 = *n; for (k = 1; k <= *n; ++k) { /* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */ if (pair) { pair = FALSE_; goto L60; } else { if (k < *n) { pair = T(k+1,k) != 0.; } } /* Determine whether condition numbers are required for the k-t h eigenpair. */ if (somcon) { if (pair) { if (! SELECT(k) && ! SELECT(k + 1)) { goto L60; } } else { if (! SELECT(k)) { goto L60; } } } ++ks; if (wants) { /* Compute the reciprocal condition number of the k-th eigenvalue. */ if (! pair) { /* Real eigenvalue. */ prod = ddot_(n, &VR(1,ks), &c__1, &VL(1,ks), &c__1); rnrm = dnrm2_(n, &VR(1,ks), &c__1); lnrm = dnrm2_(n, &VL(1,ks), &c__1); S(ks) = abs(prod) / (rnrm * lnrm); } else { /* Complex eigenvalue. */ prod1 = ddot_(n, &VR(1,ks), &c__1, &VL(1,ks), &c__1); prod1 += ddot_(n, &VR(1,ks+1), &c__1, &VL(1,ks+1), &c__1); prod2 = ddot_(n, &VL(1,ks), &c__1, &VR(1,ks+1), &c__1); prod2 -= ddot_(n, &VL(1,ks+1), &c__1, &VR(1,ks), &c__1); d__1 = dnrm2_(n, &VR(1,ks), &c__1); d__2 = dnrm2_(n, &VR(1,ks+1), &c__1); rnrm = dlapy2_(&d__1, &d__2); d__1 = dnrm2_(n, &VL(1,ks), &c__1); d__2 = dnrm2_(n, &VL(1,ks+1), &c__1); lnrm = dlapy2_(&d__1, &d__2); cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm); S(ks) = cond; S(ks + 1) = cond; } } if (wantsp) { /* Estimate the reciprocal condition number of the k-th eigenvector. Copy the matrix T to the array WORK and swap the diag onal block beginning at T(k,k) to the (1,1) position. */ dlacpy_("Full", n, n, &T(1,1), ldt, &WORK(1,1), ldwork); ifst = k; ilst = 1; dtrexc_("No Q", n, &WORK(1,1), ldwork, dummy, &c__1, & ifst, &ilst, &WORK(1,*n+1), &ierr); if (ierr == 1 || ierr == 2) { /* Could not swap because blocks not well separat ed */ scale = 1.; est = bignum; } else { /* Reordering successful */ if (WORK(2,1) == 0.) { /* Form C = T22 - lambda*I in WORK(2:N,2:N ). */ i__2 = *n; for (i = 2; i <= *n; ++i) { WORK(i,i) -= WORK(1,1); /* L20: */ } n2 = 1; nn = *n - 1; } else { /* Triangularize the 2 by 2 block by unita ry transformation U = [ cs i*ss ] [ i*ss cs ]. such that the (1,1) position of WORK is complex eigenvalue lambda with positive imagina ry part. (2,2) position of WORK is the complex eigenva lue lambda with negative imaginary part. */ mu = sqrt((d__1 = WORK(1,2), abs(d__1))) * sqrt((d__2 = WORK(2,1), abs(d__2))); delta = dlapy2_(&mu, &WORK(2,1)); cs = mu / delta; sn = -WORK(2,1) / delta; /* Form C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] [ mu ] [ .. ] [ .. ] [ mu ] where C' is conjugate transpose of comp lex matrix C, and RWORK is stored starting in the N+1 -st column of WORK. */ i__2 = *n; for (j = 3; j <= *n; ++j) { WORK(2,j) = cs * WORK(2,j) ; WORK(j,j) -= WORK(1,1); /* L30: */ } WORK(2,2) = 0.; WORK(1,*n+1) = mu * 2.; i__2 = *n - 1; for (i = 2; i <= *n-1; ++i) { WORK(i,*n+1) = sn * WORK(1,i+1); /* L40: */ } n2 = 2; nn = *n - 1 << 1; } /* Estimate norm(inv(C')) */ est = 0.; kase = 0; L50: dlacon_(&nn, &WORK(1,*n+2), &WORK(1,*n+4), &IWORK(1), &est, &kase); if (kase != 0) { if (kase == 1) { if (n2 == 1) { /* Real eigenvalue: solve C' *x = scale*c. */ i__2 = *n - 1; dlaqtr_(&c_true, &c_true, &i__2, &WORK(2,2), ldwork, dummy, &dumm, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr); } else { /* Complex eigenvalue: solve C'*(p+iq) = scale*(c+id) in real arithmetic. */ i__2 = *n - 1; dlaqtr_(&c_true, &c_false, &i__2, &WORK(2,2), ldwork, &WORK(1,*n+1), &mu, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr); } } else { if (n2 == 1) { /* Real eigenvalue: solve C* x = scale*c. */ i__2 = *n - 1; dlaqtr_(&c_false, &c_true, &i__2, &WORK(2,2), ldwork, dummy, & dumm, &scale, &WORK(1,*n+4), &WORK(1,*n+6), & ierr); } else { /* Complex eigenvalue: solve C*(p+iq) = scale*(c+id) i n real arithmetic. */ i__2 = *n - 1; dlaqtr_(&c_false, &c_false, &i__2, &WORK(2,2), ldwork, &WORK(1,*n+1), &mu, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr); } } goto L50; } } SEP(ks) = scale / max(est,smlnum); if (pair) { SEP(ks + 1) = SEP(ks); } } if (pair) { ++ks; } L60: ; } return 0; /* End of DTRSNA */ } /* dtrsna_ */