int main(void) { /* Local scalars */ char side, side_i; char trans, trans_i; lapack_int m, m_i; lapack_int n, n_i; lapack_int ilo, ilo_i; lapack_int ihi, ihi_i; lapack_int lda, lda_i; lapack_int lda_r; lapack_int ldc, ldc_i; lapack_int ldc_r; lapack_int lwork, lwork_i; lapack_int info, info_i; /* Declare scalars */ lapack_int r; lapack_int i; int failed; /* Local arrays */ lapack_complex_double *a = NULL, *a_i = NULL; lapack_complex_double *tau = NULL, *tau_i = NULL; lapack_complex_double *c = NULL, *c_i = NULL; lapack_complex_double *work = NULL, *work_i = NULL; lapack_complex_double *c_save = NULL; lapack_complex_double *a_r = NULL; lapack_complex_double *c_r = NULL; /* Iniitialize the scalar parameters */ init_scalars_zunmhr( &side, &trans, &m, &n, &ilo, &ihi, &lda, &ldc, &lwork ); r = LAPACKE_lsame( side, 'l' ) ? m : n; lda_r = r+2; ldc_r = n+2; side_i = side; trans_i = trans; m_i = m; n_i = n; ilo_i = ilo; ihi_i = ihi; lda_i = lda; ldc_i = ldc; lwork_i = lwork; /* Allocate memory for the LAPACK routine arrays */ a = (lapack_complex_double *) LAPACKE_malloc( lda*m * sizeof(lapack_complex_double) ); tau = (lapack_complex_double *) LAPACKE_malloc( (m-1) * sizeof(lapack_complex_double) ); c = (lapack_complex_double *) LAPACKE_malloc( ldc*n * sizeof(lapack_complex_double) ); work = (lapack_complex_double *) LAPACKE_malloc( lwork * sizeof(lapack_complex_double) ); /* Allocate memory for the C interface function arrays */ a_i = (lapack_complex_double *) LAPACKE_malloc( lda*m * sizeof(lapack_complex_double) ); tau_i = (lapack_complex_double *) LAPACKE_malloc( (m-1) * sizeof(lapack_complex_double) ); c_i = (lapack_complex_double *) LAPACKE_malloc( ldc*n * sizeof(lapack_complex_double) ); work_i = (lapack_complex_double *) LAPACKE_malloc( lwork * sizeof(lapack_complex_double) ); /* Allocate memory for the backup arrays */ c_save = (lapack_complex_double *) LAPACKE_malloc( ldc*n * sizeof(lapack_complex_double) ); /* Allocate memory for the row-major arrays */ a_r = (lapack_complex_double *) LAPACKE_malloc( r*(r+2) * sizeof(lapack_complex_double) ); c_r = (lapack_complex_double *) LAPACKE_malloc( m*(n+2) * sizeof(lapack_complex_double) ); /* Initialize input arrays */ init_a( lda*m, a ); init_tau( (m-1), tau ); init_c( ldc*n, c ); init_work( lwork, work ); /* Backup the ouptut arrays */ for( i = 0; i < ldc*n; i++ ) { c_save[i] = c[i]; } /* Call the LAPACK routine */ zunmhr_( &side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info ); /* Initialize input data, call the column-major middle-level * interface to LAPACK routine and check the results */ for( i = 0; i < lda*m; i++ ) { a_i[i] = a[i]; } for( i = 0; i < (m-1); i++ ) { tau_i[i] = tau[i]; } for( i = 0; i < ldc*n; i++ ) { c_i[i] = c_save[i]; } for( i = 0; i < lwork; i++ ) { work_i[i] = work[i]; } info_i = LAPACKE_zunmhr_work( LAPACK_COL_MAJOR, side_i, trans_i, m_i, n_i, ilo_i, ihi_i, a_i, lda_i, tau_i, c_i, ldc_i, work_i, lwork_i ); failed = compare_zunmhr( c, c_i, info, info_i, ldc, n ); if( failed == 0 ) { printf( "PASSED: column-major middle-level interface to zunmhr\n" ); } else { printf( "FAILED: column-major middle-level interface to zunmhr\n" ); } /* Initialize input data, call the column-major high-level * interface to LAPACK routine and check the results */ for( i = 0; i < lda*m; i++ ) { a_i[i] = a[i]; } for( i = 0; i < (m-1); i++ ) { tau_i[i] = tau[i]; } for( i = 0; i < ldc*n; i++ ) { c_i[i] = c_save[i]; } for( i = 0; i < lwork; i++ ) { work_i[i] = work[i]; } info_i = LAPACKE_zunmhr( LAPACK_COL_MAJOR, side_i, trans_i, m_i, n_i, ilo_i, ihi_i, a_i, lda_i, tau_i, c_i, ldc_i ); failed = compare_zunmhr( c, c_i, info, info_i, ldc, n ); if( failed == 0 ) { printf( "PASSED: column-major high-level interface to zunmhr\n" ); } else { printf( "FAILED: column-major high-level interface to zunmhr\n" ); } /* Initialize input data, call the row-major middle-level * interface to LAPACK routine and check the results */ for( i = 0; i < lda*m; i++ ) { a_i[i] = a[i]; } for( i = 0; i < (m-1); i++ ) { tau_i[i] = tau[i]; } for( i = 0; i < ldc*n; i++ ) { c_i[i] = c_save[i]; } for( i = 0; i < lwork; i++ ) { work_i[i] = work[i]; } LAPACKE_zge_trans( LAPACK_COL_MAJOR, r, r, a_i, lda, a_r, r+2 ); LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, c_i, ldc, c_r, n+2 ); info_i = LAPACKE_zunmhr_work( LAPACK_ROW_MAJOR, side_i, trans_i, m_i, n_i, ilo_i, ihi_i, a_r, lda_r, tau_i, c_r, ldc_r, work_i, lwork_i ); LAPACKE_zge_trans( LAPACK_ROW_MAJOR, m, n, c_r, n+2, c_i, ldc ); failed = compare_zunmhr( c, c_i, info, info_i, ldc, n ); if( failed == 0 ) { printf( "PASSED: row-major middle-level interface to zunmhr\n" ); } else { printf( "FAILED: row-major middle-level interface to zunmhr\n" ); } /* Initialize input data, call the row-major high-level * interface to LAPACK routine and check the results */ for( i = 0; i < lda*m; i++ ) { a_i[i] = a[i]; } for( i = 0; i < (m-1); i++ ) { tau_i[i] = tau[i]; } for( i = 0; i < ldc*n; i++ ) { c_i[i] = c_save[i]; } for( i = 0; i < lwork; i++ ) { work_i[i] = work[i]; } /* Init row_major arrays */ LAPACKE_zge_trans( LAPACK_COL_MAJOR, r, r, a_i, lda, a_r, r+2 ); LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, c_i, ldc, c_r, n+2 ); info_i = LAPACKE_zunmhr( LAPACK_ROW_MAJOR, side_i, trans_i, m_i, n_i, ilo_i, ihi_i, a_r, lda_r, tau_i, c_r, ldc_r ); LAPACKE_zge_trans( LAPACK_ROW_MAJOR, m, n, c_r, n+2, c_i, ldc ); failed = compare_zunmhr( c, c_i, info, info_i, ldc, n ); if( failed == 0 ) { printf( "PASSED: row-major high-level interface to zunmhr\n" ); } else { printf( "FAILED: row-major high-level interface to zunmhr\n" ); } /* Release memory */ if( a != NULL ) { LAPACKE_free( a ); } if( a_i != NULL ) { LAPACKE_free( a_i ); } if( a_r != NULL ) { LAPACKE_free( a_r ); } if( tau != NULL ) { LAPACKE_free( tau ); } if( tau_i != NULL ) { LAPACKE_free( tau_i ); } if( c != NULL ) { LAPACKE_free( c ); } if( c_i != NULL ) { LAPACKE_free( c_i ); } if( c_r != NULL ) { LAPACKE_free( c_r ); } if( c_save != NULL ) { LAPACKE_free( c_save ); } if( work != NULL ) { LAPACKE_free( work ); } if( work_i != NULL ) { LAPACKE_free( work_i ); } return 0; }
/* Subroutine */ int zerrhs_(char *path, integer *nunit) { /* Format strings */ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e" "rror exits\002,\002 (\002,i3,\002 tests done)\002)"; static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes" "ts of the error \002,\002exits ***\002)"; /* System generated locals */ integer i__1; doublereal d__1; /* Local variables */ doublecomplex a[9] /* was [3][3] */, c__[9] /* was [3][3] */; integer i__, j, m; doublereal s[3]; doublecomplex w[9], x[3]; char c2[2]; integer nt; doublecomplex vl[9] /* was [3][3] */, vr[9] /* was [3][3] */; doublereal rw[3]; integer ihi, ilo; logical sel[3]; doublecomplex tau[3]; integer info, ifaill[3]; extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublecomplex *, integer *, integer *), zgebal_(char *, integer *, doublecomplex *, integer *, integer *, integer *, doublereal *, integer *); integer ifailr[3]; extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), chkxer_(char *, integer *, integer *, logical *, logical *), zhsein_(char *, char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * , integer *, doublecomplex *, doublereal *, integer *, integer *, integer *), zhseqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *), ztrevc_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, doublecomplex *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmhr_(char *, char *, integer *, integer *, integer *, integer * , doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); /* Fortran I/O blocks */ static cilist io___1 = { 0, 0, 0, 0, 0 }; static cilist io___22 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___23 = { 0, 0, 0, fmt_9998, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZERRHS tests the error exits for ZGEBAK, CGEBAL, CGEHRD, ZUNGHR, */ /* ZUNMHR, ZHSEQR, CHSEIN, and ZTREVC. */ /* Arguments */ /* ========= */ /* PATH (input) CHARACTER*3 */ /* The LAPACK path name for the routines to be tested. */ /* NUNIT (input) INTEGER */ /* The unit number for output. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Executable Statements .. */ infoc_1.nout = *nunit; io___1.ciunit = infoc_1.nout; s_wsle(&io___1); e_wsle(); s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); /* Set the variables to innocuous values. */ for (j = 1; j <= 3; ++j) { for (i__ = 1; i__ <= 3; ++i__) { i__1 = i__ + j * 3 - 4; d__1 = 1. / (doublereal) (i__ + j); a[i__1].r = d__1, a[i__1].i = 0.; /* L10: */ } sel[j - 1] = TRUE_; /* L20: */ } infoc_1.ok = TRUE_; nt = 0; /* Test error exits of the nonsymmetric eigenvalue routines. */ if (lsamen_(&c__2, c2, "HS")) { /* ZGEBAL */ s_copy(srnamc_1.srnamt, "ZGEBAL", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info); chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info); chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info); chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 3; /* ZGEBAK */ s_copy(srnamc_1.srnamt, "ZGEBAK", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; zgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 9; zgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info); chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 9; /* ZGEHRD */ s_copy(srnamc_1.srnamt, "ZGEHRD", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info); chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; zgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info); chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 7; /* ZUNGHR */ s_copy(srnamc_1.srnamt, "ZUNGHR", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zunghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zunghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zunghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zunghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zunghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; zunghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info); chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 7; /* ZUNMHR */ s_copy(srnamc_1.srnamt, "ZUNMHR", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zunmhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zunmhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zunmhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zunmhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunmhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunmhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunmhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, & c__1, w, &c__2, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunmhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, & c__2, w, &c__2, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; zunmhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; zunmhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; zunmhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; zunmhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, & c__2, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; zunmhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; zunmhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; zunmhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; zunmhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, & c__2, w, &c__1, &info); chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 16; /* ZHSEQR */ s_copy(srnamc_1.srnamt, "ZHSEQR", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zhseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zhseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zhseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zhseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, x, c__, &c__1, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zhseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, x, c__, &c__1, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zhseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zhseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, x, c__, &c__1, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; zhseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, x, c__, &c__2, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; zhseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, x, c__, &c__1, w, & c__1, &info); chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 9; /* ZHSEIN */ s_copy(srnamc_1.srnamt, "ZHSEIN", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zhsein_("/", "N", "N", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, &c__0, &m, w, rw, ifaill, ifailr, &info); chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zhsein_("R", "/", "N", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, &c__0, &m, w, rw, ifaill, ifailr, &info); chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zhsein_("R", "N", "/", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, &c__0, &m, w, rw, ifaill, ifailr, &info); chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zhsein_("R", "N", "N", sel, &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1, &c__0, &m, w, rw, ifaill, ifailr, &info); chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; zhsein_("R", "N", "N", sel, &c__2, a, &c__1, x, vl, &c__1, vr, &c__2, &c__4, &m, w, rw, ifaill, ifailr, &info); chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; zhsein_("L", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__1, &c__4, &m, w, rw, ifaill, ifailr, &info); chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 12; zhsein_("R", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__1, &c__4, &m, w, rw, ifaill, ifailr, &info); chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; zhsein_("R", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__2, &c__1, &m, w, rw, ifaill, ifailr, &info); chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 8; /* ZTREVC */ s_copy(srnamc_1.srnamt, "ZTREVC", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; ztrevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, & m, w, rw, &info); chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; ztrevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, & m, w, rw, &info); chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; ztrevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, & m, w, rw, &info); chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; ztrevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, & m, w, rw, &info); chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; ztrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, & m, w, rw, &info); chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; ztrevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, & m, w, rw, &info); chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; ztrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, & m, w, rw, &info); chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 7; } /* Print a summary line. */ if (infoc_1.ok) { io___22.ciunit = infoc_1.nout; s_wsfe(&io___22); do_fio(&c__1, path, (ftnlen)3); do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer)); e_wsfe(); } else { io___23.ciunit = infoc_1.nout; s_wsfe(&io___23); do_fio(&c__1, path, (ftnlen)3); e_wsfe(); } return 0; /* End of ZERRHS */ } /* zerrhs_ */
/* Subroutine */ int zlaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublecomplex *h__, integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__, integer *ldz, integer *ns, integer *nd, doublecomplex *sh, doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t, integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv, doublecomplex *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; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ integer i__, j; doublecomplex s; integer jw; doublereal foo; integer kln; doublecomplex tau; integer knt; doublereal ulp; integer lwk1, lwk2; doublecomplex beta; integer kcol, info, ifst, ilst, ltop, krow; extern /* Subroutine */ int zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); integer infqr; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); integer kwtop; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); extern doublereal dlamch_(char *); doublereal safmin, safmax; extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *, logical *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); doublereal smlnum; extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *); integer lwkopt; extern /* Subroutine */ int zunmhr_(char *, char *, integer *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * ); /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ================================================================ */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. 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; --sh; 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; // , expr subst jw = min(i__1,i__2); if (jw <= 2) { lwkopt = 1; } else { /* ==== Workspace query call to ZGEHRD ==== */ i__1 = jw - 1; zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info); lwk1 = (integer) work[1].r; /* ==== Workspace query call to ZUNMHR ==== */ i__1 = jw - 1; zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[1], &c_n1, &info); lwk2 = (integer) work[1].r; /* ==== Optimal workspace ==== */ lwkopt = jw + max(lwk1,lwk2); } /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { d__1 = (doublereal) lwkopt; z__1.r = d__1; z__1.i = 0.; // , expr subst work[1].r = z__1.r; work[1].i = z__1.i; // , expr subst return 0; } /* ==== Nothing to do ... */ /* ... for an empty active block ... ==== */ *ns = 0; *nd = 0; work[1].r = 1.; work[1].i = 0.; // , expr subst 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; // , expr subst jw = min(i__1,i__2); kwtop = *kbot - jw + 1; if (kwtop == *ktop) { s.r = 0.; s.i = 0.; // , expr subst } else { i__1 = kwtop + (kwtop - 1) * h_dim1; s.r = h__[i__1].r; s.i = h__[i__1].i; // , expr subst } if (*kbot == kwtop) { /* ==== 1-by-1 deflation window: not much to do ==== */ i__1 = kwtop; i__2 = kwtop + kwtop * h_dim1; sh[i__1].r = h__[i__2].r; sh[i__1].i = h__[i__2].i; // , expr subst *ns = 1; *nd = 0; /* Computing MAX */ i__1 = kwtop + kwtop * h_dim1; d__5 = smlnum; d__6 = ulp * ((d__1 = h__[i__1].r, f2c_abs(d__1)) + (d__2 = d_imag(&h__[kwtop + kwtop * h_dim1]), f2c_abs(d__2))); // , expr subst if ((d__3 = s.r, f2c_abs(d__3)) + (d__4 = d_imag(&s), f2c_abs(d__4)) <= max( d__5,d__6)) { *ns = 0; *nd = 1; if (kwtop > *ktop) { i__1 = kwtop + (kwtop - 1) * h_dim1; h__[i__1].r = 0.; h__[i__1].i = 0.; // , expr subst } } work[1].r = 1.; work[1].i = 0.; // , expr subst 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.) ==== */ zlacpy_("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; zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3); zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv); zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); /* ==== Deflation detection loop ==== */ *ns = jw; ilst = infqr + 1; i__1 = jw; for (knt = infqr + 1; knt <= i__1; ++knt) { /* ==== Small spike tip deflation test ==== */ i__2 = *ns + *ns * t_dim1; foo = (d__1 = t[i__2].r, f2c_abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns * t_dim1]), f2c_abs(d__2)); if (foo == 0.) { foo = (d__1 = s.r, f2c_abs(d__1)) + (d__2 = d_imag(&s), f2c_abs(d__2)); } i__2 = *ns * v_dim1 + 1; /* Computing MAX */ d__5 = smlnum; d__6 = ulp * foo; // , expr subst if (((d__1 = s.r, f2c_abs(d__1)) + (d__2 = d_imag(&s), f2c_abs(d__2))) * (( d__3 = v[i__2].r, f2c_abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1 + 1]), f2c_abs(d__4))) <= max(d__5,d__6)) { /* ==== One more converged eigenvalue ==== */ --(*ns); } else { /* ==== One undeflatable eigenvalue. Move it up out of the */ /* . way. (ZTREXC can not fail in this case.) ==== */ ifst = *ns; ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, & ilst, &info); ++ilst; } /* L10: */ } /* ==== Return to Hessenberg form ==== */ if (*ns == 0) { s.r = 0.; s.i = 0.; // , expr subst } if (*ns < jw) { /* ==== sorting the diagonal of T improves accuracy for */ /* . graded matrices. ==== */ i__1 = *ns; for (i__ = infqr + 1; i__ <= i__1; ++i__) { ifst = i__; i__2 = *ns; for (j = i__ + 1; j <= i__2; ++j) { i__3 = j + j * t_dim1; i__4 = ifst + ifst * t_dim1; if ((d__1 = t[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag(&t[j + j * t_dim1]), f2c_abs(d__2)) > (d__3 = t[i__4].r, f2c_abs(d__3)) + (d__4 = d_imag(&t[ifst + ifst * t_dim1]), f2c_abs(d__4)) ) { ifst = j; } /* L20: */ } ilst = i__; if (ifst != ilst) { ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &info); } /* L30: */ } } /* ==== Restore shift/eigenvalue array from T ==== */ i__1 = jw; for (i__ = infqr + 1; i__ <= i__1; ++i__) { i__2 = kwtop + i__ - 1; i__3 = i__ + i__ * t_dim1; sh[i__2].r = t[i__3].r; sh[i__2].i = t[i__3].i; // , expr subst /* L40: */ } if (*ns < jw || s.r == 0. && s.i == 0.) { if (*ns > 1 && (s.r != 0. || s.i != 0.)) { /* ==== Reflect spike back into lower triangle ==== */ zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); i__1 = *ns; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; d_cnjg(&z__1, &work[i__]); work[i__2].r = z__1.r; work[i__2].i = z__1.i; // , expr subst /* L50: */ } beta.r = work[1].r; beta.i = work[1].i; // , expr subst zlarfg_(ns, &beta, &work[2], &c__1, &tau); work[1].r = 1.; work[1].i = 0.; // , expr subst i__1 = jw - 2; i__2 = jw - 2; zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt); d_cnjg(&z__1, &tau); zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, & work[jw + 1]); zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]); i__1 = *lwork - jw; zgehrd_(&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) { i__1 = kwtop + (kwtop - 1) * h_dim1; d_cnjg(&z__2, &v[v_dim1 + 1]); z__1.r = s.r * z__2.r - s.i * z__2.i; z__1.i = s.r * z__2.i + s.i * z__2.r; // , expr subst h__[i__1].r = z__1.r; h__[i__1].i = z__1.i; // , expr subst } zlacpy_("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; zcopy_(&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. ==== */ if (*ns > 1 && (s.r != 0. || s.i != 0.)) { i__1 = *lwork - jw; zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[jw + 1], &i__1, &info); } /* ==== 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; // , expr subst kln = min(i__3,i__4); zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset], ldwv); zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh); /* L60: */ } /* ==== 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; // , expr subst kln = min(i__3,i__4); zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset], ldt); zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh); /* L70: */ } } /* ==== 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; // , expr subst kln = min(i__3,i__4); zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset] , ldwv); zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz); /* L80: */ } } } /* ==== 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. ==== */ d__1 = (doublereal) lwkopt; z__1.r = d__1; z__1.i = 0.; // , expr subst work[1].r = z__1.r; work[1].i = z__1.i; // , expr subst /* ==== End of ZLAQR2 ==== */ return 0; }
/* Subroutine */ int zchkhs_(integer *nsizes, integer *nn, integer *ntypes, logical *dotype, integer *iseed, doublereal *thresh, integer *nounit, doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *t1, doublecomplex *t2, doublecomplex *u, integer *ldu, doublecomplex * z__, doublecomplex *uz, doublecomplex *w1, doublecomplex *w3, doublecomplex *evectl, doublecomplex *evectr, doublecomplex *evecty, doublecomplex *evectx, doublecomplex *uu, doublecomplex *tau, doublecomplex *work, integer *nwork, doublereal *rwork, integer * iwork, logical *select, doublereal *result, integer *info) { /* Initialized data */ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 }; static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 }; static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 }; static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 }; /* Format strings */ static char fmt_9999[] = "(\002 ZCHKHS: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED=" "(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9998[] = "(\002 ZCHKHS: \002,a,\002 Eigenvectors from" " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of " "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002," "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9997[] = "(\002 ZCHKHS: Selected \002,a,\002 Eigenvector" "s from \002,a,\002 do not match other eigenvectors \002,9x,\002N=" "\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5," "\002)\002)"; /* System generated locals */ integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1, evectr_offset, evectx_dim1, evectx_offset, evecty_dim1, evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1, t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1, uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2; doublecomplex z__1; /* Builtin functions */ double sqrt(doublereal); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); double z_abs(doublecomplex *); /* Local variables */ integer i__, j, k, n, n1, jj, in, ihi, ilo; doublereal ulp, cond; integer jcol, nmax; doublereal unfl, ovfl, temp1, temp2; logical badnn, match; integer imode; doublereal dumma[4]; integer iinfo; doublereal conds; extern /* Subroutine */ int zget10_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, doublereal *); doublereal aninv, anorm; extern /* Subroutine */ int zget22_(char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); integer nmats, jsize, nerrs, itype, jtype, ntest; extern /* Subroutine */ int zhst01_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *), zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); doublereal rtulp; extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); extern doublereal dlamch_(char *); doublecomplex cdumma[4]; integer idumma[1]; extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *); integer ioldsd[4]; extern /* Subroutine */ int xerbla_(char *, integer *), zgehrd_( integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), dlasum_( char *, integer *, integer *, integer *), zlatme_(integer *, char *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, char *, char *, char *, char *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *), zhsein_(char *, char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * , integer *, doublecomplex *, doublereal *, integer *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatmr_( integer *, integer *, char *, integer *, char *, doublecomplex *, integer *, doublereal *, doublecomplex *, char *, char *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *, doublereal *, char *, integer *, integer *, integer *, doublereal *, doublereal *, char *, doublecomplex *, integer *, integer *, integer *); doublereal rtunfl, rtovfl, rtulpi, ulpinv; integer mtypes, ntestt; extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, char *, doublecomplex *, integer *, doublecomplex *, integer *), ztrevc_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, doublecomplex *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer * ), zunmhr_(char *, char *, integer *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); /* 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 */ /* ======= */ /* ZCHKHS checks the nonsymmetric eigenvalue problem routines. */ /* ZGEHRD factors A as U H U' , where ' means conjugate */ /* transpose, H is hessenberg, and U is unitary. */ /* ZUNGHR generates the unitary matrix U. */ /* ZUNMHR multiplies a matrix by the unitary matrix U. */ /* ZHSEQR factors H as Z T Z' , where Z is unitary and T */ /* is upper triangular. It also computes the eigenvalues, */ /* w(1), ..., w(n); we define a diagonal matrix W whose */ /* (diagonal) entries are the eigenvalues. */ /* ZTREVC computes the left eigenvector matrix L and the */ /* right eigenvector matrix R for the matrix T. The */ /* columns of L are the complex conjugates of the left */ /* eigenvectors of T. The columns of R are the right */ /* eigenvectors of T. L is lower triangular, and R is */ /* upper triangular. */ /* ZHSEIN computes the left eigenvector matrix Y and the */ /* right eigenvector matrix X for the matrix H. The */ /* columns of Y are the complex conjugates of the left */ /* eigenvectors of H. The columns of X are the right */ /* eigenvectors of H. Y is lower triangular, and X is */ /* upper triangular. */ /* When ZCHKHS is called, a number of matrix "sizes" ("n's") and a */ /* number of matrix "types" are specified. For each size ("n") */ /* and each type of matrix, one matrix will be generated and used */ /* to test the nonsymmetric eigenroutines. For each matrix, 14 */ /* tests will be performed: */ /* (1) | A - U H U**H | / ( |A| n ulp ) */ /* (2) | I - UU**H | / ( n ulp ) */ /* (3) | H - Z T Z**H | / ( |H| n ulp ) */ /* (4) | I - ZZ**H | / ( n ulp ) */ /* (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) */ /* (6) | I - UZ (UZ)**H | / ( n ulp ) */ /* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */ /* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */ /* (9) | TR - RW | / ( |T| |R| ulp ) */ /* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */ /* (11) | HX - XW | / ( |H| |X| ulp ) */ /* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */ /* (13) | AX - XW | / ( |A| |X| ulp ) */ /* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */ /* The "sizes" are specified by an array NN(1:NSIZES); the value of */ /* each element NN(j) specifies one size. */ /* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */ /* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */ /* Currently, the list of possible types is: */ /* (1) The zero matrix. */ /* (2) The identity matrix. */ /* (3) A (transposed) Jordan block, with 1's on the diagonal. */ /* (4) A diagonal matrix with evenly spaced entries */ /* 1, ..., ULP and random complex angles. */ /* (ULP = (first number larger than 1) - 1 ) */ /* (5) A diagonal matrix with geometrically spaced entries */ /* 1, ..., ULP and random complex angles. */ /* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */ /* and random complex angles. */ /* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */ /* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */ /* (9) A matrix of the form U' T U, where U is unitary and */ /* T has evenly spaced entries 1, ..., ULP with random complex */ /* angles on the diagonal and random O(1) entries in the upper */ /* triangle. */ /* (10) A matrix of the form U' T U, where U is unitary and */ /* T has geometrically spaced entries 1, ..., ULP with random */ /* complex angles on the diagonal and random O(1) entries in */ /* the upper triangle. */ /* (11) A matrix of the form U' T U, where U is unitary and */ /* T has "clustered" entries 1, ULP,..., ULP with random */ /* complex angles on the diagonal and random O(1) entries in */ /* the upper triangle. */ /* (12) A matrix of the form U' T U, where U is unitary and */ /* T has complex eigenvalues randomly chosen from */ /* ULP < |z| < 1 and random O(1) entries in the upper */ /* triangle. */ /* (13) A matrix of the form X' T X, where X has condition */ /* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */ /* with random complex angles on the diagonal and random O(1) */ /* entries in the upper triangle. */ /* (14) A matrix of the form X' T X, where X has condition */ /* SQRT( ULP ) and T has geometrically spaced entries */ /* 1, ..., ULP with random complex angles on the diagonal */ /* and random O(1) entries in the upper triangle. */ /* (15) A matrix of the form X' T X, where X has condition */ /* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */ /* with random complex angles on the diagonal and random O(1) */ /* entries in the upper triangle. */ /* (16) A matrix of the form X' T X, where X has condition */ /* SQRT( ULP ) and T has complex eigenvalues randomly chosen */ /* from ULP < |z| < 1 and random O(1) entries in the upper */ /* triangle. */ /* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */ /* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */ /* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */ /* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */ /* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */ /* Arguments */ /* ========== */ /* NSIZES - INTEGER */ /* The number of sizes of matrices to use. If it is zero, */ /* ZCHKHS does nothing. It must be at least zero. */ /* Not modified. */ /* NN - INTEGER array, dimension (NSIZES) */ /* An array containing the sizes to be used for the matrices. */ /* Zero values will be skipped. The values must be at least */ /* zero. */ /* Not modified. */ /* NTYPES - INTEGER */ /* The number of elements in DOTYPE. If it is zero, ZCHKHS */ /* does nothing. It must be at least zero. If it is MAXTYP+1 */ /* and NSIZES is 1, then an additional type, MAXTYP+1 is */ /* defined, which is to use whatever matrix is in A. This */ /* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */ /* DOTYPE(MAXTYP+1) is .TRUE. . */ /* Not modified. */ /* DOTYPE - LOGICAL array, dimension (NTYPES) */ /* If DOTYPE(j) is .TRUE., then for each size in NN a */ /* matrix of that size and of type j will be generated. */ /* If NTYPES is smaller than the maximum number of types */ /* defined (PARAMETER MAXTYP), then types NTYPES+1 through */ /* MAXTYP will not be generated. If NTYPES is larger */ /* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */ /* will be ignored. */ /* Not modified. */ /* ISEED - INTEGER array, dimension (4) */ /* On entry ISEED specifies the seed of the random number */ /* generator. The array elements should be between 0 and 4095; */ /* if not they will be reduced mod 4096. Also, ISEED(4) must */ /* be odd. The random number generator uses a linear */ /* congruential sequence limited to small integers, and so */ /* should produce machine independent random numbers. The */ /* values of ISEED are changed on exit, and can be used in the */ /* next call to ZCHKHS to continue the same random number */ /* sequence. */ /* Modified. */ /* THRESH - DOUBLE PRECISION */ /* A test will count as "failed" if the "error", computed as */ /* described above, exceeds THRESH. Note that the error */ /* is scaled to be O(1), so THRESH should be a reasonably */ /* small multiple of 1, e.g., 10 or 100. In particular, */ /* it should not depend on the precision (single vs. double) */ /* or the size of the matrix. It must be at least zero. */ /* Not modified. */ /* NOUNIT - INTEGER */ /* The FORTRAN unit number for printing out error messages */ /* (e.g., if a routine returns IINFO not equal to 0.) */ /* Not modified. */ /* A - COMPLEX*16 array, dimension (LDA,max(NN)) */ /* Used to hold the matrix whose eigenvalues are to be */ /* computed. On exit, A contains the last matrix actually */ /* used. */ /* Modified. */ /* LDA - INTEGER */ /* The leading dimension of A, H, T1 and T2. It must be at */ /* least 1 and at least max( NN ). */ /* Not modified. */ /* H - COMPLEX*16 array, dimension (LDA,max(NN)) */ /* The upper hessenberg matrix computed by ZGEHRD. On exit, */ /* H contains the Hessenberg form of the matrix in A. */ /* Modified. */ /* T1 - COMPLEX*16 array, dimension (LDA,max(NN)) */ /* The Schur (="quasi-triangular") matrix computed by ZHSEQR */ /* if Z is computed. On exit, T1 contains the Schur form of */ /* the matrix in A. */ /* Modified. */ /* T2 - COMPLEX*16 array, dimension (LDA,max(NN)) */ /* The Schur matrix computed by ZHSEQR when Z is not computed. */ /* This should be identical to T1. */ /* Modified. */ /* LDU - INTEGER */ /* The leading dimension of U, Z, UZ and UU. It must be at */ /* least 1 and at least max( NN ). */ /* Not modified. */ /* U - COMPLEX*16 array, dimension (LDU,max(NN)) */ /* The unitary matrix computed by ZGEHRD. */ /* Modified. */ /* Z - COMPLEX*16 array, dimension (LDU,max(NN)) */ /* The unitary matrix computed by ZHSEQR. */ /* Modified. */ /* UZ - COMPLEX*16 array, dimension (LDU,max(NN)) */ /* The product of U times Z. */ /* Modified. */ /* W1 - COMPLEX*16 array, dimension (max(NN)) */ /* The eigenvalues of A, as computed by a full Schur */ /* decomposition H = Z T Z'. On exit, W1 contains the */ /* eigenvalues of the matrix in A. */ /* Modified. */ /* W3 - COMPLEX*16 array, dimension (max(NN)) */ /* The eigenvalues of A, as computed by a partial Schur */ /* decomposition (Z not computed, T only computed as much */ /* as is necessary for determining eigenvalues). On exit, */ /* W3 contains the eigenvalues of the matrix in A, possibly */ /* perturbed by ZHSEIN. */ /* Modified. */ /* EVECTL - COMPLEX*16 array, dimension (LDU,max(NN)) */ /* The conjugate transpose of the (upper triangular) left */ /* eigenvector matrix for the matrix in T1. */ /* Modified. */ /* EVEZTR - COMPLEX*16 array, dimension (LDU,max(NN)) */ /* The (upper triangular) right eigenvector matrix for the */ /* matrix in T1. */ /* Modified. */ /* EVECTY - COMPLEX*16 array, dimension (LDU,max(NN)) */ /* The conjugate transpose of the left eigenvector matrix */ /* for the matrix in H. */ /* Modified. */ /* EVECTX - COMPLEX*16 array, dimension (LDU,max(NN)) */ /* The right eigenvector matrix for the matrix in H. */ /* Modified. */ /* UU - COMPLEX*16 array, dimension (LDU,max(NN)) */ /* Details of the unitary matrix computed by ZGEHRD. */ /* Modified. */ /* TAU - COMPLEX*16 array, dimension (max(NN)) */ /* Further details of the unitary matrix computed by ZGEHRD. */ /* Modified. */ /* WORK - COMPLEX*16 array, dimension (NWORK) */ /* Workspace. */ /* Modified. */ /* NWORK - INTEGER */ /* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */ /* RWORK - DOUBLE PRECISION array, dimension (max(NN)) */ /* Workspace. Could be equivalenced to IWORK, but not SELECT. */ /* Modified. */ /* IWORK - INTEGER array, dimension (max(NN)) */ /* Workspace. */ /* Modified. */ /* SELECT - LOGICAL array, dimension (max(NN)) */ /* Workspace. Could be equivalenced to IWORK, but not RWORK. */ /* Modified. */ /* RESULT - DOUBLE PRECISION array, dimension (14) */ /* The values computed by the fourteen tests described above. */ /* The values are currently limited to 1/ulp, to avoid */ /* overflow. */ /* Modified. */ /* INFO - INTEGER */ /* If 0, then everything ran OK. */ /* -1: NSIZES < 0 */ /* -2: Some NN(j) < 0 */ /* -3: NTYPES < 0 */ /* -6: THRESH < 0 */ /* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */ /* -14: LDU < 1 or LDU < NMAX. */ /* -26: NWORK too small. */ /* If ZLATMR, CLATMS, or CLATME returns an error code, the */ /* absolute value of it is returned. */ /* If 1, then ZHSEQR could not find all the shifts. */ /* If 2, then the EISPACK code (for small blocks) failed. */ /* If >2, then 30*N iterations were not enough to find an */ /* eigenvalue or to decompose the problem. */ /* Modified. */ /* ----------------------------------------------------------------------- */ /* Some Local Variables and Parameters: */ /* ---- ----- --------- --- ---------- */ /* ZERO, ONE Real 0 and 1. */ /* MAXTYP The number of types defined. */ /* MTEST The number of tests defined: care must be taken */ /* that (1) the size of RESULT, (2) the number of */ /* tests actually performed, and (3) MTEST agree. */ /* NTEST The number of tests performed on this matrix */ /* so far. This should be less than MTEST, and */ /* equal to it by the last test. It will be less */ /* if any of the routines being tested indicates */ /* that it could not compute the matrices that */ /* would be tested. */ /* NMAX Largest value in NN. */ /* NMATS The number of matrices generated so far. */ /* NERRS The number of tests which have exceeded THRESH */ /* so far (computed by DLAFTS). */ /* COND, CONDS, */ /* IMODE Values to be passed to the matrix generators. */ /* ANORM Norm of A; passed to matrix generators. */ /* OVFL, UNFL Overflow and underflow thresholds. */ /* ULP, ULPINV Finest relative precision and its inverse. */ /* RTOVFL, RTUNFL, */ /* RTULP, RTULPI Square roots of the previous 4 values. */ /* The following four arrays decode JTYPE: */ /* KTYPE(j) The general type (1-10) for type "j". */ /* KMODE(j) The MODE value to be passed to the matrix */ /* generator for type "j". */ /* KMAGN(j) The order of magnitude ( O(1), */ /* O(overflow^(1/2) ), O(underflow^(1/2) ) */ /* KCONDS(j) Selects whether CONDS is to be 1 or */ /* 1/sqrt(ulp). (0 means irrelevant.) */ /* ===================================================================== */ /* .. 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.) { *info = -6; } else if (*lda <= 1 || *lda < nmax) { *info = -9; } else if (*ldu <= 1 || *ldu < nmax) { *info = -14; } else if ((nmax << 2) * nmax + 2 > *nwork) { *info = -26; } if (*info != 0) { i__1 = -(*info); xerbla_("ZCHKHS", &i__1); return 0; } /* Quick return if possible */ if (*nsizes == 0 || *ntypes == 0) { return 0; } /* More important constants */ unfl = dlamch_("Safe minimum"); ovfl = dlamch_("Overflow"); dlabad_(&unfl, &ovfl); ulp = dlamch_("Epsilon") * dlamch_("Base"); ulpinv = 1. / ulp; rtunfl = sqrt(unfl); rtovfl = sqrt(ovfl); rtulp = sqrt(ulp); rtulpi = 1. / rtulp; /* Loop over sizes, types */ nerrs = 0; nmats = 0; i__1 = *nsizes; for (jsize = 1; jsize <= i__1; ++jsize) { n = nn[jsize]; n1 = max(1,n); aninv = 1. / (doublereal) n1; if (*nsizes != 1) { mtypes = min(21,*ntypes); } else { mtypes = min(22,*ntypes); } i__2 = mtypes; for (jtype = 1; jtype <= i__2; ++jtype) { if (! dotype[jtype]) { goto L250; } ++nmats; ntest = 0; /* Save ISEED in case of an error. */ for (j = 1; j <= 4; ++j) { ioldsd[j - 1] = iseed[j]; /* L20: */ } /* Initialize RESULT */ for (j = 1; j <= 14; ++j) { result[j] = 0.; /* L30: */ } /* Compute "A" */ /* Control parameters: */ /* KMAGN KCONDS KMODE KTYPE */ /* =1 O(1) 1 clustered 1 zero */ /* =2 large large clustered 2 identity */ /* =3 small exponential Jordan */ /* =4 arithmetic diagonal, (w/ eigenvalues) */ /* =5 random log hermitian, w/ eigenvalues */ /* =6 random general, w/ eigenvalues */ /* =7 random diagonal */ /* =8 random hermitian */ /* =9 random general */ /* =10 random triangular */ if (mtypes > 21) { goto L100; } itype = ktype[jtype - 1]; imode = kmode[jtype - 1]; /* Compute norm */ switch (kmagn[jtype - 1]) { case 1: goto L40; case 2: goto L50; case 3: goto L60; } L40: anorm = 1.; goto L70; L50: anorm = rtovfl * ulp * aninv; goto L70; L60: anorm = rtunfl * n * ulpinv; goto L70; L70: zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda); iinfo = 0; cond = ulpinv; /* Special Matrices */ if (itype == 1) { /* Zero */ iinfo = 0; } else if (itype == 2) { /* Identity */ i__3 = n; for (jcol = 1; jcol <= i__3; ++jcol) { i__4 = jcol + jcol * a_dim1; a[i__4].r = anorm, a[i__4].i = 0.; /* L80: */ } } else if (itype == 3) { /* Jordan Block */ i__3 = n; for (jcol = 1; jcol <= i__3; ++jcol) { i__4 = jcol + jcol * a_dim1; a[i__4].r = anorm, a[i__4].i = 0.; if (jcol > 1) { i__4 = jcol + (jcol - 1) * a_dim1; a[i__4].r = 1., a[i__4].i = 0.; } /* L90: */ } } else if (itype == 4) { /* Diagonal Matrix, [Eigen]values Specified */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, & c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[ 1], &iinfo); } else if (itype == 5) { /* Hermitian, eigenvalues specified */ zlatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond, &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], & iinfo); } else if (itype == 6) { /* General, eigenvalues specified */ if (kconds[jtype - 1] == 1) { conds = 1.; } else if (kconds[jtype - 1] == 2) { conds = rtulpi; } else { conds = 0.; } zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2, " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n, &anorm, &a[a_offset], lda, &work[n + 1], &iinfo); } else if (itype == 7) { /* Diagonal, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, & c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[ 1], &iinfo); } else if (itype == 8) { /* Hermitian, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, & c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); } else if (itype == 9) { /* General, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, & c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); } else if (itype == 10) { /* Triangular, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[( n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, & c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); } else { iinfo = 1; } if (iinfo != 0) { io___35.ciunit = *nounit; s_wsfe(&io___35); do_fio(&c__1, "Generator", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); return 0; } L100: /* Call ZGEHRD to compute H and U, do tests. */ zlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda); ntest = 1; ilo = 1; ihi = n; i__3 = *nwork - n; zgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n + 1], &i__3, &iinfo); if (iinfo != 0) { result[1] = ulpinv; io___38.ciunit = *nounit; s_wsfe(&io___38); do_fio(&c__1, "ZGEHRD", (ftnlen)6); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } i__3 = n - 1; for (j = 1; j <= i__3; ++j) { i__4 = j + 1 + j * uu_dim1; uu[i__4].r = 0., uu[i__4].i = 0.; 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., h__[i__5].i = 0.; /* L110: */ } /* L120: */ } i__3 = n - 1; zcopy_(&i__3, &work[1], &c__1, &tau[1], &c__1); i__3 = *nwork - n; zunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1], &i__3, &iinfo); ntest = 2; zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, & u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]); /* Call ZHSEQR to compute T1, T2 and Z, do tests. */ /* Eigenvalues only (W3) */ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda); ntest = 3; result[3] = ulpinv; zhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], & uz[uz_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0) { io___40.ciunit = *nounit; s_wsfe(&io___40); do_fio(&c__1, "ZHSEQR(E)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); if (iinfo <= n + 2) { *info = abs(iinfo); goto L240; } } /* Eigenvalues (W1) and Full Schur Form (T2) */ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda); zhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], & uz[uz_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0 && iinfo <= n + 2) { io___41.ciunit = *nounit; s_wsfe(&io___41); do_fio(&c__1, "ZHSEQR(S)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } /* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda); zlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu); zhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], & uz[uz_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0 && iinfo <= n + 2) { io___42.ciunit = *nounit; s_wsfe(&io___42); do_fio(&c__1, "ZHSEQR(V)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } /* Compute Z = U' UZ */ zgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[ uz_offset], ldu, &c_b1, &z__[z_offset], ldu); ntest = 8; /* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */ /* and 4: | I - Z Z' | / ( n ulp ) */ zhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda, &z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[ 3]); /* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */ /* and 6: | I - UZ (UZ)' | / ( n ulp ) */ zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, & uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5] ); /* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */ zget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1] , &rwork[1], &result[7]); /* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */ temp1 = 0.; temp2 = 0.; i__3 = n; for (j = 1; j <= i__3; ++j) { /* Computing MAX */ d__1 = temp1, d__2 = z_abs(&w1[j]), d__1 = max(d__1,d__2), d__2 = z_abs(&w3[j]); temp1 = max(d__1,d__2); /* Computing MAX */ i__4 = j; i__5 = j; z__1.r = w1[i__4].r - w3[i__5].r, z__1.i = w1[i__4].i - w3[ i__5].i; d__1 = temp2, d__2 = z_abs(&z__1); temp2 = max(d__1,d__2); /* L130: */ } /* Computing MAX */ d__1 = unfl, d__2 = ulp * max(temp1,temp2); result[8] = temp2 / max(d__1,d__2); /* Compute the Left and Right Eigenvectors of T */ /* Compute the Right eigenvector Matrix: */ ntest = 9; result[9] = ulpinv; /* Select every other eigenvector */ i__3 = n; for (j = 1; j <= i__3; ++j) { select[j] = FALSE_; /* L140: */ } i__3 = n; for (j = 1; j <= i__3; j += 2) { select[j] = TRUE_; /* L150: */ } ztrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda, cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[ 1], &rwork[1], &iinfo); if (iinfo != 0) { io___47.ciunit = *nounit; s_wsfe(&io___47); do_fio(&c__1, "ZTREVC(R,A)", (ftnlen)11); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } /* Test 9: | TR - RW | / ( |T| |R| ulp ) */ zget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[ evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma); result[9] = dumma[0]; if (dumma[1] > *thresh) { io___49.ciunit = *nounit; s_wsfe(&io___49); do_fio(&c__1, "Right", (ftnlen)5); do_fio(&c__1, "ZTREVC", (ftnlen)6); do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Compute selected right eigenvectors and confirm that */ /* they agree with previous right eigenvectors */ ztrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda, cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[ 1], &rwork[1], &iinfo); if (iinfo != 0) { io___50.ciunit = *nounit; s_wsfe(&io___50); do_fio(&c__1, "ZTREVC(R,S)", (ftnlen)11); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } k = 1; match = TRUE_; i__3 = n; for (j = 1; j <= i__3; ++j) { if (select[j]) { i__4 = n; for (jj = 1; jj <= i__4; ++jj) { i__5 = 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, "ZTREVC", (ftnlen)6); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Compute the Left eigenvector Matrix: */ ntest = 10; result[10] = ulpinv; ztrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, & evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1] , &rwork[1], &iinfo); if (iinfo != 0) { io___55.ciunit = *nounit; s_wsfe(&io___55); do_fio(&c__1, "ZTREVC(L,A)", (ftnlen)11); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } /* Test 10: | LT - WL | / ( |T| |L| ulp ) */ zget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[ evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[ 2]); result[10] = dumma[2]; if (dumma[3] > *thresh) { io___56.ciunit = *nounit; s_wsfe(&io___56); do_fio(&c__1, "Left", (ftnlen)4); do_fio(&c__1, "ZTREVC", (ftnlen)6); do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Compute selected left eigenvectors and confirm that */ /* they agree with previous left eigenvectors */ ztrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, & evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1] , &rwork[1], &iinfo); if (iinfo != 0) { io___57.ciunit = *nounit; s_wsfe(&io___57); do_fio(&c__1, "ZTREVC(L,S)", (ftnlen)11); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L240; } k = 1; match = TRUE_; i__3 = n; for (j = 1; j <= i__3; ++j) { if (select[j]) { i__4 = n; for (jj = 1; jj <= i__4; ++jj) { i__5 = 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, "ZTREVC", (ftnlen)6); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Call ZHSEIN for Right eigenvectors of H, do test 11 */ ntest = 11; result[11] = ulpinv; i__3 = n; for (j = 1; j <= i__3; ++j) { select[j] = TRUE_; /* L220: */ } zhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset], lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, & n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], & iinfo); if (iinfo != 0) { io___59.ciunit = *nounit; s_wsfe(&io___59); do_fio(&c__1, "ZHSEIN(R)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); if (iinfo < 0) { goto L240; } } else { /* Test 11: | HX - XW | / ( |H| |X| ulp ) */ /* (from inverse iteration) */ zget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[ evectx_offset], ldu, &w3[1], &work[1], &rwork[1], dumma); if (dumma[0] < ulpinv) { result[11] = dumma[0] * aninv; } if (dumma[1] > *thresh) { io___60.ciunit = *nounit; s_wsfe(&io___60); do_fio(&c__1, "Right", (ftnlen)5); do_fio(&c__1, "ZHSEIN", (ftnlen)6); do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof( doublereal)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); } } /* Call ZHSEIN for Left eigenvectors of H, do test 12 */ ntest = 12; result[12] = ulpinv; i__3 = n; for (j = 1; j <= i__3; ++j) { select[j] = TRUE_; /* L230: */ } zhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset], lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, & n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], & iinfo); if (iinfo != 0) { io___61.ciunit = *nounit; s_wsfe(&io___61); do_fio(&c__1, "ZHSEIN(L)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); if (iinfo < 0) { goto L240; } } else { /* Test 12: | YH - WY | / ( |H| |Y| ulp ) */ /* (from inverse iteration) */ zget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[ evecty_offset], ldu, &w3[1], &work[1], &rwork[1], & dumma[2]); if (dumma[2] < ulpinv) { result[12] = dumma[2] * aninv; } if (dumma[3] > *thresh) { io___62.ciunit = *nounit; s_wsfe(&io___62); do_fio(&c__1, "Left", (ftnlen)4); do_fio(&c__1, "ZHSEIN", (ftnlen)6); do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof( doublereal)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); } } /* Call ZUNMHR for Right eigenvectors of A, do test 13 */ ntest = 13; result[13] = ulpinv; zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset] , ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0) { io___63.ciunit = *nounit; s_wsfe(&io___63); do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); if (iinfo < 0) { goto L240; } } else { /* Test 13: | AX - XW | / ( |A| |X| ulp ) */ /* (from inverse iteration) */ zget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[ evectx_offset], ldu, &w3[1], &work[1], &rwork[1], dumma); if (dumma[0] < ulpinv) { result[13] = dumma[0] * aninv; } } /* Call ZUNMHR for Left eigenvectors of A, do test 14 */ ntest = 14; result[14] = ulpinv; zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset] , ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1], nwork, &iinfo); if (iinfo != 0) { io___64.ciunit = *nounit; s_wsfe(&io___64); do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); if (iinfo < 0) { goto L240; } } else { /* Test 14: | YA - WY | / ( |A| |Y| ulp ) */ /* (from inverse iteration) */ zget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[ evecty_offset], ldu, &w3[1], &work[1], &rwork[1], & dumma[2]); if (dumma[2] < ulpinv) { result[14] = dumma[2] * aninv; } } /* End of Loop -- Check for RESULT(j) > THRESH */ L240: ntestt += ntest; dlafts_("ZHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh, nounit, &nerrs); L250: ; } /* L260: */ } /* Summary */ dlasum_("ZHS", nounit, &nerrs, &ntestt); return 0; /* End of ZCHKHS */ } /* zchkhs_ */
/* Subroutine */ int zlaqr3_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublecomplex *h__, integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__, integer *ldz, integer *ns, integer *nd, doublecomplex *sh, doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t, integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv, doublecomplex *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; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ integer i__, j; doublecomplex s; integer jw; doublereal foo; integer kln; doublecomplex tau; integer knt; doublereal ulp; integer lwk1, lwk2, lwk3; doublecomplex beta; integer kcol, info, nmin, ifst, ilst, ltop, krow; extern /* Subroutine */ int zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); integer infqr; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); integer kwtop; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *), zlaqr4_(logical *, logical *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer * ); extern doublereal dlamch_(char *); doublereal safmin; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); doublereal safmax; extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *, logical *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); doublereal smlnum; extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *); integer lwkopt; extern /* Subroutine */ int zunmhr_(char *, char *, integer *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * ); /* -- LAPACK auxiliary routine (version 3.2.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ /* -- April 2009 -- */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ****************************************************************** */ /* Aggressive early deflation: */ /* This subroutine accepts as input an upper Hessenberg matrix */ /* H and performs an unitary 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 unitary 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 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 unitary matrix Z is updated so */ /* so that the unitary 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 unitary 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) COMPLEX*16 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 a unitary */ /* 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) COMPLEX*16 array, dimension (LDZ,N) */ /* IF WANTZ is .TRUE., then on output, the unitary */ /* 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. */ /* SH (output) COMPLEX*16 array, dimension KBOT */ /* On output, approximate eigenvalues that may */ /* be used for shifts are stored in SH(KBOT-ND-NS+1) */ /* through SR(KBOT-ND). Converged eigenvalues are */ /* stored in SH(KBOT-ND+1) through SH(KBOT). */ /* V (workspace) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 array, dimension (LDWV,NW) */ /* LDWV (input) integer */ /* The leading dimension of W just as declared in the */ /* calling subroutine. NW .LE. LDV */ /* WORK (workspace) COMPLEX*16 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; ZLAQR3 */ /* 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 .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. 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; --sh; 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 ZGEHRD ==== */ i__1 = jw - 1; zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info); lwk1 = (integer) work[1].r; /* ==== Workspace query call to ZUNMHR ==== */ i__1 = jw - 1; zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[1], &c_n1, &info); lwk2 = (integer) work[1].r; /* ==== Workspace query call to ZLAQR4 ==== */ zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[1], &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, &infqr); lwk3 = (integer) work[1].r; /* ==== Optimal workspace ==== */ /* Computing MAX */ i__1 = jw + max(lwk1,lwk2); lwkopt = max(i__1,lwk3); } /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { d__1 = (doublereal) lwkopt; z__1.r = d__1, z__1.i = 0.; work[1].r = z__1.r, work[1].i = z__1.i; return 0; } /* ==== Nothing to do ... */ /* ... for an empty active block ... ==== */ *ns = 0; *nd = 0; work[1].r = 1., work[1].i = 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.r = 0., s.i = 0.; } else { i__1 = kwtop + (kwtop - 1) * h_dim1; s.r = h__[i__1].r, s.i = h__[i__1].i; } if (*kbot == kwtop) { /* ==== 1-by-1 deflation window: not much to do ==== */ i__1 = kwtop; i__2 = kwtop + kwtop * h_dim1; sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i; *ns = 1; *nd = 0; /* Computing MAX */ i__1 = kwtop + kwtop * h_dim1; d__5 = smlnum, d__6 = ulp * ((d__1 = h__[i__1].r, abs(d__1)) + (d__2 = d_imag(&h__[kwtop + kwtop * h_dim1]), abs(d__2))); if ((d__3 = s.r, abs(d__3)) + (d__4 = d_imag(&s), abs(d__4)) <= max( d__5,d__6)) { *ns = 0; *nd = 1; if (kwtop > *ktop) { i__1 = kwtop + (kwtop - 1) * h_dim1; h__[i__1].r = 0., h__[i__1].i = 0.; } } work[1].r = 1., work[1].i = 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.) ==== */ zlacpy_("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; zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3); zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv); nmin = ilaenv_(&c__12, "ZLAQR3", "SV", &jw, &c__1, &jw, lwork); if (jw > nmin) { zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[ kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], lwork, & infqr); } else { zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[ kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); } /* ==== Deflation detection loop ==== */ *ns = jw; ilst = infqr + 1; i__1 = jw; for (knt = infqr + 1; knt <= i__1; ++knt) { /* ==== Small spike tip deflation test ==== */ i__2 = *ns + *ns * t_dim1; foo = (d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns * t_dim1]), abs(d__2)); if (foo == 0.) { foo = (d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2)); } i__2 = *ns * v_dim1 + 1; /* Computing MAX */ d__5 = smlnum, d__6 = ulp * foo; if (((d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2))) * (( d__3 = v[i__2].r, abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1 + 1]), abs(d__4))) <= max(d__5,d__6)) { /* ==== One more converged eigenvalue ==== */ --(*ns); } else { /* ==== One undeflatable eigenvalue. Move it up out of the */ /* . way. (ZTREXC can not fail in this case.) ==== */ ifst = *ns; ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, & ilst, &info); ++ilst; } /* L10: */ } /* ==== Return to Hessenberg form ==== */ if (*ns == 0) { s.r = 0., s.i = 0.; } if (*ns < jw) { /* ==== sorting the diagonal of T improves accuracy for */ /* . graded matrices. ==== */ i__1 = *ns; for (i__ = infqr + 1; i__ <= i__1; ++i__) { ifst = i__; i__2 = *ns; for (j = i__ + 1; j <= i__2; ++j) { i__3 = j + j * t_dim1; i__4 = ifst + ifst * t_dim1; if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[j + j * t_dim1]), abs(d__2)) > (d__3 = t[i__4].r, abs(d__3)) + (d__4 = d_imag(&t[ifst + ifst * t_dim1]), abs(d__4)) ) { ifst = j; } /* L20: */ } ilst = i__; if (ifst != ilst) { ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &info); } /* L30: */ } } /* ==== Restore shift/eigenvalue array from T ==== */ i__1 = jw; for (i__ = infqr + 1; i__ <= i__1; ++i__) { i__2 = kwtop + i__ - 1; i__3 = i__ + i__ * t_dim1; sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i; /* L40: */ } if (*ns < jw || s.r == 0. && s.i == 0.) { if (*ns > 1 && (s.r != 0. || s.i != 0.)) { /* ==== Reflect spike back into lower triangle ==== */ zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); i__1 = *ns; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; d_cnjg(&z__1, &work[i__]); work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L50: */ } beta.r = work[1].r, beta.i = work[1].i; zlarfg_(ns, &beta, &work[2], &c__1, &tau); work[1].r = 1., work[1].i = 0.; i__1 = jw - 2; i__2 = jw - 2; zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt); d_cnjg(&z__1, &tau); zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, & work[jw + 1]); zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]); i__1 = *lwork - jw; zgehrd_(&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) { i__1 = kwtop + (kwtop - 1) * h_dim1; d_cnjg(&z__2, &v[v_dim1 + 1]); z__1.r = s.r * z__2.r - s.i * z__2.i, z__1.i = s.r * z__2.i + s.i * z__2.r; h__[i__1].r = z__1.r, h__[i__1].i = z__1.i; } zlacpy_("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; zcopy_(&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. ==== */ if (*ns > 1 && (s.r != 0. || s.i != 0.)) { i__1 = *lwork - jw; zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[jw + 1], &i__1, &info); } /* ==== 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); zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset], ldwv); zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh); /* L60: */ } /* ==== 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); zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset], ldt); zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh); /* L70: */ } } /* ==== 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); zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset] , ldwv); zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz); /* L80: */ } } } /* ==== 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. ==== */ d__1 = (doublereal) lwkopt; z__1.r = d__1, z__1.i = 0.; work[1].r = z__1.r, work[1].i = z__1.i; /* ==== End of ZLAQR3 ==== */ return 0; } /* zlaqr3_ */