int main(void)
{
/* Local scalars */
char compq, compq_i;
lapack_int n, n_i;
lapack_int ldt, ldt_i;
lapack_int ldt_r;
lapack_int ldq, ldq_i;
lapack_int ldq_r;
lapack_int ifst, ifst_i;
lapack_int ilst, ilst_i;
lapack_int info, info_i;
lapack_int i;
int failed;
/* Local arrays */
lapack_complex_double *t = NULL, *t_i = NULL;
lapack_complex_double *q = NULL, *q_i = NULL;
lapack_complex_double *t_save = NULL;
lapack_complex_double *q_save = NULL;
lapack_complex_double *t_r = NULL;
lapack_complex_double *q_r = NULL;
/* Iniitialize the scalar parameters */
init_scalars_ztrexc( &compq, &n, &ldt, &ldq, &ifst, &ilst );
ldt_r = n+2;
ldq_r = n+2;
compq_i = compq;
n_i = n;
ldt_i = ldt;
ldq_i = ldq;
ifst_i = ifst;
ilst_i = ilst;
/* Allocate memory for the LAPACK routine arrays */
t = (lapack_complex_double *)
LAPACKE_malloc( ldt*n * sizeof(lapack_complex_double) );
q = (lapack_complex_double *)
LAPACKE_malloc( ldq*n * sizeof(lapack_complex_double) );
/* Allocate memory for the C interface function arrays */
t_i = (lapack_complex_double *)
LAPACKE_malloc( ldt*n * sizeof(lapack_complex_double) );
q_i = (lapack_complex_double *)
LAPACKE_malloc( ldq*n * sizeof(lapack_complex_double) );
/* Allocate memory for the backup arrays */
t_save = (lapack_complex_double *)
LAPACKE_malloc( ldt*n * sizeof(lapack_complex_double) );
q_save = (lapack_complex_double *)
LAPACKE_malloc( ldq*n * sizeof(lapack_complex_double) );
/* Allocate memory for the row-major arrays */
t_r = (lapack_complex_double *)
LAPACKE_malloc( n*(n+2) * sizeof(lapack_complex_double) );
q_r = (lapack_complex_double *)
LAPACKE_malloc( n*(n+2) * sizeof(lapack_complex_double) );
/* Initialize input arrays */
init_t( ldt*n, t );
init_q( ldq*n, q );
/* Backup the ouptut arrays */
for( i = 0; i < ldt*n; i++ ) {
t_save[i] = t[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_save[i] = q[i];
}
/* Call the LAPACK routine */
ztrexc_( &compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, &info );
/* Initialize input data, call the column-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < ldt*n; i++ ) {
t_i[i] = t_save[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_i[i] = q_save[i];
}
info_i = LAPACKE_ztrexc_work( LAPACK_COL_MAJOR, compq_i, n_i, t_i, ldt_i,
q_i, ldq_i, ifst_i, ilst_i );
failed = compare_ztrexc( t, t_i, q, q_i, info, info_i, compq, ldq, ldt, n );
if( failed == 0 ) {
printf( "PASSED: column-major middle-level interface to ztrexc\n" );
} else {
printf( "FAILED: column-major middle-level interface to ztrexc\n" );
}
/* Initialize input data, call the column-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < ldt*n; i++ ) {
t_i[i] = t_save[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_i[i] = q_save[i];
}
info_i = LAPACKE_ztrexc( LAPACK_COL_MAJOR, compq_i, n_i, t_i, ldt_i, q_i,
ldq_i, ifst_i, ilst_i );
failed = compare_ztrexc( t, t_i, q, q_i, info, info_i, compq, ldq, ldt, n );
if( failed == 0 ) {
printf( "PASSED: column-major high-level interface to ztrexc\n" );
} else {
printf( "FAILED: column-major high-level interface to ztrexc\n" );
}
/* Initialize input data, call the row-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < ldt*n; i++ ) {
t_i[i] = t_save[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_i[i] = q_save[i];
}
LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, t_i, ldt, t_r, n+2 );
if( LAPACKE_lsame( compq, 'v' ) ) {
LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, q_i, ldq, q_r, n+2 );
}
info_i = LAPACKE_ztrexc_work( LAPACK_ROW_MAJOR, compq_i, n_i, t_r, ldt_r,
q_r, ldq_r, ifst_i, ilst_i );
LAPACKE_zge_trans( LAPACK_ROW_MAJOR, n, n, t_r, n+2, t_i, ldt );
if( LAPACKE_lsame( compq, 'v' ) ) {
LAPACKE_zge_trans( LAPACK_ROW_MAJOR, n, n, q_r, n+2, q_i, ldq );
}
failed = compare_ztrexc( t, t_i, q, q_i, info, info_i, compq, ldq, ldt, n );
if( failed == 0 ) {
printf( "PASSED: row-major middle-level interface to ztrexc\n" );
} else {
printf( "FAILED: row-major middle-level interface to ztrexc\n" );
}
/* Initialize input data, call the row-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < ldt*n; i++ ) {
t_i[i] = t_save[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_i[i] = q_save[i];
}
/* Init row_major arrays */
LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, t_i, ldt, t_r, n+2 );
if( LAPACKE_lsame( compq, 'v' ) ) {
LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, q_i, ldq, q_r, n+2 );
}
info_i = LAPACKE_ztrexc( LAPACK_ROW_MAJOR, compq_i, n_i, t_r, ldt_r, q_r,
ldq_r, ifst_i, ilst_i );
LAPACKE_zge_trans( LAPACK_ROW_MAJOR, n, n, t_r, n+2, t_i, ldt );
if( LAPACKE_lsame( compq, 'v' ) ) {
LAPACKE_zge_trans( LAPACK_ROW_MAJOR, n, n, q_r, n+2, q_i, ldq );
}
failed = compare_ztrexc( t, t_i, q, q_i, info, info_i, compq, ldq, ldt, n );
if( failed == 0 ) {
printf( "PASSED: row-major high-level interface to ztrexc\n" );
} else {
printf( "FAILED: row-major high-level interface to ztrexc\n" );
}
/* Release memory */
if( t != NULL ) {
LAPACKE_free( t );
}
if( t_i != NULL ) {
LAPACKE_free( t_i );
}
if( t_r != NULL ) {
LAPACKE_free( t_r );
}
if( t_save != NULL ) {
LAPACKE_free( t_save );
}
if( q != NULL ) {
LAPACKE_free( q );
}
if( q_i != NULL ) {
LAPACKE_free( q_i );
}
if( q_r != NULL ) {
LAPACKE_free( q_r );
}
if( q_save != NULL ) {
LAPACKE_free( q_save );
}
return 0;
}
/* Subroutine */ int zget36_(doublereal *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static doublecomplex diag[10];
static integer ifst, ilst;
static doublecomplex work[200];
static integer info1, info2, i__, j, n;
static doublecomplex q[100] /* was [10][10] */, ctemp;
extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal rwork[10];
static doublecomplex t1[100] /* was [10][10] */, t2[100] /*
was [10][10] */;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
static doublereal result[2];
extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *);
static doublereal eps, res;
static doublecomplex tmp[100] /* was [10][10] */;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___7 = { 0, 0, 0, 0, 0 };
#define q_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define t1_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define t1_ref(a_1,a_2) t1[t1_subscr(a_1,a_2)]
#define t2_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define t2_ref(a_1,a_2) t2[t2_subscr(a_1,a_2)]
#define tmp_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define tmp_ref(a_1,a_2) tmp[tmp_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a
matrix in complex Schur form. Thus, ZLAEXC computes a unitary matrix
Q such that
Q' * T1 * Q = T2
and where one of the diagonal blocks of T1 (the one at row IFST) has
been moved to position ILST.
The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
is in Schur form, and that the final position of the IFST block is
ILST.
The test matrices are read from a file with logical unit number NIN.
Arguments
==========
RMAX (output) DOUBLE PRECISION
Value of the largest test ratio.
LMAX (output) INTEGER
Example number where largest test ratio achieved.
NINFO (output) INTEGER
Number of examples where INFO is nonzero.
KNT (output) INTEGER
Total number of examples tested.
NIN (input) INTEGER
Input logical unit number.
===================================================================== */
eps = dlamch_("P");
*rmax = 0.;
*lmax = 0;
*knt = 0;
*ninfo = 0;
/* Read input data until N=0 */
L10:
io___2.ciunit = *nin;
s_rsle(&io___2);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
++(*knt);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___7.ciunit = *nin;
s_rsle(&io___7);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&tmp_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
zlacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
zlacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
res = 0.;
/* Test without accumulating Q */
zlaset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
ztrexc_("N", &n, t1, &c__10, q, &c__10, &ifst, &ilst, &info1);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = q_subscr(i__, j);
if (i__ == j && (q[i__3].r != 1. || q[i__3].i != 0.)) {
res += 1. / eps;
}
i__3 = q_subscr(i__, j);
if (i__ != j && (q[i__3].r != 0. || q[i__3].i != 0.)) {
res += 1. / eps;
}
/* L30: */
}
/* L40: */
}
/* Test with accumulating Q */
zlaset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
ztrexc_("V", &n, t2, &c__10, q, &c__10, &ifst, &ilst, &info2);
/* Compare T1 with T2 */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = t1_subscr(i__, j);
i__4 = t2_subscr(i__, j);
if (t1[i__3].r != t2[i__4].r || t1[i__3].i != t2[i__4].i) {
res += 1. / eps;
}
/* L50: */
}
/* L60: */
}
if (info1 != 0 || info2 != 0) {
++(*ninfo);
}
if (info1 != info2) {
res += 1. / eps;
}
/* Test for successful reordering of T2 */
zcopy_(&n, tmp, &c__11, diag, &c__1);
if (ifst < ilst) {
i__1 = ilst;
for (i__ = ifst + 1; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
i__2 = i__ - 1;
i__3 = i__ - 2;
diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
i__2 = i__ - 2;
diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
/* L70: */
}
} else if (ifst > ilst) {
i__1 = ilst;
for (i__ = ifst - 1; i__ >= i__1; --i__) {
i__2 = i__;
ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
i__2 = i__;
i__3 = i__ - 1;
diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
i__2 = i__ - 1;
diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
/* L80: */
}
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = t2_subscr(i__, i__);
i__3 = i__ - 1;
if (t2[i__2].r != diag[i__3].r || t2[i__2].i != diag[i__3].i) {
res += 1. / eps;
}
/* L90: */
}
/* Test for small residual, and orthogonality of Q */
zhst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
rwork, result);
res = res + result[0] + result[1];
/* Test for T2 being in Schur form */
i__1 = n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = t2_subscr(i__, j);
if (t2[i__3].r != 0. || t2[i__3].i != 0.) {
res += 1. / eps;
}
/* L100: */
}
/* L110: */
}
if (res > *rmax) {
*rmax = res;
*lmax = *knt;
}
goto L10;
/* End of ZGET36 */
} /* zget36_ */
/* Subroutine */ int zerrec_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\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;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
doublecomplex a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[16]
/* was [4][4] */;
integer i__, j, m;
doublereal s[4];
doublecomplex x[4];
integer nt;
doublereal rw[24];
logical sel[4];
doublereal sep[4];
integer info, ifst, ilst;
doublecomplex work[24];
doublereal scale;
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *), ztrsna_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *, integer *,
integer *, doublecomplex *, integer *, doublereal *, integer *), ztrsen_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, integer *), ztrsyl_(
char *, char *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
/* Fortran I/O blocks */
static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___19 = { 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 */
/* ======= */
/* ZERREC tests the error exits for the routines for eigen- condition */
/* estimation for DOUBLE PRECISION matrices: */
/* ZTRSYL, CTREXC, CTRSNA and CTRSEN. */
/* 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 Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
infoc_1.ok = TRUE_;
nt = 0;
/* Initialize A, B and SEL */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (j << 2) - 5;
a[i__1].r = 0., a[i__1].i = 0.;
i__1 = i__ + (j << 2) - 5;
b[i__1].r = 0., b[i__1].i = 0.;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (i__ << 2) - 5;
a[i__1].r = 1., a[i__1].i = 0.;
sel[i__ - 1] = TRUE_;
/* L30: */
}
/* Test ZTRSYL */
s_copy(srnamc_1.srnamt, "ZTRSYL", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ztrsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ztrsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ztrsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
ztrsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test ZTREXC */
s_copy(srnamc_1.srnamt, "ZTREXC", (ftnlen)32, (ftnlen)6);
ifst = 1;
ilst = 1;
infoc_1.infot = 1;
ztrexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ztrexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ilst = 2;
ztrexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 0;
ilst = 1;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 2;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ifst = 1;
ilst = 0;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ilst = 2;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test ZTRSNA */
s_copy(srnamc_1.srnamt, "ZTRSNA", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ztrsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
ztrsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__0, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
ztrsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__2, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* Test ZTRSEN */
sel[0] = FALSE_;
s_copy(srnamc_1.srnamt, "ZTRSEN", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ztrsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__2, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, x, &m, s, sep, work, &
c__0, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
c__3, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Print a summary line. */
if (infoc_1.ok) {
io___18.ciunit = infoc_1.nout;
s_wsfe(&io___18);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of ZERREC */
} /* zerrec_ */
/* Subroutine */
int ztrsen_(char *job, char *compq, logical *select, integer *n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq, doublecomplex *w, integer *m, doublereal *s, doublereal *sep, doublecomplex *work, integer *lwork, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer k, n1, n2, nn, ks;
doublereal est;
integer kase, ierr;
doublereal scale;
extern logical lsame_(char *, char *);
integer isave[3], lwmin;
logical wantq, wants;
doublereal rnorm, rwork[1];
extern /* Subroutine */
int zlacn2_(integer *, doublecomplex *, doublecomplex *, doublereal *, integer *, integer *), xerbla_( char *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *);
logical wantbh;
extern /* Subroutine */
int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
logical wantsp;
extern /* Subroutine */
int ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *);
logical lquery;
extern /* Subroutine */
int ztrsyl_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters. */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--w;
--work;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
wantq = lsame_(compq, "V");
/* Set M to the number of selected eigenvalues. */
*m = 0;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
if (select[k])
{
++(*m);
}
/* L10: */
}
n1 = *m;
n2 = *n - *m;
nn = n1 * n2;
*info = 0;
lquery = *lwork == -1;
if (wantsp)
{
/* Computing MAX */
i__1 = 1;
i__2 = nn << 1; // , expr subst
lwmin = max(i__1,i__2);
}
else if (lsame_(job, "N"))
{
lwmin = 1;
}
else if (lsame_(job, "E"))
{
lwmin = max(1,nn);
}
if (! lsame_(job, "N") && ! wants && ! wantsp)
{
*info = -1;
}
else if (! lsame_(compq, "N") && ! wantq)
{
*info = -2;
}
else if (*n < 0)
{
*info = -4;
}
else if (*ldt < max(1,*n))
{
*info = -6;
}
else if (*ldq < 1 || wantq && *ldq < *n)
{
*info = -8;
}
else if (*lwork < lwmin && ! lquery)
{
*info = -14;
}
if (*info == 0)
{
work[1].r = (doublereal) lwmin;
work[1].i = 0.; // , expr subst
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZTRSEN", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*m == *n || *m == 0)
{
if (wants)
{
*s = 1.;
}
if (wantsp)
{
*sep = zlange_("1", n, n, &t[t_offset], ldt, rwork);
}
goto L40;
}
/* Collect the selected eigenvalues at the top left corner of T. */
ks = 0;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
if (select[k])
{
++ks;
/* Swap the K-th eigenvalue to position KS. */
if (k != ks)
{
ztrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &k, & ks, &ierr);
}
}
/* L20: */
}
if (wants)
{
/* Solve the Sylvester equation for R: */
/* T11*R - R*T22 = scale*T12 */
zlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
/* Estimate the reciprocal of the condition number of the cluster */
/* of eigenvalues. */
rnorm = zlange_("F", &n1, &n2, &work[1], &n1, rwork);
if (rnorm == 0.)
{
*s = 1.;
}
else
{
*s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
}
}
if (wantsp)
{
/* Estimate sep(T11,T22). */
est = 0.;
kase = 0;
L30:
zlacn2_(&nn, &work[nn + 1], &work[1], &est, &kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Solve T11*R - R*T22 = scale*X. */
ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & ierr);
}
else
{
/* Solve T11**H*R - R*T22**H = scale*X. */
ztrsyl_("C", "C", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & ierr);
}
goto L30;
}
*sep = scale / est;
}
L40: /* Copy reordered eigenvalues to W. */
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
i__2 = k;
i__3 = k + k * t_dim1;
w[i__2].r = t[i__3].r;
w[i__2].i = t[i__3].i; // , expr subst
/* L50: */
}
work[1].r = (doublereal) lwmin;
work[1].i = 0.; // , expr subst
return 0;
/* End of ZTRSEN */
}
/* Subroutine */ int ztrsen_(char *job, char *compq, logical *select, integer
*n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq,
doublecomplex *w, integer *m, doublereal *s, doublereal *sep,
doublecomplex *work, integer *lwork, integer *info, ftnlen job_len,
ftnlen compq_len)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer k, n1, n2, nn, ks;
static doublereal est;
static integer kase, ierr;
static doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static integer lwmin;
static logical wantq, wants;
static doublereal rnorm, rwork[1];
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *, ftnlen);
static logical wantbh;
extern /* Subroutine */ int zlacon_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, ftnlen);
static logical wantsp;
extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *, ftnlen);
static logical lquery;
extern /* Subroutine */ int ztrsyl_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, integer *, ftnlen,
ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTRSEN reorders the Schur factorization of a complex matrix */
/* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in */
/* the leading positions on the diagonal of the upper triangular matrix */
/* T, and the leading columns of Q form an orthonormal basis of the */
/* corresponding right invariant subspace. */
/* Optionally the routine computes the reciprocal condition numbers of */
/* the cluster of eigenvalues and/or the invariant subspace. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies whether condition numbers are required for the */
/* cluster of eigenvalues (S) or the invariant subspace (SEP): */
/* = 'N': none; */
/* = 'E': for eigenvalues only (S); */
/* = 'V': for invariant subspace only (SEP); */
/* = 'B': for both eigenvalues and invariant subspace (S and */
/* SEP). */
/* COMPQ (input) CHARACTER*1 */
/* = 'V': update the matrix Q of Schur vectors; */
/* = 'N': do not update Q. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* SELECT specifies the eigenvalues in the selected cluster. To */
/* select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) COMPLEX*16 array, dimension (LDT,N) */
/* On entry, the upper triangular matrix T. */
/* On exit, T is overwritten by the reordered matrix T, with the */
/* selected eigenvalues as the leading diagonal elements. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
/* unitary transformation matrix which reorders T; the leading M */
/* columns of Q form an orthonormal basis for the specified */
/* invariant subspace. */
/* If COMPQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */
/* W (output) COMPLEX*16 array, dimension (N) */
/* The reordered eigenvalues of T, in the same order as they */
/* appear on the diagonal of T. */
/* M (output) INTEGER */
/* The dimension of the specified invariant subspace. */
/* 0 <= M <= N. */
/* S (output) DOUBLE PRECISION */
/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
/* condition number for the selected cluster of eigenvalues. */
/* S cannot underestimate the true reciprocal condition number */
/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
/* If JOB = 'N' or 'V', S is not referenced. */
/* SEP (output) DOUBLE PRECISION */
/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */
/* condition number of the specified invariant subspace. If */
/* M = 0 or N, SEP = norm(T). */
/* If JOB = 'N' or 'E', SEP is not referenced. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* If JOB = 'N', WORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If JOB = 'N', LWORK >= 1; */
/* if JOB = 'E', LWORK = M*(N-M); */
/* if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* ZTRSEN first collects the selected eigenvalues by computing a unitary */
/* transformation Z to move them to the top left corner of T. In other */
/* words, the selected eigenvalues are the eigenvalues of T11 in: */
/* Z'*T*Z = ( T11 T12 ) n1 */
/* ( 0 T22 ) n2 */
/* n1 n2 */
/* where N = n1+n2 and Z' means the conjugate transpose of Z. The first */
/* n1 columns of Z span the specified invariant subspace of T. */
/* If T has been obtained from the Schur factorization of a matrix */
/* A = Q*T*Q', then the reordered Schur factorization of A is given by */
/* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the */
/* corresponding invariant subspace of A. */
/* The reciprocal condition number of the average of the eigenvalues of */
/* T11 may be returned in S. S lies between 0 (very badly conditioned) */
/* and 1 (very well conditioned). It is computed as follows. First we */
/* compute R so that */
/* P = ( I R ) n1 */
/* ( 0 0 ) n2 */
/* n1 n2 */
/* is the projector on the invariant subspace associated with T11. */
/* R is the solution of the Sylvester equation: */
/* T11*R - R*T22 = T12. */
/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
/* the two-norm of M. Then S is computed as the lower bound */
/* (1 + F-norm(R)**2)**(-1/2) */
/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */
/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */
/* sqrt(N). */
/* An approximate error bound for the computed average of the */
/* eigenvalues of T11 is */
/* EPS * norm(T) / S */
/* where EPS is the machine precision. */
/* The reciprocal condition number of the right invariant subspace */
/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
/* SEP is defined as the separation of T11 and T22: */
/* sep( T11, T22 ) = sigma-min( C ) */
/* where sigma-min(C) is the smallest singular value of the */
/* n1*n2-by-n1*n2 matrix */
/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */
/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
/* product. We estimate sigma-min(C) by the reciprocal of an estimate of */
/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
/* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */
/* When SEP is small, small changes in T can cause large changes in */
/* the invariant subspace. An approximate bound on the maximum angular */
/* error in the computed right invariant subspace is */
/* EPS * norm(T) / SEP */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters. */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--w;
--work;
/* Function Body */
wantbh = lsame_(job, "B", (ftnlen)1, (ftnlen)1);
wants = lsame_(job, "E", (ftnlen)1, (ftnlen)1) || wantbh;
wantsp = lsame_(job, "V", (ftnlen)1, (ftnlen)1) || wantbh;
wantq = lsame_(compq, "V", (ftnlen)1, (ftnlen)1);
/* Set M to the number of selected eigenvalues. */
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++(*m);
}
/* L10: */
}
n1 = *m;
n2 = *n - *m;
nn = n1 * n2;
*info = 0;
lquery = *lwork == -1;
if (wantsp) {
/* Computing MAX */
i__1 = 1, i__2 = nn << 1;
lwmin = max(i__1,i__2);
} else if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
lwmin = 1;
} else if (lsame_(job, "E", (ftnlen)1, (ftnlen)1)) {
lwmin = max(1,nn);
}
if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(compq, "N", (ftnlen)1, (ftnlen)1) && ! wantq) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -8;
} else if (*lwork < lwmin && ! lquery) {
*info = -14;
}
if (*info == 0) {
work[1].r = (doublereal) lwmin, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTRSEN", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == *n || *m == 0) {
if (wants) {
*s = 1.;
}
if (wantsp) {
*sep = zlange_("1", n, n, &t[t_offset], ldt, rwork, (ftnlen)1);
}
goto L40;
}
/* Collect the selected eigenvalues at the top left corner of T. */
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++ks;
/* Swap the K-th eigenvalue to position KS. */
if (k != ks) {
ztrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &k, &
ks, &ierr, (ftnlen)1);
}
}
/* L20: */
}
if (wants) {
/* Solve the Sylvester equation for R: */
/* T11*R - R*T22 = scale*T12 */
zlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1,
(ftnlen)1);
ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr, (ftnlen)1,
(ftnlen)1);
/* Estimate the reciprocal of the condition number of the cluster */
/* of eigenvalues. */
rnorm = zlange_("F", &n1, &n2, &work[1], &n1, rwork, (ftnlen)1);
if (rnorm == 0.) {
*s = 1.;
} else {
*s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
}
}
if (wantsp) {
/* Estimate sep(T11,T22). */
est = 0.;
kase = 0;
L30:
zlacon_(&nn, &work[nn + 1], &work[1], &est, &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve T11*R - R*T22 = scale*X. */
ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr, (ftnlen)1, (ftnlen)1);
} else {
/* Solve T11'*R - R*T22' = scale*X. */
ztrsyl_("C", "C", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr, (ftnlen)1, (ftnlen)1);
}
goto L30;
}
*sep = scale / est;
}
L40:
/* Copy reordered eigenvalues to W. */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = k + k * t_dim1;
w[i__2].r = t[i__3].r, w[i__2].i = t[i__3].i;
/* L50: */
}
work[1].r = (doublereal) lwmin, work[1].i = 0.;
return 0;
/* End of ZTRSEN */
} /* ztrsen_ */
/* Subroutine */
int ztrsna_(char *job, char *howmny, logical *select, integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s, doublereal *sep, integer *mm, integer *m, doublecomplex *work, integer *ldwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k, ks, ix;
doublereal eps, est;
integer kase, ierr;
doublecomplex prod;
doublereal lnrm, rnrm, scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
doublecomplex dummy[1];
logical wants;
doublereal xnorm;
extern /* Subroutine */
int zlacn2_(integer *, doublecomplex *, doublecomplex *, doublereal *, integer *, integer *), dlabad_( doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_( char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal bignum;
logical wantbh;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical somcon;
extern /* Subroutine */
int zdrscl_(integer *, doublereal *, doublecomplex *, integer *);
char normin[1];
extern /* Subroutine */
int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
doublereal smlnum;
logical wantsp;
extern /* Subroutine */
int zlatrs_(char *, char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--s;
--sep;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
/* Set M to the number of eigenpairs for which condition numbers are */
/* to be computed. */
if (somcon)
{
*m = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (select[j])
{
++(*m);
}
/* L10: */
}
}
else
{
*m = *n;
}
*info = 0;
if (! wants && ! wantsp)
{
*info = -1;
}
else if (! lsame_(howmny, "A") && ! somcon)
{
*info = -2;
}
else if (*n < 0)
{
*info = -4;
}
else if (*ldt < max(1,*n))
{
*info = -6;
}
else if (*ldvl < 1 || wants && *ldvl < *n)
{
*info = -8;
}
else if (*ldvr < 1 || wants && *ldvr < *n)
{
*info = -10;
}
else if (*mm < *m)
{
*info = -13;
}
else if (*ldwork < 1 || wantsp && *ldwork < *n)
{
*info = -16;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZTRSNA", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
if (somcon)
{
if (! select[1])
{
return 0;
}
}
if (wants)
{
s[1] = 1.;
}
if (wantsp)
{
sep[1] = z_abs(&t[t_dim1 + 1]);
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
ks = 1;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
if (somcon)
{
if (! select[k])
{
goto L50;
}
}
if (wants)
{
/* Compute the reciprocal condition number of the k-th */
/* eigenvalue. */
zdotc_f2c_(&z__1, n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
prod.r = z__1.r;
prod.i = z__1.i; // , expr subst
rnrm = dznrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
lnrm = dznrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
s[ks] = z_abs(&prod) / (rnrm * lnrm);
}
if (wantsp)
{
/* Estimate the reciprocal condition number of the k-th */
/* eigenvector. */
/* Copy the matrix T to the array WORK and swap the k-th */
/* diagonal element to the (1,1) position. */
zlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], ldwork);
ztrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, & c__1, &ierr);
/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
i__2 = *n;
for (i__ = 2;
i__ <= i__2;
++i__)
{
i__3 = i__ + i__ * work_dim1;
i__4 = i__ + i__ * work_dim1;
i__5 = work_dim1 + 1;
z__1.r = work[i__4].r - work[i__5].r;
z__1.i = work[i__4].i - work[i__5].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
/* L20: */
}
/* Estimate a lower bound for the 1-norm of inv(C**H). The 1st */
/* and (N+1)th columns of WORK are used to store work vectors. */
sep[ks] = 0.;
est = 0.;
kase = 0;
*(unsigned char *)normin = 'N';
L30:
i__2 = *n - 1;
zlacn2_(&i__2, &work[(*n + 1) * work_dim1 + 1], &work[work_offset] , &est, &kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Solve C**H*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin, &i__2, &work[(work_dim1 << 1) + 2], ldwork, & work[work_offset], &scale, &rwork[1], &ierr);
}
else
{
/* Solve C*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2, &work[(work_dim1 << 1) + 2], ldwork, &work[ work_offset], &scale, &rwork[1], &ierr);
}
*(unsigned char *)normin = 'Y';
if (scale != 1.)
{
/* Multiply by 1/SCALE if doing so will not cause */
/* overflow. */
i__2 = *n - 1;
ix = izamax_(&i__2, &work[work_offset], &c__1);
i__2 = ix + work_dim1;
xnorm = (d__1 = work[i__2].r, f2c_abs(d__1)) + (d__2 = d_imag( &work[ix + work_dim1]), f2c_abs(d__2));
if (scale < xnorm * smlnum || scale == 0.)
{
goto L40;
}
zdrscl_(n, &scale, &work[work_offset], &c__1);
}
goto L30;
}
sep[ks] = 1. / max(est,smlnum);
}
L40:
++ks;
L50:
;
}
return 0;
/* End of ZTRSNA */
}
/* 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 ztrsna_(char *job, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s,
doublereal *sep, integer *mm, integer *m, doublecomplex *work,
integer *ldwork, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZTRSNA estimates reciprocal condition numbers for specified
eigenvalues and/or right eigenvectors of a complex upper triangular
matrix T (or of any matrix Q*T*Q**H with Q unitary).
Arguments
=========
JOB (input) CHARACTER*1
Specifies whether condition numbers are required for
eigenvalues (S) or eigenvectors (SEP):
= 'E': for eigenvalues only (S);
= 'V': for eigenvectors only (SEP);
= 'B': for both eigenvalues and eigenvectors (S and SEP).
HOWMNY (input) CHARACTER*1
= 'A': compute condition numbers for all eigenpairs;
= 'S': compute condition numbers for selected eigenpairs
specified by the array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenpairs for which
condition numbers are required. To select condition numbers
for the j-th eigenpair, SELECT(j) must be set to .TRUE..
If HOWMNY = 'A', SELECT is not referenced.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input) COMPLEX*16 array, dimension (LDT,N)
The upper triangular matrix T.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input) COMPLEX*16 array, dimension (LDVL,M)
If JOB = 'E' or 'B', VL must contain left eigenvectors of T
(or of any Q*T*Q**H with Q unitary), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VL, as returned by
ZHSEIN or ZTREVC.
If JOB = 'V', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL.
LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
VR (input) COMPLEX*16 array, dimension (LDVR,M)
If JOB = 'E' or 'B', VR must contain right eigenvectors of T
(or of any Q*T*Q**H with Q unitary), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VR, as returned by
ZHSEIN or ZTREVC.
If JOB = 'V', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
S (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'E' or 'B', the reciprocal condition numbers of the
selected eigenvalues, stored in consecutive elements of the
array. Thus S(j), SEP(j), and the j-th columns of VL and VR
all correspond to the same eigenpair (but not in general the
j-th eigenpair, unless all eigenpairs are selected).
If JOB = 'V', S is not referenced.
SEP (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'V' or 'B', the estimated reciprocal condition
numbers of the selected eigenvectors, stored in consecutive
elements of the array.
If JOB = 'E', SEP is not referenced.
MM (input) INTEGER
The number of elements in the arrays S (if JOB = 'E' or 'B')
and/or SEP (if JOB = 'V' or 'B'). MM >= M.
M (output) INTEGER
The number of elements of the arrays S and/or SEP actually
used to store the estimated condition numbers.
If HOWMNY = 'A', M is set to N.
WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N+1)
If JOB = 'E', WORK is not referenced.
LDWORK (input) INTEGER
The leading dimension of the array WORK.
LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
If JOB = 'E', RWORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The reciprocal of the condition number of an eigenvalue lambda is
defined as
S(lambda) = |v'*u| / (norm(u)*norm(v))
where u and v are the right and left eigenvectors of T corresponding
to lambda; v' denotes the conjugate transpose of v, and norm(u)
denotes the Euclidean norm. These reciprocal condition numbers always
lie between zero (very badly conditioned) and one (very well
conditioned). If n = 1, S(lambda) is defined to be 1.
An approximate error bound for a computed eigenvalue W(i) is given by
EPS * norm(T) / S(i)
where EPS is the machine precision.
The reciprocal of the condition number of the right eigenvector u
corresponding to lambda is defined as follows. Suppose
T = ( lambda c )
( 0 T22 )
Then the reciprocal condition number is
SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
where sigma-min denotes the smallest singular value. We approximate
the smallest singular value by the reciprocal of an estimate of the
one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
defined to be abs(T(1,1)).
An approximate error bound for a computed right eigenvector VR(i)
is given by
EPS * norm(T) / SEP(i)
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
static integer kase, ierr;
static doublecomplex prod;
static doublereal lnrm, rnrm;
static integer i__, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublecomplex dummy[1];
static logical wants;
static doublereal xnorm;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
static integer ks, ix;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
static logical wantbh;
extern /* Subroutine */ int zlacon_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical somcon;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal smlnum;
static logical wantsp;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, integer *);
static doublereal eps, est;
#define work_subscr(a_1,a_2) (a_2)*work_dim1 + a_1
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1
#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--s;
--sep;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
--rwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
/* Set M to the number of eigenpairs for which condition numbers are
to be computed. */
if (somcon) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || wants && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wants && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -13;
} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTRSNA", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (somcon) {
if (! select[1]) {
return 0;
}
}
if (wants) {
s[1] = 1.;
}
if (wantsp) {
sep[1] = z_abs(&t_ref(1, 1));
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
ks = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (somcon) {
if (! select[k]) {
goto L50;
}
}
if (wants) {
/* Compute the reciprocal condition number of the k-th
eigenvalue. */
zdotc_(&z__1, n, &vr_ref(1, ks), &c__1, &vl_ref(1, ks), &c__1);
prod.r = z__1.r, prod.i = z__1.i;
rnrm = dznrm2_(n, &vr_ref(1, ks), &c__1);
lnrm = dznrm2_(n, &vl_ref(1, ks), &c__1);
s[ks] = z_abs(&prod) / (rnrm * lnrm);
}
if (wantsp) {
/* Estimate the reciprocal condition number of the k-th
eigenvector.
Copy the matrix T to the array WORK and swap the k-th
diagonal element to the (1,1) position. */
zlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
ldwork);
ztrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, &
c__1, &ierr);
/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = work_subscr(i__, i__);
i__4 = work_subscr(i__, i__);
i__5 = work_subscr(1, 1);
z__1.r = work[i__4].r - work[i__5].r, z__1.i = work[i__4].i -
work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L20: */
}
/* Estimate a lower bound for the 1-norm of inv(C'). The 1st
and (N+1)th columns of WORK are used to store work vectors. */
sep[ks] = 0.;
est = 0.;
kase = 0;
*(unsigned char *)normin = 'N';
L30:
i__2 = *n - 1;
zlacon_(&i__2, &work_ref(1, *n + 1), &work[work_offset], &est, &
kase);
if (kase != 0) {
if (kase == 1) {
/* Solve C'*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
&i__2, &work_ref(2, 2), ldwork, &work[
work_offset], &scale, &rwork[1], &ierr);
} else {
/* Solve C*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
&work_ref(2, 2), ldwork, &work[work_offset], &
scale, &rwork[1], &ierr);
}
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
/* Multiply by 1/SCALE if doing so will not cause
overflow. */
i__2 = *n - 1;
ix = izamax_(&i__2, &work[work_offset], &c__1);
i__2 = work_subscr(ix, 1);
xnorm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(
&work_ref(ix, 1)), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L40;
}
zdrscl_(n, &scale, &work[work_offset], &c__1);
}
goto L30;
}
sep[ks] = 1. / max(est,smlnum);
}
L40:
++ks;
L50:
;
}
return 0;
/* End of ZTRSNA */
} /* ztrsna_ */
/* 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_ */
/* Subroutine */ int zerrec_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\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;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info, ifst, ilst;
static doublecomplex work[24], a[16] /* was [4][4] */, b[16] /*
was [4][4] */, c__[16] /* was [4][4] */;
static integer i__, j, m;
static doublereal s[4], scale;
static doublecomplex x[4];
static integer nt;
static doublereal rw[24];
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *), ztrsna_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *, integer *,
integer *, doublecomplex *, integer *, doublereal *, integer *), ztrsen_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, integer *), ztrsyl_(
char *, char *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
static logical sel[4];
static doublereal sep[4];
/* Fortran I/O blocks */
static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
#define a_subscr(a_1,a_2) (a_2)*4 + a_1 - 5
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*4 + a_1 - 5
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZERREC tests the error exits for the routines for eigen- condition
estimation for DOUBLE PRECISION matrices:
ZTRSYL, CTREXC, CTRSNA and CTRSEN.
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
infoc_1.nout = *nunit;
infoc_1.ok = TRUE_;
nt = 0;
/* Initialize A, B and SEL */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = a_subscr(i__, j);
a[i__1].r = 0., a[i__1].i = 0.;
i__1 = b_subscr(i__, j);
b[i__1].r = 0., b[i__1].i = 0.;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = a_subscr(i__, i__);
a[i__1].r = 1., a[i__1].i = 0.;
sel[i__ - 1] = TRUE_;
/* L30: */
}
/* Test ZTRSYL */
s_copy(srnamc_1.srnamt, "ZTRSYL", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
ztrsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ztrsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ztrsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
ztrsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test ZTREXC */
s_copy(srnamc_1.srnamt, "ZTREXC", (ftnlen)6, (ftnlen)6);
ifst = 1;
ilst = 1;
infoc_1.infot = 1;
ztrexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ztrexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ilst = 2;
ztrexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 0;
ilst = 1;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 2;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ifst = 1;
ilst = 0;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ilst = 2;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test ZTRSNA */
s_copy(srnamc_1.srnamt, "ZTRSNA", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
ztrsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
ztrsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__0, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
ztrsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__2, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* Test ZTRSEN */
sel[0] = FALSE_;
s_copy(srnamc_1.srnamt, "ZTRSEN", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
ztrsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__2, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, x, &m, s, sep, work, &
c__0, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
c__3, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Print a summary line. */
if (infoc_1.ok) {
io___18.ciunit = infoc_1.nout;
s_wsfe(&io___18);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of ZERREC */
} /* zerrec_ */